diff --git a/clos/3.5/CLOS-BROWSER.TEDIT b/clos/3.5/CLOS-BROWSER.TEDIT
new file mode 100644
index 00000000..21d02b63
Binary files /dev/null and b/clos/3.5/CLOS-BROWSER.TEDIT differ
diff --git a/clos/3.5/NEW-CLOS-BROWSER b/clos/3.5/NEW-CLOS-BROWSER
new file mode 100644
index 00000000..c9b89d75
--- /dev/null
+++ b/clos/3.5/NEW-CLOS-BROWSER
@@ -0,0 +1,4 @@
+(DEFINE-FILE-INFO PACKAGE (LET ((*PACKAGE*)) (CLIN-PACKAGE "CLOS-BROWSER") (CLUSE-PACKAGE "CLOS") (
CLFIND-PACKAGE "USER")) READTABLE "XCL" BASE 10)
(IL:FILECREATED " 4-Dec-2020 21:30:58" 
IL:|{DSK}<Users>arunwelch>SKYDRIVE>DOCUMENTS>UNIX>LISP>CLOS>CURRENT>NEW-CLOS-BROWSER.;2| 97081  

      IL:|changes| IL:|to:|  (CLOS::CLASSES CLOS-BROWSER:CLOS-ICON CLOS-BROWSER:CLOS-BROWSER 
                                    CLOS-BROWSER::CLOS-BROWSER-NODE)
                             (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))
                                    (CLOS-BROWSER::SUBCLASSES-OF NIL)
                                    (CLOS-BROWSER::CONTAINS-P (T CLOS-BROWSER:CLOS-BROWSER))
                                    (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))
                                    (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)
                                           )
                                    (CLOS::COMPUTE-INHERITED-METHODS (STANDARD-CLASS))
                                    (CLOS-BROWSER::SPECIALIZE (STANDARD-CLASS))
                                    (CLOS-BROWSER::SUBCLASSES-OF (STANDARD-CLASS))
                                    (CLOS-BROWSER::DELETE-METHOD (STANDARD-METHOD))
                                    (CLOS-BROWSER::COPY (STANDARD-METHOD STANDARD-CLASS))
                                    (WEB:MOVE (STANDARD-METHOD STANDARD-CLASS))
                                    (CLOS-BROWSER::PRINT-DEFINITION (STANDARD-METHOD)))
                             (IL:VARS IL:NEW-CLOS-BROWSERCOMS)
                             (IL:PROPS (IL:NEW-CLOS-BROWSER IL:MAKEFILE-ENVIRONMENT))
                             (IL:VARIABLES CLOS-BROWSER:CLOS-ICON)
                             (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-BROWSER::EDIT 
                                    CLOS-BROWSER::MAKE-METHOD-MENU-ITEMS 
                                    CLOS-BROWSER::MAKE-TOP-LEVEL-METHOD-MENU-ITEMS 
                                    CLOS-BROWSER::MAKE-MULTI-METHOD-SUB-MENU 
                                    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:|previous| IL:|date:| " 4-Dec-91 12:16:19" 
IL:|{DSK}<Users>arunwelch>SKYDRIVE>DOCUMENTS>UNIX>LISP>CLOS>BROWSER>NEW-CLOS-BROWSER.;22|)


; Copyright (c) 1991, 2020 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))
                  (WEB: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" 'WEB: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" 'WEB: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 WEB: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 WEB: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 WEB: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 2020))
(IL:DECLARE\: IL:DONTCOPY
  (IL:FILEMAP (NIL (16677 18363 (CLOS-BROWSER:BROWSE-CLASS 16677 . 18363)) (18365 19789 (
CLOS-BROWSER::COLLECT-FAMILY 18365 . 19789)) (19791 21823 (CLOS-BROWSER::MAKE-NODES 19791 . 21823)) (
21825 22500 (CLOS-BROWSER::CLOS-BROWSER-CLOSE-FN 21825 . 22500)) (22502 23434 (CLOS-BROWSER::BROWSER-CONTAINS-P
 22502 . 23434)) (47781 48105 (CLOS-BROWSER::EDIT 47781 . 48105)) (48107 53594 (
CLOS-BROWSER::MAKE-METHOD-MENU-ITEMS 48107 . 53594)) (53596 54758 (CLOS-BROWSER::MAKE-TOP-LEVEL-METHOD-MENU-ITEMS
 53596 . 54758)) (54760 56050 (CLOS-BROWSER::MAKE-MULTI-METHOD-SUB-MENU 54760 . 56050)) (70312 70931 (
CLOS-BROWSER::COMPLETE-ADD-METHOD 70312 . 70931)) (70933 73143 (CLOS-BROWSER::COMPLETE-SPECIALIZE 
70933 . 73143)) (73145 74811 (CLOS-BROWSER::LYRIC-COMPLETE-SPECIALIZE 73145 . 74811)) (74813 74978 (
CLOS-BROWSER::THIS-CLASS-NODE-P 74813 . 74978)) (74980 75082 (CLOS::CLASS-DIRECT-METHODS 74980 . 75082
)) (91908 92935 (CLOS-BROWSER::REPLACE-SPECIALIZERS 91908 . 92935)) (93246 94827 (CLOS-BROWSER::IN-SELECT-PACKAGE
 93246 . 94827)) (94829 95976 (CLOS-BROWSER::CLASSES-IN-PACKAGE 94829 . 95976)))))
IL:STOP
\ No newline at end of file
diff --git a/clos/3.5/NEW-CLOS-BROWSER.DFASL b/clos/3.5/NEW-CLOS-BROWSER.DFASL
new file mode 100644
index 00000000..d98b090e
Binary files /dev/null and b/clos/3.5/NEW-CLOS-BROWSER.DFASL differ
diff --git a/clos/3.5/README.MD b/clos/3.5/README.MD
new file mode 100644
index 00000000..308045dc
--- /dev/null
+++ b/clos/3.5/README.MD
@@ -0,0 +1,3 @@
+This is based on the '91 PCL. In order to load this into Medley 3.5, load t
+the file DEFSYS.DFASL, and then execute (CLOS::LOAD-CLOS).  After this all
+the CLOS functionality is in the package CLOS. 
diff --git a/clos/3.5/WEB-EDITOR b/clos/3.5/WEB-EDITOR
new file mode 100644
index 00000000..6d039ac6
--- /dev/null
+++ b/clos/3.5/WEB-EDITOR
@@ -0,0 +1,416 @@
+(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 " 4-Dec-2020 21:30:35" 
IL:|{DSK}<Users>arunwelch>SKYDRIVE>DOCUMENTS>UNIX>LISP>CLOS>CURRENT>WEB-EDITOR.;2| 129800 

      IL:|changes| IL:|to:|  (FNS TREE-ROOTS)

      IL:|previous| IL:|date:| "17-May-93 11:16:38" 
IL:|{DSK}<Users>arunwelch>SKYDRIVE>DOCUMENTS>UNIX>LISP>CLOS>BROWSER>cltl2>WEB-EDITOR.;10|)


; Copyright (c) 1987, 1988, 1989, 1991, 1993, 2020 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 WEB-WINDOW-EXPAND-FN 
                                WEB-WINDOW-RESHAPE-FN WEB-WINDOW-BUTTON-EVENT-FN 
                                WEB-WINDOW-AFTER-MOVE-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 WEB-WINDOW-EXPAND-FN 
                               WEB-WINDOW-RESHAPE-FN WEB-WINDOW-BUTTON-EVENT-FN 
                               WEB-WINDOW-AFTER-MOVE-FN)
)
(IL:PUTPROPS IL:WEB-EDITOR IL:COPYRIGHT ("Xerox Corporation" 1987 1988 1989 1991 1993 2020))
(IL:DECLARE\: IL:DONTCOPY
  (IL:FILEMAP (NIL (24230 24343 (MAKE-WEB-EDITOR 24230 . 24343)) (47205 50047 (WEB-WINDOW-AFTER-MOVE-FN 
47218 . 47596) (WEB-WINDOW-BUTTON-EVENT-FN 47598 . 48041) (WEB-WINDOW-RESHAPE-FN 48043 . 48599) (
WEB-WINDOW-CLOSE-FN 48601 . 48951) (IL:|PromptRead| 48953 . 50045)) (50048 50481 (WEB-WINDOW-EXPAND-FN
 50061 . 50479)) (50483 51064 (WEB-WINDOW-ICON-FN 50483 . 51064)) (54383 61996 (TREE-ROOTS 54396 . 
59847) (CHILD-NODES 59849 . 60610) (REACHABLE-NODES! 60612 . 61994)) (91791 105199 (BOX-PRINT-STRING 
91804 . 98266) (BREAK-STRING-FOR-BOXING 98268 . 104064) (BOX-WINDOW-NODE 104066 . 105197)) (105237 
108279 (FIND-SELECTED-NODE 105250 . 108277)) (116826 117997 (WEB-MENU-WHENSELECTEDFN 116839 . 117469) 
(WINDOW-WHEN-HELD-FN 117471 . 117995)) (117998 123002 (SUB-ITEM-SELECTION 118011 . 119111) (
DUAL-SUB-ITEMS 119113 . 120122) (WINDOW-WHEN-HELD-FN 120124 . 120648) (DO-MENU-METHOD 120650 . 120990)
 (DUAL-MENU 120992 . 121687) (DUAL-SELECTION 121689 . 123000)))))
IL:STOP
\ No newline at end of file
diff --git a/clos/3.5/WEB-EDITOR.DFASL b/clos/3.5/WEB-EDITOR.DFASL
new file mode 100644
index 00000000..70a59b60
Binary files /dev/null and b/clos/3.5/WEB-EDITOR.DFASL differ
diff --git a/clos/3.5/boot.dfasl b/clos/3.5/boot.dfasl
new file mode 100644
index 00000000..5d47fd44
Binary files /dev/null and b/clos/3.5/boot.dfasl differ
diff --git a/clos/3.5/boot.lisp b/clos/3.5/boot.lisp
new file mode 100644
index 00000000..5385f6ff
--- /dev/null
+++ b/clos/3.5/boot.lisp
@@ -0,0 +1,1297 @@
+;;;-*- Package: CLOS; Syntax: Common-Lisp; Base: 10 -*-
+
+
+;;; File converted on  2-Apr-91 16:40:32 from source bood
+
+
+
+(in-package "CLOS")
+
+;;; Shadow, Export, Require, Use-package, and Import forms should follow here
+
+
+
+;;; ************************************************************************* Copyright (c) 1985,
+;;; 1986, 1987, 1988, 1989, 1990 Xerox Corporation. All rights reserved. Use and copying of this
+;;; software and preparation of derivative works based upon this software are permitted.  Any
+;;; distribution of this software or derivative works must comply with all applicable United States
+;;; export control laws. This software is made available AS IS, and Xerox Corporation makes no
+;;; warranty about the software, its performance or its conformity to any specification. Any person
+;;; obtaining a copy of this software is requested to send their name and post office or electronic
+;;; mail address to: CommonLoops Coordinator Xerox PARC 3333 Coyote Hill Rd. Palo Alto, CA 94304 (or
+;;; send Arpanet mail to CommonLoops-Coordinator.pa@Xerox.arpa) Suggestions, comments and requests
+;;; for improvements are also welcome.
+;;; ************************************************************************* 
+
+
+#|
+
+The CommonLoops evaluator is meta-circular.  
+
+Most of the code in CLOS is methods on generic functions, including most of
+the code that actually implements generic functions and method lookup.
+
+So, we have a classic bootstrapping problem.   The solution to this is to
+first get a cheap implementation of generic functions running, these are
+called early generic functions.  These early generic functions and the
+corresponding early methods and early method lookup are used to get enough
+of the system running that it is possible to create real generic functions
+and methods and implement real method lookup.  At that point (done in the
+file FIXUP) the function fix-early-generic-functions is called to convert
+all the early generic functions to real generic functions.
+
+The cheap generic functions are built using the same funcallable-instance
+objects real generic-functions are made out of.  This means that as CLOS
+is being bootstrapped, the cheap generic function objects which are being
+created are the same objects which will later be real generic functions.
+This is good because:
+  - we don't cons garbage structure
+  - we can keep pointers to the cheap generic function objects
+    during booting because those pointers will still point to
+    the right object after the generic functions are all fixed
+    up
+
+
+
+This file defines the defmethod macro and the mechanism used to expand it.
+This includes the mechanism for processing the body of a method.  defmethod
+basically expands into a call to load-defmethod, which basically calls
+add-method to add the method to the generic-function.  These expansions can
+be loaded either during bootstrapping or when CLOS is fully up and running.
+
+An important effect of this structure is it means we can compile files with
+defmethod forms in them in a completely running CLOS, but then load those files
+back in during bootstrapping.  This makes development easier.  It also means
+there is only one set of code for processing defmethod.  Bootstrapping works
+by being sure to have load-method be careful to call only primitives which
+work during bootstrapping.
+
+|#
+
+(proclaim '(notinline make-a-method add-named-method ensure-generic-function-using-class add-method 
+                  remove-method))
+
+(defvar *early-functions* '((make-a-method early-make-a-method real-make-a-method)
+                            (add-named-method early-add-named-method real-add-named-method)))
+
+
+;;; For each of the early functions, arrange to have it point to its early definition.  Do this in a
+;;; way that makes sure that if we redefine one of the early definitions the redefinition will take
+;;; effect.  This makes development easier. The function which generates the redirection closure is
+;;; pulled out into a separate piece of code because of a bug in ExCL which causes this not to work
+;;; if it is inlined. 
+
+
+(eval-when (load eval)
+       (defun redirect-early-function-internal (to)
+              #'(lambda (&rest args)
+                       (apply (symbol-function to)
+                              args))) 
+	 (dolist (fns *early-functions*)
+    (let ((name (car fns))
+	  (early-name (cadr fns)))
+      (setf (symbol-function name)
+	    (redirect-early-function-internal early-name))))
+)
+
+
+;;; *generic-function-fixups* is used by fix-early-generic-functions to convert the few functions in
+;;; the bootstrap which are supposed to be generic functions but can't be early on. 
+
+
+(defvar *generic-function-fixups* '((add-method ((generic-function method)
+                                                             ; lambda-list
+                                                 (standard-generic-function method)
+                                                             ; specializers
+                                                 real-add-method))
+                                                             ; method-function
+                                    (remove-method ((generic-function method)
+                                                    (standard-generic-function method)
+                                                    real-remove-method))
+                                    (get-method ((generic-function qualifiers specializers &optional
+                                                        (errorp t))
+                                                 (standard-generic-function t t)
+                                                 real-get-method))
+                                    (ensure-generic-function-using-class ((generic-function 
+                                                                                 function-specifier 
+                                                                                 &key 
+                                                                               generic-function-class
+                                                                                 environment 
+                                                                                 &allow-other-keys)
+                                                                          (generic-function t)
+                                                                          
+                                                         real-ensure-gf-using-class--generic-function
+                                                                          )
+                                           ((generic-function function-specifier &key 
+                                                   generic-function-class environment 
+                                                   &allow-other-keys)
+                                            (null t)
+                                            real-ensure-gf-using-class--null))))
+
+
+;;; 
+
+
+(defmacro defgeneric (function-specifier lambda-list &body options)
+       (expand-defgeneric function-specifier lambda-list options))
+
+(defun expand-defgeneric (function-specifier lambda-list options)
+       (when (listp function-specifier)
+           (do-standard-defsetf-1 (cadr function-specifier)))
+       (let ((initargs nil))
+            (flet ((duplicate-option (name)
+                          (error "The option ~S appears more than once." name)))
+                  
+                  ;; INITARG takes this screwy new argument to get around a bad interaction between
+                  ;; lexical macros and setf in the Lucid compiler. 
+                  (macrolet ((initarg (key &optional new)
+                                    (if new
+                                        `(setf (getf initargs ,key)
+                                               ,new)
+                                        `(getf initargs ,key))))
+                         (dolist (option options)
+                             (ecase (car option)
+                                 (:argument-precedence-order 
+                                    (if (initarg :argument-precedence-order)
+                                        (duplicate-option :argument-precedence-order)
+                                        (initarg :argument-precedence-order
+                                               `',(cdr option))))
+                                 (declare (initarg :declarations (append (cdr option)
+                                                                        (initarg :declarations))))
+                                 (:documentation (if (initarg :documentation)
+                                                     (duplicate-option :documentation)
+                                                     (initarg :documentation
+                                                            `',(cadr option))))
+                                 (:method-combination 
+                                    (if (initarg :method-combination)
+                                        (duplicate-option :method-combination)
+                                        (initarg :method-combination
+                                               `',(cdr option))))
+                                 (:generic-function-class 
+                                    (if (initarg :generic-function-class)
+                                        (duplicate-option :generic-function-class)
+                                        (initarg :generic-function-class
+                                               `',(cadr option))))
+                                 (:method-class (if (initarg :method-class)
+                                                    (duplicate-option :method-class)
+                                                    (initarg :method-class
+                                                           `',(cadr option))))
+                                 (:method (error "DEFGENERIC doesn't support the :METHOD option yet."
+                                                 ))))
+                         (let ((declarations (initarg :declarations)))
+                              (when declarations
+                                  (initarg :declarations `',declarations)))))
+            (make-top-level-form `(defgeneric ,function-specifier)
+                   *defgeneric-times*
+                   `(load-defgeneric ',function-specifier ',lambda-list ,@initargs))))
+
+(defun load-defgeneric (function-specifier lambda-list &rest initargs)
+       (when (listp function-specifier)
+           (do-standard-defsetf-1 (cadr function-specifier)))
+       (apply #'ensure-generic-function function-specifier :lambda-list lambda-list 
+              :definition-source `((defgeneric ,function-specifier)
+                                   ,(load-truename))
+              initargs))
+
+
+;;; 
+
+
+(defmacro defmethod (&rest args &environment env)
+       (declare (arglist name {method-qualifier}* specialized-lambda-list &body body))
+       (multiple-value-bind (name qualifiers lambda-list body)
+              (parse-defmethod args)
+              (let ((proto-method (method-prototype-for-gf name)))
+                   (expand-defmethod proto-method name qualifiers lambda-list body env))))
+
+
+;;; takes a name which is either a generic function name or a list specifying a setf generic
+;;; function (like: (SETF <generic-function-name>)).  Returns the prototype instance of the
+;;; method-class for that generic function. If there is no generic function by that name, this
+;;; returns the default value, the prototype instance of the class STANDARD-METHOD.  This default
+;;; value is also returned if the spec names an ordinary function or even a macro.  In effect, this
+;;; leaves the signalling of the appropriate error until load time. NOTE that during bootstrapping,
+;;; this function is allowed to return NIL. 
+
+
+(defun method-prototype-for-gf (name)
+       (let ((gf? (and (gboundp name)
+                       (gdefinition name))))
+            (cond ((neq *boot-state* 'complete)
+                   nil)
+                  ((or (null gf?)
+                       (not (generic-function-p gf?)))
+                                                             ; Someone else MIGHT error at load
+                                                             ; time. 
+                   (class-prototype (find-class 'standard-method)))
+                  (t (class-prototype (or (generic-function-method-class gf?)
+                                          (find-class 'standard-method)))))))
+
+(defun expand-defmethod (proto-method name qualifiers lambda-list body env)
+  (when (listp name) (do-standard-defsetf-1 (cadr name)))
+  (multiple-value-bind (fn-form specializers doc plist)
+      (expand-defmethod-internal name qualifiers lambda-list body env)
+    `(load-defmethod
+      ',(if proto-method
+	    (class-name (class-of proto-method))
+	    'standard-method)
+      ',name
+      ',qualifiers
+      (list ,@(mapcar #'(lambda (specializer)
+			  (if (and (consp specializer)
+				   (eq (car specializer) 'eql))
+			      ``(eql ,,(cadr specializer))
+			      `',specializer))
+	       specializers))
+      ',(specialized-lambda-list-lambda-list lambda-list)
+      ',doc
+      ',(getf plist :isl-cache-symbol)	;Paper over a bug in KCL by
+					;passing the cache-symbol
+					;here in addition to in the
+					;plist.
+      ',plist
+      ,fn-form)))
+
+(defun
+ expand-defmethod-internal
+ (generic-function-name qualifiers specialized-lambda-list body env)
+ (declare (values fn-form specializers doc)
+        (ignore qualifiers))
+ (when (listp generic-function-name)
+     (do-standard-defsetf-1 (cadr generic-function-name)))
+ (multiple-value-bind
+  (documentation declarations real-body)
+  (extract-declarations body)
+  (multiple-value-bind
+   (parameters lambda-list specializers)
+   (parse-specialized-lambda-list specialized-lambda-list)
+   (let*
+    ((required-parameters (mapcar #'(lambda (r s)
+                                           (declare (ignore s))
+                                           r)
+                                 parameters specializers))
+     (parameters-to-reference (make-parameter-references specialized-lambda-list required-parameters
+                                     declarations generic-function-name specializers))
+     (class-declarations
+      `(declare ,@(remove nil (mapcar #'(lambda (a s)
+                                               (and (symbolp s)
+                                                    (neq s 't)
+                                                    `(class ,a ,s)))
+                                     parameters specializers))))
+     (method-lambda 
+
+            ;; Remove the documentation string and insert the appropriate class declarations.  The
+            ;; documentation string is removed to make it easy for us to insert new declarations
+            ;; later, they will just go after the cadr of the method lambda.  The class declarations
+            ;; are inserted to communicate the class of the method's arguments to the code walk. 
+            (let nil `(lambda ,lambda-list ,class-declarations ,@declarations (progn 
+                                                                                     ,@
+                                                                              parameters-to-reference
+                                                                                     )
+                             (block ,(if (listp generic-function-name)
+                                         (cadr generic-function-name)
+                                         generic-function-name)
+                                    ,@real-body))))
+     (call-next-method-p nil)
+                                                             ; flag indicating that call-next-method
+                                                             ; should be in the method definition 
+     (closurep nil)
+                                                             ; flag indicating that
+                                                             ; #'call-next-method was seen in the
+                                                             ; body of a method 
+     (next-method-p-p nil)
+                                                             ; flag indicating that next-method-p
+                                                             ; should be in the method definition 
+     (save-original-args nil)
+                                                             ; flag indicating whether or not the
+                                                             ; original arguments to the method must
+                                                             ; be preserved.  This happens for two
+                                                             ; reasons: - the method takes &mumble
+                                                             ; args, so one of the lexical functions
+                                                             ; might be used in a default value form
+                                                             ; - call-next-method is used without
+                                                             ; arguments at least once in the body
+                                                             ; of the method 
+     (original-args nil)
+     (applyp nil)
+                                                             ; flag indicating whether or not the
+                                                             ; method takes &mumble arguments. If it
+                                                             ; does, it means call-next-method
+                                                             ; without arguments must be APPLY'd to
+                                                             ; original-args.  If this gets set
+                                                             ; true, save-original-args is set so as
+                                                             ; well 
+     (aux-bindings nil)
+                                                             ; Suffice to say that &aux is one of
+                                                             ; damndest things to have put in a
+                                                             ; language. 
+     (slots (mapcar #'list required-parameters))
+     (plist nil)
+     (walked-lambda nil))
+    (flet ((walk-function (form context env)
+                  (cond ((not (eq context ':eval))
+                         form)
+                        ((not (listp form))
+                         form)
+                        ((eq (car form)
+                             'call-next-method)
+                         (setq call-next-method-p 't)
+                         (unless (cdr form)
+                                (setq save-original-args t))
+                         form)
+                        ((eq (car form)
+                             'next-method-p)
+                         (setq next-method-p-p 't)
+                         form)
+                        ((and (eq (car form)
+                                  'function)
+                              (cond ((eq (cadr form)
+                                         'call-next-method)
+                                     (setq call-next-method-p 't)
+                                     (setq save-original-args 't)
+                                     (setq closurep t)
+                                     form)
+                                    ((eq (cadr form)
+                                         'next-method-p)
+                                     (setq next-method-p-p 't)
+                                     (setq closurep t)
+                                     form)
+                                    (t nil))))
+                        ((and (or (eq (car form)
+                                      'slot-value)
+                                  (eq (car form)
+                                      'set-slot-value))
+                              (symbolp (cadr form))
+                              (constantp (caddr form)))
+                         (let ((parameter (can-optimize-access (cadr form)
+                                                 required-parameters env)))
+                              (if (null parameter)
+                                  form
+                                  (ecase (car form)
+                                      (slot-value (optimize-slot-value slots parameter form))
+                                      (set-slot-value (optimize-set-slot-value slots parameter form)))
+)))
+                        (t form))))
+          (setq walked-lambda (walk-form method-lambda env #'walk-function))
+          
+          ;; Add &allow-other-keys to the lambda list as an interim way of implementing lambda list
+          ;; congruence rules. 
+          (when (and (memq '&key lambda-list)
+                     (not (memq '&allow-other-keys lambda-list)))
+              (let* ((rll (reverse lambda-list))
+                     (aux (memq '&aux rll)))
+                    (setq lambda-list (if aux
+                                          (progn (setf (cdr aux)
+                                                       (cons '&allow-other-keys (cdr aux)))
+                                                 (nreverse rll))
+                                          (nconc (nreverse rll)
+                                                 (list '&allow-other-keys))))))
+          
+          ;; Scan the lambda list to determine whether this method takes &mumble arguments.  If it
+          ;; does, we set applyp and save-original-args true. This is also the place where we
+          ;; construct the original arguments lambda list if there has to be one. 
+          (dolist (p lambda-list)
+              (if (memq p lambda-list-keywords)
+                  (if (eq p '&aux)
+                      (progn (setq aux-bindings (cdr (memq '&aux lambda-list)))
+                             (return nil))
+                      (progn (setq applyp t save-original-args t)
+                             (push '&rest original-args)
+                             (push (make-symbol "AMPERSAND-ARGS")
+                                   original-args)
+                             (return nil)))
+                  (push (make-symbol (symbol-name p))
+                        original-args)))
+          (setq original-args (if save-original-args
+                                  (nreverse original-args)
+                                  nil))
+          (multiple-value-bind (ignore walked-declarations walked-lambda-body)
+                 (extract-declarations (cddr walked-lambda))
+                 (declare (ignore ignore))
+                 (when (some #'cdr slots)
+                     (setq slots (slot-name-lists-from-slots slots))
+                     (setq plist (list* :isl slots plist))
+                     (setq walked-lambda-body (add-pv-binding walked-lambda-body plist 
+                                                     required-parameters)))
+                 (when (or next-method-p-p call-next-method-p)
+                     (setq plist (list* :needs-next-methods-p 't plist)))
+                 
+
+;;; changes are here... (mt)
+
+                 (let ((fn-body (if (or call-next-method-p next-method-p-p)
+                                    (add-lexical-functions-to-method-lambda
+                                     walked-declarations walked-lambda-body
+                                     `(lambda ,lambda-list ,@walked-declarations 
+                                             ,.walked-lambda-body)
+                                     original-args lambda-list save-original-args applyp aux-bindings
+                                     call-next-method-p next-method-p-p closurep)
+                                    `(lambda ,lambda-list ,@walked-declarations ,.walked-lambda-body))
+                              ))
+                      (values `#',fn-body specializers documentation plist))))))))
+
+(defun
+ add-lexical-functions-to-method-lambda
+ (walked-declarations walked-lambda-body walked-lambda original-args lambda-list save-original-args 
+        applyp aux-bindings call-next-method-p next-method-p-p closurep)
+ (cond
+  ((and (null closurep)
+        (null applyp)
+        (null save-original-args))
+   
+   ;; OK to use MACROLET, CALL-NEXT-METHOD is always passed some args, and all args are mandatory
+   ;; (else APPLYP would be true). 
+   `(lambda ,lambda-list ,@walked-declarations
+           (let ((.next-method. (car *next-methods*))
+                 (.next-methods. (cdr *next-methods*)))
+                (macrolet ((call-next-method ,lambda-list '(if .next-method.
+                                                               (let ((*next-methods* .next-methods.))
+                                                                    (funcall .next-method.
+                                                                           ,@lambda-list))
+                                                               (error "No next method.")))
+                           (next-method-p nil `(not (null .next-method.))))
+                       ,@walked-lambda-body))))
+  ((and (null closurep)
+        (null applyp)
+        save-original-args)
+   
+   ;; OK to use MACROLET.  CALL-NEXT-METHOD is sometimes called in the body with zero args, so we
+   ;; have to save the original args. 
+   (if save-original-args
+       
+       ;; CALL-NEXT-METHOD is sometimes called with no args
+       `(lambda ,original-args
+               (let ((.next-method. (car *next-methods*))
+                     (.next-methods. (cdr *next-methods*)))
+                    (macrolet ((call-next-method
+                                (&rest cnm-args)
+                                `(if .next-method.
+                                     (let ((*next-methods* .next-methods.))
+                                          (funcall .next-method. ,@(if cnm-args
+                                                                       cnm-args
+                                                                       ',original-args)))
+                                     (error "No next method.")))
+                               (next-method-p nil `(not (null .next-method.))))
+                           (let* (,@(mapcar #'list lambda-list original-args)
+                                  ,@aux-bindings)
+                                 ,@walked-declarations
+                                 ,@walked-lambda-body))))))
+  ((and (null save-original-args)
+        (null applyp))
+   
+   ;; We don't have to save the original arguments.  In addition, this method doesn't take any
+   ;; &mumble arguments (this means that there is no way the lexical functions can be used inside of
+   ;; the default value form for an &mumble argument). We can expand this into a simple lambda
+   ;; expression with an FLET to define the lexical functions. 
+   `(lambda ,lambda-list ,@walked-declarations
+           (let ((.next-method. (car *next-methods*))
+                 (.next-methods. (cdr *next-methods*)))
+                (flet (,@(and call-next-method-p '((call-next-method (&rest cnm-args)
+                                                          (if .next-method.
+                                                              (let ((*next-methods* .next-methods.))
+                                                                   (apply .next-method. cnm-args))
+                                                              (error "No next method.")))))
+                       ,@(and next-method-p-p '((next-method-p nil (not (null .next-method.))))))
+                      ,@walked-lambda-body))))
+  ((null applyp)
+   
+   ;; This method doesn't accept any &mumble arguments.  But we do have to save the original
+   ;; arguments (this is because call-next-method is being called with no arguments). Have to be
+   ;; careful though, there may be multiple calls to call-next-method, all we know is that at least
+   ;; one of them is with no arguments. 
+   `(lambda ,original-args
+           (let ((.next-method. (car *next-methods*))
+                 (.next-methods. (cdr *next-methods*)))
+                (flet (,@(and call-next-method-p
+                              `((call-next-method (&rest cnm-args)
+                                       (if .next-method.
+                                           (let ((*next-methods* .next-methods.))
+                                                (if cnm-args
+                                                    (apply .next-method. cnm-args)
+                                                    (funcall .next-method. ,@original-args)))
+                                           (error "No next method.")))))
+                       ,@(and next-method-p-p '((next-method-p nil (not (null .next-method.))))))
+                      (let* (,@(mapcar #'list (remtail lambda-list (memq '&aux lambda-list))
+                                      original-args)
+                             ,@aux-bindings)
+                            ,@walked-declarations
+                            ,@walked-lambda-body)))))
+  (t
+   
+   ;; This is the fully general case. We must allow for the lexical functions being used inside the
+   ;; default value forms of &mumble arguments, and if must allow for call-next-method being called
+   ;; with no arguments. 
+   `(lambda
+     ,original-args
+     (let
+      ((.next-method. (car *next-methods*))
+       (.next-methods. (cdr *next-methods*)))
+      (flet (,@(and call-next-method-p
+                    `((call-next-method (&rest cnm-args)
+                             (if .next-method.
+                                 (let ((*next-methods* .next-methods.))
+                                      (if cnm-args
+                                          (apply .next-method. cnm-args)
+                                          (apply .next-method. ,@(remove '&rest original-args))))
+                                 (error "No next method.")))))
+             ,@(and next-method-p-p '((next-method-p nil (not (null .next-method.))))))
+            (apply #',walked-lambda ,@(remove '&rest original-args))))))))
+
+(defun make-parameter-references (specialized-lambda-list required-parameters declarations 
+                                        generic-function-name specializers)
+       (flet ((ignoredp (symbol)
+                     (dolist (decl (cdar declarations))
+                         (when (and (eq (car decl)
+                                        'ignore)
+                                    (memq symbol (cdr decl)))
+                               (return t)))))
+             (gathering ((references (collecting)))
+                    (iterate ((s (list-elements specialized-lambda-list))
+                              (p (list-elements required-parameters)))
+                           (progn p)
+                           (cond ((not (listp s)))
+                                 ((ignoredp (car s))
+                                  (warn "In defmethod ~S ~S, there is a~%~
+                      redundant ignore declaration for the parameter ~S." generic-function-name 
+                                        specializers (car s)))
+                                 (t (gather (car s)
+                                           references)))))))
+
+(defvar *method-function-plist* (make-hash-table :test #'eq))
+
+(defun method-function-plist (method-function)
+       (gethash method-function *method-function-plist*))
+
+(defun |SETF CLOS METHOD-FUNCTION-PLIST| (val method-function)
+       (setf (gethash method-function *method-function-plist*)
+             val))
+
+(defun method-function-get (method-function key)
+       (getf (method-function-plist method-function)
+             key))
+
+(defun |SETF CLOS METHOD-FUNCTION-GET| (val method-function key)
+       (setf (getf (method-function-plist method-function)
+                   key)
+             val))
+
+(defun method-function-isl (method-function)
+       (method-function-get method-function :isl))
+
+(defun method-function-needs-next-methods-p (method-function)
+       (method-function-get method-function :needs-next-methods-p))
+
+(defun load-defmethod (class name quals specls ll doc isl-cache-symbol plist fn)
+       (when (listp name)
+           (do-standard-defsetf-1 (cadr name)))
+       (let ((method-spec (make-method-spec name quals specls)))
+            (record-definition 'method method-spec)
+            (setq fn (set-function-name fn method-spec))
+            (load-defmethod-internal name quals specls ll doc isl-cache-symbol plist fn class)))
+
+(defun load-defmethod-internal (gf-spec qualifiers specializers lambda-list doc isl-cache-symbol 
+                                      plist fn method-class)
+       (when (listp gf-spec)
+           (do-standard-defsetf-1 (cadr gf-spec)))
+       (when plist
+           (setq plist (copy-list plist))
+                                                             ; Do this to keep from affecting the
+                                                             ; plist that is about to be dumped when
+                                                             ; we are compiling. 
+           (let ((uisl (getf plist :isl))
+                 (isl nil))
+                (when uisl
+                    (setq isl (intern-slot-name-lists uisl))
+                    (setf (getf plist :isl)
+                          isl))
+                (when isl-cache-symbol
+                    (setf (getf plist :isl-cache-symbol)
+                          isl-cache-symbol)
+                    (set isl-cache-symbol isl)))
+           (setf (method-function-plist fn)
+                 plist))
+       (let ((method (add-named-method gf-spec qualifiers specializers lambda-list fn :documentation
+                            doc :definition-source `((defmethod ,gf-spec ,@qualifiers ,specializers)
+                                                     ,(load-truename)))))
+            (unless (or (eq method-class 'standard-method)
+                        (eq (find-class method-class nil)
+                            (class-of method)))
+                (format *error-output* "At the time the method with qualifiers ~:~S and~%~
+               specializers ~:S on the generic function ~S~%~
+               was compiled, the method-class for that generic function was~%~
+               ~S.  But, the method class is now ~S, this~%~
+               may mean that this method was compiled improperly." qualifiers specializers gf-spec 
+                       method-class (class-name (class-of method))))
+            method))
+
+(defun make-method-spec (gf-spec qualifiers unparsed-specializers)
+       `(method ,gf-spec ,@qualifiers ,unparsed-specializers))
+
+                                                             ; Early generic-function support
+
+
+
+;;; 
+
+
+(defvar *early-generic-functions* nil)
+
+(defun ensure-generic-function (function-specifier &rest all-keys &key environment &allow-other-keys)
+       (declare (ignore environment))
+       (let ((existing (and (gboundp function-specifier)
+                            (gdefinition function-specifier))))
+            (if (and existing (eq *boot-state* 'complete)
+                     (null (generic-function-p existing)))
+                (generic-clobbers-function function-specifier)
+                (apply #'ensure-generic-function-using-class existing function-specifier all-keys))))
+
+(defun generic-clobbers-function (function-specifier)
+       (error "~S already names an ordinary function or a macro,~%~
+                  you may want to replace it with a generic function, but doing so~%~
+                  will require that you decide what to do with the existing function~%~
+                  definition.~%~
+                  The CLOS-specific function MAKE-SPECIALIZABLE may be useful to you." 
+              function-specifier))
+
+
+;;; This is the early definition of ensure-generic-function-using-class. The static-slots field of
+;;; the funcallable instances used as early generic functions is used to store the early methods and
+;;; early discriminator code for the early generic function.  The static slots field of the fins
+;;; contains a list whose: CAR    -   a list of the early methods on this early gf CADR   -   the
+;;; early discriminator code for this method 
+
+
+(defun ensure-generic-function-using-class (existing spec &rest keys)
+       (declare (ignore keys))
+       (if* existing existing (pushnew spec *early-generic-functions* :test #'equal)
+            (let ((fin (allocate-funcallable-instance-1)))
+                 (setf (gdefinition spec)
+                       fin)
+                 (setf (fsc-instance-slots fin)
+                       (list nil nil))
+                 fin)))
+
+(defun early-gf-p (x)
+       (and (fsc-instance-p x)
+            (listp (fsc-instance-slots x))))
+
+(defmacro early-gf-methods (early-gf)
+                                                             ; These are macros so that
+       `(car (fsc-instance-slots ,early-gf)))
+
+                                                             ; they can be setf'd. 
+
+
+(defmacro early-gf-discriminator-code (early-gf)
+                                                             ; 
+       `(cadr (fsc-instance-slots ,early-gf)))
+
+                                                             ; 
+
+
+(defmacro real-ensure-gf-internal (gf-class all-keys env)
+       `(progn (cond ((symbolp ,gf-class)
+                      (setq ,gf-class (find-class ,gf-class t ,env)))
+                     ((classp ,gf-class))
+                     (t (error "The :GENERIC-FUNCTION-CLASS argument (~S) was neither a~%~
+                    class nor a symbol that names a class." ,gf-class)))
+               (remf ,all-keys :generic-function-class)
+               (remf ,all-keys :environment)
+               (let ((combin (getf ,all-keys :method-combination '.shes-not-there.)))
+                    (unless (eq combin '.shes-not-there.)
+                        (setf (getf ,all-keys :method-combination)
+                              (find-method-combination (class-prototype ,gf-class)
+                                     (car combin)
+                                     (cdr combin)))))))
+
+(defun real-ensure-gf-using-class--generic-function (existing function-specifier &rest all-keys &key
+                                                           environment (generic-function-class
+                                                                        'standard-generic-function 
+                                                                        gf-class-p)
+                                                           &allow-other-keys)
+       (declare (ignore function-specifier))
+       (real-ensure-gf-internal generic-function-class all-keys environment)
+       (unless (or (null gf-class-p)
+                   (eq (class-of existing)
+                       generic-function-class))
+              (change-class existing generic-function-class))
+       (apply #'reinitialize-instance existing all-keys))
+
+(defun real-ensure-gf-using-class--null (existing function-specifier &rest all-keys &key environment
+                                               (generic-function-class 'standard-generic-function)
+                                               &allow-other-keys)
+       (declare (ignore existing))
+       (real-ensure-gf-internal generic-function-class all-keys environment)
+       (setf (gdefinition function-specifier)
+             (apply #'make-instance generic-function-class :name function-specifier all-keys)))
+
+(defun early-make-a-method (class qualifiers arglist specializers function doc &optional slot-name)
+       (let ((parsed nil)
+             (unparsed nil))
+            
+            ;; Figure out whether we got class objects or class names as the specializers and set
+            ;; parsed and unparsed appropriately.  If we got class objects, then we can compute
+            ;; unparsed, but if we got class names we don't try to compute parsed. Note that the use
+            ;; of not symbolp in this call to every should be read as 'classp' we can't use classp
+            ;; itself because it doesn't exist yet. 
+            (if (every #'(lambda (s)
+                                (not (symbolp s)))
+                       specializers)
+                (setq parsed specializers unparsed (mapcar #'(lambda (s)
+                                                                    (if (eq s 't)
+                                                                        't
+                                                                        (class-name s)))
+                                                          specializers))
+                (setq unparsed specializers parsed nil))
+            (list :early-method                              ; This is an early method dammit!
+                  function
+                                                             ; Function is here for the benefit of
+                                                             ; early-lookup-method. 
+                  parsed
+                                                             ; The parsed specializers.  This is
+                                                             ; used by early-method-specializers to
+                                                             ; cache the parse.  Note that this only
+                                                             ; comes into play when there is more
+                                                             ; than one early method on an early gf.
+                  (list class                                ; A list to which real-make-a-method
+                        qualifiers
+                                                             ; can be applied to make a real method
+                        arglist
+                                                             ; corresponding to this early one.
+                        unparsed function doc slot-name))))
+
+(defun real-make-a-method (class qualifiers lambda-list specializers function doc &optional slot-name
+                                 )
+       
+       ;; Hmm what is this use of when buying me??
+       (when (some #'(lambda (x)
+                            (and (neq x 't)
+                                 (symbolp x)))
+                   specializers)
+           (setq specializers (parse-specializers specializers)))
+       (make-instance class :qualifiers qualifiers :lambda-list lambda-list :specializers 
+              specializers :function function :documentation doc :slot-name slot-name 
+              :allow-other-keys t))
+
+(defun early-method-function (early-method)
+       (cadr early-method))
+
+
+;;; Fetch the specializers of an early method.  This is basically just a simple accessor except that
+;;; when the second argument is t, this converts the specializers from symbols into class objects. 
+;;; The class objects are cached in the early method, this makes bootstrapping faster because the
+;;; class objects only have to be computed once. NOTE: the second argument should only be passed as
+;;; T by early-lookup-method. this is to implement the rule that only when there is more than one
+;;; early method on a generic function is the conversion from class names to class objects done. the
+;;; corresponds to the fact that we are only allowed to have one method on any generic function up
+;;; until the time classes exist. 
+
+
+(defun early-method-specializers (early-method &optional objectsp)
+       (if (and (listp early-method)
+                (eq (car early-method)
+                    :early-method))
+           (cond ((eq objectsp 't)
+                  (or (caddr early-method)
+                      (setf (caddr early-method)
+                            (mapcar #'find-class (cadddr (cadddr early-method))))))
+                 (t (cadddr (cadddr early-method))))
+           (error "~S is not an early-method." early-method)))
+
+(defun early-method-qualifiers (early-method)
+       (cadr (cadddr early-method)))
+
+(defun early-add-named-method (generic-function-name qualifiers specializers arglist function &rest 
+                                     options)
+       (declare (ignore options))
+       (let* ((gf (ensure-generic-function generic-function-name))
+              (existing (dolist (m (early-gf-methods gf))
+                            (when (and (equal (early-method-specializers m)
+                                              specializers)
+                                       (equal (early-method-qualifiers m)
+                                              qualifiers))
+                                  (return m))))
+              (new (make-a-method 'standard-method qualifiers arglist specializers function nil)))
+             (when existing (remove-method gf existing))
+             (add-method gf new)))
+
+
+;;; This is the early version of add-method.  Later this will become a generic function.  See
+;;; fix-early-generic-functions which has special knowledge about add-method. 
+
+
+(defun add-method (generic-function method)
+       (when (not (fsc-instance-p generic-function))
+             (error "Early add-method didn't get a funcallable instance."))
+       (when (not (and (listp method)
+                       (eq (car method)
+                           :early-method)))
+             (error "Early add-method didn't get an early method."))
+       (push method (early-gf-methods generic-function))
+       (early-update-discriminator-code generic-function))
+
+
+;;; This is the early version of remove method. 
+
+
+(defun remove-method (generic-function method)
+       (when (not (fsc-instance-p generic-function))
+             (error "Early remove-method didn't get a funcallable instance."))
+       (when (not (and (listp method)
+                       (eq (car method)
+                           :early-method)))
+             (error "Early remove-method didn't get an early method."))
+       (setf (early-gf-methods generic-function)
+             (remove method (early-gf-methods generic-function)))
+       (early-update-discriminator-code generic-function))
+
+
+;;; And the early version of get-method. 
+
+
+(defun get-method (generic-function qualifiers specializers &optional (errorp t))
+       (if (early-gf-p generic-function)
+           (or (dolist (m (early-gf-methods generic-function))
+                   (when (and (or (equal (early-method-specializers m nil)
+                                         specializers)
+                                  (equal (early-method-specializers m 't)
+                                         specializers))
+                              (equal (early-method-qualifiers m)
+                                     qualifiers))
+                         (return m)))
+               (if errorp
+                   (error "Can't get early method.")
+                   nil))
+           (real-get-method generic-function qualifiers specializers errorp)))
+
+(defun early-update-discriminator-code (generic-function)
+       (let* ((methods (early-gf-methods generic-function))
+              (early-dfun (cond ((null methods)
+                                 #'(lambda (&rest ignore)
+                                          (declare (ignore ignore))
+                                          (error 
+              "Called an early generic-function that ~
+                              has no methods?")))
+                                ((null (cdr methods))
+                                 
+                                 ;; If there is only one method, just use that method's function. 
+                                 ;; This corresponds to the important fact that early
+                                 ;; generic-functions with only one method always call that method
+                                 ;; when they are called.  If there is more than one method, we have
+                                 ;; to install a simple little discriminator-code for this generic
+                                 ;; function. 
+                                 (cadr (car methods)))
+                                (t #'(lambda (&rest args)
+                                            (early-dfun methods args))))))
+             (set-funcallable-instance-function generic-function early-dfun)
+             (setf (early-gf-discriminator-code generic-function)
+                   early-dfun)))
+
+(defun early-get-cpl (object)
+       (bootstrap-get-slot 'std-class                        ; HMMM? should be CLOS-CLASS
+              (class-of object)
+              'class-precedence-list))
+
+(defun early-sort-methods (list args)
+       (if (null (cdr list))
+           list
+           (sort list #'(lambda (specls-1 specls-2)
+                               (iterate ((s1 (list-elements specls-1))
+                                         (s2 (list-elements specls-2))
+                                         (a (list-elements args)))
+                                      (cond ((eq s1 s2))
+                                            ((eq s2 *the-class-t*)
+                                             (return t))
+                                            ((eq s1 *the-class-t*)
+                                             (return nil))
+                                            (t (return (memq s2 (memq s1 (early-get-cpl a))))))))
+                 :key
+                 #'(lambda (em)
+                          (early-method-specializers em t)))))
+
+(defun early-dfun (methods args)
+       (let ((primary nil)
+             (before nil)
+             (after nil)
+             (around nil))
+            (dolist (method methods)
+                (let* ((specializers (early-method-specializers method t))
+                       (qualifiers (early-method-qualifiers method))
+                       (args args)
+                       (specs specializers))
+                      (when (loop (when (or (null args)
+                                            (null specs))
+                                      
+
+                                 ;; If we are out of specs, then we must be in the optional, rest or
+                                 ;; keywords arguments.  This method is applicable to these
+                                 ;; arguments.  Return T. 
+                                      (return t))
+                                  (let ((arg (pop args))
+                                        (spec (pop specs)))
+                                       (unless (or (eq spec *the-class-t*)
+                                                   (memq spec (early-get-cpl arg)))
+                                              (return nil))))
+                          (cond ((null qualifiers)
+                                 (push method primary))
+                                ((equal qualifiers '(:before))
+                                 (push method before))
+                                ((equal qualifiers '(:after))
+                                 (push method after))
+                                ((equal qualifiers '(:around))
+                                 (push method around))
+                                (t (error "Unrecognized qualifer in early method."))))))
+            (setq primary (early-sort-methods primary args)
+                  before
+                  (early-sort-methods before args)
+                  after
+                  (early-sort-methods after args)
+                  around
+                  (early-sort-methods around args))
+            (flet ((do-main-combined-method (arguments)
+                          (dolist (m before)
+                              (apply (cadr m)
+                                     arguments))
+                          (multiple-value-prog1 (let ((*next-methods* (mapcar #'car (cdr primary))))
+                                                     (apply (cadar primary)
+                                                            arguments))
+                                 (dolist (m after)
+                                     (apply (cadr m)
+                                            arguments)))))
+                  (if (null around)
+                      (do-main-combined-method args)
+                      (let ((*next-methods* (append (mapcar #'cadr (cdr around))
+                                                   #'do-main-combined-method)))
+                           (apply (caar around)
+                                  args))))))
+
+(defun
+ fix-early-generic-functions
+ (&optional noisyp)
+ (allocate-instance (find-class 'standard-generic-function))
+                                                             ; Be sure this class has an instance. 
+ (let* ((class (find-class 'standard-generic-function))
+        (wrapper (class-wrapper class))
+        (n-static-slots (class-no-of-instance-slots class))
+        (default-initargs (default-initargs class nil))
+        (*invalidate-discriminating-function-force-p* t))
+       (flet ((fix-structure (gf)
+                     (let ((static-slots (%allocate-static-slot-storage--class n-static-slots)))
+                          (setf (fsc-instance-wrapper gf)
+                                wrapper
+                                (fsc-instance-slots gf)
+                                static-slots))))
+             (dolist (early-gf-spec *early-generic-functions*)
+                 (when noisyp (format t "~&~S..." early-gf-spec))
+                 (let* ((early-gf (gdefinition early-gf-spec))
+                        (early-static-slots (fsc-instance-slots early-gf))
+                        (early-discriminator-code nil)
+                        (early-methods nil)
+                        (methods nil)
+                        (aborted t))
+                       (flet ((trampoline (&rest args)
+                                     (apply early-discriminator-code args)))
+                             (if (not (listp early-static-slots))
+                                 (when noisyp (format t "already fixed?"))
+                                 (unwind-protect
+                                     (progn (setq early-discriminator-code (
+                                                                          early-gf-discriminator-code
+                                                                            early-gf))
+                                            (setq early-methods (early-gf-methods early-gf))
+                                            (setf (gdefinition early-gf-spec)
+                                                  #'trampoline)
+                                            (when noisyp (format t "trampoline..."))
+                                            (fix-structure early-gf)
+                                            (when noisyp (format t "fixed..."))
+                                            (apply #'initialize-instance early-gf :name early-gf-spec
+                                                   default-initargs)
+                                            (dolist (early-method early-methods)
+                                                (destructuring-bind (class quals lambda-list specs fn
+                                                                           doc slot-name)
+                                                       (cadddr early-method)
+                                                       (setq specs (early-method-specializers 
+                                                                          early-method t))
+                                                       (let ((method (real-make-a-method class quals
+                                                                            lambda-list specs fn doc
+                                                                            slot-name)))
+                                                            (real-add-method early-gf method)
+                                                            (push method methods)
+                                                            (when noisyp (format t "m")))))
+                                            (setf (slot-value early-gf 'name)
+                                                  early-gf-spec)
+                                            (fixup-magic-generic-function early-gf-spec early-methods
+                                                   early-gf (reverse methods))
+                                            (setq aborted nil))
+                                     (setf (gdefinition early-gf-spec)
+                                           early-gf)
+                                     (when noisyp (format t "."))
+                                     (when aborted
+                                         (setf (fsc-instance-slots early-gf)
+                                               early-static-slots)))))))
+             (dolist (fns *early-functions*)
+                 (setf (symbol-function (car fns))
+                       (symbol-function (caddr fns))))
+             (dolist (fixup *generic-function-fixups*)
+                 (let ((fspec (car fixup))
+                       (methods (cdr fixup))
+                       (gf (make-instance 'standard-generic-function)))
+                      (set-function-name gf fspec)
+                      (setf (generic-function-name gf)
+                            fspec)
+                      (dolist (method methods)
+                          (destructuring-bind (lambda-list specializers method-fn-name)
+                                 method
+                                 (let* ((fn (if method-fn-name
+                                                (symbol-function method-fn-name)
+                                                (symbol-function fspec)))
+                                        (method (make-a-method 'standard-method nil lambda-list 
+                                                       specializers fn nil)))
+                                       (real-add-method gf method))))
+                      (setf (gdefinition fspec)
+                            gf))))))
+
+
+;;; parse-defmethod is used by defmethod to parse the &rest argument into the 'real' arguments. 
+;;; This is where the syntax of defmethod is really implemented. 
+
+
+(defun parse-defmethod (cdr-of-form)
+       (declare (values name qualifiers specialized-lambda-list body))
+       (let ((name (pop cdr-of-form))
+             (qualifiers nil)
+             (spec-ll nil))
+            (loop (if (and (car cdr-of-form)
+                           (atom (car cdr-of-form)))
+                      (push (pop cdr-of-form)
+                            qualifiers)
+                      (return (setq qualifiers (nreverse qualifiers)))))
+            (setq spec-ll (pop cdr-of-form))
+            (values name qualifiers spec-ll cdr-of-form)))
+
+(defun parse-specializers (specializers)
+       (flet ((parse (spec)
+                     (cond ((symbolp spec)
+                            (or (find-class spec nil)
+                                (error 
+              "~S used as a specializer,~%~
+                         but is not the name of a class." spec)))
+                           ((and (listp spec)
+                                 (eq (car spec)
+                                     'eql)
+                                 (null (cddr spec)))
+                            (make-instance 'eql-specializer :object (cadr spec))
+                                                             ; *EQL* spec 
+                            )
+                           (t (error "~S is not a legal specializer." spec)))))
+             (mapcar #'parse specializers)))
+
+(defun unparse-specializers (specializers-or-method)
+       (if (listp specializers-or-method)
+           (flet ((unparse (spec)
+                         (cond ((classp spec)
+                                (or (class-name spec)
+                                    spec))
+                               ((eql-specializer-p spec)
+                                                             ; *EQL*
+                                (eql-specializer-object spec)
+                                                             ; (and (listp spec) (eq (car spec)
+                                                             ; 'eql)) spec 
+                                )
+                               (t (error "~S is not a legal specializer." spec)))))
+                 (mapcar #'unparse specializers-or-method))
+           (unparse-specializers (method-specializers specializers-or-method))))
+
+(defun parse-method-or-spec (spec &optional (errorp t))
+       (declare (values generic-function method method-name))
+       (let (gf method name temp)
+            (if (method-p spec)
+                (setq method spec gf (method-generic-function method)
+                      temp
+                      (and gf (generic-function-name gf))
+                      name
+                      (if temp
+                          (intern-function-name (make-method-spec temp (method-qualifiers method)
+                                                       (unparse-specializers (method-specializers
+                                                                              method))))
+                          (make-symbol (format nil "~S" method))))
+                (multiple-value-bind (gf-spec quals specls)
+                       (parse-defmethod spec)
+                       (and (setq gf (and (or errorp (gboundp gf-spec))
+                                          (gdefinition gf-spec)))
+                            (let ((nreq (compute-discriminating-function-arglist-info gf)))
+                                 (setq specls (append (parse-specializers specls)
+                                                     (make-list (- nreq (length specls))
+                                                            :initial-element *the-class-t*)))
+                                 (and (setq method (get-method gf quals specls errorp))
+                                      (setq name (intern-function-name (make-method-spec gf-spec 
+                                                                              quals specls))))))))
+            (values gf method name)))
+
+(defun specialized-lambda-list-parameters (specialized-lambda-list)
+       (multiple-value-bind (parameters ignore1 ignore2)
+              (parse-specialized-lambda-list specialized-lambda-list)
+              (declare (ignore ignore1 ignore2))
+              parameters))
+
+(defun specialized-lambda-list-lambda-list (specialized-lambda-list)
+       (multiple-value-bind (ignore1 lambda-list ignore2)
+              (parse-specialized-lambda-list specialized-lambda-list)
+              (declare (ignore ignore1 ignore2))
+              lambda-list))
+
+(defun specialized-lambda-list-specializers (specialized-lambda-list)
+       (multiple-value-bind (ignore1 ignore2 specializers)
+              (parse-specialized-lambda-list specialized-lambda-list)
+              (declare (ignore ignore1 ignore2))
+              specializers))
+
+(defun specialized-lambda-list-required-parameters (specialized-lambda-list)
+       (multiple-value-bind (ignore1 ignore2 ignore3 required-parameters)
+              (parse-specialized-lambda-list specialized-lambda-list)
+              (declare (ignore ignore1 ignore2 ignore3))
+              required-parameters))
+
+(defun parse-specialized-lambda-list (arglist &optional post-keyword)
+       (declare (values parameters lambda-list specializers required-parameters))
+       (let ((arg (car arglist)))
+            (cond ((null arglist)
+                   (values nil nil nil nil))
+                  ((eq arg '&aux)
+                   (values nil arglist nil))
+                  ((memq arg lambda-list-keywords)
+                   (unless (memq arg '(&optional &rest &key &allow-other-keys &aux))
+                       
+                       ;; Warn about non-standard lambda-list-keywords, but then go on to treat them
+                       ;; like a standard lambda-list-keyword what with the warning its probably ok.
+                       (warn "Unrecognized lambda-list keyword ~S in arglist.~%~
+                    Assuming that the symbols following it are parameters,~%~
+                    and not allowing any parameter specializers to follow~%~
+                    to follow it." arg))
+                   
+                   ;; When we are at a lambda-list-keyword, the parameters don't include the
+                   ;; lambda-list-keyword; the lambda-list does include the lambda-list-keyword; and
+                   ;; no specializers are allowed to follow the lambda-list-keywords (at least for
+                   ;; now). 
+                   (multiple-value-bind (parameters lambda-list)
+                          (parse-specialized-lambda-list (cdr arglist)
+                                 t)
+                          (values parameters (cons arg lambda-list)
+                                 nil nil)))
+                  (post-keyword 
+
+                         ;; After a lambda-list-keyword there can be no specializers.
+                         (multiple-value-bind (parameters lambda-list)
+                                (parse-specialized-lambda-list (cdr arglist)
+                                       t)
+                                (values (cons (if (listp arg)
+                                                  (car arg)
+                                                  arg)
+                                              parameters)
+                                       (cons arg lambda-list)
+                                       nil nil)))
+                  (t (multiple-value-bind (parameters lambda-list specializers required)
+                            (parse-specialized-lambda-list (cdr arglist))
+                            (values (cons (if (listp arg)
+                                              (car arg)
+                                              arg)
+                                          parameters)
+                                   (cons (if (listp arg)
+                                             (car arg)
+                                             arg)
+                                         lambda-list)
+                                   (cons (if (listp arg)
+                                             (cadr arg)
+                                             't)
+                                         specializers)
+                                   (cons (if (listp arg)
+                                             (car arg)
+                                             arg)
+                                         required)))))))
+
+(eval-when (load eval)
+       (setq *boot-state* 'early))
+
+(defmacro with-slots (slots instance &body body &environment env)
+       (let ((gensym (gensym))
+             (specs (mapcar #'(lambda (ss)
+                                     (if (consp ss)
+                                         (list (car ss)
+                                               (variable-lexical-p (car ss)
+                                                      env)
+                                               (cadr ss))
+                                         (list ss (variable-lexical-p ss env)
+                                               ss)))
+                           slots)))
+            (expand-with-slots specs body env gensym instance
+                   #'(lambda (s)
+                            `(slot-value ,gensym ',s)))))
+
+(defmacro with-accessors (slot-accessor-pairs instance &body body &environment env)
+       (let ((gensym (gensym))
+             (specs (mapcar #'(lambda (ss)
+                                     (list (car ss)
+                                           (variable-lexical-p (car ss)
+                                                  env)
+                                           (cadr ss)))
+                           slot-accessor-pairs)))
+            (expand-with-slots specs body env gensym instance #'(lambda (a)
+                                                                       `(,a ,gensym)))))
+
+(defun expand-with-slots (specs body env gensym instance translate-fn)
+       `(let ((,gensym ,instance))
+             ,@(and (symbolp instance)
+                    `((declare (variable-rebinding ,gensym ,instance))))
+             ,gensym
+             ,@(cdr (walk-form `(progn ,@body)
+                           env
+                           #'(lambda (f c e)
+                                    (expand-with-slots-internal specs f c translate-fn e))))))
+
+(defun expand-with-slots-internal (specs form context translate-fn env)
+       (let ((entry nil))
+            (cond ((not (eq context :eval))
+                   form)
+                  ((symbolp form)
+                   (if (and (setq entry (assoc form specs))
+                            (eq (cadr entry)
+                                (variable-lexical-p form env)))
+                       (funcall translate-fn (caddr entry))
+                       form))
+                  ((not (listp form))
+                   form)
+                  ((member (car form)
+                          '(setq setf))
+                   
+                   ;; Have to be careful.  We must only convert the form to a SETF form when we
+                   ;; convert one of the 'logical' variables to a form Otherwise we will get looping
+                   ;; in implementations where setf is a macro which expands into setq. 
+                   (let ((kind (car form)))
+                        (labels ((scan-setf (tail)
+                                        (if (null tail)
+                                            nil
+                                            (walker::relist* tail
+                                                   (if (and (setq entry (assoc (car tail)
+                                                                               specs))
+                                                            (eq (cadr entry)
+                                                                (variable-lexical-p (car tail)
+                                                                       env)))
+                                                       (progn (setq kind 'setf)
+                                                              (funcall translate-fn (caddr entry)))
+                                                       (car tail))
+                                                   (cadr tail)
+                                                   (scan-setf (cddr tail))))))
+                               (let (new-tail)
+                                    (setq new-tail (scan-setf (cdr form)))
+                                    (walker::recons form kind new-tail)))))
+                  ((eq (car form)
+                       'multiple-value-setq)
+                   (let* ((vars (cadr form))
+                          (gensyms (mapcar #'(lambda (i)
+                                                    (declare (ignore i))
+                                                    (gensym))
+                                          vars)))
+                         `(multiple-value-bind ,gensyms ,(caddr form)
+                                 . ,(reverse (mapcar #'(lambda (v g)
+                                                              `(setf ,v ,g))
+                                                    vars gensyms)))))
+                  (t form))))
diff --git a/clos/3.5/braid.dfasl b/clos/3.5/braid.dfasl
new file mode 100644
index 00000000..2f7b7cc2
Binary files /dev/null and b/clos/3.5/braid.dfasl differ
diff --git a/clos/3.5/braid.lisp b/clos/3.5/braid.lisp
new file mode 100644
index 00000000..80424b6a
--- /dev/null
+++ b/clos/3.5/braid.lisp
@@ -0,0 +1,503 @@
+;;;-*-Mode:LISP; Package:(CLOS (LISP WALKER)); Base:10; Syntax:Common-lisp -*-
+;;;
+;;; *************************************************************************
+;;; Copyright (c) 1991 Venue
+;;; All rights reserved.
+;;; *************************************************************************
+;;;
+;;; Bootstrapping the meta-braid.
+;;;
+;;; The code in this file takes the early definitions that have been saved
+;;; up and actually builds those class objects.  This work is largely driven
+;;; off of those class definitions, but the fact that STANDARD-CLASS is the
+;;; class of all metaclasses in the braid is built into this code pretty
+;;; deeply.
+;;;
+;;; 
+
+(in-package 'clos)
+
+(defun early-class-definition (class-name)
+  (or (find class-name *early-class-definitions* :key #'ecd-class-name)
+      (error "~S is not a class in *early-class-definitions*." class-name)))
+
+(defun canonical-slot-name (canonical-slot)
+  (getf canonical-slot :name))
+
+(defun early-collect-inheritance (class-name)
+  (declare (values slots cpl default-initargs direct-subclasses))
+  (let ((cpl (early-collect-cpl class-name)))
+    (values (early-collect-slots cpl)
+	    cpl
+	    (early-collect-default-initargs cpl)
+	    (gathering1 (collecting)
+	      (dolist (definition *early-class-definitions*)
+		(when (memq class-name (ecd-superclass-names definition))
+		  (gather1 (ecd-class-name definition))))))))
+
+(defun early-collect-cpl (class-name)
+  (labels ((walk (c)
+	     (let* ((definition (early-class-definition c))
+		    (supers (ecd-superclass-names definition)))
+	       (cons c
+		     (apply #'append (mapcar #'early-collect-cpl supers))))))
+    (remove-duplicates (walk class-name) :from-end nil :test #'eq)))
+
+(defun early-collect-slots (cpl)
+  (let* ((definitions (mapcar #'early-class-definition cpl))
+	 (super-slots (mapcar #'ecd-canonical-slots definitions))
+	 (slots (apply #'append (reverse super-slots))))
+    (dolist (s1 slots)
+      (let ((name1 (canonical-slot-name s1)))
+	(dolist (s2 (cdr (memq s1 slots)))
+	  (when (eq name1 (canonical-slot-name s2))
+	    (error "More than one early class defines a slot with the~%~
+                    name ~S.  This can't work because the bootstrap~%~
+                    object system doesn't know how to compute effective~%~
+                    slots."
+		   name1)))))
+    slots))
+
+(defun early-collect-default-initargs (cpl)
+  (let ((default-initargs ()))
+    (dolist (class-name cpl)
+      (let ((definition (early-class-definition class-name)))
+	(dolist (option (ecd-other-initargs definition))
+	  (unless (eq (car option) :default-initargs)
+	    (error "The defclass option ~S is not supported by the bootstrap~%~
+                    object system."
+		   (car option)))
+	  (setq default-initargs
+		(nconc default-initargs (reverse (cdr option)))))))
+    (reverse default-initargs)))
+
+
+;;;
+;;; bootstrap-get-slot and bootstrap-set-slot are used to access and change
+;;; the values of slots during bootstrapping.  During bootstrapping, there
+;;; are only two kinds of objects whose slots we need to access, CLASSes
+;;; and SLOTDs.  The first argument to these functions tells whether the
+;;; object is a CLASS or a SLOTD.
+;;;
+;;; Note that the way this works it stores the slot in the same place in
+;;; memory that the full object system will expect to find it later.  This
+;;; is critical to the bootstrapping process, the whole changeover to the
+;;; full object system is predicated on this.
+;;;
+;;; One important point is that the layout of standard classes and standard
+;;; slots must be computed the same way in this file as it is by the full
+;;; object system later.
+;;; 
+(defun bootstrap-get-slot (type object slot-name)
+  (let ((index (bootstrap-slot-index type slot-name)))
+    (svref (std-instance-slots object) index)))
+
+(defun bootstrap-set-slot (type object slot-name new-value)
+  (let ((index (bootstrap-slot-index type slot-name)))
+    (setf (svref (std-instance-slots object) index) new-value)))
+
+(defvar *std-class-slots*
+	(mapcar #'canonical-slot-name
+		(early-collect-inheritance 'standard-class)))
+
+(defvar *bin-class-slots*
+	(mapcar #'canonical-slot-name
+		(early-collect-inheritance 'built-in-class)))
+
+(defvar *std-slotd-slots*
+	(mapcar #'canonical-slot-name
+		(early-collect-inheritance 'standard-slot-definition)))
+
+(defun bootstrap-slot-index (type slot-name)
+  (or (position slot-name (ecase type
+			    (std-class *std-class-slots*)
+			    (bin-class *bin-class-slots*)
+			    (std-slotd *std-slotd-slots*)))
+      (error "~S not found" slot-name)))
+
+
+;;;
+;;; bootstrap-meta-braid
+;;;
+;;; This function builds the base metabraid from the early class definitions.
+;;;   
+(defun bootstrap-meta-braid ()
+  (let* ((std-class-size (length *std-class-slots*))
+         (std-class (%allocate-instance--class std-class-size))
+         (std-class-wrapper (make-wrapper std-class))
+	 (built-in-class (%allocate-instance--class std-class-size))
+	 (built-in-class-wrapper (make-wrapper built-in-class))
+	 (direct-slotd    (%allocate-instance--class std-class-size))
+	 (effective-slotd (%allocate-instance--class std-class-size))
+	 (direct-slotd-wrapper    (make-wrapper direct-slotd))
+	 (effective-slotd-wrapper (make-wrapper effective-slotd)))
+    ;;
+    ;; First, make a class metaobject for each of the early classes.  For
+    ;; each metaobject we also set its wrapper.  Except for the class T,
+    ;; the wrapper is always that of STANDARD-CLASS.
+    ;; 
+    (dolist (definition *early-class-definitions*)
+      (let* ((name (ecd-class-name definition))
+	     (meta (ecd-metaclass definition))
+             (class (case name
+                      (standard-class                     std-class)
+                      (standard-direct-slot-definition    direct-slotd)
+		      (standard-effective-slot-definition effective-slotd)
+		      (built-in-class                     built-in-class)
+                      (otherwise
+			(%allocate-instance--class std-class-size)))))
+	(unless (eq name t)
+	  (inform-type-system-about-class class name))
+	(setf (std-instance-wrapper class)
+	      (ecase meta
+		(standard-class std-class-wrapper)
+		(built-in-class built-in-class-wrapper)))
+        (setf (find-class name) class)))
+    ;;
+    ;;
+    ;;
+    (dolist (definition *early-class-definitions*)
+      (let ((name (ecd-class-name definition))
+	    (source (ecd-source definition))
+	    (direct-supers (ecd-superclass-names definition))
+	    (direct-slots  (ecd-canonical-slots definition))
+	    (other-initargs (ecd-other-initargs definition)))
+	(let ((direct-default-initargs
+		(getf other-initargs :default-initargs)))
+	  (multiple-value-bind (slots cpl default-initargs direct-subclasses)
+	      (early-collect-inheritance name)
+	    (let* ((class (find-class name))
+		   (wrapper
+		     (cond
+		       ((eq class std-class)       std-class-wrapper)
+		       ((eq class direct-slotd)    direct-slotd-wrapper)
+		       ((eq class effective-slotd) effective-slotd-wrapper)
+		       ((eq class built-in-class)  built-in-class-wrapper)
+		       (t (make-wrapper class))))
+		   (proto nil))
+	      (cond ((eq name 't)
+		     (setq *the-wrapper-of-t* wrapper
+			   *the-class-t* class))
+		    ((memq name '(standard-object 
+				  standard-class
+				  standard-effective-slot-definition))
+		     (set (intern (format nil "*THE-CLASS-~A*" (symbol-name name))
+				  *the-clos-package*)
+			  class)))
+	      (dolist (slot slots)
+		(unless (eq (getf slot :allocation :instance) :instance)
+		  (error "Slot allocation ~S not supported in bootstrap.")))
+	      
+	      (setf (wrapper-instance-slots-layout wrapper)
+		    (mapcar #'canonical-slot-name slots))
+	      (setf (wrapper-class-slots wrapper)
+		    ())
+	      
+	      (setq proto (%allocate-instance--class (length slots)))
+	      (setf (std-instance-wrapper proto) wrapper)
+	    
+	      (setq direct-slots
+		    (bootstrap-make-slot-definitions name direct-slots
+						     direct-slotd-wrapper nil))
+	      (setq slots
+		    (bootstrap-make-slot-definitions name slots
+						     effective-slotd-wrapper t))
+	      
+	      (bootstrap-initialize-std-class
+		class name source
+		direct-supers direct-subclasses cpl wrapper
+		direct-slots slots direct-default-initargs default-initargs
+		proto)
+	      
+	      (dolist (slotd direct-slots)
+		(bootstrap-accessor-definitions
+		  name
+		  (bootstrap-get-slot 'std-slotd slotd 'name)
+		  (bootstrap-get-slot 'std-slotd slotd 'readers)
+		  (bootstrap-get-slot 'std-slotd slotd 'writers))))))))))
+
+(defun bootstrap-accessor-definitions (class-name slot-name readers writers)
+  (flet ((do-reader-definition (reader)
+	   (add-method
+	     (ensure-generic-function reader)
+	     (make-a-method
+	       'standard-reader-method
+	       ()
+	       (list class-name)
+	       (list class-name)
+	       (make-std-reader-method-function slot-name)
+	       "automatically generated reader method"
+	       slot-name)))
+	 (do-writer-definition (writer)
+	   (add-method
+	     (ensure-generic-function writer)
+	     (make-a-method
+	       'standard-writer-method
+	       ()
+	       (list 'new-value class-name)
+	       (list 't class-name)
+	       (make-std-writer-method-function slot-name)
+	       "automatically generated writer method"
+	       slot-name))))
+    (dolist (reader readers) (do-reader-definition reader))
+    (dolist (writer writers) (do-writer-definition writer))))
+
+;;;
+;;; Initialize a standard class metaobject.
+;;;
+(defun bootstrap-initialize-std-class
+       (class
+	name definition-source direct-supers direct-subclasses cpl wrapper
+	direct-slots slots direct-default-initargs default-initargs proto)
+  (flet ((classes (names) (mapcar #'find-class names))
+	 (set-slot (slot-name value)
+	   (bootstrap-set-slot 'std-class class slot-name value)))
+    
+    (set-slot 'name name)
+    (set-slot 'source definition-source)
+    (set-slot 'class-precedence-list (classes cpl))
+    (set-slot 'direct-superclasses (classes direct-supers))
+    (set-slot 'direct-slots direct-slots)
+    (set-slot 'direct-subclasses (classes direct-subclasses))
+    (set-slot 'direct-methods (cons nil nil))
+    (set-slot 'no-of-instance-slots (length slots))
+    (set-slot 'slots slots)
+    (set-slot 'wrapper wrapper)
+    (set-slot 'prototype proto)
+    (set-slot 'plist
+	      `(,@(and direct-default-initargs
+		       `(direct-default-initargs ,direct-default-initargs))
+		,@(and default-initargs
+		       `(default-initargs ,default-initargs))))
+    ))
+
+;;;
+;;; Initialize a built-in-class metaobject.
+;;;
+(defun bootstrap-initialize-bin-class
+       (class
+	name definition-source direct-supers direct-subclasses cpl wrapper)
+  (flet ((classes (names) (mapcar #'find-class names))
+	 (set-slot (slot-name value)
+	   (bootstrap-set-slot 'bin-class class slot-name value)))
+    
+    (set-slot 'name name)
+    (set-slot 'source definition-source)
+    (set-slot 'direct-superclasses (classes direct-supers))
+    (set-slot 'direct-subclasses (classes direct-subclasses))
+    (set-slot 'direct-methods (cons nil nil))
+    (set-slot 'class-precedence-list (classes cpl))
+    (set-slot 'wrapper wrapper)))
+
+(defun bootstrap-make-slot-definitions (name slots wrapper e-p)
+  (mapcar #'(lambda (slot) (bootstrap-make-slot-definition name slot wrapper e-p))
+          slots))
+
+(defun bootstrap-make-slot-definition (name slot wrapper e-p)  
+  (let ((slotd (%allocate-instance--class (length *std-slotd-slots*))))
+    (setf (std-instance-wrapper slotd) wrapper)
+    (flet ((get-val (name) (getf slot name))
+	   (set-val (name val) (bootstrap-set-slot 'std-slotd slotd name val)))
+      (set-val 'name         (get-val :name))
+      (set-val 'initform     (get-val :initform))
+      (set-val 'initfunction (get-val :initfunction))      
+      (set-val 'initargs     (get-val :initargs))
+      (set-val 'readers      (get-val :readers))
+      (set-val 'writers      (get-val :writers))
+      (set-val 'allocation   :instance)
+      (set-val 'type         (get-val :type))
+      (set-val 'class        nil)
+      (set-val 'instance-index nil)
+      (when (and (eq name 'standard-class) (eq (get-val :name) 'slots) e-p)
+	(setq *the-eslotd-standard-class-slots* slotd))
+      slotd)))
+
+(defun bootstrap-built-in-classes ()
+  ;;
+  ;; First make sure that all the supers listed in *built-in-class-lattice*
+  ;; are themselves defined by *built-in-class-lattice*.  This is just to
+  ;; check for typos and other sorts of brainos.
+  ;; 
+  (dolist (e *built-in-classes*)
+    (dolist (super (cadr e))
+      (unless (or (eq super 't)
+		  (assq super *built-in-classes*))
+	(error "In *built-in-classes*: ~S has ~S as a super,~%~
+                but ~S is not itself a class in *built-in-classes*."
+	       (car e) super super))))
+
+  ;;
+  ;; In the first pass, we create a skeletal object to be bound to the
+  ;; class name.
+  ;;
+  (let* ((built-in-class (find-class 'built-in-class))
+	 (built-in-class-wrapper (class-wrapper built-in-class))
+	 (bin-class-size (length *bin-class-slots*)))
+    (dolist (e *built-in-classes*)
+      (let ((class (%allocate-instance--class bin-class-size)))
+	(setf (std-instance-wrapper class) built-in-class-wrapper)
+	(setf (find-class (car e)) class))))
+
+  ;;
+  ;; In the second pass, we initialize the class objects.
+  ;;
+  (dolist (e *built-in-classes*)
+    (destructuring-bind (name supers subs cpl) e
+      (let* ((class (find-class name))
+	     (wrapper (make-wrapper class)))
+	(set (get-built-in-class-symbol name) class)
+	(set (get-built-in-wrapper-symbol name) wrapper)
+
+	(setf (wrapper-instance-slots-layout wrapper) ()
+	      (wrapper-class-slots wrapper) ())
+
+	(bootstrap-initialize-bin-class class
+					name nil
+					supers subs
+					(cons name cpl) wrapper)
+	))))
+
+
+;;;
+;;;
+;;;
+
+(defun class-of (x) (wrapper-class (wrapper-of x)))
+
+(defun wrapper-of (x) 
+  (or (and (std-instance-p x)
+	   (std-instance-wrapper x))
+      (and (fsc-instance-p x)
+	   (fsc-instance-wrapper x))
+      (built-in-wrapper-of x)
+      (error "Can't determine wrapper of ~S" x)))
+
+
+(eval-when (compile eval)
+
+(defun make-built-in-class-subs ()
+  (mapcar #'(lambda (e)
+	      (let ((class (car e))
+		    (class-subs ()))
+		(dolist (s *built-in-classes*)
+		  (when (memq class (cadr s)) (pushnew (car s) class-subs)))
+		(cons class class-subs)))
+	  (cons '(t) *built-in-classes*)))
+
+(defun make-built-in-class-tree ()
+  (let ((subs (make-built-in-class-subs)))
+    (labels ((descend (class)
+	       (cons class (mapcar #'descend (cdr (assq class subs))))))
+      (descend 't))))
+
+(defun make-built-in-wrapper-of-body ()
+  (make-built-in-wrapper-of-body-1 (make-built-in-class-tree)
+				   'x
+				   #'get-built-in-wrapper-symbol))
+
+(defun make-built-in-wrapper-of-body-1 (tree var get-symbol)
+  (let ((*specials* ()))
+    (declare (special *specials*))
+    (let ((inner (make-built-in-wrapper-of-body-2 tree var get-symbol)))
+      `(locally (declare (special .,*specials*)) ,inner))))
+
+(defun make-built-in-wrapper-of-body-2 (tree var get-symbol)
+  (declare (special *specials*))
+  (let ((symbol (funcall get-symbol (car tree))))
+    (push symbol *specials*)
+    (let ((sub-tests
+	    (mapcar #'(lambda (x)
+			(make-built-in-wrapper-of-body-2 x var get-symbol))
+		    (cdr tree))))
+      `(and (typep ,var ',(car tree))
+	    ,(if sub-tests
+		 `(or ,.sub-tests ,symbol)
+		 symbol)))))
+)
+
+(defun built-in-wrapper-of (x)
+  #.(make-built-in-wrapper-of-body))
+
+
+
+
+(eval-when (load eval)
+  (clrhash *find-class*)
+  (bootstrap-meta-braid)
+  (bootstrap-built-in-classes)
+  (setq *boot-state* 'braid)
+  (setf (symbol-function 'load-defclass) #'real-load-defclass)
+  )
+
+
+;;;
+;;; All of these method definitions must appear here because the bootstrap
+;;; only allows one method per generic function until the braid is fully
+;;; built.
+;;;
+(defmethod print-object (instance stream)
+  (printing-random-thing (instance stream)
+    (let ((name (class-name (class-of instance))))
+      (if name
+	  (format stream "~S" name)
+	  (format stream "Instance")))))
+
+(defmethod print-object ((class class) stream)
+  (named-object-print-function class stream))
+
+(defmethod print-object ((slotd standard-slot-definition) stream)
+  (named-object-print-function slotd stream))
+
+(defun named-object-print-function (instance stream
+				    &optional (extra nil extra-p))
+  (printing-random-thing (instance stream)
+    (if extra-p					
+	(format stream "~A ~S ~:S"
+		(capitalize-words (class-name (class-of instance)))
+		(slot-value-or-default instance 'name)
+		extra)
+	(format stream "~A ~S"
+		(capitalize-words (class-name (class-of instance)))
+		(slot-value-or-default instance 'name)))))
+
+
+;;;
+;;;
+;;;
+;(defmethod shared-initialize :after ((class class) slot-names &key name)
+;  (declare (ignore slot-names))
+;  (setf (slot-value class 'name) name))
+;
+;
+;(defmethod shared-initialize :after ((class std-class)
+;				     slot-names
+;				     &key direct-superclasses
+;					  direct-slots)
+; (declare (ignore slot-names))
+; (setf (slot-value class 'direct-superclasses) direct-superclasses
+;	(slot-value class 'direct-slots) direct-slots))
+
+;;;
+;;;
+;;;
+(defmethod shared-initialize :after ((slotd standard-slot-definition)
+				     slot-names
+				     &key class
+					  name
+					  initform
+					  initfunction
+					  initargs 
+					  (allocation :instance)
+					  (type t)
+					  readers
+					  writers)
+  (declare (ignore slot-names))
+  (setf (slot-value slotd 'name) name
+	(slot-value slotd 'initform) initform
+	(slot-value slotd 'initfunction) initfunction
+	(slot-value slotd 'initargs) initargs 
+	(slot-value slotd 'allocation) (if (eq allocation :class) class allocation)
+	(slot-value slotd 'type) type
+	(slot-value slotd 'readers) readers
+	(slot-value slotd 'writers) writers))
+
diff --git a/clos/3.5/cache.dfasl b/clos/3.5/cache.dfasl
new file mode 100644
index 00000000..3b1151d1
Binary files /dev/null and b/clos/3.5/cache.dfasl differ
diff --git a/clos/3.5/cache.lisp b/clos/3.5/cache.lisp
new file mode 100644
index 00000000..068ab817
--- /dev/null
+++ b/clos/3.5/cache.lisp
@@ -0,0 +1,1089 @@
+;;;-*-Mode:LISP; Package:(CLOS LISP 1000); Base:10; Syntax:Common-lisp -*-
+;;;
+;;; *************************************************************************
+;;; Copyright (c) 1991 Venue
+;;; All rights reserved.
+;;; *************************************************************************
+;;;
+;;; The basics of the CLOS wrapper cache mechanism.
+;;;
+
+(in-package 'clos)
+;;;
+;;; The caching algorithm implemented:
+;;;
+;;; << put a paper here >>
+;;;
+;;; For now, understand that as far as most of this code goes, a cache has
+;;; two important properties.  The first is the number of wrappers used as
+;;; keys in each cache line.  Throughout this code, this value is always
+;;; called NKEYS.  The second is whether or not the cache lines of a cache
+;;; store a value.  Throughout this code, this always called VALUEP.
+;;;
+;;; Depending on these values, there are three kinds of caches.
+;;;
+;;; NKEYS = 1, VALUEP = NIL
+;;;
+;;; In this kind of cache, each line is 1 word long.  No cache locking is
+;;; needed since all read's in the cache are a single value.  Nevertheless
+;;; line 0 (location 0) is reserved, to ensure that invalid wrappers will
+;;; not get a first probe hit.
+;;;
+;;; To keep the code simpler, a cache lock count does appear in location 0
+;;; of these caches, that count is incremented whenever data is written to
+;;; the cache.  But, the actual lookup code (see make-dlap) doesn't need to
+;;; do locking when reading the cache.
+;;; 
+;;;
+;;; NKEYS = 1, VALUEP = T
+;;;
+;;; In this kind of cache, each line is 2 words long.  Cache locking must
+;;; be done to ensure the synchronization of cache reads.  Line 0 of the
+;;; cache (location 0) is reserved for the cache lock count.  Location 1
+;;; of the cache is unused (in effect wasted).
+;;; 
+;;; NKEYS > 1
+;;;
+;;; In this kind of cache, the 0 word of the cache holds the lock count.
+;;; The 1 word of the cache is line 0.  Line 0 of these caches is not
+;;; reserved.
+;;;
+;;; This is done because in this sort of cache, the overhead of doing the
+;;; cache probe is high enough that the 1+ required to offset the location
+;;; is not a significant cost.  In addition, because of the larger line
+;;; sizes, the space that would be wasted by reserving line 0 to hold the
+;;; lock count is more significant.
+;;;
+
+
+;;;
+;;; Caches
+;;;
+;;; A cache is essentially just a vector.  The use of the individual `words'
+;;; in the vector depends on particular properties of the cache as described
+;;; above.
+;;;
+;;; This defines an abstraction for caches in terms of their most obvious
+;;; implementation as simple vectors.  But, please notice that part of the
+;;; implementation of this abstraction, is the function lap-out-cache-ref.
+;;; This means that most port-specific modifications to the implementation
+;;; of caches will require corresponding port-specific modifications to the
+;;; lap code assembler.
+;;;
+(defmacro cache-ref (cache location)
+  `(svref (the simple-vector ,cache) (the fixnum ,location)))
+
+(defun emit-cache-ref (cache-operand location-operand)
+  (operand :iref cache-operand location-operand))
+
+
+(defun cache-size (cache)
+  (array-dimension (the simple-vector cache) 0))
+
+(defun allocate-cache (size)
+  (make-array size :adjustable nil))
+
+(defmacro cache-lock-count (cache)
+  `(cache-ref ,cache 0))
+
+(defun flush-cache-internal (cache)
+  (without-interrupts  
+    (fill (the simple-vector cache) nil)
+    (setf (cache-lock-count cache) 0))
+  cache)
+
+(defmacro modify-cache (cache &body body)
+  `(without-interrupts
+     (multiple-value-prog1
+       (progn ,@body)
+       (let ((old-count (cache-lock-count ,cache)))
+	 (setf (cache-lock-count ,cache)
+	       (if (= old-count most-positive-fixnum) 1 (1+ old-count)))))))
+
+
+
+;;;
+;;; Some facilities for allocation and freeing caches as they are needed.
+;;; This is done on the assumption that a better port of CLOS will arrange
+;;; to cons these all the same static area.  Given that, the fact that
+;;; CLOS tries to reuse them should be a win.
+;;; 
+(defvar *free-caches* (make-hash-table :size 16))
+
+;;;
+;;; Return a cache that has had flush-cache-internal called on it.  This
+;;; returns a cache of exactly the size requested, it won't ever return a
+;;; larger cache.
+;;; 
+(defun get-cache (size)
+  (let ((entry (gethash size *free-caches*)))
+    (without-interrupts
+      (cond ((null entry)
+	     (setf (gethash size *free-caches*) (cons 0 nil))
+	     (get-cache size))
+	    ((null (cdr entry))
+	     (incf (car entry))
+	     (flush-cache-internal (allocate-cache size)))
+	    (t
+	     (let ((cache (cdr entry)))
+	       (setf (cdr entry) (cache-ref cache 0))
+	       (flush-cache-internal cache)))))))
+
+(defun free-cache (cache)
+  (let ((entry (gethash (cache-size cache) *free-caches*)))
+    (without-interrupts
+      (if (null entry)
+	  (error "Attempt to free a cache not allocated by GET-CACHE.")
+	  (let ((thread (cdr entry)))
+	    (loop (unless thread (return))
+		  (when (eq thread cache) (error "Freeing a cache twice."))
+		  (setq thread (cache-ref thread 0)))	  
+	    (flush-cache-internal cache)		;Help the GC
+	    (setf (cache-ref cache 0) (cdr entry))
+	    (setf (cdr entry) cache)
+	    nil)))))
+
+;;;
+;;; This is just for debugging and analysis.  It shows the state of the free
+;;; cache resource.
+;;; 
+(defun show-free-caches ()
+  (let ((elements ()))
+    (maphash #'(lambda (s e) (push (list s e) elements)) *free-caches*)
+    (setq elements (sort elements #'< :key #'car))
+    (dolist (e elements)
+      (let* ((size (car e))
+	     (entry (cadr e))
+	     (allocated (car entry))
+	     (head (cdr entry))
+	     (free 0))
+	(loop (when (null head) (return t))
+	      (setq head (cache-ref head 0))
+	      (incf free))
+	(format t
+		"~&There  ~4D are caches of size ~4D. (~D free  ~3D%)"
+		allocated
+		size
+		free
+		(floor (* 100 (/ free (float allocated)))))))))
+
+
+;;;
+;;; Wrapper cache numbers
+;;; 
+
+;;;
+;;; The constant WRAPPER-CACHE-NUMBER-ADDS-OK controls the number of non-zero
+;;; bits wrapper cache numbers will have.
+;;;
+;;; The value of this constant is the number of wrapper cache numbers which
+;;; can be added and still be certain the result will be a fixnum.  This is
+;;; used by all the code that computes primary cache locations from multiple
+;;; wrappers.
+;;;
+;;; The value of this constant is used to derive the next two which are the
+;;; forms of this constant which it is more convenient for the runtime code
+;;; to use.
+;;; 
+(eval-when (compile load eval)
+
+(defconstant wrapper-cache-number-adds-ok 4)
+
+(defconstant wrapper-cache-number-length
+	     (- (integer-length most-positive-fixnum)
+		wrapper-cache-number-adds-ok))
+
+(defconstant wrapper-cache-number-mask
+	     (1- (expt 2 wrapper-cache-number-length)))
+
+
+(defvar *get-wrapper-cache-number* (make-random-state))
+
+(defun get-wrapper-cache-number ()
+  (let ((n 0))
+    (loop
+      (setq n
+	    (logand wrapper-cache-number-mask
+		    (random most-positive-fixnum *get-wrapper-cache-number*)))
+      (unless (zerop n) (return n)))))
+
+
+(unless (> wrapper-cache-number-length 8)
+  (error "In this implementation of Common Lisp, fixnums are so small that~@
+          wrapper cache numbers end up being only ~D bits long.  This does~@
+          not actually keep CLOS from running, but it may degrade cache~@
+          performance.~@
+          You may want to consider changing the value of the constant~@
+          WRAPPER-CACHE-NUMBER-ADDS-OK.")))
+
+
+;;;
+;;; wrappers themselves
+;;;
+;;; This caching algorithm requires that wrappers have more than one wrapper
+;;; cache number.  You should think of these multiple numbers as being in
+;;; columns.  That is, for a given cache, the same column of wrapper cache
+;;; numbers will be used.
+;;;
+;;; If at some point the cache distribution of a cache gets bad, the cache
+;;; can be rehashed by switching to a different column.
+;;;
+;;; The columns are referred to by field number which is that number which,
+;;; when used as a second argument to wrapper-ref, will return that column
+;;; of wrapper cache number.
+;;;
+;;; This code is written to allow flexibility as to how many wrapper cache
+;;; numbers will be in each wrapper, and where they will be located.  It is
+;;; also set up to allow port specific modifications to `pack' the wrapper
+;;; cache numbers on machines where the addressing modes make that a good
+;;; idea.
+;;; 
+(eval-when (compile load eval)
+(defconstant wrapper-layout
+	     '(number
+	       number
+	       number
+	       number
+	       number
+	       number
+	       number
+	       number
+	       state
+	       instance-slots-layout
+	       class-slots
+	       class))
+)
+
+(eval-when (compile load eval)
+
+(defun wrapper-field (type)
+  (position type wrapper-layout))
+
+(defun next-wrapper-field (field-number)
+  (position (nth field-number wrapper-layout)
+	    wrapper-layout
+	    :start (1+ field-number)))
+
+);eval-when
+
+(defmacro wrapper-ref (wrapper n)
+  `(svref ,wrapper ,n))
+
+(defun emit-wrapper-ref (wrapper-operand field-operand)
+  (operand :iref wrapper-operand field-operand))
+
+	      
+(defmacro wrapper-state (wrapper)
+  `(wrapper-ref ,wrapper ,(wrapper-field 'state)))
+
+(defmacro wrapper-instance-slots-layout (wrapper)
+  `(wrapper-ref ,wrapper ,(wrapper-field 'instance-slots-layout)))
+
+(defmacro wrapper-class-slots (wrapper)
+  `(wrapper-ref ,wrapper ,(wrapper-field 'class-slots)))
+
+(defmacro wrapper-class (wrapper)
+  `(wrapper-ref ,wrapper ,(wrapper-field 'class)))
+
+
+(defmacro make-wrapper-internal ()
+  `(let ((wrapper (make-array ,(length wrapper-layout) :adjustable nil)))
+     ,@(gathering1 (collecting)
+	 (iterate ((i (interval :from 0))
+		   (desc (list-elements wrapper-layout)))
+	   (ecase desc
+	     (number
+	      (gather1 `(setf (wrapper-ref wrapper ,i)
+			      (get-wrapper-cache-number))))
+	     ((state instance-slots-layout class-slots class)))))
+     (setf (wrapper-state wrapper) 't)     
+     wrapper))
+
+(defun make-wrapper (class)
+  (let ((wrapper (make-wrapper-internal)))
+    (setf (wrapper-class wrapper) class)
+    wrapper))
+
+;;;
+;;; The wrapper cache machinery provides general mechanism for trapping on
+;;; the next access to any instance of a given class.  This mechanism is
+;;; used to implement the updating of instances when the class is redefined
+;;; (make-instances-obsolete).  The same mechanism is also used to update
+;;; generic function caches when there is a change to the supers of a class.
+;;;
+;;; Basically, a given wrapper can be valid or invalid.  If it is invalid,
+;;; it means that any attempt to do a wrapper cache lookup using the wrapper
+;;; should trap.  Also, methods on slot-value-using-class check the wrapper
+;;; validity as well.  This is done by calling check-wrapper-validity.
+;;; 
+
+(defun invalid-wrapper-p (wrapper)
+  (neq (wrapper-state wrapper) 't))
+
+(defvar *previous-nwrappers* (make-hash-table))
+
+(defun invalidate-wrapper (owrapper state nwrapper)
+  (ecase state
+    ((flush obsolete)
+     (let ((new-previous ()))
+       ;;
+       ;; First off, a previous call to invalidate-wrapper may have recorded
+       ;; owrapper as an nwrapper to update to.  Since owrapper is about to
+       ;; be invalid, it no longer makes sense to update to it.
+       ;;
+       ;; We go back and change the previously invalidated wrappers so that
+       ;; they will now update directly to nwrapper.  This corresponds to a
+       ;; kind of transitivity of wrapper updates.
+       ;; 
+       (dolist (previous (gethash owrapper *previous-nwrappers*))
+	 (when (eq state 'obsolete)
+	   (setf (car previous) 'obsolete))
+	 (setf (cadr previous) nwrapper)
+	 (push previous new-previous))
+       
+       (iterate ((type (list-elements wrapper-layout))
+		 (i (interval :from 0)))
+	 (when (eq type 'number) (setf (wrapper-ref owrapper i) 0)))
+       (push (setf (wrapper-state owrapper) (list state nwrapper))
+	     new-previous)
+       
+       (setf (gethash owrapper *previous-nwrappers*) ()
+	     (gethash nwrapper *previous-nwrappers*) new-previous)))))
+
+(defun check-wrapper-validity (instance)
+  (let* ((owrapper (wrapper-of instance))
+	 (state (wrapper-state owrapper)))
+    (if (eq state  't)
+	owrapper
+	(let ((nwrapper
+		(ecase (car state)
+		  (flush
+		    (flush-cache-trap owrapper (cadr state) instance))
+		  (obsolete
+		    (obsolete-instance-trap owrapper (cadr state) instance)))))
+	  ;;
+	  ;; This little bit of error checking is superfluous.  It only
+	  ;; checks to see whether the person who implemented the trap
+	  ;; handling screwed up.  Since that person is hacking internal
+	  ;; CLOS code, and is not a user, this should be needless.  Also,
+	  ;; since this directly slows down instance update and generic
+	  ;; function cache refilling, feel free to take it out sometime
+	  ;; soon.
+	  ;; 
+	  (cond ((neq nwrapper (wrapper-of instance))
+		 (error "Wrapper returned from trap not wrapper of instance."))
+		((invalid-wrapper-p nwrapper)
+		 (error "Wrapper returned from trap invalid.")))
+	  nwrapper))))
+
+
+
+(defun compute-line-size (nelements) (expt 2 (ceiling (log nelements 2))))
+
+(defun compute-cache-parameters (nkeys valuep nlines-or-cache)
+  (declare (values cache-mask actual-size line-size nlines))
+  (flet ((compute-mask (cache-size line-size)
+	   (logxor (1- cache-size) (1- line-size))))
+    (if (= nkeys 1)
+	(let* ((line-size (if valuep 2 1))
+	       (cache-size (if (numberp nlines-or-cache)
+			       (* line-size
+				  (expt 2 (ceiling (log nlines-or-cache 2))))
+			       (cache-size nlines-or-cache))))
+	  (values (compute-mask cache-size line-size)
+		  cache-size
+		  line-size
+		  (/ cache-size line-size)))
+	(let* ((line-size (compute-line-size (+ nkeys (if valuep 1 0))))
+	       (cache-size (if (numberp nlines-or-cache)
+			       (* line-size 
+				  (expt 2 (ceiling (log nlines-or-cache 2))))
+			       (1- (cache-size nlines-or-cache)))))
+	  (values (compute-mask cache-size line-size)
+		  (1+ cache-size)
+		  line-size
+		  (/ cache-size line-size))))))
+
+
+
+;;;
+;;; The various implementations of computing a primary cache location from
+;;; wrappers.  Because some implementations of this must run fast there are
+;;; several implementations of the same algorithm.
+;;;
+;;; The algorithm is:
+;;;
+;;;  SUM       over the wrapper cache numbers,
+;;;  ENSURING  that the result is a fixnum
+;;;  MASK      the result against the mask argument.
+;;;
+;;;
+
+;;;
+;;; COMPUTE-PRIMARY-CACHE-LOCATION
+;;; 
+;;; The basic functional version.  This is used by the cache miss code to
+;;; compute the primary location of an entry.  
+;;;
+(defun compute-primary-cache-location (field mask wrappers)
+  (if (not (consp wrappers))
+      (logand mask (wrapper-ref wrappers field))
+      (let ((location 0))
+	(iterate ((wrapper (list-elements wrappers))
+		  (i (interval :from 0)))
+	  ;;
+	  ;; First add the cache number of this wrapper to location.
+	  ;; 
+	  (let ((wrapper-cache-number (wrapper-ref wrapper field)))
+	    (if (zerop wrapper-cache-number)
+		(return-from compute-primary-cache-location 0)
+		(setq location (+ location wrapper-cache-number))))
+	  ;;
+	  ;; Then, if we are working with lots of wrappers, deal with
+	  ;; the wrapper-cache-number-mask stuff.
+	  ;; 
+	  (when (and (not (zerop i))
+		     (zerop (mod i wrapper-cache-number-adds-ok)))
+	    (setq location
+		  (logand location wrapper-cache-number-mask))))
+	(1+ (logand mask location)))))
+
+;;;
+;;; COMPUTE-PRIMARY-CACHE-LOCATION-FROM-LOCATION
+;;;
+;;; This version is called on a cache line.  It fetches the wrappers from
+;;; the cache line and determines the primary location.  Various parts of
+;;; the cache filling code call this to determine whether it is appropriate
+;;; to displace a given cache entry.
+;;; 
+;;; If this comes across a wrapper whose cache-no is 0, it returns the symbol
+;;; invalid to suggest to its caller that it would be provident to blow away
+;;; the cache line in question.
+;;;
+(defun compute-primary-cache-location-from-location (field cache location mask nkeys)
+  (let ((result 0))
+    (dotimes (i nkeys)
+      (let* ((wrapper (cache-ref cache (+ i location)))
+	     (wcn (wrapper-ref wrapper field)))
+	(setq result (+ result wcn)))
+      (when (and (not (zerop i))
+		 (zerop (mod i wrapper-cache-number-adds-ok)))
+	(setq result (logand result wrapper-cache-number-mask)))
+      )    
+    (if (= nkeys 1)
+	(logand mask result)
+	(1+ (logand mask result)))))
+
+(defun emit-1-wrapper-compute-primary-cache-location (wrapper primary wrapper-cache-no)
+  (with-lap-registers ((mask index))
+    (let ((field wrapper-cache-no))
+      (flatten-lap
+        (opcode :move (operand :cvar 'mask) mask)
+        (opcode :move (operand :cvar 'field) field)
+        (opcode :move (emit-wrapper-ref wrapper field) wrapper-cache-no)
+        (opcode :move (operand :ilogand wrapper-cache-no mask) primary)))))
+
+(defun emit-n-wrapper-compute-primary-cache-location (wrappers primary miss-label)
+  (with-lap-registers ((field index)
+		       (mask index))
+    (let ((add-wrapper-cache-numbers
+	   (flatten-lap
+	    (gathering1 (flattening-lap)
+	       (iterate ((wrapper (list-elements wrappers))
+			 (i (interval :from 1)))
+		 (gather1
+		  (with-lap-registers ((wrapper-cache-no index))
+		    (flatten-lap
+		     (opcode :move (emit-wrapper-ref wrapper field) wrapper-cache-no)
+		     (opcode :izerop wrapper-cache-no miss-label)
+		     (opcode :move (operand :i+ primary wrapper-cache-no) primary)
+		     (when (zerop (mod i wrapper-cache-number-adds-ok))
+		       (opcode :move (operand :ilogand primary mask) primary))))))))))
+      (flatten-lap
+       (opcode :move (operand :constant 0) primary)
+       (opcode :move (operand :cvar 'field) field)
+       (opcode :move (operand :cvar 'mask) mask)
+       add-wrapper-cache-numbers
+       (opcode :move (operand :ilogand primary mask) primary)
+       (opcode :move (operand :i1+ primary) primary)))))
+
+
+
+;;;
+;;;  NIL              means nothing so far, no actual arg info has NILs
+;;;                   in the metatype
+;;;  CLASS            seen all sorts of metaclasses
+;;;                   (specifically, more than one of the next 4 values)
+;;;  T                means everything so far is the class T
+;;;  STANDARD-CLASS   seen only standard classes
+;;;  BUILT-IN-CLASS   seen only built in classes
+;;;  STRUCTURE-CLASS  seen only structure classes
+;;;  
+(defun raise-metatype (metatype new-specializer)
+  (let ((standard  (find-class 'standard-class))
+	(fsc       (find-class 'funcallable-standard-class))
+;	(structure (find-class 'structure-class))
+	(built-in  (find-class 'built-in-class)))
+    (flet ((specializer->metatype (x)
+	     (let ((meta-specializer 
+		     (if (and (eq *boot-state* 'complete)
+			      (eql-specializer-p x))
+			 (class-of (class-of (eql-specializer-object x)))
+			 (class-of x))))
+	       (cond ((eq x *the-class-t*) t)
+		     ((*subtypep meta-specializer standard)  'standard-instance)
+		     ((*subtypep meta-specializer fsc)       'standard-instance)
+;                    ((*subtypep meta-specializer structure) 'structure-instance)
+		     ((*subtypep meta-specializer built-in)  'built-in-instance)
+		     (t (error "CLOS can not handle the specializer ~S (meta-specializer ~S)."
+			       new-specializer meta-specializer))))))
+      ;;
+      ;; We implement the following table.  The notation is
+      ;; that X and Y are distinct meta specializer names.
+      ;; 
+      ;;   NIL    <anything>    ===>  <anything>
+      ;;    X      X            ===>      X
+      ;;    X      Y            ===>    CLASS
+      ;;    
+      (let ((new-metatype (specializer->metatype new-specializer)))
+	(cond ((null metatype) new-metatype)
+	      ((eq metatype new-metatype) new-metatype)
+	      (t 'class))))))
+
+
+(defun emit-fetch-wrapper (metatype argument dest miss-label &optional slot)
+  (let ((exit-emit-fetch-wrapper (make-symbol "exit-emit-fetch-wrapper")))
+    (with-lap-registers ((arg t))
+      (ecase metatype
+	(standard-instance
+	  (let ((get-std-inst-wrapper (make-symbol "get-std-inst-wrapper"))
+		(get-fsc-inst-wrapper (make-symbol "get-fsc-inst-wrapper")))
+	    (flatten-lap
+	      (opcode :move (operand :arg argument) arg)
+	      (opcode :std-instance-p arg get-std-inst-wrapper)	   ;is it a std wrapper?
+	      (opcode :fsc-instance-p arg get-fsc-inst-wrapper)	   ;is it a fsc wrapper?
+	      (opcode :go miss-label)
+	      (opcode :label get-fsc-inst-wrapper)
+	      (opcode :move (operand :fsc-wrapper arg) dest)	   ;get fsc wrapper
+	      (and slot
+		   (opcode :move (operand :fsc-slots arg) slot))
+	      (opcode :go exit-emit-fetch-wrapper)
+	      (opcode :label get-std-inst-wrapper)
+	      (opcode :move (operand :std-wrapper arg) dest)	   ;get std wrapper
+	      (and slot
+		   (opcode :move (operand :std-slots arg) slot))
+	      (opcode :label exit-emit-fetch-wrapper))))
+
+	(class
+	  (when slot (error "Can't do a slot reg for this metatype."))
+	  (let ((get-std-inst-wrapper (make-symbol "get-std-inst-wrapper"))
+		(get-fsc-inst-wrapper (make-symbol "get-fsc-inst-wrapper"))
+		(get-built-in-wrapper (make-symbol "get-built-in-wrapper")))
+	    (flatten-lap
+	      (opcode :move (operand :arg argument) arg)
+	      (opcode :std-instance-p arg get-std-inst-wrapper)
+	      (opcode :fsc-instance-p arg get-fsc-inst-wrapper)
+	      (opcode :built-in-instance-p arg get-built-in-wrapper)
+	      ;; If the code falls through the checks above, there is a serious problem
+	      (opcode :label get-fsc-inst-wrapper)
+	      (opcode :move (operand :fsc-wrapper arg) dest)
+	      (opcode :go exit-emit-fetch-wrapper)
+	      (opcode :label get-built-in-wrapper)
+	      (opcode :move (operand :built-in-wrapper arg) dest)
+	      (opcode :go exit-emit-fetch-wrapper)
+	      (opcode :label get-std-inst-wrapper)
+	      (opcode :move (operand :std-wrapper arg) dest)
+	      (opcode :label exit-emit-fetch-wrapper))))
+	(structure-instance 
+	  (when slot (error "Can't do a slot reg for this metatype."))
+	  (error "Not yet implemented"))
+	(built-in-instance
+	  (when slot (error "Can't do a slot reg for this metatype."))
+	  (let ((get-built-in-wrapper (make-symbol "get-built-in-wrapper")))
+	    (flatten-lap
+	      (opcode :move (operand :arg argument) arg)
+	      (opcode :built-in-instance-p arg get-built-in-wrapper)
+	      (opcode :go miss-label)
+	      (opcode :label get-built-in-wrapper)
+	      (opcode :move (operand :built-in-wrapper arg) dest))))))))
+
+
+;;;
+;;; Some support stuff for getting a hold of symbols that we need when
+;;; building the discriminator codes.  Its ok for these to be interned
+;;; symbols because we don't capture any user code in the scope in which
+;;; these symbols are bound.
+;;; 
+
+(defvar *dfun-arg-symbols* '(.ARG0. .ARG1. .ARG2. .ARG3.))
+
+(defun dfun-arg-symbol (arg-number)
+  (or (nth arg-number (the list *dfun-arg-symbols*))
+      (intern (format nil ".ARG~A." arg-number) *the-clos-package*)))
+
+(defvar *slot-vector-symbols* '(.SLOTS0. .SLOTS1. .SLOTS2. .SLOTS3.))
+
+(defun slot-vector-symbol (arg-number)
+  (or (nth arg-number (the list *slot-vector-symbols*))
+      (intern (format nil ".SLOTS~A." arg-number) *the-clos-package*)))
+
+(defun make-dfun-lambda-list (metatypes applyp)
+  (gathering1 (collecting)
+    (iterate ((i (interval :from 0))
+	      (s (list-elements metatypes)))
+      (progn s)
+      (gather1 (dfun-arg-symbol i)))
+    (when applyp
+      (gather1 '&rest)
+      (gather1 '.dfun-rest-arg.))))
+
+(defun make-dlap-lambda-list (metatypes applyp)
+  (gathering1 (collecting)
+    (iterate ((i (interval :from 0))
+	      (s (list-elements metatypes)))
+      (progn s)
+      (gather1 (dfun-arg-symbol i)))
+    (when applyp
+      (gather1 '&rest))))
+
+(defun make-dfun-call (metatypes applyp fn-variable)
+  (let ((required
+	  (gathering1 (collecting)
+	    (iterate ((i (interval :from 0))
+		      (s (list-elements metatypes)))
+	      (progn s)
+	      (gather1 (dfun-arg-symbol i))))))
+    (if applyp
+	`(apply   ,fn-variable ,@required .dfun-rest-arg.)
+	`(funcall ,fn-variable ,@required))))
+
+
+;;;
+;;; Here is where we actually fill, recache and expand caches.
+;;;
+;;; The function FILL-CACHE is the ONLY external entrypoint into this code.
+;;; It returns 4 values:
+;;;   a wrapper field number
+;;;   a cache
+;;;   a mask
+;;;   an absolute cache size (the size of the actual vector)
+;;;
+;;;
+(defun fill-cache (field cache nkeys valuep limit-fn wrappers value)
+  (declare (values field cache mask size))
+  (fill-cache-internal field cache nkeys valuep limit-fn wrappers value))
+
+(defun default-limit-fn (nlines)
+  (case nlines
+    ((1 2 4) 1)
+    ((8 16)  4)
+    (otherwise 6)))
+
+
+;;;
+;;; Its too bad Common Lisp compilers freak out when you have a defun with
+;;; a lot of LABELS in it.  If I could do that I could make this code much
+;;; easier to read and work with.
+;;;
+;;; Ahh Scheme...
+;;; 
+;;; In the absence of that, the following little macro makes the code that
+;;; follows a little bit more reasonable.  I would like to add that having
+;;; to practically write my own compiler in order to get just this simple
+;;; thing is something of a drag.
+;;;
+(eval-when (compile load eval)
+
+(proclaim '(special *nkeys* *valuep* *limit-fn*))
+
+;;; This patch avoids a bug in the ENVCALL instruction. Lookup of free
+;;; variables under ENVCALL always results in nil. In particular, the
+;;; compiler generates such code for flet and friends. Therefore, some
+;;; macros must be defined at top-level.
+
+;(defmacro cache     () '.cache.)
+;(defmacro nkeys () '*nkeys*)
+;(defmacro valuep    () '*valuep*)
+;(defmacro limit-fn  () '*limit-fn*)
+;(defmacro line-size () '.line-size.)
+;(defmacro mask      () '.mask.)
+;(defmacro size      () '.size.)
+;(defmacro nlines    () '.nlines.)
+;(defmacro line-reserved-p (line)
+;            `(and (= (nkeys) 1)
+;                 (= ,line 0)))
+;(defmacro line-location (line)
+;            `(and (null (line-reserved-p ,line))
+;                 (if (= (nkeys) 1)
+;                     (* ,line (line-size))
+;                     (1+ (* ,line (line-size))))))
+;(defmacro location-line (location)
+;            `(if (= (nkeys) 1)
+;                (/ ,location (line-size))
+;                (/ (1- ,location) (line-size))))
+;end patch
+
+(defvar *local-cache-functions*
+	`((cache     () .cache.)
+	  (nkeys     () *nkeys*)
+	  (valuep    () *valuep*)
+	  (limit-fn  () *limit-fn*)
+	  (line-size () .line-size.)
+	  (mask      () .mask.)
+	  (size      () .size.)
+	  (nlines    () .nlines.)
+	  ;;
+	  ;; Return T IFF this cache location is reserved.  The only time
+	  ;; this is true is for line number 0 of an nkeys=1 cache.  
+	  ;;
+	  (line-reserved-p (line)
+	    (and (= (nkeys) 1)
+		 (= line 0))) 
+	  ;;
+	  ;; Given a line number, return the cache location.  This is the
+	  ;; value that is the second argument to cache-ref.  Basically,
+	  ;; this deals with the offset of nkeys>1 caches and multiplies
+	  ;; by line size.  This returns nil if the line is reserved.
+	  ;; 	  
+	  (line-location (line)
+	    (and (null (line-reserved-p line))
+		 (if (= (nkeys) 1)
+		     (* line (line-size))
+		     (1+ (* line (line-size)))))) 
+	  ;;
+	  ;; Given a cache location, return the line.  This is the inverse
+	  ;; of LINE-LOCATION.
+	  ;; 	  
+	  (location-line (location)
+	    (if (= (nkeys) 1)
+		(/ location (line-size))
+		(/ (1- location) (line-size)))) 
+	  ;;
+	  ;; Given a line number, return the wrappers stored at that line.
+	  ;; As usual, if nkeys=1, this returns a single value.  Only when
+	  ;; nkeys>1 does it return a list.  An error is signalled if the
+	  ;; line is reserved.
+	  ;;
+	  (line-wrappers (line)
+	    (when (line-reserved-p line) (error "Line is reserved."))
+	    (let ((location (line-location line)))
+	      (if (= (nkeys) 1)
+		  (cache-ref (cache) location)
+		  (gathering1 (collecting)
+		    (dotimes (i (nkeys))
+		      (gather1 (cache-ref (cache) (+ location i))))))))
+	  ;;
+	  ;; Given a line number, return the value stored at that line.
+	  ;; If valuep is NIL, this returns NIL.  As with line-wrappers,
+	  ;; an error is signalled if the line is reserved.
+	  ;; 
+	  (line-value (line)
+	    (when (line-reserved-p line) (error "Line is reserved."))
+	    (and (valuep)
+		 (cache-ref (cache) (+ (line-location line) (nkeys)))))
+	  ;;
+	  ;; Given a line number, return true IFF that line has data in
+	  ;; it.  The state of the wrappers stored in the line is not
+	  ;; checked.  An error is signalled if line is reserved.
+	  (line-full-p (line)
+	    (when (line-reserved-p line) (error "Line is reserved."))
+	    (not (null (cache-ref (cache) (line-location line)))))
+	  ;;
+	  ;; Given a line number, return true IFF the line is full and
+	  ;; there are no invalid wrappers in the line, and the line's
+	  ;; wrappers are different from wrappers.
+	  ;; An error is signalled if the line is reserved.
+	  ;;
+	  (line-valid-p (line wrappers)
+	    (when (line-reserved-p line) (error "Line is reserved."))
+	    (let ((loc (line-location line)))
+	      (dotimes (i (nkeys) t)
+		(let ((wrapper (cache-ref (cache) (+ loc i))))
+		  (when (or (null wrapper)
+;***					(numberp wrapper)
+					;Think of this as an optimized:
+					; (and (zerop i)
+					;      (= (nkeys) 1)
+					;      (null (valuep))
+					;      (numberp wrapper))
+                            (invalid-wrapper-p wrapper))
+                    (return nil))))))
+	  ;;
+	  ;; How many unreserved lines separate line-1 and line-2.
+	  ;;
+	  (line-separation (line-1 line-2)
+	    (let ((diff (- line-2 line-1)))
+	      (cond ((zerop diff) diff)
+		    ((plusp diff) diff)
+		    (t
+		     (if (line-reserved-p 0)
+			 (1- (+ (- (nlines) line-1) line-2))
+			 (+ (- (nlines) line-1) line-2))))))
+	  ;;
+	  ;; Given a cache line, get the next cache line.  This will not
+	  ;; return a reserved line.
+	  ;; 
+	  (next-line (line)
+	    (if (= line (1- (nlines)))
+		(if (line-reserved-p 0) 1 0)
+		(1+ line)))
+	  ;;
+	  ;; Given a line which has a valid entry in it, this will return
+	  ;; the primary cache line of the wrappers in that line.  We just
+	  ;; call COMPUTE-PRIMARY-CACHE-LOCATION-FROM-LOCATION, this is an
+	  ;; easier packaging up of the call to it.
+	  ;; 
+	  (line-primary (field line)
+	    (location-line
+	      (compute-primary-cache-location-from-location
+		field (cache) (line-location line) (mask) (nkeys))))
+	  ;;
+	  ;;
+	  (fill-line (line wrappers value)
+	    (when (line-reserved-p line)
+	      (error "Attempt to fill a reserved line."))
+	    (let ((loc (line-location line)))
+	      (cond ((= (nkeys) 1)
+		     (setf (cache-ref (cache) loc) wrappers)
+		     (when (valuep) (setf (cache-ref (cache) (1+ loc)) value)))
+		    (t
+		     (iterate ((i (interval :from 0))
+			       (w (list-elements wrappers)))
+		       (setf (cache-ref (cache) (+ loc i)) w))
+		     (when (valuep) (setf (cache-ref (cache) (+ loc (nkeys))) value))))))
+	  ;;
+	  ;; Blindly copy the contents of one cache line to another.  The
+	  ;; contents of the <to> line are overwritten, so whatever was in
+	  ;; there should already have been moved out.
+	  ;;
+	  ;; For convenience in debugging, this also clears out the from
+	  ;; location after it has been copied.
+	  ;;
+	  (copy-line (from to)
+	    (if (line-reserved-p to)
+		(error "Copying something into a reserved cache line.")
+		(let ((from-loc (line-location from))
+		      (to-loc (line-location to)))
+		  (modify-cache (cache)
+		    (dotimes (i (line-size))
+		      (setf (cache-ref (cache) (+ to-loc i))
+			    (cache-ref (cache) (+ from-loc i)))
+		      (setf (cache-ref (cache) (+ from-loc i))
+			    nil))))))
+	  ;;
+	  ;;
+	  ;;
+	  (transfer-line (from-cache from-line to-cache to-line)
+	    (if (line-reserved-p to-line)
+		(error "transfering something into a reserved cache line.")
+		(let ((from-loc (line-location from-line))
+		      (to-loc (line-location to-line)))
+		  (modify-cache to-cache
+		    (dotimes (i (line-size))
+		      (setf (cache-ref to-cache (+ to-loc i))
+			    (cache-ref from-cache (+ from-loc i))))))))
+	  ))
+
+(defmacro with-local-cache-functions ((cache) &body body &environment env)
+  `(let ((.cache. ,cache))
+     (declare (type simple-vector .cache.))
+     (multiple-value-bind (.mask. .size. .line-size. .nlines.)
+	 (compute-cache-parameters *nkeys* *valuep* .cache.)
+       (declare (type fixnum .mask. .size. .line-size. .nlines.))
+       (progn .mask. .size. .line-size. .nlines.)
+       (labels ,(mapcar #'(lambda (fn) (assq fn *local-cache-functions*))
+			(pickup-local-cache-functions body env))
+	 ,@body))))
+
+(defun pickup-local-cache-functions (body env)
+  (let ((functions ())
+	(possible-functions (mapcar #'car *local-cache-functions*)))
+    (labels ((walk-function (form context env)
+	       (declare (ignore env))
+	       (when (and (eq context :eval)
+			  (consp form)
+			  (symbolp (car form)))
+		 (let ((name (car form)))
+		   (when (and (not (memq name functions))
+			      (memq name possible-functions))
+		     (pushnew name functions)
+		     (walk (cddr (assq name *local-cache-functions*))))))
+	       form)
+	     (walk (body)
+	       (walk-form `(progn . ,body) env #'walk-function)))
+      (walk body)
+      functions)))
+
+)
+
+
+;;;
+;;; returns 4 values, <field> <cache> <mask> <size>
+;;; It tries to re-adjust the cache every time it makes a new fill.  The
+;;; intuition here is that we want uniformity in the number of probes needed to
+;;; find an entry.  Furthermore, adjusting has the nice property of throwing out
+;;; any entries that are invalid.
+;;;
+(defun fill-cache-internal (field cache nkeys valuep limit-fn wrappers value)
+  (let ((*nkeys* nkeys)
+	(*valuep* valuep)
+	(*limit-fn* limit-fn))
+    (with-local-cache-functions (cache)
+      (flet ((4-values-please (f c)
+	       (multiple-value-bind (mask size)
+		   (compute-cache-parameters *nkeys* *valuep* c)
+		 (values f c mask size))))
+	(let ((easy-fill-p (fill-cache-p nil field cache wrappers value)))
+	  (if easy-fill-p
+	      (4-values-please field cache)
+	      (multiple-value-bind (adj-field adj-cache)
+		  (adjust-cache field cache wrappers value)
+		(if adj-field
+		    (4-values-please adj-field adj-cache)
+		    (multiple-value-bind (exp-field exp-cache)
+			(expand-cache field cache wrappers value)
+		      (4-values-please exp-field exp-cache))))))))))
+
+;;;
+;;; returns T or NIL
+;;;
+(defun fill-cache-p (forcep field cache wrappers value)
+  (with-local-cache-functions (cache)
+    (let* ((primary (location-line (compute-primary-cache-location field (mask) wrappers))))
+      (multiple-value-bind (free emptyp)
+	  (find-free-cache-line primary field cache wrappers)
+	(when (or forcep emptyp) (fill-line free wrappers value) t)))))
+
+(defun fill-cache-from-cache-p (forcep field cache from-cache from-line)
+  (with-local-cache-functions (from-cache)
+    (let ((primary (line-primary field from-line)))
+      (multiple-value-bind (free emptyp)
+	  (find-free-cache-line primary field cache)
+	(when (or forcep emptyp)
+	  (transfer-line from-cache from-line cache free)
+	  t)))))
+
+(defun entry-in-cache-p (field cache wrappers value)
+  (declare (ignore field value))
+  (with-local-cache-functions (cache)
+    (dotimes (i (nlines))
+      (unless (line-reserved-p i)
+	(when (equal (line-wrappers i) wrappers) (return t))))))
+
+;;;
+;;; Returns NIL or (values <field> <cache>)
+;;; 
+;;; This is only called when it isn't possible to put the entry in the cache
+;;; the easy way.  That is, this function assumes that FILL-CACHE-P has been
+;;; called as returned NIL.
+;;;
+;;; If this returns NIL, it means that it wasn't possible to find a wrapper
+;;; field for which all of the entries could be put in the cache (within the
+;;; limit).  
+;;;
+(defun adjust-cache (field cache wrappers value)
+  (with-local-cache-functions (cache)
+    (let ((ncache (get-cache (size))))
+      (do ((nfield field (next-wrapper-field nfield)))
+	  ((null nfield) (free-cache ncache) nil)
+	(labels ((try-one-fill-from-line (line)
+		   (fill-cache-from-cache-p nil nfield ncache cache line))
+		 (try-one-fill (wrappers value)
+		   (fill-cache-p nil nfield ncache wrappers value)))
+	  (if (and (dotimes (i (nlines) t)
+		     (when (and (null (line-reserved-p i))
+				(line-valid-p i wrappers))
+		       (unless (try-one-fill-from-line i) (return nil))))
+		   (try-one-fill wrappers value))
+	      (return (values nfield ncache))
+	      (flush-cache-internal ncache)))))))
+
+		       
+;;;
+;;; returns: (values <field> <cache>)
+;;;
+(defun expand-cache (field cache wrappers value)
+  (declare (values field cache) (ignore field))
+  (with-local-cache-functions (cache)
+    (multiple-value-bind (ignore size)
+	(compute-cache-parameters (nkeys) (valuep) (* (nlines) 2))
+      (let* ((ncache (get-cache size))
+	     (nfield (wrapper-field 'number)))
+	(labels ((do-one-fill-from-line (line)
+		   (unless (fill-cache-from-cache-p nil nfield ncache cache line)
+		     (do-one-fill (line-wrappers line) (line-value line))))
+		 (do-one-fill (wrappers value)
+		   (multiple-value-bind (adj-field adj-cache)
+		       (adjust-cache nfield ncache wrappers value)
+		     (if adj-field
+			 (setq nfield adj-field ncache adj-cache)
+			 (fill-cache-p t nfield ncache wrappers value))))
+		 (try-one-fill (wrappers value)
+		   (fill-cache-p nil nfield ncache wrappers value)))
+	  (dotimes (i (nlines))
+	    (when (and (null (line-reserved-p i))
+		       (line-valid-p i wrappers))
+	      (do-one-fill-from-line i)))
+	  (unless (try-one-fill wrappers value)
+	    (do-one-fill wrappers value))
+	  (values nfield ncache))))))
+
+
+;;;
+;;; This is the heart of the cache filling mechanism.  It implements the decisions
+;;; about where entries are placed.
+;;; 
+;;; Find a line in the cache at which a new entry can be inserted.
+;;;
+;;;   <line>
+;;;   <empty?>           is <line> in fact empty?
+;;;
+(defun find-free-cache-line (primary field cache &optional wrappers)
+  (declare (values line empty?))
+  (with-local-cache-functions (cache)
+    (let ((limit (funcall (limit-fn) (nlines)))
+	  (wrappedp nil))
+      (when (line-reserved-p primary) (setq primary (next-line primary)))
+      (labels (;;
+	       ;; Try to find a free line starting at <start>.  <primary>
+	       ;; is the primary line of the entry we are finding a free
+	       ;; line for, it is used to compute the seperations.
+	       ;;
+	       (find-free (p s)
+		 (do* ((line s (next-line line))
+		       (nsep (line-separation p s) (1+ nsep)))
+		      (())
+		   (if (null (line-valid-p line wrappers)) ;If this line is empty or
+		       (return (values line t))	           ;invalid, just use it.
+
+		       (let ((osep (line-separation (line-primary field line) line)))
+			 (if (and wrappedp (>= line primary))
+			     ;;
+			     ;; have gone all the way around the cache, time to quit
+			     ;; 
+			     (return (values line nil))
+			     
+			     (when (cond ((or (= nsep limit)) t)
+					 ((= nsep osep) (zerop (random 2)))
+					 ((> nsep osep) t)
+					 (t nil))
+			       ;;
+			       ;; Try to displace what is in this line so that we
+			       ;; can use the line.
+			       ;;
+			       (return (values line (displace line)))))))
+		   
+		   (if (= line (1- (nlines))) (setq wrappedp t))))
+	       ;;
+	       ;; Given a line, attempt to free up that line by moving its
+	       ;; contents elsewhere. Returns nil when it wasn't possible to
+	       ;; move the contents of the line without dumping something on
+	       ;; the floor.  
+	       ;; 
+	       (displace (line)
+		 (if (= line (1- (nlines))) (setq wrappedp t))
+		 (multiple-value-bind (dline dempty?)
+		     (find-free (line-primary field line) (next-line line))
+		   (when dempty? (copy-line line dline) t))))
+	
+	(find-free primary primary)))))
diff --git a/clos/3.5/clos-env-internal.DFASL b/clos/3.5/clos-env-internal.DFASL
new file mode 100644
index 00000000..6daa5de0
Binary files /dev/null and b/clos/3.5/clos-env-internal.DFASL differ
diff --git a/clos/3.5/clos-env-internal.lisp b/clos/3.5/clos-env-internal.lisp
new file mode 100644
index 00000000..6d720032
--- /dev/null
+++ b/clos/3.5/clos-env-internal.lisp
@@ -0,0 +1,260 @@
+(DEFINE-FILE-INFO PACKAGE "XCL" READTABLE "XCL")
+(il:filecreated "28-Aug-87 18:42:36" il:{phylum}<clos>clos-env-internal.\;1 8356   
+
+      il:|changes| il:|to:|  (il:vars il:clos-env-internalcoms)
+                             (il:props (il:clos-env-internal il:makefile-environment))
+                             (il:functions stack-eql stack-pointer-frame stack-frame-valid-p 
+                                    stack-frame-fn-header stack-frame-pc fnheader-debugging-info 
+                                    stack-frame-name compiled-closure-fnheader compiled-closure-env)
+)
+
+
+; Copyright (c) 1987 by Xerox Corporation.  All rights reserved.
+
+(il:prettycomprint il:clos-env-internalcoms)
+
+(il:rpaqq il:clos-env-internalcoms (
+
+(il:* il:|;;;| "***************************************")
+
+                                   
+
+(il:* il:|;;;| " Copyright (c) 1987 Xerox Corporation.  All rights reserved.")
+
+                                   
+
+(il:* il:|;;;| "")
+
+                                   
+
+(il:* il:|;;;| "Use and copying of this software and preparation of derivative works based upon this software are permitted.  Any distribution of this software or derivative works must comply with all applicable United States export control laws.")
+
+                                   
+
+(il:* il:|;;;| " ")
+
+                                   
+
+(il:* il:|;;;| "This software is made available AS IS, and Xerox Corporation makes no  warranty about the software, its performance or its conformity to any  specification.")
+
+                                   
+
+(il:* il:|;;;| " ")
+
+                                   
+
+(il:* il:|;;;| "Any person obtaining a copy of this software is requested to send their name and post office or electronic mail address to:")
+
+                                   
+
+(il:* il:|;;;| "   CommonLoops Coordinator")
+
+                                   
+
+(il:* il:|;;;| "   Xerox Artifical Intelligence Systems")
+
+                                   
+
+(il:* il:|;;;| "   2400 Hanover St.")
+
+                                   
+
+(il:* il:|;;;| "   Palo Alto, CA 94303")
+
+                                   
+
+(il:* il:|;;;| "(or send Arpanet mail to CommonLoops-Coordinator.pa@Xerox.arpa)")
+
+                                   
+
+(il:* il:|;;;| "")
+
+                                   
+
+(il:* il:|;;;| " Suggestions, comments and requests for improvements are also welcome.")
+
+                                   
+
+(il:* il:|;;;| " *************************************************************************")
+
+                                   
+
+(il:* il:|;;;| "")
+
+                                   (il:declare\: il:dontcopy (il:prop il:makefile-environment 
+                                                                    il:clos-env-internal))
+                                                             (il:* il:\; 
+                                                             "We're off to hack the system...")
+
+                                   (il:declare\: il:eval@compile il:dontcopy (il:files clos::abc)
+                                          
+          
+          (il:* il:|;;| "The Deltas and The East and The Freeze")
+)
+                                   (il:functions stack-eql stack-pointer-frame stack-frame-valid-p 
+                                          stack-frame-fn-header stack-frame-pc 
+                                          fnheader-debugging-info stack-frame-name 
+                                          compiled-closure-fnheader compiled-closure-env)))
+
+
+
+(il:* il:|;;;| "***************************************")
+
+
+
+
+(il:* il:|;;;| " Copyright (c) 1987 Xerox Corporation.  All rights reserved.")
+
+
+
+
+(il:* il:|;;;| "")
+
+
+
+
+(il:* il:|;;;| 
+"Use and copying of this software and preparation of derivative works based upon this software are permitted.  Any distribution of this software or derivative works must comply with all applicable United States export control laws."
+)
+
+
+
+
+(il:* il:|;;;| " ")
+
+
+
+
+(il:* il:|;;;| 
+"This software is made available AS IS, and Xerox Corporation makes no  warranty about the software, its performance or its conformity to any  specification."
+)
+
+
+
+
+(il:* il:|;;;| " ")
+
+
+
+
+(il:* il:|;;;| 
+"Any person obtaining a copy of this software is requested to send their name and post office or electronic mail address to:"
+)
+
+
+
+
+(il:* il:|;;;| "   CommonLoops Coordinator")
+
+
+
+
+(il:* il:|;;;| "   Xerox Artifical Intelligence Systems")
+
+
+
+
+(il:* il:|;;;| "   2400 Hanover St.")
+
+
+
+
+(il:* il:|;;;| "   Palo Alto, CA 94303")
+
+
+
+
+(il:* il:|;;;| "(or send Arpanet mail to CommonLoops-Coordinator.pa@Xerox.arpa)")
+
+
+
+
+(il:* il:|;;;| "")
+
+
+
+
+(il:* il:|;;;| " Suggestions, comments and requests for improvements are also welcome.")
+
+
+
+
+(il:* il:|;;;| " *************************************************************************")
+
+
+
+
+(il:* il:|;;;| "")
+
+(il:declare\: il:dontcopy 
+
+(il:putprops il:clos-env-internal il:makefile-environment (:package "XCL" :readtable "XCL"))
+)
+
+
+
+(il:* il:\; "We're off to hack the system...")
+
+(il:declare\: il:eval@compile il:dontcopy 
+(il:filesload clos::abc)
+)
+
+(defun stack-eql (x y) "Test two stack pointers for equality" (and (il:stackp x)
+                                                                   (il:stackp y)
+                                                                   (eql (il:fetch (il:stackp il:edfxp
+                                                                                         )
+                                                                           il:of x)
+                                                                        (il:fetch (il:stackp il:edfxp
+                                                                                         )
+                                                                           il:of y))))
+
+
+(defun stack-pointer-frame (stack-pointer) (il:|fetch| (il:stackp il:edfxp) il:|of| stack-pointer))
+
+
+(defun stack-frame-valid-p (frame) (not (il:|fetch| (il:fx il:invalidp) il:|of| frame)))
+
+
+(defun stack-frame-fn-header (frame) (il:|fetch| (il:fx il:fnheader) il:|of| frame))
+
+
+(defun stack-frame-pc (frame) (il:|fetch| (il:fx il:pc) il:|of| frame))
+
+
+(defun fnheader-debugging-info (fnheader) (let* ((start-pc (il:fetch (il:fnheader il:startpc)
+                                                              il:of fnheader))
+                                                 (name-table-words
+                                                  (let ((size (il:fetch (il:fnheader il:ntsize)
+                                                                 il:of fnheader)))
+                                                       (if (zerop size)
+                                                           il:wordsperquad
+                                                           (* size 2))))
+                                                 (past-name-table-in-words (+ (il:fetch (il:fnheader
+                                                                                         
+                                                                                     il:overheadwords
+                                                                                         )
+                                                                                 il:of fnheader)
+                                                                              name-table-words)))
+                                                (and (= (- start-pc (* il:bytesperword 
+                                                                       past-name-table-in-words))
+                                                        il:bytespercell)
+          
+          (il:* il:|;;| "It's got a debugging-info list.")
+
+                                                     (il:\\getbaseptr fnheader 
+                                                            past-name-table-in-words))))
+
+
+(defun stack-frame-name (frame) (il:|fetch| (il:fx il:framename) il:|of| frame))
+
+
+(defun compiled-closure-fnheader (closure) (il:|fetch| (il:compiled-closure il:fnheader) il:|of|
+                                                                                         closure))
+
+
+(defun compiled-closure-env (closure) (il:fetch (il:compiled-closure il:environment) il:of closure))
+
+(il:putprops il:clos-env-internal il:copyright ("Xerox Corporation" 1987))
+(il:declare\: il:dontcopy
+  (il:filemap (nil)))
+il:stop
diff --git a/clos/3.5/clos-env.DFASL b/clos/3.5/clos-env.DFASL
new file mode 100644
index 00000000..c0562b23
Binary files /dev/null and b/clos/3.5/clos-env.DFASL differ
diff --git a/clos/3.5/clos-env.lisp b/clos/3.5/clos-env.lisp
new file mode 100644
index 00000000..be366810
--- /dev/null
+++ b/clos/3.5/clos-env.lisp
@@ -0,0 +1,1609 @@
+;;;-*-Mode:LISP; Package:(CLOS (LISP WALKER)); Base:10; Syntax:Common-lisp -*-
+;;;
+;;; *************************************************************************
+;;; Copyright (c) 1991 Venue
+;;; All rights reserved.
+;;; *************************************************************************
+;;;
+;;; Medley-Lisp specific environment hacking for CLOS
+
+(in-package "CLOS")
+
+;; 
+;; Protect the Corporation
+;; 
+(eval-when (eval load)
+  (format *terminal-io*
+    "~&;CLOS-ENV Copyright (c) 1991 by ~
+        Venue Corporation.  All rights reserved.~%"))
+
+
+;;; Make funcallable instances (FINs) print by calling print-object.
+
+(eval-when (eval load)
+  (il:defprint 'il:compiled-closure 'il:print-closure))
+
+(defun il:print-closure (x &optional stream depth)
+  ;; See the IRM, section 25.3.3.  Unfortunatly, that documentation is
+  ;; not correct.  In particular, it makes no mention of the third argument.
+  (cond ((not (funcallable-instance-p x))
+	 ;; IL:\CCLOSURE.DEFPRINT is the orginal system function for
+	 ;; printing closures
+	 (il:\\cclosure.defprint x stream))
+	((streamp stream)
+	 ;; Use the standard CLOS printing method, then return T to tell
+	 ;; the printer that we have done the printing ourselves.
+	 (print-object x stream)
+	 t)
+	(t 
+	 ;; Internal printing (again, see the IRM section 25.3.3). 
+	 ;; Return a list containing the string of characters that
+	 ;; would be printed, if the object were being printed for
+	 ;; real.
+	 (with-output-to-string (stream)
+	   (list (print-object x stream))))))
+
+
+;;; Naming methods
+
+(defun gf-named (gf-name)
+  (let ((spec (cond ((symbolp gf-name) gf-name)
+		    ((and (consp gf-name)
+			  (eq (first gf-name) 'setf)
+			  (symbolp (second gf-name))
+			  (null (cddr gf-name)))
+		     (get-setf-function-name (second gf-name)))
+		    (t nil))))
+    (if (and (fboundp spec)
+	     (generic-function-p (symbol-function spec)))
+	(symbol-function spec)
+	nil)))
+
+(defun generic-function-method-names (gf-name hasdefp)
+  (if hasdefp
+      (let ((names nil))
+        (maphash #'(lambda (key value)
+                     (declare (ignore value))
+                     (when (and (consp key) (eql (car key) gf-name))
+                       (pushnew key names)))
+                 (gethash 'methods xcl:*definition-hash-table*))
+        names)
+      (let ((gf (gf-named gf-name)))
+        (when gf
+          (mapcar #'full-method-name (generic-function-methods gf))))))
+
+(defun full-method-name (method)
+  "Return the full name of the method"
+  (let ((specializers (mapcar #'(lambda (x)
+		                  (cond ((eq x 't) t)
+		                        ((and (consp x) (eq (car x) 'eql)) x)
+		                        (t (class-name x))))
+		       (method-specializers method))))
+    ;; Now go through some hair to make sure that specializer is
+    ;; really right.  Once CLOS returns the right value for
+    ;; specializers this can be taken out.
+    (let* ((arglist (method-lambda-list method))
+	   (number-required (or (position-if
+				  #'(lambda (x) (member x lambda-list-keywords))
+				  arglist)
+				(length arglist)))
+	   (diff (- number-required (length specializers))))
+      (when (> diff 0)
+	(setq specializers (nconc (copy-list specializers)
+				  (make-list diff :initial-element 't)))))
+    (make-full-method-name (generic-function-name
+			       (method-generic-function method))
+			   (method-qualifiers method)
+			   specializers)))
+
+(defun make-full-method-name (generic-function-name qualifiers arg-types)
+  "Return the full name of a method, given the generic-function name, the method
+qualifiers, and the arg-types"
+  ;; The name of the method is:
+  ;;      (<generic-function-name> <qualifier-1> .. 
+  ;;         (<arg-specializer-1>..))
+  (labels ((remove-trailing-ts (l)
+	     (if (null l)
+		 nil
+		 (let ((tail (remove-trailing-ts (cdr l))))
+		   (if (null tail)
+		       (if (eq (car l) 't)
+			   nil
+			   (list (car l)))
+		       (if (eq l tail)
+			   l
+			   (cons (car l) tail)))))))
+    `(,generic-function-name ,@qualifiers
+      ,(remove-trailing-ts arg-types))))
+
+(defun parse-full-method-name (method-name)
+  "Parse the method name, returning the gf-name, the qualifiers, and the
+arg-types."
+  (values (first method-name)
+	  (butlast (rest method-name))
+	  (car (last method-name))))
+
+(defun prompt-for-full-method-name (gf-name &optional has-def-p)
+  "Prompt the user for the full name of a method on the given generic function name"
+  (let ((method-names (generic-function-method-names gf-name has-def-p)))
+    (cond ((null method-names)
+	   nil)
+	  ((null (cdr method-names))
+	   (car method-names))
+	  (t (il:menu
+	      (il:create
+	       il:menu il:items il:_	;If HAS-DEF-P, include only
+					; those methods that have a
+					; symbolic def'n that we can
+					; find
+	       (remove-if #'null
+			  (mapcar #'(lambda (m)
+				      (if (or (not has-def-p)
+					      (il:hasdef m 'methods))
+					  `(,(with-output-to-string (s)
+					       (dolist (x m)
+						 (format s "~A " x))
+					       s)
+					    ',m)
+					  nil))
+				  method-names))
+	       il:title il:_ "Which method?"))))))
+
+
+;;; Converting generic defining macros into DEFDEFINER macros
+
+(defmacro make-defdefiner (definer-name definer-type type-description &body 
+					definer-options)
+  "Make the DEFINER-NAME use DEFDEFINER, defining items of type DEFINER-TYPE"
+  (let ((old-definer-macro-name (intern (string-append definer-name
+						       " old definition")
+					(symbol-package definer-name)))
+	(old-definer-macro-expander (intern (string-append definer-name 
+							   " old expander")
+					    (symbol-package definer-name))))
+    `(progn 
+      ;; First, move the current defining function off to some safe
+      ;; place
+      (unmake-defdefiner ',definer-name)
+      (cond ((not (fboundp ',definer-name))
+	     (error "~A has no definition!" ',definer-name))
+	    ((fboundp ',old-definer-macro-name))
+	    ((macro-function ',definer-name)
+					; We have to move the macro
+					; expansion function as well,
+					; so it won't get clobbered
+					; when the original macro is
+					; redefined.  See AR 7410.
+	     (let* ((expansion-function (macro-function ',definer-name)))
+	       (setf (symbol-function ',old-definer-macro-expander)
+		     (loop (if (symbolp expansion-function)
+			       (setq expansion-function
+				     (symbol-function expansion-function))
+			       (return expansion-function))))
+	       (setf (macro-function ',old-definer-macro-name)
+		     ',old-definer-macro-expander)
+	       (setf (get ',definer-name 'make-defdefiner) expansion-function)))
+	    (t (error "~A does not name a macro." ',definer-name)))
+      ;; Make sure the type is defined
+      (xcl:def-define-type ,definer-type ,type-description)
+      ;; Now redefine the definer, using DEFEDFINER and the original def'n
+      (xcl:defdefiner ,(if definer-options
+			   (cons definer-name definer-options)
+			   definer-name)
+	  ,definer-type	(&body b) `(,',old-definer-macro-name ,@,'b)))))
+
+(defun unmake-defdefiner (definer-name)
+  (let ((old-expander (get definer-name 'make-defdefiner)))
+    (when old-expander
+      (setf (macro-function definer-name old-expander))
+      (remprop definer-name 'make-defdefiner))))
+
+
+;;; For tricking ED into being able to use just the generic-function-name
+;;; instead of the full method name
+
+(defun source-manager-method-edit-fn (name type source editcoms options)
+  "Edit a method of the given name"
+  (let ((full-name (if (gf-named name)
+					;If given the name of a
+					; generic-function, try to get
+					; the full method name
+		       (prompt-for-full-method-name name t)
+					; Otherwise it should name the
+					; method
+		       name)))
+    (when (not (null full-name))
+      (il:default.editdef full-name type source editcoms options))
+    (or full-name name)))		;Return the name
+
+(defun source-manager-method-hasdef-fn (name type &optional source)
+  "Is there a method defined with the given name?"
+  (cond ((not (eq type 'methods)) nil)
+	((or (symbolp name)
+	     (and (consp name)
+		  (eq (first name) 'setf)
+		  (symbolp (second name))
+		  (null (cddr name))))
+	 ;; If passed in the name of a generic-function, pretend that
+	 ;; there is a method by that name if there is a generic function
+	 ;; by that name, and there is a method whose source we can find.
+	 (if (and (not (null (gf-named name)))
+		  (find-if #'(lambda (m)
+			       (il:hasdef m type source))
+			   (generic-function-method-names name t)))
+	     name
+	     nil))
+	((and (consp name) (>= (length name) 2))
+	 ;; Standard methods are named (gf-name {qualifiers}* ({specializers}*))
+	 (when (il:getdef name type source '(il:nocopy il:noerror))
+	   name))
+	(t
+	 ;; Nothing else can name a method
+	 nil)))
+
+;;; Initialize the CLOS env
+
+(defun initialize-clos-env nil
+  "Initialize the Medley CLOS environment" 
+  ;; Set up SourceManager DEFDEFINERS for classes and methods.
+  ;;
+  ;; Make sure to define methods before classes, so that (IL:FILES?) will build
+  ;; filecoms that have classes before methods. 
+  (unless (il:hasdef 'methods 'il:filepkgtype)
+    (make-defdefiner defmethod methods "methods"
+		     (:name (lambda (form)
+			      (multiple-value-bind (name qualifiers arglist)
+				  (parse-defmethod (cdr form))
+				(make-full-method-name name qualifiers
+				    (specialized-lambda-list-specializers
+					arglist)))))
+		     (:undefiner
+		      (lambda (method-name)
+			(multiple-value-bind
+			      (name qualifiers arg-types)
+			    (parse-full-method-name method-name)
+			  (let* ((gf (gf-named name))
+				 (method (when gf
+					   (get-method gf qualifiers
+						       (mapcar #'find-class 
+							       arg-types)))))
+			    (when method (remove-method gf method))))))))
+  ;; Include support for DEFGENERIC, if that is defined
+  (unless (or (not (fboundp 'defgeneric))
+	      (il:hasdef 'generic-functions 'il:filepkgtype))
+    (make-defdefiner defgeneric generic-functions "generic-function definitions"))
+  ;; DEFCLASS FileManager stuff
+  (unless (il:hasdef 'classes 'il:filepkgtype)
+    (make-defdefiner defclass classes "class definitions"
+		     (:undefiner (lambda (name)
+				   (when (find-class name t)
+				     (setf (find-class name) nil)))))
+    ;; CLASSES "include" TYPES.
+    (il:filepkgcom 'classes 'il:contents
+		   #'(lambda (com name type &optional reason)
+		       (declare (ignore name reason))
+		       (if (member type '(il:types classes) :test #'eq)
+			   (cdr com)
+			   nil))))
+  ;; Set up the hooks so that ED can be handed the name of a generic function,
+  ;; and end up editing a method instead
+  (il:filepkgtype 'methods 'il:editdef 'source-manager-method-edit-fn
+		  'il:hasdef 'source-manager-method-hasdef-fn)
+  ;; Set up the inspect macro.  The right way to do this is to
+  ;; (ENSURE-GENERIC-FUNCTION 'IL:INSPECT...), but for now...
+  (push '((il:function clos-object-p) . \\internal-inspect-object)
+	il:inspectmacros)
+  ;; Unmark any SourceManager changes caused by this loadup
+  (dolist (com (il:filepkgchanges))
+    (dolist (name (cdr com))
+      (when (and (symbolp name)
+		 (eq (symbol-package name) (find-package "CLOS")))
+	(il:unmarkaschanged name (car com))))))
+
+(eval-when (eval load)
+  (initialize-clos-env))
+
+
+;;; Inspecting CLOS objects
+
+(defun clos-object-p (x)
+  "Is the datum a CLOS object?"
+  (or (std-instance-p x)
+      (fsc-instance-p x)))
+
+(defun \\internal-inspect-object (x type where)
+  (inspect-object x type where))
+
+(defun \\internal-inspect-slot-names (x)
+  (inspect-slot-names x))
+
+(defun \\internal-inspect-slot-value (x slot-name)
+  (inspect-slot-value x slot-name))
+
+(defun \\internal-inspect-setf-slot-value (x slot-name value)
+  (inspect-setf-slot-value x slot-name value))
+
+(defun \\internal-inspect-slot-name-command (slot-name x window)
+  (inspect-slot-name-command slot-name x window))
+
+(defun \\internal-inspect-title (x y)
+  (inspect-title x y))
+
+(defmethod inspect-object (x type where)
+  "Open an insect window on the object x"
+  (il:inspectw.create x '\\internal-inspect-slot-names
+              '\\internal-inspect-slot-value
+              '\\internal-inspect-setf-slot-value
+              '\\internal-inspect-slot-name-command nil nil 
+              '\\internal-inspect-title nil where
+              #'(lambda (n v)		;Same effect as NIL, but avoids bug in
+		  (declare (ignore v))	; INSPECTW.CREATE
+		  n)))
+
+(defmethod inspect-slot-names (x)
+  "Return a list of names of slots of the object that should be shown in the
+inspector"
+  (mapcar #'(lambda (slotd) (slot-value slotd 'name))
+	  (slots-to-inspect (class-of x) x)))
+
+(defmethod inspect-slot-value (x slot-name)
+  (cond ((not (slot-exists-p x slot-name)) "** no such slot **")
+	((not (slot-boundp x slot-name)) "** slot not bound **")
+	(t (slot-value x slot-name))))
+
+(defmethod inspect-setf-slot-value (x slot-name value)
+  "Used by the inspector to set the value fo a slot"
+  ;; Make this UNDO-able
+  (il:undosave `(inspect-setf-slot-value ,x ,slot-name
+		 ,(slot-value x slot-name)))
+  ;; Then change the value
+  (setf (slot-value x slot-name) value))
+
+(defmethod inspect-slot-name-command (slot-name x window)
+  "Allows the user to select a menu item to change a slot value in an inspect
+window"
+  ;; This code is a very slightly hacked version of the system function
+  ;; DEFAULT.INSPECTW.PROPCOMMANDFN.  We have to do this because the
+  ;; standard version makes some nasty assumptions about
+  ;; structure-objects that are not true for CLOS objects.
+  (declare (special il:|SetPropertyMenu|))
+  (case (il:menu (cond ((typep il:|SetPropertyMenu| 'il:menu)
+			il:|SetPropertyMenu|)
+		       (t (il:setq il:|SetPropertyMenu|
+				   (il:|create| il:menu il:items il:_
+				       '((set 'set 
+					  "Allows a new value to be entered"
+					  )))))))
+    (set 
+     ;; The user want to set the value
+     (il:ersetq (prog ((il:oldvalueitem (il:itemofpropertyvalue slot-name 
+								window))
+		       il:newvalue il:pwindow)
+		   (il:ttydisplaystream (il:setq il:pwindow
+						 (il:getpromptwindow window 3)))
+		   (il:clearbuf t t)
+		   (il:resetlst
+		    (il:resetsave (il:\\itemw.flipitem il:oldvalueitem window)
+				  (list 'il:\\itemw.flipitem 
+					il:oldvalueitem window))
+		    (il:resetsave (il:tty.process (il:this.process)))
+		    (il:resetsave (il:printlevel 4 3))
+		    (il:|printout| t "Enter the new " 
+			slot-name " for " x t 
+			"The expression read will be EVALuated."
+			t "> ")
+		    (il:setq il:newvalue (il:lispx (il:lispxread t t)
+						   '>))
+					; clear tty buffer because it
+					; sometimes has stuff left.
+		    (il:clearbuf t t))
+		   (il:closew il:pwindow)
+		   (return (il:inspectw.replace window slot-name il:newvalue)))))))
+
+(defmethod inspect-title (x window)
+  "Return the title to use in an inspect window viewing x"
+  (format nil "Inspecting a ~A" (class-name (class-of x))))
+
+(defmethod inspect-title ((x standard-class) window)
+  (format nil "Inspecting the class ~A" (class-name x)))
+
+
+;;;  Debugger support for CLOS
+
+
+(il:filesload clos-env-internal)
+
+;; Non-CLOS specific changes to the debugger
+
+;; Redefining the standard INTERESTING-FRAME-P function.  Now functions can be
+;; declared uninteresting to BT by giving them an XCL::UNINTERESTINGP
+;; property.
+
+(dolist (fn '(si::*unwind-protect* il:*env*
+	      evalhook xcl::nohook xcl::undohook
+	      xcl::execa0001 xcl::execa0001a0002
+	      xcl::|interpret-UNDOABLY|
+	      cl::|interpret-IF| cl::|interpret-FLET|
+	      cl::|interpret-LET| cl::|interpret-LETA0001|
+	      cl::|interpret-BLOCK| cl::|interpret-BLOCKA0001|
+	      il:do-event il:eval-input
+	      apply t))
+  (setf (get fn 'xcl::uninterestingp) t))
+
+(defun xcl::interesting-frame-p (xcl::pos &optional xcl::interpflg)
+  "Return TRUE iff the frame should be visible for a short backtrace."
+  (declare (special il:openfns))
+  (let ((xcl::name (if (il:stackp xcl::pos) (il:stkname xcl::pos) xcl::pos)))
+    (typecase xcl::name
+      (symbol (case xcl::name
+		(il:*env*
+		 ;; *ENV* is used by ENVEVAL etc.
+		 nil)
+		(il:errorset
+		 (or (<= (il:stknargs xcl::pos) 1)
+		     (not (eq (il:stkarg 2 xcl::pos nil)
+			      'il:internal))))
+		(il:eval
+		 (or (<= (il:stknargs xcl::pos) 1)
+		     (not (eq (il:stkarg 2 xcl::pos nil)
+			      'xcl::internal))))
+		(il:apply
+		 (or (<= (il:stknargs xcl::pos) 2)
+		     (not (il:stkarg 3 xcl::pos nil))))
+		(otherwise
+		 (cond ((get xcl::name 'xcl::uninterestingp)
+			;; Explicitly declared uninteresting.
+			nil)
+		       ((eq (il:chcon1 xcl::name) (char-code #\\))
+			;; Implicitly declared uninteresting by starting the
+			;; name with a "\".
+			nil)
+		       ((or (member xcl::name il:openfns :test #'eq)
+			    (eq xcl::name 'funcall))
+			;;The function won't be seen when compiled, so only show
+			;;it if INTERPFLG it true
+			xcl::interpflg)
+		       (t 
+			;; Interesting by default.
+			t)))))
+       (cons (case (car xcl::name)
+	       (:broken t)
+	       (otherwise nil)))
+       (otherwise nil))))
+
+(setq il:*short-backtrace-filter* 'xcl::interesting-frame-p)
+
+
+(eval-when (eval compile)
+  (il:record il:bkmenuitem (il:label (il:bkmenuinfo il:frame-name))))
+
+
+;;  Change the frame inspector to open up lexical environments
+
+  ;; Since the DEFSTRUCT is going to build the accessors in the package that is
+  ;; current at read-time, and we want the accessors to reside in the IL
+  ;; package, we have got to make sure that the defstruct happens when the
+  ;; package is IL.
+
+(in-package "IL")
+
+(cl:defstruct (frame-prop-name (:type cl:list))
+  (label-fn 'nill)
+  (value-fn
+   (function
+    (lambda (prop-name framespec)
+     (frame-prop-name-data prop-name))))
+  (setf-fn 'nill)
+  (inspect-fn
+   (function
+    (lambda (value prop-name framespec window)
+     (default.inspectw.valuecommandfn value prop-name (car framespec) window))))
+  (data nil))
+
+(cl:in-package "CLOS")
+
+(defun il:debugger-stack-frame-prop-names (il:framespec) 
+  ;; Frame prop-names are structures of the form
+  ;; (LABEL-FN VALUE-FN SETF-FN EDIT-FN DATA)
+  (let ((il:pos (car il:framespec))
+	(il:backtrace-item (cadr il:framespec)))
+    (il:if (eq 'eval (il:stkname il:pos))
+     il:then
+     (let ((il:expression (il:stkarg 1 il:pos))
+	   (il:environment (il:stkarg 2 il:pos)))
+       `(,(il:make-frame-prop-name :inspect-fn
+	   (il:function
+	    (il:lambda (il:value il:prop-name il:framespec il:window)
+	      (il:inspect/as/function il:value (car il:framespec) il:window)))
+	   :data il:expression)
+	 ,(il:make-frame-prop-name :data "ENVIRONMENT")
+	 ,@(il:for il:aspect il:in
+	    `((,(and il:environment (il:environment-vars il:environment))
+	       "vars")
+	      (,(and il:environment (il:environment-functions il:environment))
+	       "functions")
+	      (,(and il:environment (il:environment-blocks il:environment))
+	       "blocks")
+	      (,(and il:environment (il:environment-tagbodies il:environment))
+	       "tag bodies"))
+	    il:bind il:group-name il:p-list
+	    il:eachtime (il:setq il:group-name (cadr il:aspect))
+	                (il:setq il:p-list (car il:aspect))
+	    il:when (not (null il:p-list))
+	    il:join
+	    `(,(il:make-frame-prop-name :data il:group-name)
+	      ,@(il:for il:p il:on il:p-list il:by cddr il:collect
+		 (il:make-frame-prop-name :label-fn
+		  (il:function (il:lambda (il:prop-name il:framespec)
+				 (car (il:frame-prop-name-data il:prop-name))))
+		  :value-fn
+		  (il:function (il:lambda (il:prop-name il:framespec)
+				 (cadr (il:frame-prop-name-data il:prop-name))))
+		  :setf-fn
+		  (il:function (il:lambda (il:prop-name il:framespec il:new-value)
+				 (il:change (cadr (il:frame-prop-name-data
+						   il:prop-name))
+					    il:new-value)))
+		  :data il:p))))))
+     il:else
+     (flet ((il:build-name (&key il:arg-name il:arg-number)
+	      (il:make-frame-prop-name :label-fn
+		  (il:function (il:lambda (il:prop-name il:framespec)
+				 (car (il:frame-prop-name-data il:prop-name))))
+		  :value-fn
+		  (il:function (il:lambda (il:prop-name il:framespec)
+				 (il:stkarg (cadr (il:frame-prop-name-data
+						   il:prop-name))
+					    (car il:framespec))))
+		  :setf-fn
+		  (il:function (il:lambda (il:prop-name il:framespec il:new-value)
+				 (il:setstkarg (cadr (il:frame-prop-name-data
+						      il:prop-name))
+					       (car il:framespec)
+					       il:new-value)))
+		  :data
+		  (list il:arg-name il:arg-number))))
+       (let ((il:nargs (il:stknargs il:pos t))
+	     (il:nargs1 (il:stknargs il:pos))
+	     (il:fnname (il:stkname il:pos))
+	     il:argname
+	     (il:arglist))
+	 (and (il:litatom il:fnname)
+	      (il:ccodep il:fnname)
+	      (il:setq il:arglist (il:listp (il:smartarglist il:fnname))))
+	 `(,(il:make-frame-prop-name :inspect-fn
+	     (il:function (il:lambda (il:value il:prop-name il:framespec
+					       il:window)
+			    (il:inspect/as/function il:value
+						    (car il:framespec)
+						    il:window)))
+	     :data
+	     (il:fetch (il:bkmenuitem il:frame-name) il:of il:backtrace-item))
+	   ,@(il:bind il:mode il:for il:i il:from 1 il:to il:nargs1 il:collect
+	      (progn (il:while (il:fmemb (il:setq il:argname (il:pop il:arglist))
+					 lambda-list-keywords)
+			       il:do
+			       (il:setq il:mode il:argname))
+		     (il:build-name :arg-name
+				    (or (il:stkargname il:i il:pos)
+					; special
+					(if (case il:mode
+					      ((nil &optional) il:argname)
+					      (t nil))
+					    (string il:argname)
+					    (il:concat "arg " (- il:i 1))))
+				    :arg-number il:i)))
+	   ,@(let* ((il:novalue "No value")
+		    (il:slots (il:for il:pvar il:from 0 il:as il:i il:from
+				      (il:add1 il:nargs1)
+				      il:to il:nargs il:by 1 il:when
+				      (and (il:neq il:novalue (il:stkarg il:i il:pos
+									 il:novalue))
+					   (or (il:setq il:argname (il:stkargname
+								    il:i il:pos))
+					       (il:setq il:argname (il:concat 
+								    "local " 
+								    il:pvar)))
+					   )
+				      il:collect
+				      (il:build-name :arg-name il:argname 
+						     :arg-number il:i))))
+               (and il:slots (cons (il:make-frame-prop-name :data "locals")
+                                   il:slots)))))))))
+
+(defun il:debugger-stack-frame-fetchfn (il:framespec il:prop-name)
+  (il:apply* (il:frame-prop-name-value-fn il:prop-name)
+	     il:prop-name il:framespec))
+
+(defun il:debugger-stack-frame-storefn (il:framespec il:prop-name il:newvalue)
+  (il:apply* (il:frame-prop-name-setf-fn il:prop-name)
+	     il:prop-name il:framespec il:newvalue))
+
+(defun il:debugger-stack-frame-value-command (il:datum il:prop-name 
+						       il:framespec il:window)
+  (il:apply* (il:frame-prop-name-inspect-fn il:prop-name)
+	     il:datum il:prop-name il:framespec il:window))
+
+(defun il:debugger-stack-frame-title (il:framespec &optional il:window)
+  (declare (ignore il:window))
+  (il:concat (il:stkname (car il:framespec)) "  Frame"))
+
+(defun il:debugger-stack-frame-property (il:prop-name il:framespec)
+  (il:apply* (il:frame-prop-name-label-fn il:prop-name)
+	     il:prop-name il:framespec))
+
+;; Teaching the debugger that there are other file-manager types that can
+;; appear on the stack
+
+(defvar xcl::*function-types* '(il:fns il:functions)
+  "Manager types that can appear on the stack")
+
+;; Redefine a couple of system functions to use the above stuff
+
+#+Xerox-Lyric
+(progn
+
+(defun il:attach-backtrace-menu (&optional (il:ttywindow
+					    (il:wfromds (il:ttydisplaystream)))
+					   il:skip)
+  (let ((il:bkmenu (il:|create| il:menu
+		       il:items il:_
+		       (il:collect-backtrace-items il:ttywindow il:skip)
+		       il:whenselectedfn il:_
+		       (il:function il:backtrace-item-selected)
+		       il:whenheldfn il:_
+		       #'(il:lambda (il:item il:menu il:button)
+			   (declare (ignore il:item il:menu))
+			   (case il:button
+			     (il:left (il:promptprint 
+				       "Open a frame inspector on this stack frame"
+				       ))
+			     (il:middle (il:promptprint 
+					 "Inspect/Edit this function"))
+			     ))
+		       il:menuoutlinesize il:_ 0
+		       il:menufont il:_ il:backtracefont
+		       il:menucolumns il:_ 1))
+	(il:ttyregion (il:windowprop il:ttywindow 'il:region))
+	il:btw)
+    (cond
+      ((il:setq il:btw (il:|for| il:atw il:|in| (il:attachedwindows il:ttywindow)
+			   il:|when| (and (il:setq il:btw (il:windowprop il:atw 'il:menu))
+					  (eql (il:|fetch| (il:menu il:whenselectedfn)
+						   il:|of| (car il:btw))
+					       (il:function il:backtrace-item-selected)))
+			   il:|do|                       
+			   (return il:atw)))       
+       (il:deletemenu (car (il:windowprop il:btw 'il:menu))
+		      nil il:btw)
+       (il:windowprop il:btw 'il:extent nil)
+       (il:clearw il:btw))
+      ((il:setq il:btw (il:createw (il:region-next-to (il:windowprop il:ttywindow 'il:region)
+						      (il:widthifwindow (il:imin (il:|fetch| (il:menu 
+											      il:imagewidth
+											      )
+										     il:|of| il:bkmenu)
+										 il:|MaxBkMenuWidth|))
+						      (il:|fetch| (il:region il:height) il:|of| il:ttyregion
+							  )
+						      'il:left)))   
+       (il:attachwindow il:btw il:ttywindow (cond
+					      ((il:igreaterp (il:|fetch| (il:region il:left)
+								 il:|of| (il:windowprop
+									  il:btw
+									  'il:region))
+							     (il:|fetch| (il:region il:left)
+								 il:|of| il:ttyregion))
+					       'il:right)
+					      (t 'il:left))
+			nil
+			'il:localclose)
+       (il:windowprop il:btw 'il:process (il:windowprop il:ttywindow 'il:process))
+
+       ))
+    (il:addmenu il:bkmenu il:btw (il:|create| il:_ il:position
+				     il:xcoord il:_ 0
+				     il:ycoord il:_ (il:idifference (il:windowprop
+								     il:btw
+								     'il:height)
+								    (il:|fetch| (il:menu il:imageheight
+											 ) il:|of| 
+											   il:bkmenu
+											   ))))))
+
+(defun il:backtrace-item-selected (il:item il:menu il:button)
+  (il:resetlst
+   (prog (il:olditem il:ttywindow il:bkpos il:pos il:positions il:framewindow
+		     (il:framespecn (il:|fetch| (il:bkmenuitem il:bkmenuinfo) il:|of| il:item)
+
+				    ))
+      (cond
+	((il:setq il:olditem (il:|fetch| (il:menu il:menuuserdata) il:|of| il:menu))
+	 (il:menudeselect il:olditem il:menu)        
+	 ))
+      (il:setq il:ttywindow (il:windowprop (il:wfrommenu il:menu)
+					   'il:mainwindow))
+      (il:setq il:bkpos (il:windowprop il:ttywindow 'il:stack-position))
+      (il:setq il:pos (il:stknth (- il:framespecn)
+				 il:bkpos))
+      (let ((il:lp (il:windowprop il:ttywindow 'il:lastpos)))
+	(and il:lp (il:stknth 0 il:pos il:lp)))
+      (il:menuselect il:item il:menu)                
+      (if (eq il:button 'il:middle)
+	  (progn 
+
+
+	    (il:resetsave nil (list 'il:relstk il:pos))
+	    (il:inspect/as/function (il:|fetch| (il:bkmenuitem il:frame-name)
+					il:|of| il:item)
+				    il:pos il:ttywindow))
+	  (progn 
+
+
+	    (il:setq il:framewindow
+		     (xcl:with-profile (il:process.eval
+						  (il:windowprop il:ttywindow 'il:process)
+						  '(let ((il:profile (xcl:copy-profile (xcl:find-profile
+											"READ-PRINT"))))
+						    (setf (xcl::profile-entry-value '
+							   xcl:*eval-function* il:profile)
+						     xcl:*eval-function*)
+						    (xcl:save-profile il:profile))
+						  t)
+		       (il:inspectw.create (list il:pos il:item)
+				   'il:debugger-stack-frame-prop-names
+				   'il:debugger-stack-frame-fetchfn
+				   'il:debugger-stack-frame-storefn nil '
+				   il:debugger-stack-frame-value-command nil '
+				   il:debugger-stack-frame-title nil (
+								      il:make-frame-inspect-window
+								      il:ttywindow)
+				   'il:debugger-stack-frame-property)))
+	    (cond
+	      ((not (il:windowprop il:framewindow 'il:mainwindow))
+	       (il:attachwindow il:framewindow il:ttywindow
+				(cond
+				  ((il:igreaterp (il:|fetch| (il:region il:bottom)
+						     il:|of| (il:windowprop il:framewindow
+									    'il:region))
+						 (il:|fetch| (il:region il:bottom)
+						     il:|of| (il:windowprop il:ttywindow 'il:region)))
+				   'il:top)
+				  (t 'il:bottom))
+				nil
+				'il:localclose)
+	       (il:windowaddprop il:framewindow 'il:closefn (il:function il:detachwindow
+									 ))))))
+      (return))))
+
+(defun il:collect-backtrace-items (xcl::tty-window xcl::skip)
+   (let* ((xcl::items (cons nil nil))
+          (xcl::items-tail xcl::items))
+         (macrolet ((xcl::collect-item (xcl::new-item)
+                           `(progn (setf (rest xcl::items-tail)
+                                         (cons ,xcl::new-item nil))
+                                   (pop xcl::items-tail))))
+                (let* ((xcl::filter-fn (cond
+                                          ((null xcl::skip)
+                                           #'xcl:true)
+                                          ((eq xcl::skip t)
+                                           il:*short-backtrace-filter*)
+                                          (t xcl::skip)))
+                       (xcl::top-frame (il:stknth 0 (il:getwindowprop xcl::tty-window '
+                                                           il:stack-position)))
+                       (xcl::next-frame xcl::top-frame)
+                       (xcl::frame-number 0)
+                       xcl::interesting-p xcl::last-frame-consumed xcl::use-frame xcl::label)
+                      (loop (when (null xcl::next-frame)
+                                  (return))
+                            (multiple-value-setq (xcl::interesting-p xcl::last-frame-consumed 
+                                                        xcl::use-frame xcl::label)
+                                   (funcall xcl::filter-fn xcl::next-frame))
+                            (when (null xcl::last-frame-consumed)
+                                                            
+                                (setf xcl::last-frame-consumed xcl::next-frame))
+                            (when xcl::interesting-p        
+                                (when (null xcl::use-frame)
+                                      (setf xcl::use-frame xcl::last-frame-consumed))
+                                                             
+                                (when (null xcl::label)
+                                    (setf xcl::label (il:stkname xcl::use-frame))
+                                    (if (member xcl::label '(eval il:eval il:apply apply)
+                                               :test
+                                               'eq)
+                                        (setf xcl::label (il:stkarg 1 xcl::use-frame))))
+                                                            
+                                (loop (cond
+                                         ((not (typep xcl::next-frame 'il:stackp))
+                                          (error "~%Use-frame ~S not found" xcl::use-frame))
+                                         ((xcl::stack-eql xcl::next-frame xcl::use-frame)
+                                          (return))
+                                         (t (incf xcl::frame-number)
+                                            (setf xcl::next-frame (il:stknth -1 xcl::next-frame 
+                                                                         xcl::next-frame)))))
+                                                             
+                                (xcl::collect-item (il:|create| il:bkmenuitem
+                                                          il:label il:_ (let ((*print-level* 2)
+                                                                              (*print-length* 3)
+                                                                              (*print-escape* t)
+                                                                              (*print-gensym* t)
+                                                                              (*print-pretty* nil)
+                                                                              (*print-circle* nil)
+                                                                              (*print-radix* 10)
+                                                                              (*print-array* nil)
+                                                                              (il:*print-structure*
+                                                                               nil))
+                                                                             (prin1-to-string 
+                                                                                    xcl::label))
+                                                          il:bkmenuinfo il:_ xcl::frame-number
+                                                          il:frame-name il:_ xcl::label)))
+                                                             
+                            (loop (cond
+                                     ((not (typep xcl::next-frame 'il:stackp))
+                                      (error "~%Last-frame-consumed ~S not found" 
+                                             xcl::last-frame-consumed))
+                                     ((prog1 (xcl::stack-eql xcl::next-frame xcl::last-frame-consumed
+                                                    )
+                                          (incf xcl::frame-number)
+                                          (setf xcl::next-frame (il:stknth -1 xcl::next-frame 
+                                                             
+                                                                       xcl::next-frame)))
+                                      (return)))))))
+         (rest xcl::items)))
+
+)
+#+Xerox-Medley
+(progn
+
+(defun dbg::attach-backtrace-menu (&optional tty-window skip)
+  (declare (special il:\\term.ofd il:backtracefont))
+  (or tty-window (il:setq tty-window (il:wfromds (il:ttydisplaystream))))
+  (prog (btw bkmenu
+	     (tty-region (il:windowprop tty-window 'il:region))
+	     ;; And, for the FORMAT below...
+	     (*print-level* 2)
+	     (*print-length* 3)
+	     (*print-escape* t)
+	     (*print-gensym* t)
+	     (*print-pretty* nil)
+	     (*print-circle* nil)
+	     (*print-radix* 10)
+	     (*print-array* nil)
+	     (il:*print-structure* nil))
+     (setq bkmenu
+	   (il:|create| il:menu
+	       il:items il:_ (dbg::collect-backtrace-items tty-window skip)
+	       il:whenselectedfn il:_ 'dbg::backtrace-item-selected
+	       il:menuoutlinesize il:_ 0
+	       il:menufont il:_ il:backtracefont 
+	       il:menucolumns il:_ 1
+	       il:whenheldfn il:_
+	       #'(il:lambda (item menu button)
+		   (declare (ignore item menu))
+		   (case button
+		     (il:left
+		      (il:promptprint
+		       "Open a frame inspector on this stack frame"))
+		     (il:middle
+		      (il:promptprint "Inspect/Edit this function"))))))
+     (cond ((setq btw
+		  (dolist (atw  (il:attachedwindows tty-window))
+		    ;; Test for an attached window that has a backtrace menu in
+		    ;; it.
+		    (when (and (setq btw (il:windowprop atw 'il:menu))
+			   (eq (il:|fetch| (il:menu il:whenselectedfn)
+				   il:|of| (car btw))
+			       'dbg::backtrace-item-selected))
+		      (return atw))))
+	    ;; If there is alread a backtrace window, delete the old menu from
+	    ;; it.
+	    (il:deletemenu (car (il:windowprop btw 'il:menu)) nil btw)
+	    (il:windowprop btw 'il:extent nil)
+	    (il:clearw btw))
+	   ((setq btw
+		  (il:createw (dbg::region-next-to
+			       (il:windowprop tty-window 'il:region)
+			       (il:widthifwindow
+				(il:imin (il:|fetch| (il:menu il:imagewidth)
+					     il:|of| bkmenu)
+					 il:|MaxBkMenuWidth|))
+			       (il:|fetch| (il:region il:height)
+				   il:|of| tty-region)
+			       :left)))
+					; put bt window at left of TTY
+					; window unless ttywindow is
+					; near left edge.
+	    (il:attachwindow btw tty-window
+			     (if (il:igreaterp (il:|fetch| (il:region il:left)
+						   il:|of|
+						   (il:windowprop btw
+								  'il:region))
+					       (il:|fetch| (il:region il:left)
+						   il:|of| tty-region))
+				 'il:right
+				 'il:left)
+			     nil
+			     'il:localclose)
+	    ;; So that button clicks will switch the TTY
+	    (il:windowprop btw 'il:process
+			   (il:windowprop tty-window 'il:process))))
+     (il:addmenu bkmenu btw (il:|create| il:position
+				il:xcoord il:_ 0 
+				il:ycoord il:_ (- (il:windowprop btw 'il:height)
+						  (il:|fetch| (il:menu 
+							       il:imageheight)
+						      il:|of| bkmenu))))
+     ;; IL:ADDMENU sets up buttoneventfn for window that we don't
+     ;; want.  We want to catch middle button events before the menu
+     ;; handler, so that we can pop up edit/inspect menu for the frame
+     ;; currently selected.  So replace the buttoneventfn, and can
+     ;; nuke the cursorin and cursormoved guys, cause don't need them.
+     (il:windowprop btw 'il:buttoneventfn 'dbg::backtrace-menu-buttoneventfn)
+     (il:windowprop btw 'il:cursorinfn nil)
+     (il:windowprop btw 'il:cursormovedfn nil)))
+
+(defun dbg::collect-backtrace-items (tty-window skip)
+  (xcl:with-collection
+      ;;
+      ;; There are a number of possibilities for the values returned by the
+      ;; filter-fn.
+      ;;
+      ;; (1) INTERESTING-P is false, and the other values are all NIL.  This
+      ;; is the simple case where the stack frame NEXT-POS should be ignored
+      ;; completly, and processing should continue with the next frame.
+      ;;
+      ;; (2) INTERESTING-P is true, and the other values are all NIL.  This
+      ;; is the simple case where the stack frame NEXT-POS should appear in
+      ;; the backtrace as is, and processing should continue with the next
+      ;; frame.
+      ;;
+      ;; [Note that these two cases take care of old values of the
+      ;; filter-fn.]
+      ;;
+      ;; (3) INTERESTING-P is false, and LAST-FRAME-CONSUMED is a stack
+      ;; frame.  In that case, ignore all stack frames from NEXT-POS to
+      ;; LAST-FRAME-CONSUMED, inclusive.
+      ;;
+      ;; (4) INTERESTING-P is true, and LAST-FRAME-CONSUMED is a stack
+      ;; frame.  In this case, the backtrace should include a single entry
+      ;; coresponding to the frame USE-FRAME (which defaults to
+      ;; LAST-FRAME-CONSUMED), and processing should continue with the next
+      ;; frame after LAST-FRAME-CONSUMED.  If LABEL is non-NIL, it will be
+      ;; the label that appears in the backtrace menu; otherwise the name of
+      ;; USE-FRAME will be used (or the form being EVALed if the frame is an
+      ;; EVAL frame).
+      ;;
+      (let* ((filter (cond ((null skip) #'xcl:true)
+			   ((eq skip t) il:*short-backtrace-filter*)
+			   (t skip)))
+	     (top-frame (il:stknth 0 (il:getwindowprop tty-window
+					      'dbg::stack-position)))
+	     (next-frame top-frame)
+	     (frame-number 0)
+	     interestingp last-frame-consumed frame-to-use label-to-use)
+	(loop (when (null next-frame) (return))
+	      ;; Get the values of INTERSTINGP, LAST-FRAME-CONSUMED,
+	      ;; FRAME-TO-USE, and LABEL-TO-USE
+	      (multiple-value-setq (interestingp last-frame-consumed 
+						 frame-to-use label-to-use)
+		(funcall filter next-frame))
+	      (when (null last-frame-consumed)
+		(setf last-frame-consumed next-frame))
+	      (when interestingp
+		(when (null frame-to-use)
+		  (setf frame-to-use last-frame-consumed))
+		(when (null label-to-use)
+		  (setf label-to-use (il:stkname frame-to-use))
+		  (if (member label-to-use '(eval il:eval il:apply apply)
+			      :test 'eq)
+		      (setf label-to-use (il:stkarg 1 frame-to-use))))
+
+		;; Walk the stack until we find the frame to use
+		(loop (cond ((not (typep next-frame 'il:stackp))
+			     (error "~%Use-frame ~S not found" frame-to-use))
+			    ((xcl::stack-eql next-frame frame-to-use)
+			     (return))
+			    (t (incf frame-number)
+			       (setf next-frame
+				     (il:stknth -1 next-frame next-frame)))))
+
+		;; Add the menu item to the list under construction
+		(xcl:collect (il:|create| il:bkmenuitem
+				 il:label il:_ (let ((*print-level* 2)
+						     (*print-length* 3)
+						     (*print-escape* t)
+						     (*print-gensym* t)
+						     (*print-pretty* nil)
+						     (*print-circle* nil)
+						     (*print-radix* 10)
+						     (*print-array* nil)
+						     (il:*print-structure* nil))
+						 (prin1-to-string label-to-use))
+				 il:bkmenuinfo il:_ frame-number
+				 il:frame-name il:_ label-to-use)))
+
+	      ;; Update NEXT-POS
+	      (loop (cond ((not (typep next-frame 'il:stackp))
+			   (error "~%Last-frame-consumed ~S not found" 
+				  last-frame-consumed))
+			  ((prog1
+			       (xcl::stack-eql next-frame last-frame-consumed)
+			     (incf frame-number)
+			     (setf next-frame (il:stknth -1 next-frame
+							 next-frame)))
+			   (return))))))))
+
+(defun dbg::backtrace-menu-buttoneventfn (window &aux menu)
+  (setq menu (car (il:listp (il:windowprop window 'il:menu))))
+  (unless (or (il:lastmousestate il:up) (null menu))
+    (il:totopw window)
+    (cond ((il:lastmousestate il:middle)
+	   ;; look for a selected frame in this menu, and then pop up
+	   ;; the editor invoke menu for that frame.  don't change the
+	   ;; selection, just present the edit menu.
+	   (let* ((selection (il:menu.handler menu
+					  (il:windowprop window 'il:dsp)))
+		  (tty-window (il:windowprop window 'il:mainwindow))
+		  (last-pos (il:windowprop tty-window 'dbg::lastpos)))
+                        
+	     ;; don't have to worry about releasing POS because we
+	     ;; only look at it here (nobody here hangs on to it)
+	     ;; and we will be around for less time than LASTPOS. 
+	     ;; The debugger is responsible for releasing LASTPOS.
+	     (il:inspect/as/function (cond
+				       ((and selection
+					     (il:|fetch| (il:bkmenuitem il:frame-name)
+						 il:|of| (car selection))))
+				       ((and (symbolp (il:stkname last-pos))
+					     (il:getd (il:stkname last-pos)))
+					(il:stkname last-pos))
+				       (t 'il:nill))
+				     last-pos tty-window)))
+	  (t (let ((selection (il:menu.handler menu
+					   (il:windowprop window 'il:dsp))))
+	       (when selection
+		 (il:doselecteditem menu (car selection) (cdr selection))))))))
+
+;; This function isn't really redefined, but it needs to be recomiled since we
+;; changed the def'n of the BKMENUITEM record.
+
+(defun dbg::backtrace-item-selected (item menu button)
+  ;;When a frame name is selected in the backtrace menu, this is the function
+  ;;that gets called.
+  (declare (special il:brkenv) (ignore button))
+  (let* ((frame-spec (il:|fetch| (il:bkmenuitem il:bkmenuinfo) il:|of| item))
+	 (tty-window (il:windowprop (il:wfrommenu menu) 'il:mainwindow))
+	 (bkpos (il:windowprop tty-window 'dbg::stack-position))
+	 (pos (il:stknth (- frame-spec) bkpos)))
+    (let ((lp (il:windowprop tty-window 'dbg::lastpos)))
+      (and lp (il:stknth 0 pos lp)))
+    ;; change the item selected from OLDITEM to ITEM.  Only do this on left
+    ;; buttons now.  Middle just pops up the edit menu, doesn't select. -woz
+    (let ((old-item (il:|fetch| (il:menu il:menuuserdata) il:|of| menu)))
+      (when old-item (il:menudeselect old-item menu))
+      (il:menuselect item menu))
+    ;; Change the lexical environment so it is the one in effect as of this
+    ;; frame.
+    (il:process.eval (il:windowprop tty-window (quote dbg::process))
+	       `(setq il:brkenv ',(il:find-lexical-environment pos))
+	       t)
+    (let ((frame-window (xcl:with-profile
+			    (il:process.eval (il:windowprop tty-window
+							    'il:process)
+				       `(let ((profile (xcl:copy-profile
+							(xcl:find-profile
+							 "READ-PRINT"))))
+					 (setf
+					  (xcl::profile-entry-value
+					   'xcl:*eval-function* profile)
+					  xcl:*eval-function*)
+					 (xcl:save-profile profile))
+				       t)
+			  (il:inspectw.create pos
+				      #'(lambda (pos)
+					  (dbg::stack-frame-properties pos t))
+				      'dbg::stack-frame-fetchfn
+				      'dbg::stack-frame-storefn
+				      nil
+				      'dbg::stack-frame-value-command
+				      nil
+				      (format nil "~S  Frame" (il:stkname pos))
+				      nil (dbg::make-frame-inspect-window
+					   tty-window)
+				      'dbg::stack-frame-property))))
+      (when (not (il:windowprop frame-window 'il:mainwindow))
+	(il:attachwindow frame-window tty-window
+			 (if (> (il:|fetch| (il:region il:bottom) il:|of|
+				    (il:windowprop frame-window 'il:region))
+				(il:|fetch| (il:region il:bottom) il:|of|
+				    (il:windowprop tty-window 'il:region)))
+			     'il:top 'il:bottom)
+			 nil 'il:localclose)
+	(il:windowaddprop frame-window 'il:closefn 'il:detachwindow)))))
+
+)					;end of Xerox-Medley
+
+(defun il:select.fns.editor (&optional function)
+    ;; gives the user a menu choice of editors.
+    (il:menu (il:|create| il:menu
+		 il:items il:_ (cond ((il:ccodep function)
+				      '((il:|InspectCode| 'il:inspectcode 
+					 "Shows the compiled code.")
+					(il:|DisplayEdit| 'ed 
+					 "Edit it with the display editor")
+					(il:|TtyEdit| 'il:ef 
+					 "Edit it with the standard editor")))
+				     ((il:closure-p function)
+				      '((il:|Inspect| 'inspect 
+					 "Inspect this object")))
+				     (t '((il:|DisplayEdit| 'ed 
+					   "Edit it with the display editor")
+					  (il:|TtyEdit| 'il:ef 
+					   "Edit it with the standard editor"))))
+		 il:centerflg il:_ t)))
+
+;; 
+
+
+;; CLOS specific extensions to the debugger
+
+
+;; There are some new things that act as functions, and that we want to be
+;; able to edit from a backtrace window
+
+(pushnew 'methods xcl::*function-types*)
+
+(eval-when (eval compile load)
+  (unless (generic-function-p (symbol-function 'il:inspect/as/function))
+    (make-specializable 'il:inspect/as/function)))
+
+(defmethod il:inspect/as/function (name stack-pointer debugger-window)
+  ;; Calls an editor on function NAME.  STKP and WINDOW are the stack pointer
+  ;; and window of the break in which this inspect command was called.
+  (declare (ignore debugger-window))
+  (let ((editor (il:select.fns.editor name)))
+    (case editor
+      ((nil) 
+       ;; No editor chosen, so don't do anything
+       nil)
+      (il:inspectcode 
+       ;; Inspect the compiled code
+       (let ((frame (xcl::stack-pointer-frame stack-pointer)))
+	 (if (and (il:stackp stack-pointer)
+		  (xcl::stack-frame-valid-p frame))
+	     (il:inspectcode (let ((code-base (xcl::stack-frame-fn-header frame)))
+			       (cond ((eq (il:\\get-compiled-code-base name)
+					  code-base)
+				      name)
+				     (t 
+				      ;; Function executing in this frame is not
+				      ;; the one in the definition cell of its
+				      ;; name, so fetch the real code.  Have to
+				      ;; pass a CCODEP
+				      (il:make-compiled-closure code-base))))
+                             nil nil nil (xcl::stack-frame-pc frame))
+	     (il:inspectcode name))))
+      (ed 
+       ;; Use the standard editor.
+       ;; This used to take care to apply the editor in the debugger
+       ;; process, so forms evaluated in the editor happen in the
+       ;; context of the break.  But that doesn't count for much any
+       ;; more, now that lexical variables are the way to go.  Better to
+       ;; use the LEX debugger command (thank you, Herbie) and
+       ;; shift-select pieces of code from the editor into the debugger
+       ;; window. 
+       (ed name `(,@xcl::*function-types* :display)))
+      (otherwise (funcall editor name)))))
+
+(defmethod il:inspect/as/function ((name standard-object) stkp window)
+  (when (il:menu (il:|create| il:menu
+		     il:items il:_ '(("Inspect" t "Inspect this object"))))
+    (inspect name)))
+
+(defmethod il:inspect/as/function ((x standard-method) stkp window)
+  (let* ((generic-function-name (slot-value (slot-value x 'generic-function)
+					    'name))
+	 (method-name (full-method-name x))
+	 (editor (il:select.fns.editor method-name)))
+    (il:allow.button.events)
+    (case editor
+      (ed (ed method-name '(:display methods)))
+      (il:inspectcode (il:inspectcode (slot-value x 'function)))
+      ((nil) nil)
+      (otherwise (funcall editor method-name)))))
+
+;; A replacement for the vanilla IL:INTERESTING-FRAME-P so we can see methods
+;; and generic-functions on the stack.
+
+(defun interesting-frame-p (stack-pos &optional interp-flag)
+  ;; Return up to four values:  INTERESTING-P LAST-FRAME-CONSUMED USE-FRAME and
+  ;; LABEL.  See the function IL:COLLECT-BACKTRACE-ITEMS for a full description
+  ;; of how these values are used.
+  (labels
+      ((function-matches-frame-p (function frame)
+	   "Is the function being called in this frame?"
+	   (let* ((frame-name (il:stkname frame))
+		  (code-being-run (cond
+				    ((typep frame-name 'il:closure)
+				     frame-name)
+				    ((and (consp frame-name)
+					  (eq 'il:\\interpreter
+					      (xcl::stack-frame-name
+					       (il:\\stackargptr frame))))
+				     frame-name)
+				    (t (xcl::stack-frame-fn-header
+					(il:\\stackargptr frame))))))
+	     (or (eq function code-being-run)
+		 (and (typep function 'il:compiled-closure)
+		      (eq (xcl::compiled-closure-fnheader function)
+			  code-being-run)))))
+       (generic-function-from-frame (frame)
+	 "If this the frame of a generic function return the gf, otherwise
+          return NIL."
+	 ;; Generic functions are implemented as compiled closures.  On the
+	 ;; stack, we only see the fnheader for the the closure.  This could
+	 ;; be a discriminator code, or in the default method only case it
+	 ;; will be the actual method function.  To tell if this is a generic
+	 ;; function frame, we have to check very carefully to see if the
+	 ;; right stuff is on the stack.  Specifically, the closure's ccode,
+	 ;; and the first local variable has to be a ptrhunk big enough to be
+	 ;; a FIN environment, and fin-env-fin of that ptrhunk has to point
+	 ;; to a generic function whose ccode and environment match. 
+	 (let ((n-args (il:stknargs frame))
+	       (env nil)
+	       (gf nil))
+	   (if (and ;; is there at least one local?
+		(> (il:stknargs frame t) n-args)
+		;; and does the local contain something that might be
+		;; the closure environment of a funcallable instance?
+		(setf env (il:stkarg (1+ n-args) frame))
+		;; and does the local contain something that might be
+		;; the closure environment of a funcallable instance?
+		(typep env *fin-env-type*)
+		(setf gf (fin-env-fin env))
+		;; whose fin-env-fin points to a generic function?
+		(generic-function-p gf)
+		;; whose environment is the same as env?
+		(eq (xcl::compiled-closure-env gf) env)
+		;; and whose code is the same as the code for this
+		;; frame? 
+		(function-matches-frame-p gf frame))
+	       gf
+	       nil))))
+    (let ((frame-name (il:stkname stack-pos)))
+      ;; See if there is a generic-function on the stack at this
+      ;; location.
+      (let ((gf (generic-function-from-frame stack-pos)))
+	(when gf
+	  (return-from interesting-frame-p (values t stack-pos stack-pos gf))))
+      ;; See if this is an interpreted method.  The method body is
+      ;; wrapped in a (BLOCK <function-name> ...).  We look for an
+      ;; interpreted call to BLOCK whose block-name is the name of
+      ;; generic-function.
+      (when (and (eq frame-name 'eval)
+		 (consp (il:stkarg 1 stack-pos))
+		 (eq (first (il:stkarg 1 stack-pos)) 'block)
+		 (symbolp (second (il:stkarg 1 stack-pos)))
+		 (fboundp (second (il:stkarg 1 stack-pos)))
+		 (generic-function-p
+		     (symbol-function (second (il:stkarg 1 stack-pos)))))
+	(let* ((form (il:stkarg 1 stack-pos))
+	       (block-name (second form))
+	       (generic-function (symbol-function block-name))
+	       (methods (generic-function-methods (symbol-function block-name))))
+	  ;; If this is really a method being called from a
+	  ;; generic-function, the g-f should be no more than a
+	  ;; few(?) frames up the stack.  Check for the method call
+	  ;; by looking for a call to APPLY, where the function
+	  ;; being applied is the code in one of the methods.
+	  (do ((i 100 (1- i))
+	       (previous-pos stack-pos current-pos)
+	       (current-pos (il:stknth -1 stack-pos) (il:stknth -1 current-pos))
+	       (found-method nil)
+	       (method-pos))
+	      ((or (null current-pos) (<= i 0)) nil)
+	    (cond ((equalp generic-function
+			   (generic-function-from-frame current-pos))
+		   (if found-method
+		       (return-from interesting-frame-p
+			 (values t previous-pos method-pos found-method))
+		       (return)))
+		  (found-method nil)
+		  ((eq (il:stkname current-pos) 'apply)
+		   (dolist (method methods)
+		     (when (eq (method-function method)
+			       (il:stkarg 1 current-pos))
+		       (setq method-pos current-pos)
+		       (setq found-method method)
+		       (return))))))))
+      ;; Try to handle compiled methods
+      (when (and (symbolp frame-name)
+		 (not (fboundp frame-name))
+		 (eq (il:chcon1 frame-name)
+		     (il:charcode il:\())
+		 (or (string-equal "(method " (symbol-name frame-name)
+			      :start2 0 :end2 13)
+		     (string-equal "(method " (symbol-name frame-name)
+			      :start2 0 :end2 12)
+		     (string-equal "(method " (symbol-name frame-name)
+			      :start2 0 :end2 8)))
+	;; Looks like a name that CLOS consed up.  See if there is a
+	;; GF nearby up the stack.  If there is, use it to help
+	;; determine which method we have.
+	(do ((i 30 (1- i))
+	     (current-pos (il:stknth -1 stack-pos)
+			  (il:stknth -1 current-pos))
+	     (gf))
+	    ((or (null current-pos)
+		 (<= i 0))
+	     nil)
+	  (setq gf (generic-function-from-frame current-pos))
+	  (when gf
+	    (dolist (method (generic-function-methods gf))
+	      (when (function-matches-frame-p (method-function method)
+					      stack-pos)
+		(return-from interesting-frame-p
+		  (values t stack-pos stack-pos method))))
+	    (return))))
+      ;; If we haven't already returned, use the default method.
+      (xcl::interesting-frame-p stack-pos interp-flag))))
+
+
+(setq il:*short-backtrace-filter* 'interesting-frame-p)
+
+;;; Support for undo
+
+ (defun undoable-setf-slot-value (object slot-name new-value)
+    (if (slot-boundp object slot-name)
+      (il:undosave (list 'undoable-setf-slot-value
+                         object slot-name (slot-value object slot-name)))
+      (il:undosave (list 'slot-makunbound object slot-name)))
+    (setf (slot-value object slot-name) new-value))
+
+  (setf (get 'slot-value :undoable-setf-inverse) 'undoable-setf-slot-value)
+
+
+;;; Support for ?= and friends
+
+;; The arglists for generic-functions are built using gensyms, and don't reflect
+;; any keywords (they are all included in an &REST arg).  Rather then use the
+;; arglist in the code, we use the one that CLOS kindly keeps in the generic-function.
+
+(xcl:advise-function 'il:smartarglist
+  '(if (and il:explainflg
+	(symbolp il:fn)
+	(fboundp il:fn)
+	(generic-function-p (symbol-function il:fn)))
+    (generic-function-pretty-arglist (symbol-function il:fn))
+    (xcl:inner))
+  :when :around :priority :last)
+
+(setf (get 'defclass 'il:argnames)
+      '(nil (class-name (#\{ superclass-name #\} #\*)
+	     (#\{ slot-specifier #\} #\*)
+	     #\{ slot-option #\} #\*)))
+
+(setf (get 'defmethod 'il:argnames)
+      '(nil (#\{ name #\| (setf name) #\} #\{ method-qualifier #\} #\*
+	     specialized-lambda-list #\{ declaration #\| doc-string #\} #\*
+	     #\{ form #\} #\*)))
+
+;;; Prettyprinting support, the result of Harley Davis.
+
+;; Support the standard Prettyprinter.  This is really minimal right now.  If
+;; anybody wants to fix this, I'd be happy to include their code.  In fact,
+;; there is almost no support for Commonlisp in the standard Prettyprinter, so
+;; the field is wide open to hackers with time on their hands.
+
+
+(setf (get 'defmethod :definition-print-template) ;Not quite right, since it
+      '(:name :arglist :body))		          ; doesn't handle qualifiers,
+		          		          ; but it will have to do.
+
+(defun defclass-prettyprint (form)
+  (let ((left (il:dspxposition))
+	(char-width (il:charwidth (il:charcode x) *standard-output*)))
+    (xcl:destructuring-bind (defclass name supers slots . options) form
+      (princ "(")
+      (prin1 defclass)
+      (princ " ")
+      (prin1 name)
+      (princ " ")
+      (if (null supers)
+	  (princ "()")			;Print "()" instead of "nil"
+	  (il:sequential.prettyprint (list supers) (il:dspxposition)))
+      (if (null slots)
+	  (progn (il:prinendline (+ left (* 4 char-width)) *standard-output*)
+		 (princ "()"))
+	  (il:sequential.prettyprint (list slots) (+ left (* 4 char-width))))
+      (when options
+	(il:sequential.prettyprint options (+ left (* 2 char-width))))
+      (princ ")")
+      nil)))
+
+(let ((pprint-macro (assoc 'defclass il:prettyprintmacros)))
+  (if (null pprint-macro)
+      (push (cons 'defclass 'defclass-prettyprint)
+	    il:prettyprintmacros)
+      (setf (cdr pprint-macro) 'defclass-prettyprint)))
+
+(defun binder-prettyprint (form)
+  ;; Prettyprints expressions like MULTIPLE-VALUE-BIND and WITH-SLOTS
+  ;; that are of the form (fn (var ...) form &rest body).
+  ;; This code is far from correct, but it's better than nothing.
+  (if (and (consp form)
+	   (not (null (cdddr form))))
+      ;; I have no idea what I'm doing here.  Seems I can copy and edit somebody
+      ;; elses code without understanding it.
+      (let ((body-indent (+ (il:dspxposition)
+			    (* 2 (il:charwidth (il:charcode x)
+					       *standard-output*))))
+	    (form-indent (+ (il:dspxposition)
+			    (* 4 (il:charwidth (il:charcode x)
+					       *standard-output*)))))
+	(princ "(")
+	(prin1 (first form))
+	(princ " ")
+	(il:superprint (second form) form nil *standard-output*)
+	(il:sequential.prettyprint (list (third form)) form-indent)
+	(il:sequential.prettyprint (cdddr form) body-indent)
+	(princ ")")
+	nil)				;Return NIL to indicate that we did
+					; the printing
+      t))				;Return true to use default printing
+
+
+(dolist (fn '(multiple-value-bind with-accessors with-slots))
+  (let ((pprint-macro (assoc fn 'il:prettyprintmacros)))
+    (if (null pprint-macro)
+	(push (cons fn 'binder-prettyprint)
+	      il:prettyprintmacros)
+	(setf (cdr pprint-macro) 'binder-prettyprint))))
+
+
+
+;; SEdit has its own prettyprinter, so we need to support that too.  This is due
+;; to Harley Davis.  Really.
+
+(push (cons :slot-spec
+	    '(((sedit::prev-keyword? (sedit::next-inline? 1 break sedit::from-indent . 1)
+		break sedit::from-indent . 0)
+	       (sedit::set-indent . 1)
+	       (sedit::next-inline? 1 break sedit::from-indent . 1)
+	       (sedit::prev-keyword? (sedit::next-inline? 1 break sedit::from-indent . 1)
+		break sedit::from-indent . 0))
+	      ((sedit::prev-keyword? (sedit::next-inline? 1 break sedit::from-indent . 1)
+		break sedit::from-indent . 0)
+	       (sedit::set-indent . 1)
+	       (sedit::next-inline? 1 break sedit::from-indent . 1)
+	       (sedit::prev-keyword? (sedit::next-inline? 1 break sedit::from-indent . 1)
+		break sedit::from-indent . 0))))
+    sedit:*indent-alist*)
+
+(setf (sedit:get-format :slot-spec)
+      '(:indent :slot-spec :inline t))
+
+(setf (sedit:get-format :slot-spec-list)
+      '(:indent :binding-list :args (:slot-spec) :inline nil))
+
+(setf (sedit:get-format 'defclass)
+      '(:indent ((2) 1)
+	:args (:keyword nil nil :slot-spec-list nil)
+	:sublists (4)))
+
+(setf (sedit:get-format 'defmethod)
+      '(:indent ((2))
+	:args (:keyword nil :lambda-list nil)
+	:sublists (3)))
+
+(setf (sedit:get-format 'defgeneric) 'defun)
+
+(setf (sedit:get-format 'generic-flet) 'flet)
+
+(setf (sedit:get-format 'generic-labels) 'flet)
+
+(setf (sedit:get-format 'call-next-method)
+      '(:indent (1) :args (:keyword nil)))
+
+(setf (sedit:get-format 'symbol-macrolet) 'let)
+
+(setf (sedit:get-format 'with-accessors)
+      '(:indent ((1) 1)
+	:args (:keyword :binding-list nil)
+	:sublists (2)
+	:miser :never))
+
+(setf (sedit:get-format 'with-slots) 'with-accessors)
+
+(setf (sedit:get-format 'make-instance)
+      '(:indent ((1))
+	:args (:keyword nil :slot-spec-list)))
+
+(setf (sedit:get-format '*make-instance) 'make-instance)
+
+;;; PrettyFileIndex stuff, the product of Harley Davis.
+
+(defvar *pfi-class-type* '(class defclass pfi-class-namer))
+
+(defvar *pfi-method-type* '(method defmethod pfi-method-namer)
+  "Handles method for prettyfileindex")
+
+(defvar *pfi-index-accessors* nil
+  "t -> each slot accessor gets a listing in the index.")
+
+(defvar *pfi-method-index* :group
+  ":group, :separate, :both, or nil")
+
+(defun pfi-add-class-type ()
+  (pushnew *pfi-class-type* il:*pfi-types*))
+
+(defun pfi-add-method-type ()
+  (pushnew *pfi-method-type* il:*pfi-types*))
+
+(defun pfi-class-namer (expression entry)
+  (let ((class-name (second expression)))
+    ;; Following adds all slot readers/writers/accessors as separate entries in
+    ;; the index.  Probably a mistake.
+    (if *pfi-index-accessors*
+	(let ((slot-list (fourth expression))
+	      (accessor-names nil))
+	  (labels ((add-accessor (method-index name-index)
+		     (push (case *pfi-method-index*
+			     (:group method-index)
+			     (:separate name-index)
+			     ((t :both) (list method-index name-index))
+			     ((nil) nil)
+			     (otherwise (error "Illegal value for *pfi-method-index*: ~S"
+					       *pfi-method-index*)))
+			   accessor-names))
+		   (add-reader (reader-name)
+		     (add-accessor `(method (,reader-name (,class-name)))
+				   `(,reader-name (,class-name))))
+		   (add-writer (writer-name)
+		     (add-accessor `(method ((setf ,writer-name) (t ,class-name)))
+				   `((setf ,writer-name) (t ,class-name)))))
+	    (dolist (slot-def slot-list)
+	      (do* ((rest-slot-args (cdr slot-def) (cddr rest-slot-args))
+		    (slot-arg (first  rest-slot-args)  (first rest-slot-args)))
+		   ((null rest-slot-args))
+ 		(case slot-arg
+		  (:reader (add-reader (second rest-slot-args)))
+		  (:writer (add-writer (second rest-slot-args)))
+		  (:accessor (add-reader (second rest-slot-args))
+			     (add-writer (second rest-slot-args)))
+		  (otherwise nil))))
+	    (cons `(class (,class-name)) accessor-names)))
+	class-name)))
+
+(defun pfi-method-namer (expression entry)
+  (let ((method-name (second expression))
+	(specializers nil)
+	(qualifiers nil)
+	lambda-list)
+    (do* ((rest-qualifiers (cddr expression) (cdr rest-qualifiers))
+	  (qualifier (first rest-qualifiers) (first rest-qualifiers)))
+	 ((listp qualifier) (setq lambda-list qualifier)
+	                    (setq qualifiers (reverse qualifiers)) qualifiers)
+      (push qualifier qualifiers))
+    (do* ((rest-lambda-list lambda-list (cdr rest-lambda-list))
+	  (arg (first rest-lambda-list) (first rest-lambda-list)))
+	 ((or (member arg lambda-list-keywords) (null rest-lambda-list))
+	  (setq specializers (reverse specializers)))
+      (push (if (listp arg) (second arg) t) specializers))
+    (let ((method-index `(method (,method-name ,@qualifiers ,specializers)))
+	  (name-index `(,method-name ,@qualifiers ,specializers)))
+      (case *pfi-method-index*
+	(:group method-index)
+	(:separate name-index)
+	((t :both) (list method-index name-index))
+	((nil) nil)
+	(otherwise (error "Illegal value for *pfi-method-index*: ~S" *pfi-method-index*))))))
+
+(defun pfi-install-clos ()
+  (pfi-add-method-type)
+  (pfi-add-class-type))
+
+(eval-when (eval load)
+  (when (boundp (quote il:*pfi-types*))
+    (pfi-install-clos))
+  )
diff --git a/clos/3.5/combin.dfasl b/clos/3.5/combin.dfasl
new file mode 100644
index 00000000..5013db78
Binary files /dev/null and b/clos/3.5/combin.dfasl differ
diff --git a/clos/3.5/combin.lisp b/clos/3.5/combin.lisp
new file mode 100644
index 00000000..f76ba815
--- /dev/null
+++ b/clos/3.5/combin.lisp
@@ -0,0 +1,254 @@
+;;;-*-Mode:LISP; Package: CLOS; Base:10; Syntax:Common-lisp -*-
+;;;
+;;; *************************************************************************
+;;; Copyright (c) 1991 Venue
+;;; All rights reserved.
+;;; *************************************************************************
+;;;
+
+(in-package 'clos)
+
+(defun make-effective-method-function (generic-function form)
+  (flet ((name-function (fn) (set-function-name fn 'a-combined-method) fn))
+    (if (and (listp form)
+	     (eq (car form) 'call-method)
+	     (method-p (cadr form))
+	     (every #'method-p (caddr form)))
+	;;
+	;; The effective method is just a call to call-method.  This opens up
+	;; the possibility of just using the method function of the method as
+	;; as the effective method function.
+	;;
+	;; But we have to be careful.  If that method function will ask for
+	;; the next methods we have to provide them.  We do not look to see
+	;; if there are next methods, we look at whether the method function
+	;; asks about them.  If it does, we must tell it whether there are
+	;; or aren't to prevent the leaky next methods bug.
+	;; 
+	(let* ((method-function (method-function (cadr form)))
+	       (arg-info (gf-arg-info generic-function))
+	       (metatypes (arg-info-metatypes arg-info))
+	       (applyp (arg-info-applyp arg-info)))
+	  (if (not (method-function-needs-next-methods-p method-function))
+	      method-function
+	      (let ((next-method-functions (mapcar #'method-function (caddr form))))
+		(name-function
+		  (get-function `(lambda ,(make-dfun-lambda-list metatypes applyp)
+				   (let ((*next-methods* .next-method-functions.))
+				     ,(make-dfun-call metatypes applyp '.method-function.)))
+		    #'default-test-converter	;This could be optimized by making
+						;the interface from here to the
+						;walker more clear so that the
+						;form wouldn't get walked at all.
+		    #'(lambda (form)
+			(if (memq form '(.next-method-functions. .method-function.))
+			    (values form (list form))
+			    form))
+		    #'(lambda (form)
+			(cond ((eq form '.next-method-functions.)
+			       (list next-method-functions))
+			      ((eq form '.method-function.)
+			       (list method-function)))))))))
+	;;
+	;; We have some sort of `real' effective method.  Go off and get a
+	;; compiled function for it.  Most of the real hair here is done by
+	;; the GET-FUNCTION mechanism.
+	;; 
+	(name-function (make-effective-method-function-internal generic-function form)))))
+
+(defvar *global-effective-method-gensyms* ())
+(defvar *rebound-effective-method-gensyms*)
+
+(defun get-effective-method-gensym ()
+  (or (pop *rebound-effective-method-gensyms*)
+      (let ((new (make-symbol "EFFECTIVE-METHOD-GENSYM-")))
+	(push new *global-effective-method-gensyms*)
+	new)))
+
+(eval-when (load)
+  (let ((*rebound-effective-method-gensyms* ()))
+    (dotimes (i 10) (get-effective-method-gensym))))
+
+(defun make-effective-method-function-internal (generic-function effective-method)
+  (let* ((*rebound-effective-method-gensyms* *global-effective-method-gensyms*)
+	 (arg-info (gf-arg-info generic-function))
+	 (metatypes (arg-info-metatypes arg-info))
+	 (applyp (arg-info-applyp arg-info)))
+    (labels ((test-converter (form)
+	       (if (and (consp form) (eq (car form) 'call-method))
+		   '.call-method.
+		   (default-test-converter form)))
+	     (code-converter (form)
+	       (if (and (consp form) (eq (car form) 'call-method))
+		   ;;
+		   ;; We have a `call' to CALL-METHOD.  There may or may not be next methods
+		   ;; and the two cases are a little different.  It controls how many gensyms
+		   ;; we will generate.
+		   ;;
+		   (let ((gensyms
+			   (if (cddr form)
+			       (list (get-effective-method-gensym)
+				     (get-effective-method-gensym))
+			       (list (get-effective-method-gensym)
+				     ()))))
+		     (values `(let ((*next-methods* ,(cadr gensyms)))
+				,(make-dfun-call metatypes applyp (car gensyms)))
+			     gensyms))
+		   (default-code-converter form)))
+	     (constant-converter (form)
+	       (if (and (consp form) (eq (car form) 'call-method))
+		   (if (cddr form)
+		       (list (check-for-make-method (cadr form))
+			     (mapcar #'check-for-make-method (caddr form)))
+		       (list (check-for-make-method (cadr form))
+			     ()))
+		   (default-constant-converter form)))
+	     (check-for-make-method (effective-method)
+	       (cond ((method-p effective-method)
+		      (method-function effective-method))
+		     ((and (listp effective-method)
+			   (eq (car effective-method) 'make-method))
+		      (make-effective-method-function generic-function
+						      (make-progn (cadr effective-method))))
+		     (t
+		      (error "Effective-method form is malformed.")))))
+      (get-function `(lambda ,(make-dfun-lambda-list metatypes applyp) ,effective-method)
+		  #'test-converter
+		  #'code-converter
+		  #'constant-converter))))
+
+
+
+(defvar *invalid-method-error*
+	#'(lambda (&rest args)
+	    (declare (ignore args))
+	    (error
+	      "INVALID-METHOD-ERROR was called outside the dynamic scope~%~
+               of a method combination function (inside the body of~%~
+               DEFINE-METHOD-COMBINATION or a method on the generic~%~
+               function COMPUTE-EFFECTIVE-METHOD).")))
+
+(defvar *method-combination-error*
+	#'(lambda (&rest args)
+	    (declare (ignore args))
+	    (error
+	      "METHOD-COMBINATION-ERROR was called outside the dynamic scope~%~
+               of a method combination function (inside the body of~%~
+               DEFINE-METHOD-COMBINATION or a method on the generic~%~
+               function COMPUTE-EFFECTIVE-METHOD).")))
+
+;(defmethod compute-effective-method :around        ;issue with magic
+;	   ((generic-function generic-function)     ;generic functions
+;	    (method-combination method-combination)
+;	    applicable-methods)
+;  (declare (ignore applicable-methods))
+;  (flet ((real-invalid-method-error (method format-string &rest args)
+;	   (declare (ignore method))
+;	   (apply #'error format-string args))
+;	 (real-method-combination-error (format-string &rest args)
+;	   (apply #'error format-string args)))
+;    (let ((*invalid-method-error* #'real-invalid-method-error)
+;	  (*method-combination-error* #'real-method-combination-error))
+;      (call-next-method))))
+
+(defun invalid-method-error (&rest args)
+  (declare (arglist method format-string &rest format-arguments))
+  (apply *invalid-method-error* args))
+
+(defun method-combination-error (&rest args)
+  (declare (arglist format-string &rest format-arguments))
+  (apply *method-combination-error* args))
+
+
+
+;;;
+;;; The STANDARD method combination type.  This is coded by hand (rather than
+;;; with define-method-combination) for bootstrapping and efficiency reasons.
+;;; Note that the definition of the find-method-combination-method appears in
+;;; the file defcombin.lisp, this is because EQL methods can't appear in the
+;;; bootstrap.
+;;;
+;;; The defclass for the METHOD-COMBINATION and STANDARD-METHOD-COMBINATION
+;;; classes has to appear here for this reason.  This code must conform to
+;;; the code in the file defcombin, look there for more details.
+;;;
+
+(defclass method-combination () ())
+
+(define-gf-predicate method-combination-p method-combination)
+
+(defclass standard-method-combination
+	  (definition-source-mixin method-combination)
+     ((type          :reader method-combination-type
+	             :initarg :type)
+      (documentation :reader method-combination-documentation
+		     :initarg :documentation)
+      (options       :reader method-combination-options
+	             :initarg :options)))
+
+(defmethod print-object ((mc method-combination) stream)
+  (printing-random-thing (mc stream)
+    (format stream
+	    "Method-Combination ~S ~S"
+	    (method-combination-type mc)
+	    (method-combination-options mc))))
+
+(eval-when (load eval)
+  (setq *standard-method-combination*
+	(make-instance 'standard-method-combination
+		       :type 'standard
+		       :documentation "The standard method combination."
+		       :options ())))
+
+;This definition appears in defcombin.lisp.
+;
+;(defmethod find-method-combination ((generic-function generic-function)
+;				     (type (eql 'standard))
+;				     options)
+;  (when options
+;    (method-combination-error
+;      "The method combination type STANDARD accepts no options."))
+;  *standard-method-combination*)
+
+(defun make-call-methods (methods)
+  (mapcar #'(lambda (method) `(call-method ,method ())) methods))
+
+(defmethod compute-effective-method ((generic-function generic-function)
+				     (combin standard-method-combination)
+				     applicable-methods)
+  (let ((before ())
+	(primary ())
+	(after ())
+	(around ()))
+    (dolist (m applicable-methods)
+      (let ((qualifiers (method-qualifiers m)))
+	(cond ((member ':before qualifiers)  (push m before))
+	      ((member ':after  qualifiers)  (push m after))
+	      ((member ':around  qualifiers) (push m around))
+	      (t
+	       (push m primary)))))
+    (setq before  (reverse before)
+	  after   (reverse after)
+	  primary (reverse primary)
+	  around  (reverse around))
+    (cond ((null primary)
+	   `(error "No primary method for the generic function ~S." ',generic-function))
+	  ((and (null before) (null after) (null around))
+	   ;;
+	   ;; By returning a single call-method `form' here we enable an important
+	   ;; implementation-specific optimization.
+	   ;; 
+	   `(call-method ,(first primary) ,(rest primary)))
+	  (t
+	   (let ((main-effective-method
+		   (if (or before after (rest primary))
+		       `(multiple-value-prog1
+			  (progn ,@(make-call-methods before)
+				 (call-method ,(first primary) ,(rest primary)))
+			  ,@(make-call-methods (reverse after)))
+		       `(call-method ,(first primary) ()))))
+	     (if around
+		 `(call-method ,(first around)
+			       (,@(rest around) (make-method ,main-effective-method)))
+		 main-effective-method))))))
+
diff --git a/clos/3.5/compat.dfasl b/clos/3.5/compat.dfasl
new file mode 100644
index 00000000..6d244268
Binary files /dev/null and b/clos/3.5/compat.dfasl differ
diff --git a/clos/3.5/compat.lisp b/clos/3.5/compat.lisp
new file mode 100644
index 00000000..ca390f84
--- /dev/null
+++ b/clos/3.5/compat.lisp
@@ -0,0 +1,11 @@
+;;;-*-Mode:LISP; Package: CLOS; Base:10; Syntax:Common-lisp; -*-
+;;;
+;;; *************************************************************************
+;;; Copyright (c) 1991 Venue
+;;; All rights reserved.
+;;; *************************************************************************
+;;;
+
+(in-package 'clos)
+
+()
diff --git a/clos/3.5/construct.dfasl b/clos/3.5/construct.dfasl
new file mode 100644
index 00000000..83a5b7ef
Binary files /dev/null and b/clos/3.5/construct.dfasl differ
diff --git a/clos/3.5/construct.lisp b/clos/3.5/construct.lisp
new file mode 100644
index 00000000..7d740475
--- /dev/null
+++ b/clos/3.5/construct.lisp
@@ -0,0 +1,1090 @@
+;;;-*-Mode:LISP; Package:(CLOS LISP 1000); Base:10; Syntax:Common-lisp -*-
+;;;
+;;; *************************************************************************
+;;; Copyright (c) 1991 Venue
+;;; All rights reserved.
+;;; *************************************************************************
+;;;
+;;;
+;;; This file defines the defconstructor and other make-instance optimization
+;;; mechanisms.
+;;; 
+
+(in-package 'clos)
+
+;;;
+;;; defconstructor is used to define special purpose functions which just
+;;; call make-instance with a symbol as the first argument.  The semantics
+;;; of defconstructor is that it is equivalent to defining a function which
+;;; just calls make-instance. The purpose of defconstructor is to provide
+;;; CLOS with a way of noticing these calls to make-instance so that it can
+;;; optimize them.  Specific ports of CLOS could just have their compiler
+;;; spot these calls to make-instance and then call this code.  Having the
+;;; special defconstructor facility is the best we can do portably.
+;;; 
+;;;
+;;; A call to defconstructor like:
+;;;
+;;;  (defconstructor make-foo foo (a b &rest r) a a :mumble b baz r)
+;;;
+;;; Is equivalent to a defun like:
+;;;
+;;;  (defun make-foo (a b &rest r)
+;;;    (make-instance 'foo 'a a ':mumble b 'baz r))
+;;;
+;;; Calls like the following are also legal:
+;;;
+;;;  (defconstructor make-foo foo ())
+;;;  (defconstructor make-bar bar () :x *x* :y *y*)
+;;;  (defconstructor make-baz baz (a b c) a-b (list a b) b-c (list b c))
+;;;
+;;;
+;;; The general idea of this implementation is that the expansion of the
+;;; defconstructor form includes the creation of closure generators which
+;;; can be called to create constructor code for the class.  The ways that
+;;; a constructor can be optimized depends not only on the defconstructor
+;;; form, but also on the state of the class and the generic functions in
+;;; the initialization protocol.  Because of this, the determination of the
+;;; form of constructor code to be used is a two part process.
+;;;
+;;; At compile time, make-constructor-code-generators looks at the actual
+;;; defconstructor form and makes a list of appropriate constructor code
+;;; generators.  All that is really taken into account here is whether
+;;; any initargs are supplied in the call to make-instance, and whether
+;;; any of those are constant.
+;;;
+;;; At constructor code generation time (see note about lazy evaluation)
+;;; compute-constructor-code calls each of the constructor code generators
+;;; to try to get code for this constructor.  Each generator looks at the
+;;; state of the class and initialization protocol generic functions and
+;;; decides whether its type of code is appropriate.  This depends on things
+;;; like whether there are any applicable methods on initialize-instance,
+;;; whether class slots are affected by initialization etc.
+;;; 
+;;;
+;;; Constructor objects are funcallable instances, the protocol followed to
+;;; to compute the constructor code for them is quite similar to the protocol
+;;; followed to compute the discriminator code for a generic function.  When
+;;; the constructor is first loaded, we install as its code a function which
+;;; will compute the actual constructor code the first time it is called.
+;;; 
+;;; If there is an update to the class structure which might invalidate the
+;;; optimized constructor, the special lazy constructor installer is put back
+;;; so that it can compute the appropriate constructor when it is called.
+;;; This is the same kind of lazy evaluation update strategy used elswhere
+;;; in CLOS.
+;;;
+;;; To allow for flexibility in the CLOS implementation and to allow CLOS users
+;;; to specialize this constructor facility for their own metaclasses, there
+;;; is an internal protocol followed by the code which loads and installs
+;;; the constructors.  This is documented in the comments in the code.
+;;;
+;;; This code is also designed so that one of its levels, can be used to
+;;; implement optimization of calls to make-instance which can't go through
+;;; the defconstructor facility.  This has not been implemented yet, but the
+;;; hooks are there.
+;;;
+;;;
+
+(defmacro defconstructor
+	  (name class lambda-list &rest initialization-arguments)
+  (expand-defconstructor class
+			 name
+			 lambda-list
+			 (copy-list initialization-arguments)))
+
+(defun expand-defconstructor (class-name name lambda-list supplied-initargs)
+  (let ((class (find-class class-name nil))
+	(supplied-initarg-names
+	  (gathering1 (collecting)
+	    (iterate ((name (*list-elements supplied-initargs :by #'cddr)))
+	      (gather1 name)))))
+    (when (null class)
+      (error "defconstructor form being compiled (or evaluated) before~@
+              class ~S is defined."
+	     class-name))
+    `(progn
+       ;; In order to avoid undefined function warnings, we want to tell
+       ;; the compile time environment that a function with this name and
+       ;; this argument list has been defined.  The portable way to do this
+       ;; is with defun.
+       (proclaim '(notinline ,name))
+       (defun ,name ,lambda-list
+	 (declare (ignore ,@(specialized-lambda-list-parameters lambda-list)))
+	 (error "Constructor ~S not loaded." ',name))
+
+       ,(make-top-level-form `(defconstructor ,name)
+			     '(load eval)
+	  `(load-constructor
+	     ',class-name
+	     ',(class-name (class-of class))
+	     ',name
+	     ',supplied-initarg-names
+	     ;; make-constructor-code-generators is called to return a list
+	     ;; of constructor code generators.  The actual interpretation
+	     ;; of this list is left to compute-constructor-code, but the
+	     ;; general idea is that it should be an plist where the keys
+	     ;; name a kind of constructor code and the values are generator
+	     ;; functions which return the actual constructor code.  The
+	     ;; constructor code is usually a closures over the arguments
+	     ;; to the generator.
+	     ,(make-constructor-code-generators class
+						name
+						lambda-list
+						supplied-initarg-names
+						supplied-initargs))))))
+
+(defun load-constructor (class-name metaclass-name constructor-name
+			 supplied-initarg-names code-generators)
+  (let ((class (find-class class-name nil)))
+    (cond ((null class)
+	   (error "defconstructor form being loaded (or evaluated) before~@
+                   class ~S is defined."
+		  class-name))
+	  ((neq (class-name (class-of class)) metaclass-name)
+	   (error "When defconstructor ~S was compiled, the metaclass of the~@
+                   class ~S was ~S.  The metaclass is now ~S.~@
+                   The constructor must be recompiled."
+		  constructor-name
+		  class-name
+		  metaclass-name
+		  (class-name (class-of class))))
+	  (t
+	   (load-constructor-internal class
+				      constructor-name
+				      supplied-initarg-names
+				      code-generators)
+	   constructor-name))))
+
+;;;
+;;; The actual constructor objects.
+;;; 
+(defclass constructor ()			   
+     ((class					;The class with which this
+	:initarg :class				;constructor is associated.
+	:reader constructor-class)		;The actual class object,
+						;not the class name.
+						;      
+      (name					;The name of this constructor.
+	:initform nil				;This is the symbol in whose
+	:initarg :name				;function cell the constructor
+	:reader constructor-name)		;usually sits.  Of course, this
+						;is optional.  defconstructor
+						;makes named constructors, but
+						;it is possible to manipulate
+						;anonymous constructors also.
+						;
+      (code-type				;The type of code currently in
+	:initform nil				;use by this constructor.  This
+	:accessor constructor-code-type)	;is mostly for debugging and
+						;analysis purposes.
+						;The lazy installer sets this
+						;to LAZY.  The most basic and
+						;least optimized type of code
+						;is called FALLBACK.
+						;
+      (supplied-initarg-names			;The names of the initargs this
+	:initarg :supplied-initarg-names	;constructor supplies when it
+	:reader					;"calls" make-instance.
+	   constructor-supplied-initarg-names)	;
+						;
+      (code-generators				;Generators for the different
+	:initarg :code-generators		;types of code this constructor
+	:reader constructor-code-generators))	;could use.
+  (:metaclass funcallable-standard-class))
+
+
+;;;
+;;; Because the value in the code-type slot should always correspond to the
+;;; funcallable-instance-function of the constructor, this function should
+;;; always be used to set the both at the same time.
+;;;
+(defun set-constructor-code (constructor code type)
+  (set-funcallable-instance-function constructor code)
+  (set-function-name constructor (constructor-name constructor))
+  (setf (constructor-code-type constructor) type))
+
+
+(defmethod print-object ((constructor constructor) stream)
+  (printing-random-thing (constructor stream)
+    (format stream
+	    "~S ~S (~S)"
+	    (or (class-name (class-of constructor)) "Constructor")
+	    (or (constructor-name constructor) "Anonymous")
+	    (constructor-code-type constructor))))
+
+(defmethod describe-object ((constructor constructor) stream)
+  (format stream
+	  "~S is a constructor for the class ~S.~%~
+            The current code type is ~S.~%~
+            Other possible code types are ~S."
+	  constructor (constructor-class constructor)
+	  (constructor-code-type constructor)
+	  (gathering1 (collecting)
+	    (doplist (key val) (constructor-code-generators constructor)
+	      (gather1 key)))))
+
+;;;
+;;; I am not in a hairy enough mood to make this implementation be metacircular
+;;; enough that it can support a defconstructor for constructor objects.
+;;; 
+(defun make-constructor (class name supplied-initarg-names code-generators)
+  (make-instance 'constructor
+		 :class class
+		 :name name
+		 :supplied-initarg-names supplied-initarg-names
+		 :code-generators code-generators))
+
+; This definition actually appears in std-class.lisp.
+;(defmethod class-constructors ((class std-class))
+;  (with-slots (plist) class (getf plist 'constructors)))
+
+(defmethod add-constructor ((class std-class)
+			    (constructor constructor))
+  (with-slots (plist) class
+    (pushnew constructor (getf plist 'constructors))))
+
+(defmethod remove-constructor ((class std-class)
+			       (constructor constructor))
+  (with-slots (plist) class
+    (setf (getf plist 'constructors)
+	  (delete constructor (getf plist 'constructors)))))
+
+(defmethod get-constructor ((class std-class) name &optional (error-p t))
+  (or (dolist (c (class-constructors class))
+	(when (eq (constructor-name c) name) (return c)))
+      (if error-p
+	  (error "Couldn't find a constructor with name ~S for class ~S."
+		 name class)
+	  ())))
+
+;;;
+;;; This is called to actually load a defconstructor constructor.  It must
+;;; install the lazy installer in the function cell of the constructor name,
+;;; and also add this constructor to the list of constructors the class has.
+;;; 
+(defmethod load-constructor-internal
+	   ((class std-class) name initargs generators)
+  (let ((constructor (make-constructor class name initargs generators))
+	(old (get-constructor class name nil)))
+    (when old (remove-constructor class old))
+    (install-lazy-constructor-installer constructor)
+    (add-constructor class constructor)
+    (setf (symbol-function name) constructor)))
+
+(defmethod install-lazy-constructor-installer ((constructor constructor))
+  (let ((class (constructor-class constructor)))
+    (set-constructor-code constructor
+			  #'(lambda (&rest args)
+			      (multiple-value-bind (code type)
+				  (compute-constructor-code class constructor)
+				(prog1 (apply code args)
+				       (set-constructor-code constructor
+							     code
+							     type))))
+			  'lazy)))
+
+;;;
+;;; The interface to keeping the constructors updated.
+;;;
+;;; add-method and remove-method (for standard-generic-function and -method),
+;;; promise to call maybe-update-constructors on the generic function and
+;;; the method.
+;;; 
+;;; The class update code promises to call update-constructors whenever the
+;;; class is changed.  That is, whenever the supers, slots or options change.
+;;; If user defined classes of constructor needs to be updated in more than
+;;; these circumstances, they should use the dependent updating mechanism to
+;;; make sure update-constructors is called.
+;;;
+;;; Bootstrapping concerns force the definitions of maybe-update-constructors
+;;; and update-constructors to be in the file std-class.  For clarity, they
+;;; also appear below.  Be sure to keep the definition here and there in sync.
+;;; 
+;(defvar *initialization-generic-functions*
+;	 (list #'make-instance
+;	       #'default-initargs
+;	       #'allocate-instance
+;	       #'initialize-instance
+;	       #'shared-initialize))
+;
+;(defmethod maybe-update-constructors
+;	   ((generic-function generic-function)
+;	    (method method))
+;  (when (memq generic-function *initialization-generic-functions*)
+;    (labels ((recurse (class)
+;	       (update-constructors class)
+;	       (dolist (subclass (class-direct-subclasses class))
+;		 (recurse subclass))))
+;      (when (classp (car (method-specializers method)))
+;	(recurse (car (method-specializers method)))))))
+;
+;(defmethod update-constructors ((class std-class))
+;  (dolist (cons (class-constructors class))
+;    (install-lazy-constructor-installer cons)))
+;
+;(defmethod update-constructors ((class class))
+;  ())
+
+
+
+;;;
+;;; Here is the actual smarts for making the code generators and then trying
+;;; each generator to get constructor code. This extensible mechanism allows
+;;; new kinds of constructor code types to be added. A programmer defining a
+;;; specialization of the constructor class can either use this mechanism to
+;;; define new code types, or can override this mechanism by overriding the
+;;; methods on make-constructor-code-generators and compute-constructor-code.
+;;;
+;;; The function defined by define-constructor-code-type will receive the
+;;; class object, and the 4 original arguments to defconstructor. It can
+;;; return a constructor code generator, or return nil if this type of code
+;;; is determined to not be appropriate after looking at the defconstructor
+;;; arguments.
+;;;
+;;; When compute-constructor-code is called, it first performs basic checks
+;;; to make sure that the basic assumptions common to all the code types are
+;;; valid.  (For details see method definition).  If any of the tests fail,
+;;; the fallback constructor code type is used.  If none of the tests fail,
+;;; the constructor code generators are called in order.  They receive 5
+;;; arguments:
+;;;
+;;;   CLASS        the class the constructor is making instances of
+;;;   WRAPPER      that class's wrapper
+;;;   DEFAULTS     the result of calling class-default-initargs on class
+;;;   INITIALIZE   the applicable methods on initialize-instance
+;;;   SHARED       the applicable methosd on shared-initialize
+;;;
+;;; The first code generator to return code is used.  The code generators are
+;;; called in reverse order of definition, so define-constructor-code-type
+;;; forms which define better code should appear after ones that define less
+;;; good code.  The fallback code type appears first.  Note that redefining a
+;;; code type does not change its position in the list.  To do that,  define
+;;; a new type at the end with the behavior.
+;;; 
+
+(defvar *constructor-code-types* ())
+
+(defmacro define-constructor-code-type (type arglist &body body)
+  (let ((fn-name (intern (format nil
+				 "CONSTRUCTOR-CODE-GENERATOR ~A ~A"
+				 (package-name (symbol-package type))
+				 (symbol-name type))
+			 *the-clos-package*)))
+    `(progn
+       (defun ,fn-name ,arglist .,body)
+       (load-define-constructor-code-type ',type ',fn-name))))
+
+(defun load-define-constructor-code-type (type generator)
+  (let ((old-entry (assq type *constructor-code-types*)))
+    (if old-entry 
+	(setf (cadr old-entry) generator)
+	(push (list type generator) *constructor-code-types*))
+    type))
+
+(defmethod make-constructor-code-generators
+	   ((class std-class)
+	    name lambda-list supplied-initarg-names supplied-initargs)
+  (cons 'list
+	(gathering1 (collecting)
+	  (dolist (entry *constructor-code-types*)
+	    (let ((generator
+		    (funcall (cadr entry) class name lambda-list 
+					  supplied-initarg-names
+					  supplied-initargs)))
+	      (when generator
+		(gather1 `',(car entry))
+		(gather1 generator)))))))
+
+(defmethod compute-constructor-code ((class std-class)
+				     (constructor constructor))
+  (let* ((proto (class-prototype class))
+	 (wrapper (class-wrapper class))
+	 (defaults (class-default-initargs class))
+         (make
+           (compute-applicable-methods #'make-instance (list class)))
+	 (supplied-initarg-names
+	   (constructor-supplied-initarg-names constructor))
+         (default
+	   (compute-applicable-methods #'default-initargs
+				       (list class supplied-initarg-names))) ;?
+         (allocate
+           (compute-applicable-methods #'allocate-instance (list class)))
+         (initialize
+           (compute-applicable-methods #'initialize-instance (list proto)))
+         (shared
+           (compute-applicable-methods #'shared-initialize (list proto t)))
+         (code-generators
+           (constructor-code-generators constructor))
+	 (code-generators
+	   (constructor-code-generators constructor)))
+    (flet ((call-code-generator (generator)
+	     (when (null generator)
+	       (unless (setq generator (getf code-generators 'fallback))
+		 (error "No FALLBACK generator?")))
+	     (funcall generator class wrapper defaults initialize shared)))
+      (if (or (cdr make)
+	      (cdr default)
+	      (cdr allocate)
+	      (check-initargs class
+			      supplied-initarg-names
+			      defaults
+			      (append initialize shared)))
+	  ;; These are basic shared assumptions, if one of the
+	  ;; has been violated, we have to resort to the fallback
+	  ;; case.  Any of these assumptions could be moved out
+	  ;; of here and into the individual code types if there
+	  ;; was a need to do so.
+	  (values (call-code-generator nil) 'fallback)
+	  ;; Otherwise try all the generators until one produces
+	  ;; code for us.
+	  (doplist (type generator) code-generators
+	    (let ((code (call-code-generator generator)))
+	      (when code (return (values code type)))))))))
+
+;;;
+;;; The facilities are useful for debugging, and to measure the performance
+;;; boost from constructors.
+;;; 
+
+(defun map-constructors (fn)
+  (let ((nclasses 0)
+	(nconstructors 0))
+    (labels ((recurse (class)
+	       (incf nclasses)
+	       (dolist (constructor (class-constructors class))
+		 (incf nconstructors)
+		 (funcall fn constructor))
+	       (dolist (subclass (class-direct-subclasses class))
+		 (recurse subclass))))
+      (recurse (find-class 't))
+      (values nclasses nconstructors))))
+
+(defun reset-constructors ()
+  (multiple-value-bind (nclass ncons)
+      (map-constructors #'install-lazy-constructor-installer )
+    (format t "~&~D classes, ~D constructors." nclass ncons)))
+
+(defun disable-constructors ()
+  (multiple-value-bind (nclass ncons)
+      (map-constructors
+	#'(lambda (c)
+	    (let ((gen (getf (constructor-code-generators c) 'fallback)))
+	      (if (null gen)
+		  (error "No fallback constructor for ~S." c)
+		  (set-constructor-code c
+					(funcall gen
+						 (constructor-class c)
+						 () () () ())
+					'fallback)))))
+    (format t "~&~D classes, ~D constructors." nclass ncons)))
+
+(defun enable-constructors ()
+  (reset-constructors))
+
+
+;;;
+;;; Helper functions and utilities that are shared by all of the code types
+;;; and by the main compute-constructor-code method as well.
+;;; 
+
+(defvar *standard-initialize-instance-method*
+        (get-method #'initialize-instance
+		    ()
+		    (list *the-class-standard-object*)))
+
+(defvar *standard-shared-initialize-method*
+        (get-method #'shared-initialize
+		    ()
+		    (list *the-class-standard-object* *the-class-t*)))
+
+(defun non-clos-initialize-instance-methods-p (methods)
+  (notevery #'(lambda (m) (eq m *standard-initialize-instance-method*))
+	    methods))
+
+(defun non-clos-shared-initialize-methods-p (methods)
+  (notevery #'(lambda (m) (eq m *standard-shared-initialize-method*))
+	    methods))
+
+(defun non-clos-or-after-initialize-instance-methods-p (methods)
+  (notevery #'(lambda (m) (or (eq m *standard-initialize-instance-method*)
+			      (equal '(:after) (method-qualifiers m))))
+	    methods))
+
+(defun non-clos-or-after-shared-initialize-methods-p (methods)
+  (notevery #'(lambda (m) (or (eq m *standard-shared-initialize-method*)
+			      (equal '(:after) (method-qualifiers m))))
+	    methods))
+
+
+;;; 
+;;; if initargs are valid return nil, otherwise return t.
+;;;
+(defun check-initargs (class supplied-initarg-names defaults methods)
+  (let ((legal (apply #'append
+		      (mapcar #'slotd-initargs (class-slots class)))))
+    ;; Add to the set of slot-filling initargs the set of
+    ;; initargs that are accepted by the methods.  If at
+    ;; any point we come across &allow-other-keys, we can
+    ;; just quit.
+    (dolist (method methods)
+      (multiple-value-bind (keys allow-other-keys)
+	  (function-keywords method)
+	(when allow-other-keys
+	  (return-from check-initargs nil))
+	(setq legal (append keys legal))))
+    ;; Now check the supplied-initarg-names and the default initargs
+    ;; against the total set that we know are legal.
+    (dolist (key supplied-initarg-names)
+      (unless (memq key legal)
+	(return-from check-initargs t)))
+    (dolist (default defaults)
+      (unless (memq (car default) legal)
+	(return-from check-initargs t)))))
+
+
+;;;
+;;; This returns two values.  The first is a vector which can be used as the
+;;; initial value of the slots vector for the instance. The first is a symbol
+;;; describing the initforms this class has.  
+;;;
+;;;  If the first value is:
+;;;
+;;;    :unsupplied    no slot has an initform
+;;;    :constants     all slots have either a constant initform
+;;;                   or no initform at all
+;;;    t              there is at least one non-constant initform
+;;; 
+(defun compute-constant-vector (class)
+  (declare (values constants flag))
+  (let* ((wrapper (class-wrapper class))
+	 (layout (wrapper-instance-slots-layout wrapper))
+	 (flag :unsupplied)
+	 (constants ()))
+    (dolist (slotd (class-slots class))
+      (let ((name (slotd-name slotd))
+	    (initform (slotd-initform slotd))
+	    (initfn (slotd-initfunction slotd)))
+	(cond ((null (memq name layout)))
+	      ((or (eq initform *slotd-unsupplied*)
+		   (null initfn))
+	       (push (cons name *slot-unbound*) constants))
+	      ((constantp initform)
+	       (push (cons name (eval initform)) constants)
+	       (when (eq flag ':unsupplied) (setq flag ':constants)))
+	      (t
+	       (push (cons name *slot-unbound*) constants)
+	       (setq flag 't)))))
+    (values
+      (apply #'vector
+	     (mapcar #'cdr
+		     (sort constants #'(lambda (x y)
+					 (memq (car y)
+					       (memq (car x) layout))))))
+      flag)))
+
+(defmacro copy-constant-vector (constants)
+  `(copy-seq (the simple-vector ,constants)))
+
+
+;;;
+;;; This takes a class and a list of initarg-names, and returns an alist
+;;; indicating the positions of the slots those initargs may fill.  The
+;;; order of the initarg-names argument is important of course, since we
+;;; have to respect the rules about the leftmost initarg that fills a slot
+;;; having precedence.  This function allows initarg names to appear twice
+;;; in the list, it only considers the first appearance.
+;;;
+(defun compute-initarg-positions (class initarg-names)
+  (let* ((layout (wrapper-instance-slots-layout (class-wrapper class)))
+	 (positions
+	   (gathering1 (collecting)
+	     (iterate ((slot-name (list-elements layout))
+		       (position (interval :from 0)))
+	       (gather1 (cons slot-name position)))))
+	 (slot-initargs
+	   (mapcar #'(lambda (slotd)
+		       (list (slotd-initargs slotd)
+			     (or (cdr (assq (slotd-name slotd) positions))
+				 ':class)))
+		   (class-slots class))))
+    ;; Go through each of the initargs, and figure out what position
+    ;; it fills by replacing the entries in slot-initargs it fills.
+    (dolist (initarg initarg-names)
+      (dolist (slot-entry slot-initargs)
+	(let ((slot-initargs (car slot-entry)))
+	  (when (and (listp slot-initargs)
+		     (not (null slot-initargs))
+		     (memq initarg slot-initargs))
+	    (setf (car slot-entry) initarg)))))
+    (gathering1 (collecting)
+      (dolist (initarg initarg-names)
+	(let ((positions (gathering1 (collecting)
+			   (dolist (slot-entry slot-initargs)
+			     (when (eq (car slot-entry) initarg)
+			       (gather1 (cadr slot-entry)))))))
+	  (when positions
+	    (gather1 (cons initarg positions))))))))
+
+
+;;;
+;;; The FALLBACK case allows anything.  This always works, and always appears
+;;; as the last of the generators for a constructor.  It does a full call to
+;;; make-instance.
+;;;
+
+(define-constructor-code-type fallback
+        (class name arglist supplied-initarg-names supplied-initargs)
+  (declare (ignore name supplied-initarg-names))
+  `(function
+     (lambda (&rest ignore)
+       (declare (ignore ignore))
+       (function
+	 (lambda ,arglist
+	   (make-instance
+	     ',(class-name class)
+	     ,@(gathering1 (collecting)
+		 (iterate ((tail (*list-tails supplied-initargs :by #'cddr)))
+		   (gather1 `',(car tail))
+		   (gather1 (cadr tail))))))))))
+
+;;;
+;;; The GENERAL case allows:
+;;;   constant, unsupplied or non-constant initforms
+;;;   constant or non-constant default initargs
+;;;   supplied initargs
+;;;   slot-filling initargs
+;;;   :after methods on shared-initialize and initialize-instance
+;;;   
+(define-constructor-code-type general
+        (class name arglist supplied-initarg-names supplied-initargs)
+  (declare (ignore name))
+  (let ((raw-allocator (raw-instance-allocator class))
+	(slots-fetcher (slots-fetcher class))
+	(wrapper-fetcher (wrapper-fetcher class)))
+    `(function
+       (lambda (class .wrapper. defaults init shared)
+	 (multiple-value-bind (.constants.
+			       .constant-initargs.
+			       .initfns-initargs-and-positions.
+			       .supplied-initarg-positions.
+			       .shared-initfns.
+			       .initfns.)
+	     (general-generator-internal class
+					 defaults
+					 init
+					 shared
+					 ',supplied-initarg-names
+					 ',supplied-initargs)
+	   .supplied-initarg-positions.
+	   (when (and .constants.
+		      (null (non-clos-or-after-initialize-instance-methods-p
+			      init))
+		      (null (non-clos-or-after-shared-initialize-methods-p
+			      shared)))
+	     (function
+	       (lambda ,arglist
+		 (declare (optimize (speed 3) (safety 0)))
+		 (let ((.instance. (,raw-allocator))
+		       (.slots. (copy-constant-vector .constants.))
+		       (.positions. .supplied-initarg-positions.)
+		       (.initargs. .constant-initargs.))		   
+		   .positions.
+		   
+		   (setf (,slots-fetcher .instance.) .slots.)	     
+		   (setf (,wrapper-fetcher .instance.) .wrapper.)
+
+		   (dolist (entry .initfns-initargs-and-positions.)
+		     (let ((val (funcall (car entry)))
+			   (initarg (cadr entry)))
+		       (when initarg
+			 (push val .initargs.)
+			 (push initarg .initargs.))
+		       (dolist (pos (cddr entry))
+			 (setf (%svref .slots. pos) val))))
+
+		   ,@(gathering1 (collecting)
+		       (doplist (initarg value) supplied-initargs
+			 (unless (constantp value)
+			   (gather1 `(let ((.value. ,value))
+				       (push .value. .initargs.)
+				       (push ',initarg .initargs.)
+				       (dolist (.p. (pop .positions.))
+					 (setf (%svref .slots. .p.)
+					       .value.)))))))
+
+		   (dolist (fn .shared-initfns.)
+		     (apply fn .instance. t .initargs.))
+		   (dolist (fn .initfns.)
+		     (apply fn .instance. .initargs.))
+		     
+		   .instance.)))))))))
+
+(defun general-generator-internal
+       (class defaults init shared supplied-initarg-names supplied-initargs)
+  (flet ((bail-out () (return-from general-generator-internal nil)))
+    (let* ((constants (compute-constant-vector class))
+	   (layout (wrapper-instance-slots-layout (class-wrapper class)))
+	   (initarg-positions
+	     (compute-initarg-positions class
+					(append supplied-initarg-names
+						(mapcar #'car defaults))))
+	   (initfns-initargs-and-positions ())
+	   (supplied-initarg-positions ())
+	   (constant-initargs ())
+	   (used-positions ()))
+					       
+      ;;
+      ;; Go through each of the supplied initargs for three reasons.
+      ;;
+      ;;   - If it fills a class slot, bail out.
+      ;;   - If its a constant form, fill the constant vector.
+      ;;   - Otherwise remember the positions no two initargs
+      ;;     will try to fill the same position, since compute
+      ;;     initarg positions already took care of that, but
+      ;;     we do need to know what initforms will and won't
+      ;;     be needed.
+      ;;   
+      (doplist (initarg val) supplied-initargs
+	(let ((positions (cdr (assq initarg initarg-positions))))
+	  (cond ((memq :class positions) (bail-out))
+		((constantp val)
+		 (setq val (eval val))
+		 (push val constant-initargs)
+		 (push initarg constant-initargs)
+		 (dolist (pos positions) (setf (svref constants pos) val)))
+		(t
+		 (push positions supplied-initarg-positions)))
+	  (setq used-positions (append positions used-positions))))
+      ;;
+      ;; Go through each of the default initargs, for three reasons.
+      ;;
+      ;;   - If it fills a class slot, bail out.
+      ;;   - If it is a constant, and it does fill a slot, put that
+      ;;     into the constant vector.
+      ;;   - If it isn't a constant, record its initfn and position.
+      ;;   
+      (dolist (default defaults)
+	(let* ((name (car default))
+	       (initfn (cadr default))
+	       (form (caddr default))
+	       (value ())
+	       (positions (cdr (assq name initarg-positions))))
+	  (unless (memq name supplied-initarg-names)
+	    (cond ((memq :class positions) (bail-out))
+		  ((constantp form)
+		   (setq value (eval form))
+		   (push value constant-initargs)
+		   (push name constant-initargs)
+		   (dolist (pos positions)
+		     (setf (svref constants pos) value)))
+		  (t
+		   (push (list* initfn name positions)
+			 initfns-initargs-and-positions)))
+	    (setq used-positions (append positions used-positions)))))
+      ;;
+      ;; Go through each of the slot initforms:
+      ;;
+      ;;    - If its position has already been filled, do nothing.
+      ;;      The initfn won't need to be called, and the slot won't
+      ;;      need to be touched.
+      ;;    - If it is a class slot, and has an initform, bail out.
+      ;;    - If its a constant or unsupplied, ignore it, it is
+      ;;      already in the constant vector.
+      ;;    - Otherwise, record its initfn and position
+      ;;
+      (dolist (slotd (class-slots class))
+	(let* ((alloc (slotd-allocation slotd))
+	       (name (slotd-name slotd))
+	       (form (slotd-initform slotd))
+	       (initfn (slotd-initfunction slotd))
+	       (position (position name layout)))
+	  (cond ((neq alloc :instance)
+		 (unless (or (eq form *slotd-unsupplied*)
+			     (null initfn))
+		   (bail-out)))
+		((member position used-positions))
+		((or (constantp form)
+		     (eq form *slotd-unsupplied*)))
+		(t
+		 (push (list initfn nil position)
+		       initfns-initargs-and-positions)))))
+
+      (values constants
+	      constant-initargs
+	      (nreverse initfns-initargs-and-positions)
+	      (nreverse supplied-initarg-positions)
+	      (mapcar #'method-function
+		      (remove *standard-shared-initialize-method* shared))
+	      (mapcar #'method-function
+		      (remove *standard-initialize-instance-method* init))))))
+
+
+;;;
+;;; The NO-METHODS case allows:
+;;;   constant, unsupplied or non-constant initforms
+;;;   constant or non-constant default initargs
+;;;   supplied initargs that are arguments to constructor, or constants
+;;;   slot-filling initargs
+;;;
+
+(define-constructor-code-type no-methods
+        (class name arglist supplied-initarg-names supplied-initargs)
+  (declare (ignore name))
+  (let ((raw-allocator (raw-instance-allocator class))
+	(slots-fetcher (slots-fetcher class))
+	(wrapper-fetcher (wrapper-fetcher class)))
+    `(function
+       (lambda (class .wrapper. defaults init shared)
+	 (multiple-value-bind (.constants.
+			       .initfns-and-positions.
+			       .supplied-initarg-positions.)
+	     (no-methods-generator-internal class
+					    defaults
+					    ',supplied-initarg-names
+					    ',supplied-initargs)
+	   .initfns-and-positions.
+	   .supplied-initarg-positions.
+	   (when (and .constants.
+		      (null (non-clos-initialize-instance-methods-p init))
+		      (null (non-clos-shared-initialize-methods-p shared)))
+	     #'(lambda ,arglist
+		 (declare (optimize (speed 3) (safety 0)))
+		 (let ((.instance. (,raw-allocator))
+		       (.slots. (copy-constant-vector .constants.))
+		       (.positions. .supplied-initarg-positions.))
+		   .positions.
+		   (setf (,slots-fetcher .instance.) .slots.)
+		   (setf (,wrapper-fetcher .instance.) .wrapper.)
+
+		   (dolist (entry .initfns-and-positions.)
+		     (let ((val (funcall (car entry))))
+		       (dolist (pos (cdr entry))
+			 (setf (%svref .slots. pos) val))))
+		 
+		   ,@(gathering1 (collecting)
+		       (doplist (initarg value) supplied-initargs
+			 (unless (constantp value)
+			   (gather1
+			     `(let ((.value. ,value))
+				(dolist (.p. (pop .positions.))
+				  (setf (%svref .slots. .p.) .value.)))))))
+		     
+		   .instance.))))))))
+
+(defun no-methods-generator-internal
+       (class defaults supplied-initarg-names supplied-initargs)
+  (flet ((bail-out () (return-from no-methods-generator-internal nil)))
+    (let* ((constants	(compute-constant-vector class))
+	   (layout (wrapper-instance-slots-layout (class-wrapper class)))
+	   (initarg-positions
+	     (compute-initarg-positions class
+					(append supplied-initarg-names
+						(mapcar #'car defaults))))
+	   (initfns-and-positions ())
+	   (supplied-initarg-positions ())
+	   (used-positions ()))
+      ;;
+      ;; Go through each of the supplied initargs for three reasons.
+      ;;
+      ;;   - If it fills a class slot, bail out.
+      ;;   - If its a constant form, fill the constant vector.
+      ;;   - Otherwise remember the positions, no two initargs
+      ;;     will try to fill the same position, since compute
+      ;;     initarg positions already took care of that, but
+      ;;     we do need to know what initforms will and won't
+      ;;     be needed.
+      ;;   
+      (doplist (initarg val) supplied-initargs
+	(let ((positions (cdr (assq initarg initarg-positions))))
+	  (cond ((memq :class positions) (bail-out))
+		((constantp val)
+		 (setq val (eval val))
+		 (dolist (pos positions)
+		   (setf (svref constants pos) val)))
+		(t
+		 (push positions supplied-initarg-positions)))
+	  (setq used-positions (append positions used-positions))))
+      ;;
+      ;; Go through each of the default initargs, for three reasons.
+      ;;
+      ;;   - If it fills a class slot, bail out.
+      ;;   - If it is a constant, and it does fill a slot, put that
+      ;;     into the constant vector.
+      ;;   - If it isn't a constant, record its initfn and position.
+      ;;   
+      (dolist (default defaults)
+	(let* ((name (car default))
+	       (initfn (cadr default))
+	       (form (caddr default))
+	       (value ())
+	       (positions (cdr (assq name initarg-positions))))
+	  (unless (memq name supplied-initarg-names)
+	    (cond ((memq :class positions) (bail-out))
+		  ((constantp form)
+		   (setq value (eval form))
+		   (dolist (pos positions)
+		     (setf (svref constants pos) value)))
+		  (t
+		   (push (cons initfn positions)
+			 initfns-and-positions)))
+	    (setq used-positions (append positions used-positions)))))
+      ;;
+      ;; Go through each of the slot initforms:
+      ;;
+      ;;    - If its position has already been filled, do nothing.
+      ;;      The initfn won't need to be called, and the slot won't
+      ;;      need to be touched.
+      ;;    - If it is a class slot, and has an initform, bail out.
+      ;;    - If its a constant or unsupplied, do nothing, we know
+      ;;      that it is already in the constant vector.
+      ;;    - Otherwise, record its initfn and position
+      ;;
+      (dolist (slotd (class-slots class))
+	(let* ((alloc (slotd-allocation slotd))
+	       (name (slotd-name slotd))
+	       (form (slotd-initform slotd))
+	       (initfn (slotd-initfunction slotd))
+	       (position (position name layout)))
+	  (cond ((neq alloc :instance)
+		 (unless (or (eq form *slotd-unsupplied*) 
+			     (null initfn))
+		   (bail-out)))
+		((member position used-positions))
+		((or (constantp form)
+		     (eq form *slotd-unsupplied*)))
+		(t
+		 (push (list initfn position) initfns-and-positions)))))
+
+      (values constants
+	      (nreverse initfns-and-positions)
+	      (nreverse supplied-initarg-positions)))))
+
+
+;;;
+;;; The SIMPLE-SLOTS case allows:
+;;;   constant or unsupplied initforms
+;;;   constant default initargs
+;;;   supplied initargs
+;;;   slot filling initargs
+;;;
+
+(define-constructor-code-type simple-slots
+        (class name arglist supplied-initarg-names supplied-initargs)
+  (declare (ignore name))
+  (let ((raw-allocator (raw-instance-allocator class))
+	(slots-fetcher (slots-fetcher class))
+	(wrapper-fetcher (wrapper-fetcher class)))
+    `(function
+       (lambda (class .wrapper. defaults init shared)
+	 (when (and (null (non-clos-initialize-instance-methods-p init))
+		    (null (non-clos-shared-initialize-methods-p shared)))
+	   (multiple-value-bind (.constants. .supplied-initarg-positions.)
+	       (simple-slots-generator-internal class
+						defaults
+						',supplied-initarg-names
+						',supplied-initargs)
+	     (when .constants.
+	       (function
+		 (lambda ,arglist
+		   (declare (optimize (speed 3) (safety 0)))
+		   (let ((.instance. (,raw-allocator))
+			 (.slots. (copy-constant-vector .constants.))
+			 (.positions. .supplied-initarg-positions.))
+		     
+		     .positions.
+		     (setf (,slots-fetcher .instance.) .slots.)	     
+		     (setf (,wrapper-fetcher .instance.) .wrapper.)
+		 
+		     ,@(gathering1 (collecting)
+			 (doplist (initarg value) supplied-initargs
+			   (unless (constantp value)
+			     (gather1
+			       `(let ((.value. ,value))
+				  (dolist (.p. (pop .positions.))
+				    (setf (%svref .slots. .p.) .value.)))))))
+		     
+		     .instance.))))))))))
+
+(defun simple-slots-generator-internal
+       (class defaults supplied-initarg-names supplied-initargs)
+  (flet ((bail-out () (return-from simple-slots-generator-internal nil)))
+    (let* ((constants (compute-constant-vector class))
+	   (layout (wrapper-instance-slots-layout (class-wrapper class)))
+	   (initarg-positions
+	     (compute-initarg-positions class
+					(append supplied-initarg-names
+						(mapcar #'car defaults))))
+	   (supplied-initarg-positions ())
+	   (used-positions ()))
+      ;;
+      ;; Go through each of the supplied initargs for three reasons.
+      ;;
+      ;;   - If it fills a class slot, bail out.
+      ;;   - If its a constant form, fill the constant vector.
+      ;;   - Otherwise remember the positions, no two initargs
+      ;;     will try to fill the same position, since compute
+      ;;     initarg positions already took care of that, but
+      ;;     we do need to know what initforms will and won't
+      ;;     be needed.
+      ;;   
+      (doplist (initarg val) supplied-initargs
+	(let ((positions (cdr (assq initarg initarg-positions))))
+	  (cond ((memq :class positions) (bail-out))
+		((constantp val)
+		 (setq val (eval val))
+		 (dolist (pos positions)
+		   (setf (svref constants pos) val)))
+		(t
+		 (push positions supplied-initarg-positions)))
+	  (setq used-positions (append used-positions positions))))
+      ;;
+      ;; Go through each of the default initargs for three reasons.
+      ;; 
+      ;;   - If it isn't a constant form, bail out.
+      ;;   - If it fills a class slot, bail out.
+      ;;   - If it is a constant, and it does fill a slot, put that
+      ;;     into the constant vector.
+      ;;   
+      (dolist (default defaults)
+	(let* ((name (car default))
+	       (form (caddr default))
+	       (value ())
+	       (positions (cdr (assq name initarg-positions))))
+	  (unless (memq name supplied-initarg-names)
+	    (cond ((memq :class positions) (bail-out))
+		  ((not (constantp form))
+		   (bail-out))
+		  (t
+		   (setq value (eval form))
+		   (dolist (pos positions)
+		     (setf (svref constants pos) value)))))))
+      ;;
+      ;; Go through each of the slot initforms:
+      ;;
+      ;;    - If its position has already been filled, do nothing.
+      ;;      The initfn won't need to be called, and the slot won't
+      ;;      need to be touched, we are OK.
+      ;;    - If it has a non-constant initform, bail-out.  This
+      ;;      case doesn't handle those.
+      ;;    - If it has a constant or unsupplied initform we don't
+      ;;      really need to do anything, the value is in the
+      ;;      constants vector.
+      ;;
+      (dolist (slotd (class-slots class))
+	(let* ((alloc (slotd-allocation slotd))
+	       (name (slotd-name slotd))
+	       (form (slotd-initform slotd))
+	       (initfn (slotd-initfunction slotd))
+	       (position (position name layout)))
+	  (cond ((neq alloc :instance)
+		 (unless (or (eq form *slotd-unsupplied*)
+			     (null initfn))
+		   (bail-out)))
+		((member position used-positions))
+		((or (constantp form)
+		     (eq form *slotd-unsupplied*)))
+		(t
+		 (bail-out)))))
+      
+      (values constants (nreverse supplied-initarg-positions)))))
diff --git a/clos/3.5/cpl.dfasl b/clos/3.5/cpl.dfasl
new file mode 100644
index 00000000..e8ae73df
Binary files /dev/null and b/clos/3.5/cpl.dfasl differ
diff --git a/clos/3.5/cpl.lisp b/clos/3.5/cpl.lisp
new file mode 100644
index 00000000..9eda3018
--- /dev/null
+++ b/clos/3.5/cpl.lisp
@@ -0,0 +1,271 @@
+;;;-*- Package: CLOS; Syntax: Common-Lisp; Base: 10 -*-
+;;;. Copyright (c) 1991 by Venue
+
+
+(in-package "CLOS")
+
+
+;;; compute-class-precedence-list Knuth section 2.2.3 has some interesting notes on this. What
+;;; appears here is basically the algorithm presented there. The key idea is that we use
+;;; class-precedence-description (CPD) structures to store the precedence information as we proceed.
+;;; The CPD structure for a class stores two critical pieces of information: - a count of the number
+;;; of "reasons" why the class can't go into the class precedence list yet. - a list of the
+;;; "reasons" this class prevents others from going in until after it 
+
+
+
+;; 
+
+
+
+;;; A "reason" is essentially a single local precedence constraint.  If a constraint between two
+;;; classes arises more than once it generates more than one reason.  This makes things simpler,
+;;; linear, and isn't a problem as long as we make sure to keep track of each instance of a
+;;; "reason". This code is divided into three phases. - the first phase simply generates the CPD's
+;;; for each of the class and its superclasses.  The remainder of the code will manipulate these
+;;; CPDs rather than the class objects themselves.  At the end of this pass, the CPD-SUPERS field of
+;;; a CPD is a list of the CPDs of the direct superclasses of the class. - the second phase folds
+;;; all the local constraints into the CPD structure.  The CPD-COUNT of each CPD is built up, and
+;;; the CPD-AFTER fields are augmented to include precedence constraints from the CPD-SUPERS field
+;;; and from the order of classes in other CPD-SUPERS fields. After this phase, the CPD-AFTER field
+;;; of a class includes all the direct superclasses of the class plus any class that immediately
+;;; follows the class in the direct superclasses of another.  There can be duplicates in this list. 
+;;; The CPD-COUNT field is equal to the number of times this class appears in the CPD-AFTER field of
+;;; all the other CPDs. - In the third phase, classes are put into the precedence list one at a
+;;; time, with only those classes with a CPD-COUNT of 0 being candidates for insertion.  When a
+;;; class is inserted , every CPD in its CPD-AFTER field has its count decremented. In the usual
+;;; case, there is only one candidate for insertion at any point.  If there is more than one, the
+;;; specified tiebreaker rule is used to choose among them. 
+
+
+(defmethod compute-class-precedence-list ((root std-class)
+                                          direct-superclasses)
+       (compute-std-cpl root direct-superclasses))
+
+(defstruct (class-precedence-description (:conc-name nil)
+                  (:print-function (lambda (obj str depth)
+                                          (declare (ignore depth))
+                                          (format str "#<CPD ~S ~D>" (class-name (cpd-class obj))
+                                                 (cpd-count obj))))
+                  (:constructor make-cpd nil))
+       (cpd-class nil)
+       (cpd-supers nil)
+       (cpd-after nil)
+       (cpd-count 0))
+
+(defun compute-std-cpl (class supers)
+       (cond ((null supers)
+                                                             ; First two branches of COND
+              (list class))
+                                                             ; are implementing the single
+             ((null (cdr supers))
+                                                             ; inheritance optimization.
+              (cons class (compute-std-cpl (car supers)
+                                 (class-direct-superclasses (car supers)))))
+             (t (multiple-value-bind (all-cpds nclasses)
+                    (compute-std-cpl-phase-1 class supers)
+                  (compute-std-cpl-phase-2 all-cpds)
+                  (compute-std-cpl-phase-3 class all-cpds nclasses)))))
+
+(defvar *compute-std-cpl-class->entry-table-size* 60)
+
+(defun compute-std-cpl-phase-1 (class supers)
+       (let ((nclasses 0)
+             (all-cpds nil)
+             (table (make-hash-table :size *compute-std-cpl-class->entry-table-size* :test
+                           #'eq)))
+            (labels ((get-cpd (c)
+                            (or (gethash c table)
+                                (setf (gethash c table)
+                                      (make-cpd))))
+                     (walk (c supers)
+                           (if (forward-referenced-class-p c)
+                               (cpl-forward-referenced-class-error class c)
+                               (let ((cpd (get-cpd c)))
+                                    (unless (cpd-class cpd)
+                                                             ; If we have already done this class
+                                                             ; before, we can quit. 
+                                        (setf (cpd-class cpd)
+                                              c)
+                                        (incf nclasses)
+                                        (push cpd all-cpds)
+                                        (setf (cpd-supers cpd)
+                                              (mapcar #'get-cpd supers))
+                                        (dolist (super supers)
+                                            (walk super (class-direct-superclasses super))))))))
+                   (walk class supers)
+                   (values all-cpds nclasses))))
+
+(defun compute-std-cpl-phase-2 (all-cpds)
+       (dolist (cpd all-cpds)
+           (let ((supers (cpd-supers cpd)))
+                (when supers
+                    (setf (cpd-after cpd)
+                          (nconc (cpd-after cpd)
+                                 supers))
+                    (incf (cpd-count (car supers))
+                          1)
+                    (do* ((t1 supers t2)
+                          (t2 (cdr t1)
+                              (cdr t1)))
+                         ((null t2))
+                       (incf (cpd-count (car t2))
+                             2)
+                       (push (car t2)
+                             (cpd-after (car t1))))))))
+
+(defun
+ compute-std-cpl-phase-3
+ (class all-cpds nclasses)
+ (let ((candidates nil)
+       (next-cpd nil)
+       (rcpl nil))
+      
+      ;; We have to bootstrap the collection of those CPD's that have a zero count.  Once we get
+      ;; going, we will maintain this list incrementally. 
+      (dolist (cpd all-cpds)
+          (when (zerop (cpd-count cpd))
+                (push cpd candidates)))
+      (loop (when (null candidates)
+                
+                ;; If there are no candidates, and enough classes have been put into the precedence
+                ;; list, then we are all done.  Otherwise it means there is a consistency problem. 
+                (if (zerop nclasses)
+                    (return (reverse rcpl))
+                    (cpl-inconsistent-error class all-cpds)))
+            
+            ;; Try to find the next class to put in from among the candidates. If there is only one,
+            ;; its easy, otherwise we have to use the famous RPG tiebreaker rule.  There is some
+            ;; hair here to avoid having to call DELETE on the list of candidates.  I dunno if its
+            ;; worth it but what the hell. 
+            (setq next-cpd
+                  (if (null (cdr candidates))
+                      (prog1 (car candidates)
+                             (setq candidates nil))
+                      (block tie-breaker
+                          (dolist (c rcpl)
+                              (let ((supers (class-direct-superclasses c)))
+                                   (if (memq (cpd-class (car candidates))
+                                             supers)
+                                       (return-from tie-breaker (pop candidates))
+                                       (do ((loc candidates (cdr loc)))
+                                           ((null (cdr loc)))
+                                         (let ((cpd (cadr loc)))
+                                              (when (memq (cpd-class cpd)
+                                                          supers)
+                                                  (setf (cdr loc)
+                                                        (cddr loc))
+                                                  (return-from tie-breaker cpd))))))))))
+            (decf nclasses)
+            (push (cpd-class next-cpd)
+                  rcpl)
+            (dolist (after (cpd-after next-cpd))
+                (when (zerop (decf (cpd-count after)))
+                      (push after candidates))))))
+
+
+;;; Support code for signalling nice error messages. 
+
+
+(defun cpl-error (class format-string &rest format-args)
+       (error "While computing the class precedence list of the class ~A.~%~A"
+              (if (class-name class)
+                  (format nil "named ~S" (class-name class))
+                  class)
+              (apply #'format nil format-string format-args)))
+
+(defun cpl-forward-referenced-class-error (class forward-class)
+       (flet ((class-or-name (class)
+                     (if (class-name class)
+                         (format nil "named ~S" (class-name class))
+                         class)))
+             (let ((names (mapcar #'class-or-name (cdr (find-superclass-chain class forward-class))))
+                   )
+                  (cpl-error class 
+                "The class ~A is a forward referenced class.~@
+                  The class ~A is ~A." (class-or-name forward-class)
+                         (class-or-name forward-class)
+                         (if (null (cdr names))
+                             (format nil "a direct superclass of the class ~A" (class-or-name class))
+                             (format nil "reached from the class ~A by following~@
+                              the direct superclass chain through: ~A~
+                              ~%  ending at the class ~A" (class-or-name class)
+                                    (format nil "~{~%  the class ~A,~}" (butlast names))
+                                    (car (last names))))))))
+
+(defun find-superclass-chain (bottom top)
+       (labels ((walk (c chain)
+                      (if (eq c top)
+                          (return-from find-superclass-chain (nreverse chain))
+                          (dolist (super (class-direct-superclasses c))
+                              (walk super (cons super chain))))))
+              (walk bottom (list bottom))))
+
+(defun cpl-inconsistent-error (class all-cpds)
+       (let ((reasons (find-cycle-reasons all-cpds)))
+            (cpl-error class "It is not possible to compute the class precedence list because~@
+       there ~A in the local precedence relations.~@
+       ~A because:~{~%  ~A~}." (if (cdr reasons)
+                                   "are circularities"
+                                   "is a circularity")
+                   (if (cdr reasons)
+                       "These arise"
+                       "This arises")
+                   (format-cycle-reasons (apply #'append reasons)))))
+
+(defun format-cycle-reasons (reasons)
+       (flet ((class-or-name (cpd)
+                     (let ((class (cpd-class cpd)))
+                          (if (class-name class)
+                              (format nil "named ~S" (class-name class))
+                              class))))
+             (mapcar #'(lambda (reason)
+                              (ecase (caddr reason)
+                                  (:super (format nil 
+                                                 "the class ~A appears in the supers of the class ~A"
+                                                 (class-or-name (cadr reason))
+                                                 (class-or-name (car reason))))
+                                  (:in-supers (format nil 
+                                    "the class ~A follows the class ~A in the supers of the class ~A"
+                                                     (class-or-name (cadr reason))
+                                                     (class-or-name (car reason))
+                                                     (class-or-name (cadddr reason))))))
+                    reasons)))
+
+(defun find-cycle-reasons (all-cpds)
+       (let ((been-here nil)
+                                                             ; List of classes we have visited.
+             (cycle-reasons nil))
+            (labels ((chase (path)
+                            (if (memq (car path)
+                                      (cdr path))
+                                (record-cycle (memq (car path)
+                                                    (nreverse path)))
+                                (unless (memq (car path)
+                                              been-here)
+                                    (push (car path)
+                                          been-here)
+                                    (dolist (after (cpd-after (car path)))
+                                        (chase (cons after path))))))
+                     (record-cycle
+                      (cycle)
+                      (let ((reasons nil))
+                           (do* ((t1 cycle t2)
+                                 (t2 (cdr t1)
+                                     (cdr t1)))
+                                ((null t2))
+                              (let ((c1 (car t1))
+                                    (c2 (car t2)))
+                                   (if (memq c2 (cpd-supers c1))
+                                       (push (list c1 c2 :super)
+                                             reasons)
+                                       (dolist (cpd all-cpds)
+                                           (when (memq c2 (memq c1 (cpd-supers cpd)))
+                                               (return (push (list c1 c2 :in-supers cpd)
+                                                             reasons)))))))
+                           (push (nreverse reasons)
+                                 cycle-reasons))))
+                   (dolist (cpd all-cpds)
+                       (unless (zerop (cpd-count cpd))
+                           (chase (list cpd))))
+                   cycle-reasons)))
diff --git a/clos/3.5/ctypes.dfasl b/clos/3.5/ctypes.dfasl
new file mode 100644
index 00000000..54d81e78
Binary files /dev/null and b/clos/3.5/ctypes.dfasl differ
diff --git a/clos/3.5/ctypes.lisp b/clos/3.5/ctypes.lisp
new file mode 100644
index 00000000..1de6d3a4
--- /dev/null
+++ b/clos/3.5/ctypes.lisp
@@ -0,0 +1,25 @@
+;;;-*-Mode:LISP; Package: PCL; Base:10; Syntax:Common-lisp -*-
+;;;
+;;; *************************************************************************
+;;; Copyright (c) 1991 Venue
+;;; All rights reserved.
+;;; *************************************************************************
+;;;
+
+(in-package 'clos)
+
+;;;
+;;; The built-in method combination types as taken from page 1-31 of 88-002R.
+;;; Note that the STANDARD method combination type is defined by hand in the
+;;; file combin.lisp.
+;;;
+
+(define-method-combination +      :identity-with-one-argument t)
+(define-method-combination and    :identity-with-one-argument t)
+(define-method-combination append :identity-with-one-argument nil)
+(define-method-combination list   :identity-with-one-argument nil)
+(define-method-combination max    :identity-with-one-argument t)
+(define-method-combination min    :identity-with-one-argument t)
+(define-method-combination nconc  :identity-with-one-argument t)
+(define-method-combination or     :identity-with-one-argument t)
+(define-method-combination progn  :identity-with-one-argument t)
diff --git a/clos/3.5/defclass.dfasl b/clos/3.5/defclass.dfasl
new file mode 100644
index 00000000..87ee9f7a
Binary files /dev/null and b/clos/3.5/defclass.dfasl differ
diff --git a/clos/3.5/defclass.lisp b/clos/3.5/defclass.lisp
new file mode 100644
index 00000000..4aaf9791
--- /dev/null
+++ b/clos/3.5/defclass.lisp
@@ -0,0 +1,230 @@
+;;;-*- Package: CLOS; Syntax: Common-Lisp; Base: 10 -*-
+
+;;;. Copyright (c) 1991 by Venue
+(in-package "CLOS")
+
+;;; ************************************************************************* 
+
+
+
+;;; MAKE-TOP-LEVEL-FORM is used by all PCL macros that appear `at top-level'. The original
+;;; motiviation for this function was to deal with the bug in the Genera compiler that prevents
+;;; lambda expressions in top-level forms other than DEFUN from being compiled. Now this function is
+;;; used to grab other functionality as well.  This includes: - Preventing the grouping of top-level
+;;; forms.  For example, a DEFCLASS followed by a DEFMETHOD may not want to be grouped into the same
+;;; top-level form. - Telling the programming environment what the pretty version of the name of
+;;; this form is.  This is used by WARN. 
+
+
+(defun make-top-level-form (name times form)
+       (flet ((definition-name nil (if (and (listp name)
+                                            (memq (car name)
+                                                  '(defmethod defclass class method 
+                                                          method-combination)))
+                                       (format nil "~A~{ ~S~}" (capitalize-words (car name)
+                                                                      nil)
+                                              (cdr name))
+                                       (format nil "~S" name))))
+             (definition-name)
+             (make-progn `',name `(eval-when ,times ,form))))
+
+(defun make-progn (&rest forms)
+       (let ((progn-form nil))
+            (labels ((collect-forms (forms)
+                            (unless (null forms)
+                                (collect-forms (cdr forms))
+                                (if (and (listp (car forms))
+                                         (eq (caar forms)
+                                             'progn))
+                                    (collect-forms (cdar forms))
+                                    (push (car forms)
+                                          progn-form)))))
+                   (collect-forms forms)
+                   (cons 'progn progn-form))))
+
+
+;;; Like the DEFMETHOD macro, the expansion of the DEFCLASS macro is fixed. DEFCLASS always expands
+;;; into a call to LOAD-DEFCLASS.  Until the meta- braid is set up, LOAD-DEFCLASS has a special
+;;; definition which simply collects all class definitions up, when the metabraid is initialized it
+;;; is done from those class definitions. After the metabraid has been setup, and the protocol for
+;;; defining classes has been defined, the real definition of LOAD-DEFCLASS is installed by the file
+;;; defclass.lisp 
+
+
+(defmacro defclass (name direct-superclasses direct-slots &rest options)
+       (declare (indentation 2 4 3 1))
+       (expand-defclass name direct-superclasses direct-slots options))
+
+(defun expand-defclass (name supers slots options)
+       (setq supers (copy-tree supers)
+             slots
+             (copy-tree slots)
+             options
+             (copy-tree options))
+       (let ((metaclass 'standard-class))
+            (dolist (option options)
+                (if (not (listp option))
+                    (error "~S is not a legal defclass option." option)
+                    (when (eq (car option)
+                              ':metaclass)
+                        (unless (legal-class-name-p (cadr option))
+                            (error 
+        "The value of the :metaclass option (~S) is not a~%~
+                      legal class name." (cadr option)))
+                        (setq metaclass (cadr option))
+                        (setf options (remove option options))
+                        (return t))))
+            (let ((*initfunctions* nil)
+                  (*accessors* nil))
+                                                             ; Truly a crock, but we got to have it
+                                                             ; to live nicely. 
+                 (declare (special *initfunctions* *accessors*))
+                 (let ((canonical-slots (mapcar #'(lambda (spec)
+                                                         (canonicalize-slot-specification name spec))
+                                               slots))
+                       (other-initargs (mapcar #'(lambda (option)
+                                                        (canonicalize-defclass-option name option))
+                                              options)))
+                      (do-standard-defsetfs-for-defclass *accessors*)
+;		      (load-defclass name metaclass supers
+;				     canonical-slots (apply #'append
+;							    other-initargs) *accessors*)))))
+                      (make-top-level-form `(defclass ,name nil nil)
+                             *defclass-times*
+                             `(let ,(mapcar #'cdr *initfunctions*)
+                                   (load-defclass ',name ',metaclass ',supers (list 
+                                                                                    ,@canonical-slots
+                                                                                    )
+                                          (list ,@(apply #'append other-initargs))
+                                          ',*accessors*)))))))
+
+(defun make-initfunction (initform)
+       (declare (special *initfunctions*))
+       (cond ((or (eq initform 't)
+                  (equal initform ''t))
+              '#'true)
+             ((or (eq initform 'nil)
+                  (equal initform ''nil))
+              '#'false)
+             ((or (eql initform '0)
+                  (equal initform ''0))
+              '#'zero)
+             (t (let ((entry (assoc initform *initfunctions* :test #'equal)))
+                     (unless entry
+                         (setq entry (list initform (gensym)
+                                           `#'(lambda nil ,initform)))
+                         (push entry *initfunctions*))
+                     (cadr entry)))))
+
+(defun canonicalize-slot-specification (class-name spec)
+       (declare (special *accessors*))
+       (cond ((and (symbolp spec)
+                   (not (keywordp spec))
+                   (not (memq spec '(t nil))))
+              `'(:name ,spec))
+             ((not (consp spec))
+              (error "~S is not a legal slot specification." spec))
+             ((null (cdr spec))
+              `'(:name ,(car spec)))
+             ((null (cddr spec))
+              (error 
+        "In DEFCLASS ~S, the slot specification ~S is obsolete.~%~
+                 Convert it to ~S" class-name spec (list (car spec)
+                                                         :initform
+                                                         (cadr spec))))
+             (t (let* ((name (pop spec))
+                       (readers nil)
+                       (writers nil)
+                       (initargs nil)
+                       (unsupplied (list nil))
+                       (initform (getf spec :initform unsupplied)))
+                      (doplist (key val)
+                             spec
+                             (case key
+                                 (:accessor 
+                                    (push val *accessors*)
+                                    (push val readers)
+                                    (push `(setf ,val)
+                                          writers))
+                                 (:reader (push val readers))
+                                 (:writer (push val writers))
+                                 (:initarg (push val initargs))))
+                      (loop (unless (remf spec :accessor)
+                                   (return)))
+                      (loop (unless (remf spec :reader)
+                                   (return)))
+                      (loop (unless (remf spec :writer)
+                                   (return)))
+                      (loop (unless (remf spec :initarg)
+                                   (return)))
+                      (setq spec `(:name ',name :readers ',readers
+				   :writers ',writers :initargs
+                                         ',initargs
+                                         ',spec))
+                      (if (eq initform unsupplied)
+                          `(list* ,@spec)
+                          `(list* :initfunction ,(make-initfunction initform)
+                                  ,@spec))))))
+
+(defun canonicalize-defclass-option (class-name option)
+       (declare (ignore class-name))
+       (case (car option)
+           (:default-initargs (let ((canonical nil))
+                                   (let (key val (tail (cdr option)))
+                                        (loop (when (null tail)
+                                                    (return nil))
+                                              (setq key (pop tail)
+                                                    val
+                                                    (pop tail))
+                                              (push ``(,',key ,,(make-initfunction val)
+                                                             ,',val)
+                                                    canonical))
+                                        `(':direct-default-initargs (list ,@(nreverse canonical))))))
+           (otherwise `(',(car option)
+                        ',(cdr option)))))
+
+
+;;; This is the early definition of load-defclass.  It just collects up all the class definitions in
+;;; a list.  Later, in the file braid1.lisp, these are actually defined. Each entry in
+;;; *early-class-definitions* is an early-class-definition. 
+
+
+(defparameter *early-class-definitions* nil)
+
+(defun make-early-class-definition (name source metaclass superclass-names canonical-slots 
+                                         other-initargs)
+       (list 'early-class-definition name source metaclass superclass-names canonical-slots 
+             other-initargs))
+
+(defun ecd-class-name (ecd)
+       (nth 1 ecd))
+
+(defun ecd-source (ecd)
+       (nth 2 ecd))
+
+(defun ecd-metaclass (ecd)
+       (nth 3 ecd))
+
+(defun ecd-superclass-names (ecd)
+       (nth 4 ecd))
+
+(defun ecd-canonical-slots (ecd)
+       (nth 5 ecd))
+
+(defun ecd-other-initargs (ecd)
+       (nth 6 ecd))
+
+(proclaim '(notinline load-defclass))
+
+(defun load-defclass (name metaclass supers canonical-slots canonical-options accessor-names)
+       (setq supers (copy-tree supers)
+             canonical-slots
+             (copy-tree canonical-slots)
+             canonical-options
+             (copy-tree canonical-options))
+       (do-standard-defsetfs-for-defclass accessor-names)
+       (let ((ecd (make-early-class-definition name (load-truename)
+                         metaclass supers canonical-slots (apply #'append canonical-options)))
+             (existing (find name *early-class-definitions* :key #'ecd-class-name)))
+            (setq *early-class-definitions* (cons ecd (remove existing *early-class-definitions*)))
+            ecd))
diff --git a/clos/3.5/defcombin.dfasl b/clos/3.5/defcombin.dfasl
new file mode 100644
index 00000000..50b05006
Binary files /dev/null and b/clos/3.5/defcombin.dfasl differ
diff --git a/clos/3.5/defcombin.lisp b/clos/3.5/defcombin.lisp
new file mode 100644
index 00000000..5bb69ebd
--- /dev/null
+++ b/clos/3.5/defcombin.lisp
@@ -0,0 +1,410 @@
+;;;-*-Mode:LISP; Package: CLOS; Base:10; Syntax:Common-lisp -*-
+;;;
+;;; *************************************************************************
+;;; Copyright (c) 1991 Venue
+;;; All rights reserved.
+;;; *************************************************************************
+;;;
+
+(in-package 'clos)
+
+;;;
+;;; DEFINE-METHOD-COMBINATION
+;;;
+
+(defmacro define-method-combination (&whole form &rest args)
+  (declare (ignore args))
+  (if (and (cddr form)
+	   (listp (caddr form)))
+      (expand-long-defcombin form)
+      (expand-short-defcombin form)))
+
+
+;;;
+;;; STANDARD method combination
+;;;
+;;; The STANDARD method combination type is implemented directly by the class
+;;; STANDARD-METHOD-COMBINATION.  The method on COMPUTE-EFFECTIVE-METHOD does
+;;; standard method combination directly and is defined by hand in the file
+;;; combin.lisp.  The method for FIND-METHOD-COMBINATION must appear in this
+;;; file for bootstrapping reasons.
+;;;
+;;; A commented out copy of this definition appears in combin.lisp.
+;;; If you change this definition here, be sure to change it there
+;;; also.
+;;;
+(defmethod find-method-combination ((generic-function generic-function)
+				    (type (eql 'standard))
+				    options)
+  (when options
+    (method-combination-error
+      "The method combination type STANDARD accepts no options."))
+  *standard-method-combination*)
+
+
+
+;;;
+;;; short method combinations
+;;;
+;;; Short method combinations all follow the same rule for computing the
+;;; effective method.  So, we just implement that rule once.  Each short
+;;; method combination object just reads the parameters out of the object
+;;; and runs the same rule.
+;;;
+;;;
+(defclass short-method-combination (standard-method-combination)
+     ((operator
+	:reader short-combination-operator
+	:initarg :operator)
+      (identity-with-one-argument
+	:reader short-combination-identity-with-one-argument
+	:initarg :identity-with-one-argument)))
+
+(define-gf-predicate short-method-combination-p short-method-combination)
+
+(defun expand-short-defcombin (whole)
+  (let* ((type (cadr whole))
+	 (documentation
+	   (getf (cddr whole) :documentation ""))
+	 (identity-with-one-arg
+	   (getf (cddr whole) :identity-with-one-argument nil))
+	 (operator 
+	   (getf (cddr whole) :operator type)))
+    (make-top-level-form `(define-method-combination ,type)
+			 '(load eval)
+      `(load-short-defcombin
+	 ',type ',operator ',identity-with-one-arg ',documentation))))
+
+(defun load-short-defcombin (type operator ioa doc)
+  (let* ((truename (load-truename))
+	 (specializers
+	   (list (find-class 'generic-function)
+		 (make-instance 'eql-specializer :object type)
+		 *the-class-t*))
+	 (old-method
+	   (get-method #'find-method-combination () specializers nil))
+	 (new-method nil))
+    (setq new-method
+	  (make-instance 'standard-method
+	    :qualifiers ()
+	    :specializers specializers
+	    :lambda-list '(generic-function type options)
+	    :function #'(lambda (gf type options)
+			  (declare (ignore gf))
+			  (do-short-method-combination
+			    type options operator ioa new-method doc))
+	    :definition-source `((define-method-combination ,type) ,truename)))
+    (when old-method
+      (remove-method #'find-method-combination old-method))
+    (add-method #'find-method-combination new-method)))
+
+(defun do-short-method-combination (type options operator ioa method doc)
+  (cond ((null options) (setq options '(:most-specific-first)))
+	((equal options '(:most-specific-first)))
+	((equal options '(:most-specific-last)))
+	(t
+	 (method-combination-error
+	   "Illegal options to a short method combination type.~%~
+            The method combination type ~S accepts one option which~%~
+            must be either :MOST-SPECIFIC-FIRST or :MOST-SPECIFIC-LAST."
+	   type)))
+  (make-instance 'short-method-combination
+		 :type type
+		 :options options
+		 :operator operator
+		 :identity-with-one-argument ioa
+		 :definition-source method
+		 :documentation doc))
+
+(defmethod compute-effective-method ((generic-function generic-function)
+				     (combin short-method-combination)
+				     applicable-methods)
+  (let ((type (method-combination-type combin))
+	(operator (short-combination-operator combin))
+	(ioa (short-combination-identity-with-one-argument combin))
+	(around ())
+	(primary ()))
+    (dolist (m applicable-methods)
+      (let ((qualifiers (method-qualifiers m)))
+	(flet ((lose (method why)
+		 (invalid-method-error
+		   method
+		   "The method ~S ~A.~%~
+                    The method combination type ~S was defined with the~%~
+                    short form of DEFINE-METHOD-COMBINATION and so requires~%~
+                    all methods have either the single qualifier ~S or the~%~
+                    single qualifier :AROUND."
+		   method why type type)))
+	  (cond ((null qualifiers)
+		 (lose m "has no qualifiers"))
+		((cdr qualifiers)
+		 (lose m "has more than one qualifier"))
+		((eq (car qualifiers) :around)
+		 (push m around))
+		((eq (car qualifiers) type)
+		 (push m primary))
+		(t
+		 (lose m "has an illegal qualifier"))))))
+    (setq around (nreverse around)
+	  primary (nreverse primary))
+    (let ((main-method
+	    (if (and (null (cdr primary))
+		     (not (null ioa)))
+		`(call-method ,(car primary) ())
+		`(,operator ,@(mapcar #'(lambda (m) `(call-method ,m ()))
+				      primary)))))
+      (cond ((null primary)
+	     `(error "No ~S methods for the generic function ~S."
+		     ',type ',generic-function))
+	    ((null around) main-method)
+	    (t
+	     `(call-method ,(car around)
+			   (,@(cdr around) (make-method ,main-method))))))))
+
+
+;;;
+;;; long method combinations
+;;;
+;;;
+
+(defclass long-method-combination (standard-method-combination)
+     ((function :initarg :function
+		:reader long-method-combination-function)))
+
+(defun expand-long-defcombin (form)
+  (let ((type (cadr form))
+	(lambda-list (caddr form))
+	(method-group-specifiers (cadddr form))
+	(body (cddddr form))
+	(arguments-option ())
+	(gf-var nil))
+    (when (and (consp (car body)) (eq (caar body) :arguments))
+      (setq arguments-option (cdr (pop body))))
+    (when (and (consp (car body)) (eq (caar body) :generic-function))
+      (setq gf-var (cadr (pop body))))
+    (multiple-value-bind (documentation function)
+	(make-long-method-combination-function
+	  type lambda-list method-group-specifiers arguments-option gf-var
+	  body)
+      (make-top-level-form `(define-method-combination ,type)
+			   '(load eval)
+	`(load-long-defcombin ',type ',documentation #',function)))))
+
+(defvar *long-method-combination-functions* (make-hash-table :test #'eq))
+
+(defun load-long-defcombin (type doc function)
+  (let* ((specializers
+	   (list (find-class 'generic-function)
+		 (make-instance 'eql-specializer :object type)
+		 *the-class-t*))
+	 (old-method
+	   (get-method #'find-method-combination () specializers nil))
+	 (new-method
+	   (make-instance 'standard-method
+	     :qualifiers ()
+	     :specializers specializers
+	     :lambda-list '(generic-function type options)
+	     :function #'(lambda (generic-function type options)
+			   (declare (ignore generic-function))
+			   (make-instance 'long-method-combination
+			     :type type
+			     :documentation doc
+			     :options options))
+	     :definition-source `((define-method-combination ,type)
+				  ,(load-truename)))))
+    (setf (gethash type *long-method-combination-functions*) function)
+    (when old-method (remove-method #'find-method-combination old-method))
+    (add-method #'find-method-combination new-method)))
+
+(defmethod compute-effective-method ((generic-function generic-function)
+				     (combin long-method-combination)
+				     applicable-methods)
+  (funcall (gethash (method-combination-type combin)
+		    *long-method-combination-functions*)
+	   generic-function
+	   combin
+	   applicable-methods))
+
+;;;
+;;;
+;;;
+(defun make-long-method-combination-function
+       (type ll method-group-specifiers arguments-option gf-var body)
+  (declare (ignore type) (values documentation function))
+  (multiple-value-bind (documentation declarations real-body)
+      (extract-declarations body)
+
+    (let ((wrapped-body
+	    (wrap-method-group-specifier-bindings method-group-specifiers
+						  declarations
+						  real-body)))
+      (when gf-var
+	(push `(,gf-var .generic-function.) (cadr wrapped-body)))
+      
+      (when arguments-option
+	(setq wrapped-body (deal-with-arguments-option wrapped-body
+						       arguments-option)))
+
+      (when ll
+	(setq wrapped-body
+	      `(apply #'(lambda ,ll ,wrapped-body)
+		      (method-combination-options .method-combination.))))
+
+      (values
+	documentation
+	`(lambda (.generic-function. .method-combination. .applicable-methods.)
+	   (progn .generic-function. .method-combination. .applicable-methods.)
+	   (block .long-method-combination-function. ,wrapped-body))))))
+;;
+;; parse-method-group-specifiers parse the method-group-specifiers
+;;
+
+(defun wrap-method-group-specifier-bindings
+       (method-group-specifiers declarations real-body)
+  (with-gathering ((names (collecting))
+		   (specializer-caches (collecting))
+		   (cond-clauses (collecting))
+		   (required-checks (collecting))
+		   (order-cleanups (collecting)))
+      (dolist (method-group-specifier method-group-specifiers)
+	(multiple-value-bind (name tests description order required)
+	    (parse-method-group-specifier method-group-specifier)
+	  (declare (ignore description))
+	  (let ((specializer-cache (gensym)))
+	    (gather name names)
+	    (gather specializer-cache specializer-caches)
+	    (gather `((or ,@tests)
+		      (if  (equal ,specializer-cache .specializers.)
+			   (return-from .long-method-combination-function.
+			     '(error "More than one method of type ~S ~
+                                      with the same specializers."
+				     ',name))
+			   (setq ,specializer-cache .specializers.))
+		      (push .method. ,name))
+		    cond-clauses)
+	    (when required
+	      (gather `(when (null ,name)
+			 (return-from .long-method-combination-function.
+			   '(error "No ~S methods." ',name)))
+		      required-checks))
+	    (loop (unless (and (constantp order)
+			       (neq order (setq order (eval order))))
+		    (return t)))
+	    (gather (cond ((eq order :most-specific-first)
+			   `(setq ,name (nreverse ,name)))
+			  ((eq order :most-specific-last) ())
+			  (t
+			   `(ecase ,order
+			      (:most-specific-first
+				(setq ,name (nreverse ,name)))
+			      (:most-specific-last))))
+		    order-cleanups))))
+   `(let (,@names ,@specializer-caches)
+      ,@declarations
+      (dolist (.method. .applicable-methods.)
+	(let ((.qualifiers. (method-qualifiers .method.))
+	      (.specializers. (method-specializers .method.)))
+	  (progn .qualifiers. .specializers.)
+	  (cond ,@cond-clauses)))
+      ,@required-checks
+      ,@order-cleanups
+      ,@real-body)))
+   
+(defun parse-method-group-specifier (method-group-specifier)
+  (declare (values name tests description order required))
+  (let* ((name (pop method-group-specifier))
+	 (patterns ())
+	 (tests 
+	   (gathering1 (collecting)
+	     (block collect-tests
+	       (loop
+		 (if (or (null method-group-specifier)
+			 (memq (car method-group-specifier)
+			       '(:description :order :required)))
+		     (return-from collect-tests t)
+		     (let ((pattern (pop method-group-specifier)))
+		       (push pattern patterns)
+		       (gather1 (parse-qualifier-pattern name pattern)))))))))
+    (values name
+	    tests
+	    (getf method-group-specifier :description
+		  (make-default-method-group-description patterns))
+	    (getf method-group-specifier :order :most-specific-first)
+	    (getf method-group-specifier :required nil))))
+
+(defun parse-qualifier-pattern (name pattern)
+  (cond ((eq pattern '()) `(null .qualifiers.))
+	((eq pattern '*) 't)
+	((symbolp pattern) `(,pattern .qualifiers.))
+	((listp pattern) `(qualifier-check-runtime ',pattern .qualifiers.))
+	(t (error "In the method group specifier ~S,~%~
+                   ~S isn't a valid qualifier pattern."
+		  name pattern))))
+
+(defun qualifier-check-runtime (pattern qualifiers)
+  (loop (cond ((and (null pattern) (null qualifiers))
+	       (return t))
+	      ((eq pattern '*) (return t))
+	      ((and pattern qualifiers (eq (car pattern) (car qualifiers)))
+	       (pop pattern)
+	       (pop qualifiers))	      
+	      (t (return nil)))))
+
+(defun make-default-method-group-description (patterns)
+  (if (cdr patterns)
+      (format nil
+	      "methods matching one of the patterns: ~{~S, ~} ~S"
+	      (butlast patterns) (car (last patterns)))
+      (format nil
+	      "methods matching the pattern: ~S"
+	      (car patterns))))
+
+
+
+;;;
+;;; This baby is a complete mess.  I can't believe we put it in this
+;;; way.  No doubt this is a large part of what drives MLY crazy.
+;;;
+;;; At runtime (when the effective-method is run), we bind an intercept
+;;; lambda-list to the arguments to the generic function.
+;;; 
+;;; At compute-effective-method time, the symbols in the :arguments
+;;; option are bound to the symbols in the intercept lambda list.
+;;;
+(defun deal-with-arguments-option (wrapped-body arguments-option)
+  (let* ((intercept-lambda-list
+	   (gathering1 (collecting)
+	     (dolist (arg arguments-option)
+	       (if (memq arg lambda-list-keywords)
+		   (gather1 arg)
+		   (gather1 (gensym))))))
+	 (intercept-rebindings
+	   (gathering1 (collecting)
+	     (iterate ((arg (list-elements arguments-option))
+		       (int (list-elements intercept-lambda-list)))
+	       (unless (memq arg lambda-list-keywords)
+		 (gather1 `(,arg ',int)))))))
+    ;;
+    ;;
+    (setf (cadr wrapped-body)
+	  (append intercept-rebindings (cadr wrapped-body)))
+    ;;
+    ;; Be sure to fill out the intercept lambda list so that it can
+    ;; be too short if it wants to.
+    ;; 
+    (cond ((memq '&rest intercept-lambda-list))
+	  ((memq '&allow-other-keys intercept-lambda-list))
+	  ((memq '&key intercept-lambda-list)
+	   (setq intercept-lambda-list
+		 (append intercept-lambda-list '(&allow-other-keys))))
+	  (t
+	   (setq intercept-lambda-list
+		 (append intercept-lambda-list '(&rest .ignore.)))))
+
+    `(let ((inner-result. ,wrapped-body))
+       `(apply #'(lambda ,',intercept-lambda-list
+		   ,,(when (memq '.ignore. intercept-lambda-list)
+		       ''(declare (ignore .ignore.)))
+		   ,inner-result.)
+	       .combined-method-args.))))
+
diff --git a/clos/3.5/defs.DFASL b/clos/3.5/defs.DFASL
new file mode 100644
index 00000000..44148d64
Binary files /dev/null and b/clos/3.5/defs.DFASL differ
diff --git a/clos/3.5/defs.lisp b/clos/3.5/defs.lisp
new file mode 100644
index 00000000..e0f2a047
--- /dev/null
+++ b/clos/3.5/defs.lisp
@@ -0,0 +1,570 @@
+;;;-*- Package: CLOS; Syntax: Common-Lisp; Base: 10 -*-
+;;;. Copyright (c) 1991 by Venue
+
+
+(in-package "CLOS")
+
+(eval-when (compile load eval)
+       (defvar *defclass-times* '(load eval compile))	;Probably have to change this
+						;if you use defconstructor.
+(defvar *defmethod-times*  '(load eval compile))
+(defvar *defgeneric-times* '(load eval compile))
+)
+
+
+;;; Convert a function name to its standard setf function name.  We have to do this hack because not
+;;; all Common Lisps have yet converted to having setf function specs. In a port that does have setf
+;;; function specs you can use those just by making the obvious simple changes to these functions. 
+;;; The rest of CLOS believes that there are function names like (SETF <foo>), this is the only place
+;;; that knows about this hack. 
+
+
+(eval-when (compile load eval)
+       (defvar *setf-function-names* (make-hash-table :size 200 :test #'eq))
+(defun get-setf-function-name (name)
+  (or (gethash name *setf-function-names*)
+      (setf (gethash name *setf-function-names*)
+	    (intern (format nil
+			    "SETF ~A ~A"
+			    (package-name (symbol-package name))
+			    (symbol-name name))
+		    *the-clos-package*))))
+
+;;;
+;;; Call this to define a setf macro for a function with the same behavior as
+;;; specified by the SETF function cleanup proposal.  Specifically, this will
+;;; cause: (SETF (FOO a b) x) to expand to (|SETF FOO| x a b).
+;;;
+;;; do-standard-defsetf                  A macro interface for use at top level
+;;;                                      in files.  Unfortunately, users may
+;;;                                      have to use this for a while.
+;;;                                      
+;;; do-standard-defsetfs-for-defclass    A special version called by defclass.
+;;; 
+;;; do-standard-defsetf-1                A functional interface called by the
+;;;                                      above, defmethod and defgeneric.
+;;;                                      Since this is all a crock anyways,
+;;;                                      users are free to call this as well.
+;;;
+(defmacro do-standard-defsetf (&rest function-names)
+  `(eval-when (compile load eval)
+     (dolist (fn-name ',function-names) (do-standard-defsetf-1 fn-name))))
+
+(defun do-standard-defsetfs-for-defclass (accessors)
+  (dolist (name accessors) (do-standard-defsetf-1 name)))
+
+(defun do-standard-defsetf-1 (function-name)
+  (unless (setfboundp function-name)
+    (let* ((setf-function-name (get-setf-function-name function-name)))
+    
+  (flet ((setf-expander (body env)
+	       (declare (ignore env))
+	       (let ((temps
+		       (mapcar #'(lambda (x) (declare (ignore x)) (gensym))
+			       (cdr body)))
+		     (forms (cdr body))
+		     (vars (list (gensym))))
+		 (values temps
+			 forms
+			 vars
+			 `(,setf-function-name ,@vars ,@temps)
+			 `(,function-name ,@temps)))))
+	(let ((setf-method-expander (intern (concatenate 'string
+						         (symbol-name function-name)
+						         "-setf-expander")
+				     (symbol-package function-name))))
+	  (setf (get function-name :setf-method-expander) setf-method-expander
+		(symbol-function setf-method-expander) #'setf-expander)))
+
+     )))
+(defun setfboundp (symbol)
+(or (get symbol :setf-inverse)
+	       (get symbol 'il:setf-inverse)
+	       (get symbol 'il:setfn)
+	       (get symbol :shared-setf-inverse)
+	       (get symbol :setf-method-expander)
+	       (get symbol 'il:setf-method-expander)))
+)
+
+                                                             ; eval-when
+
+
+
+;;; CLOS, like user code, must endure the fact that we don't have a properly working setf.  Many
+;;; things work because they get mentioned by a defclass or defmethod before they are used, but
+;;; others have to be done by hand. 
+
+
+(do-standard-defsetf 
+	class-wrapper                           ; ***
+     generic-function-name 
+	method-function-plist 
+	method-function-get 
+	gdefinition 
+     slot-value-using-class)
+
+(defsetf slot-value set-slot-value)
+
+
+;;; This is like fdefinition on the Lispm.  If Common Lisp had something like function specs I
+;;; wouldn't need this.  On the other hand, I don't like the way this really works so maybe function
+;;; specs aren't really right either? I also don't understand the real implications of a Lisp-1 on
+;;; this sort of thing.  Certainly some of the lossage in all of this is because these SPECs name
+;;; global definitions. Note that this implementation is set up so that an implementation which has
+;;; a 'real' function spec mechanism can use that instead and in that way get rid of setf generic
+;;; function names. 
+
+
+(defmacro parse-gspec (spec (non-setf-var . non-setf-case)
+                            (setf-var . setf-case))
+              (once-only (spec)
+              `(cond ((symbolp ,spec)
+                      (let ((,non-setf-var ,spec))
+                           ,@non-setf-case))
+                     ((and (listp ,spec)
+                           (eq (car ,spec)
+                               'setf)
+                           (symbolp (cadr ,spec)))
+                      (let ((,setf-var (cadr ,spec)))
+                           ,@setf-case))
+                     (t (error "Can't understand ~S as a generic function specifier.~%~
+               It must be either a symbol which can name a function or~%~
+               a list like ~S, where the car is the symbol ~S and the cadr~%~
+               is a symbol which can name a generic function." ,spec '(setf <foo>)
+                               'setf)))))
+
+
+;;; If symbol names a function which is traced or advised, return the unadvised, traced etc.
+;;; definition.  This lets me get at the generic function object even when it is traced. 
+
+
+(defun unencapsulated-fdefinition (symbol)
+       (il:virginfn symbol))
+
+
+;;; If symbol names a function which is traced or advised, redefine the `real' definition without
+;;; affecting the advise. 
+
+
+(defun fdefine-carefully (symbol new-definition)
+       (let ((advisedp (member symbol il:advisedfns :test #'eq))
+             (brokenp (member symbol il:brokenfns :test #'eq)))
+            
+            ;; In XeroxLisp (late of envos) tracing is implemented as a special case of "breaking". 
+            ;; Advising, however, is treated specially. 
+            (xcl:unadvise-function symbol :no-error t)
+            (xcl:unbreak-function symbol :no-error t)
+            (setf (symbol-function symbol)
+                  new-definition)
+            (when brokenp (xcl:rebreak-function symbol))
+            (when advisedp (xcl:readvise-function symbol)))
+       new-definition)
+
+(defun gboundp (spec)
+       (parse-gspec spec (name (fboundp name))
+              (name (fboundp (get-setf-function-name name)))))
+
+(defun gmakunbound (spec)
+       (parse-gspec spec (name (fmakunbound name))
+              (name (fmakunbound (get-setf-function-name name)))))
+
+(defun gdefinition (spec)
+       (parse-gspec spec (name (or (macro-function name)
+                                                             ; ??
+                                   (unencapsulated-fdefinition name)))
+              (name (unencapsulated-fdefinition (get-setf-function-name name)))))
+
+(defun SETF\ CLOS\ GDEFINITION (new-value spec)
+       (parse-gspec spec (name (fdefine-carefully name new-value))
+              (name (fdefine-carefully (get-setf-function-name name)
+                           new-value))))
+
+
+;;; These functions are a pale imitiation of their namesake.  They accept class objects or types
+;;; where they should. 
+
+
+(defun *typep (object type)
+       (if (classp type)
+           (let ((class (class-of object)))
+                (if class
+                    (memq type (class-precedence-list class))
+                    nil))
+           (let ((class (find-class type nil)))
+                (if class
+                    (*typep object class)
+                    (typep object type)))))
+
+(defun *subtypep (type1 type2)
+       (let ((c1 (if (classp type1)
+                     type1
+                     (find-class type1 nil)))
+             (c2 (if (classp type2)
+                     type2
+                     (find-class type2 nil))))
+            (if (and c1 c2)
+                (memq c2 (class-precedence-list c1))
+                (if (or c1 c2)
+                    nil
+                                                             ; This isn't quite right, but...
+                    (subtypep type1 type2)))))
+
+(defun do-satisfies-deftype (name predicate)
+       (let* ((specifier `(satisfies ,predicate))
+              (expand-fn #'(lambda (&rest ignore)
+                                  (declare (ignore ignore))
+                                  specifier)))
+             
+             ;; Specific ports can insert their own way of doing this.  Many ports may find the
+             ;; expand-fn defined above useful. 
+             (or 
+                 ;; This is the default for ports for which we don't know any better.  Note that for
+                 ;; most ports, providing this definition should just speed up class definition.  It
+                 ;; shouldn't have an effect on performance of most user code. 
+                 (eval `(deftype ,name nil '(satisfies ,predicate))))))
+
+(defun make-type-predicate-name (name)
+       (intern (format nil "TYPE-PREDICATE ~A ~A" (package-name (symbol-package name))
+                      (symbol-name name))
+              *the-clos-package*))
+
+(proclaim '(special *the-class-t* *the-class-vector* *the-class-symbol* *the-class-string* 
+                  *the-class-sequence* *the-class-rational* *the-class-ratio* *the-class-number* 
+                  *the-class-null* *the-class-list* *the-class-integer* *the-class-float* 
+                  *the-class-cons* *the-class-complex* *the-class-character* *the-class-bit-vector* 
+                  *the-class-array* *the-class-standard-object* *the-class-class* *the-class-method*
+                  *the-class-generic-function* *the-class-standard-class* *the-class-standard-method*
+                  *the-class-standard-generic-function* 
+                  *the-class-standard-effective-slot-definition* *the-eslotd-standard-class-slots*))
+
+(proclaim '(special *the-wrapper-of-t* *the-wrapper-of-vector* *the-wrapper-of-symbol* 
+                  *the-wrapper-of-string* *the-wrapper-of-sequence* *the-wrapper-of-rational* 
+                  *the-wrapper-of-ratio* *the-wrapper-of-number* *the-wrapper-of-null* 
+                  *the-wrapper-of-list* *the-wrapper-of-integer* *the-wrapper-of-float* 
+                  *the-wrapper-of-cons* *the-wrapper-of-complex* *the-wrapper-of-character* 
+                  *the-wrapper-of-bit-vector* *the-wrapper-of-array*))
+
+(defvar *built-in-class-symbols* nil)
+
+(defvar *built-in-wrapper-symbols* nil)
+
+(defun get-built-in-class-symbol (class-name)
+       (or (cadr (assq class-name *built-in-class-symbols*))
+           (let ((symbol (intern (format nil "*THE-CLASS-~A*" (symbol-name class-name))
+                                *the-clos-package*)))
+                (push (list class-name symbol)
+                      *built-in-class-symbols*)
+                symbol)))
+
+(defun get-built-in-wrapper-symbol (class-name)
+       (or (cadr (assq class-name *built-in-wrapper-symbols*))
+           (let ((symbol (intern (format nil "*THE-WRAPPER-OF-~A*" (symbol-name class-name))
+                                *the-clos-package*)))
+                (push (list class-name symbol)
+                      *built-in-wrapper-symbols*)
+                symbol)))
+
+(pushnew 'class *variable-declarations*)
+
+(pushnew 'variable-rebinding *variable-declarations*)
+
+(defun variable-class (var env)
+       (caddr (variable-declaration 'class var env)))
+
+(defvar *boot-state* nil)
+                                                             ; NIL EARLY BRAID COMPLETE 
+
+
+(eval-when (load eval)
+       (when (eq *boot-state* 'complete)
+             (error "Trying to load (or compile) CLOS in an environment in which it~%~
+            has already been loaded.  This doesn't work, you will have to~%~
+            get a fresh lisp (reboot) and then load CLOS."))
+       (when *boot-state* (cerror "Try loading (or compiling) CLOS anyways." "Trying to load (or compile) CLOS in an environment in which it~%~
+             has already been partially loaded.  This may not work, you may~%~
+             need to get a fresh lisp (reboot) and then load CLOS.")))
+
+
+;;; This is used by combined methods to communicate the next methods to the methods they call.  This
+;;; variable is captured by a lexical variable of the methods to give it the proper lexical scope. 
+
+
+(defvar *next-methods* nil)
+
+(defvar *not-an-eql-specializer* '(not-an-eql-specializer))
+
+(defvar *umi-gfs*)
+
+(defvar *umi-complete-classes*)
+
+(defvar *umi-reorder*)
+
+(defvar *invalidate-discriminating-function-force-p* nil)
+
+(defvar *invalid-dfuns-on-stack* nil)
+
+(defvar *standard-method-combination*)
+
+(defvar *slotd-unsupplied* (list '*slotd-unsupplied*))
+
+                                                             ; ***
+
+
+(defmacro define-gf-predicate (predicate &rest classes)
+       `(progn (defmethod ,predicate ((x t))
+                      nil)
+               ,@(mapcar #'(lambda (c)
+                                  `(defmethod ,predicate ((x ,c))
+                                          t))
+                        classes)))
+
+(defmacro plist-value (object name)
+       `(with-slots (plist)
+               ,object
+               (getf plist ,name)))
+
+(defsetf plist-value (object name)
+       (new-value)
+       (once-only (new-value)
+              `(with-slots (plist)
+                      ,object
+                      (if ,new-value
+                          (setf (getf plist ,name)
+                                ,new-value)
+                          (progn (remf plist ,name)
+                                 nil)))))
+
+(defvar *built-in-classes* 
+
+       ;; name       supers     subs                     cdr of cpl 
+       '((number (t) (complex float rational)
+                (t))
+         (complex (number)
+                nil
+                (number t))
+         (float (number)
+                nil
+                (number t))
+         (rational (number)
+                (integer ratio)
+                (number t))
+         (integer (rational)
+                nil
+                (rational number t))
+         (ratio (rational)
+                nil
+                (rational number t))
+         (sequence (t)
+                (list vector)
+                (t))
+         (list (sequence)
+               (cons null)
+               (sequence t))
+         (cons (list)
+               nil
+               (list sequence t))
+         (array (t)
+                (vector)
+                (t))
+         (vector (array sequence)
+                (string bit-vector)
+                (array sequence t))
+         (string (vector)
+                nil
+                (vector array sequence t))
+         (bit-vector (vector)
+                nil
+                (vector array sequence t))
+         (character (t)
+                nil
+                (t))
+         (symbol (t)
+                (null)
+                (t))
+         (null (symbol)
+               nil
+               (symbol list sequence t))))
+
+
+;;; The classes that define the kernel of the metabraid. 
+
+
+(defclass t nil nil (:metaclass built-in-class))
+
+(defclass standard-object (t)
+       nil)
+
+(defclass metaobject (standard-object)
+       nil)
+
+(defclass specializer (metaobject)
+       nil)
+
+(defclass definition-source-mixin (standard-object)
+       ((source :initform (load-truename)
+               :reader definition-source :initarg :definition-source)))
+
+(defclass plist-mixin (standard-object)
+       ((plist :initform nil)))
+
+(defclass documentation-mixin (plist-mixin)
+       nil)
+
+(defclass dependent-update-mixin (plist-mixin)
+       nil)
+
+
+;;; The class CLASS is a specified basic class.  It is the common superclass of any kind of class. 
+;;; That is any class that can be a metaclass must have the class CLASS in its class precedence
+;;; list. 
+
+
+(defclass class (documentation-mixin dependent-update-mixin definition-source-mixin specializer)
+       ((name :initform nil :initarg :name :accessor class-name)
+        (direct-superclasses :initform nil :reader class-direct-superclasses)
+        (direct-subclasses :initform nil :reader class-direct-subclasses)
+        (direct-methods :initform (cons nil nil))))
+
+
+;;; The class CLOS-CLASS is an implementation-specific common superclass of all specified subclasses
+;;; of the class CLASS. 
+
+
+(defclass clos-class (class)
+       ((class-precedence-list :initform nil)
+        (wrapper :initform nil)))
+
+
+;;; The class STD-CLASS is an implementation-specific common superclass of the classes
+;;; STANDARD-CLASS and FUNCALLABLE-STANDARD-CLASS. 
+
+
+(defclass std-class (clos-class)
+       ((direct-slots :initform nil :accessor class-direct-slots)
+        (slots :initform nil :accessor class-slots)
+        (no-of-instance-slots                                ; *** MOVE TO WRAPPER ***
+               :initform 0 :accessor class-no-of-instance-slots)
+        (prototype :initform nil)))
+
+(defclass standard-class (std-class)
+       nil)
+
+(defclass funcallable-standard-class (std-class)
+       nil)
+
+(defclass forward-referenced-class (clos-class)
+       nil)
+
+(defclass built-in-class (clos-class)
+       nil)
+
+
+;;; Slot definitions. Note that throughout CLOS, "SLOT-DEFINITION" is abbreviated as "SLOTD". 
+
+
+(defclass slot-definition (metaobject)
+       nil)
+
+(defclass direct-slot-definition (slot-definition)
+       nil)
+
+(defclass effective-slot-definition (slot-definition)
+       nil)
+;
+(defclass standard-slot-definition (slot-definition)
+       ((name :initform nil :accessor slotd-name)
+        (initform :initform *slotd-unsupplied* :accessor slotd-initform)
+        (initfunction :initform *slotd-unsupplied* :accessor slotd-initfunction)
+        (readers :initform nil :accessor slotd-readers)
+        (writers :initform nil :accessor slotd-writers)
+        (initargs :initform nil :accessor slotd-initargs)
+        (allocation :initform nil :accessor slotd-allocation)
+        (type :initform nil :accessor slotd-type)
+        (documentation :initform "" :initarg :documentation)
+        (class :initform nil :accessor slotd-class)
+        (instance-index :initform nil :accessor slotd-instance-index)))
+
+(defclass standard-direct-slot-definition (standard-slot-definition direct-slot-definition)
+       nil)
+
+                                                             ; Adding slots here may involve extra
+                                                             ; work to the code in braid.lisp 
+
+
+(defclass standard-effective-slot-definition (standard-slot-definition effective-slot-definition)
+       nil)
+
+                                                             ; Adding slots here may involve extra
+                                                             ; work to the code in braid.lisp 
+
+
+(defclass eql-specializer (specializer)
+       ((object :initarg :object :reader eql-specializer-object)))
+
+
+;;; 
+
+
+(defmacro dolist-carefully ((var list improper-list-handler)
+                            &body body)
+       `(let ((,var nil)
+              (.dolist-carefully. ,list))
+             (loop (when (null .dolist-carefully.)
+                         (return nil))
+                   (if (consp .dolist-carefully.)
+                       (progn (setq ,var (pop .dolist-carefully.))
+                              ,@body)
+                       (,improper-list-handler)))))
+
+(defun legal-std-documentation-p (x)
+       (if (or (null x)
+               (stringp x))
+           t
+           "a string or NULL"))
+
+(defun legal-std-lambda-list-p (x)
+       (declare (ignore x))
+       t)
+
+(defun legal-std-method-function-p (x)
+       (if (functionp x)
+           t
+           "a function"))
+
+(defun legal-std-qualifiers-p (x)
+       (flet ((improper-list nil (return-from legal-std-qualifiers-p "Is not a proper list.")))
+             (dolist-carefully (q x improper-list)
+                    (let ((ok (legal-std-qualifier-p q)))
+                         (unless (eq ok t)
+                             (return-from legal-std-qualifiers-p (format nil "Contains ~S which ~A" q
+                                                                        ok)))))
+             t))
+
+(defun legal-std-qualifier-p (x)
+       (if (and x (atom x))
+           t
+           "is not a non-null atom"))
+
+(defun legal-std-slot-name-p (x)
+       (cond ((not (symbolp x))
+              "is not a symbol and so cannot be bound")
+             ((keywordp x)
+              "is a keyword and so cannot be bound")
+             ((memq x '(t nil))
+              "cannot be bound")
+             (t t)))
+
+(defun legal-std-specializers-p (x)
+       (flet ((improper-list nil (return-from legal-std-specializers-p "Is not a proper list.")))
+             (dolist-carefully (s x improper-list)
+                    (let ((ok (legal-std-specializer-p s)))
+                         (unless (eq ok t)
+                             (return-from legal-std-specializers-p (format nil "Contains ~S which ~A"
+                                                                          s ok)))))
+             t))
+
+(defun legal-std-specializer-p (x)
+       (if (or (classp x)
+               (eql-specializer-p x))
+           t
+           "is neither a class object nor an eql specializer"))
diff --git a/clos/3.5/defsys.DFASL b/clos/3.5/defsys.DFASL
new file mode 100644
index 00000000..91e2f5e3
Binary files /dev/null and b/clos/3.5/defsys.DFASL differ
diff --git a/clos/3.5/defsys.lisp b/clos/3.5/defsys.lisp
new file mode 100644
index 00000000..62e5850c
--- /dev/null
+++ b/clos/3.5/defsys.lisp
@@ -0,0 +1,761 @@
+;;;-*-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))
+
+   (clos-env    t                                   t ()   Xerox)
+   (web-editor  t                                   t ()   Xerox)
+   (new-clos-browser t                              t ()   Xerox)
+   ))
+
+(defun compile-clos (&optional m)
+  (let (#+:coral(ccl::*warn-if-redefine-kernel* nil)
+	#+Lucid (lcl:*redefinition-action* nil)
+	#+excl  (excl::*redefinition-warnings* nil)
+	#+Genera (sys:inhibit-fdefine-warnings t)
+	)
+    (cond ((null m)        (operate-on-system 'clos :compile))
+	  ((eq m :print)   (operate-on-system 'clos :compile () t))
+	  ((eq m :query)   (operate-on-system 'clos :query-compile))
+	  ((eq m :confirm) (operate-on-system 'clos :confirm-compile))
+	  ((eq m 't)       (operate-on-system 'clos :recompile))        
+	  ((listp m)       (operate-on-system 'clos :compile-from m))
+	  ((symbolp m)     (operate-on-system 'clos :recompile-some `(,m))))))
+
+(defun load-clos (&optional m)
+  (let (#+:coral(ccl::*warn-if-redefine-kernel* nil)
+	#+Lucid (lcl:*redefinition-action* nil)
+	#+excl  (excl::*redefinition-warnings* nil)
+	#+Genera (sys:inhibit-fdefine-warnings t)
+	)
+    (cond ((null m)      (operate-on-system 'clos :load))
+	  ((eq m :query) (operate-on-system 'clos :query-load)))
+    (pushnew :clos *features*)))
+
+#+Genera
+;;; Make sure Genera bug mail contains the CLOS bug data.  A little
+;;; kludgy, but what the heck.  If they didn't mean for people to do
+;;; this, they wouldn't have made private patch notes be flavored
+;;; objects, right?  Right.
+(progn
+  (scl:defflavor clos-private-patch-info ((description)) ())
+  (scl:defmethod (sct::private-patch-info-description clos-private-patch-info) ()
+    (or description
+	(setf description (string-append "CLOS version: " *clos-system-date*))))
+  (scl:defmethod (sct::private-patch-info-pathname clos-private-patch-info) ()
+    *clos-directory*)
+  (unless (find-if #'(lambda (x) (typep x 'clos-private-patch-info))
+		   sct::*private-patch-info*)
+    (push (scl:make-instance 'clos-private-patch-info)
+	  sct::*private-patch-info*)))
+
+(defun bug-report-info (&optional (stream *standard-output*))
+  (format stream "~&CLOS system date: ~A~
+                  ~&Lisp Implementation type: ~A~
+                  ~&Lisp Implementation version: ~A~
+                  ~&*features*: ~S"
+	  *clos-system-date*
+	  (lisp-implementation-type)
+	  (lisp-implementation-version)
+	  *features*))
+
+
+
+;;;;
+;;;
+;;; This stuff is not intended for external use.
+;;; 
+(defun rename-clos ()
+  (dolist (f (cadr (get-system 'clos)))
+    (let ((old nil)
+          (new nil))
+      (let ((*system-directory* *default-pathname-defaults*))
+        (setq old (make-source-pathname (car f))))
+      (setq new  (make-source-pathname (car f)))
+      (rename-file old new))))
+
+#+Genera
+(defun edit-clos ()
+  (dolist (f (cadr (get-system 'clos)))
+    (let ((*system-directory* *clos-directory*))
+      (zwei:find-file (make-source-pathname (car f))))))
+
+#+Genera
+(defun hardcopy-clos (&optional query-p)
+  (let ((files (mapcar #'(lambda (f)
+                           (setq f (car f))
+                           (and (or (not query-p)
+                                    (y-or-n-p "~A? " f))
+                                f))
+		       (cadr (get-system 'clos))))
+        (b zwei:*interval*))
+    (unwind-protect
+        (dolist (f files)
+          (when f
+            (multiple-value-bind (ignore b)
+                (zwei:find-file (make-source-pathname f))
+              (zwei:hardcopy-buffer b))))
+      (zwei:make-buffer-current b))))
+
+
+;;;
+;;; unido!ztivax!dae@seismo.css.gov
+;;; z30083%tansei.cc.u-tokyo.junet@utokyo-relay.csnet
+;;; Victor@carmen.uu.se
+;;; mcvax!harlqn.co.uk!chris@uunet.UU.NET
+;;; 
+#+Genera
+(defun mail-clos (to)
+  (let* ((original-buffer zwei:*interval*)
+	 (*system-directory* (pathname "vaxc:/user/ftp/pub/clos/")
+			    ;(funcall (car (get-system 'clos)))
+			     )
+         (files (list* 'defsys
+			'test
+			(caddr (get-system 'clos))))
+         (total-number (length files))
+         (file nil)
+	 (number-of-lines 0)
+         (i 0)
+         (mail-buffer nil))
+    (unwind-protect
+        (loop
+           (when (null files) (return nil))
+           (setq file (pop files))
+           (incf i)
+           (multiple-value-bind (ignore b)
+               (zwei:find-file (make-source-pathname file))
+	     (setq number-of-lines (zwei:count-lines b))
+             (zwei:com-mail-internal t
+                                     :initial-to to
+                                     :initial-body b
+				     :initial-subject
+                                     (format nil
+				       "CLOS file   ~A   (~A of ~A) ~D lines"
+				       file i total-number number-of-lines))
+             (setq mail-buffer zwei:*interval*)
+             (zwei:com-exit-com-mail)
+             (format t "~&Just sent ~A  (~A of ~A)." b i total-number)
+             (zwei:kill-buffer mail-buffer)))
+      (zwei:make-buffer-current original-buffer))))
+
+
diff --git a/clos/3.5/dfun.dfasl b/clos/3.5/dfun.dfasl
new file mode 100644
index 00000000..85d8576f
Binary files /dev/null and b/clos/3.5/dfun.dfasl differ
diff --git a/clos/3.5/dfun.lisp b/clos/3.5/dfun.lisp
new file mode 100644
index 00000000..1e958a30
--- /dev/null
+++ b/clos/3.5/dfun.lisp
@@ -0,0 +1,606 @@
+;;;-*- Package: CLOS; Syntax: Common-Lisp; Base: 10 -*-
+
+;;;. Copyright (c) 1991 by Venue
+
+(in-package "CLOS")
+
+                                                             
+                                                             ; ************************************************************************
+                                                             ; temporary for data gathering         
+                                                             ; temporary for data gathering
+                                                             ; ************************************************************************
+
+
+(defvar *dfun-states* (make-hash-table :test #'eq))
+
+(defun notice-dfun-state (generic-function state &optional nkeys valuep)
+       (setf (gethash generic-function *dfun-states*)
+             (cons state (when nkeys (list nkeys valuep)))))
+
+                                                             
+                                                             ; ************************************************************************
+                                                             ; temporary for data gathering         
+                                                             ; temporary for data gathering
+                                                             ; ************************************************************************
+
+
+(defvar *dfun-constructors* nil)
+
+                                                             ; An alist in which each entry is of
+                                                             ; the form (<generator> . (<subentry>
+                                                             ; ...)) Each subentry is of the form:
+                                                             ; (<args> <constructor> <system>) 
+
+
+(defvar *enable-dfun-constructor-caching* t)
+
+                                                             ; If this is NIL, then the whole
+                                                             ; mechanism for caching dfun
+                                                             ; constructors is turned off.  The only
+                                                             ; time that makes sense is when
+                                                             ; debugging LAP code. 
+
+
+(defun show-dfun-constructors nil (format t "~&DFUN constructor caching is ~A." (if 
+                                                                    *enable-dfun-constructor-caching*
+                                                                                    "enabled"
+                                                                                    "disabled"))
+       (dolist (generator-entry *dfun-constructors*)
+           (dolist (args-entry (cdr generator-entry))
+               (format t "~&~S ~S" (cons (car generator-entry)
+                                         (caar args-entry))
+                      (caddr args-entry)))))
+
+(defun get-dfun-constructor (generator &rest args)
+       (let* ((generator-entry (assq generator *dfun-constructors*))
+              (args-entry (assoc args (cdr generator-entry)
+                                 :test
+                                 #'equal)))
+             (if (null *enable-dfun-constructor-caching*)
+                 (apply (symbol-function generator)
+                        args)
+                 (or (cadr args-entry)
+                     (let ((new (apply (symbol-function generator)
+                                       args)))
+                          (if generator-entry
+                              (push (list (copy-list args)
+                                          new nil)
+                                    (cdr generator-entry))
+                              (push (list generator (list (copy-list args)
+                                                          new nil))
+                                    *dfun-constructors*))
+                          new)))))
+
+(defun load-precompiled-dfun-constructor (generator args system constructor)
+       (let* ((generator-entry (assq generator *dfun-constructors*))
+              (args-entry (assoc args (cdr generator-entry)
+                                 :test
+                                 #'equal)))
+             (unless args-entry
+                 (if generator-entry
+                     (push (list args constructor system)
+                           (cdr generator-entry))
+                     (push (list generator (list args constructor system))
+                           *dfun-constructors*)))))
+
+(defmacro
+ precompile-dfun-constructors
+ (&optional system)
+ (let
+  ((*precompiling-lap* t))
+  `(progn
+    ,@(gathering1 (collecting)
+             (dolist (generator-entry *dfun-constructors*)
+                 (dolist (args-entry (cdr generator-entry))
+                     (when (or (null (caddr args-entry))
+                               (eq (caddr args-entry)
+                                   system))
+                         (multiple-value-bind (closure-variables arguments iregs vregs tregs lap)
+                             (apply (symbol-function (car generator-entry))
+                                    (car args-entry))
+                           (gather1 (make-top-level-form `(precompile-dfun-constructor
+                                                           ,(car generator-entry))
+                                           '(load)
+                                           `(load-precompiled-dfun-constructor
+                                             ',(car generator-entry)
+                                             ',(car args-entry)
+                                             ',system
+                                             (precompile-lap-closure-generator ,closure-variables
+                                                    ,arguments
+                                                    ,iregs
+                                                    ,vregs
+                                                    ,tregs
+                                                    ,lap))))))))))))
+
+(defun make-initial-dfun (generic-function)
+       #'(lambda (&rest args)
+                (initial-dfun args generic-function)))
+
+
+;;; When all the methods of a generic function are automatically generated reader or writer methods
+;;; a number of special optimizations are possible. These are important because of the large number
+;;; of generic functions of this type. There are a number of cases: ONE-CLASS-ACCESSOR In this case,
+;;; the accessor generic function has only been called with one class of argument.  There is no
+;;; cache vector, the wrapper of the one class, and the slot index are stored directly as closure
+;;; variables of the discriminating function.  This case can convert to either of the next kind.
+;;; TWO-CLASS-ACCESSOR Like above, but two classes.  This is common enough to do specially. There is
+;;; no cache vector.  The two classes are stored a separate closure variables. ONE-INDEX-ACCESSOR In
+;;; this case, the accessor generic function has seen more than one class of argument, but the index
+;;; of the slot is the same for all the classes that have been seen.  A cache vector is used to
+;;; store the wrappers that have been seen, the slot index is stored directly as a closure variable
+;;; of the discriminating function.  This case can convert to the next kind. N-N-ACCESSOR This is
+;;; the most general case.  In this case, the accessor generic function has seen more than one class
+;;; of argument and more than one slot index.  A cache vector stores the wrappers and corresponding
+;;; slot indexes.  Because each cache line is more than one element long, a cache lock count is
+;;; used. ONE-CLASS-ACCESSOR 
+
+
+(defun update-to-one-class-readers-dfun (generic-function wrapper index)
+       (let ((constructor (get-dfun-constructor 'emit-one-class-reader (consp index))))
+            (notice-dfun-state generic-function `(one-class readers ,(consp index)))
+                                                             ; ***
+            (update-dfun generic-function (funcall constructor wrapper index
+                                                 #'(lambda (arg)
+                                                          (declare (clos-fast-call))
+                                                          (one-class-readers-miss arg 
+                                                                 generic-function index wrapper))))))
+
+(defun update-to-one-class-writers-dfun (generic-function wrapper index)
+       (let ((constructor (get-dfun-constructor 'emit-one-class-writer (consp index))))
+            (notice-dfun-state generic-function `(one-class writers ,(consp index)))
+                                                             ; ***
+            (update-dfun generic-function (funcall constructor wrapper index
+                                                 #'(lambda (new-value arg)
+                                                          (declare (clos-fast-call))
+                                                          (one-class-writers-miss new-value arg 
+                                                                 generic-function index wrapper))))))
+
+(defun one-class-readers-miss (arg generic-function index wrapper)
+       (accessor-miss generic-function 'one-class 'reader nil arg index wrapper nil nil nil))
+
+(defun one-class-writers-miss (new arg generic-function index wrapper)
+       (accessor-miss generic-function 'one-class 'writer new arg index wrapper nil nil nil))
+
+
+;;; TWO-CLASS-ACCESSOR 
+
+
+(defun update-to-two-class-readers-dfun (generic-function wrapper-0 wrapper-1 index)
+       (let ((constructor (get-dfun-constructor 'emit-two-class-reader (consp index))))
+            (notice-dfun-state generic-function `(two-class readers ,(consp index)))
+                                                             ; ***
+            (update-dfun generic-function (funcall constructor wrapper-0 wrapper-1 index
+                                                 #'(lambda (arg)
+                                                          (declare (clos-fast-call))
+                                                          (two-class-readers-miss arg 
+                                                                 generic-function index wrapper-0 
+                                                                 wrapper-1))))))
+
+(defun update-to-two-class-writers-dfun (generic-function wrapper-0 wrapper-1 index)
+       (let ((constructor (get-dfun-constructor 'emit-two-class-writer (consp index))))
+            (notice-dfun-state generic-function `(two-class writers ,(consp index)))
+                                                             ; ***
+            (update-dfun generic-function (funcall constructor wrapper-0 wrapper-1 index
+                                                 #'(lambda (new-value arg)
+                                                          (declare (clos-fast-call))
+                                                          (two-class-writers-miss new-value arg 
+                                                                 generic-function index wrapper-0 
+                                                                 wrapper-1))))))
+
+(defun two-class-readers-miss (arg generic-function index w0 w1)
+       (accessor-miss generic-function 'two-class 'reader nil arg index w0 w1 nil nil))
+
+(defun two-class-writers-miss (new arg generic-function index w0 w1)
+       (accessor-miss generic-function 'two-class 'writer new arg index w0 w1 nil nil))
+
+
+;;; std accessors same index dfun 
+
+
+(defun update-to-one-index-readers-dfun (generic-function index &optional field cache)
+       (unless field
+           (setq field (wrapper-field 'number)))
+       (let ((constructor (get-dfun-constructor 'emit-one-index-readers (consp index))))
+            (multiple-value-bind (mask size)
+                (compute-cache-parameters 1 nil (or cache 4))
+              (unless cache
+                  (setq cache (get-cache size)))
+              (notice-dfun-state generic-function `(one-index readers ,(consp index)))
+                                                             ; ***
+              (update-dfun generic-function (funcall constructor field cache mask size index
+                                                   #'(lambda (arg)
+                                                            (declare (clos-fast-call))
+                                                            (one-index-readers-miss arg 
+                                                                   generic-function index field cache
+                                                                   )))
+                     cache))))
+
+(defun update-to-one-index-writers-dfun (generic-function index &optional field cache)
+       (unless field
+           (setq field (wrapper-field 'number)))
+       (let ((constructor (get-dfun-constructor 'emit-one-index-writers (consp index))))
+            (multiple-value-bind (mask size)
+                (compute-cache-parameters 1 nil (or cache 4))
+              (unless cache
+                  (setq cache (get-cache size)))
+              (notice-dfun-state generic-function `(one-index writers ,(consp index)))
+                                                             ; ***
+              (update-dfun generic-function (funcall constructor field cache mask size index
+                                                   #'(lambda (new-value arg)
+                                                            (declare (clos-fast-call))
+                                                            (one-index-writers-miss new-value arg 
+                                                                   generic-function index field cache
+                                                                   )))
+                     cache))))
+
+(defun one-index-readers-miss (arg gf index field cache)
+       (accessor-miss gf 'one-index 'reader nil arg index nil nil field cache))
+
+(defun one-index-writers-miss (new arg gf index field cache)
+       (accessor-miss gf 'one-index 'writer new arg index nil nil field cache))
+
+(defun one-index-limit-fn (nlines)
+       (default-limit-fn nlines))
+
+(defun update-to-n-n-readers-dfun (generic-function &optional field cache)
+       (unless field
+           (setq field (wrapper-field 'number)))
+       (let ((constructor (get-dfun-constructor 'emit-n-n-readers)))
+            (multiple-value-bind (mask size)
+                (compute-cache-parameters 1 t (or cache 2))
+              (unless cache
+                  (setq cache (get-cache size)))
+              (notice-dfun-state generic-function `(n-n readers))
+                                                             ; ***
+              (update-dfun generic-function (funcall constructor field cache mask size
+                                                   #'(lambda (arg)
+                                                            (declare (clos-fast-call))
+                                                            (n-n-readers-miss arg generic-function 
+                                                                   field cache)))
+                     cache))))
+
+(defun update-to-n-n-writers-dfun (generic-function &optional field cache)
+       (unless field
+           (setq field (wrapper-field 'number)))
+       (let ((constructor (get-dfun-constructor 'emit-n-n-writers)))
+            (multiple-value-bind (mask size)
+                (compute-cache-parameters 1 t (or cache 2))
+              (unless cache
+                  (setq cache (get-cache size)))
+              (notice-dfun-state generic-function `(n-n writers))
+                                                             ; ***
+              (update-dfun generic-function (funcall constructor field cache mask size
+                                                   #'(lambda (new arg)
+                                                            (declare (clos-fast-call))
+                                                            (n-n-writers-miss new arg 
+                                                                   generic-function field cache)))
+                     cache))))
+
+(defun n-n-readers-miss (arg gf field cache)
+       (accessor-miss gf 'n-n 'reader nil arg nil nil nil field cache))
+
+(defun n-n-writers-miss (new arg gf field cache)
+       (accessor-miss gf 'n-n 'writer new arg nil nil nil field cache))
+
+(defun n-n-accessors-limit-fn (nlines)
+       (default-limit-fn nlines))
+
+
+;;; 
+
+
+(defun update-to-checking-dfun (generic-function function &optional field cache)
+       (unless field
+           (setq field (wrapper-field 'number)))
+       (let* ((arg-info (gf-arg-info generic-function))
+              (metatypes (arg-info-metatypes arg-info))
+              (applyp (arg-info-applyp arg-info))
+              (nkeys (arg-info-nkeys arg-info)))
+             (if (every #'(lambda (mt)
+                                 (eq mt 't))
+                        metatypes)
+                 (progn (notice-dfun-state generic-function `(default-method-only))
+                                                             ; ***
+                        (update-dfun generic-function function))
+                 (multiple-value-bind (mask size)
+                     (compute-cache-parameters nkeys nil (or cache 2))
+                   (unless cache
+                       (setq cache (get-cache size)))
+                   (let ((constructor (get-dfun-constructor 'emit-checking metatypes applyp)))
+                        (notice-dfun-state generic-function '(checking)
+                               nkeys nil)
+                                                             ; ****
+                        (update-dfun generic-function
+                               (funcall constructor field cache mask size function
+                                      #'(lambda (&rest args)
+                                               (declare (clos-fast-call))
+                                               (checking-miss generic-function args function field 
+                                                      cache)))
+                               cache))))))
+
+(defun checking-limit-fn (nlines)
+       (default-limit-fn nlines))
+
+
+;;; 
+
+
+(defun update-to-caching-dfun (generic-function &optional field cache)
+       (unless field
+           (setq field (wrapper-field 'number)))
+       (let* ((arg-info (gf-arg-info generic-function))
+              (metatypes (arg-info-metatypes arg-info))
+              (applyp (arg-info-applyp arg-info))
+              (nkeys (arg-info-nkeys arg-info))
+              (constructor (get-dfun-constructor 'emit-caching metatypes applyp)))
+             (multiple-value-bind (mask size)
+                 (compute-cache-parameters nkeys t (or cache 2))
+               (unless cache
+                   (setq cache (get-cache size)))
+               (notice-dfun-state generic-function '(caching)
+                      nkeys t)
+                                                             ; ****
+               (update-dfun generic-function (funcall constructor field cache mask size
+                                                    #'(lambda (&rest args)
+                                                             (declare (clos-fast-call))
+                                                             (caching-miss generic-function args 
+                                                                    field cache)))
+                      cache))))
+
+(defun caching-limit-fn (nlines)
+       (default-limit-fn nlines))
+
+
+;;; The dynamically adaptive method lookup algorithm is implemented is implemented as a kind of
+;;; state machine.  The kinds of discriminating function is the state, the various kinds of reasons
+;;; for a cache miss are the state transitions. The code which implements the transitions is all in
+;;; the miss handlers for each kind of dfun.  Those appear here. Note that within the states that
+;;; cache, there are dfun updates which simply select a new cache or cache field.  Those are not
+;;; considered as state transitions. 
+
+
+(defun initial-dfun (args generic-function)
+       (protect-cache-miss-code generic-function args
+              (multiple-value-bind (wrappers invalidp nfunction applicable)
+                  (cache-miss-values generic-function args)
+                (multiple-value-bind (ntype nindex)
+                    (accessor-miss-values generic-function applicable args)
+                  (cond ((null applicable)
+                         (apply #'no-applicable-method generic-function args))
+                        (invalidp (apply nfunction args))
+                        ((and ntype nindex)
+                         (ecase ntype
+                             (reader (update-to-one-class-readers-dfun generic-function wrappers 
+                                            nindex))
+                             (writer (update-to-one-class-writers-dfun generic-function wrappers 
+                                            nindex)))
+                         (apply nfunction args))
+                        (ntype (apply nfunction args))
+                        (t (update-to-checking-dfun generic-function nfunction)
+                           (apply nfunction args)))))))
+
+(defun
+ accessor-miss
+ (gf ostate otype new object oindex ow0 ow1 field cache)
+ (declare (ignore ow1))
+ (let ((args (ecase otype                                    ; The congruence rules assure
+                 (reader (list object))                      ; us that this is safe despite
+                 (writer (list new object)))))
+                                                             ; not knowing the new type yet.
+      (protect-cache-miss-code
+       gf args
+       (multiple-value-bind (wrappers invalidp nfunction applicable)
+           (cache-miss-values gf args)
+         (multiple-value-bind (ntype nindex)
+             (accessor-miss-values gf applicable args)
+           
+           ;; The following lexical functions change the state of the dfun to that which is their
+           ;; name.  They accept arguments which are the parameters of the new state, and get other
+           ;; information from the lexical variables bound above. 
+           (flet ((two-class (index w0 w1)
+                         (when (zerop (random 2))
+                               (psetf w0 w1 w1 w0))
+                         (ecase ntype
+                             (reader (update-to-two-class-readers-dfun gf w0 w1 index))
+                             (writer (update-to-two-class-writers-dfun gf w0 w1 index))))
+                  (one-index (index &optional field cache)
+                         (ecase ntype
+                             (reader (update-to-one-index-readers-dfun gf index field cache))
+                             (writer (update-to-one-index-writers-dfun gf index field cache))))
+                  (n-n (&optional field cache)
+                       (ecase ntype
+                           (reader (update-to-n-n-readers-dfun gf field cache))
+                           (writer (update-to-n-n-writers-dfun gf field cache))))
+                  (checking nil (update-to-checking-dfun gf nfunction))
+                  
+                  ;; 
+                  (do-fill (valuep limit-fn update-fn)
+                         (multiple-value-bind (nfield ncache)
+                             (fill-cache field cache 1 valuep limit-fn wrappers nindex)
+                           (unless (and (= nfield field)
+                                        (eq ncache cache))
+                                  (funcall update-fn nfield ncache)))))
+                 (cond ((null nfunction)
+                        (apply #'no-applicable-method gf args))
+                       ((null ntype)
+                        (checking)
+                        (apply nfunction args))
+                       ((or invalidp (null nindex))
+                        (apply nfunction args))
+                       ((not (or (std-instance-p object)
+                                 (fsc-instance-p object)))
+                        (checking)
+                        (apply nfunction args))
+                       ((neq ntype otype)
+                        (checking)
+                        (apply nfunction args))
+                       (t (ecase ostate
+                              (one-class (if (eql nindex oindex)
+                                             (two-class nindex ow0 wrappers)
+                                             (n-n)))
+                              (two-class (if (eql nindex oindex)
+                                             (one-index nindex)
+                                             (n-n)))
+                              (one-index (if (eql nindex oindex)
+                                             (do-fill nil #'one-index-limit-fn
+                                                    #'(lambda (nfield ncache)
+                                                             (one-index nindex nfield ncache)))
+                                             (n-n)))
+                              (n-n (unless (consp nindex)
+                                       (do-fill t #'n-n-accessors-limit-fn #'n-n))))
+                          (apply nfunction args)))))))))
+
+(defun checking-miss (generic-function args ofunction field cache)
+       (protect-cache-miss-code generic-function args
+              (let* ((arg-info (gf-arg-info generic-function))
+                     (nkeys (arg-info-nkeys arg-info)))
+                    (multiple-value-bind (wrappers invalidp nfunction)
+                        (cache-miss-values generic-function args)
+                      (cond (invalidp (apply nfunction args))
+                            ((null nfunction)
+                             (apply #'no-applicable-method generic-function args))
+                            ((eq ofunction nfunction)
+                             (multiple-value-bind (nfield ncache)
+                                 (fill-cache field cache nkeys nil #'checking-limit-fn wrappers nil)
+                               (unless (and (= nfield field)
+                                            (eq ncache cache))
+                                      (update-to-checking-dfun generic-function nfunction nfield 
+                                             ncache)))
+                             (apply nfunction args))
+                            (t (update-to-caching-dfun generic-function)
+                               (apply nfunction args)))))))
+
+(defun caching-miss (generic-function args ofield ocache)
+       (protect-cache-miss-code generic-function args
+              (let* ((arg-info (gf-arg-info generic-function))
+                     (nkeys (arg-info-nkeys arg-info)))
+                    (multiple-value-bind (wrappers invalidp function)
+                        (cache-miss-values generic-function args)
+                      (cond (invalidp (apply function args))
+                            ((null function)
+                             (apply #'no-applicable-method generic-function args))
+                            (t (multiple-value-bind (nfield ncache)
+                                   (fill-cache ofield ocache nkeys t #'caching-limit-fn wrappers 
+                                          function)
+                                 (unless (and (= nfield ofield)
+                                              (eq ncache ocache))
+                                        (update-to-caching-dfun generic-function nfield ncache)))
+                               (apply function args)))))))
+
+
+;;; Some useful support functions which are shared by the implementations of the different kinds of
+;;; dfuns. Given a generic function and a set of arguments to that generic function, returns a mess
+;;; of values. <wrappers>   Is a single wrapper if the generic function has only one key, that is
+;;; arg-info-nkeys of the arg-info is 1. Otherwise a list of the wrappers of the specialized
+;;; arguments to the generic function. Note that all these wrappers are valid.  This function does
+;;; invalid wrapper traps when it finds an invalid wrapper and then returns the new, valid wrapper.
+;;; <invalidp>   True if any of the specialized arguments had an invalid wrapper, false otherwise.
+;;; <function>   The compiled effective method function for this set of arguments.  Gotten from
+;;; get-secondary-dispatch-function so effective-method-function caching is in effect, and that is
+;;; important since it is what keeps us in checking dfun state when possible. <type>       READER or
+;;; WRITER when the only method that would be run is a standard reader or writer method.  To be
+;;; specific, the value is READER when the method combination is eq to
+;;; *standard-method-combination*; there are no applicable :before, :after or :around methods; and
+;;; the most specific primary method is a standard reader method. <index>      If <type> is READER
+;;; or WRITER, and the slot accessed is an :instance slot, this is the index number of that slot in
+;;; the object argument. <applicable> Sorted list of applicable methods. 
+
+
+(defun cache-miss-values (generic-function args)
+       (declare (values wrappers invalidp function applicable))
+       (multiple-value-bind (function appl arg-info)
+           (get-secondary-dispatch-function generic-function args)
+         (multiple-value-bind (wrappers invalidp)
+             (get-wrappers generic-function args arg-info)
+           (values wrappers invalidp (cache-miss-values-function generic-function function)
+                  appl))))
+
+(defun get-wrappers (generic-function args &optional arg-info)
+       (let* ((invalidp nil)
+              (wrappers nil)
+              (arg-info (or arg-info (gf-arg-info generic-function)))
+              (metatypes (arg-info-metatypes arg-info))
+              (nkeys (arg-info-nkeys arg-info)))
+             (flet ((get-valid-wrapper (x)
+                           (let ((wrapper (wrapper-of x)))
+                                (cond ((invalid-wrapper-p wrapper)
+                                       (setq invalidp t)
+                                       (check-wrapper-validity x))
+                                      (t wrapper)))))
+                   (setq wrappers (block collect-wrappers
+                                      (gathering1 (collecting)
+                                             (iterate ((arg (list-elements args))
+                                                       (metatype (list-elements metatypes)))
+                                                    (when (neq metatype 't)
+                                                        (if (= nkeys 1)
+                                                            (return-from collect-wrappers
+                                                                   (get-valid-wrapper arg))
+                                                            (gather1 (get-valid-wrapper arg))))))))
+                   (values wrappers invalidp))))
+
+(defun cache-miss-values-function (generic-function function)
+       (if (eq *generate-random-code-segments* generic-function)
+           (progn (setq *generate-random-code-segments* nil)
+                  #'(lambda (&rest args)
+                           (declare (ignore args))
+                           nil))
+           function))
+
+(defun generate-random-code-segments (generic-function)
+       (dolist (arglist (generate-arglists generic-function))
+           (let ((*generate-random-code-segments* generic-function))
+                (apply generic-function arglist))))
+
+(defun generate-arglists (generic-function)
+       
+       ;; Generate arglists using class-prototypes and eql-specializer-objects to get all the
+       ;; "different" values that could be returned by get-secondary-dispatch-function for this
+       ;; generic-function. 
+       (let ((methods (generic-function-methods generic-function)))
+            (mapcar #'(lambda (class-list)
+                             (mapcar #'(lambda (specializer)
+                                              (if (eql-specializer-p specializer)
+                                                  (eql-specializer-object specializer)
+                                                  (class-prototype specializer)))
+                                    (method-specializers (find class-list methods :test
+                                                               #'(lambda (class-list method)
+                                                                        (every 
+                                                                               #'
+                                                                 specializer-applicable-using-class-p
+                                                                               (method-specializers
+                                                                                method)
+                                                                               class-list))))))
+                   (generate-arglist-classes generic-function))))
+
+(defun generate-arglist-classes (generic-function)
+       (let ((methods (generic-function-methods generic-function)))
+            (declare (ignore methods))
+            
+            ;; Finish this sometime.
+            nil))
+
+(defun accessor-miss-values (generic-function applicable args)
+       (declare (values type index))
+       (let ((type (and (eq (generic-function-method-combination generic-function)
+                            *standard-method-combination*)
+                        (every #'(lambda (m)
+                                        (null (method-qualifiers m)))
+                               applicable)
+                        (let ((method (car applicable)))
+                             (cond ((standard-reader-method-p method)
+                                    (and (optimize-slot-value-by-class-p (class-of (car args))
+                                                (accessor-method-slot-name method)
+                                                nil)
+                                         'reader))
+                                   ((standard-writer-method-p method)
+                                    (and (optimize-slot-value-by-class-p (class-of (cadr args))
+                                                (accessor-method-slot-name method)
+                                                t)
+                                         'writer))
+                                   (t nil))))))
+            (values type (and type (let ((wrapper (wrapper-of (case type
+                                                                  (reader (car args))
+                                                                  (writer (cadr args)))))
+                                         (slot-name (accessor-method-slot-name (car applicable))))
+                                        (or (instance-slot-index wrapper slot-name)
+                                            (assq slot-name (wrapper-class-slots wrapper))))))))
diff --git a/clos/3.5/dlap.dfasl b/clos/3.5/dlap.dfasl
new file mode 100644
index 00000000..cc04e654
Binary files /dev/null and b/clos/3.5/dlap.dfasl differ
diff --git a/clos/3.5/dlap.lisp b/clos/3.5/dlap.lisp
new file mode 100644
index 00000000..e50f0bb8
--- /dev/null
+++ b/clos/3.5/dlap.lisp
@@ -0,0 +1,492 @@
+;;;-*- Package: CLOS; Syntax: Common-Lisp; Base: 10 -*-
+
+;;; Copyright (c) 1991 by Venue
+
+(in-package "CLOS")
+
+;;;
+
+(defun emit-one-class-reader (class-slot-p)
+       (emit-reader/writer :reader 1 class-slot-p))
+
+(defun emit-one-class-writer (class-slot-p)
+       (emit-reader/writer :writer 1 class-slot-p))
+
+(defun emit-two-class-reader (class-slot-p)
+       (emit-reader/writer :reader 2 class-slot-p))
+
+(defun emit-two-class-writer (class-slot-p)
+       (emit-reader/writer :writer 2 class-slot-p))
+
+(defun emit-reader/writer (reader/writer 1-or-2-class class-slot-p)
+       (let ((instance nil)
+             (arglist nil)
+             (closure-variables nil)
+             (field (wrapper-field 'number)))
+                                                             ; we need some field to do the fast
+                                                             ; obsolete check 
+            (ecase reader/writer
+                (:reader (setq instance (dfun-arg-symbol 0)
+                               arglist
+                               (list instance)))
+                (:writer (setq instance (dfun-arg-symbol 1)
+                               arglist
+                               (list (dfun-arg-symbol 0)
+                                     instance))))
+            (ecase 1-or-2-class
+                (1 (setq closure-variables '(wrapper-0 index miss-fn)))
+                (2 (setq closure-variables '(wrapper-0 wrapper-1 index miss-fn))))
+            (generating-lap
+             closure-variables arglist
+             (with-lap-registers ((inst t)
+                                                             ; reg for the instance
+                                  (wrapper vector)
+                                                             ; reg for the wrapper
+                                  (cache-no index))
+                                                             ; reg for the cache no
+                    (let ((index cache-no)
+                                                             ; This register is used for different
+                                                             ; values at different times. 
+                          (slots (and (null class-slot-p)
+                                      (allocate-register 'vector)))
+                          (csv (and class-slot-p (allocate-register t))))
+                         (prog1 (flatten-lap (opcode :move (operand :arg instance)
+                                                    inst)
+                                                             ; get the instance
+                                       (opcode :std-instance-p inst 'std-instance)
+                                                             ; if not either std-inst
+                                       (opcode :fsc-instance-p inst 'fsc-instance)
+                                                             ; or fsc-instance then
+                                       (opcode :go 'trap)
+                                                             ; we lose
+                                       (opcode :label 'fsc-instance)
+                                       (opcode :move (operand :fsc-wrapper inst)
+                                              wrapper)
+                                       (and slots (opcode :move (operand :fsc-slots inst)
+                                                         slots))
+                                       (opcode :go 'have-wrapper)
+                                       (opcode :label 'std-instance)
+                                       (opcode :move (operand :std-wrapper inst)
+                                              wrapper)
+                                       (and slots (opcode :move (operand :std-slots inst)
+                                                         slots))
+                                       (opcode :label 'have-wrapper)
+                                       (opcode :move (operand :cref wrapper field)
+                                              cache-no)
+                                       (opcode :izerop cache-no 'trap)
+                                                             ; obsolete wrapper?
+                                       (ecase 1-or-2-class
+                                           (1 (emit-check-1-class-wrapper wrapper 'wrapper-0
+                                                     'trap))
+                                           (2 (emit-check-2-class-wrapper wrapper 'wrapper-0
+                                                     'wrapper-1
+                                                     'trap)))
+                                       (if class-slot-p
+                                           (flatten-lap (opcode :move (operand :cvar 'index)
+                                                               csv)
+                                                  (ecase reader/writer
+                                                      (:reader (emit-get-class-slot csv 'trap inst))
+                                                      (:writer (emit-set-class-slot csv (car arglist)
+                                                                      inst))))
+                                           (flatten-lap (opcode :move (operand :cvar 'index)
+                                                               index)
+                                                  (ecase reader/writer
+                                                      (:reader (emit-get-slot slots index
+                                                                      'trap inst))
+                                                      (:writer (emit-set-slot slots index
+                                                                      (car arglist)
+                                                                      inst)))))
+                                       (opcode :label 'trap)
+                                       (emit-miss 'miss-fn))
+                             (when slots (deallocate-register slots))
+                             (when csv (deallocate-register csv))))))))
+
+(defun emit-one-index-readers (class-slot-p)
+       (let ((arglist (list (dfun-arg-symbol 0))))
+            (generating-lap '(field cache mask size index miss-fn)
+                   arglist
+                   (with-lap-registers ((slots vector))
+                          (emit-dlap arglist '(standard-instance)
+                                 'trap
+                                 (with-lap-registers ((index index))
+                                        (flatten-lap (opcode :move (operand :cvar 'index)
+                                                            index)
+                                               (if class-slot-p
+                                                   (emit-get-class-slot index 'trap slots)
+                                                   (emit-get-slot slots index 'trap))))
+                                 (flatten-lap (opcode :label 'trap)
+                                        (emit-miss 'miss-fn))
+                                 nil
+                                 (and (null class-slot-p)
+                                      (list slots)))))))
+
+(defun emit-one-index-writers (class-slot-p)
+       (let ((arglist (list (dfun-arg-symbol 0)
+                            (dfun-arg-symbol 1))))
+            (generating-lap '(field cache mask size index miss-fn)
+                   arglist
+                   (with-lap-registers ((slots vector))
+                          (emit-dlap arglist '(t standard-instance)
+                                 'trap
+                                 (with-lap-registers ((index index))
+                                        (flatten-lap (opcode :move (operand :cvar 'index)
+                                                            index)
+                                               (if class-slot-p
+                                                   (emit-set-class-slot index (dfun-arg-symbol 0)
+                                                          slots)
+                                                   (emit-set-slot slots index (dfun-arg-symbol 0)))))
+                                 (flatten-lap (opcode :label 'trap)
+                                        (emit-miss 'miss-fn))
+                                 nil
+                                 (and (null class-slot-p)
+                                      (list nil slots)))))))
+
+(defun emit-n-n-readers nil (let ((arglist (list (dfun-arg-symbol 0))))
+                                 (generating-lap '(field cache mask size miss-fn)
+                                        arglist
+                                        (with-lap-registers ((slots vector)
+                                                             (index index))
+                                               (emit-dlap arglist '(standard-instance)
+                                                      'trap
+                                                      (emit-get-slot slots index 'trap)
+                                                      (flatten-lap (opcode :label 'trap)
+                                                             (emit-miss 'miss-fn))
+                                                      index
+                                                      (list slots))))))
+
+(defun emit-n-n-writers nil (let ((arglist (list (dfun-arg-symbol 0)
+                                                 (dfun-arg-symbol 1))))
+                                 (generating-lap '(field cache mask size miss-fn)
+                                        arglist
+                                        (with-lap-registers ((slots vector)
+                                                             (index index))
+                                               (flatten-lap (emit-dlap arglist '(t standard-instance)
+                                                                   'trap
+                                                                   (emit-set-slot slots index
+                                                                          (dfun-arg-symbol 0))
+                                                                   (flatten-lap (opcode :label
+                                                                                       'trap)
+                                                                          (emit-miss 'miss-fn))
+                                                                   index
+                                                                   (list nil slots)))))))
+
+(defun emit-checking (metatypes applyp)
+       (let ((dlap-lambda-list (make-dlap-lambda-list metatypes applyp)))
+            (generating-lap '(field cache mask size function miss-fn)
+                   dlap-lambda-list
+                   (emit-dlap (remove '&rest dlap-lambda-list)
+                          metatypes
+                          'trap
+                          (with-lap-registers (#'t)
+                                 (flatten-lap (opcode :move (operand :cvar 'function)
+                                                     function)
+                                        (opcode :jmp function)))
+                          (with-lap-registers ((miss-function t))
+                                 (flatten-lap (opcode :label 'trap)
+                                        (opcode :move (operand :cvar 'miss-fn)
+                                               miss-function)
+                                        (opcode :jmp miss-function)))
+                          nil))))
+
+(defun emit-caching (metatypes applyp)
+       (let ((dlap-lambda-list (make-dlap-lambda-list metatypes applyp)))
+            (generating-lap '(field cache mask size miss-fn)
+                   dlap-lambda-list
+                   (with-lap-registers (#'t)
+                          (emit-dlap (remove '&rest dlap-lambda-list)
+                                 metatypes
+                                 'trap
+                                 (flatten-lap (opcode :jmp function))
+                                 (with-lap-registers ((miss-function t))
+                                        (flatten-lap (opcode :label 'trap)
+                                               (opcode :move (operand :cvar 'miss-fn)
+                                                      miss-function)
+                                               (opcode :jmp miss-function)))
+                                 function)))))
+
+(defun emit-check-1-class-wrapper (wrapper cwrapper-0 miss-label)
+       (with-lap-registers ((cwrapper vector))
+              (flatten-lap (opcode :move (operand :cvar cwrapper-0)
+                                  cwrapper)
+                     (opcode :neq wrapper cwrapper miss-label))))
+
+                                                             ; wrappers not eq, trap
+
+
+(defun emit-check-2-class-wrapper (wrapper cwrapper-0 cwrapper-1 miss-label)
+       (with-lap-registers ((cwrapper vector))
+              (flatten-lap (opcode :move (operand :cvar cwrapper-0)
+                                  cwrapper)
+                                                             ; This is an OR.  Isn't
+                     (opcode :eq wrapper cwrapper 'hit-internal)
+                                                             ; assembly code fun
+                     (opcode :move (operand :cvar cwrapper-1)
+                            cwrapper)
+                                                             ; 
+                     (opcode :neq wrapper cwrapper miss-label)
+                                                             ; 
+                     (opcode :label 'hit-internal))))
+
+(defun emit-get-slot (slots index trap-label &optional temp)
+       (let ((slot-unbound (operand :constant *slot-unbound*)))
+            (with-lap-registers ((val t :reuse temp))
+                   (flatten-lap (opcode :move (operand :iref slots index)
+                                       val)
+                                                             ; get slot value
+                          (opcode :eq val slot-unbound trap-label)
+                                                             ; is the slot unbound?
+                          (opcode :return val)))))
+
+                                                             ; return the slot value
+
+
+(defun emit-set-slot (slots index new-value-arg &optional temp)
+       (with-lap-registers ((new-val t :reuse temp))
+              (flatten-lap (opcode :move (operand :arg new-value-arg)
+                                  new-val)
+                                                             ; get new value into a reg
+                     (opcode :move new-val (operand :iref slots index))
+                                                             ; set slot value
+                     (opcode :return new-val))))
+
+(defun emit-get-class-slot (index trap-label &optional temp)
+       (let ((slot-unbound (operand :constant *slot-unbound*)))
+            (with-lap-registers ((val t :reuse temp))
+                   (flatten-lap (opcode :move (operand :cdr index)
+                                       val)
+                          (opcode :eq val slot-unbound trap-label)
+                          (opcode :return val)))))
+
+(defun emit-set-class-slot (index new-value-arg &optional temp)
+       (with-lap-registers ((new-val t :reuse temp))
+              (flatten-lap (opcode :move (operand :arg new-value-arg)
+                                  new-val)
+                     (opcode :move new-val (operand :cdr index))
+                     (opcode :return new-val))))
+
+(defun emit-miss (miss-fn)
+       (with-lap-registers ((miss-fn-reg t))
+              (flatten-lap (opcode :move (operand :cvar miss-fn)
+                                  miss-fn-reg)
+                                                             ; get the miss function
+                     (opcode :jmp miss-fn-reg))))
+
+                                                             ; and call it
+
+
+(defun dlap-wrappers (metatypes)
+       (mapcar #'(lambda (x)
+                        (and (neq x 't)
+                             (allocate-register 'vector)))
+              metatypes))
+
+(defun dlap-wrapper-moves (wrappers args metatypes miss-label slot-regs)
+       (gathering1 (collecting)
+              (iterate ((mt (list-elements metatypes))
+                        (arg (list-elements args))
+                        (wrapper (list-elements wrappers))
+                        (i (interval :from 0)))
+                     (when wrapper
+                         (gather1 (emit-fetch-wrapper mt arg wrapper miss-label (nth i slot-regs)))))
+              ))
+
+(defun emit-dlap (args metatypes miss-label hit miss value-reg &optional slot-regs)
+       (let* ((wrappers (dlap-wrappers metatypes))
+              (nwrappers (remove nil wrappers))
+              (wrapper-moves (dlap-wrapper-moves wrappers args metatypes miss-label slot-regs)))
+             (prog1 (emit-dlap-internal nwrappers wrapper-moves hit miss miss-label value-reg)
+                 (mapc #'deallocate-register nwrappers))))
+
+(defun emit-dlap-internal (wrapper-regs wrapper-moves hit miss miss-label value-reg)
+       (cond ((cdr wrapper-regs)
+              (emit-greater-than-1-dlap wrapper-regs wrapper-moves hit miss miss-label value-reg))
+             ((null value-reg)
+              (emit-1-nil-dlap (car wrapper-regs)
+                     (car wrapper-moves)
+                     hit miss miss-label))
+             (t (emit-1-t-dlap (car wrapper-regs)
+                       (car wrapper-moves)
+                       hit miss miss-label value-reg))))
+
+(defun emit-1-nil-dlap (wrapper wrapper-move hit miss miss-label)
+       (with-lap-registers ((location index)
+                            (primary index)
+                            (cache vector))
+              (flatten-lap wrapper-move (opcode :move (operand :cvar 'cache)
+                                               cache)
+                     (with-lap-registers ((wrapper-cache-no index))
+                            (flatten-lap (emit-1-wrapper-compute-primary-cache-location wrapper 
+                                                primary wrapper-cache-no)
+                                   (opcode :move primary location)
+                                   (emit-check-1-wrapper-in-cache cache location wrapper hit)
+                                                             ; inline hit code
+                                   (opcode :izerop wrapper-cache-no miss-label)))
+                     (with-lap-registers ((size index))
+                            (flatten-lap (opcode :move (operand :cvar 'size)
+                                                size)
+                                   (opcode :label 'loop)
+                                   (opcode :move (operand :i1+ location)
+                                          location)
+                                   (opcode :fix= location primary miss-label)
+                                   (opcode :fix= location size 'set-location-to-min)
+                                   (opcode :label 'continue)
+                                   (emit-check-1-wrapper-in-cache cache location wrapper hit)
+                                   (opcode :go 'loop)
+                                   (opcode :label 'set-location-to-min)
+                                   (opcode :izerop primary miss-label)
+                                   (opcode :move (operand :constant (index-value->index 0))
+                                          location)
+                                   (opcode :go 'continue)))
+                     miss)))
+
+
+;;; The function below implements CACHE-LOCK-COUNT as the first entry in a cache (svref cache 0). 
+;;; This should probably be abstracted. 
+
+
+(defun emit-1-t-dlap (wrapper wrapper-move hit miss miss-label value)
+       (with-lap-registers ((location index)
+                            (primary index)
+                            (cache vector)
+                            (initial-lock-count t))
+              (flatten-lap wrapper-move (opcode :move (operand :cvar 'cache)
+                                               cache)
+                     (with-lap-registers ((wrapper-cache-no index))
+                            (flatten-lap (emit-1-wrapper-compute-primary-cache-location wrapper 
+                                                primary wrapper-cache-no)
+                                   (opcode :move primary location)
+                                   (opcode :move (operand :cref cache 0)
+                                          initial-lock-count)
+                                                             ; get lock-count
+                                   (emit-check-cache-entry cache location wrapper 'hit-internal)
+                                   (opcode :izerop wrapper-cache-no miss-label)))
+                                                             ; check for obsolescence
+                     (with-lap-registers ((size index))
+                            (flatten-lap (opcode :move (operand :cvar 'size)
+                                                size)
+                                   (opcode :label 'loop)
+                                   (opcode :move (operand :i1+ location)
+                                          location)
+                                   (opcode :move (operand :i1+ location)
+                                          location)
+                                   (opcode :label 'continue)
+                                   (opcode :fix= location primary miss-label)
+                                   (opcode :fix= location size 'set-location-to-min)
+                                   (emit-check-cache-entry cache location wrapper 'hit-internal)
+                                   (opcode :go 'loop)
+                                   (opcode :label 'set-location-to-min)
+                                   (opcode :izerop primary miss-label)
+                                   (opcode :move (operand :constant (index-value->index 2))
+                                          location)
+                                   (opcode :go 'continue)))
+                     (opcode :label 'hit-internal)
+                     (opcode :move (operand :i1+ location)
+                            location)
+                                                             ; position for getting value
+                     (opcode :move (emit-cache-ref cache location)
+                            value)
+                     (emit-lock-count-test initial-lock-count cache 'hit)
+                     miss
+                     (opcode :label 'hit)
+                     hit)))
+
+(defun emit-greater-than-1-dlap (wrappers wrapper-moves hit miss miss-label value)
+       (let ((cache-line-size (compute-line-size (+ (length wrappers)
+                                                    (if value
+                                                        1
+                                                        0)))))
+            (with-lap-registers ((location index)
+                                 (primary index)
+                                 (cache vector)
+                                 (initial-lock-count t)
+                                 (next-location index)
+                                 (line-size index))
+                                                             ; Line size holds a constant that can
+                                                             ; be folded in if there was a way to
+                                                             ; add a constant to an index register 
+                   (flatten-lap (apply #'flatten-lap wrapper-moves)
+                          (opcode :move (operand :constant cache-line-size)
+                                 line-size)
+                          (opcode :move (operand :cvar 'cache)
+                                 cache)
+                          (emit-n-wrapper-compute-primary-cache-location wrappers primary miss-label)
+                          (opcode :move primary location)
+                          (opcode :move location next-location)
+                          (opcode :move (operand :cref cache 0)
+                                 initial-lock-count)
+                                                             ; get the lock-count
+                          (with-lap-registers ((size index))
+                                 (flatten-lap (opcode :move (operand :cvar 'size)
+                                                     size)
+                                        (opcode :label 'continue)
+                                        (opcode :move (operand :i+ location line-size)
+                                               next-location)
+                                        (emit-check-cache-line cache location wrappers 'hit)
+                                        (emit-adjust-location location next-location primary size
+                                               'continue miss-label)
+                                        (opcode :label 'hit)
+                                        (and value (opcode :move (emit-cache-ref cache location)
+                                                          value))
+                                        (emit-lock-count-test initial-lock-count cache 'hit-internal)
+                                        miss
+                                        (opcode :label 'hit-internal)
+                                        hit))))))
+
+
+;;; Cache related lap code 
+
+
+(defun emit-check-1-wrapper-in-cache (cache location wrapper hit-code)
+       (let ((exit-emit-check-1-wrapper-in-cache (make-symbol "exit-emit-check-1-wrapper-in-cache")))
+            (with-lap-registers ((cwrapper vector))
+                   (flatten-lap (opcode :move (emit-cache-ref cache location)
+                                       cwrapper)
+                          (opcode :neq cwrapper wrapper exit-emit-check-1-wrapper-in-cache)
+                          hit-code
+                          (opcode :label exit-emit-check-1-wrapper-in-cache)))))
+
+(defun emit-check-cache-entry (cache location wrapper hit-label)
+       (with-lap-registers ((cwrapper vector))
+              (flatten-lap (opcode :move (emit-cache-ref cache location)
+                                  cwrapper)
+                     (opcode :eq cwrapper wrapper hit-label))))
+
+(defun emit-check-cache-line (cache location wrappers hit-label)
+       (let ((checks (flatten-lap (gathering1 (flattening-lap)
+                                         (iterate ((wrapper (list-elements wrappers)))
+                                                (with-lap-registers ((cwrapper vector))
+                                                       (gather1 (flatten-lap (opcode :move
+                                                                                    (emit-cache-ref
+                                                                                     cache location)
+                                                                                    cwrapper)
+                                                                       (opcode :neq cwrapper wrapper
+                                                                              
+                                                                              '
+                                                                           exit-emit-check-cache-line
+                                                                              )
+                                                                       (opcode :move (operand :i1+ 
+                                                                                            location)
+                                                                              location)))))))))
+            (flatten-lap checks (opcode :go hit-label)
+                   (opcode :label 'exit-emit-check-cache-line))))
+
+(defun emit-lock-count-test (initial-lock-count cache hit-label)
+       
+       ;; jumps to hit-label if cache-lock-count consistent, otherwise, continues 
+       (with-lap-registers ((new-lock-count t))
+              (flatten-lap (opcode :move (operand :cref cache 0)
+                                  new-lock-count)
+                                                             ; get new cache-lock-count
+                     (opcode :fix= new-lock-count initial-lock-count hit-label))))
+
+(defun emit-adjust-location (location next-location primary size cont-label miss-label)
+       (flatten-lap (opcode :move next-location location)
+              (opcode :fix= location size 'at-end-of-cache)
+              (opcode :fix= location primary miss-label)
+              (opcode :go cont-label)
+              (opcode :label 'at-end-of-cache)
+              (opcode :fix= primary (operand :constant (index-value->index 1))
+                     miss-label)
+              (opcode :move (operand :constant (index-value->index 1))
+                     location)
+              (opcode :go cont-label)))
diff --git a/clos/3.5/env.dfasl b/clos/3.5/env.dfasl
new file mode 100644
index 00000000..a3ec34f9
Binary files /dev/null and b/clos/3.5/env.dfasl differ
diff --git a/clos/3.5/env.lisp b/clos/3.5/env.lisp
new file mode 100644
index 00000000..15bf87f2
--- /dev/null
+++ b/clos/3.5/env.lisp
@@ -0,0 +1,200 @@
+;;;-*-Mode:LISP; Package:(CLOS (LISP WALKER)); Base:10; Syntax:Common-lisp -*-
+;;;
+;;; *************************************************************************
+;;; Copyright (c) 1991 Venue
+;;; All rights reserved.
+;;; *************************************************************************
+;;;
+;;; Basic environmental stuff.
+;;;
+
+(in-package 'clos)
+
+
+
+;;;
+;;;
+;;;
+
+(defgeneric describe-object (object stream))
+
+
+(defmethod describe-object ((object standard-object) stream)
+  (let* ((class (class-of object))
+	 (slotds (slots-to-inspect class object))
+	 (max-slot-name-length 0)
+	 (instance-slotds ())
+	 (class-slotds ())
+	 (other-slotds ()))
+    (flet ((adjust-slot-name-length (name)
+	     (setq max-slot-name-length
+		   (max max-slot-name-length
+			(length (the string (symbol-name name))))))
+	   (describe-slot (name value &optional (allocation () alloc-p))
+	     (if alloc-p
+		 (format stream
+			 "~% ~A ~S ~VT  ~S"
+			 name allocation (+ max-slot-name-length 7) value)
+		 (format stream
+			 "~% ~A~VT  ~S"
+			 name max-slot-name-length value))))
+      ;; Figure out a good width for the slot-name column.
+      (dolist (slotd slotds)
+	(adjust-slot-name-length (slotd-name slotd))
+	(case (slotd-allocation slotd)
+	  (:instance (push slotd instance-slotds))
+	  (:class  (push slotd class-slotds))
+	  (otherwise (push slotd other-slotds))))
+      (setq max-slot-name-length  (min (+ max-slot-name-length 3) 30))
+      (format stream "~%~S is an instance of class ~S:" object class)
+
+      (when instance-slotds
+	(format stream "~% The following slots have :INSTANCE allocation:")
+	(dolist (slotd (nreverse instance-slotds))
+	  (describe-slot (slotd-name slotd)
+			 (slot-value-or-default object (slotd-name slotd)))))
+
+      (when class-slotds
+	(format stream "~% The following slots have :CLASS allocation:")
+	(dolist (slotd (nreverse class-slotds))
+	  (describe-slot (slotd-name slotd)
+			 (slot-value-or-default object (slotd-name slotd)))))
+
+      (when other-slotds 
+	(format stream "~% The following slots have allocation as shown:")
+	(dolist (slotd (nreverse other-slotds))
+	  (describe-slot (slotd-name slotd)
+			 (slot-value-or-default object (slotd-name slotd))
+			 (slotd-allocation slotd))))
+      (values))))
+
+(defmethod slots-to-inspect ((class std-class) (object standard-object))
+  (class-slots class))
+
+;;;
+;;;
+;;;
+(defmethod describe-object ((class class) stream)
+  (flet ((pretty-class (c) (or (class-name c) c)))
+    (macrolet ((ft (string &rest args) `(format stream ,string ,@args)))
+      (ft "~&~S is a class, it is an instance of ~S.~%"
+	  class (pretty-class (class-of class)))
+      (let ((name (class-name class)))
+	(if name
+	    (if (eq class (find-class name nil))
+		(ft "Its proper name is ~S.~%" name)
+		(ft "Its name is ~S, but this is not a proper name.~%" name))
+	    (ft "It has no name (the name is NIL).~%")))
+      (ft "The direct superclasses are: ~:S, and the direct~%~
+           subclasses are: ~:S.  The class precedence list is:~%~S~%~
+           There are ~D methods specialized for this class."
+	  (mapcar #'pretty-class (class-direct-superclasses class))
+	  (mapcar #'pretty-class (class-direct-subclasses class))
+	  (mapcar #'pretty-class (class-precedence-list class))
+	  (length (specializer-methods class))))))
+
+
+
+;;;
+;;; trace-method and untrace-method accept method specs as arguments.  A
+;;; method-spec should be a list like:
+;;;   (<generic-function-spec> qualifiers* (specializers*))
+;;; where <generic-function-spec> should be either a symbol or a list
+;;; of (SETF <symbol>).
+;;;
+;;;   For example, to trace the method defined by:
+;;;
+;;;     (defmethod foo ((x spaceship)) 'ss)
+;;;
+;;;   You should say:
+;;;
+;;;     (trace-method '(foo (spaceship)))
+;;;
+;;;   You can also provide a method object in the place of the method
+;;;   spec, in which case that method object will be traced.
+;;;
+;;; For untrace-method, if an argument is given, that method is untraced.
+;;; If no argument is given, all traced methods are untraced.
+;;;
+(defclass traced-method (method)
+     ((method :initarg :method)
+      (function :initarg :function
+		:reader method-function)
+      (generic-function :initform nil
+			:accessor method-generic-function)))
+
+(defmethod method-lambda-list ((m traced-method))
+  (with-slots (method) m (method-lambda-list method)))
+
+(defmethod method-specializers ((m traced-method))
+  (with-slots (method) m (method-specializers method)))
+
+(defmethod method-qualifiers ((m traced-method))
+  (with-slots (method) m (method-qualifiers method)))
+
+(defmethod method-qualifiers ((m traced-method))
+  (with-slots (method) m (method-qualifiers method)))
+
+(defmethod accessor-method-slot-name ((m traced-method))
+  (with-slots (method) m (accessor-method-slot-name method)))
+
+(defvar *traced-methods* ())
+
+(defun trace-method (spec &rest options)
+  (multiple-value-bind (gf omethod name)
+      (parse-method-or-spec spec)
+    (let* ((tfunction (trace-method-internal (method-function omethod)
+					     name
+					     options))
+	   (tmethod (make-instance 'traced-method
+				   :method omethod
+				   :function tfunction)))
+      (remove-method gf omethod)
+      (add-method gf tmethod)
+      (pushnew tmethod *traced-methods*)
+      tmethod)))
+
+(defun untrace-method (&optional spec)  
+  (flet ((untrace-1 (m)
+	   (let ((gf (method-generic-function m)))
+	     (when gf
+	       (remove-method gf m)
+	       (add-method gf (slot-value m 'method))
+	       (setq *traced-methods* (remove m *traced-methods*))))))
+    (if (not (null spec))
+	(multiple-value-bind (gf method)	    
+	    (parse-method-or-spec spec)
+	  (declare (ignore gf))
+	  (if (memq method *traced-methods*)
+	      (untrace-1 method)
+	      (error "~S is not a traced method?" method)))
+	(dolist (m *traced-methods*) (untrace-1 m)))))
+
+(defun trace-method-internal (ofunction name options)
+  (eval `(untrace ,name))
+  (setf (symbol-function name) ofunction)
+  (eval `(trace ,name ,@options))
+  (symbol-function name))
+
+
+
+
+;(defun compile-method (spec)
+;  (multiple-value-bind (gf method name)
+;      (parse-method-or-spec spec)
+;    (declare (ignore gf))
+;    (compile name (method-function method))
+;    (setf (method-function method) (symbol-function name))))
+
+(defmacro undefmethod (&rest args)
+  #+(or (not :lucid) :lcl3.0)
+  (declare (arglist name {method-qualifier}* specializers))
+  `(undefmethod-1 ',args))
+
+(defun undefmethod-1 (args)
+  (multiple-value-bind (gf method)
+      (parse-method-or-spec args)
+    (when (and gf method)
+      (remove-method gf method)
+      method)))
+
diff --git a/clos/3.5/fin.dfasl b/clos/3.5/fin.dfasl
new file mode 100644
index 00000000..0e6be034
Binary files /dev/null and b/clos/3.5/fin.dfasl differ
diff --git a/clos/3.5/fin.lisp b/clos/3.5/fin.lisp
new file mode 100644
index 00000000..c8de5102
--- /dev/null
+++ b/clos/3.5/fin.lisp
@@ -0,0 +1,235 @@
+;;;-*- Package: CLOS; Syntax: Common-Lisp; Base: 10 -*-
+
+
+;;; File converted on 26-Mar-91 10:33:34 from source fin
+;;;. Original source {dsk}<usr>local>users>welch>lisp>clos>rev4>il-format>fin.;3 created 19-Feb-91 16:21:49
+
+;;;. Copyright (c) 1991 by Venue
+
+
+
+
+(in-package "CLOS")
+
+;;; Shadow, Export, Require, Use-package, and Import forms should follow here
+
+
+
+
+
+
+;; 
+
+
+
+;;; FUNCALLABLE INSTANCES
+
+
+
+;; 
+
+
+
+;;; The first part of the file contains the implementation dependent code to implement funcallable
+;;; instances.  Each implementation must provide the following functions and macros:
+;;; ALLOCATE-FUNCALLABLE-INSTANCE-1 () should create and return a new funcallable instance.  The
+;;; funcallable-instance-data slots must be initialized to NIL. This is called by
+;;; allocate-funcallable-instance and by the bootstrapping code. FUNCALLABLE-INSTANCE-P (x) the
+;;; obvious predicate.  This should be an INLINE function. it must be funcallable, but it would be
+;;; nice if it compiled open. SET-FUNCALLABLE-INSTANCE-FUNCTION (fin new-value) change the fin so
+;;; that when it is funcalled, the new-value function is called.  Note that it is legal for
+;;; new-value to be copied before it is installed in the fin, specifically there is no accessor for
+;;; a FIN's function so this function does not have to preserve the actual new value.  The new-value
+;;; argument can be any funcallable thing, a closure, lambda compiled code etc.  This function must
+;;; coerce those values if necessary. NOTE: new-value is almost always a compiled closure.  This is
+;;; the important case to optimize. FUNCALLABLE-INSTANCE-DATA-1 (fin data-name) should return the
+;;; value of the data named data-name in the fin. data-name is one of the symbols in the list which
+;;; is the value of funcallable-instance-data.  Since data-name is almost always a quoted symbol and
+;;; funcallable-instance-data is a constant, it is possible (and worthwhile) to optimize the
+;;; computation of data-name's offset in the data part of the fin. This must be SETF'able. 
+
+
+(defconstant funcallable-instance-data '(wrapper slots)
+       "These are the 'data-slots' which funcallable instances have so that
+   the meta-class funcallable-standard-class can store class, and static
+   slots in them.")
+
+(defmacro funcallable-instance-data-position (data)
+       (if (and (consp data)
+                (eq (car data)
+                    'quote)
+                (boundp 'funcallable-instance-data))
+           (or (position (cadr data)
+                      funcallable-instance-data :test #'eq)
+               (progn (warn "Unknown funcallable-instance data: ~S." (cadr data))
+                      `(error "Unknown funcallable-instance data: ~S." ',(cadr data))))
+           `(position ,data funcallable-instance-data :test #'eq)))
+
+(defun called-fin-without-function nil (error "Attempt to funcall a funcallable-instance without first~%~
+          setting its funcallable-instance-function."))
+
+
+;;; In Xerox Common Lisp, a lexical closure is a pair of an environment and CCODEP.  The environment
+;;; is represented as a block.  There is space in the top 8 bits of the pointers to the CCODE and
+;;; the environment to use to mark the closure as being a FIN. To help the debugger figure out when
+;;; it has found a FIN on the stack, we reserve the last element of the closure environment to use
+;;; to point back to the actual fin. Note that there is code in xerox-low which lets us access the
+;;; fields of compiled-closures and which defines the closure-overlay record.  That code is there
+;;; because there are some clients of it in that file. 
+
+
+
+;; Don't be fooled.  We actually allocate one bigger than this to have a place to store the
+;; backpointer to the fin.  -smL 
+
+
+(defconstant funcallable-instance-closure-size 15)
+
+(defvar *fin-env-type* (type-of (il:\\allocblock (1+ funcallable-instance-closure-size)
+                                       t)))
+
+
+;; Well, Gregor may be too proud to hack xpointers, but bvm and I aren't. -smL
+
+
+(defstruct fin-env-pointer (pointer nil :type il:fullxpointer))
+
+(defun fin-env-fin (fin-env)
+       (fin-env-pointer-pointer (il:\\getbaseptr fin-env (* funcallable-instance-closure-size 2))))
+
+(defun |set fin-env-fin| (fin-env new-value)
+       (il:\\rplptr fin-env (* funcallable-instance-closure-size 2)
+              (make-fin-env-pointer :pointer new-value))
+       new-value)
+
+(defsetf fin-env-fin |set fin-env-fin|)
+
+
+;; The finalization function that will clean up the backpointer from the fin-env to the fin.  This
+;; needs to be careful to not cons at all.  This depends on there being no other finalization
+;; function on compiled-closures, since there is only one finalization function per datatype.  Too
+;; bad.  -smL 
+
+
+(defun finalize-fin (fin)
+       
+       ;; This could use the fn funcallable-instance-p, but if we get here we know that this is a
+       ;; closure, so we can skip that test. 
+       (when (il:fetch (closure-overlay funcallable-instance-p)
+                    il:of fin)
+           (let ((env (il:fetch (il:compiled-closure il:environment)
+                             il:of fin)))
+                (when env
+                    (setq env (il:\\getbaseptr env (* funcallable-instance-closure-size 2)))
+                    (when (typep env 'fin-env-pointer)
+                        (setf (fin-env-pointer-pointer env)
+                              nil)))))
+       nil)
+
+(eval-when (load)
+       
+       ;; Install the above finalization function.
+       (when (fboundp 'finalize-fin)
+           (il:\\set.finalization.function 'il:compiled-closure 'finalize-fin)))
+
+(defun allocate-funcallable-instance-1 nil (let* ((env (il:\\allocblock (1+ 
+                                                                    funcallable-instance-closure-size
+                                                                            )
+                                                              t))
+                                                  (fin (il:make-compiled-closure nil env)))
+                                                 (setf (fin-env-fin env)
+                                                       fin)
+                                                 (il:replace (closure-overlay funcallable-instance-p)
+                                                        il:of fin il:with 't)
+                                                 (set-funcallable-instance-function
+                                                  fin
+                                                  #'(lambda (&rest ignore)
+                                                           (declare (ignore ignore))
+                                                           (called-fin-without-function)))
+                                                 fin))
+
+(xcl:definline funcallable-instance-p (x)
+       (and (typep x 'il:compiled-closure)
+            (il:fetch (closure-overlay funcallable-instance-p)
+                   il:of x)))
+
+(defun set-funcallable-instance-function (fin new)
+       (cond ((not (funcallable-instance-p fin))
+              (error "~S is not a funcallable-instance" fin))
+             ((not (functionp new))
+              (error "~S is not a function." new))
+             ((typep new 'il:compiled-closure)
+              (let* ((fin-env (il:fetch (il:compiled-closure il:environment)
+                                     il:of fin))
+                     (new-env (il:fetch (il:compiled-closure il:environment)
+                                     il:of new))
+                     (new-env-size (if new-env
+                                       (il:\\#blockdatacells new-env)
+                                       0))
+                     (fin-env-size (- funcallable-instance-closure-size (length 
+                                                                            funcallable-instance-data
+                                                                               ))))
+                    (cond ((and new-env (<= new-env-size fin-env-size))
+                           (dotimes (i fin-env-size)
+                               (il:\\rplptr fin-env (* i 2)
+                                      (if (< i new-env-size)
+                                          (il:\\getbaseptr new-env (* i 2))
+                                          nil)))
+                           (setf (compiled-closure-fnheader fin)
+                                 (compiled-closure-fnheader new)))
+                          (t (set-funcallable-instance-function fin (make-trampoline new))))))
+             (t (set-funcallable-instance-function fin (make-trampoline new)))))
+
+(defun make-trampoline (function)
+       #'(lambda (&rest args)
+                (apply function args)))
+
+(defmacro funcallable-instance-data-1 (fin data)
+       `(il:\\getbaseptr (il:fetch (il:compiled-closure il:environment)
+                                il:of
+                                ,fin)
+               (* (- funcallable-instance-closure-size (funcallable-instance-data-position
+                                                        ,data)
+                     1)
+                                                             ; Reserve last element to point back to
+                                                             ; actual FIN! 
+                  2)))
+
+(defsetf funcallable-instance-data-1 (fin data)
+       (new-value)
+       `(il:\\rplptr (il:fetch (il:compiled-closure il:environment)
+                            il:of
+                            ,fin)
+               (* (- funcallable-instance-closure-size (funcallable-instance-data-position
+                                                        ,data)
+                     1)
+                  2)
+               ,new-value))
+
+                                                             ; end of #+Xerox
+
+
+
+;;; 
+
+
+(defmacro fsc-instance-p (fin)
+       `(funcallable-instance-p ,fin))
+
+(defmacro fsc-instance-class (fin)
+       `(wrapper-class (funcallable-instance-data-1 ,fin 'wrapper)))
+
+(defmacro fsc-instance-wrapper (fin)
+       `(funcallable-instance-data-1 ,fin 'wrapper))
+
+(defmacro fsc-instance-slots (fin)
+       `(funcallable-instance-data-1 ,fin 'slots))
+
+(defun allocate-funcallable-instance (wrapper number-of-static-slots)
+       (let ((fin (allocate-funcallable-instance-1))
+             (slots (%allocate-static-slot-storage--class number-of-static-slots)))
+            (setf (fsc-instance-wrapper fin)
+                  wrapper
+                  (fsc-instance-slots fin)
+                  slots)
+            fin))
diff --git a/clos/3.5/fixup.dfasl b/clos/3.5/fixup.dfasl
new file mode 100644
index 00000000..400b0fed
Binary files /dev/null and b/clos/3.5/fixup.dfasl differ
diff --git a/clos/3.5/fixup.lisp b/clos/3.5/fixup.lisp
new file mode 100644
index 00000000..13d1c52c
--- /dev/null
+++ b/clos/3.5/fixup.lisp
@@ -0,0 +1,15 @@
+;;;-*- Package: CLOS; Syntax: Common-Lisp; Base: 10 -*-
+
+
+;;;. Copyright (c) 1991 by Venue
+
+(in-package "CLOS")
+
+
+(eval-when (compile load eval)
+       (fix-early-generic-functions)
+       (setq *boot-state* 'complete))
+
+(defun print-std-instance (instance stream depth)
+       (declare (ignore depth))
+       (print-object instance stream))
diff --git a/clos/3.5/fngen.dfasl b/clos/3.5/fngen.dfasl
new file mode 100644
index 00000000..c323074d
Binary files /dev/null and b/clos/3.5/fngen.dfasl differ
diff --git a/clos/3.5/fngen.lisp b/clos/3.5/fngen.lisp
new file mode 100644
index 00000000..09e6d0da
--- /dev/null
+++ b/clos/3.5/fngen.lisp
@@ -0,0 +1,172 @@
+;;;-*- Package: CLOS; Syntax: Common-Lisp; Base: 10 -*-
+
+;;;. Copyright (c) 1991 by Venue
+
+(in-package "CLOS")
+
+
+
+;;; GET-FUNCTION is the main user interface to this code.  If it is called with a lambda expression
+;;; only, it will return a corresponding function. The optional constant-converter argument, can be
+;;; a function which will be called to convert each constant appearing in the lambda to whatever
+;;; value should appear in the function. Whether the returned function is actually compiled depends
+;;; on whether the compiler is present (see COMPILE-LAMBDA) and whether this shape of code was
+;;; precompiled. 
+
+
+(defun get-function (lambda &optional (test-converter #'default-test-converter)
+                           (code-converter #'default-code-converter)
+                           (constant-converter #'default-constant-converter))
+       (apply (get-function-generator lambda test-converter code-converter)
+              (compute-constants lambda constant-converter)))
+
+(defun default-test-converter (form)
+       (if (not (constantp form))
+           form
+           '.constant.))
+
+(defun default-code-converter (form)
+       (if (not (constantp form))
+           form
+           (let ((gensym (gensym)))
+                (values gensym (list gensym)))))
+
+(defun default-constant-converter (form)
+       (and (constantp form)
+            (list (if (and (consp form)
+                           (eq (car form)
+                               'quote))
+                                                             ; This had better
+                      (cadr form)
+                                                             ; do the same as
+                      form))))
+
+                                                             ; EVAL would have.
+
+
+
+;;; *fgens* is a list of all the function generators we have so far.  Each element is a FGEN
+;;; structure as implemented below.  Don't ever touch this list by hand, use STORE-FGEN. 
+
+
+(defvar *fgens* nil)
+
+(defun store-fgen (fgen)
+       (setq *fgens* (nconc *fgens* (list fgen))))
+
+(defun lookup-fgen (test)
+       (find test (the list *fgens*)
+             :key
+             #'fgen-test :test #'equal))
+
+(defun make-fgen (test gensyms generator generator-lambda system)
+       (let ((new (make-array 6)))
+            (setf (svref new 0)
+                  test
+                  (svref new 1)
+                  gensyms
+                  (svref new 2)
+                  generator
+                  (svref new 3)
+                  generator-lambda
+                  (svref new 4)
+                  system)
+            new))
+
+(defun fgen-test (fgen)
+       (svref fgen 0))
+
+(defun fgen-gensyms (fgen)
+       (svref fgen 1))
+
+(defun fgen-generator (fgen)
+       (svref fgen 2))
+
+(defun fgen-generator-lambda (fgen)
+       (svref fgen 3))
+
+(defun fgen-system (fgen)
+       (svref fgen 4))
+
+(defun get-function-generator (lambda test-converter code-converter)
+       (let* ((test (compute-test lambda test-converter))
+              (fgen (lookup-fgen test)))
+             (if fgen
+                 (fgen-generator fgen)
+                 (get-new-function-generator lambda test code-converter))))
+
+(defun get-new-function-generator (lambda test code-converter)
+       (multiple-value-bind (gensyms generator-lambda)
+              (get-new-function-generator-internal lambda code-converter)
+              (let* ((generator (compile-lambda generator-lambda))
+                     (fgen (make-fgen test gensyms generator generator-lambda nil)))
+                    (store-fgen fgen)
+                    generator)))
+
+(defun get-new-function-generator-internal (lambda code-converter)
+       (multiple-value-bind (code gensyms)
+              (compute-code lambda code-converter)
+              (values gensyms `(lambda ,gensyms #',code))))
+
+(defun compute-test (lambda test-converter)
+       (walk-form lambda nil #'(lambda (f c e)
+                                      (declare (ignore e))
+                                      (if (neq c :eval)
+                                          f
+                                          (let ((converted (funcall test-converter f)))
+                                               (values converted (neq converted f)))))))
+
+(defun compute-code (lambda code-converter)
+       (let ((gensyms nil))
+            (values (walk-form lambda nil #'(lambda (f c e)
+                                                   (declare (ignore e))
+                                                   (if (neq c :eval)
+                                                       f
+                                                       (multiple-value-bind
+                                                        (converted gens)
+                                                        (funcall code-converter f)
+                                                        (when gens
+                                                            (setq gensyms (append gensyms gens)))
+                                                        (values converted (neq converted f))))))
+                   gensyms)))
+
+(defun compute-constants (lambda constant-converter)
+       (macrolet ((appending nil `(let ((result nil))
+                                       (values #'(lambda (value)
+                                                        (setq result (append result value)))
+                                              #'(lambda nil result)))))
+              (gathering1 (appending)
+                     (walk-form lambda nil #'(lambda (f c e)
+                                                    (declare (ignore e))
+                                                    (if (neq c :eval)
+                                                        f
+                                                        (let ((consts (funcall constant-converter f))
+                                                              )
+                                                             (if consts
+                                                                 (progn (gather1 consts)
+                                                                        (values f t))
+                                                                 f))))))))
+
+
+;;; 
+
+
+(defmacro
+ precompile-function-generators
+ (&optional system)
+ (make-top-level-form
+  `(precompile-function-generators ,system)
+  '(load)
+  `(progn ,@(gathering1 (collecting)
+                   (dolist (fgen *fgens*)
+                       (when (or (null (fgen-system fgen))
+                                 (eq (fgen-system fgen)
+                                     system))
+                           (gather1 `(load-function-generator ',(fgen-test fgen)
+                                            ',(fgen-gensyms fgen)
+                                            #',(fgen-generator-lambda fgen)
+                                            ',(fgen-generator-lambda fgen)
+                                            ',system))))))))
+
+(defun load-function-generator (test gensyms generator generator-lambda system)
+       (store-fgen (make-fgen test gensyms generator generator-lambda system)))
diff --git a/clos/3.5/fsc.dfasl b/clos/3.5/fsc.dfasl
new file mode 100644
index 00000000..e3b6de85
Binary files /dev/null and b/clos/3.5/fsc.dfasl differ
diff --git a/clos/3.5/fsc.lisp b/clos/3.5/fsc.lisp
new file mode 100644
index 00000000..a2670af9
--- /dev/null
+++ b/clos/3.5/fsc.lisp
@@ -0,0 +1,72 @@
+;;;-*- Package: CLOS; Syntax: Common-Lisp; Base: 10 -*-
+
+;;;. Copyright (c) 1991 by Venue
+
+
+(in-package "CLOS")
+
+
+;;; This file contains the
+;;; definition of the FUNCALLABLE-STANDARD-CLASS metaclass.  Much of the implementation of this
+;;; metaclass is actually defined on the class STD-CLASS.  What appears in this file is a modest
+;;; number of simple methods related to the low-level differences in the implementation of standard
+;;; and funcallable-standard instances. As it happens, none of these differences are the ones
+;;; reflected in the MOP specification; STANDARD-CLASS and FUNCALLABLE-STANDARD-CLASS share all
+;;; their specified methods at STD-CLASS. workings of this metaclass and the standard-class
+;;; metaclass. 
+
+
+(defmethod wrapper-fetcher ((class funcallable-standard-class))
+       'fsc-instance-wrapper)
+
+(defmethod slots-fetcher ((class funcallable-standard-class))
+       'fsc-instance-slots)
+
+(defmethod raw-instance-allocator ((class funcallable-standard-class))
+       'allocate-funcallable-instance-1)
+
+
+;;; 
+
+
+(defmethod check-super-metaclass-compatibility ((fsc funcallable-standard-class)
+                                                (class standard-class))
+       (null (wrapper-instance-slots-layout (class-wrapper class))))
+
+(defmethod allocate-instance ((class funcallable-standard-class)
+                              &rest initargs)
+       (declare (ignore initargs))
+       (unless (class-finalized-p class)
+              (finalize-inheritance class))
+       (let ((class-wrapper (class-wrapper class)))
+            (allocate-funcallable-instance class-wrapper (class-no-of-instance-slots class))))
+
+(defmethod make-reader-method-function ((class funcallable-standard-class)
+                                        slot-name)
+       (make-std-reader-method-function slot-name))
+
+(defmethod make-writer-method-function ((class funcallable-standard-class)
+                                        slot-name)
+       (make-std-writer-method-function slot-name))
+
+                                                             ; See the comment about
+                                                             ; reader-function--std and
+                                                             ; writer-function--sdt.
+                                                             ; (define-function-template
+                                                             ; reader-function--fsc () '(slot-name)
+                                                             ; `(function (lambda (instance)
+                                                             ; (slot-value-using-class
+                                                             ; (wrapper-class (get-wrapper
+                                                             ; instance)) instance slot-name))))
+                                                             ; (define-function-template
+                                                             ; writer-function--fsc () '(slot-name)
+                                                             ; `(function (lambda (nv instance)
+                                                             ; (setf (slot-value-using-class
+                                                             ; (wrapper-class (get-wrapper
+                                                             ; instance)) instance slot-name) nv))))
+                                                             ; (eval-when (load)
+                                                             ; (pre-make-templated-function-constructor
+                                                             ; reader-function--fsc)
+                                                             ; (pre-make-templated-function-constructor
+                                                             ; writer-function--fsc)) 
+
diff --git a/clos/3.5/init.dfasl b/clos/3.5/init.dfasl
new file mode 100644
index 00000000..6676e1e1
Binary files /dev/null and b/clos/3.5/init.dfasl differ
diff --git a/clos/3.5/init.lisp b/clos/3.5/init.lisp
new file mode 100644
index 00000000..d44e50ef
--- /dev/null
+++ b/clos/3.5/init.lisp
@@ -0,0 +1,183 @@
+;;;-*- Package: CLOS; Syntax: Common-Lisp; Base: 10 -*-
+
+;;;. Copyright (c) 1991 by Venue
+
+(in-package "CLOS")
+
+;;; this file defines the
+;;; initialization and related protocols. 
+
+
+(defmethod make-instance ((class std-class)
+                          &rest initargs)
+       (unless (class-finalized-p class)
+              (finalize-inheritance class))
+       (setq initargs (default-initargs class initargs))
+       (when initargs
+           (when (and (eq *boot-state* 'complete)
+                      (let ((tail initargs))
+                           (loop (unless tail (return t))
+                                 (when (eq (car tail)
+                                           ':allow-other-keys)
+                                       (return nil))
+                                 (setq tail (cddr tail)))))
+               (check-initargs-1 class initargs (append (compute-applicable-methods 
+                                                               #'allocate-instance (list class))
+                                                       (compute-applicable-methods
+                                                        #'initialize-instance
+                                                        (list (class-prototype class)))
+                                                       (compute-applicable-methods
+                                                        #'shared-initialize
+                                                        (list (class-prototype class)
+                                                              t))))))
+       (let ((instance (apply #'allocate-instance class initargs)))
+            (apply #'initialize-instance instance initargs)
+            instance))
+
+(defmethod make-instance ((class-name symbol)
+                          &rest initargs)
+       (apply #'make-instance (find-class class-name)
+              initargs))
+
+(defvar *default-initargs-flag* (list nil))
+
+(defmethod default-initargs ((class std-class)
+                             supplied-initargs)
+       
+       ;; This implementation of default initargs is critically dependent on all-default-initargs
+       ;; not having any duplicate initargs in it. 
+       (let ((all-default (class-default-initargs class))
+             (miss *default-initargs-flag*))
+            (flet ((getf* (plist key)
+                          (do nil
+                              ((null plist)
+                               miss)
+                            (if (eq (car plist)
+                                    key)
+                                (return (cadr plist))
+                                (setq plist (cddr plist))))))
+                  (labels ((default-1 (tail)
+                                  (if (null tail)
+                                      nil
+                                      (if (eq (getf* supplied-initargs (caar tail))
+                                              miss)
+                                          (list* (caar tail)
+                                                 (funcall (cadar tail))
+                                                 (default-1 (cdr tail)))
+                                          (default-1 (cdr tail))))))
+                         (append supplied-initargs (default-1 all-default))))))
+
+(defmethod initialize-instance ((instance standard-object)
+                                &rest initargs)
+       (apply #'shared-initialize instance t initargs))
+
+(defmethod reinitialize-instance ((instance standard-object)
+                                  &rest initargs)
+       (when initargs
+           (when (eq *boot-state* 'complete)
+               (check-initargs-1 (class-of instance)
+                      initargs
+                      (append (compute-applicable-methods #'reinitialize-instance (list instance))
+                             (compute-applicable-methods #'shared-initialize (list instance t))))))
+       (apply #'shared-initialize instance nil initargs)
+       instance)
+
+(defmethod update-instance-for-different-class ((previous standard-object)
+                                                (current standard-object)
+                                                &rest initargs)
+       (when initargs
+           (check-initargs-1 (class-of current)
+                  initargs
+                  (append (compute-applicable-methods #'update-instance-for-different-class
+                                 (list previous current))
+                         (compute-applicable-methods #'shared-initialize (list current t)))))
+       
+       ;; First we must compute the newly added slots.  The spec defines newly added slots as "those
+       ;; local slots for which no slot of the same name exists in the previous class." 
+       (let ((added-slots 'nil)
+             (current-slotds (class-slots (class-of current)))
+             (previous-slot-names (mapcar #'slotd-name (class-slots (class-of previous)))))
+            (dolist (slotd current-slotds)
+                (if (and (not (memq (slotd-name slotd)
+                                    previous-slot-names))
+                         (eq (slotd-allocation slotd)
+                             ':instance))
+                    (push (slotd-name slotd)
+                          added-slots)))
+            (apply #'shared-initialize current added-slots initargs)))
+
+(defmethod update-instance-for-redefined-class ((instance standard-object)
+                                                added-slots discarded-slots property-list &rest 
+                                                initargs)
+       (declare (ignore discarded-slots property-list))
+       (when initargs
+           (check-initargs-1 (class-of instance)
+                  initargs
+                  (append (compute-applicable-methods #'update-instance-for-redefined-class
+                                 (list instance))
+                         (compute-applicable-methods #'shared-initialize (list instance nil)))))
+       (apply #'shared-initialize instance added-slots initargs))
+
+(defmethod shared-initialize ((instance standard-object)
+                              slot-names &rest initargs)
+       
+       ;; initialize the instance's slots in a two step process 1) A slot for which one of the
+       ;; initargs in initargs can set the slot, should be set by that initarg.  If more than one
+       ;; initarg in initargs can set the slot, the leftmost one should set it. 2) Any slot not set
+       ;; by step 1, may be set from its initform by step 2.  Only those slots specified by the
+       ;; slot-names argument are set.  If slot-names is: T any slot not set in step 1 is set from
+       ;; its initform <list of slot names> any slot in the list, and not set in step 1 is set from
+       ;; its initform () no slots are set from initforms 
+       (let* ((class (class-of instance))
+              (slotds (class-slots class)))
+             (dolist (slotd slotds)
+                 (let ((slot-name (slotd-name slotd))
+                       (slot-initargs (slotd-initargs slotd)))
+                      (flet ((from-initargs nil 
+
+                                    ;; Try to initialize the slot from one of the initargs. If we
+                                    ;; succeed return T, otherwise return nil. 
+                                    (doplist (initarg val)
+                                           initargs
+                                           (when (memq initarg slot-initargs)
+                                               (setf (slot-value instance slot-name)
+                                                     val)
+                                               (return 't))))
+                             (from-initforms nil 
+
+                                    ;; Try to initialize the slot from its initform.  This returns
+                                    ;; no meaningful value. 
+                                    (if (and slot-names (or (eq slot-names 't)
+                                                            (memq slot-name slot-names))
+                                             (not (slot-boundp instance slot-name)))
+                                        (let ((initfunction (slotd-initfunction slotd)))
+                                             (when initfunction
+                                                 (setf (slot-value instance slot-name)
+                                                       (funcall initfunction)))))))
+                            (or (from-initargs)
+                                (from-initforms))))))
+       instance)
+
+
+;;; if initargs are valid return nil, otherwise signal an error 
+
+
+(defun check-initargs-1 (class initargs methods)
+       (let ((legal (apply #'append (mapcar #'slotd-initargs (class-slots class)))))
+            (unless (getf initargs :allow-other-keys)
+                
+                ;; Add to the set of slot-filling initargs the set of initargs that are accepted by
+                ;; the methods.  If at any point we come across &allow-other-keys, we can just quit.
+                (dolist (method methods)
+                    (multiple-value-bind (keys allow-other-keys)
+                        (function-keywords method)
+                      (when allow-other-keys (return-from check-initargs-1 nil))
+                      (setq legal (append keys legal))))
+                
+                ;; Now check the supplied-initarg-names and the default initargs against the total
+                ;; set that we know are legal. 
+                (doplist (key val)
+                       initargs
+                       (unless (memq key legal)
+                           (error "Invalid initialization argument ~S for class ~S" key (class-name
+                                                                                         class)))))))
diff --git a/clos/3.5/iterate.dfasl b/clos/3.5/iterate.dfasl
new file mode 100644
index 00000000..e90254d4
Binary files /dev/null and b/clos/3.5/iterate.dfasl differ
diff --git a/clos/3.5/iterate.lisp b/clos/3.5/iterate.lisp
new file mode 100644
index 00000000..212f819c
--- /dev/null
+++ b/clos/3.5/iterate.lisp
@@ -0,0 +1,1080 @@
+(DEFINE-FILE-INFO READTABLE "XCL" PACKAGE (CLIN-PACKAGE ITERATE USE (QUOTE (LISP WALKER))) 
+BASE 10)
+(IL:FILECREATED "19-Feb-91 13:55:29" 
+IL:|{DSK}<usr>local>users>welch>lisp>clos>rev4>il-format>ITERATE.;2| 65656  
+
+      IL:|changes| IL:|to:|  (IL:VARS IL:ITERATECOMS)
+
+      IL:|previous| IL:|date:| " 6-Feb-91 11:00:58" 
+IL:|{DSK}<usr>local>users>welch>lisp>clos>rev4>il-format>ITERATE.;1|)
+
+
+; Copyright (c) 1991 by Venue.  All rights reserved.
+
+(IL:PRETTYCOMPRINT IL:ITERATECOMS)
+
+(IL:RPAQQ IL:ITERATECOMS 
+          (
+
+(IL:* IL:|;;;| "************************************************************************* Copyright (c) 1985, 1986, 1987, 1988, 1989, 1990 Xerox Corporation. All rights reserved. Use and copying of this software and preparation of derivative works based upon this software are permitted.  Any distribution of this software or derivative works must comply with all applicable United States export control laws. This software is made available AS IS, and Xerox Corporation makes no warranty about the software, its performance or its conformity to any specification. Any person obtaining a copy of this software is requested to send their name and post office or electronic mail address to: CommonLoops Coordinator Xerox PARC 3333 Coyote Hill Rd. Palo Alto, CA 94304 (or send Arpanet mail to CommonLoops-Coordinator.pa@Xerox.arpa) Suggestions, comments and requests for improvements are also welcome. ************************************************************************* Original source {pooh/n}<pooh>vanmelle>lisp>iterate;4 created 27-Sep-88 12:35:33 ")
+
+           (IL:P (IN-PACKAGE :ITERATE :USE '(:LISP :WALKER))
+                 (EXPORT '(ITERATE ITERATE* GATHERING GATHER WITH-GATHERING INTERVAL ELEMENTS 
+                                 LIST-ELEMENTS LIST-TAILS PLIST-ELEMENTS EACHTIME WHILE UNTIL 
+                                 COLLECTING JOINING MAXIMIZING MINIMIZING SUMMING *ITERATE-WARNINGS*)
+                        ))
+           (IL:VARIABLES *ITERATE-WARNINGS*)
+           
+
+(IL:* IL:|;;;| "ITERATE macro")
+
+           (IL:FUNCTIONS ITERATE SIMPLE-EXPAND-ITERATE-FORM)
+           (IL:VARIABLES *ITERATE-TEMP-VARS-LIST*)
+           (IL:FUNCTIONS OPTIMIZE-ITERATE-FORM EXPAND-INTO-LET VARIABLES-FROM-LET 
+                  ITERATE-TRANSFORM-BODY PARSE-DECLARATIONS EXTRACT-SPECIAL-BINDINGS 
+                  FUNCTION-LAMBDA-P RENAME-LET-BINDINGS RENAME-VARIABLES MV-SETQ VARIABLE-SAME-P 
+                  MAYBE-WARN)
+           
+           (IL:* IL:|;;| "Sample iterators")
+
+           (IL:FUNCTIONS INTERVAL LIST-ELEMENTS LIST-TAILS ELEMENTS PLIST-ELEMENTS SEQUENCE-ACCESSOR)
+           
+           (IL:* IL:|;;| "These \"iterators\" may be withdrawn")
+
+           (IL:FUNCTIONS EACHTIME WHILE UNTIL)
+                                                             (IL:* IL:\; "GATHERING macro")
+           (IL:FUNCTIONS GATHERING WITH-GATHERING SIMPLE-EXPAND-GATHERING-FORM)
+           (IL:VARIABLES *ACTIVE-GATHERERS* *ANONYMOUS-GATHERING-SITE*)
+           (IL:FUNCTIONS OPTIMIZE-GATHERING-FORM RENAME-AND-CAPTURE-VARIABLES WALK-GATHERING-BODY)
+           
+           (IL:* IL:|;;| "Sample gatherers")
+
+           (IL:FUNCTIONS COLLECTING JOINING MAXIMIZING MINIMIZING SUMMING)
+                                                             (IL:* IL:\; 
+                                           "Easier to read expanded code if PROG1 gets left alone ")
+           (XCL:FILE-ENVIRONMENTS "ITERATE")))
+
+
+
+(IL:* IL:|;;;| 
+"************************************************************************* Copyright (c) 1985, 1986, 1987, 1988, 1989, 1990 Xerox Corporation. All rights reserved. Use and copying of this software and preparation of derivative works based upon this software are permitted.  Any distribution of this software or derivative works must comply with all applicable United States export control laws. This software is made available AS IS, and Xerox Corporation makes no warranty about the software, its performance or its conformity to any specification. Any person obtaining a copy of this software is requested to send their name and post office or electronic mail address to: CommonLoops Coordinator Xerox PARC 3333 Coyote Hill Rd. Palo Alto, CA 94304 (or send Arpanet mail to CommonLoops-Coordinator.pa@Xerox.arpa) Suggestions, comments and requests for improvements are also welcome. ************************************************************************* Original source {pooh/n}<pooh>vanmelle>lisp>iterate;4 created 27-Sep-88 12:35:33 "
+)
+
+
+(IN-PACKAGE :ITERATE :USE '(:LISP :WALKER))
+
+(EXPORT '(ITERATE ITERATE* GATHERING GATHER WITH-GATHERING INTERVAL ELEMENTS LIST-ELEMENTS 
+                LIST-TAILS PLIST-ELEMENTS EACHTIME WHILE UNTIL COLLECTING JOINING MAXIMIZING 
+                MINIMIZING SUMMING *ITERATE-WARNINGS*))
+
+(DEFVAR *ITERATE-WARNINGS* :ANY "Controls whether warnings are issued for iterate/gather forms that aren't optimized.
+NIL => never; :USER => those resulting from user code; T => always, even if it's the iteration macro that's suboptimal."
+)
+
+
+
+(IL:* IL:|;;;| "ITERATE macro")
+
+
+(DEFMACRO ITERATE (CLAUSES &BODY BODY &ENVIRONMENT ENV)
+   (OPTIMIZE-ITERATE-FORM CLAUSES BODY ENV))
+
+(DEFUN SIMPLE-EXPAND-ITERATE-FORM (CLAUSES BODY)
+
+   (IL:* IL:|;;| 
+ "Expand ITERATE.  This is the \"formal semantics\" expansion, which we never use. ")
+
+   (LET*
+    ((BLOCK-NAME (GENSYM))
+     (BOUND-VAR-LISTS (MAPCAR #'(LAMBDA (CLAUSE)
+                                       (LET ((NAMES (FIRST CLAUSE)))
+                                            (IF (LISTP NAMES)
+                                                NAMES
+                                                (LIST NAMES))))
+                             CLAUSES))
+     (GENERATOR-VARS (MAPCAR #'(LAMBDA (CLAUSE)
+                                      (DECLARE (IGNORE CLAUSE))
+                                      (GENSYM))
+                            CLAUSES)))
+    `(BLOCK ,BLOCK-NAME
+         (LET*
+          ,(MAPCAN #'(LAMBDA (GVAR CLAUSE VAR-LIST)          (IL:* IL:\; 
+            "For each clause, bind a generator temp to the clause, then bind the specified var(s) ")
+                            (CONS (LIST GVAR (SECOND CLAUSE))
+                                  (COPY-LIST VAR-LIST)))
+                  GENERATOR-VARS CLAUSES BOUND-VAR-LISTS)
+
+          (IL:* IL:|;;| "Note bug in formal semantics: there can be declarations in the head of BODY; they go here, rather than inside loop ")
+
+          (LOOP ,@(MAPCAR #'(LAMBDA (VAR-LIST GEN-VAR)       (IL:* IL:\; 
+   "Set each bound variable (or set of vars) to the result of calling the corresponding generator ")
+                                   `(MULTIPLE-VALUE-SETQ ,VAR-LIST
+                                           (FUNCALL ,GEN-VAR #'(LAMBDA NIL (RETURN-FROM ,BLOCK-NAME))
+                                                  )))
+                         BOUND-VAR-LISTS GENERATOR-VARS)
+                ,@BODY)))))
+
+(DEFPARAMETER *ITERATE-TEMP-VARS-LIST* '(ITERATE-TEMP-1 ITERATE-TEMP-2 ITERATE-TEMP-3 
+                                                   ITERATE-TEMP-4 ITERATE-TEMP-5 ITERATE-TEMP-6 
+                                                   ITERATE-TEMP-7 ITERATE-TEMP-8)
+                                           "Temp var names used by ITERATE expansions.")
+
+(DEFUN OPTIMIZE-ITERATE-FORM (CLAUSES BODY ITERATE-ENV)
+   (LET*
+    ((TEMP-VARS *ITERATE-TEMP-VARS-LIST*)
+     (BLOCK-NAME (GENSYM))
+     (FINISH-FORM `(RETURN-FROM ,BLOCK-NAME))
+     (BOUND-VARS (MAPCAN #'(LAMBDA (CLAUSE)
+                                  (LET ((NAMES (FIRST CLAUSE)))
+                                       (IF (LISTP NAMES)
+                                           (COPY-LIST NAMES)
+                                           (LIST NAMES))))
+                        CLAUSES))
+     ITERATE-DECLS GENERATOR-DECLS UPDATE-FORMS BINDINGS LEFTOVER-BODY)
+    (DO ((TAIL BOUND-VARS (CDR TAIL)))
+        ((NULL TAIL))                                        (IL:* IL:\; "Check for duplicates")
+      (WHEN (MEMBER (CAR TAIL)
+                   (CDR TAIL))
+          (WARN "Variable appears more than once in ITERATE: ~S" (CAR TAIL))))
+    (FLET
+     ((GET-ITERATE-TEMP NIL 
+
+             (IL:* IL:|;;| "Make temporary var.  Note that it is ok to re-use these symbols in each iterate, because they are not used within BODY. ")
+
+             (OR (POP TEMP-VARS)
+                 (GENSYM))))
+     (DOLIST (CLAUSE CLAUSES)
+         (COND
+            ((OR (NOT (CONSP CLAUSE))
+                 (NOT (CONSP (CDR CLAUSE))))
+             (WARN "Bad syntax in ITERATE: clause not of form (var iterator): ~S" CLAUSE))
+            (T
+             (UNLESS (NULL (CDDR CLAUSE))
+                    (WARN "Probable parenthesis error in ITERATE clause--more than 2 elements: ~S" 
+                          CLAUSE))
+             (MULTIPLE-VALUE-BIND (LET-BODY BINDING-TYPE LET-BINDINGS LOCALDECLS OTHERDECLS 
+                                         EXTRA-BODY)
+                 (EXPAND-INTO-LET (SECOND CLAUSE)
+                        'ITERATE ITERATE-ENV)
+
+               (IL:* IL:|;;| 
+             "We have expanded the generator clause and parsed it into its LET pieces. ")
+
+               (PROG* ((VARS (FIRST CLAUSE))
+                       GEN-ARGS RENAMED-VARS)
+                      (SETQ VARS (IF (LISTP VARS)
+                                     (COPY-LIST VARS)
+                                     (LIST VARS)))           (IL:* IL:\; 
+                           "VARS is now a (fresh) list of all iteration vars bound in this clause ")
+                      (COND
+                         ((EQ LET-BODY :ABORT)               (IL:* IL:\; 
+                                                    "Already issued a warning about malformedness ")
+                          )
+                         ((NULL (SETQ LET-BODY (FUNCTION-LAMBDA-P LET-BODY 1)))
+                                                             (IL:* IL:\; "Not of the expected form")
+                          (LET ((GENERATOR (SECOND CLAUSE)))
+                               (COND
+                                  ((AND (CONSP GENERATOR)
+                                        (FBOUNDP (CAR GENERATOR)))
+                                                             (IL:* IL:\; "It looks ok--a macro or function here--so the guy who wrote it just didn't do it in an optimizable way ")
+                                   (MAYBE-WARN :DEFINITION "Could not optimize iterate clause ~S because generator not of form (LET[*] ... (FUNCTION (LAMBDA (finish) ...)))"
+                                          GENERATOR))
+                                  (T                         (IL:* IL:\; 
+                                           "Perhaps it's just a misspelling?  Probably user error ")
+                                     (MAYBE-WARN :USER 
+                                            "Iterate operator in clause ~S is not fboundp." GENERATOR
+                                            )))
+                               (SETQ LET-BODY :ABORT)))
+                         (T
+
+                          (IL:* IL:|;;| "We have something of the form #'(LAMBDA (finisharg) ...), possibly with some LET bindings around it.  LET-BODY = ((finisharg) ...). ")
+
+                          (SETQ LET-BODY (CDR LET-BODY))
+                          (SETQ GEN-ARGS (POP LET-BODY))
+                          (WHEN LET-BINDINGS
+
+                              (IL:* IL:|;;| "The first transformation we want to perform is \"LET-eversion\": turn (let* ((generator (let (..bindings..) #'(lambda ...)))) ..body..) into (let* (..bindings.. (generator #'(lambda ...))) ..body..).  This transformation is valid if nothing in body refers to any of the bindings, something we can assure by alpha-converting the inner let (substituting new names for each var).  Of course, none of those vars can be special, but we already checked for that above. ")
+
+                              (MULTIPLE-VALUE-SETQ (LET-BINDINGS RENAMED-VARS)
+                                     (RENAME-LET-BINDINGS LET-BINDINGS BINDING-TYPE ITERATE-ENV 
+                                            LEFTOVER-BODY #'GET-ITERATE-TEMP))
+                              (SETQ LEFTOVER-BODY NIL)       (IL:* IL:\; 
+                                     "If there was any leftover from previous, it is now consumed ")
+                              )
+
+                          (IL:* IL:|;;| "The second transformation is substituting the body of the generator (LAMBDA (finish-arg) . gen-body) for its appearance in the update form (funcall generator #'(lambda () finish-form)), then simplifying that form.  The requirement for this part is that the generator body not refer to any variables that are bound between the generator binding and the appearance in the loop body.  The only variables bound in that interval are generator temporaries, which have unique names so are no problem, and the iteration variables remaining for subsequent clauses.  We'll discover the story as we walk the body. ")
+
+                          (MULTIPLE-VALUE-BIND (FINISHDECL OTHER REST)
+                              (PARSE-DECLARATIONS LET-BODY GEN-ARGS)
+                            (DECLARE (IGNORE FINISHDECL))(IL:* IL:\; "Pull out declares, if any, separating out the one(s) referring to the finish arg, which we will throw away ")
+                            (WHEN OTHER                      (IL:* IL:\; 
+                               "Combine remaining decls with decls extracted from the LET, if any ")
+                                (SETQ OTHERDECLS (NCONC OTHERDECLS OTHER)))
+                            (SETQ LET-BODY (COND
+                                              (OTHERDECLS    (IL:* IL:\; 
+                                 "There are interesting declarations, so have to keep it wrapped. ")
+                                                     `(LET NIL (DECLARE ,@OTHERDECLS)
+                                                           ,@REST))
+                                              ((NULL (CDR REST))
+                                                             (IL:* IL:\; "Only one form left")
+                                               (FIRST REST))
+                                              (T `(PROGN ,@REST)))))
+                          (UNLESS (EQ (SETQ LET-BODY (ITERATE-TRANSFORM-BODY LET-BODY ITERATE-ENV
+                                                            RENAMED-VARS (FIRST GEN-ARGS)
+                                                            FINISH-FORM BOUND-VARS CLAUSE))
+                                      :ABORT)
+
+                              (IL:* IL:|;;| "Skip the rest if transformation failed.  Warning has already been issued. Note possible further optimization: if LET-BODY expanded into (prog1 oldvalue prepare-for-next-iteration), as so many do, then we could in most cases split the PROG1 into two pieces: do the (setq var oldvalue) here, and do the prepare-for-next-iteration at the bottom of the loop. This does a slight optimization of the PROG1 and also rearranges the code in a way that a reasonably clever compiler might detect how to get rid of redundant variables altogether (such as happens with INTERVAL and LIST-TAILS); that would make the whole thing closer to what you might have coded by hand.  However, to do this optimization, we need to assure that (a) the prepare-for-next-iteration refers freely to no vars other than the internal vars we have extracted from the LET, and (b) that the code has no side effects.  These are both true for all the iterators defined by this module, but how shall we represent side-effect info and/or tap into the compiler's knowledge of same? ")
+
+                              (WHEN LOCALDECLS               (IL:* IL:\; "There were declarations for the generator locals--have to keep them for later, and rename the vars mentioned ")
+                                  (SETQ
+                                   GENERATOR-DECLS
+                                   (NCONC
+                                    GENERATOR-DECLS
+                                    (MAPCAR
+                                     #'(LAMBDA (DECL)
+                                              (LET ((HEAD (CAR DECL)))
+                                                   (CONS HEAD (IF (EQ HEAD 'TYPE)
+                                                                  (CONS (SECOND DECL)
+                                                                        (SUBLIS RENAMED-VARS
+                                                                               (CDDR DECL)))
+                                                                  (SUBLIS RENAMED-VARS (CDR DECL)))))
+                                              )
+                                     LOCALDECLS)))))))
+
+                (IL:* IL:|;;| "Finished analyzing clause now.  LET-BODY is the form which, when evaluated, returns updated values for the iteration variable(s) VARS. ")
+
+                      (WHEN (EQ LET-BODY :ABORT)
+
+                          (IL:* IL:|;;| "Some punt case: go with the formal semantics: bind a var to the generator, then call it in the update section ")
+
+                          (LET ((GVAR (GET-ITERATE-TEMP))
+                                (GENERATOR (SECOND CLAUSE)))
+                               (SETQ LET-BINDINGS
+                                     (LIST (LIST GVAR
+                                                 (COND
+                                                    (LEFTOVER-BODY
+                                                             (IL:* IL:\; "Have to use this up")
+                                                     `(PROGN ,@(PROG1 LEFTOVER-BODY (SETQ 
+                                                                                        LEFTOVER-BODY
+                                                                                          NIL))
+                                                             GENERATOR))
+                                                    (T GENERATOR)))))
+                               (SETQ LET-BODY `(FUNCALL ,GVAR #'(LAMBDA NIL ,FINISH-FORM)))))
+                      (PUSH (MV-SETQ (COPY-LIST VARS)
+                                   LET-BODY)
+                            UPDATE-FORMS)
+                      (DOLIST (V VARS)
+                          (DECLARE (IGNORE V))           (IL:* IL:\; "Pop off the vars we have now bound from the list of vars to watch out for--we'll bind them right now ")
+                          (POP BOUND-VARS))
+                      (SETQ BINDINGS (NCONC BINDINGS LET-BINDINGS
+                                            (COND
+                                               (EXTRA-BODY   (IL:* IL:\; 
+                          "There was some computation to do after the bindings--here's our chance ")
+                                                      (CONS (LIST (FIRST VARS)
+                                                                  `(PROGN ,@EXTRA-BODY NIL))
+                                                            (REST VARS)))
+                                               (T VARS))))))))))
+    (DO ((TAIL BODY (CDR TAIL)))
+        ((NOT (AND (CONSP TAIL)
+                   (CONSP (CAR TAIL))
+                   (EQ (CAAR TAIL)
+                       'DECLARE)))
+
+         (IL:* IL:|;;| "TAIL now points at first non-declaration.  If there were declarations, pop them off so they appear in the right place ")
+
+         (UNLESS (EQ TAIL BODY)
+             (SETQ ITERATE-DECLS (LDIFF BODY TAIL))
+             (SETQ BODY TAIL))))
+    `(BLOCK ,BLOCK-NAME
+         (LET* ,BINDINGS ,@(AND GENERATOR-DECLS `((DECLARE ,@GENERATOR-DECLS)))
+               ,@ITERATE-DECLS
+               ,@LEFTOVER-BODY
+               (LOOP ,@(NREVERSE UPDATE-FORMS)
+                     ,@BODY)))))
+
+(DEFUN EXPAND-INTO-LET (CLAUSE PARENT-NAME ENV)
+
+   (IL:* IL:|;;| "Return values: Body, LET[*], bindings, localdecls, otherdecls, extra body, where BODY is a single form.  If multiple forms in a LET, the preceding forms are returned as extra body.  Returns :ABORT if it issued a punt warning. ")
+
+   (PROG ((EXPANSION CLAUSE)
+          EXPANDEDP BINDING-TYPE LET-BINDINGS LET-BODY)
+     EXPAND
+         (MULTIPLE-VALUE-SETQ (EXPANSION EXPANDEDP)
+                (MACROEXPAND-1 EXPANSION ENV))
+         (COND
+            ((NOT (CONSP EXPANSION))                         (IL:* IL:\; "Shouldn't happen")
+             )
+            ((SYMBOLP (SETQ BINDING-TYPE (FIRST EXPANSION)))
+             (CASE BINDING-TYPE
+                 ((LET LET*) 
+                    (SETQ LET-BINDINGS (SECOND EXPANSION))   (IL:* IL:\; 
+                                                           "List of variable bindings")
+                    (SETQ LET-BODY (CDDR EXPANSION))
+                    (GO HANDLE-LET))))
+            ((AND (CONSP BINDING-TYPE)
+                  (EQ (CAR BINDING-TYPE)
+                      'LAMBDA)
+                  (NOT (FIND-IF #'(LAMBDA (X)
+                                         (MEMBER X LAMBDA-LIST-KEYWORDS))
+                              (SETQ LET-BINDINGS (SECOND BINDING-TYPE))))
+                  (EQL (LENGTH (SECOND EXPANSION))
+                       (LENGTH LET-BINDINGS))
+                  (NULL (CDDR EXPANSION)))                   (IL:* IL:\; 
+                                                      "A simple LAMBDA form can be treated as LET ")
+             (SETQ LET-BODY (CDDR BINDING-TYPE))
+             (SETQ LET-BINDINGS (MAPCAR #'LIST LET-BINDINGS (SECOND EXPANSION)))
+             (SETQ BINDING-TYPE 'LET)
+             (GO HANDLE-LET)))
+
+    (IL:* IL:|;;| "Fall thru if not a LET")
+
+         (COND
+            (EXPANDEDP                                       (IL:* IL:\; "try expanding again")
+                   (GO EXPAND))
+            (T                                               (IL:* IL:\; 
+                                                           "Boring--return form as the body ")
+               (RETURN EXPANSION)))
+     HANDLE-LET
+         (RETURN (LET ((LOCALS (VARIABLES-FROM-LET LET-BINDINGS))
+                       EXTRA-BODY SPECIALS)
+                      (MULTIPLE-VALUE-BIND (LOCALDECLS OTHERDECLS LET-BODY)
+                          (PARSE-DECLARATIONS LET-BODY LOCALS)
+                        (COND
+                           ((SETQ SPECIALS (EXTRACT-SPECIAL-BINDINGS LOCALS LOCALDECLS))
+                            (MAYBE-WARN (COND
+                                               ((FIND-IF #'VARIABLE-GLOBALLY-SPECIAL-P SPECIALS)
+                                                             (IL:* IL:\; 
+                                                  "This could be the fault of a user proclamation ")
+                                                :USER)
+                                               (T :DEFINITION))
+                                   
+                                "Couldn't optimize ~S because expansion of ~S binds specials ~(~S ~)"
+                                   PARENT-NAME CLAUSE SPECIALS)
+                            :ABORT)
+                           (T (VALUES (COND
+                                         ((NOT (CONSP LET-BODY))
+                                                             (IL:* IL:\; 
+                              "Null body of LET?  unlikely, but someone else will likely complain ")
+                                          NIL)
+                                         ((NULL (CDR LET-BODY))
+                                                             (IL:* IL:\; 
+                                    "A single expression, which we hope is (function (lambda...)) ")
+                                          (FIRST LET-BODY))
+                                         (T 
+
+                                 (IL:* IL:|;;| "More than one expression.  These are forms to evaluate after the bindings but before the generator form is returned.  Save them to evaluate in the next convenient place.  Note that this is ok, as there is no construct that can cause a LET to return prematurely (without returning also from some surrounding construct). ")
+
+                                            (SETQ EXTRA-BODY (BUTLAST LET-BODY))
+                                            (CAR (LAST LET-BODY))))
+                                     BINDING-TYPE LET-BINDINGS LOCALDECLS OTHERDECLS EXTRA-BODY))))))
+    ))
+
+(DEFUN VARIABLES-FROM-LET (BINDINGS)
+
+   (IL:* IL:|;;| "Return a list of the variables bound in the first argument to LET[*].")
+
+   (MAPCAR #'(LAMBDA (BINDING)
+                    (IF (CONSP BINDING)
+                        (FIRST BINDING)
+                        BINDING))
+          BINDINGS))
+
+(DEFUN ITERATE-TRANSFORM-BODY (LET-BODY ITERATE-ENV RENAMED-VARS FINISH-ARG FINISH-FORM 
+                                         BOUND-VARS CLAUSE)
+
+(IL:* IL:|;;;| "This is the second major transformation for a single iterate clause. LET-BODY is the body of the iterator after we have extracted its local variables and declarations.  We have two main tasks: (1) Substitute internal temporaries for occurrences of the LET variables; the alist RENAMED-VARS specifies this transformation.  (2) Substitute evaluation of FINISH-FORM for any occurrence of (funcall FINISH-ARG).  Along the way, we check for forms that would invalidate these transformations: occurrence of FINISH-ARG outside of a funcall, and free reference to any element of BOUND-VARS.  CLAUSE & TYPE are the original ITERATE clause and its type (ITERATE or ITERATE*), for purpose of error messages.  On success, we return the transformed body; on failure, :ABORT. ")
+
+   (WALK-FORM LET-BODY ITERATE-ENV #'(LAMBDA (FORM CONTEXT ENV)
+                                            (DECLARE (IGNORE CONTEXT))
+
+                                            (IL:* IL:|;;| 
+      "Need to substitute RENAMED-VARS, as well as turn (FUNCALL finish-arg) into the finish form ")
+
+                                            (COND
+                                               ((SYMBOLP FORM)
+                                                (LET (RENAMING)
+                                                     (COND
+                                                        ((AND (EQ FORM FINISH-ARG)
+                                                              (VARIABLE-SAME-P FORM ENV 
+                                                                     ITERATE-ENV))
+                                                             (IL:* IL:\; 
+                 "An occurrence of the finish arg outside of FUNCALL context--I can't handle this ")
+                                                         (MAYBE-WARN :DEFINITION "Couldn't optimize iterate form because generator ~S does something with its FINISH arg besides FUNCALL it."
+                                                                (SECOND CLAUSE))
+                                                         (RETURN-FROM ITERATE-TRANSFORM-BODY :ABORT))
+                                                        ((AND (SETQ RENAMING (ASSOC FORM RENAMED-VARS
+                                                                                    ))
+                                                              (VARIABLE-SAME-P FORM ENV 
+                                                                     ITERATE-ENV))
+                                                             (IL:* IL:\; 
+                                                     "Reference to one of the vars we're renaming ")
+                                                         (CDR RENAMING))
+                                                        ((AND (MEMBER FORM BOUND-VARS)
+                                                              (VARIABLE-SAME-P FORM ENV 
+                                                                     ITERATE-ENV))
+                                                             (IL:* IL:\; "FORM is a var that is bound in this same ITERATE, or bound later in this ITERATE*. This is a conflict. ")
+                                                         (MAYBE-WARN :USER "Couldn't optimize iterate form because generator ~S is closed over ~S, in conflict with a subsequent iteration variable."
+                                                                (SECOND CLAUSE)
+                                                                FORM)
+                                                         (RETURN-FROM ITERATE-TRANSFORM-BODY :ABORT))
+                                                        (T FORM))))
+                                               ((AND (CONSP FORM)
+                                                     (EQ (FIRST FORM)
+                                                         'FUNCALL)
+                                                     (EQ (SECOND FORM)
+                                                         FINISH-ARG)
+                                                     (VARIABLE-SAME-P (SECOND FORM)
+                                                            ENV ITERATE-ENV))
+                                                             (IL:* IL:\; 
+                                                           "(FUNCALL finish-arg) => finish-form ")
+                                                (UNLESS (NULL (CDDR FORM))
+                                                    (MAYBE-WARN :DEFINITION 
+                              "Generator for ~S applied its finish arg to > 0 arguments ~S--ignored."
+                                                           (SECOND CLAUSE)
+                                                           (CDDR FORM)))
+                                                FINISH-FORM)
+                                               (T FORM)))))
+
+(DEFUN PARSE-DECLARATIONS (TAIL LOCALS)
+
+   (IL:* IL:|;;| "Extract the declarations from the head of TAIL and divide them into 2 classes: declares about variables in the list LOCALS, and all other declarations.  Returns 3 values: those 2 lists plus the remainder of TAIL. ")
+
+   (LET
+    (LOCALDECLS OTHERDECLS FORM)
+    (LOOP
+     (UNLESS (AND TAIL (CONSP (SETQ FORM (CAR TAIL)))
+                  (EQ (CAR FORM)
+                      'DECLARE))
+         (RETURN (VALUES LOCALDECLS OTHERDECLS TAIL)))
+     (MAPC
+      #'(LAMBDA (DECL)
+               (CASE (FIRST DECL)
+                   ((INLINE NOTINLINE OPTIMIZE)              (IL:* IL:\; 
+                                                           "These don't talk about vars")
+                      (PUSH DECL OTHERDECLS))
+                   (T                                        (IL:* IL:\; 
+                                                           "Assume all other kinds are for vars ")
+                      (LET* ((VARS (IF (EQ (FIRST DECL)
+                                           'TYPE)
+                                       (CDDR DECL)
+                                       (CDR DECL)))
+                             (L (INTERSECTION LOCALS VARS))
+                             OTHER)
+                            (COND
+                               ((NULL L)                     (IL:* IL:\; "None talk about LOCALS")
+                                (PUSH DECL OTHERDECLS))
+                               ((NULL (SETQ OTHER (SET-DIFFERENCE VARS L)))
+                                                             (IL:* IL:\; "All talk about LOCALS")
+                                (PUSH DECL LOCALDECLS))
+                               (T                            (IL:* IL:\; "Some of each")
+                                  (LET ((HEAD (CONS 'TYPE (AND (EQ (FIRST DECL)
+                                                                   'TYPE)
+                                                               (LIST (SECOND DECL))))))
+                                       (PUSH (APPEND HEAD OTHER)
+                                             OTHERDECLS)
+                                       (PUSH (APPEND HEAD L)
+                                             LOCALDECLS))))))))
+      (CDR FORM))
+     (POP TAIL))))
+
+(DEFUN EXTRACT-SPECIAL-BINDINGS (VARS DECLS)
+
+   (IL:* IL:|;;| 
+"Return the subset of VARS that are special, either globally or because of a declaration in DECLS ")
+
+   (LET ((SPECIALS (REMOVE-IF-NOT #'VARIABLE-GLOBALLY-SPECIAL-P VARS)))
+        (DOLIST (D DECLS)
+            (WHEN (EQ (CAR D)
+                      'SPECIAL)
+                (SETQ SPECIALS (UNION SPECIALS (INTERSECTION VARS (CDR D))))))
+        SPECIALS))
+
+(DEFUN FUNCTION-LAMBDA-P (FORM &OPTIONAL NARGS)
+
+   (IL:* IL:|;;| "If FORM is #'(LAMBDA bindings . body) and bindings is of length NARGS, return the lambda expression ")
+
+   (LET (ARGS BODY)
+        (AND (CONSP FORM)
+             (EQ (CAR FORM)
+                 'FUNCTION)
+             (CONSP (SETQ FORM (CDR FORM)))
+             (NULL (CDR FORM))
+             (CONSP (SETQ FORM (CAR FORM)))
+             (EQ (CAR FORM)
+                 'LAMBDA)
+             (CONSP (SETQ BODY (CDR FORM)))
+             (LISTP (SETQ ARGS (CAR BODY)))
+             (OR (NULL NARGS)
+                 (EQL (LENGTH ARGS)
+                      NARGS))
+             FORM)))
+
+(DEFUN RENAME-LET-BINDINGS (LET-BINDINGS BINDING-TYPE ENV LEFTOVER-BODY &OPTIONAL TEMPVARFN)
+
+   (IL:* IL:|;;| "Perform the alpha conversion required for \"LET eversion\" of (LET[*] LET-BINDINGS . body)--rename each of the variables to an internal name. Returns 2 values: a new set of LET bindings and the alist of old var names to new (so caller can walk the body doing the rest of the renaming). BINDING-TYPE is one of LET or LET*.  LEFTOVER-BODY is optional list of forms that must be eval'ed before the first binding happens.  ENV is the macro expansion environment, in case we have to walk a LET*.  TEMPVARFN is a function of no args to return a temporary var; if omitted, we use GENSYM. ")
+
+   (LET (RENAMED-VARS)
+        (VALUES (MAPCAR #'(LAMBDA (BINDING)
+                                 (LET ((VALUEFORM (COND
+                                                     ((NOT (CONSP BINDING))
+                                                             (IL:* IL:\; "No initial value")
+                                                      NIL)
+                                                     ((OR (EQ BINDING-TYPE 'LET)
+                                                          (NULL RENAMED-VARS))
+                                                             (IL:* IL:\; 
+                                       "All bindings are in parallel, so none can refer to others ")
+                                                      (SECOND BINDING))
+                                                     (T      (IL:* IL:\; 
+               "In a LET*, have to substitute vars in the 2nd and subsequent initialization forms ")
+                                                        (RENAME-VARIABLES (SECOND BINDING)
+                                                               RENAMED-VARS ENV))))
+                                       (NEWVAR (IF TEMPVARFN
+                                                   (FUNCALL TEMPVARFN)
+                                                   (GENSYM))))
+                                      (PUSH (CONS (IF (CONSP BINDING)
+                                                      (FIRST BINDING)
+                                                      BINDING)
+                                                  NEWVAR)
+                                            RENAMED-VARS)    (IL:* IL:\; 
+                        "Add new variable to the list AFTER we have walked the initial value form ")
+                                      (WHEN LEFTOVER-BODY
+
+                                          (IL:* IL:|;;| "Previous clause had some computation to do after its bindings.  Here is the first opportunity to do it ")
+
+                                          (SETQ VALUEFORM `(PROGN ,@LEFTOVER-BODY ,VALUEFORM))
+                                          (SETQ LEFTOVER-BODY NIL))
+                                      (LIST NEWVAR VALUEFORM)))
+                       LET-BINDINGS)
+               RENAMED-VARS)))
+
+(DEFUN RENAME-VARIABLES (FORM ALIST ENV)
+
+   (IL:* IL:|;;| "Walks FORM, renaming occurrences of the key variables in ALIST with their corresponding values.  ENV is FORM's environment, so we can make sure we are talking about the same variables. ")
+
+   (WALK-FORM FORM ENV #'(LAMBDA (FORM CONTEXT SUBENV)
+                                (DECLARE (IGNORE CONTEXT))
+                                (LET (PAIR)
+                                     (COND
+                                        ((AND (SYMBOLP FORM)
+                                              (SETQ PAIR (ASSOC FORM ALIST))
+                                              (VARIABLE-SAME-P FORM SUBENV ENV))
+                                         (CDR PAIR))
+                                        (T FORM))))))
+
+(DEFUN MV-SETQ (VARS EXPR)
+
+   (IL:* IL:|;;| "Produces (MULTIPLE-VALUE-SETQ vars expr), except that I'll optimize some of the simple cases for benefit of compilers that don't, and I don't care what the value is, and I know that the variables need not be set in parallel, since they can't be used free in EXPR ")
+
+   (COND
+      ((NULL VARS)                                           (IL:* IL:\; "EXPR is a side-effect")
+       EXPR)
+      ((NOT (CONSP VARS))                                    (IL:* IL:\; 
+                                    "This is an error, but I'll let MULTIPLE-VALUE-SETQ report it ")
+       `(MULTIPLE-VALUE-SETQ ,VARS ,EXPR))
+      ((AND (LISTP EXPR)
+            (EQ (CAR EXPR)
+                'VALUES))
+
+       (IL:* IL:|;;| "(mv-setq (a b c) (values x y z)) can be reduced to a parallel setq (psetq returns nil, but I don't care about returned value).  Do this even for the single variable case so that we catch (mv-setq (a) (values x y)) ")
+
+       (POP EXPR)                                            (IL:* IL:\; "VALUES")
+       `(SETQ ,@(MAPCON #'(LAMBDA (TAIL)
+                                 (LIST (CAR TAIL)
+                                       (COND
+                                          ((OR (CDR TAIL)
+                                               (NULL (CDR EXPR)))
+                                                             (IL:* IL:\; 
+                                                           "One result expression for this var ")
+                                           (POP EXPR))
+                                          (T                 (IL:* IL:\; 
+                            "More expressions than vars, so arrange to evaluate all the rest now. ")
+                                             (CONS 'PROG1 EXPR)))))
+                       VARS)))
+      ((NULL (CDR VARS))                                     (IL:* IL:\; "Simple one variable case")
+       `(SETQ ,(CAR VARS)
+              ,EXPR))
+      (T                                                     (IL:* IL:\; 
+                                                           "General case--I know nothing")
+         `(MULTIPLE-VALUE-SETQ ,VARS ,EXPR))))
+
+(DEFUN VARIABLE-SAME-P (VAR ENV1 ENV2)
+   (EQ (VARIABLE-LEXICAL-P VAR ENV1)
+       (VARIABLE-LEXICAL-P VAR ENV2)))
+
+(DEFUN MAYBE-WARN (TYPE &REST WARN-ARGS)
+
+   (IL:* IL:|;;| "Issue a warning about not being able to optimize this thing.  TYPE is one of :DEFINITION, meaning the definition is at fault, and :USER, meaning the user's code is at fault. ")
+
+   (WHEN (CASE *ITERATE-WARNINGS*
+             ((NIL) NIL)
+             ((:USER) (EQ TYPE :USER))
+             (T T))
+       (APPLY #'WARN WARN-ARGS)))
+
+
+
+(IL:* IL:|;;| "Sample iterators")
+
+
+(DEFMACRO INTERVAL (&WHOLE WHOLE &KEY FROM DOWNFROM TO DOWNTO ABOVE BELOW BY TYPE)
+   (COND
+      ((AND FROM DOWNFROM)
+       (ERROR "Can't use both FROM and DOWNFROM in ~S" WHOLE))
+      ((CDR (REMOVE NIL (LIST TO DOWNTO ABOVE BELOW)))
+       (ERROR "Can't use more than one limit keyword in ~S" WHOLE))
+      (T
+       (LET*
+        ((DOWN (OR DOWNFROM DOWNTO ABOVE))
+         (LIMIT (OR TO DOWNTO ABOVE BELOW))
+         (INC (COND
+                 ((NULL BY)
+                  1)
+                 ((CONSTANTP BY)                             (IL:* IL:\; 
+                                                           "Can inline this increment")
+                  BY))))
+        `(LET ((FROM ,(OR FROM DOWNFROM 0))
+               ,@(AND LIMIT `((TO ,LIMIT)))
+               ,@(AND (NULL INC)
+                      `((BY ,BY))))
+              ,@(AND TYPE `((DECLARE (TYPE ,TYPE FROM ,@(AND LIMIT '(TO))
+                                               ,@(AND (NULL INC)
+                                                      `(BY))))))
+              #'(LAMBDA (FINISH)
+                       ,@(COND
+                            ((NULL LIMIT)                    (IL:* IL:\; 
+                                                           "We won't use the FINISH arg")
+                             '((DECLARE (IGNORE FINISH)))))
+                       (PROG1 ,(COND
+                                  (LIMIT                     (IL:* IL:\; 
+                           "Test the limit.  If ok, return current value and increment, else quit ")
+                                         `(IF (,(COND
+                                                   (ABOVE '>)
+                                                   (BELOW '<)
+                                                   (DOWN '>=)
+                                                   (T '<=))
+                                               FROM TO)
+                                              FROM
+                                              (FUNCALL FINISH)))
+                                  (T                         (IL:* IL:\; "No test")
+                                     'FROM))
+                           (SETQ FROM (,(IF DOWN
+                                            '-
+                                            '+)
+                                       FROM
+                                       ,(OR INC 'BY))))))))))
+
+(DEFMACRO LIST-ELEMENTS (LIST &KEY (BY '#'CDR))
+   `(LET ((TAIL ,LIST))
+         #'(LAMBDA (FINISH)
+                  (PROG1 (IF (ENDP TAIL)
+                             (FUNCALL FINISH)
+                             (FIRST TAIL))
+                      (SETQ TAIL (FUNCALL ,BY TAIL))))))
+
+(DEFMACRO LIST-TAILS (LIST &KEY (BY '#'CDR))
+   `(LET ((TAIL ,LIST))
+         #'(LAMBDA (FINISH)
+                  (PROG1 (IF (ENDP TAIL)
+                             (FUNCALL FINISH)
+                             TAIL)
+                      (SETQ TAIL (FUNCALL ,BY TAIL))))))
+
+(DEFMACRO ELEMENTS (SEQUENCE)
+   "Generates successive elements of SEQUENCE, with second value being the index.  Use (ELEMENTS (THE type arg)) if you care about the type."
+   (LET* ((TYPE (AND (CONSP SEQUENCE)
+                     (EQ (FIRST SEQUENCE)
+                         'THE)
+                     (SECOND SEQUENCE)))
+          (ACCESSOR (IF TYPE
+                        (SEQUENCE-ACCESSOR TYPE)
+                        'ELT))
+          (LISTP (EQ TYPE 'LIST)))
+
+         (IL:* IL:|;;| "If type is given via THE, we may be able to generate a good accessor here for the benefit of implementations that aren't smart about (ELT (THE STRING FOO)).  I'm not bothering to keep the THE inside the body, however, since I assume any compiler that would understand (AREF (THE SIMPLE-ARRAY S)) would also understand that (AREF S) is the same when I bound S to (THE SIMPLE-ARRAY foo) and never modified it. If sequence is declared to be a list, it's better to cdr down it, so we have some extra cases here.  Normally folks would write LIST-ELEMENTS, but maybe they wanted to get the index for free... ")
+
+         `(LET* ((INDEX 0)
+                 (S ,SEQUENCE)
+                 ,@(AND (NOT LISTP)
+                        '((SIZE (LENGTH S)))))
+                #'(LAMBDA (FINISH)
+                         (VALUES (COND
+                                    ,(IF LISTP
+                                         '((NOT (ENDP S))
+                                           (POP S))
+                                         `((< INDEX SIZE)
+                                           (,ACCESSOR S INDEX)))
+                                    (T (FUNCALL FINISH)))
+                                (PROG1 INDEX
+                                    (SETQ INDEX (1+ INDEX))))))))
+
+(DEFMACRO PLIST-ELEMENTS (PLIST)
+   "Generates each time 2 items, the indicator and the value."
+   `(LET ((TAIL ,PLIST))
+         #'(LAMBDA (FINISH)
+                  (VALUES (IF (ENDP TAIL)
+                              (FUNCALL FINISH)
+                              (FIRST TAIL))
+                         (PROG1 (IF (ENDP (SETQ TAIL (CDR TAIL)))
+                                    (FUNCALL FINISH)
+                                    (FIRST TAIL))
+                             (SETQ TAIL (CDR TAIL)))))))
+
+(DEFUN SEQUENCE-ACCESSOR (TYPE)
+
+   (IL:* IL:|;;| 
+ "returns the function with which most efficiently to make accesses to a sequence of type TYPE. ")
+
+   (CASE (IF (CONSP TYPE)                                    (IL:* IL:\; "e.g., (VECTOR FLOAT *)")
+             (CAR TYPE)
+             TYPE)
+       ((ARRAY SIMPLE-ARRAY VECTOR) 'AREF)
+       (SIMPLE-VECTOR 'SVREF)
+       (STRING 'CHAR)
+       (SIMPLE-STRING 'SCHAR)
+       (BIT-VECTOR 'BIT)
+       (SIMPLE-BIT-VECTOR 'SBIT)
+       (T 'ELT)))
+
+
+
+(IL:* IL:|;;| "These \"iterators\" may be withdrawn")
+
+
+(DEFMACRO EACHTIME (EXPR)
+   `#'(LAMBDA (FINISH)
+             (DECLARE (IGNORE FINISH))
+             ,EXPR))
+
+(DEFMACRO WHILE (EXPR)
+   `#'(LAMBDA (FINISH)
+             (UNLESS ,EXPR (FUNCALL FINISH))))
+
+(DEFMACRO UNTIL (EXPR)
+   `#'(LAMBDA (FINISH)
+             (WHEN ,EXPR (FUNCALL FINISH))))
+
+
+
+(IL:* IL:\; "GATHERING macro")
+
+
+(DEFMACRO GATHERING (CLAUSES &BODY BODY &ENVIRONMENT ENV)
+   (OR (OPTIMIZE-GATHERING-FORM CLAUSES BODY ENV)
+       (SIMPLE-EXPAND-GATHERING-FORM CLAUSES BODY ENV)))
+
+(DEFMACRO WITH-GATHERING (CLAUSES GATHER-BODY &BODY USE-BODY)
+   "Binds the variables specified in CLAUSES to the result of (GATHERING clauses gather-body) and evaluates the forms in USE-BODY inside that contour."
+
+   (IL:* IL:|;;| "We may optimize this a little better later for those compilers that don't do a good job on (m-v-bind vars (... (values ...)) ...). ")
+
+   `(MULTIPLE-VALUE-BIND ,(MAPCAR #'CAR CLAUSES)
+        (GATHERING ,CLAUSES ,GATHER-BODY)
+      ,@USE-BODY))
+
+(DEFUN SIMPLE-EXPAND-GATHERING-FORM (CLAUSES BODY ENV)
+   (DECLARE (IGNORE ENV))
+
+   (IL:* IL:|;;| 
+ "The \"formal semantics\" of GATHERING.  We use this only in cases that can't be optimized. ")
+
+   (LET
+    ((ACC-NAMES (MAPCAR #'FIRST (IF (SYMBOLP CLAUSES)        (IL:* IL:\; 
+                                                        "Shorthand using anonymous gathering site ")
+                                    (SETQ CLAUSES `((*ANONYMOUS-GATHERING-SITE* (,CLAUSES))))
+                                    CLAUSES)))
+     (REALIZER-NAMES (MAPCAR #'(LAMBDA (BINDING)
+                                      (DECLARE (IGNORE BINDING))
+                                      (GENSYM))
+                            CLAUSES)))
+    `(MULTIPLE-VALUE-CALL
+      #'(LAMBDA ,(MAPCAN #'LIST ACC-NAMES REALIZER-NAMES)
+               (FLET ((GATHER (VALUE &OPTIONAL (ACCUMULATOR *ANONYMOUS-GATHERING-SITE*))
+                             (FUNCALL ACCUMULATOR VALUE)))
+                     ,@BODY
+                     (VALUES ,@(MAPCAR #'(LAMBDA (RNAME)
+                                                `(FUNCALL ,RNAME))
+                                      REALIZER-NAMES))))
+      ,@(MAPCAR #'SECOND CLAUSES))))
+
+(DEFVAR *ACTIVE-GATHERERS* NIL
+   "List of GATHERING bindings currently active during macro expansion)")
+
+(DEFVAR *ANONYMOUS-GATHERING-SITE* NIL
+   "Variable used in formal expansion of an abbreviated GATHERING form (one with anonymous gathering site)."
+)
+
+(DEFUN OPTIMIZE-GATHERING-FORM (CLAUSES BODY GATHERING-ENV)
+   (LET*
+    (ACC-INFO LEFTOVER-BODY TOP-BINDINGS FINISH-FORMS TOP-DECLS)
+    (DOLIST (CLAUSE (IF (SYMBOLP CLAUSES)                    (IL:* IL:\; "A shorthand")
+                        `((*ANONYMOUS-GATHERING-SITE* (,CLAUSES)))
+                        CLAUSES))
+        (MULTIPLE-VALUE-BIND (LET-BODY BINDING-TYPE LET-BINDINGS LOCALDECLS OTHERDECLS EXTRA-BODY)
+            (EXPAND-INTO-LET (SECOND CLAUSE)
+                   'GATHERING GATHERING-ENV)
+          (PROG* ((ACC-VAR (FIRST CLAUSE))
+                  RENAMED-VARS ACCUMULATOR REALIZER)
+                 (WHEN (AND (CONSP LET-BODY)
+                            (EQ (CAR LET-BODY)
+                                'VALUES)
+                            (CONSP (SETQ LET-BODY (CDR LET-BODY)))
+                            (SETQ ACCUMULATOR (FUNCTION-LAMBDA-P (CAR LET-BODY)))
+                            (CONSP (SETQ LET-BODY (CDR LET-BODY)))
+                            (SETQ REALIZER (FUNCTION-LAMBDA-P (CAR LET-BODY)
+                                                  0))
+                            (NULL (CDR LET-BODY)))
+
+                     (IL:* IL:|;;| "Macro returned something of the form (VALUES #'(lambda (value)")
+
+                     (IL:* IL:|;;| 
+   "..) #'(lambda () ...)), a function to accumulate values and a function to realize the result. ")
+
+                     (WHEN BINDING-TYPE
+
+                         (IL:* IL:|;;| "Gatherer expanded into a LET")
+
+                         (COND
+                            (OTHERDECLS (MAYBE-WARN :DEFINITION "Couldn't optimize GATHERING clause ~S because its expansion carries declarations about more than the bound variables: ~S"
+                                               (SECOND CLAUSE)
+                                               `(DECLARE ,@OTHERDECLS))
+                                   (GO PUNT)))
+                         (WHEN LET-BINDINGS
+
+                             (IL:* IL:|;;| "The first transformation we want to perform is a variant of \"LET-eversion\": turn (mv-bind (acc real) (let (..bindings..) (values #'(lambda ...) #'(lambda ")
+
+                             (IL:* IL:|;;| "..))) ..body..) into (let* (..bindings.. (acc #'(lambda ...)) (real #'(lambda ...))) ..body..).  This transformation is valid if nothing in body refers to any of the bindings, something we can assure by alpha-converting the inner let (substituting new names for each var).  Of course, none of those vars can be special, but we already checked for that above. ")
+
+                             (MULTIPLE-VALUE-SETQ (LET-BINDINGS RENAMED-VARS)
+                                    (RENAME-LET-BINDINGS LET-BINDINGS BINDING-TYPE GATHERING-ENV
+                                           LEFTOVER-BODY))
+                             (SETQ TOP-BINDINGS (NCONC TOP-BINDINGS LET-BINDINGS))
+                             (SETQ LEFTOVER-BODY NIL)        (IL:* IL:\; 
+                                     "If there was any leftover from previous, it is now consumed ")
+                             ))
+                     (SETQ LEFTOVER-BODY (NCONC LEFTOVER-BODY EXTRA-BODY))
+                                                             (IL:* IL:\; 
+                                                          "Computation to do after these bindings ")
+                     (PUSH (CONS ACC-VAR (RENAME-AND-CAPTURE-VARIABLES ACCUMULATOR RENAMED-VARS 
+                                                GATHERING-ENV))
+                           ACC-INFO)
+                     (SETQ REALIZER (RENAME-VARIABLES REALIZER RENAMED-VARS GATHERING-ENV))
+                     (PUSH (COND
+                              ((NULL (CDDDR REALIZER))       (IL:* IL:\; 
+                                                           "Simple (LAMBDA () expr) => expr ")
+                               (THIRD REALIZER))
+                              (T                             (IL:* IL:\; 
+                                     "There could be declarations or something, so leave as a LET ")
+                                 (CONS 'LET (CDR REALIZER))))
+                           FINISH-FORMS)
+                     (UNLESS (NULL LOCALDECLS)               (IL:* IL:\; 
+                                   "Declarations about the LET variables also has to percolate up ")
+                         (SETQ TOP-DECLS (NCONC TOP-DECLS (SUBLIS RENAMED-VARS LOCALDECLS))))
+                     (RETURN))
+                 (MAYBE-WARN :DEFINITION "Couldn't optimize GATHERING clause ~S because its expansion is not of the form (VALUES #'(LAMBDA ...) #'(LAMBDA () ...))"
+                        (SECOND CLAUSE))
+             PUNT
+                 (LET ((GS (GENSYM))
+                       (EXPANSION `(MULTIPLE-VALUE-LIST ,(SECOND CLAUSE))))
+                                                             (IL:* IL:\; 
+                "Slow way--bind gensym to the macro expansion, and we will funcall it in the body ")
+                      (PUSH (LIST ACC-VAR GS)
+                            ACC-INFO)
+                      (PUSH `(FUNCALL (CADR ,GS))
+                            FINISH-FORMS)
+                      (SETQ TOP-BINDINGS
+                            (NCONC TOP-BINDINGS
+                                   (LIST (LIST GS
+                                               (COND
+                                                  (LEFTOVER-BODY
+                                                   `(PROGN ,@(PROG1 LEFTOVER-BODY (SETQ LEFTOVER-BODY
+                                                                                        NIL))
+                                                           ,EXPANSION))
+                                                  (T EXPANSION))))))))))
+    (SETQ BODY (WALK-GATHERING-BODY BODY GATHERING-ENV ACC-INFO))
+    (COND
+       ((EQ BODY :ABORT)                                     (IL:* IL:\; 
+                                                           "Couldn't finish expansion")
+        NIL)
+       (T `(LET* ,TOP-BINDINGS ,@(AND TOP-DECLS `((DECLARE ,@TOP-DECLS)))
+                 ,BODY
+                 ,(COND
+                     ((NULL (CDR FINISH-FORMS))              (IL:* IL:\; "just a single value")
+                      (CAR FINISH-FORMS))
+                     (T `(VALUES ,@(REVERSE FINISH-FORMS)))))))))
+
+(DEFUN RENAME-AND-CAPTURE-VARIABLES (FORM ALIST ENV)
+
+   (IL:* IL:|;;| "Walks FORM, renaming occurrences of the key variables in ALIST with their corresponding values, and capturing any other free variables. Returns a list of the new form and the list of other closed-over vars.  ENV is FORM's environment, so we can make sure we are talking about the same variables. ")
+
+   (LET (CLOSED)
+        (LIST (WALK-FORM FORM ENV #'(LAMBDA (FORM CONTEXT SUBENV)
+                                           (DECLARE (IGNORE CONTEXT))
+                                           (LET (PAIR)
+                                                (COND
+                                                   ((OR (NOT (SYMBOLP FORM))
+                                                        (NOT (VARIABLE-SAME-P FORM SUBENV ENV)))
+                                                             (IL:* IL:\; 
+                                                       "non-variable or one that has been rebound ")
+                                                    FORM)
+                                                   ((SETQ PAIR (ASSOC FORM ALIST))
+                                                             (IL:* IL:\; "One to rename")
+                                                    (CDR PAIR))
+                                                   (T        (IL:* IL:\; "var is free")
+                                                      (PUSHNEW FORM CLOSED)
+                                                      FORM)))))
+              CLOSED)))
+
+(DEFUN WALK-GATHERING-BODY (BODY GATHERING-ENV ACC-INFO)
+
+   (IL:* IL:|;;| "Walk the body of (GATHERING (...) . BODY) in environment GATHERING-ENV. ACC-INFO is a list of information about each of the gathering \"bindings\" in the form, in the form (var gatheringfn freevars env) ")
+
+   (LET ((*ACTIVE-GATHERERS* (NCONC (MAPCAR #'CAR ACC-INFO)
+                                    *ACTIVE-GATHERERS*)))
+
+        (IL:* IL:|;;| "*ACTIVE-GATHERERS* tells us what vars are currently legal as GATHER targets.  This is so that when we encounter a GATHER not belonging to us we can know whether to warn about it. ")
+
+        (WALK-FORM
+         (CONS 'PROGN BODY)
+         GATHERING-ENV
+         #'(LAMBDA (FORM CONTEXT ENV)
+                  (DECLARE (IGNORE CONTEXT))
+                  (LET (INFO SITE)
+                       (COND
+                          ((CONSP FORM)
+                           (COND
+                              ((NOT (EQ (CAR FORM)
+                                        'GATHER))            (IL:* IL:\; 
+                                                           "We only care about GATHER")
+                               (WHEN (AND (EQ (CAR FORM)
+                                              'FUNCTION)
+                                          (EQ (CADR FORM)
+                                              'GATHER))      (IL:* IL:\; 
+                                                         "Passed as functional--can't macroexpand ")
+                                   (MAYBE-WARN :USER 
+                                         "Can't optimize GATHERING because of reference to #'GATHER."
+                                          )
+                                   (RETURN-FROM WALK-GATHERING-BODY :ABORT))
+                               FORM)
+                              ((SETQ INFO (ASSOC (SETQ SITE (IF (NULL (CDDR FORM))
+                                                                '*ANONYMOUS-GATHERING-SITE*
+                                                                (THIRD FORM)))
+                                                 ACC-INFO))  (IL:* IL:\; 
+                  "One of ours--expand (GATHER value var).  INFO = (var gatheringfn freevars env) ")
+                               (UNLESS (NULL (CDDDR FORM))
+                                      (WARN "Extra arguments (> 2) in ~S discarded." FORM))
+                               (LET ((FN (SECOND INFO)))
+                                    (COND
+                                       ((SYMBOLP FN)         (IL:* IL:\; "Unoptimized case--just call the gatherer.  FN is the gensym that we bound to the list of two values returned from the gatherer. ")
+                                        `(FUNCALL (CAR ,FN)
+                                                ,(SECOND FORM)))
+                                       (T                    (IL:* IL:\; 
+                                                           "FN = (lambda (value) ...)")
+                                          (DOLIST (S (THIRD INFO))
+                                              (UNLESS (OR (VARIABLE-SAME-P S ENV GATHERING-ENV)
+                                                          (AND (VARIABLE-SPECIAL-P S ENV)
+                                                               (VARIABLE-SPECIAL-P S GATHERING-ENV)))
+
+                                 (IL:* IL:|;;| "Some var used free in the LAMBDA form has been rebound between here and the parent GATHERING form, so can't substitute the lambda.  Ok if it's a special reference both here and in the LAMBDA, because then it's not closed over. ")
+
+                                                  (MAYBE-WARN :USER "Can't optimize GATHERING because the expansion closes over the variable ~S, which is rebound around a GATHER for it."
+                                                         S)
+                                                  (RETURN-FROM WALK-GATHERING-BODY :ABORT)))
+
+                                 (IL:* IL:|;;| "Return ((lambda (value) ...) actual-value).  In many cases we could simplify this further by substitution, but we'd have to be careful (for example, we would need to alpha-convert any LET we found inside).  Any decent compiler will do it for us. ")
+
+                                          (LIST FN (SECOND FORM))))))
+                              ((AND (SETQ INFO (MEMBER SITE *ACTIVE-GATHERERS*))
+                                    (OR (EQ SITE '*ANONYMOUS-GATHERING-SITE*)
+                                        (VARIABLE-SAME-P SITE ENV (FOURTH INFO))))
+                                                             (IL:* IL:\; "Some other GATHERING will take care of this form, so pass it up for now. Environment check is to make sure nobody shadowed it between here and there ")
+                               FORM)
+                              (T                             (IL:* IL:\; 
+                                                           "Nobody's going to handle it")
+                                 (IF (EQ SITE '*ANONYMOUS-GATHERING-SITE*)
+                                                             (IL:* IL:\; 
+    "More likely that she forgot to mention the site than forget to write an anonymous gathering. ")
+                                     (WARN "There is no gathering site specified in ~S." FORM)
+                                     (WARN 
+                                   "The site ~S in ~S is not defined in an enclosing GATHERING form."
+                                           SITE FORM))       (IL:* IL:\; 
+                           "Turn it into something else so we don't warn twice in the nested case ")
+                                 `(%ORPHANED-GATHER ,@(CDR FORM)))))
+                          ((AND (SYMBOLP FORM)
+                                (SETQ INFO (ASSOC FORM ACC-INFO))
+                                (VARIABLE-SAME-P FORM ENV GATHERING-ENV))
+                                                             (IL:* IL:\; 
+                                   "A variable reference to a gather binding from environment TEM ")
+                           (MAYBE-WARN :USER 
+                "Can't optimize GATHERING because site variable ~S is used outside of a GATHER form."
+                                  FORM)
+                           (RETURN-FROM WALK-GATHERING-BODY :ABORT))
+                          (T FORM)))))))
+
+
+
+(IL:* IL:|;;| "Sample gatherers")
+
+
+(DEFMACRO COLLECTING (&KEY INITIAL-VALUE)
+   `(LET* ((HEAD ,INITIAL-VALUE)
+           (TAIL ,(AND INITIAL-VALUE `(LAST HEAD))))
+          (VALUES #'(LAMBDA (VALUE)
+                           (IF (NULL HEAD)
+                               (SETQ HEAD (SETQ TAIL (LIST VALUE)))
+                               (SETQ TAIL (CDR (RPLACD TAIL (LIST VALUE))))))
+                 #'(LAMBDA NIL HEAD))))
+
+(DEFMACRO JOINING (&KEY INITIAL-VALUE)
+   `(LET ((RESULT ,INITIAL-VALUE))
+         (VALUES #'(LAMBDA (VALUE)
+                          (SETQ RESULT (NCONC RESULT VALUE)))
+                #'(LAMBDA NIL RESULT))))
+
+(DEFMACRO MAXIMIZING (&KEY INITIAL-VALUE)
+   `(LET ((RESULT ,INITIAL-VALUE))
+         (VALUES #'(LAMBDA (VALUE)
+                          (WHEN ,(COND
+                                    ((AND (CONSTANTP INITIAL-VALUE)
+                                          (NOT (NULL (EVAL INITIAL-VALUE))))
+                                                             (IL:* IL:\; 
+                    "Initial value is given and we know it's not NIL, so leave out the null check ")
+                                     '(> VALUE RESULT))
+                                    (T '(OR (NULL RESULT)
+                                            (> VALUE RESULT))))
+                                (SETQ RESULT VALUE)))
+                #'(LAMBDA NIL RESULT))))
+
+(DEFMACRO MINIMIZING (&KEY INITIAL-VALUE)
+   `(LET ((RESULT ,INITIAL-VALUE))
+         (VALUES #'(LAMBDA (VALUE)
+                          (WHEN ,(COND
+                                    ((AND (CONSTANTP INITIAL-VALUE)
+                                          (NOT (NULL (EVAL INITIAL-VALUE))))
+                                                             (IL:* IL:\; 
+                    "Initial value is given and we know it's not NIL, so leave out the null check ")
+                                     '(< VALUE RESULT))
+                                    (T '(OR (NULL RESULT)
+                                            (< VALUE RESULT))))
+                                (SETQ RESULT VALUE)))
+                #'(LAMBDA NIL RESULT))))
+
+(DEFMACRO SUMMING (&KEY (INITIAL-VALUE 0))
+   `(LET ((SUM ,INITIAL-VALUE))
+         (VALUES #'(LAMBDA (VALUE)
+                          (SETQ SUM (+ SUM VALUE)))
+                #'(LAMBDA NIL SUM))))
+
+
+
+(IL:* IL:\; "Easier to read expanded code if PROG1 gets left alone ")
+
+
+(XCL:DEFINE-FILE-ENVIRONMENT "ITERATE" :PACKAGE (IN-PACKAGE :ITERATE :USE '(:LISP :WALKER))
+   :READTABLE "XCL"
+   :BASE 10
+   :COMPILER :COMPILE-FILE)
+(IL:PUTPROPS IL:ITERATE IL:COPYRIGHT ("Venue" 1991))
+(IL:DECLARE\: IL:DONTCOPY
+  (IL:FILEMAP (NIL)))
+IL:STOP
diff --git a/clos/3.5/lap.dfasl b/clos/3.5/lap.dfasl
new file mode 100644
index 00000000..e100f6db
Binary files /dev/null and b/clos/3.5/lap.dfasl differ
diff --git a/clos/3.5/lap.lisp b/clos/3.5/lap.lisp
new file mode 100644
index 00000000..4dceda84
--- /dev/null
+++ b/clos/3.5/lap.lisp
@@ -0,0 +1,364 @@
+;;;-*- Package: CLOS; Syntax: Common-Lisp; Base: 10 -*-
+
+
+;;;. Copyright (c) 1991 by Venue
+
+(in-package "CLOS")
+
+;;; This file defines CLOS's interface to the LAP mechanism. The file is divided into two parts.  The
+;;; first part defines the interface used by CLOS to create abstract LAP code vectors.  CLOS never
+;;; creates lists that represent LAP code directly, it always calls this mechanism to do so. This
+;;; provides a layer of error checking on the LAP code before it gets to the implementation-specific
+;;; assembler.  Note that this error checking is syntactic only, but even so is useful to have. 
+;;; Because of it, no specific LAP assembler should worry itself with checking the syntax of the LAP
+;;; code. The second part of the file defines the LAP assemblers for each CLOS port. These are
+;;; included together in the same file to make it easier to change them all should some random
+;;; change be made in the LAP mechanism. 
+
+
+(defvar *make-lap-closure-generator*)
+
+(defvar *precompile-lap-closure-generator*)
+
+(defvar *lap-in-lisp*)
+
+(defun make-lap-closure-generator (closure-variables arguments iregs vregs tregs lap-code)
+       (funcall *make-lap-closure-generator* closure-variables arguments iregs vregs tregs lap-code))
+
+(defmacro precompile-lap-closure-generator (cvars args i-regs v-regs t-regs lap)
+       (funcall *precompile-lap-closure-generator* cvars args i-regs v-regs t-regs lap))
+
+(defmacro lap-in-lisp (cvars args iregs vregs tregs lap)
+       (declare (ignore cvars args))
+       `(locally (declare (optimize (safety 0)
+                                 (speed 3)))
+               ,(make-lap-prog iregs vregs tregs (flatten-lap lap (opcode :label 'exit-lap-in-lisp)))
+               ))
+
+
+;;; The following functions and macros are used by CLOS when generating LAP code: GENERATING-LAP
+;;; WITH-LAP-REGISTERS ALLOCATE-REGISTER DEALLOCATE-REGISTER LAP-FLATTEN OPCODE OPERAND 
+
+
+(proclaim '(special *generating-lap*))
+
+                                                             ; CAR   - alist of free registers CADR 
+                                                             ; - alist of allocated registers CADDR
+                                                             ; - max reg number allocated in each
+                                                             ; alist, the entries have the form: 
+                                                             ; (type . (:REG <n>)) 
+
+
+
+;;; This goes around the generation of any lap code.  <body> should return a lap code sequence, this
+;;; macro will take care of converting that to a lap closure generator. 
+
+
+(defmacro generating-lap (closure-variables arguments &body body)
+       `(let* ((*generating-lap* (list nil nil -1)))
+              (finalize-lap-generation nil ,closure-variables ,arguments (progn ,@body))))
+
+(defmacro generating-lap-in-lisp (closure-variables arguments &body body)
+       `(let* ((*generating-lap* (list nil nil -1)))
+              (finalize-lap-generation t ,closure-variables ,arguments (progn ,@body))))
+
+
+;;; Each register specification looks like: (<var> <type> &key :reuse <other-reg>) 
+
+
+(defmacro with-lap-registers (register-specifications &body body)
+       
+       ;; Given that, for now, there is only one keyword argument and that, for now, we do no error
+       ;; checking, we can be pretty sleazy about how this works. 
+       (flet ((make-allocations
+               nil
+               (gathering1 (collecting)
+                      (dolist (spec register-specifications)
+                          (gather1 `(,(car spec)
+                                     (or ,(cadddr spec)
+                                         (allocate-register ',(cadr spec))))))))
+              (make-deallocations nil (gathering1
+                                       (collecting)
+                                       (dolist (spec register-specifications)
+                                           (gather1 `(unless ,(cadddr spec)
+                                                         (deallocate-register ,(car spec))))))))
+             `(let ,(make-allocations)
+                   (multiple-value-prog1 (progn ,@body)
+                          ,@(make-deallocations)))))
+
+(defun allocate-register (type)
+       (destructuring-bind (free allocated)
+              *generating-lap*
+              (let ((entry (assoc type free)))
+                   (cond (entry (setf (car *generating-lap*)
+                                      (delete entry free)
+                                      (cadr *generating-lap*)
+                                      (cons entry allocated))
+                                (cdr entry))
+                         (t (let ((new `(,type :reg ,(incf (caddr *generating-lap*)))))
+                                 (setf (cadr *generating-lap*)
+                                       (cons new allocated))
+                                 (cdr new)))))))
+
+(defun deallocate-register (reg)
+       (let ((entry (rassoc reg (cadr *generating-lap*))))
+            (unless entry (error "Attempt to free an unallocated register."))
+            (push entry (car *generating-lap*))
+            (setf (cadr *generating-lap*)
+                  (delete entry (cadr *generating-lap*)))))
+
+(defvar *precompiling-lap* nil)
+
+(defun finalize-lap-generation (in-lisp-p closure-variables arguments lap-code)
+       (when (cadr *generating-lap*)
+             (error "Registers still allocated when lap being finalized."))
+       (let ((iregs nil)
+             (vregs nil)
+             (tregs nil))
+            (dolist (entry (car *generating-lap*))
+                (ecase (car entry)
+                    (index (push (caddr entry)
+                                 iregs))
+                    (vector (push (caddr entry)
+                                  vregs))
+                    ((t) (push (caddr entry)
+                               tregs))))
+            (cond (in-lisp-p (macroexpand `(lap-in-lisp ,closure-variables ,arguments ,iregs
+                                                  ,vregs
+                                                  ,tregs
+                                                  ,lap-code)))
+                  (*precompiling-lap* (values closure-variables arguments iregs vregs tregs lap-code)
+                         )
+                  (t (make-lap-closure-generator closure-variables arguments iregs vregs tregs 
+                            lap-code)))))
+
+(defun flatten-lap (&rest opcodes-or-sequences)
+       (let ((result nil))
+            (dolist (opcode-or-sequence opcodes-or-sequences result)
+                (cond ((null opcode-or-sequence))
+                      ((not (consp (car opcode-or-sequence)))
+                                                             ; its an opcode
+                       (setf result (append result (list opcode-or-sequence))))
+                      (t (setf result (append result opcode-or-sequence)))))))
+
+(defmacro flattening-lap nil '(let ((result nil))
+                                   (values #'(lambda (value)
+                                                    (push value result))
+                                          #'(lambda nil (apply #'flatten-lap (reverse result))))))
+
+
+;;; This code deals with the syntax of the individual opcodes and operands. The first two of these
+;;; variables are documented to all ports.  They are lists of the symbols which name the lap opcodes
+;;; and operands.  They can be useful to determine whether a port has implemented all the required
+;;; opcodes and operands. The third of these variables is for use of the emitter only. 
+
+
+(defvar *lap-operands* nil)
+
+(defvar *lap-opcodes* nil)
+
+(defvar *lap-emitters* (make-hash-table :test #'eq :size 30))
+
+(defun opcode (name &rest args)
+       (let ((emitter (gethash name *lap-emitters*)))
+            (if emitter
+                (apply emitter args)
+                (error "No opcode named ~S." name))))
+
+(defun operand (name &rest args)
+       (let ((emitter (gethash name *lap-emitters*)))
+            (if emitter
+                (apply emitter args)
+                (error "No operand named ~S." name))))
+
+(defmacro defopcode (name types)
+       (let ((fn-name (symbol-append "LAP Opcode " name *the-clos-package*))
+             (lambda-list (mapcar #'(lambda (x)
+                                           (declare (ignore x))
+                                           (gensym))
+                                 types)))
+            `(progn (eval-when (load eval)
+                           (load-defopcode ',name ',fn-name))
+                    (defun ,fn-name ,lambda-list (defopcode-1 ',name ',types ,@lambda-list)))))
+
+(defmacro defoperand (name types)
+       (let ((fn-name (symbol-append "LAP Operand " name *the-clos-package*))
+             (lambda-list (mapcar #'(lambda (x)
+                                           (declare (ignore x))
+                                           (gensym))
+                                 types)))
+            `(progn (eval-when (load eval)
+                           (load-defoperand ',name ',fn-name))
+                    (defun ,fn-name ,lambda-list (defoperand-1 ',name ',types ,@lambda-list)))))
+
+(defun load-defopcode (name fn-name)
+       (if* (memq name *lap-operands*)
+            (error "LAP opcodes and operands must have disjoint names.")
+            (setf (gethash name *lap-emitters*)
+                  fn-name)
+            (pushnew name *lap-opcodes*)))
+
+(defun load-defoperand (name fn-name)
+       (if* (memq name *lap-opcodes*)
+            (error "LAP opcodes and operands must have disjoint names.")
+            (setf (gethash name *lap-emitters*)
+                  fn-name)
+            (pushnew name *lap-operands*)))
+
+(defun defopcode-1 (name operand-types &rest args)
+       (iterate ((arg (list-elements args))
+                 (type (list-elements operand-types)))
+              (check-opcode-arg name arg type))
+       (cons name (copy-list args)))
+
+(defun defoperand-1 (name operand-types &rest args)
+       (iterate ((arg (list-elements args))
+                 (type (list-elements operand-types)))
+              (check-operand-arg name arg type))
+       (cons name (copy-list args)))
+
+(defun check-opcode-arg (name arg type)
+       (labels ((usual (x)
+                       (and (consp arg)
+                            (eq (car arg)
+                                x)))
+                (check (x)
+                       (ecase x
+                           ((:reg :cdr :constant :iref :cvar :arg :lisp :lisp-variable) (usual x))
+                           (:label (symbolp arg))
+                           (:operand (and (consp arg)
+                                          (memq (car arg)
+                                                *lap-operands*))))))
+              (unless (if (consp type)
+                          (if (eq (car type)
+                                  'or)
+                              (some #'check (cdr type))
+                              (error "What type is this?"))
+                          (check type))
+                     (error "The argument ~S to the opcode ~A is not of type ~S." arg name type))))
+
+(defun check-operand-arg (name arg type)
+       (flet ((check (x)
+                     (ecase x
+                         (:symbol (symbolp arg))
+                         (:register-number (and (integerp arg)
+                                                (>= x 0)))
+                         (:t t)
+                         (:reg (and (consp arg)
+                                    (eq (car arg)
+                                        :reg)))
+                         (:fixnum (typep arg 'fixnum)))))
+             (unless (if (consp type)
+                         (if (eq (car type)
+                                 'or)
+                             (some #'check (cdr type))
+                             (error "What type is this?"))
+                         (check type))
+                    (error "The argument ~S to the operand ~A is not of type ~S." arg name type))))
+
+
+;;; The actual opcodes. 
+
+
+(defopcode :break nil)
+
+                                                             ; For debugging only.  Not
+
+
+(defopcode :beep nil)
+
+                                                             ; all ports are required to
+
+
+(defopcode :print (:reg))
+
+                                                             ; implement this.
+
+
+(defopcode :move (:operand (or :reg :iref :cdr :lisp-variable)))
+
+(defopcode :eq ((or :reg :constant)
+                (or :reg :constant)
+                :label))
+
+(defopcode :neq ((or :reg :constant)
+                 (or :reg :constant)
+                 :label))
+
+(defopcode :fix= ((or :reg :constant)
+                  (or :reg :constant)
+                  :label))
+
+(defopcode :izerop (:reg :label))
+
+(defopcode :std-instance-p (:reg :label))
+
+(defopcode :fsc-instance-p (:reg :label))
+
+(defopcode :built-in-instance-p (:reg :label))
+
+(defopcode :structure-instance-p (:reg :label))
+
+(defopcode :jmp ((or :reg :constant)))
+
+(defopcode :label (:label))
+
+(defopcode :go (:label))
+
+(defopcode :return ((or :reg :constant)))
+
+(defopcode :exit-lap-in-lisp nil)
+
+
+;;; The actual operands. 
+
+
+(defoperand :reg (:register-number))
+
+(defoperand :cvar (:symbol))
+
+(defoperand :arg (:symbol))
+
+(defoperand :cdr (:reg))
+
+(defoperand :constant (:t))
+
+(defoperand :std-wrapper (:reg))
+
+(defoperand :fsc-wrapper (:reg))
+
+(defoperand :built-in-wrapper (:reg))
+
+(defoperand :structure-wrapper (:reg))
+
+(defoperand :other-wrapper (:reg))
+
+(defoperand :std-slots (:reg))
+
+(defoperand :fsc-slots (:reg))
+
+(defoperand :cref (:reg :fixnum))
+
+(defoperand :iref (:reg :reg))
+
+(defoperand :iset (:reg :reg :reg))
+
+(defoperand :i1+ (:reg))
+
+(defoperand :i+ (:reg :reg))
+
+(defoperand :i- (:reg :reg))
+
+(defoperand :ilogand (:reg :reg))
+
+(defoperand :ilogxor (:reg :reg))
+
+(defoperand :ishift (:reg :fixnum))
+
+(defoperand :lisp (:t))
+
+(defoperand :lisp-variable (:symbol))
+
+
+;;; LAP tests (there need to be a lot more of these) 
+
diff --git a/clos/3.5/low.dfasl b/clos/3.5/low.dfasl
new file mode 100644
index 00000000..1a8764a9
Binary files /dev/null and b/clos/3.5/low.dfasl differ
diff --git a/clos/3.5/low.lisp b/clos/3.5/low.lisp
new file mode 100644
index 00000000..dcd28cef
--- /dev/null
+++ b/clos/3.5/low.lisp
@@ -0,0 +1,194 @@
+
+;;;-*- Package: CLOS; Syntax: Common-Lisp; Base: 10 -*-
+
+
+;;; File converted on 26-Mar-91 10:29:45 from source low
+;;;. Original source {dsk}<usr>local>users>welch>lisp>clos>rev4>il-format>low.;4 created 27-Feb-91 17:16:47
+
+;;;. Copyright (c) 1991 by Venue
+
+
+
+(in-package "CLOS")
+
+;;; Shadow, Export, Require, Use-package, and Import forms should follow here
+
+
+
+;;;
+;;;*************************************************************************
+;;;Copyright (c) 1991 Venue
+;;; This file contains portable versions of low-level functions and macros which are ripe for
+;;; implementation specific customization.  None of the code in this file *has* to be customized for
+;;; a particular Common Lisp implementation. Moreover, in some implementations it may not make any
+;;; sense to customize some of this code. ks. 
+
+
+(defmacro %svref (vector index)
+       `(locally (declare (optimize (speed 3)
+                                 (safety 0))
+                        (inline svref))
+               (svref (the simple-vector ,vector)
+                      (the fixnum ,index))))
+
+(defsetf %svref (vector index)
+       (new-value)
+       `(locally (declare (optimize (speed 3)
+                                 (safety 0))
+                        (inline svref))
+               (setf (svref (the simple-vector ,vector)
+                            (the fixnum ,index))
+                     ,new-value)))
+
+
+;;; without-interrupts OK, Common Lisp doesn't have this and for good reason.  But For all of the
+;;; Common Lisp's that CLOS runs on today, there is a meaningful way to implement this.  WHAT I MEAN
+;;; IS: I want the body to be evaluated in such a way that no other code that is running CLOS can be
+;;; run during that evaluation.  I agree that the body won't take *long* to evaluate.  That is to
+;;; say that I will only use without interrupts around relatively small computations. INTERRUPTS-ON
+;;; should turn interrupts back on if they were on. INTERRUPTS-OFF should turn interrupts back off.
+;;; These are only valid inside the body of WITHOUT-INTERRUPTS. OK? 
+
+
+
+;;; AKW: IT'S CALLED, BUT NEVER REALLY USED, SO I'VE REPLACED IT WITH THE PROGN. IF WE REALLY NEED
+;;; IT, CAN BE TRIVIALLY DONE WITH IL:MONITORS
+
+
+(defmacro without-interrupts (&body body)
+       `(progn ,.body))
+
+
+;;; Very Low-Level representation of instances with meta-class standard-class. 
+
+
+(defmacro std-instance-wrapper (x)
+       `(%std-instance-wrapper ,x))
+
+(defmacro std-instance-slots (x)
+       `(%std-instance-slots ,x))
+
+(defun print-std-instance (instance stream depth)
+                                                             ; A temporary definition used
+       (declare (ignore depth))
+                                                             ; for debugging the bootstrap
+       (printing-random-thing (instance stream)
+                                                             ; code of CLOS (See high.lisp).
+              (format stream "#<std-instance>")))
+
+(defmacro %allocate-instance--class (no-of-slots)
+       `(let ((instance (%%allocate-instance--class)))
+             (%allocate-instance--class-1 ,no-of-slots instance)
+             instance))
+
+(defmacro %allocate-instance--class-1 (no-of-slots instance)
+       (once-only (instance)
+              `(progn (setf (std-instance-slots ,instance)
+                            (%allocate-static-slot-storage--class ,no-of-slots)))))
+
+
+;;; This is the value that we stick into a slot to tell us that it is unbound. It may seem gross,
+;;; but for performance reasons, we make this an interned symbol.  That means that the fast check to
+;;; see if a slot is unbound is to say (EQ <val> '..SLOT-UNBOUND..).  That is considerably faster
+;;; than looking at the value of a special variable.  Be careful, there are places in the code which
+;;; actually use ..slot-unbound.. rather than this variable.  So much for modularity 
+
+
+(defvar *slot-unbound* '..slot-unbound..)
+
+(defmacro %allocate-static-slot-storage--class (no-of-slots)
+       `(make-array ,no-of-slots :initial-element *slot-unbound*))
+
+(defmacro std-instance-class (instance)
+       `(wrapper-class (std-instance-wrapper ,instance)))
+
+
+;; 
+
+
+
+;;; FUNCTION-ARGLIST
+
+
+
+;; 
+
+
+
+;;; [COMMENTED OUT AKW. NEVER CALLED] Given something which is functionp, function-arglist should
+;;; return the argument list for it.  CLOS does not count on having this available, but
+;;; MAKE-SPECIALIZABLE works much better if it is available.  Versions of function-arglist for each
+;;; specific port of clos should be put in the appropriate xxx-low file. This is what it should look
+;;; like: 
+
+
+                                                             ; (defun function-arglist (function)
+                                                             ; (<system-dependent-arglist-function>
+                                                             ; function)) 
+
+
+
+;; (FUNCTIONS CLOS::FUNCTION-PRETTY-ARGLIST) (SETFS CLOS::FUNCTION-PRETTY-ARGLIST) (FUNCTIONS
+;; CLOS::SET-FUNCTION-PRETTY-ARGLIST)
+
+
+
+;;; set-function-name When given a function should give this function the name <new-name>. Note that
+;;; <new-name> is sometimes a list.  Some lisps get the upset in the tummy when they start thinking
+;;; about functions which have lists as names.  To deal with that there is set-function-name-intern
+;;; which takes a list spec for a function name and turns it into a symbol if need be. When given a
+;;; funcallable instance, set-function-name MUST side-effect that FIN to give it the name.  When
+;;; given any other kind of function set-function-name is allowed to return new function which is
+;;; the 'same' except that it has the name. In all cases, set-function-name must return the new (or
+;;; same) function. 
+
+
+(defun set-function-name #'new-name (declare (notinline set-function-name-1 intern-function-name))
+       (set-function-name-1 function (intern-function-name new-name)
+              new-name))
+
+(defun set-function-name-1 (fn new-name uninterned-name)
+       (cond ((typep fn 'il:compiled-closure)
+              (il:\\rplptr (compiled-closure-fnheader fn)
+                     4 new-name)
+              (when (and (consp uninterned-name)
+                         (eq (car uninterned-name)
+                             'method))
+                  (let ((debug (si::compiled-function-debugging-info fn)))
+                       (when debug
+                           (setf (cdr debug)
+                                 uninterned-name)))))
+             (t nil))
+       fn)
+
+(defun intern-function-name (name)
+       (cond ((symbolp name)
+              name)
+             ((listp name)
+              (intern (let ((*package* *the-clos-package*)
+                            (*print-case* :upcase)
+                            (*print-gensym* 't))
+                           (format nil "~S" name))
+                     *the-clos-package*))))
+
+
+;;; COMPILE-LAMBDA This is like the Common Lisp function COMPILE.  In fact, that is what it ends up
+;;; calling.   
+
+
+(defun compile-lambda (lambda &rest desirability)
+       (declare (ignore desirability))
+       (compile nil lambda))
+
+(defmacro precompile-random-code-segments (&optional system)
+  `(progn
+     (precompile-function-generators ,system)
+     (precompile-dfun-constructors ,system)))
+
+
+
+(defun record-definition (type spec &rest args)
+  (declare (ignore type spec args))
+  ())
+
+(defun doctor-dfun-for-the-debugger (gf dfun) (declare (ignore gf)) dfun)
\ No newline at end of file
diff --git a/clos/3.5/low2.dfasl b/clos/3.5/low2.dfasl
new file mode 100644
index 00000000..09194e45
Binary files /dev/null and b/clos/3.5/low2.dfasl differ
diff --git a/clos/3.5/low2.lisp b/clos/3.5/low2.lisp
new file mode 100644
index 00000000..0c648b9b
--- /dev/null
+++ b/clos/3.5/low2.lisp
@@ -0,0 +1,144 @@
+;;;-*- Package: CLOS; Syntax: Common-Lisp; Base: 10 -*-
+
+
+;;; File converted on 26-Mar-91 10:30:44 from source xerox-low
+;;;. Original source {dsk}<usr>local>users>welch>lisp>clos>rev4>il-format>xerox-low.;3 created 27-Feb-91 16:37:43
+
+;;;. Copyright (c) 1991 by Venue
+
+
+
+(in-package "CLOS")
+
+;;; Shadow, Export, Require, Use-package, and Import forms should follow here
+
+
+
+;;; ************************************************************************* This is the 1100
+;;; (Xerox version) of the file portable-low. 
+
+
+(defmacro load-time-eval (form)
+       `(il:loadtimeconstant ,form))
+
+
+;;; make the pointer from an instance to its class wrapper be an xpointer. this prevents instance
+;;; creation from spending a lot of time incrementing the large refcount of the class-wrapper.  This
+;;; is safe because there will always be some other pointer to the wrapper to keep it around. 
+
+
+(defstruct (std-instance (:predicate std-instance-p)
+                  (:conc-name %std-instance-)
+                  (:constructor %%allocate-instance--class nil)
+                  (:fast-accessors t)
+                  (:print-function %print-std-instance))
+       (wrapper nil :type il:fullxpointer)
+       (slots nil))
+
+(defun %print-std-instance (instance &optional stream depth)
+       
+       ;; See the IRM, section 25.3.3.  Unfortunatly, that documentation is not correct.  In
+       ;; particular, it makes no mention of the third argument. 
+       (cond ((streamp stream)
+              
+              ;; Use the standard CLOS printing method, then return T to tell the printer that we
+              ;; have done the printing ourselves. 
+              (print-std-instance instance stream depth)
+              t)
+             (t 
+                ;; Internal printing (again, see the IRM section 25.3.3). Return a list containing
+                ;; the string of characters that would be printed, if the object were being printed
+                ;; for real. 
+                (list (with-output-to-string (stream)
+                             (print-std-instance instance stream depth))))))
+
+
+;; 
+
+
+
+;;; FUNCTION-ARGLIST
+
+
+
+;; 
+
+
+(defun function-arglist (x)
+       
+       ;; Xerox lisp has the bad habit of returning a symbol to mean &rest, and strings instead of
+       ;; symbols.  How silly. 
+       (let ((arglist (il:arglist x)))
+            (when (symbolp arglist)
+                
+                ;; This could be due to trying to extract the arglist of an interpreted function
+                ;; (though why that should be hard is beyond me).  On the other hand, if the
+                ;; function is compiled, it helps to ask for the "smart" arglist. 
+                (setq arglist (if (consp (symbol-function x))
+                                  (second (symbol-function x))
+                                  (il:arglist x t))))
+            (if (symbolp arglist)
+                
+                ;; Probably never get here, but just in case
+                (list '&rest 'rest)
+                
+                ;; Make sure there are no strings where there should be symbols
+                (if (some #'stringp arglist)
+                    (mapcar #'(lambda (a)
+                                     (if (symbolp a)
+                                         a
+                                         (intern a)))
+                           arglist)
+                    arglist))))
+
+(defun printing-random-thing-internal (thing stream)
+       (let ((*print-base* 8))
+            (princ (il:\\hiloc thing)
+                   stream)
+            (princ "," stream)
+            (princ (il:\\loloc thing)
+                   stream)))
+
+(defun record-definition (name type &optional parent-name parent-type)
+       (declare (ignore type parent-name))
+       nil)
+
+
+;;; FIN uses this too! 
+
+
+(eval-when (compile load eval)
+       (il:datatype il:compiled-closure (il:fnheader il:environment))
+       (il:blockrecord closure-overlay ((funcallable-instance-p il:flag))))
+
+(defun compiled-closure-fnheader (compiled-closure)
+       (il:fetch (il:compiled-closure il:fnheader)
+              il:of compiled-closure))
+
+(defun set-compiled-closure-fnheader (compiled-closure nv)
+       (il:replace (il:compiled-closure il:fnheader)
+              il:of compiled-closure nv))
+
+(defsetf compiled-closure-fnheader set-compiled-closure-fnheader)
+
+
+;;; In Lyric, and until the format of FNHEADER changes, getting the name from a compiled closure
+;;; looks like this: (fetchfield '(nil 4 pointer) (fetch (compiled-closure fnheader) closure)) Of
+;;; course this is completely non-robust, but it will work for now.  This is not the place to go
+;;; into a long tyrade about what is wrong with having record package definitions go away when you
+;;; ship the sysout; there isn't enough diskspace. 
+
+
+(defun set-function-name-1 (fn new-name uninterned-name)
+       (cond ((typep fn 'il:compiled-closure)
+              (il:\\rplptr (compiled-closure-fnheader fn)
+                     4 new-name)
+              (when (and (consp uninterned-name)
+                         (eq (car uninterned-name)
+                             'method))
+                  (let ((debug (si::compiled-function-debugging-info fn)))
+                       (when debug
+                           (setf (cdr debug)
+                                 uninterned-name)))))
+             (t nil))
+       fn)
diff --git a/clos/3.5/macros.dfasl b/clos/3.5/macros.dfasl
new file mode 100644
index 00000000..973c7177
Binary files /dev/null and b/clos/3.5/macros.dfasl differ
diff --git a/clos/3.5/macros.lisp b/clos/3.5/macros.lisp
new file mode 100644
index 00000000..4f6a294d
--- /dev/null
+++ b/clos/3.5/macros.lisp
@@ -0,0 +1,355 @@
+;;;-*- Package: CLOS; Syntax: Common-Lisp; Base: 10 -*-
+
+
+;;; File converted on 26-Mar-91 10:27:21 from source macros
+;;;. Original source {dsk}<usr>local>users>welch>lisp>clos>rev4>il-format>macros.;3 created 19-Feb-91 13:51:21
+
+;;;. Copyright (c) 1991 Venue
+
+
+
+(in-package "CLOS")
+
+
+;;;Macros global variable
+;;; definitions, and other random support stuff used by the rest of the system. For simplicity (not
+;;; having to use eval-when a lot), this file must be loaded before it can be compiled. 
+
+
+(in-package 'clos)
+
+(proclaim '(declaration values arglist indentation class variable-rebinding clos-fast-call))
+
+
+;;; Age old functions which CommonLisp cleaned-up away.  They probably exist in other packages in
+;;; all CommonLisp implementations, but I will leave it to the compiler to optimize into calls to
+;;; them. Common Lisp BUG: Some Common Lisps define these in the Lisp package which causes all sorts
+;;; of lossage.  Common Lisp should explictly specify which symbols appear in the Lisp package. 
+
+
+(eval-when (compile load eval)
+       (defmacro memq (item list)
+              `(member ,item ,list :test #'eq))
+       (defmacro assq (item list)
+              `(assoc ,item ,list :test #'eq))
+       (defmacro rassq (item list)
+              `(rassoc ,item ,list :test #'eq))
+       (defmacro delq (item list)
+              `(delete ,item ,list :test #'eq))
+       (defmacro posq (item list)
+              `(position ,item ,list :test #'eq))
+       (defmacro neq (x y)
+              `(not (eq ,x ,y)))
+       (defun make-caxr (n form)
+              (if (< n 4)
+                  `(,(nth n '(car cadr caddr cadddr))
+                    ,form)
+                  (make-caxr (- n 4)
+                         `(cddddr ,form))))
+       (defun make-cdxr (n form)
+              (cond ((zerop n)
+                     form)
+                    ((< n 5)
+                     `(,(nth n '(identity cdr cddr cdddr cddddr))
+                       ,form))
+                    (t (make-cdxr (- n 4)
+                              `(cddddr ,form))))))
+
+(defun zero (&rest ignore)
+       (declare (ignore ignore))
+       0)
+
+(defun make-plist (keys vals)
+       (if (null vals)
+           nil
+           (list* (car keys)
+                  (car vals)
+                  (make-plist (cdr keys)
+                         (cdr vals)))))
+
+(defun remtail (list tail)
+       (if (eq list tail)
+           nil
+           (cons (car list)
+                 (remtail (cdr list)
+                        tail))))
+
+
+;;; ONCE-ONLY does the same thing as it does in zetalisp.  I should have just lifted it from there
+;;; but I am honest.  Not only that but this one is written in Common Lisp.  I feel a lot like
+;;; bootstrapping, or maybe more like rebuilding Rome. 
+
+
+(defmacro once-only (vars &body body)
+       (let ((gensym-var (gensym))
+             (run-time-vars (gensym))
+             (run-time-vals (gensym))
+             (expand-time-val-forms nil))
+            (dolist (var vars)
+                (push `(if (or (symbolp ,var)
+                               (numberp ,var)
+                               (and (listp ,var)
+                                    (member (car ,var)
+                                           ''function)))
+                           ,var
+                           (let ((,gensym-var (gensym)))
+                                (push ,gensym-var ,run-time-vars)
+                                (push ,var ,run-time-vals)
+                                ,gensym-var))
+                      expand-time-val-forms))
+            `(let* (,run-time-vars ,run-time-vals (wrapped-body (let ,(mapcar #'list vars
+                                                                             (reverse 
+                                                                                expand-time-val-forms
+                                                                                    ))
+                                                                     ,@body)))
+                   `(let ,(mapcar #'list (reverse ,run-time-vars)
+                                 (reverse ,run-time-vals))
+                         ,wrapped-body))))
+
+(eval-when
+ (compile load eval)
+ (defun extract-declarations (body &optional environment)
+        (declare (values documentation declarations body))
+        (let (documentation declarations form)
+             (when (and (stringp (car body))
+                        (cdr body))
+                 (setq documentation (pop body)))
+             (block outer
+                 (loop (when (null body)
+                             (return-from outer nil))
+                       (setq form (car body))
+                       (when (block inner
+                                 (loop (cond ((not (listp form))
+                                              (return-from outer nil))
+                                             ((eq (car form)
+                                                  'declare)
+                                              (return-from inner 't))
+                                             (t (multiple-value-bind
+                                                 (newform macrop)
+                                                 (macroexpand-1 form environment)
+                                                 (if (or (not (eq newform form))
+                                                         macrop)
+                                                     (setq form newform)
+                                                     (return-from outer nil)))))))
+                           (pop body)
+                           (dolist (declaration (cdr form))
+                               (push declaration declarations)))))
+             (values documentation (and declarations `((declare ,.(nreverse declarations))))
+                    body))))
+
+(defvar *keyword-package* (find-package 'keyword))
+
+(defun make-keyword (symbol)
+       (intern (symbol-name symbol)
+              *keyword-package*))
+
+(eval-when (compile load eval)
+       (defun string-append (&rest strings)
+              (setq strings (copy-list strings))
+                                                             ; The explorer can't even rplaca an
+                                                             ; &rest arg? 
+              (do ((string-loc strings (cdr string-loc)))
+                  ((null string-loc)
+                   (apply #'concatenate 'string strings))
+                (rplaca string-loc (string (car string-loc))))))
+
+(defun symbol-append (sym1 sym2 &optional (package *package*))
+       (intern (string-append sym1 sym2)
+              package))
+
+(defmacro check-member (place list &key (test #'eql)
+                              (pretty-name place))
+       (once-only (place list)
+              `(or (member ,place ,list :test ,test)
+                   (error "The value of ~A, ~S is not one of ~S." ',pretty-name ,place ,list))))
+
+(defmacro alist-entry (alist key make-entry-fn)
+       (once-only (alist key)
+              `(or (assq ,key ,alist)
+                   (progn (setf ,alist (cons (,make-entry-fn ,key)
+                                             ,alist))
+                          (car ,alist)))))
+
+(defmacro collecting-once (&key initial-value)
+       `(let* ((head ,initial-value)
+               (tail ,(and initial-value `(last head))))
+              (values #'(lambda (value)
+                               (if (null head)
+                                   (setq head (setq tail (list value)))
+                                   (unless (memq value head)
+                                       (setq tail (cdr (rplacd tail (list value)))))))
+                     #'(lambda nil head))))
+
+(defmacro doplist ((key val)
+                   plist &body body &environment env)
+       (multiple-value-bind (doc decls bod)
+              (extract-declarations body env)
+              (declare (ignore doc))
+              `(let ((.plist-tail. ,plist)
+                     ,key
+                     ,val)
+                    ,@decls
+                    (loop (when (null .plist-tail.)
+                                (return nil))
+                          (setq ,key (pop .plist-tail.))
+                          (when (null .plist-tail.)
+                                (error "Malformed plist in doplist, odd number of elements."))
+                          (setq ,val (pop .plist-tail.))
+                          (progn ,@bod)))))
+
+(defmacro if* (condition true &rest false)
+       `(if ,condition
+            ,true
+            (progn ,@false)))
+
+
+;; 
+
+
+
+;;; printing-random-thing
+
+
+
+;; 
+
+
+
+;;; Similar to printing-random-object in the lisp machine but much simpler and machine independent. 
+
+
+(defmacro printing-random-thing ((thing stream)
+                                 &body body)
+       (once-only (stream)
+              `(progn (format ,stream "#<")
+                      ,@body
+                      (format ,stream " ")
+                      (printing-random-thing-internal ,thing ,stream)
+                      (format ,stream ">"))))
+
+(defun printing-random-thing-internal (thing stream)
+       (let ((*print-base* 8))
+            (princ (il:\\hiloc thing)
+                   stream)
+            (princ "," stream)
+            (princ (il:\\loloc thing)
+                   stream)))
+
+
+;; 
+
+
+
+;;; 
+
+
+
+;; 
+
+
+(defun capitalize-words (string &optional (dashes-p t))
+       (let ((string (copy-seq (string string))))
+            (declare (string string))
+            (do* ((flag t flag)
+                  (length (length string)
+                         length)
+                  (char nil char)
+                  (i 0 (+ i 1)))
+                 ((= i length)
+                  string)
+               (setq char (elt string i))
+               (cond ((both-case-p char)
+                      (if flag
+                          (and (setq flag (lower-case-p char))
+                               (setf (elt string i)
+                                     (char-upcase char)))
+                          (and (not flag)
+                               (setf (elt string i)
+                                     (char-downcase char))))
+                      (setq flag nil))
+                     ((char-equal char #\-)
+                      (setq flag t)
+                      (unless dashes-p
+                          (setf (elt string i)
+                                #\Space)))
+                     (t (setq flag nil))))))
+
+
+;;; FIND-CLASS This is documented in the CLOS specification. 
+
+
+(defvar *find-class* (make-hash-table :test #'eq))
+
+(defun legal-class-name-p (x)
+       (and (symbolp x)
+            (not (keywordp x))))
+
+(defun find-class (symbol &optional (errorp t)
+                         environment)
+       (declare (ignore environment))
+       (or (gethash symbol *find-class*)
+           (cond ((null errorp)
+                  nil)
+                 ((legal-class-name-p symbol)
+                  (error "No class named: ~S." symbol))
+                 (t (error "~S is not a legal class name." symbol)))))
+
+(defsetf find-class (symbol &optional (errorp t)
+                           environment)
+       (new-value)
+       (declare (ignore errorp environment))
+       `(|SETF CLOS FIND-CLASS| ,new-value ,symbol))
+
+(defun |SETF CLOS FIND-CLASS| (new-value symbol)
+       (if (legal-class-name-p symbol)
+           (setf (gethash symbol *find-class*)
+                 new-value)
+           (error "~S is not a legal class name." symbol)))
+
+(defun find-wrapper (symbol)
+       (class-wrapper (find-class symbol)))
+
+(defmacro gathering1 (gatherer &body body)
+  `(gathering ((.gathering1. ,gatherer))
+               (macrolet ((gather1 (x)
+                                 `(gather ,x .gathering1.)))
+                      ,@body)))
+
+
+;;; 
+
+
+(defmacro vectorizing (&key (size 0))
+       `(let* ((limit ,size)
+               (result (make-array limit))
+               (index 0))
+              (values #'(lambda (value)
+                               (if (= index limit)
+                                   (error "vectorizing more elements than promised.")
+                                   (progn (setf (svref result index)
+                                                value)
+                                          (incf index)
+                                          value)))
+                     #'(lambda nil result))))
+
+
+;;; These are augmented definitions of list-elements and list-tails from iterate.lisp.  These
+;;; versions provide the extra :by keyword which can be used to specify the step function through
+;;; the list. 
+
+
+(defmacro *list-elements (list &key (by #'cdr))
+       `(let ((tail ,list))
+             #'(lambda (finish)
+                      (if (endp tail)
+                          (funcall finish)
+                          (prog1 (car tail)
+                              (setq tail (funcall ,by tail)))))))
+
+(defmacro *list-tails (list &key (by #'cdr))
+       `(let ((tail ,list))
+             #'(lambda (finish)
+                      (prog1 (if (endp tail)
+                                 (funcall finish)
+                                 tail)
+                          (setq tail (funcall ,by tail))))))
diff --git a/clos/3.5/methods.dfasl b/clos/3.5/methods.dfasl
new file mode 100644
index 00000000..54844882
Binary files /dev/null and b/clos/3.5/methods.dfasl differ
diff --git a/clos/3.5/methods.lisp b/clos/3.5/methods.lisp
new file mode 100644
index 00000000..fa52befe
--- /dev/null
+++ b/clos/3.5/methods.lisp
@@ -0,0 +1,1304 @@
+;;;-*- Package: CLOS; Syntax: Common-Lisp; Base: 10 -*-
+
+
+;;;. Copyright (c) 1991 by Venue
+
+(in-package "CLOS")
+
+
+
+;;; METHODS Methods themselves are simple inanimate objects.  Most properties of methods are
+;;; immutable, methods cannot be reinitialized.  The following properties of methods can be changed:
+;;; METHOD-GENERIC-FUNCTION METHOD-FUNCTION            ?? 
+
+(defclass method (metaobject) ())
+
+(defclass standard-method (definition-source-mixin documentation-mixin method)
+     ((generic-function
+	:initform nil	
+	:accessor method-generic-function)
+;     (qualifiers
+;	:initform ()
+;	:initarg  :qualifiers
+;	:reader method-qualifiers)
+      (specializers
+	:initform ()
+	:initarg  :specializers
+	:reader method-specializers)
+      (lambda-list
+	:initform ()
+	:initarg  :lambda-list
+	:reader method-lambda-list)
+      (function
+	:initform nil
+	:initarg :function
+	:reader method-function)		;writer defined by hand
+;     (documentation
+;	:initform ""
+;	:initarg  :documentation)
+      ))
+
+(defclass standard-accessor-method (standard-method)
+     ((slot-name :initform nil
+		 :initarg :slot-name)))
+
+
+;;; This method has to be defined by hand!  Don't try to define it using :accessor or :reader.  It
+;;; can't be an automatically generated reader method because that would break the way the special
+;;; discriminator code which uses this feature works.  -- Probably false now 8/21 
+
+
+(defmethod accessor-method-slot-name ((m standard-accessor-method))
+       (slot-value m 'slot-name))
+
+(defclass standard-reader-method (standard-accessor-method) ())
+(defclass standard-writer-method (standard-accessor-method) ())
+
+(defmethod print-object ((method standard-method)
+                         stream)
+       (printing-random-thing (method stream)
+              (let ((generic-function (method-generic-function method))
+                    (class-name (capitalize-words (class-name (class-of method)))))
+                   (format stream "~A ~S ~{~S ~}~:S" class-name (and generic-function (
+                                                                                generic-function-name
+                                                                                       
+                                                                                     generic-function
+                                                                                       ))
+                          (method-qualifiers method)
+                          (unparse-specializers method)))))
+
+(defmethod print-object ((method standard-accessor-method)
+                         stream)
+       (printing-random-thing (method stream)
+              (let ((generic-function (method-generic-function method))
+                    (class-name (capitalize-words (class-name (class-of method)))))
+                   (format stream "~A ~S, slot:~S, ~:S" class-name (and generic-function (
+                                                                                generic-function-name
+                                                                                          
+                                                                                     generic-function
+                                                                                          ))
+                          (accessor-method-slot-name method)
+                          (unparse-specializers method)))))
+
+
+;;; INITIALIZATION Error checking is done in before methods.  Because of the simplicity of standard
+;;; method objects the standard primary method can fill the slots. Methods are not reinitializable. 
+
+
+(defmethod reinitialize-instance ((method standard-method)
+                                  &rest initargs)
+       (declare (ignore initargs))
+       (error 
+        "Attempt to reinitialize the method ~S.~%~
+          Method objects cannot be reinitialized." method))
+
+(defmethod shared-initialize :before ((method standard-method)
+                                      slot-names &key qualifiers lambda-list specializers function 
+                                      documentation)
+       (declare (ignore slot-names))
+       (flet ((lose (initarg value string)
+                    (error "When initializing the method ~S:~%~
+                   The ~S initialization argument was: ~S.~%~
+                   which ~A." method initarg value string)))
+             (let ((check-qualifiers (legal-std-qualifiers-p qualifiers))
+                   (check-lambda-list (legal-std-lambda-list-p lambda-list))
+                   (check-specializers (legal-std-specializers-p specializers))
+                   (check-function (legal-std-method-function-p function))
+                   (check-documentation (legal-std-documentation-p documentation)))
+                  (unless (eq check-qualifiers t)
+                         (lose :qualifiers qualifiers check-qualifiers))
+                  (unless (eq check-lambda-list t)
+                         (lose :lambda-list lambda-list check-lambda-list))
+                  (unless (eq check-specializers t)
+                         (lose :specializers specializers check-specializers))
+                  (unless (eq check-function t)
+                         (lose :function function check-function))
+                  (unless (eq check-documentation t)
+                         (lose :documentation documentation check-documentation)))))
+
+(defmethod shared-initialize :before ((method standard-accessor-method)
+                                      slot-names &key slot-name)
+       (declare (ignore slot-names))
+       (let ((legalp (legal-std-slot-name-p slot-name)))
+            (unless (eq legalp t)
+                   (error "The value of the :SLOT-NAME initarg ~A." legalp))))
+
+(defmethod shared-initialize :after ((method standard-method)
+                                     slot-names &key qualifiers)
+       (setf (plist-value method 'qualifiers)
+             qualifiers))
+
+(defmethod method-qualifiers ((method standard-method))
+       (plist-value method 'qualifiers))
+
+(defclass generic-function (dependent-update-mixin
+			    definition-source-mixin
+			    metaobject)
+     ()
+  (:metaclass funcallable-standard-class))
+    
+(defclass standard-generic-function (generic-function)
+     ((name
+	:initform nil
+	:initarg :name
+	:accessor generic-function-name)
+      (methods
+	:initform ()
+	:accessor generic-function-methods)
+      (method-class
+	:initarg :method-class
+	:accessor generic-function-method-class)
+      (method-combination
+	:initarg :method-combination
+	:accessor generic-function-method-combination)
+
+;     (permutation
+;	:accessor gf-permutation)
+      (arg-info
+	:initform ()
+	:accessor gf-arg-info)
+      (dfun-state
+	:initform ()
+	:accessor gf-dfun-state)
+      (effective-method-functions		;((methods . fn) ..)
+	:initform ()
+	:accessor gf-effective-method-functions)
+      (valid-p
+	:initform nil
+	:accessor gf-valid-p)
+      (pretty-arglist
+	:initform ()
+	:accessor gf-pretty-arglist)
+      )
+  (:metaclass funcallable-standard-class)
+  (:default-initargs :method-class *the-class-standard-method*
+		     :method-combination *standard-method-combination*))
+
+
+(define-gf-predicate generic-function-p generic-function)
+
+(define-gf-predicate method-p method)
+
+(define-gf-predicate standard-accessor-method-p standard-accessor-method)
+
+(define-gf-predicate standard-reader-method-p standard-reader-method)
+
+(define-gf-predicate standard-writer-method-p standard-writer-method)
+
+(defvar *the-class-method* (find-class 'method))
+
+(defvar *the-class-standard-method* (find-class 'standard-method))
+
+(defvar *the-class-generic-function* (find-class 'generic-function))
+
+(defvar *the-class-standard-generic-function* (find-class 'standard-generic-function))
+
+(defmethod print-object ((generic-function generic-function)
+                         stream)
+       (named-object-print-function generic-function stream (list (length (generic-function-methods
+                                                                           generic-function)))))
+
+(defmethod shared-initialize :before ((generic-function standard-generic-function)
+                                      slot-names &key (name nil namep)
+                                      (lambda-list nil lambda-list-p)
+                                      argument-precedence-order declarations documentation
+                                      (method-class nil method-class-supplied-p)
+                                      (method-combination nil method-combination-supplied-p))
+       (declare (ignore slot-names declarations argument-precedence-order lambda-list lambda-list-p 
+                       name))
+       (when namep (set-function-name generic-function name))
+       (flet ((initarg-error (initarg value string)
+                     (error "When initializing the generic-function ~S:~%~
+                   The ~S initialization argument was: ~A.~%~
+                   It must be ~A." generic-function initarg value string)))
+             (cond (method-class-supplied-p (when (symbolp method-class)
+                                                (setq method-class (find-class method-class)))
+                          (unless (and (classp method-class)
+                                       (*subtypep method-class *the-class-method*))
+                                 (initarg-error :method-class method-class 
+                                        "a subclass of the class METHOD"))
+                          (setf (slot-value generic-function 'method-class)
+                                method-class))
+                   ((slot-boundp generic-function 'method-class))
+                   (t (initarg-error :method-class "not supplied" "a subclass of the class METHOD")))
+             (cond (method-combination-supplied-p (unless (method-combination-p method-combination)
+                                                         (initarg-error :method-combination 
+                                                                method-combination 
+                                                                "a method combination object")))
+                   ((slot-boundp generic-function 'method-combination))
+                   (t (initarg-error :method-combination "not supplied" "a method combination object"
+                             )))))
+
+(defmethod initialize-instance :after ((gf standard-generic-function)
+                                       &key lambda-list argument-precedence-order)
+       (declare (ignore slot-names))
+       (when lambda-list
+           (setf (gf-arg-info gf)
+                 (new-arg-info-from-generic-function lambda-list argument-precedence-order))))
+
+(defmethod reinitialize-instance ((generic-function standard-generic-function)
+                                  &rest initargs &key name lambda-list argument-precedence-order 
+                                  declarations documentation method-class method-combination)
+       (declare (ignore documentation declarations argument-precedence-order lambda-list name 
+                       method-class method-combination))
+       (macrolet ((add-initarg (check name slot-name)
+                         `(unless ,check
+                              (push (slot-value generic-function ,slot-name)
+                                    initargs)
+                              (push ,name initargs))))
+                                                             ; (add-initarg name :name 'name)
+                                                             ; (add-initarg lambda-list :lambda-list
+                                                             ; 'lambda-list) (add-initarg
+                                                             ; argument-precedence-order
+                                                             ; :argument-precedence-order
+                                                             ; 'argument-precedence-order)
+                                                             ; (add-initarg declarations
+                                                             ; :declarations 'declarations)
+                                                             ; (add-initarg documentation
+                                                             ; :documentation 'documentation)
+                                                             ; (add-initarg method-class
+                                                             ; :method-class 'method-class)
+                                                             ; (add-initarg method-combination
+                                                             ; :method-combination
+                                                             ; 'method-combination) 
+              (apply #'call-next-method generic-function initargs)))
+
+
+;;; These three are scheduled for demolition. 
+
+
+(defmethod remove-named-method (generic-function-name argument-specifiers &optional extra)
+       (let ((generic-function nil)
+             (method nil))
+            (cond ((or (null (fboundp generic-function-name))
+                       (not (generic-function-p (setq generic-function (symbol-function 
+                                                                              generic-function-name))
+                                   )))
+                   (error "~S does not name a generic-function." generic-function-name))
+                  ((null (setq method (get-method generic-function extra (parse-specializers 
+                                                                                argument-specifiers)
+                                             nil)))
+                   (error "There is no method for the generic-function ~S~%~
+                   which matches the argument-specifiers ~S." generic-function argument-specifiers))
+                  (t (remove-method generic-function method)))))
+
+(defun real-add-named-method (generic-function-name qualifiers specializers lambda-list function 
+                                    &rest other-initargs)
+       
+       ;; What about changing the class of the generic-function if there is one.  Whose job is that
+       ;; anyways.  Do we need something kind of like class-for-redefinition? 
+       (let* ((generic-function (ensure-generic-function generic-function-name :lambda-list
+                                       (method-ll->generic-function-ll lambda-list)))
+              (specs (parse-specializers specializers))
+                                                             ; (existing (get-method
+                                                             ; generic-function qualifiers specs
+                                                             ; nil))
+              (proto (method-prototype-for-gf generic-function-name))
+              (new (apply #'make-instance (class-of proto)
+                          :qualifiers qualifiers :specializers specs :lambda-list lambda-list 
+                          :function function other-initargs)))
+                                                             ; (when existing (remove-method
+                                                             ; generic-function existing))
+             (add-method generic-function new)))
+
+(defun make-specializable (function-name &key (arglist nil arglistp))
+       (cond ((not (null arglistp)))
+             ((not (fboundp function-name)))
+             ((fboundp 'function-arglist)
+              
+              ;; function-arglist exists, get the arglist from it.
+              (setq arglist (function-arglist function-name)))
+             (t (error "The :arglist argument to make-specializable was not supplied~%~
+            and there is no version of FUNCTION-ARGLIST defined for this~%~
+            port of Portable CommonLoops.~%~
+            You must either define a version of FUNCTION-ARGLIST (which~%~
+            should be easy), and send it off to the Portable CommonLoops~%~
+            people or you should call make-specializable again with the~%~
+            :arglist keyword to specify the arglist.")))
+       (let ((original (and (fboundp function-name)
+                            (symbol-function function-name)))
+             (generic-function (make-instance 'standard-generic-function :name function-name))
+             (nrequireds 0))
+            (if (generic-function-p original)
+                original
+                (progn (dolist (arg arglist)
+                           (if (memq arg lambda-list-keywords)
+                               (return)
+                               (incf nrequireds)))
+                       (setf (symbol-function function-name)
+                             generic-function)
+                       (set-function-name generic-function function-name)
+                       (when arglistp
+                           (setf (gf-pretty-arglist generic-function)
+                                 arglist))
+                       (when original
+                           (add-named-method function-name nil (make-list nrequireds :initial-element
+                                                                      't)
+                                  arglist original))
+                       generic-function))))
+
+(defun real-get-method (generic-function qualifiers specializers &optional (errorp t))
+       (let ((hit (dolist (method (generic-function-methods generic-function))
+                      (when (and (equal qualifiers (method-qualifiers method))
+                                 (every #'same-specializer-p specializers (method-specializers method
+                                                                                 )))
+                            (return method)))))
+            (cond (hit hit)
+                  ((null errorp)
+                   nil)
+                  (t (error "No method on ~S with qualifiers ~:S and specializers ~:S." 
+                            generic-function qualifiers specializers)))))
+
+
+;;; Compute various information about a generic-function's arglist by looking at the argument lists
+;;; of the methods.  The hair for trying not to use &rest arguments lives here. The values returned
+;;; are: number-of-required-arguments the number of required arguments to this generic-function's
+;;; discriminating function &rest-argument-p whether or not this generic-function's discriminating
+;;; function takes an &rest argument. specialized-argument-positions a list of the positions of the
+;;; arguments this generic-function specializes (e.g. for a classical generic-function this is the
+;;; list: (1)). 
+
+
+(defmethod compute-discriminating-function-arglist-info ((generic-function standard-generic-function)
+                                                         )
+       (declare (values number-of-required-arguments &rest-argument-p specialized-argument-postions))
+       (let ((number-required nil)
+             (restp nil)
+             (specialized-positions nil)
+             (methods (generic-function-methods generic-function)))
+            (dolist (method methods)
+                (multiple-value-setq (number-required restp specialized-positions)
+                       (compute-discriminating-function-arglist-info-internal generic-function method
+                              number-required restp specialized-positions)))
+            (values number-required restp (sort specialized-positions #'<))))
+
+(defun compute-discriminating-function-arglist-info-internal (generic-function method 
+                                                                    number-of-requireds restp 
+                                                                    specialized-argument-positions)
+       (declare (ignore generic-function))
+       (let ((requireds 0))
+            
+            ;; Go through this methods arguments seeing how many are required, and whether there is
+            ;; an &rest argument. 
+            (dolist (arg (method-lambda-list method))
+                (cond ((eq arg '&aux)
+                       (return))
+                      ((memq arg '(&optional &rest &key))
+                       (return (setq restp t)))
+                      ((memq arg lambda-list-keywords))
+                      (t (incf requireds))))
+            
+            ;; Now go through this method's type specifiers to see which argument positions are type
+            ;; specified.  Treat T specially in the usual sort of way.  For efficiency don't bother
+            ;; to keep specialized-argument-positions sorted, rather depend on our caller to do
+            ;; that. 
+            (iterate ((type-spec (list-elements (method-specializers method)))
+                      (pos (interval :from 0)))
+                   (unless (eq type-spec *the-class-t*)
+                          (pushnew pos specialized-argument-positions)))
+            
+            ;; Finally merge the values for this method into the values for the exisiting methods
+            ;; and return them.  Note that if num-of-requireds is NIL it means this is the first
+            ;; method and we depend on that. 
+            (values (min (or number-of-requireds requireds)
+                         requireds)
+                   (or restp (and number-of-requireds (/= number-of-requireds requireds)))
+                   specialized-argument-positions)))
+
+(defun make-discriminating-function-arglist (number-required-arguments restp)
+       (nconc (gathering ((args (collecting)))
+                     (iterate ((i (interval :from 0 :below number-required-arguments)))
+                            (gather (intern (format nil "Discriminating Function Arg ~D" i))
+                                   args)))
+              (when restp
+                  `(&rest ,(intern "Discriminating Function &rest Arg")))))
+
+
+;;; 
+
+
+(defun make-arg-info (precedence metatypes number-optional key/rest-p keywords)
+       (let ((new (make-array 6 :adjustable nil)))
+            (setf (svref new 0)
+                  'arg-info
+                  (svref new 1)
+                  precedence
+                  (svref new 2)
+                  metatypes
+                  (svref new 3)
+                  number-optional
+                  (svref new 4)
+                  key/rest-p
+                  (svref new 5)
+                  keywords)
+                                                             ; nil         no keyword or rest
+                                                             ; allowed (k1 k2 ..)  each method must
+                                                             ; accept these keyword arguments T     
+                                                             ; must have &key or &rest 
+            new))
+
+(defun check-arg-info (x)
+       (or (and (simple-vector-p x)
+                (= (array-dimension x 0)
+                   6)
+                (eq (svref x 0)
+                    'arg-info))
+           (error "~S is not an ARG-INFO." x)))
+
+(defun arg-info-precedence (arg-info)
+       (check-arg-info arg-info)
+       (svref arg-info 1))
+
+(defun arg-info-metatypes (arg-info)
+       (check-arg-info arg-info)
+       (svref arg-info 2))
+
+(defun arg-info-number-optional (arg-info)
+       (check-arg-info arg-info)
+       (svref arg-info 3))
+
+(defun arg-info-key/rest-p (arg-info)
+       (check-arg-info arg-info)
+       (svref arg-info 4))
+
+(defun arg-info-keywords (arg-info)
+       (check-arg-info arg-info)
+       (svref arg-info 5))
+
+(defun arg-info-applyp (arg-info)
+       (check-arg-info arg-info)
+       (or (plusp (arg-info-number-optional arg-info))
+           (arg-info-key/rest-p arg-info)))
+
+(defun arg-info-number-required (arg-info)
+       (check-arg-info arg-info)
+       (length (arg-info-metatypes arg-info)))
+
+(defun arg-info-nkeys (arg-info)
+       (count-if #'(lambda (x)
+                          (neq x 't))
+              (arg-info-metatypes arg-info)))
+
+(defun new-arg-info-from-generic-function (lambda-list argument-precedence-order)
+       (multiple-value-bind (nreq nopt keysp restp allow-other-keys-p keywords)
+           (analyze-lambda-list lambda-list)
+         (declare (ignore allow-other-keys-p))
+         (let ((metatypes (make-list nreq))
+               (precedence (compute-precedence lambda-list nreq argument-precedence-order)))
+              (make-arg-info precedence metatypes nopt (or keysp restp)
+                     keywords))))
+
+(defun new-arg-info-from-method (method)
+       (multiple-value-bind (nreq nopt keysp restp)
+           (analyze-lambda-list (method-lambda-list method))
+         (make-arg-info (compute-precedence (method-lambda-list method)
+                               nreq nil)
+                (mapcar #'raise-metatype (make-list nreq)
+                       (method-specializers method))
+                nopt
+                (or keysp restp)
+                nil)))
+
+(defun add-arg-info (generic-function method arg-info)
+       (flet ((lose (string &rest args)
+                    (error 
+              "Attempt to add the method ~S to the generic function ~S.~%~
+                   But ~A" method generic-function (apply #'format nil string args)))
+              (compare (x y)
+                     (if (> x y)
+                         "more"
+                         "fewer")))
+             (multiple-value-bind (nreq nopt keysp restp allow-other-keys-p keywords)
+                 (analyze-lambda-list (method-lambda-list method))
+               (let ((gf-nreq (arg-info-number-required arg-info))
+                     (gf-nopt (arg-info-number-optional arg-info))
+                     (gf-key/rest-p (arg-info-key/rest-p arg-info))
+                     (gf-keywords (arg-info-keywords arg-info)))
+                    (unless (= nreq gf-nreq)
+                        (lose "the method has ~A required arguments than the generic function."
+                              (compare nreq gf-nreq)))
+                    (unless (= nopt gf-nopt)
+                        (lose "the method has ~S optional arguments than the generic function."
+                              (compare nopt gf-nopt)))
+                    (unless (eq (or keysp restp)
+                                gf-key/rest-p)
+                           (error "the method and generic function differ in whether they accept~%~
+                  rest or keyword arguments."))
+                    (when gf-keywords
+                        (unless (or (and restp (not keysp))
+                                    allow-other-keys-p
+                                    (every #'(lambda (k)
+                                                    (memq k keywords))
+                                           gf-keywords))
+                               (error "the generic function requires each method to accept the keyword arguments~%~
+               ~S.  The method does not all of accept these." gf-keywords)))
+                    (make-arg-info (arg-info-precedence arg-info)
+                           (mapcar #'raise-metatype (arg-info-metatypes arg-info)
+                                  (method-specializers method))
+                           gf-nopt gf-key/rest-p gf-keywords)))))
+
+(defun remove-arg-info (generic-function method arg-info)
+       (declare (ignore generic-function method))
+       arg-info)
+
+
+;;; 
+
+
+(defun compute-precedence (lambda-list nreq argument-precedence-order)
+       (let ((nreq (analyze-lambda-list lambda-list)))
+            (if (null argument-precedence-order)
+                (let ((c -1))
+                     (gathering1 (collecting)
+                            (dotimes (i nreq)
+                                (gather1 (incf c)))))
+                (mapcar #'(lambda (x)
+                                 (position x lambda-list))
+                       argument-precedence-order))))
+
+(defmethod no-applicable-method (generic-function &rest args)
+       (cerror "Retry call to ~S" 
+         "No matching method for the generic-function ~S,~@
+          when called with arguments ~S." generic-function args)
+       (let ((*invalid-dfuns-on-stack* (remove generic-function *invalid-dfuns-on-stack*)))
+            (invalidate-discriminating-function generic-function)
+            (apply generic-function args)))
+
+(defun real-add-method (generic-function method)
+       (if (method-generic-function method)
+           (error "The method ~S is already part of the generic~@
+              function ~S.  It can't be added to another generic~@
+              function until it is removed from the first one." method (method-generic-function
+                                                                        method))
+           (let* ((qualifiers (method-qualifiers method))
+                  (lambda-list (method-lambda-list method))
+                  (specializers (method-specializers method))
+                  (existing (get-method generic-function qualifiers specializers nil)))
+                 
+                 ;; If there is already a method like this one then we must get rid of it before
+                 ;; proceeding.  Note that we call the generic function remove-method to remove it
+                 ;; rather than doing it in some internal way. 
+                 (when existing (remove-method generic-function existing))
+                 
+                 ;; 
+                 (let ((arg-info (gf-arg-info generic-function)))
+                      (setf (gf-arg-info generic-function)
+                            (if (null arg-info)
+                                (new-arg-info-from-method method)
+                                (add-arg-info generic-function method arg-info)))
+                      (setf (method-generic-function method)
+                            generic-function)
+                      (pushnew method (generic-function-methods generic-function))
+                      (dolist (specializer specializers)
+                          (add-method-on-specializer method specializer))
+                      (invalidate-discriminating-function generic-function)
+                      (maybe-update-constructors generic-function method)
+                      method))))
+
+(defun real-remove-method (generic-function method)
+       (if (neq generic-function (method-generic-function method))
+           (error "The method ~S is attached to the generic function~@
+               ~S.  It can't be removed from the generic function~@
+               to which it is not attached." method (method-generic-function method))
+           (let* ((methods (generic-function-methods generic-function))
+                  (new-methods (remove method methods))
+                  (new-arg-info (remove-arg-info generic-function method (gf-arg-info 
+                                                                                generic-function))))
+                 (setf (method-generic-function method)
+                       nil)
+                 (setf (generic-function-methods generic-function)
+                       new-methods)
+                 (dolist (specializer (method-specializers method))
+                     (remove-method-on-specializer method specializer))
+                 (setf (gf-arg-info generic-function)
+                       new-arg-info)
+                 (invalidate-discriminating-function generic-function)
+                 (maybe-update-constructors generic-function method)
+                 generic-function)))
+
+
+;;; This is it.  You have reached the special place where everything comes together.  This is where
+;;; we ensure that the metacircularity will bottom out properly. Remember once again that the source
+;;; of the problem is that the specified behavior clearly calls for the process of method lookup to
+;;; itself call generic functions.  This implies that for a given generic function in the method
+;;; lookup protocol (compute-applicable-methods for example), we can end up in the unfortunate
+;;; situation of having to call that generic function in order to call it! So, we must arrange to
+;;; snap this infinite regress. The strategy taken here is to identify a particular subset of calls
+;;; to method lookup protocol generic functions and snap the recursion there. This subset of generic
+;;; function calls has the following properties: - Any generic function call in the world will,
+;;; eventually reach one of these generic function calls.  That is we are sure that if we can
+;;; arrange for these calls not to recurse we know we are all set. - These calls themselves don't
+;;; recurse.  We arrange, by magic, for the method lookup and application involved in these calls
+;;; not to call any other generic functions. 
+
+
+(defvar *magic-generic-functions* '((compute-discriminating-function ((standard-generic-function)
+                                                                      (standard-generic-function)))
+                                    (compute-applicable-methods ((standard-generic-function t)
+                                                                 (generic-function t)))
+                                    (compute-applicable-methods-using-classes ((
+                                                                            standard-generic-function
+                                                                                t)
+                                                                               (generic-function
+                                                                                t)))
+                                                             ; (same-specializer-p      
+                                                             ; ((standard-class standard-class) (t
+                                                             ; t))) (specializer-applicable-p
+                                                             ; ((standard-class t) (class t))) 
+                                    (specializer-applicable-using-class-p ((standard-class t)
+                                                                           (class t))
+                                           ((built-in-class t)
+                                            (class t)))
+                                    (order-specializers-using-class ((standard-class standard-class t
+                                                                            )
+                                                                     (class class t)))
+                                    (compute-effective-method ((standard-generic-function
+                                                                (eql *standard-method-combination*)
+                                                                t)
+                                                               (generic-function 
+                                                                      standard-method-combination t))
+                                           )
+                                    (method-p ((standard-method)
+                                               (method))
+                                           ((standard-reader-method)
+                                            (method))
+                                           ((standard-writer-method)
+                                            (method)))
+                                    (standard-accessor-method-p ((standard-method)
+                                                                 (t))
+                                           ((standard-reader-method)
+                                            (standard-accessor-method))
+                                           ((standard-writer-method)
+                                            (standard-accessor-method)))
+                                    (standard-reader-method-p ((standard-method)
+                                                               (t))
+                                           ((standard-reader-method)
+                                            (standard-reader-method))
+                                           ((standard-writer-method)
+                                            (t)))
+                                    (standard-writer-method-p ((standard-method)
+                                                               (t))
+                                           ((standard-reader-method)
+                                            (t))
+                                           ((standard-writer-method)
+                                            (standard-writer-method)))
+                                    (method-qualifiers ((standard-method)
+                                                        (standard-method))
+                                           ((standard-reader-method)
+                                            (standard-method)))
+                                    (method-specializers ((standard-method)
+                                                          (standard-method))
+                                           ((standard-reader-method)
+                                            (standard-method)))
+                                    (method-lambda-list ((standard-method)
+                                                         (standard-method))
+                                           ((standard-reader-method)
+                                            (standard-method)))
+                                    (method-function ((standard-method)
+                                                      (standard-method))
+                                           ((standard-reader-method)
+                                            (standard-method)))
+                                    (accessor-method-slot-name ((standard-reader-method)
+                                                                (standard-accessor-method))
+                                           ((standard-writer-method)
+                                            (standard-accessor-method)))
+                                    (classp ((standard-class)
+                                             (class))
+                                           ((built-in-class)
+                                            (class)))
+                                    (class-precedence-list ((standard-class)
+                                                            (clos-class)))
+                                    (class-finalized-p ((standard-class)
+                                                        (clos-class)))
+                                    (generic-function-methods ((standard-generic-function)
+                                                               (standard-generic-function)))
+                                    (generic-function-method-combination ((standard-generic-function)
+                                                                          (standard-generic-function)
+                                                                          ))
+                                    (gf-arg-info ((standard-generic-function)
+                                                  (standard-generic-function)))
+                                    (gf-dfun-state ((standard-generic-function)
+                                                    (standard-generic-function)))
+                                    (gf-effective-method-functions ((standard-generic-function)
+                                                                    (standard-generic-function)))
+                                    ((setf gf-effective-method-functions)
+                                     ((t standard-generic-function)
+                                      (t standard-generic-function)))
+                                                             ; (gf-permutation                      
+                                                             ; ((standard-generic-function)
+                                                             ; (standard-generic-function))) 
+                                    (slot-value-using-class ((standard-class t 
+                                                                   standard-effective-slot-definition
+                                                                    )
+                                                             ; the first t is a bug
+                                                             (std-class standard-object 
+                                                                   standard-effective-slot-definition
+                                                                    ))
+                                           ((funcallable-standard-class t 
+                                                   standard-effective-slot-definition)
+                                            (std-class standard-object 
+                                                   standard-effective-slot-definition)))
+                                    ((setf slot-value-using-class)
+                                     ((t standard-class t standard-effective-slot-definition)
+                                      (t std-class standard-object standard-effective-slot-definition
+                                         ))
+                                     ((t funcallable-standard-class t 
+                                         standard-effective-slot-definition)
+                                      (t std-class standard-object standard-effective-slot-definition
+                                         )))))
+
+(defvar *magic-generic-functions-1* nil)
+
+(defun
+ fixup-magic-generic-function
+ (gfspec early-methods gf methods)
+ (flet
+  ((get-specls (names convert-t-p)
+          (mapcar #'(lambda (s)
+                           (cond ((consp s)
+                                  `(eql ,(eval (cadr s))))
+                                 ((eq s t)
+                                  (if convert-t-p
+                                      (find-class t)
+                                      t))
+                                 (t (find-class s))))
+                 names)))
+  (let
+   ((e (assoc gfspec *magic-generic-functions* :test #'equal)))
+   (when e
+       (push (list* gf (make-arg-info
+                        nil
+                        (apply #'mapcar #'(lambda (&rest args)
+                                                 (if (every #'(lambda (arg)
+                                                                     (eq arg 't))
+                                                            args)
+                                                     't
+                                                     'standard-instance))
+                               (mapcar #'second (cdr e)))
+                        nil nil nil)
+                    (gathering1 (collecting)
+                           (dolist (pair (cdr e))
+                               (iterate ((em (list-elements early-methods))
+                                         (m (list-elements methods)))
+                                      (when (equal (early-method-specializers em t)
+                                                   (get-specls (cadr pair)
+                                                          t))
+                                          (gather1 (list (get-specls (car pair)
+                                                                nil)
+                                                         (list m)
+                                                         (early-method-function em)))
+                                          (return t))))))
+             *magic-generic-functions-1*)))))
+
+(defun get-secondary-dispatch-function (generic-function args)
+       (declare (values compiled-secondary-dispatch-function methods arg-info))
+       (multiple-value-bind (fn methods arg-info)
+           (get-magic-secondary-dispatch-function generic-function args)
+         (if fn
+             (values fn methods arg-info)
+             (get-normal-secondary-dispatch-function generic-function args))))
+
+(defun get-magic-secondary-dispatch-function (generic-function args)
+       (let ((e (assq generic-function *magic-generic-functions-1*)))
+            (when e
+                (dolist (entry (cddr e))
+                    (destructuring-bind (specls appl function)
+                           entry
+                           (unless (iterate ((arg (list-elements args))
+                                             (specl (list-elements specls)))
+                                          (let ((class (class-of arg)))
+                                               (unless (if (consp specl)
+                                                           (eql (cadr specl)
+                                                                arg)
+                                                           (or (eq specl t)
+                                                               (eq specl class)))
+                                                      (return t))))
+                               (return (values function appl (cadr e)))))))))
+
+(defmacro protect-cache-miss-code (gf args &body body)
+       (let ((wrappers (gensym))
+             (invalidp (gensym))
+             #'(gensym)
+             (appl (gensym)))
+            (once-only (gf args)
+                   `(if (memq ,gf *invalid-dfuns-on-stack*)
+                        (multiple-value-bind (,wrappers ,invalidp ,function ,appl)
+                            (cache-miss-values ,gf ,args)
+                          (declare (ignore ,wrappers ,invalidp))
+                          (if (null ,appl)
+                              (apply #'no-applicable-method ,gf ,args)
+                              (apply ,function ,args)))
+                        (let ((*invalid-dfuns-on-stack* (cons ,gf *invalid-dfuns-on-stack*)))
+                             ,@body)))))
+
+(defmethod same-specializer-p (specl1 specl2)
+       (eq specl1 specl2))
+
+(defmethod specializer-applicable-p ((specializer class)
+                                     object)
+       (memq specializer (class-precedence-list (class-of object))))
+
+(defmethod specializer-applicable-using-class-p ((specializer class)
+                                                 class)
+       (*subtypep class specializer))
+
+(defmethod order-specializers-using-class ((specl1 class)
+                                           (specl2 class)
+                                           class)
+       (cond ((eq specl1 specl2)
+              nil)
+             ((memq specl2 (memq specl1 (class-precedence-list class)))
+              specl1)
+             (t specl2)))
+
+(defmethod compute-applicable-methods ((generic-function generic-function)
+                                       arguments)
+       (labels ((filter (method)
+                       (let ((arguments-tail arguments))
+                            (dolist (m-spec (method-specializers method)
+                                           t)
+                                (unless arguments-tail
+                                    (error "The function ~S requires at least ~D arguments"
+                                           (generic-function-name generic-function)
+                                           (arg-info-number-required (gf-arg-info generic-function))))
+                                (unless (specializer-applicable-p m-spec (pop arguments-tail))
+                                       (return nil)))))
+                (sorter (method-1 method-2)
+                       (dolist (index (arg-info-precedence (gf-arg-info generic-function)))
+                           (let* ((specl1 (nth index (method-specializers method-1)))
+                                  (specl2 (nth index (method-specializers method-2)))
+                                  (class (class-of (nth index arguments)))
+                                  (order (order-specializers-using-class specl1 specl2 class)))
+                                 (when order
+                                     (return-from sorter (eq order specl1)))))))
+              (let ((methods (generic-function-methods generic-function)))
+                   (stable-sort (copy-list (remove-if-not #'filter methods))
+                          #'sorter))))
+
+(defmethod compute-applicable-methods-using-classes ((generic-function generic-function)
+                                                     classes)
+       (labels ((filter (method)
+                       (let ((classes-tail classes))
+                            (dolist (m-spec (method-specializers method)
+                                           t)
+                                (unless classes-tail
+                                    (error "The function ~S requires at least ~D arguments"
+                                           (generic-function-name generic-function)
+                                           (arg-info-number-required (gf-arg-info generic-function))))
+                                (unless (specializer-applicable-using-class-p m-spec (pop 
+                                                                                         classes-tail
+                                                                                          ))
+                                       (return nil)))))
+                (sorter (method-1 method-2)
+                       (dolist (index (arg-info-precedence (gf-arg-info generic-function)))
+                           (let* ((specl1 (nth index (method-specializers method-1)))
+                                  (specl2 (nth index (method-specializers method-2)))
+                                  (class (nth index classes))
+                                  (order (order-specializers-using-class specl1 specl2 class)))
+                                 (when order
+                                     (return-from sorter (eq order specl1)))))))
+              (let ((methods (generic-function-methods generic-function)))
+                   (stable-sort (copy-list (remove-if-not #'filter methods))
+                          #'sorter))))
+
+(defun get-normal-secondary-dispatch-function (generic-function args)
+       (let* ((classes (mapcar #'(lambda (arg mt)
+                                        (declare (ignore mt))
+                                        (class-of arg))
+                              args
+                              (arg-info-metatypes (gf-arg-info generic-function))))
+              (methods (compute-applicable-methods-using-classes generic-function classes))
+              (net (generate-discrimination-net generic-function methods))
+              (arg-info (gf-arg-info generic-function))
+              (metatypes (arg-info-metatypes arg-info))
+              (applyp (arg-info-applyp arg-info)))
+             (flet ((net-test-converter (form)
+                           (if (and (consp form)
+                                    (eq (car form)
+                                        'methods))
+                               '.methods.
+                               (default-test-converter form)))
+                    (net-code-converter (form)
+                           (if (and (consp form)
+                                    (eq (car form)
+                                        'methods))
+                               (let ((gensym (gensym)))
+                                    (values (make-dfun-call metatypes applyp gensym)
+                                           (list gensym)))
+                               (default-code-converter form)))
+                    (net-constant-converter (form)
+                           (if (and (consp form)
+                                    (eq (car form)
+                                        'methods))
+                               (list (get-effective-method-function generic-function (cdr form)))
+                               (default-constant-converter form))))
+                   (if (eq (car net)
+                           'methods)
+                       (and (cdr net)
+                            (values (get-effective-method-function generic-function (cdr net))
+                                   methods))
+                       (values (get-function `(lambda ,(make-dfun-lambda-list metatypes applyp)
+                                                     ,net)
+                                      #'net-test-converter
+                                      #'net-code-converter
+                                      #'net-constant-converter)
+                              methods)))))
+
+(defun get-effective-method-function (generic-function methods)
+       (let ((combin (generic-function-method-combination generic-function))
+             (precomputed (gf-effective-method-functions generic-function)))
+            
+            ;; NOTE: We are assuming a restriction on user code that the method combination must not
+            ;; change once it is connected to the generic function. This has to be legal, because
+            ;; otherwise any kind of method lookup caching couldn't work.  See this by saying that
+            ;; this cache, is just a backing cache for the fast cache.  If that cache is legal, this
+            ;; one must be too. Should altering the set of methods flush this cache? 
+            (let ((entry (assoc methods precomputed :test #'equal)))
+                 (if entry
+                     (values (cdr entry)
+                            (car entry))
+                     (let* ((effective (compute-effective-method generic-function combin methods))
+                            (fn (make-effective-method-function generic-function effective)))
+                           (setf (gf-effective-method-functions generic-function)
+                                 (cons (cons methods fn)
+                                       precomputed))
+                           (values fn methods))))))
+
+(defun
+ generate-discrimination-net
+ (generic-function methods)
+ (let* ((arg-info (gf-arg-info generic-function))
+        (nreq (arg-info-number-required arg-info))
+        (metatypes (arg-info-metatypes arg-info)))
+       (labels ((do-column (position contenders)
+                       (if (< position nreq)
+                           (if (eq (nth position metatypes)
+                                   't)
+                               (do-column (1+ position)
+                                      contenders)
+                               (do-methods position contenders nil nil))
+                           `(methods ,@contenders)))
+                (do-methods
+                 (position contenders known-outcomes winners)
+                 
+                 ;; <contenders> is a (sorted) list of methods that must be discriminated
+                 ;; <known-outcomes> is a list of outcomes from tests already made on this argument
+                 ;; each outcome looks like (<specializer> [t | nil]) <winners> is a (sorted) list
+                 ;; of methods that are potentially applicable after the discrimination has been
+                 ;; made. 
+                 (if (null contenders)
+                     (do-column (1+ position)
+                            winners)
+                     (let* ((method (car contenders))
+                            (specl (nth position (method-specializers method))))
+                           (flet ((determined-to-be (truth-value)
+                                         (if (classp specl)
+                                             truth-value
+                                             (some #'(lambda (outcome)
+                                                            (outcome-implies-p generic-function
+                                                                   (car outcome)
+                                                                   (cadr outcome)
+                                                                   specl truth-value))
+                                                   known-outcomes)))
+                                  (if-true nil (do-methods position (cdr contenders)
+                                                      (if (not (classp specl))
+                                                          (cons `(,specl t)
+                                                                known-outcomes)
+                                                          known-outcomes)
+                                                      (append winners `(,method))))
+                                  (if-false nil (do-methods position (cdr contenders)
+                                                       (if (not (classp specl))
+                                                           (cons `(,specl nil)
+                                                                 known-outcomes)
+                                                           known-outcomes)
+                                                       winners)))
+                                 (cond ((determined-to-be nil)
+                                        (if-false))
+                                       ((determined-to-be t)
+                                        (if-true))
+                                       (t `(if ,(compute-argument-test-form generic-function
+                                                       (dfun-arg-symbol position)
+                                                       specl)
+                                               ,(if-true)
+                                               ,(if-false)))))))))
+              (do-column 0 methods))))
+
+(define-gf-predicate eql-specializer-p eql-specializer)
+
+(defmethod same-specializer-p ((specl1 eql-specializer)
+                               (specl2 eql-specializer))
+       (eql (eql-specializer-object specl1)
+            (eql-specializer-object specl2)))
+
+(defmethod specializer-applicable-p ((specializer eql-specializer)
+                                     object)
+       (eql (eql-specializer-object specializer)
+            object))
+
+(defmethod specializer-applicable-using-class-p ((specializer eql-specializer)
+                                                 class)
+       (eq class (class-of (eql-specializer-object specializer))))
+
+                                                             ; It would be most egregious to use
+                                                             ; *subtypep here. 
+
+
+(defmethod order-specializers-using-class ((specl1 eql-specializer)
+                                           (specl2 eql-specializer)
+                                           argument-class)
+       (declare (ignore argument-class))
+       nil)
+
+(defmethod order-specializers-using-class ((specl1 class)
+                                           (specl2 eql-specializer)
+                                           argument-class)
+       (declare (ignore argument-class))
+       specl2)
+
+(defmethod order-specializers-using-class ((specl1 eql-specializer)
+                                           (specl2 class)
+                                           argument-class)
+       (declare (ignore argument-class))
+       specl1)
+
+
+;;; Does a given pair of values for {<specializer1> <truth1>} imply a given pair of values for
+;;; {<specializer2> <truth2>}. 
+
+
+(defmethod outcome-implies-p ((generic-function generic-function)
+                              (specl1 eql-specializer)
+                              value1
+                              (specl2 eql-specializer)
+                              value2)
+       (flet ((same-truth-value (x y)
+                     (or (and x y)
+                         (and (not x)
+                              (not y)))))
+             (let ((obj1 (eql-specializer-object specl1))
+                   (obj2 (eql-specializer-object specl2)))
+                  (or (and (eql obj1 obj2)
+                           (same-truth-value value1 value2))
+                      (and (not (eql obj1 obj2))
+                           value1
+                           (not value2))))))
+
+
+;;; Return a form which tests a given argument against a given specializer. 
+
+
+(defmethod compute-argument-test-form ((generic-function generic-function)
+                                       argument-form
+                                       (specializer eql-specializer))
+       `(eql ,argument-form ',(eql-specializer-object specializer)))
+
+
+;;; The value returned by compute-discriminating-function is a function object.  It is called a
+;;; discriminating function because it is called when the generic function is called and its role is
+;;; to discriminate on the arguments to the generic function and then call appropriate method
+;;; functions. A discriminating function can only be called when it is installed as the funcallable
+;;; instance function of the generic function for which it was computed. More precisely, if
+;;; compute-discriminating-function is called with an argument <gf1>, and returns a result <df1>,
+;;; that result must not be passed to apply or funcall directly.  Rather, <df1> must be stored as
+;;; the funcallable instance function of the same generic function <gf1> (using
+;;; set-funcallable-instance-function).  Then the generic function can be passed to funcall or
+;;; apply. An important exception is that methods on this generic function are permitted to return a
+;;; function which itself ends up calling the value returned by a more specific method.  This kind
+;;; of `encapsulation' of discriminating function is critical to many uses of the MOP. As an
+;;; example, the following canonical case is legal: (defmethod compute-discriminating-function ((gf
+;;; my-generic-function)) (let ((std (call-next-method))) #'(lambda (arg) (print (list 'call-to-gf
+;;; gf arg)) (funcall std arg)))) Because many discriminating functions would like to use a dynamic
+;;; strategy in which the precise discriminating function changes with time it is important to
+;;; specify how a discriminating function is permitted itself to change the funcallable instance
+;;; function of the generic function. Discriminating functions are may set the funcallable instance
+;;; function of the generic function, but the new value must be generated by making a call to
+;;; COMPUTE-DISCRIMINATING-FUNCTION.  This is to ensure that any more specific methods which may
+;;; have encapsulated the discriminating function will get a chance to encapsulate the new, inner
+;;; discriminating function. This implies that if a discriminating function wants to modify itself
+;;; it should first store some information in the generic function proper, and then call
+;;; compute-discriminating-function.  The appropriate method on compute-discriminating-function will
+;;; see the information stored in the generic function and generate a discriminating function
+;;; accordingly. The following is an example of a discriminating function which modifies itself in
+;;; accordance with this protocol: (defmethod compute-discriminating-function ((gf
+;;; my-generic-function)) #'(lambda (arg) (cond (<some condition> <store some info in the generic
+;;; function> (set-funcallable-instance-function gf (compute-discriminating-function gf)) (funcall
+;;; gf arg)) (t <call-a-method-of-gf>)))) Whereas this code would not be legal: (defmethod
+;;; compute-discriminating-function ((gf my-generic-function)) #'(lambda (arg) (cond (<some
+;;; condition> (set-funcallable-instance-function gf #'(lambda (a) ..)) (funcall gf arg)) (t
+;;; <call-a-method-of-gf>)))) NOTE:  All the examples above assume that all instances of the class
+;;; my generic function accept only one argument. 
+
+
+(defmethod compute-discriminating-function ((gf standard-generic-function))
+       (let* ((state (gf-dfun-state gf))
+              (dfun (typecase state
+                        (null (make-initial-dfun gf))
+                        (function state)
+                        (cons (car state)))))
+             (doctor-dfun-for-the-debugger gf dfun)))
+
+(defun update-dfun (generic-function dfun &optional cache)
+       (let ((ostate (gf-dfun-state generic-function)))
+            (unless (typep ostate '(or null function))
+                (free-cache (cdr ostate)))
+            (setf (gf-dfun-state generic-function)
+                  (if cache
+                      (cons dfun cache)
+                      dfun))
+            (invalidate-dfun-internal generic-function)))
+
+(defvar *generate-random-code-segments* nil)
+
+(defun invalidate-discriminating-function (generic-function)
+       (let ((ostate (gf-dfun-state generic-function)))
+            (unless (typep ostate '(or null function))
+                (free-cache (cdr ostate)))
+            (setf (gf-dfun-state generic-function)
+                  nil)
+            (setf (gf-effective-method-functions generic-function)
+                  nil)
+            (invalidate-dfun-internal generic-function)
+            (when *generate-random-code-segments*
+                (let ((*generate-random-code-segments* nil))
+                     (generate-random-code-segments generic-function)))))
+
+(defun invalidate-dfun-internal (generic-function)
+       
+       ;; Set the funcallable instance function to something that just calls invalid-dfun, that is,
+       ;; arrange to use lazy evaluation to update the dfun later. 
+       (set-funcallable-instance-function generic-function #'(lambda (&rest args)
+                                                                    (invalid-dfun generic-function 
+                                                                           args)))
+       
+       ;; Except that during bootstrapping, we would like to update the dfun right away, and this
+       ;; arranges for that. 
+       (when *invalidate-discriminating-function-force-p*
+           (let ((*invalid-dfuns-on-stack* (cons generic-function *invalid-dfuns-on-stack*)))
+                (set-funcallable-instance-function generic-function (compute-discriminating-function
+                                                                     generic-function)))))
+
+(defun invalid-dfun (gf args)
+       (protect-cache-miss-code gf args (let ((new-dfun (compute-discriminating-function gf)))
+                                             (set-funcallable-instance-function gf new-dfun)
+                                             (apply gf args))))
+
+
+;;; 
+
+
+(defmethod function-keywords ((method standard-method))
+       (multiple-value-bind (nreq nopt keysp restp allow-other-keys-p keywords)
+           (analyze-lambda-list (method-lambda-list method))
+         (declare (ignore nreq nopt keysp restp))
+         (values keywords allow-other-keys-p)))
+
+(defun analyze-lambda-list (lambda-list)
+       (declare (values nrequired noptional keysp restp allow-other-keys-p keywords 
+                       keyword-parameters))
+       (flet ((parse-keyword-argument (arg)
+                     (if (listp arg)
+                         (if (listp (car arg))
+                             (cadar arg)
+                             (make-keyword (car arg)))
+                         (make-keyword arg))))
+             (let ((nrequired 0)
+                   (noptional 0)
+                   (keysp nil)
+                   (restp nil)
+                   (allow-other-keys-p nil)
+                   (keywords nil)
+                   (keyword-parameters nil)
+                   (state 'required))
+                  (dolist (x lambda-list)
+                      (if (memq x lambda-list-keywords)
+                          (case x
+                              (&optional (setq state 'optional))
+                              (&key (setq keysp 't state 'key))
+                              (&allow-other-keys (setq allow-other-keys-p 't))
+                              (&rest (setq restp 't state 'rest))
+                              (&aux (return t))
+                              (otherwise (error 
+                                               "Encountered the non-standard lambda list keyword ~S."
+                                                x)))
+                          (ecase state
+                              (required (incf nrequired))
+                              (optional (incf noptional))
+                              (key 
+                                 (push (parse-keyword-argument x)
+                                       keywords)
+                                 (push x keyword-parameters))
+                              (rest nil))))
+                  (values nrequired noptional keysp restp allow-other-keys-p (reverse keywords)
+                         (reverse keyword-parameters)))))
+
+(defun method-ll->generic-function-ll (ll)
+       (multiple-value-bind (nreq nopt keysp restp allow-other-keys-p keywords keyword-parameters)
+           (analyze-lambda-list ll)
+         (declare (ignore nreq nopt keysp restp allow-other-keys-p keywords))
+         (remove-if #'(lambda (s)
+                             (or (memq s keyword-parameters)
+                                 (eq s '&allow-other-keys)))
+                ll)))
+
+
+;;; This is based on the rules of method lambda list congruency defined in the spec.  The lambda
+;;; list it constructs is the pretty union of the lambda lists of all the methods.  It doesn't take
+;;; method applicability into account at all yet. 
+
+
+(defmethod generic-function-pretty-arglist ((generic-function standard-generic-function))
+       (let ((methods (generic-function-methods generic-function))
+             (arglist nil))
+            (when methods
+                (multiple-value-bind (required optional rest key allow-other-keys)
+                    (method-pretty-arglist (car methods))
+                  (dolist (m (cdr methods))
+                      (multiple-value-bind (method-key-keywords method-allow-other-keys method-key)
+                          (function-keywords m)
+                        
+                        ;; we've modified function-keywords to return what we want as the third
+                        ;; value, no other change here. 
+                        (declare (ignore method-key-keywords))
+                        (setq key (union key method-key))
+                        (setq allow-other-keys (or allow-other-keys method-allow-other-keys))))
+                  (when allow-other-keys
+                      (setq arglist '(&allow-other-keys)))
+                  (when key
+                      (setq arglist (nconc (list '&key)
+                                           key arglist)))
+                  (when rest
+                      (setq arglist (nconc (list '&rest rest)
+                                           arglist)))
+                  (when optional
+                      (setq arglist (nconc (list '&optional)
+                                           optional arglist)))
+                  (nconc required arglist)))))
+
+(defmethod method-pretty-arglist ((method standard-method))
+       (let ((required nil)
+             (optional nil)
+             (rest nil)
+             (key nil)
+             (allow-other-keys nil)
+             (state 'required)
+             (arglist (method-lambda-list method)))
+            (dolist (arg arglist)
+                (cond ((eq arg '&optional)
+                       (setq state 'optional))
+                      ((eq arg '&rest)
+                       (setq state 'rest))
+                      ((eq arg '&key)
+                       (setq state 'key))
+                      ((eq arg '&allow-other-keys)
+                       (setq allow-other-keys 't))
+                      ((memq arg lambda-list-keywords))
+                      (t (ecase state
+                             (required (push arg required))
+                             (optional (push arg optional))
+                             (key (push arg key))
+                             (rest (setq rest arg))))))
+            (values (nreverse required)
+                   (nreverse optional)
+                   rest
+                   (nreverse key)
+                   allow-other-keys)))
diff --git a/clos/3.5/patch.dfasl b/clos/3.5/patch.dfasl
new file mode 100644
index 00000000..157f778a
Binary files /dev/null and b/clos/3.5/patch.dfasl differ
diff --git a/clos/3.5/patch.lisp b/clos/3.5/patch.lisp
new file mode 100644
index 00000000..eab79094
--- /dev/null
+++ b/clos/3.5/patch.lisp
@@ -0,0 +1,143 @@
+(DEFINE-FILE-INFO READTABLE "XCL" PACKAGE (CLIN-PACKAGE "XCL-USER") BASE 10)
+(IL:FILECREATED "19-Feb-91 14:09:19" 
+IL:|{DSK}<usr>local>users>welch>lisp>clos>rev4>il-format>XEROX-PATCHES.;2| 9876   
+
+      IL:|changes| IL:|to:|  (IL:VARS IL:XEROX-PATCHESCOMS)
+
+      IL:|previous| IL:|date:| " 6-Feb-91 10:55:16" 
+IL:|{DSK}<usr>local>users>welch>lisp>clos>rev4>il-format>XEROX-PATCHES.;1|)
+
+
+; Copyright (c) 1991 by Venue.  All rights reserved.
+
+(IL:PRETTYCOMPRINT IL:XEROX-PATCHESCOMS)
+
+(IL:RPAQQ IL:XEROX-PATCHESCOMS (
+
+
+                                    (IL:FUNCTIONS OPTIMIZE-LOGICAL-OP-1-ARG)
+                                    (OPTIMIZERS (LOGIOR :OPTIMIZED-BY OPTIMIZE-LOGICAL-OP-1-ARG)
+                                           (LOGXOR :OPTIMIZED-BY OPTIMIZE-LOGICAL-OP-1-ARG)
+                                           (LOGAND :OPTIMIZED-BY OPTIMIZE-LOGICAL-OP-1-ARG)
+                                           (LOGEQV :OPTIMIZED-BY OPTIMIZE-LOGICAL-OP-1-ARG))
+                                    
+                                    (IL:* IL:|;;| "A bug compiling LABELS")
+
+                                    (IL:FUNCTIONS COMPILER::META-CALL-LABELS)
+                                    (FILE-ENVIRONMENTS "XEROX-PATCHES")))
+
+
+
+
+
+
+(IL:* IL:|;;;| 
+"Declare side-effects (actually, lack of side-effects) info for some internal arithmetic functions.  These are needed because the compiler runs the optimizers before checking the side-effects, so side-effect declarations on the \"real\" functions are oft times ignored. Fix a nit in the compiler While no person would generate code like (logor x), macro can (and do). "
+)
+
+
+(DEFUN OPTIMIZE-LOGICAL-OP-1-ARG (FORM ENV CTXT)
+   (DECLARE (IGNORE ENV CTXT))
+   (IF (= 2 (LENGTH FORM))
+       (SECOND FORM)
+       'COMPILER:PASS))
+
+(DEFOPTIMIZER LOGIOR OPTIMIZE-LOGICAL-OP-1-ARG)
+
+(DEFOPTIMIZER LOGXOR OPTIMIZE-LOGICAL-OP-1-ARG)
+
+(DEFOPTIMIZER LOGAND OPTIMIZE-LOGICAL-OP-1-ARG)
+
+(DEFOPTIMIZER LOGEQV OPTIMIZE-LOGICAL-OP-1-ARG)
+
+
+
+(IL:* IL:|;;| "A bug compiling LABELS")
+
+
+(DEFUN COMPILER::META-CALL-LABELS (COMPILER::NODE COMPILER:CONTEXT)
+
+   (IL:* IL:|;;| "This is similar to META-CALL-LAMBDA, but we have some extra information. There are only required arguments, and we have the correct number of them. ")
+
+   (LET ((COMPILER::*MADE-CHANGES* NIL))
+
+        (IL:* IL:|;;| "First, substitute the functions wherever possible.")
+
+        (DOLIST (COMPILER::FN-PAIR (COMPILER::LABELS-FUNS COMPILER::NODE)
+                       (WHEN (NULL (COMPILER::NODE-META-P (COMPILER::LABELS-BODY COMPILER::NODE)))
+                           (SETF (COMPILER::NODE-META-P COMPILER::NODE)
+                                 NIL)
+                           (SETQ COMPILER::*MADE-CHANGES* T)))
+            (WHEN (COMPILER::SUBSTITUTABLE-P (CDR COMPILER::FN-PAIR)
+                         (CAR COMPILER::FN-PAIR))
+                (LET ((COMPILER::*SUBST-OCCURRED* NIL))
+
+                     (IL:* IL:|;;| "First try substituting into the body.")
+
+                     (SETF (COMPILER::LABELS-BODY COMPILER::NODE)
+                           (COMPILER::META-SUBSTITUTE (CDR COMPILER::FN-PAIR)
+                                  (CAR COMPILER::FN-PAIR)
+                                  (COMPILER::LABELS-BODY COMPILER::NODE)))
+                     (WHEN (NOT COMPILER::*SUBST-OCCURRED*)
+
+                         (IL:* IL:|;;| "Wasn't in the body - try the other functions.")
+
+                         (DOLIST (COMPILER::TARGET-PAIR (COMPILER::LABELS-FUNS COMPILER::NODE))
+                             (UNLESS (EQ COMPILER::TARGET-PAIR COMPILER::FN-PAIR)
+                                 (SETF (CDR COMPILER::TARGET-PAIR)
+                                       (COMPILER::META-SUBSTITUTE (CDR COMPILER::FN-PAIR)
+                                              (CAR COMPILER::FN-PAIR)
+                                              (CDR COMPILER::TARGET-PAIR)))
+                                 (WHEN COMPILER::*SUBST-OCCURRED*
+                                                             (IL:* IL:\; 
+                                                           "Found it, we can stop now.")
+                                     (SETF (COMPILER::NODE-META-P COMPILER::NODE)
+                                           NIL)
+                                     (SETQ COMPILER::*MADE-CHANGES* T)
+                                     (RETURN)))))
+
+                     (IL:* IL:|;;| "May need to reanalyze the node, since things might have changed. Note that reanalyzing the parts of the node this way means the the state in the enclosing loop is not lost. ")
+
+                     (DOLIST (COMPILER::FNS (COMPILER::LABELS-FUNS COMPILER::NODE))
+                         (COMPILER::MEVAL (CDR COMPILER::FNS)
+                                :ARGUMENT))
+                     (COMPILER::MEVAL (COMPILER::LABELS-BODY COMPILER::NODE)
+                            :RETURN))))
+
+        (IL:* IL:|;;| "Now remove any functions that aren't referenced.")
+
+        (DOLIST (COMPILER::FN-PAIR (PROG1 (COMPILER::LABELS-FUNS COMPILER::NODE)
+                                       (SETF (COMPILER::LABELS-FUNS COMPILER::NODE)
+                                             NIL)))
+            (COND
+               ((NULL (COMPILER::VARIABLE-READ-REFS (CAR COMPILER::FN-PAIR)))
+                (COMPILER::RELEASE-TREE (CDR COMPILER::FN-PAIR))
+                (SETQ COMPILER::*MADE-CHANGES* T))
+               (T (PUSH COMPILER::FN-PAIR (COMPILER::LABELS-FUNS COMPILER::NODE)))))
+
+        (IL:* IL:|;;| "If there aren't any functions left, replace the node with its body.")
+
+        (WHEN (NULL (COMPILER::LABELS-FUNS COMPILER::NODE))
+            (LET ((COMPILER::BODY (COMPILER::LABELS-BODY COMPILER::NODE)))
+                 (SETF (COMPILER::LABELS-BODY COMPILER::NODE)
+                       NIL)
+                 (COMPILER::RELEASE-TREE COMPILER::NODE)
+                 (SETQ COMPILER::NODE COMPILER::BODY COMPILER::*MADE-CHANGES* T)))
+
+        (IL:* IL:|;;| "Finally, set the meta-p flag if everythings OK.")
+
+        (IF (NULL COMPILER::*MADE-CHANGES*)
+            (SETF (COMPILER::NODE-META-P COMPILER::NODE)
+                  COMPILER:CONTEXT)
+            (SETF (COMPILER::NODE-META-P COMPILER::NODE)
+                  NIL)))
+   COMPILER::NODE)
+
+(DEFINE-FILE-ENVIRONMENT "XEROX-PATCHES" :PACKAGE (IN-PACKAGE "XCL-USER")
+   :READTABLE "XCL"
+   :BASE 10
+   :COMPILER :COMPILE-FILE)
+(IL:PUTPROPS IL:XEROX-PATCHES IL:COPYRIGHT ("Venue" 1991))
+(IL:DECLARE\: IL:DONTCOPY
+  (IL:FILEMAP (NIL)))
+IL:STOP
diff --git a/clos/3.5/pkg.dfasl b/clos/3.5/pkg.dfasl
new file mode 100644
index 00000000..b67004b2
Binary files /dev/null and b/clos/3.5/pkg.dfasl differ
diff --git a/clos/3.5/pkg.lisp b/clos/3.5/pkg.lisp
new file mode 100644
index 00000000..7491df0d
--- /dev/null
+++ b/clos/3.5/pkg.lisp
@@ -0,0 +1,81 @@
+;;;-*- Package: CLOS; Syntax: Common-Lisp; Base: 10 -*-
+
+
+;;; File converted on 26-Mar-91 10:23:29 from source pkg
+;;;. Original source {dsk}<usr>local>users>welch>lisp>clos>rev4>il-format>pkg.;4 created  1-Mar-91 10:10:26
+
+;;;. Copyright (c) 1991 by Venue
+
+
+(in-package "CLOS")
+
+
+
+;;; Some CommonLisps have more symbols in the Lisp package than the ones that are explicitly
+;;; specified in CLtL.  This causes trouble. Any Lisp that has extra symbols in the Lisp package
+;;; should shadow those symbols in the CLOS package. 
+
+
+(shadow 'cl:documentation)
+
+
+;;; These come from the index pages of 88-002R. 
+
+(eval-when (compile load eval)
+(defvar *exports*
+       '(add-method built-in-class call-method call-next-method change-class class-name class-of 
+               compute-applicable-methods defclass defgeneric define-method-combination defmethod 
+               ensure-generic-function find-class find-method function-keywords generic-flet 
+               generic-labels initialize-instance invalid-method-error make-instance 
+               make-instances-obsolete method-combination-error method-qualifiers next-method-p 
+               no-applicable-method no-next-method print-object reinitialize-instance remove-method 
+               shared-initialize slot-boundp slot-exists-p slot-makunbound slot-missing slot-unbound
+               slot-value standard standard-class standard-generic-function standard-method 
+               standard-object structure-class symbol-macrolet update-instance-for-different-class 
+               update-instance-for-redefined-class with-accessors with-added-methods with-slots))
+
+(import '(xcl:false xcl:destructuring-bind xcl:true) *the-clos-package*)
+
+(export *exports* *the-clos-package*)
+
+(import *exports* (find-package :lisp))
+
+(export *exports* (find-package :lisp)))
+
+                                                             ; (defvar *chapter-3-exports* '(
+                                                             ; get-setf-function
+                                                             ; get-setf-function-name
+                                                             ; class-prototype class object 
+
+
+
+;; essential-class
+
+
+                                                             ; class-name class-precedence-list
+                                                             ; class-local-supers class-local-slots
+                                                             ; class-direct-subclasses
+                                                             ; class-direct-methods class-slots
+                                                             ; method-arglist
+                                                             ; method-argument-specifiers
+                                                             ; method-function method-equal
+                                                             ; slotd-name slot-missing 
+
+
+
+;; define-meta-class %allocate-instance %instance-ref %instancep %instance-meta-class 
+
+
+                                                             ; allocate-instance optimize-slot-value
+                                                             ; optimize-setf-of-slot-value
+                                                             ; add-named-class
+                                                             ; class-for-redefinition add-class
+                                                             ; supers-changed slots-changed
+                                                             ; check-super-metaclass-compatibility
+                                                             ; make-slotd
+                                                             ; compute-class-precedence-list
+                                                             ; walk-method-body
+                                                             ; walk-method-body-form
+                                                             ; add-named-method remove-named-method
+                                                             ; )) 
+
diff --git a/clos/3.5/plap.dfasl b/clos/3.5/plap.dfasl
new file mode 100644
index 00000000..543967d0
Binary files /dev/null and b/clos/3.5/plap.dfasl differ
diff --git a/clos/3.5/plap.lisp b/clos/3.5/plap.lisp
new file mode 100644
index 00000000..49d8b833
--- /dev/null
+++ b/clos/3.5/plap.lisp
@@ -0,0 +1,309 @@
+;;;-*- Package: CLOS; Syntax: Common-Lisp; Base: 10 -*-
+
+
+;;;. Copyright (c) 1991 by Venue
+
+(in-package "CLOS")
+
+
+;;; The portable implementation of the LAP assembler. The portable implementation of the LAP
+;;; assembler works by translating LAP code back into Lisp code and then compiling that Lisp code. 
+;;; Note that this implementation is actually going to get a lot of use.  Some implementations (KCL)
+;;; won't implement a native LAP assembler at all. Other implementations may not implement native
+;;; LAP assemblers for all of their ports.  All of this implies that this portable LAP assembler
+;;; needs to generate the best code it possibly can. 
+
+
+(defmacro
+ lap-case
+ (operand &body cases)
+ (once-only
+  (operand)
+  `(ecase (car ,operand)
+       ,@(mapcar #'(lambda (case)
+                          `(,(car case)
+                            (apply #'(lambda ,(cadr case)
+                                            ,@(cddr case))
+                                   (cdr ,operand))))
+                cases))))
+
+(defvar *lap-args*)
+
+(defvar *lap-rest-p*)
+
+(defvar *lap-i-regs*)
+
+(defvar *lap-v-regs*)
+
+(defvar *lap-t-regs*)
+
+(defvar *lap-optimize-declaration* '((speed 3)
+                                     (safety 0)
+                                     (compilation-speed 0)))
+
+(eval-when (load eval)
+       (setq *make-lap-closure-generator* #'(lambda (closure-var-names arg-names index-regs 
+                                                           vector-regs t-regs lap-code)
+                                                   (compile-lambda (make-lap-closure-generator-lambda
+                                                                    closure-var-names arg-names 
+                                                                    index-regs vector-regs t-regs 
+                                                                    lap-code)))
+             *precompile-lap-closure-generator*
+             #'(lambda (cvars args i-regs v-regs t-regs lap)
+                      `#',(make-lap-closure-generator-lambda cvars args i-regs v-regs t-regs lap))
+             *lap-in-lisp*
+             #'(lambda (cvars args iregs vregs tregs lap)
+                      (declare (ignore cvars args))
+                      (make-lap-prog iregs vregs tregs (flatten-lap lap 
+                                                             ; (opcode :label 'exit-lap-in-lisp)
+                                                              )))))
+
+(defun make-lap-closure-generator-lambda (cvars args i-regs v-regs t-regs lap)
+       (let* ((rest (memq '&rest args))
+              (ldiff (and rest (ldiff args rest))))
+             (when rest
+                 (setq args (append ldiff '(&rest .lap-rest-arg.))))
+             (let* ((*lap-args* (if rest
+                                    ldiff
+                                    args))
+                    (*lap-rest-p* (not (null rest))))
+                   `(lambda ,cvars #'(lambda ,args (declare (optimize . ,*lap-optimize-declaration*))
+                                            ,(make-lap-prog-internal i-regs v-regs t-regs lap))))))
+
+(defun make-lap-prog (i-regs v-regs t-regs lap)
+       (let* ((*lap-args* 'lap-in-lisp)
+              (*lap-rest-p* 'lap-in-lisp))
+             (make-lap-prog-internal i-regs v-regs t-regs lap)))
+
+(defun make-lap-prog-internal (i-regs v-regs t-regs lap)
+       (let* ((*lap-i-regs* i-regs)
+              (*lap-v-regs* v-regs)
+              (*lap-t-regs* t-regs)
+              (code (mapcar #'lap-opcode lap)))
+             `(prog ,(mapcar #'(lambda (reg)
+                                      `(,(lap-reg reg)
+                                        ,(lap-reg-initial-value-form reg)))
+                            (append i-regs v-regs t-regs))
+                    (declare (type fixnum ,@(mapcar #'lap-reg *lap-i-regs*))
+                           (type simple-vector ,@(mapcar #'lap-reg *lap-v-regs*))
+                           (optimize . ,*lap-optimize-declaration*))
+                    ,.code)))
+
+(defconstant *empty-vector* '#())
+
+(defun lap-reg-initial-value-form (reg)
+       (cond ((member reg *lap-i-regs*)
+              0)
+             ((member reg *lap-v-regs*)
+              '*empty-vector*)
+             ((member reg *lap-t-regs*)
+              nil)
+             (t (error "What kind of register is ~S?" reg))))
+
+(defun lap-opcode (opcode)
+       (lap-case opcode (:move (from to)
+                               `(setf ,(lap-operand to)
+                                      ,(lap-operand from)))
+              ((:eq :neq :fix=)
+               (arg1 arg2 label)
+               `(when ,(lap-operands (ecase (car opcode)
+                                         (:eq 'eq)
+                                         (:neq 'neq)
+                                         (:fix= 'runtime\ fix=))
+                              arg1 arg2)
+                    (go ,label)))
+              ((:izerop)
+               (arg label)
+               `(when ,(lap-operands 'runtime\ izerop arg)
+                    (go ,label)))
+              (:std-instance-p (from label)
+                     `(when ,(lap-operands 'runtime\ std-instance-p from)
+                          (go ,label)))
+              (:fsc-instance-p (from label)
+                     `(when ,(lap-operands 'runtime\ fsc-instance-p from)
+                          (go ,label)))
+              (:built-in-instance-p (from label)
+                     (declare (ignore from))
+                     `(when ,t
+                          (go ,label)))
+                                                             ; ***
+              (:structure-instance-p (from label)
+                     `(when ,(lap-operands 'runtime\ ??? from)
+                          (go ,label)))
+                                                             ; ***
+              (:jmp (fn)
+                    (if (eq *lap-args* 'lap-in-lisp)
+                        (error "Can't do a :JMP in LAP-IN-LISP.")
+                        `(return ,(if *lap-rest-p*
+                                      `(runtime\ apply ,(lap-operand fn)
+                                              ,@*lap-args* .lap-rest-arg.)
+                                      `(runtime\ funcall ,(lap-operand fn)
+                                              ,@*lap-args*)))))
+              (:return (value)
+                     `(return ,(lap-operand value)))
+              (:label (label)
+                     label)
+              (:go (label)
+                   `(go ,label))
+              (:exit-lap-in-lisp nil `(go exit-lap-in-lisp))
+              (:break nil `(break))
+              (:beep nil)
+              (:print (val)
+                     (lap-operands 'print val))))
+
+(defun lap-operand (operand)
+       (lap-case operand (:reg (n)
+                               (lap-reg n))
+              (:cdr (reg)
+                    (lap-operands 'cdr reg))
+              ((:cvar :arg)
+               (name)
+               name)
+              (:constant (c)
+                     `',c)
+              ((:std-wrapper :fsc-wrapper :built-in-wrapper :structure-wrapper :std-slots :fsc-slots)
+               (x)
+               (lap-operands (ecase (car operand)
+                                 (:std-wrapper 'runtime\ std-wrapper)
+                                 (:fsc-wrapper 'runtime\ fsc-wrapper)
+                                 (:built-in-wrapper 'runtime\ built-in-wrapper)
+                                 (:structure-wrapper 'runtime\ structure-wrapper)
+                                 (:std-slots 'runtime\ std-slots)
+                                 (:fsc-slots 'runtime\ fsc-slots))
+                      x))
+              (:i1+ (index)
+                    (lap-operands 'runtime\ i1+ index))
+              (:i+ (index1 index2)
+                   (lap-operands 'runtime\ i+ index1 index2))
+              (:i- (index1 index2)
+                   (lap-operands 'runtime\ i- index1 index2))
+              (:ilogand (index1 index2)
+                     (lap-operands 'runtime\ ilogand index1 index2))
+              (:ilogxor (index1 index2)
+                     (lap-operands 'runtime\ ilogxor index1 index2))
+              (:iref (vector index)
+                     (lap-operands 'runtime\ iref vector index))
+              (:iset (vector index value)
+                     (lap-operands 'runtime\ iset vector index value))
+              (:cref (vector i)
+                     `(runtime\ svref ,(lap-operand vector)
+                             ,i))
+              (:lisp-variable (symbol)
+                     symbol)
+              (:lisp (form)
+                     form)))
+
+(defun lap-operands (fn &rest regs)
+       (cons fn (mapcar #'lap-operand regs)))
+
+(defun lap-reg (n)
+       (intern (format nil "REG~D" n)
+              *the-clos-package*))
+
+
+;;; Runtime Implementations of the operands and opcodes. In those ports of CLOS which choose not to
+;;; completely re-implement the LAP code generator, it may still be provident to consider
+;;; reimplementing one or more of these to get the compiler to produce better code.  That is why
+;;; they are split out. 
+
+
+(proclaim '(declaration clos-fast-call))
+
+(defmacro runtime\ funcall (fn &rest args)
+       `(funcall ,fn ,.args))
+
+(defmacro runtime\ apply (fn &rest args)
+       `(apply ,fn ,.args))
+
+(defmacro runtime\ std-wrapper (x)
+       `(std-instance-wrapper ,x))
+
+(defmacro runtime\ fsc-wrapper (x)
+       `(fsc-instance-wrapper ,x))
+
+(defmacro runtime\ built-in-wrapper (x)
+       `(built-in-wrapper-of ,x))
+
+(defmacro runtime\ structure-wrapper (x)
+       `(??? ,x))
+
+(defmacro runtime\ std-slots (x)
+       `(std-instance-slots (the std-instance ,x)))
+
+(defmacro runtime\ fsc-slots (x)
+       `(fsc-instance-slots ,x))
+
+(defmacro runtime\ std-instance-p (x)
+       `(std-instance-p ,x))
+
+(defmacro runtime\ fsc-instance-p (x)
+       `(fsc-instance-p ,x))
+
+(defmacro runtime\ izerop (x)
+       `(zerop (the fixnum ,x)))
+
+(defmacro runtime\ fix= (x y)
+       `(= (the fixnum ,x)
+           (the fixnum ,y)))
+
+
+;;; These are the implementations of the index operands.  The portable assembler generates Lisp code
+;;; that uses these macros.  Even though the variables holding the arguments and results have type
+;;; declarations on them, we put type declarations in here. Some compilers are so stupid... 
+
+
+(defmacro runtime\ iref (vector index)
+       `(svref (the simple-vector ,vector)
+               (the fixnum ,index)))
+
+(defmacro runtime\ iset (vector index value)
+       `(setf (svref (the simple-vector ,vector)
+                     (the fixnum ,index))
+              ,value))
+
+(defmacro runtime\ svref (vector fixnum)
+       `(svref (the simple-vector ,vector)
+               (the fixnum ,fixnum)))
+
+(defmacro runtime\ i+ (index1 index2)
+       `(the fixnum (+ (the fixnum ,index1)
+                       (the fixnum ,index2))))
+
+(defmacro runtime\ i- (index1 index2)
+       `(the fixnum (- (the fixnum ,index1)
+                       (the fixnum ,index2))))
+
+(defmacro runtime\ i1+ (index)
+       `(the fixnum (1+ (the fixnum ,index))))
+
+(defmacro runtime\ ilogand (index1 index2)
+       `(the fixnum (logand (the fixnum ,index1)
+                           (the fixnum ,index2))))
+
+(defmacro runtime\ ilogxor (index1 index2)
+       `(the fixnum (logxor (the fixnum ,index1)
+                           (the fixnum ,index2))))
+
+
+;;; In the portable implementation, indexes are just fixnums. 
+
+
+(defconstant index-value-limit most-positive-fixnum)
+
+(defun index-value->index (index-value)
+       index-value)
+
+(defun index->index-value (index)
+       index)
+
+(defun make-index-mask (cache-size line-size)
+       (let ((cache-size-in-bits (floor (log cache-size 2)))
+             (line-size-in-bits (floor (log line-size 2)))
+             (mask 0))
+            (dotimes (i cache-size-in-bits)
+                (setq mask (dpb 1 (byte 1 i)
+                                mask)))
+            (dotimes (i line-size-in-bits)
+                (setq mask (dpb 0 (byte 1 i)
+                                mask)))
+            mask))
diff --git a/clos/3.5/precom1.dfasl b/clos/3.5/precom1.dfasl
new file mode 100644
index 00000000..a3c45d74
Binary files /dev/null and b/clos/3.5/precom1.dfasl differ
diff --git a/clos/3.5/precom1.lisp b/clos/3.5/precom1.lisp
new file mode 100644
index 00000000..76d6e88b
--- /dev/null
+++ b/clos/3.5/precom1.lisp
@@ -0,0 +1,31 @@
+;;;-*-Mode:LISP; Package:(CLOS LISP 1000); Base:10; Syntax:Common-lisp -*-
+;;;
+;;; *************************************************************************
+;;; Copyright (c) 1991 Venue
+;;; All rights reserved.
+;;; *************************************************************************
+;;;
+
+(in-package 'clos)
+
+;;;
+;;; pre-allocate generic function caches.  The hope is that this will put
+;;; them nicely together in memory, and that that may be a win.  Of course
+;;; the first gc copy will probably blow that out, this really wants to be
+;;; wrapped in something that declares the area static.
+;;;
+;;; This preallocation only creates about 25% more caches than CLOS itself
+;;; uses need.  Some ports may want to preallocate some more of these.
+;;; 
+(eval-when (load)
+  (flet ((allocate (n size)
+	   (mapcar #'free-cache
+		   (mapcar #'get-cache
+			   (make-list n :initial-element size)))))
+    (allocate 128 4)
+    (allocate 64 8)
+    (allocate 64 9)
+    (allocate 32 16)
+    (allocate 16 17)
+    (allocate 16 32)
+    (allocate 1  64)))
\ No newline at end of file
diff --git a/clos/3.5/precom2.dfasl b/clos/3.5/precom2.dfasl
new file mode 100644
index 00000000..45e202cb
Binary files /dev/null and b/clos/3.5/precom2.dfasl differ
diff --git a/clos/3.5/precom2.lisp b/clos/3.5/precom2.lisp
new file mode 100644
index 00000000..0c763a45
--- /dev/null
+++ b/clos/3.5/precom2.lisp
@@ -0,0 +1,12 @@
+;;;-*-Mode:LISP; Package:(CLOS LISP 1000); Base:10; Syntax:Common-lisp -*-
+;;;
+;;; *************************************************************************
+;;; Copyright (c) 1991 Venue
+;;; All rights reserved.
+;;; *************************************************************************
+;;;
+
+(in-package 'clos)
+
+(precompile-dfun-constructors clos)		;this is half of a call to
+						;precompile-random-code-segments
diff --git a/clos/3.5/precom4.dfasl b/clos/3.5/precom4.dfasl
new file mode 100644
index 00000000..203ab57d
Binary files /dev/null and b/clos/3.5/precom4.dfasl differ
diff --git a/clos/3.5/precom4.lisp b/clos/3.5/precom4.lisp
new file mode 100644
index 00000000..06a17cf5
--- /dev/null
+++ b/clos/3.5/precom4.lisp
@@ -0,0 +1,12 @@
+;;;-*-Mode:LISP; Package:(CLOS LISP 1000); Base:10; Syntax:Common-lisp -*-
+;;;
+;;; *************************************************************************
+;;; Copyright (c) 1991 Venue
+;;; All rights reserved.
+;;; *************************************************************************
+;;;
+
+(in-package 'clos)
+
+(precompile-function-generators clos)		;this is half of a call to
+						;precompile-random-code-segments
diff --git a/clos/3.5/slots.dfasl b/clos/3.5/slots.dfasl
new file mode 100644
index 00000000..1f1476be
Binary files /dev/null and b/clos/3.5/slots.dfasl differ
diff --git a/clos/3.5/slots.lisp b/clos/3.5/slots.lisp
new file mode 100644
index 00000000..c21c00d6
--- /dev/null
+++ b/clos/3.5/slots.lisp
@@ -0,0 +1,261 @@
+;;;-*- Package: CLOS; Syntax: Common-Lisp; Base: 10 -*-
+
+
+;;;. Copyright (c) 1991 by Venue
+
+(in-package "CLOS")
+
+;;; These four functions work on std-instances and fsc-instances.  These are instances for which it
+;;; is possible to change the wrapper and the slots. For these kinds of instances, most specified
+;;; methods from the instance structure protocol are promoted to the implementation-specific class
+;;; std-class.  Many of these methods call these four functions. 
+
+
+(defun get-wrapper (inst)
+       (cond ((std-instance-p inst)
+              (std-instance-wrapper inst))
+             ((fsc-instance-p inst)
+              (fsc-instance-wrapper inst))
+             (t (error "What kind of instance is this?"))))
+
+(defun get-slots (inst)
+       (cond ((std-instance-p inst)
+              (std-instance-slots inst))
+             ((fsc-instance-p inst)
+              (fsc-instance-slots inst))
+             (t (error "What kind of instance is this?"))))
+
+(defun set-wrapper (inst new)
+       (cond ((std-instance-p inst)
+              (setf (std-instance-wrapper inst)
+                    new))
+             ((fsc-instance-p inst)
+              (setf (fsc-instance-wrapper inst)
+                    new))
+             (t (error "What kind of instance is this?"))))
+
+(defun set-slots (inst new)
+       (cond ((std-instance-p inst)
+              (setf (std-instance-slots inst)
+                    new))
+             ((fsc-instance-p inst)
+              (setf (fsc-instance-slots inst)
+                    new))
+             (t (error "What kind of instance is this?"))))
+
+(defmacro get-slot-value-2 (instance wrapper slot-name slots index)
+       `(let ((val (%svref ,slots ,index)))
+             (if (eq val ',*slot-unbound*)
+                 (slot-unbound (wrapper-class ,wrapper)
+                        ,instance
+                        ,slot-name)
+                 val)))
+
+(defmacro set-slot-value-2 (nv instance wrapper slot-name slots index)
+       (declare (ignore instance wrapper slot-name))
+       `(setf (%svref ,slots ,index)
+              ,nv))
+
+(defun get-class-slot-value-1 (object wrapper slot-name)
+       (let ((entry (assq slot-name (wrapper-class-slots wrapper))))
+            (if (null entry)
+                (slot-missing (wrapper-class wrapper)
+                       object slot-name 'slot-value)
+                (if (eq (cdr entry)
+                        *slot-unbound*)
+                    (slot-unbound (wrapper-class wrapper)
+                           object slot-name)
+                    (cdr entry)))))
+
+(defun set-class-slot-value-1 (new-value object wrapper slot-name)
+       (let ((entry (assq slot-name (wrapper-class-slots wrapper))))
+            (if (null entry)
+                (slot-missing (wrapper-class wrapper)
+                       object slot-name 'setf new-value)
+                (setf (cdr entry)
+                      new-value))))
+
+(defmethod class-slot-value ((class std-class)
+                             slot-name)
+       (let ((wrapper (class-wrapper class))
+             (prototype (class-prototype class)))
+            (get-class-slot-value-1 prototype wrapper slot-name)))
+
+(defmethod (setf class-slot-value)
+       (nv (class std-class)
+           slot-name)
+       (let ((wrapper (class-wrapper class))
+             (prototype (class-prototype class)))
+            (set-class-slot-value-1 nv prototype wrapper slot-name)))
+
+(defmethod find-slot-definition ((class std-class)
+                                 slot-name)
+       (if (and (eq class *the-class-standard-class*)
+                (eq slot-name 'slots))
+           *the-eslotd-standard-class-slots*
+           (progn (unless (class-finalized-p class)
+                         (finalize-inheritance class))
+                  (dolist (eslotd (class-slots class))
+                      (when (eq (slotd-name eslotd)
+                                slot-name)
+                            (return eslotd))))))
+
+(defun slot-value (object slot-name)
+       (let ((class (class-of object)))
+            (if (eq class *the-class-standard-effective-slot-definition*)
+                (let* ((wrapper (check-wrapper-validity object))
+                       (slots (get-slots object))
+                       (index (instance-slot-index wrapper slot-name)))
+                      (if index
+                          (get-slot-value-2 object wrapper slot-name slots index)
+                          (get-class-slot-value-1 object wrapper slot-name)))
+                (let ((slot-definition (find-slot-definition class slot-name)))
+                     (if (null slot-definition)
+                         (slot-missing class object slot-name 'slot-value)
+                         (slot-value-using-class class object slot-definition))))))
+
+(defun set-slot-value (object slot-name new-value)
+       (let ((class (class-of object)))
+            (if (eq class *the-class-standard-effective-slot-definition*)
+                (let* ((wrapper (check-wrapper-validity object))
+                       (slots (get-slots object))
+                       (index (instance-slot-index wrapper slot-name)))
+                      (if index
+                          (set-slot-value-2 new-value object wrapper slot-name slots index)
+                          (set-class-slot-value-1 new-value object wrapper slot-name)))
+                (let ((slot-definition (find-slot-definition class slot-name)))
+                     (if (null slot-definition)
+                         (slot-missing class object slot-name 'setf)
+                         (setf (slot-value-using-class class object slot-definition)
+                               new-value))))))
+
+(defun slot-boundp (object slot-name)
+       (let* ((class (class-of object))
+              (slot-definition (find-slot-definition class slot-name)))
+             (if (null slot-definition)
+                 (slot-missing class object slot-name 'slot-boundp)
+                 (slot-boundp-using-class class object slot-definition))))
+
+(defun slot-makunbound (object slot-name)
+       (let* ((class (class-of object))
+              (slot-definition (find-slot-definition class slot-name)))
+             (if (null slot-definition)
+                 (slot-missing class object slot-name 'slot-makunbound)
+                 (slot-makunbound-using-class class object slot-definition))))
+
+(defun slot-exists-p (object slot-name)
+       (let* ((class (class-of object))
+              (slot-definition (find-slot-definition class slot-name)))
+             (and slot-definition (slot-exists-p-using-class class object slot-definition))))
+
+
+;;; This isn't documented, but is used within CLOS in a number of print object methods (see
+;;; named-object-print-function). 
+
+
+(defun slot-value-or-default (object slot-name &optional (default "unbound"))
+       (if (slot-boundp object slot-name)
+           (slot-value object slot-name)
+           default))
+
+
+;;; 
+
+
+(defmethod slot-value-using-class ((class std-class)
+                                   (object standard-object)
+                                   (slotd standard-effective-slot-definition))
+       (let* ((wrapper (check-wrapper-validity object))
+                                                             ; trap if need be
+              (slots (get-slots object))
+              (slot-name (slotd-name slotd))
+              (index (or (slotd-instance-index slotd)
+                         (setf (slotd-instance-index slotd)
+                               (instance-slot-index wrapper slot-name)))))
+             (if index
+                 (get-slot-value-2 object wrapper slot-name slots index)
+                 (get-class-slot-value-1 object wrapper slot-name))))
+
+(defmethod (setf slot-value-using-class)
+       (new-value (class std-class)
+              (object standard-object)
+              (slotd standard-effective-slot-definition))
+       (let* ((wrapper (check-wrapper-validity object))
+                                                             ; trap if need be
+              (slots (get-slots object))
+              (slot-name (slotd-name slotd))
+              (index (or (slotd-instance-index slotd)
+                         (setf (slotd-instance-index slotd)
+                               (instance-slot-index wrapper slot-name)))))
+             (if index
+                 (set-slot-value-2 new-value object wrapper slot-name slots index)
+                 (set-class-slot-value-1 new-value object wrapper slot-name))))
+
+(defmethod slot-boundp-using-class ((class std-class)
+                                    (object standard-object)
+                                    (slotd standard-effective-slot-definition))
+       (let* ((wrapper (check-wrapper-validity object))
+                                                             ; trap if need be
+              (slots (get-slots object))
+              (slot-name (slotd-name slotd))
+              (index (or (slotd-instance-index slotd)
+                         (setf (slotd-instance-index slotd)
+                               (instance-slot-index wrapper slot-name)))))
+             (if index
+                 (neq (svref slots index)
+                      *slot-unbound*)
+                 (let ((entry (assq slot-name (wrapper-class-slots wrapper))))
+                      (if (null entry)
+                          (slot-missing class object slot-name 'slot-boundp)
+                          (neq (cdr entry)
+                               *slot-unbound*))))))
+
+(defmethod slot-makunbound-using-class ((class std-class)
+                                        (object standard-object)
+                                        (slotd standard-effective-slot-definition))
+       (let* ((wrapper (check-wrapper-validity object))
+                                                             ; trap if need be
+              (slots (get-slots object))
+              (slot-name (slotd-name slotd))
+              (index (or (slotd-instance-index slotd)
+                         (setf (slotd-instance-index slotd)
+                               (instance-slot-index wrapper slot-name)))))
+             (cond (index (setf (%svref slots index)
+                                *slot-unbound*)
+                          object)
+                   (t (let ((entry (assq slot-name (wrapper-class-slots wrapper))))
+                           (if* (null entry)
+                                (slot-missing class object slot-name 'slot-makunbound)
+                                (setf (cdr entry)
+                                      *slot-unbound*)
+                                object))))))
+
+(defmethod slot-exists-p-using-class ((class std-class)
+                                      (object standard-object)
+                                      (slotd standard-effective-slot-definition))
+       t)
+
+(defmethod slot-missing ((class t)
+                         instance slot-name operation &optional new-value)
+       (error "When attempting to ~A,~%the slot ~S is missing from the object ~S."
+              (ecase operation
+                  (slot-value "read the slot's value (slot-value)")
+                  (setf (format nil "set the slot's value to ~S (setf of slot-value)" new-value))
+                  (slot-boundp "test to see if slot is bound (slot-boundp)")
+                  (slot-makunbound "make the slot unbound (slot-makunbound)"))
+              slot-name instance))
+
+(defmethod slot-unbound ((class t)
+                         instance slot-name)
+       (error "The slot ~S is unbound in the object ~S." slot-name instance))
+
+(defmethod allocate-instance ((class standard-class)
+                              &rest initargs)
+       (declare (ignore initargs))
+       (unless (class-finalized-p class)
+              (finalize-inheritance class))
+       (let* ((class-wrapper (class-wrapper class))
+              (instance (%allocate-instance--class (class-no-of-instance-slots class))))
+             (setf (std-instance-wrapper instance)
+                   class-wrapper)
+             instance))
diff --git a/clos/3.5/std-class.dfasl b/clos/3.5/std-class.dfasl
new file mode 100644
index 00000000..2cf32a27
Binary files /dev/null and b/clos/3.5/std-class.dfasl differ
diff --git a/clos/3.5/std-class.lisp b/clos/3.5/std-class.lisp
new file mode 100644
index 00000000..a07b366c
--- /dev/null
+++ b/clos/3.5/std-class.lisp
@@ -0,0 +1,997 @@
+
+;;;-*- Package: CLOS; Syntax: Common-Lisp; Base: 10 -*-
+
+
+;;; File converted on 10-Apr-91 22:24:19 from source std-class
+;;;. Original source {dsk}<usr>local>users>welch>lisp>clos>rev4>il-format>std-class.;4 created 20-Feb-91 13:07:14
+
+;;;. Copyright (c) 1991 by Venue
+
+
+(in-package "CLOS")
+
+
+
+(define-gf-predicate classp class)
+
+(define-gf-predicate standard-class-p standard-class)
+
+(define-gf-predicate forward-referenced-class-p forward-referenced-class)
+
+(defmethod shared-initialize :after ((object documentation-mixin)
+                                     slot-names &key documentation)
+       (declare (ignore slot-names))
+       (setf (plist-value object 'documentation)
+             documentation))
+
+(defmethod documentation (object &optional doc-type)
+       (cl:documentation object doc-type))
+
+(defmethod (setf documentation)
+       (new-value object &optional doc-type)
+       (declare (ignore new-value doc-type))
+       (error "Can't change the documentation of ~S." object))
+
+(defmethod documentation ((object documentation-mixin)
+                          &optional doc-type)
+  (declare (ignore doc-type))
+  (car (plist-value object 'documentation)))
+
+(defmethod (setf documentation)
+       (new-value (object documentation-mixin)
+              &optional doc-type)
+       (declare (ignore doc-type))
+       (setf (plist-value object 'documentation)
+             new-value))
+
+(defmethod documentation ((slotd standard-slot-definition)
+                          &optional doc-type)
+       (declare (ignore doc-type))
+       (slot-value slotd 'documentation))
+
+(defmethod (setf documentation)
+       (new-value (slotd standard-slot-definition)
+              &optional doc-type)
+       (declare (ignore doc-type))
+       (setf (slot-value slotd 'documentation)
+             new-value))
+
+(defmethod documentation ((method standard-method) &optional doc-type)
+  (declare (ignore doc-type))
+  (plist-value method 'documentation))
+
+(defmethod (setf documentation)
+	   (new-value (method standard-method)
+		      &optional doc-type)
+  (declare (ignore doc-type))
+  (setf (plist-value method 'documentation) new-value))
+
+;;; Various class accessors that are a little more complicated than can be done with automatically
+;;; generated reader methods. 
+
+
+(defmethod class-wrapper ((class clos-class))
+       (with-slots (wrapper)
+           class
+         (let ((w? wrapper))
+              (if (consp w?)
+                  (let ((new (make-wrapper class)))
+                       (setf (wrapper-instance-slots-layout new)
+                             (car w?)
+                             (wrapper-class-slots new)
+                             (cdr w?))
+                       (setq wrapper new))
+                  w?))))
+
+(defmethod class-precedence-list ((class clos-class))
+       (unless (class-finalized-p class)
+              (finalize-inheritance class))
+       (with-slots (class-precedence-list)
+           class
+         class-precedence-list))
+
+(defmethod class-finalized-p ((class clos-class))
+       (with-slots (wrapper)
+           class
+         (not (null wrapper))))
+
+(defmethod class-prototype ((class std-class))
+       (with-slots (prototype)
+           class
+         (or prototype (setq prototype (allocate-instance class)))))
+
+(defmethod class-direct-default-initargs ((class std-class))
+       (plist-value class 'direct-default-initargs))
+
+(defmethod class-default-initargs ((class std-class))
+       (plist-value class 'default-initargs))
+
+(defmethod class-constructors ((class std-class))
+       (plist-value class 'constructors))
+
+(defmethod class-slot-cells ((class std-class))
+       (plist-value class 'class-slot-cells))
+
+
+;;; Class accessors that are even a little bit more complicated than those above.  These have a
+;;; protocol for updating them, we must implement that protocol. Maintaining the direct subclasses
+;;; backpointers.  The update methods are here, the values are read by an automatically generated
+;;; reader method. 
+
+
+(defmethod add-direct-subclass ((class class)
+                                (subclass class))
+       (with-slots (direct-subclasses)
+           class
+         (pushnew subclass direct-subclasses)
+         subclass))
+
+(defmethod remove-direct-subclass ((class class)
+                                   (subclass class))
+       (with-slots (direct-subclasses)
+           class
+         (setq direct-subclasses (remove subclass direct-subclasses))
+         subclass))
+
+
+;;; Maintaining the direct-methods and direct-generic-functions backpointers. There are four generic
+;;; functions involved, each has one method for the class case and another method for the damned EQL
+;;; specializers. All of these are specified methods and appear in their specified place in the
+;;; class graph. ADD-METHOD-ON-SPECIALIZER REMOVE-METHOD-ON-SPECIALIZER SPECIALIZER-METHODS
+;;; SPECIALIZER-GENERIC-FUNCTIONS In each case, we maintain one value which is a cons.  The car is
+;;; the list methods.  The cdr is a list of the generic functions.  The cdr is always computed
+;;; lazily. 
+
+
+(defmethod add-method-on-specializer ((method method)
+                                      (specializer class))
+       (with-slots (direct-methods)
+           specializer
+         (setf (car direct-methods)
+               (adjoin method (car direct-methods))
+               (cdr direct-methods)
+               nil))
+       method)
+
+(defmethod remove-method-on-specializer ((method method)
+                                         (specializer class))
+       (with-slots (direct-methods)
+           specializer
+         (setf (car direct-methods)
+               (remove method (car direct-methods))
+               (cdr direct-methods)
+               nil))
+       method)
+
+(defmethod specializer-methods ((specializer class))
+       (with-slots (direct-methods)
+           specializer
+         (car direct-methods)))
+
+(defmethod specializer-generic-functions ((specializer class))
+       (with-slots (direct-methods)
+           specializer
+         (or (cdr direct-methods)
+             (setf (cdr direct-methods)
+                   (gathering1 (collecting-once)
+                          (dolist (m (car direct-methods))
+                              (gather1 (method-generic-function m))))))))
+
+
+;;; This hash table is used to store the direct methods and direct generic functions of EQL
+;;; specializers.  Each value in the table is the cons. 
+
+
+(defvar *eql-specializer-methods* (make-hash-table :test #'eql))
+
+(defmethod add-method-on-specializer ((method method)
+                                      (specializer eql-specializer))
+       (let* ((object (eql-specializer-object specializer))
+              (entry (gethash object *eql-specializer-methods*)))
+             (unless entry
+                 (setq entry (setf (gethash object *eql-specializer-methods*)
+                                   (cons nil nil))))
+             (setf (car entry)
+                   (adjoin method (car entry))
+                   (cdr entry)
+                   nil)
+             method))
+
+(defmethod remove-method-on-specializer ((method method)
+                                         (specializer eql-specializer))
+       (let* ((object (eql-specializer-object specializer))
+              (entry (gethash object *eql-specializer-methods*)))
+             (when entry
+                 (setf (car entry)
+                       (remove method (car entry))
+                       (cdr entry)
+                       nil))
+             method))
+
+(defmethod specializer-methods ((specializer eql-specializer))
+       (car (gethash (eql-specializer-object specializer)
+                   *eql-specializer-methods*)))
+
+(defmethod specializer-generic-functions ((specializer eql-specializer))
+       (let* ((object (eql-specializer-object specializer))
+              (entry (gethash object *eql-specializer-methods*)))
+             (when entry
+                 (or (cdr entry)
+                     (setf (cdr entry)
+                           (gathering1 (collecting-once)
+                                  (dolist (m (car entry))
+                                      (gather1 (method-generic-function m)))))))))
+
+(defun real-load-defclass (name metaclass-name supers slots other accessors)
+       (do-standard-defsetfs-for-defclass accessors)
+                                                             ; ***
+       (apply #'ensure-class name :metaclass metaclass-name :direct-superclasses supers :direct-slots
+              slots :definition-source `((defclass ,name ()
+                                             ())
+                                         ,(load-truename))
+              other))
+
+(defun ensure-class (name &rest all)
+       (apply #'ensure-class-using-class name (find-class name nil)
+              all))
+
+(defmethod ensure-class-using-class (name (class null)
+                                          &rest args &key)
+       (multiple-value-bind (meta initargs)
+           (ensure-class-values class args)
+         (setf class (apply #'make-instance meta :name name initargs)
+               (find-class name)
+               class)
+	 (inform-type-system-about-class class name)
+                                                             ; ***
+         class))
+
+(defmethod ensure-class-using-class (name (class clos-class)
+                                          &rest args &key)
+       (multiple-value-bind (meta initargs)
+           (ensure-class-values class args)
+         (unless (eq (class-of class)
+                     meta)
+                (change-class class meta))
+         (apply #'reinitialize-instance class initargs)
+         (inform-type-system-about-class class name)
+                                                             ; ***
+         class))
+
+(defun ensure-class-values (class args)
+       (let* ((initargs (copy-list args))
+              (unsupplied (list 1))
+              (supplied-meta (getf initargs :metaclass unsupplied))
+              (supplied-supers (getf initargs :direct-superclasses unsupplied))
+              (supplied-slots (getf initargs :direct-slots unsupplied))
+              (meta (cond ((neq supplied-meta unsupplied)
+                           (find-class supplied-meta))
+                          ((or (null class)
+                               (forward-referenced-class-p class))
+                           *the-class-standard-class*)
+                          (t (class-of class))))
+              (proto (class-prototype meta)))
+             (flet ((fix-super (s)
+                           (cond ((classp s)
+                                  s)
+                                 ((not (legal-class-name-p s))
+                                  (error "~S is not a class or a legal class name." s))
+                                 (t (or (find-class s nil)
+                                        (setf (find-class s)
+                                              (make-instance 'forward-referenced-class :name s)))))))
+                   (loop (unless (remf initargs :metaclass)
+                                (return)))
+                   (loop (unless (remf initargs :direct-superclasses)
+                                (return)))
+                   (loop (unless (remf initargs :direct-slots)
+                                (return)))
+                   (values meta (list* :direct-superclasses (and (neq supplied-supers unsupplied)
+                                                                 (mapcar #'fix-super supplied-supers)
+                                                                 )
+                                       :direct-slots
+                                       (and (neq supplied-slots unsupplied)
+                                            supplied-slots)
+                                       initargs)))))
+
+
+;;; 
+
+
+(defmethod shared-initialize :before ((class std-class)
+                                      slot-names &key direct-superclasses)
+       (declare (ignore slot-names))
+       
+       ;; *** error checking
+       )
+
+(defmethod shared-initialize :after ((class std-class)
+                                     slot-names 
+				     &key (direct-superclasses 
+					   nil direct-superclasses-p)
+                                     (direct-slots nil direct-slots-p)
+                                     (direct-default-initargs 
+				      nil direct-default-initargs-p))
+  (declare (ignore slot-names))
+  (setq direct-superclasses (if direct-superclasses-p
+				(setf (slot-value class 'direct-superclasses)
+				      (or direct-superclasses 
+					  (list *the-class-standard-object*)
+					  ))
+				(slot-value class 'direct-superclasses)))
+  (setq direct-slots (if direct-slots-p
+			 (setf (slot-value class 'direct-slots)
+			       (mapcar #'(lambda (pl)
+					   (make-direct-slotd class pl))
+				       direct-slots))
+			 (slot-value class 'direct-slots)))
+  (if direct-default-initargs-p
+      (setf (plist-value class 'direct-default-initargs)
+	    direct-default-initargs)
+      (setq direct-default-initargs
+	    (plist-value class 'direct-default-initargs)))
+  (setf (plist-value class 'class-slot-cells)
+	(gathering1 (collecting)
+                    (dolist (dslotd direct-slots)
+		      (when (eq (slotd-allocation dslotd)
+				class)
+			(let ((initfunction (slotd-initfunction dslotd)))
+			  (gather1 (cons (slotd-name dslotd)
+					 (if initfunction
+					     (funcall initfunction)
+					     *slot-unbound*))))))))
+  (add-direct-subclasses class direct-superclasses)
+  (add-slot-accessors class direct-slots))
+
+(defmethod reinitialize-instance :before ((class std-class)
+                                          &key direct-superclasses direct-slots 
+                                          direct-default-initargs)
+       (declare (ignore direct-default-initargs))
+       (remove-direct-subclasses class (class-direct-superclasses class))
+       (remove-slot-accessors class (class-direct-slots class)))
+
+(defmethod reinitialize-instance :after ((class std-class)
+                                         &rest initargs &key)
+       (update-class class nil)
+       (map-dependents class #'(lambda (dependent)
+                                      (apply #'update-dependent class dependent initargs))))
+
+(defun add-slot-accessors (class dslotds)
+       (fix-slot-accessors class dslotds 'add))
+
+(defun remove-slot-accessors (class dslotds)
+       (fix-slot-accessors class dslotds 'remove))
+
+(defun fix-slot-accessors (class dslotds add/remove)
+       (flet ((fix (gfspec name r/w)
+                   (let ((gf (ensure-generic-function gfspec)))
+                        (case r/w
+                            (r (if (eq add/remove 'add)
+                                   (add-reader-method class gf name)
+                                   (remove-reader-method class gf)))
+                            (w (if (eq add/remove 'add)
+                                   (add-writer-method class gf name)
+                                   (remove-writer-method class gf)))))))
+             (dolist (dslotd dslotds)
+                 (let ((slot-name (slotd-name dslotd)))
+                      (dolist (r (slotd-readers dslotd))
+                          (fix r slot-name 'r))
+                      (dolist (w (slotd-writers dslotd))
+                          (fix w slot-name 'w))))))
+
+(defun add-direct-subclasses (class new)
+       (dolist (n new)
+           (unless (memq class (class-direct-subclasses class))
+                  (add-direct-subclass n class))))
+
+(defun remove-direct-subclasses (class new)
+       (let ((old (class-direct-superclasses class)))
+            (dolist (o (set-difference old new))
+                (remove-direct-subclass o class))))
+
+
+;;; 
+
+
+(defmethod finalize-inheritance ((class std-class))
+       (update-class class t))
+
+
+;;; Called by :after reinitialize instance whenever a class is reinitialized. The class may or may
+;;; not be finalized. 
+
+
+(defun update-class (class finalizep)
+       (when (or finalizep (class-finalized-p class))
+           (let* ((dsupers (class-direct-superclasses class))
+                  (dslotds (class-direct-slots class))
+                  (dinits (class-direct-default-initargs class))
+                  (cpl (compute-class-precedence-list class dsupers))
+                  (eslotds (compute-slots class cpl dslotds))
+                  (inits (compute-default-initargs class cpl dinits)))
+                 (update-cpl class cpl)
+                 (update-slots class cpl eslotds)
+		 (update-dinits class dinits)
+                 (update-inits class inits)
+                 (update-constructors class)))
+       (unless finalizep
+           (dolist (sub (class-direct-subclasses class))
+               (update-class sub nil))))
+
+(defun update-cpl (class cpl)
+       (when (class-finalized-p class)
+           (unless (equal (class-precedence-list class)
+                          cpl)
+                  (force-cache-flushes class)))
+       (setf (slot-value class 'class-precedence-list)
+             cpl))
+
+(defun update-slots (class cpl eslotds)
+       (multiple-value-bind (nlayout nwrapper-class-slots)
+           (compute-storage-info cpl eslotds)
+         
+         ;; If there is a change in the shape of the instances then the old class is now obsolete. 
+         (let* ((owrapper (class-wrapper class))
+                (olayout (and owrapper (wrapper-instance-slots-layout owrapper)))
+                (owrapper-class-slots (and owrapper (wrapper-class-slots owrapper)))
+                (nwrapper (cond ((null owrapper)
+                                 (make-wrapper class))
+                                ((and (equal nlayout olayout)
+                                      (not (iterate ((o (list-elements owrapper-class-slots))
+                                                     (n (list-elements nwrapper-class-slots)))
+                                                  (unless (eq (car o)
+                                                              (car n))
+                                                         (return t)))))
+                                 owrapper)
+                                (t 
+
+                                 ;; This will initialize the new wrapper to have the same state as
+                                 ;; the old wrapper.  We will then have to change that.  This may
+                                 ;; seem like wasted work (it is), but the spec requires that we
+                                 ;; call make-instances-obsolete. 
+                                   (make-instances-obsolete class)
+                                   (class-wrapper class)))))
+               (with-slots (wrapper no-of-instance-slots slots)
+                   class
+                 (setf no-of-instance-slots (length nlayout)
+                       slots eslotds (wrapper-instance-slots-layout nwrapper)
+                       nlayout
+                       (wrapper-class-slots nwrapper)
+                       nwrapper-class-slots wrapper nwrapper))
+               (dolist (eslotd eslotds)
+                   (setf (slotd-class eslotd)
+                         class)
+                   (setf (slotd-instance-index eslotd)
+                         (instance-slot-index nwrapper (slotd-name eslotd)))))))
+
+(defun compute-storage-info (cpl eslotds)
+       (let ((instance nil)
+             (class nil))
+            (dolist (eslotd eslotds)
+                (let ((alloc (slotd-allocation eslotd)))
+                     (cond ((eq alloc :instance)
+                            (push eslotd instance))
+                           ((classp alloc)
+                            (push eslotd class)))))
+            (values (compute-layout cpl instance)
+                   (compute-class-slots class))))
+
+(defun compute-layout (cpl instance-eslotds)
+       (let* ((names (gathering1 (collecting)
+                            (dolist (eslotd instance-eslotds)
+                                (when (eq (slotd-allocation eslotd)
+                                          :instance)
+                                    (gather1 (slotd-name eslotd))))))
+              (order nil))
+             (labels ((rwalk (tail)
+                             (when tail
+                                 (rwalk (cdr tail))
+                                 (dolist (ss (class-slots (car tail)))
+                                     (let ((n (slotd-name ss)))
+                                          (when (memq n names)
+                                              (setq order (cons n order)
+                                                    names
+                                                    (remove n names))))))))
+                    (rwalk cpl)
+                    (reverse (append names order)))))
+
+(defun compute-class-slots (eslotds)
+       (gathering1 (collecting)
+              (dolist (eslotd eslotds)
+                  (gather1 (assoc (slotd-name eslotd)
+                                  (class-slot-cells (slotd-allocation eslotd)))))))
+(defun update-dinits (class dinits)
+  (setf (plist-value class 'direct-default-initargs) 
+	(remove-invalid dinits (class-slots class))))
+
+(defun update-inits (class inits)
+       (setf (plist-value class 'default-initargs) 
+	     (remove-invalid inits (class-slots class))))
+
+;; bug: :default-initargs aren't updated with slots are removed, so
+;; update-inits removes initargs that don't have corresponding slots.
+
+(defun remove-invalid (inits slotds &aux (return nil))
+  (dolist (element inits)
+    (dolist (slotd slotds)
+      (if (member (car element) (slot-value slotd 'initargs))
+	  (pushnew element return))))
+  return)
+
+
+
+(defmethod compute-default-initargs ((class std-class)
+                                     cpl direct)
+       (labels ((walk (tail)
+                      (if (null tail)
+                          nil
+                          (let ((c (pop tail)))
+                               (append (if (eq c class)
+                                           direct
+                                           (class-direct-default-initargs c))
+                                      (walk tail))))))
+              (let ((initargs (walk cpl)))
+		(delete-duplicates initargs 
+				   :test #'eq :key #'car :from-end t))))
+
+
+;;; Protocols for constructing direct and effective slot definitions. 
+
+
+(defmethod direct-slot-definition-class ((class std-class)
+                                         initargs)
+       (declare (ignore initargs))
+       (find-class 'standard-direct-slot-definition))
+
+(defun make-direct-slotd (class initargs)
+       (let ((initargs (list* :class class initargs)))
+            (apply #'make-instance (direct-slot-definition-class class initargs)
+                   initargs)))
+
+
+;;; 
+
+
+(defmethod compute-slots ((class std-class)
+                          cpl class-direct-slots)
+       
+       ;; As specified, we must call COMPUTE-EFFECTIVE-SLOT-DEFINITION once for each different slot
+       ;; name we find in our superclasses.  Each call receives the class and a list of the dslotds
+       ;; with that name. The list is in most-specific-first order. 
+       (let ((name-dslotds-alist nil))
+            (labels ((collect-one-class (dslotds)
+                            (dolist (d dslotds)
+                                (let* ((name (slotd-name d))
+                                       (entry (assq name name-dslotds-alist)))
+                                      (if entry
+                                          (push d (cdr entry))
+                                          (push (list name d)
+                                                name-dslotds-alist))))))
+                   (collect-one-class class-direct-slots)
+                   (dolist (c (cdr cpl))
+                       (collect-one-class (class-direct-slots c)))
+                   (mapcar #'(lambda (direct)
+                                    (compute-effective-slot-definition class (nreverse (cdr direct)))
+                                    )
+                          name-dslotds-alist))))
+
+(defmethod compute-effective-slot-definition ((class std-class)
+                                              dslotds)
+       (let* ((initargs (compute-effective-slot-definition-initargs class dslotds))
+              (class (effective-slot-definition-class class initargs)))
+             (apply #'make-instance class initargs)))
+
+(defmethod effective-slot-definition-class ((class std-class)
+                                            initargs)
+       (declare (ignore initargs))
+       (find-class 'standard-effective-slot-definition))
+
+(defmethod compute-effective-slot-definition-initargs ((class std-class)
+                                                       direct-slotds)
+       (let* ((name nil)
+              (initfunction nil)
+              (initform nil)
+              (initargs nil)
+              (allocation nil)
+              (type t)
+              (namep nil)
+              (initp nil)
+              (allocp nil))
+             (dolist (slotd direct-slotds)
+                 (when slotd
+                     (unless namep
+                         (setq name (slotd-name slotd)
+                               namep t))
+                     (unless initp
+                         (when (slotd-initfunction slotd)
+                             (setq initform (slotd-initform slotd)
+                                   initfunction
+                                   (slotd-initfunction slotd)
+                                   initp t)))
+                     (unless allocp
+                         (setq allocation (slotd-allocation slotd)
+                               allocp t))
+                     (setq initargs (append (slotd-initargs slotd)
+                                           initargs))
+                     (let ((slotd-type (slotd-type slotd)))
+                          (setq type (cond ((null type)
+                                            slotd-type)
+                                           ((subtypep type slotd-type)
+                                            type)
+                                           (t `(and ,type ,slotd-type)))))))
+             (list :name name :initform initform :initfunction initfunction :initargs initargs 
+                   :allocation allocation :type type)))
+
+
+;;; NOTE: For bootstrapping considerations, these can't use make-instance to make the method object.
+;;; They have to use make-a-method which is a specially bootstrapped mechanism for making standard
+;;; methods. 
+
+
+(defmethod add-reader-method ((class std-class)
+                              generic-function slot-name)
+       (let* ((name (class-name class))
+              (method (make-a-method 'standard-reader-method nil (list (or name 'standard-object))
+                             (list class)
+                             (make-reader-method-function class slot-name)
+                             "automatically generated reader method" slot-name)))
+             (add-method generic-function method)))
+
+(defmethod add-writer-method ((class std-class)
+                              generic-function slot-name)
+       (let* ((name (class-name class))
+              (method (make-a-method 'standard-writer-method nil (list 'new-value (or name
+                                                                                      
+                                                                                      '
+                                                                                      standard-object
+                                                                                      ))
+                             (list *the-class-t* class)
+                             (make-writer-method-function class slot-name)
+                             "automatically generated writer method" slot-name)))
+             (add-method generic-function method)))
+
+(defmethod remove-reader-method ((class std-class)
+                                 generic-function)
+       (let ((method (get-method generic-function nil (list class)
+                            nil)))
+            (when method (remove-method generic-function method))))
+
+(defmethod remove-writer-method ((class std-class)
+                                 generic-function)
+       (let ((method (get-method generic-function nil (list *the-class-t* class)
+                            nil)))
+            (when method (remove-method generic-function method))))
+
+
+;;; make-reader-method-function and make-write-method function are NOT part of the standard
+;;; protocol.  They are however useful, CLOS makes uses makes use of them internally and documents
+;;; them for CLOS users. *** This needs work to make type testing by the writer functions which ***
+;;; do type testing faster.  The idea would be to have one constructor *** for each possible type
+;;; test.  In order to do this it would be nice *** to have help from inform-type-system-about-class
+;;; and friends. *** There is a subtle bug here which is going to have to be fixed. *** Namely, the
+;;; simplistic use of the template has to be fixed.  We *** have to give the optimize-slot-value
+;;; method the user might have *** defined for this metclass a chance to run. 
+
+
+(defmethod make-reader-method-function ((class standard-class)
+                                        slot-name)
+       (make-std-reader-method-function slot-name))
+
+(defmethod make-writer-method-function ((class standard-class)
+                                        slot-name)
+       (make-std-writer-method-function slot-name))
+
+(defun make-std-reader-method-function (slot-name)
+       #'(lambda (instance)
+                (slot-value instance slot-name)))
+
+(defun make-std-writer-method-function (slot-name)
+       #'(lambda (nv instance)
+                (setf (slot-value instance slot-name)
+                      nv)))
+
+                                                             ; inform-type-system-about-class
+                                                             ; make-type-predicate 
+
+
+
+;;; These are NOT part of the standard protocol.  They are internal mechanism which CLOS uses to
+;;; *try* and tell the type system about class definitions. In a more fully integrated
+;;; implementation of CLOS, the type system would know about class objects and class names in a more
+;;; fundamental way and the mechanism used to inform the type system about new classes would be
+;;; different. 
+
+
+(defmethod inform-type-system-about-class ((class std-class)
+                                           name)
+       (let ((predicate-name (make-type-predicate-name name)))
+            (setf (symbol-function predicate-name)
+                  (make-type-predicate name))
+            (do-satisfies-deftype name predicate-name)
+	    (setf (gethash name lisp::*typep-hash-table*)
+		  predicate-name))) ;makes typep significantly faster...
+
+(defun make-type-predicate (name)
+       #'(lambda (x)
+                (not (null (memq (find-class name)
+                                 (cond ((std-instance-p x)
+                                        (class-precedence-list (std-instance-class x)))
+                                       ((fsc-instance-p x)
+                                        (class-precedence-list (fsc-instance-class x)))))))))
+
+
+;;; These 4 definitions appear here for bootstrapping reasons.  Logically, they should be in the
+;;; construct file.  For documentation purposes, a copy of these definitions appears in the
+;;; construct file.  If you change one of the definitions here, be sure to change the copy there. 
+
+
+(defvar *initialization-generic-functions* (list #'make-instance #'default-initargs 
+                                                 #'allocate-instance #'initialize-instance
+                                                 #'shared-initialize))
+
+(defmethod maybe-update-constructors ((generic-function generic-function)
+                                      (method method))
+       (when (memq generic-function *initialization-generic-functions*)
+           (labels ((recurse (class)
+                           (update-constructors class)
+                           (dolist (subclass (class-direct-subclasses class))
+                               (recurse subclass))))
+                  (when (classp (car (method-specializers method)))
+                      (recurse (car (method-specializers method)))))))
+
+(defmethod update-constructors ((class std-class))
+       (dolist (cons (class-constructors class))
+           (install-lazy-constructor-installer cons)))
+
+(defmethod update-constructors ((class class))
+       nil)
+
+(defmethod compatible-meta-class-change-p (class proto-new-class)
+       (eq (class-of class)
+           (class-of proto-new-class)))
+
+(defmethod check-super-metaclass-compatibility ((class t)
+                                                (new-super t))
+       (unless (eq (class-of class)
+                   (class-of new-super))
+           (error "The class ~S was specified as a~%super-class of the class ~S;~%~
+            but the meta-classes ~S and~%~S are incompatible." new-super class (class-of new-super)
+                  (class-of class))))
+
+
+;;; 
+
+
+(defun force-cache-flushes (class)
+       (let* ((owrapper (class-wrapper class))
+              (state (wrapper-state owrapper)))
+             
+             ;; We only need to do something if the state is still T.  If the state isn't T, it will
+             ;; be FLUSH or OBSOLETE, and both of those will already be doing what we want.  In
+             ;; particular, we must be sure we never change an OBSOLETE into a FLUSH since OBSOLETE
+             ;; means do what FLUSH does and then some. 
+             (when (eq state 't)
+                 (let ((nwrapper (make-wrapper class)))
+                      (setf (wrapper-instance-slots-layout nwrapper)
+                            (wrapper-instance-slots-layout owrapper))
+                      (setf (wrapper-class-slots nwrapper)
+                            (wrapper-class-slots owrapper))
+                      (without-interrupts (setf (slot-value class 'wrapper)
+                                                nwrapper)
+                             (invalidate-wrapper owrapper 'flush nwrapper))
+                      (update-constructors class)))))
+
+                                                             ; ??? ***
+
+
+(defun flush-cache-trap (owrapper nwrapper instance)
+       (declare (ignore owrapper))
+       (set-wrapper instance nwrapper))
+
+
+;;; make-instances-obsolete can be called by user code.  It will cause the next access to the
+;;; instance (as defined in 88-002R) to trap through the update-instance-for-redefined-class
+;;; mechanism. 
+
+
+(defmethod make-instances-obsolete ((class std-class))
+       (let ((owrapper (class-wrapper class))
+             (nwrapper (make-wrapper class)))
+            (setf (wrapper-instance-slots-layout nwrapper)
+                  (wrapper-instance-slots-layout owrapper))
+            (setf (wrapper-class-slots nwrapper)
+                  (wrapper-class-slots owrapper))
+            (without-interrupts (setf (slot-value class 'wrapper)
+                                      nwrapper)
+                   (invalidate-wrapper owrapper 'obsolete nwrapper)
+                   class)))
+
+(defmethod make-instances-obsolete ((class symbol))
+       (make-instances-obsolete (find-class class)))
+
+
+;;; obsolete-instance-trap is the internal trap that is called when we see an obsolete instance. 
+;;; The times when it is called are: - when the instance is involved in method lookup - when
+;;; attempting to access a slot of an instance It is not called by class-of, wrapper-of, or any of
+;;; the low-level instance access macros. Of course these times when it is called are an internal
+;;; implementation detail of CLOS and are not part of the documented description of when the obsolete
+;;; instance update happens.  The documented description is as it appears in 88-002R. This has to
+;;; return the new wrapper, so it counts on all the methods on obsolete-instance-trap-internal to
+;;; return the new wrapper.  It also does a little internal error checking to make sure that the
+;;; traps are only happening when they should, and that the trap methods are computing apropriate
+;;; new wrappers. 
+
+
+(defun obsolete-instance-trap (owrapper nwrapper instance)
+       
+       ;; local  --> local        transfer local  --> shared       discard local  -->  --         
+       ;; discard shared --> local        transfer shared --> shared       discard shared -->  --   
+       ;; discard --    --> local        add --    --> shared        -- 
+       (let* ((class (wrapper-class nwrapper))
+              (guts (allocate-instance class))
+                                                             ; ??? allocate-instance ???
+              (olayout (wrapper-instance-slots-layout owrapper))
+              (nlayout (wrapper-instance-slots-layout nwrapper))
+              (oslots (get-slots instance))
+              (nslots (get-slots guts))
+              (oclass-slots (wrapper-class-slots owrapper))
+              (added nil)
+              (discarded nil)
+              (plist nil))
+             
+             ;; Go through all the old local slots. 
+             (iterate ((name (list-elements olayout))
+                       (opos (interval :from 0)))
+                    (let ((npos (posq name nlayout)))
+                         (if npos
+                             (setf (svref nslots npos)
+                                   (svref oslots opos))
+                             (progn (push name discarded)
+                                    (unless (eq (svref oslots opos)
+                                                *slot-unbound*)
+                                        (setf (getf plist name)
+                                              (svref oslots opos)))))))
+             
+             ;; Go through all the old shared slots. 
+             (iterate ((oclass-slot-and-val (list-elements oclass-slots)))
+                    (let ((name (car oclass-slot-and-val))
+                          (val (cdr oclass-slot-and-val)))
+                         (let ((npos (posq name nlayout)))
+                              (if npos
+                                  (setf (svref nslots npos)
+                                        (cdr oclass-slot-and-val))
+                                  (progn (push name discarded)
+                                         (unless (eq val *slot-unbound*)
+                                             (setf (getf plist name)
+                                                   val)))))))
+             
+             ;; Go through all the new local slots to compute the added slots. 
+             (dolist (nlocal nlayout)
+                 (unless (or (memq nlocal olayout)
+                             (assq nlocal oclass-slots))
+                        (push nlocal added)))
+             (without-interrupts (set-wrapper instance nwrapper)
+                    (set-slots instance nslots))
+             (update-instance-for-redefined-class instance added discarded plist)
+             nwrapper))
+
+
+;;; 
+
+
+(defmacro change-class-internal (wrapper-fetcher slots-fetcher alloc)
+       `(let* ((old-class (class-of instance))
+               (copy (,alloc old-class))
+               (guts (,alloc new-class))
+               (new-wrapper (,wrapper-fetcher guts))
+               (old-wrapper (class-wrapper old-class))
+               (old-layout (wrapper-instance-slots-layout old-wrapper))
+               (new-layout (wrapper-instance-slots-layout new-wrapper))
+               (old-slots (,slots-fetcher instance))
+               (new-slots (,slots-fetcher guts))
+               (old-class-slots (wrapper-class-slots old-wrapper)))
+              
+              ;; "The values of local slots specified by both the class Cto and Cfrom are retained. 
+              ;; If such a local slot was unbound, it remains unbound." 
+              (iterate ((new-slot (list-elements new-layout))
+                        (new-position (interval :from 0)))
+                     (let ((old-position (position new-slot old-layout :test #'eq)))
+                          (when old-position
+                              (setf (svref new-slots new-position)
+                                    (svref old-slots old-position)))))
+              
+              ;; "The values of slots specified as shared in the class Cfrom and as local in the
+              ;; class Cto are retained." 
+              (iterate ((slot-and-val (list-elements old-class-slots)))
+                     (let ((position (position (car slot-and-val)
+                                            new-layout :test #'eq)))
+                          (when position
+                              (setf (svref new-slots position)
+                                    (cdr slot-and-val)))))
+              
+              ;; Make the copy point to the old instance's storage, and make the old instance point
+              ;; to the new storage. 
+              (without-interrupts (setf (,slots-fetcher copy)
+                                        old-slots)
+                     (setf (,wrapper-fetcher instance)
+                           new-wrapper)
+                     (setf (,slots-fetcher instance)
+                           new-slots))
+              (update-instance-for-different-class copy instance)
+              instance))
+
+(defmethod change-class ((instance standard-object)
+                         (new-class standard-class))
+       (unless (std-instance-p instance)
+           (error "Can't change the class of ~S to ~S~@
+            because it isn't already an instance with metaclass~%~S." instance new-class 
+                  'standard-class))
+       (change-class-internal std-instance-wrapper std-instance-slots allocate-instance))
+
+(defmethod change-class ((instance standard-object)
+                         (new-class funcallable-standard-class))
+       (unless (fsc-instance-p instance)
+           (error "Can't change the class of ~S to ~S~@
+            because it isn't already an instance with metaclass~%~S." instance new-class 
+                  'funcallable-standard-class))
+       (change-class-internal fsc-instance-wrapper fsc-instance-slots allocate-instance))
+
+(defmethod change-class ((instance t)
+                         (new-class-name symbol))
+       (change-class instance (find-class new-class-name)))
+
+
+;;; The metaclass BUILT-IN-CLASS This metaclass is something of a weird creature.  By this point,
+;;; all instances of it which will exist have been created, and no instance is ever created by
+;;; calling MAKE-INSTANCE. But, there are other parts of the protcol we must follow and those
+;;; definitions appear here. 
+
+
+(defmethod shared-initialize :before ((class built-in-class)
+                                      slot-names &rest initargs)
+       (declare (ignore slot-names))
+       (error "Attempt to initialize or reinitialize a built in class."))
+
+(defmethod class-direct-slots ((class built-in-class))
+       nil)
+
+(defmethod class-slots ((class built-in-class))
+       nil)
+
+(defmethod class-direct-default-initargs ((class built-in-class))
+       nil)
+
+(defmethod class-default-initargs ((class built-in-class))
+       nil)
+
+(defmethod check-super-metaclass-compatibility ((c class)
+                                                (s built-in-class))
+       (or (eq s *the-class-t*)
+           (error "~S cannot have ~S as a super.~%~
+              The class ~S is the only built in class that can be a~%~
+              superclass of a standard class." c s *the-class-t*)))
+
+
+;;; 
+
+
+(defmethod check-super-metaclass-compatibility ((c std-class)
+                                                (f forward-referenced-class))
+       't)
+
+
+;;; 
+
+
+(defmethod add-dependent ((metaobject dependent-update-mixin)
+                          dependent)
+       (pushnew dependent (plist-value metaobject 'dependents)))
+
+(defmethod remove-dependent ((metaobject dependent-update-mixin)
+                             dependent)
+       (setf (plist-value metaobject 'dependents)
+             (delete dependent (plist-value metaobject 'dependents))))
+
+(defmethod map-dependents ((metaobject dependent-update-mixin)
+                           function)
+       (dolist (dependent (plist-value metaobject 'dependents))
+           (funcall function dependent)))
diff --git a/clos/3.5/vector.dfasl b/clos/3.5/vector.dfasl
new file mode 100644
index 00000000..c33ac4f1
Binary files /dev/null and b/clos/3.5/vector.dfasl differ
diff --git a/clos/3.5/vector.lisp b/clos/3.5/vector.lisp
new file mode 100644
index 00000000..5f613f84
--- /dev/null
+++ b/clos/3.5/vector.lisp
@@ -0,0 +1,368 @@
+;;;-*-Mode:LISP; Package:(CLOS LISP 1000); Base:10; Syntax:Common-lisp -*-
+;;;
+;;; *************************************************************************
+;;; Copyright (c) 1991 Venue
+;;; All rights reserved.
+;;; *************************************************************************
+;;;
+;;; Permutation vectors.
+;;;
+
+(in-package 'clos)
+
+(defmacro instance-slot-index (wrapper slot-name)
+  `(let ((pos 0))
+     (block loop
+       (dolist (sn (wrapper-instance-slots-layout ,wrapper))
+	 (when (eq ,slot-name sn) (return-from loop pos))
+	 (incf pos)))))
+
+
+;;;
+;;;
+;;;
+(defmacro %isl-cache           (isl) `(%svref ,isl 1))
+(defmacro %isl-field           (isl) `(%svref ,isl 2))
+(defmacro %isl-mask            (isl) `(%svref ,isl 3))
+(defmacro %isl-size            (isl) `(%svref ,isl 4))
+(defmacro %isl-slot-name-lists (isl) `(%svref ,isl 5))
+
+(defun make-isl (slot-name-lists)
+  (multiple-value-bind (mask size)
+      (compute-primary-pv-cache-size slot-name-lists)
+    (make-isl-internal (wrapper-field 'number)
+		       (get-cache size)
+		       mask
+		       size
+		       slot-name-lists)))
+
+(defun make-isl-internal (field cache mask size slot-name-lists)  
+  (let ((isl (make-array 6)))
+    (setf (svref isl 0)               'isl
+	  (%isl-cache isl)            cache
+	  (%isl-field isl)            field
+	  (%isl-mask  isl)            mask
+	  (%isl-size  isl)            size
+	  (%isl-slot-name-lists isl)  slot-name-lists)
+    isl))
+
+(defun make-isl-type-declaration (var)
+  `(type simple-vector ,var))
+
+(defun islp (x)
+  (and (simple-vector-p x)
+       (= (array-dimension x 0) 5)
+       (eq (svref x 0) 'isl)))
+
+(defvar *slot-name-lists-inner* (make-hash-table :test #'equal))
+(defvar *slot-name-lists-outer* (make-hash-table :test #'equal))
+
+(defun intern-slot-name-lists (slot-name-lists)
+  (flet ((inner (x) 
+	   (or (gethash x *slot-name-lists-inner*)
+	       (setf (gethash x *slot-name-lists-inner*) (copy-list x))))
+	 (outer (x) 
+	   (or (gethash x *slot-name-lists-outer*)
+	       (setf (gethash x *slot-name-lists-outer*) (make-isl (copy-list x))))))
+    (outer (mapcar #'inner slot-name-lists))))
+
+
+
+(defvar *pvs* (make-hash-table :test #'equal))
+
+(defvar default-svuc-method nil)
+(defvar default-setf-svuc-method nil)
+
+(defun optimize-slot-value-by-class-p (class slot-name setf-p)
+  (or (not (eq *boot-state* 'complete))
+      (let* ((slot-definition (find-slot-definition class slot-name))
+	     (gfun-name (if setf-p
+			    '(setf slot-value-using-class) 'slot-value-using-class))
+	     (gfun (gdefinition gfun-name))
+	     (csym (if setf-p 'default-setf-svuc-method 'default-svuc-method))
+	     (app-methods nil))
+	(dolist (method (generic-function-methods gfun))
+	  (let* ((mspecs (method-specializers method))
+		 (specs (if setf-p (cdr mspecs) mspecs)))
+	    (when (and (specializer-applicable-p (first specs) class)
+		       (specializer-applicable-using-class-p (second specs) class)
+		       (specializer-applicable-p (third specs) slot-definition))
+	      (push method app-methods))))
+	(and app-methods (null (cdr app-methods))
+	     (eq (car app-methods)
+		 (or (symbol-value csym)
+		     (let* ((specs (if setf-p
+				       '(t
+					 std-class 
+					 standard-object
+					 standard-effective-slot-definition)
+				       '(std-class 
+					 standard-object
+					 standard-effective-slot-definition)))
+			    (slist (mapcar #'find-class specs)))
+		       (set csym (get-method gfun nil slist)))))))))
+
+(defun lookup-pv (isl args)
+  (let* ((class-slot-p nil)
+	 (elements
+	  (gathering1 (collecting)
+	    (iterate ((slot-names (list-elements (%isl-slot-name-lists isl)))
+		      (arg (list-elements args)))
+	      (when slot-names
+		(let* ((wrapper     (check-wrapper-validity arg))
+		       (class       (wrapper-class wrapper))
+		       (class-slots (wrapper-class-slots wrapper)))
+		  (dolist (slot-name slot-names)
+		    (if (and (optimize-slot-value-by-class-p
+			      class slot-name nil)
+			     (optimize-slot-value-by-class-p
+			      class slot-name t))
+			(let ((index (instance-slot-index wrapper slot-name)))
+			  (if index
+			      (gather1 index)
+			      (let ((cell (assq slot-name class-slots)))
+				(if cell
+				    (progn (setq class-slot-p t) (gather1 cell))
+				    (gather1 nil)))))
+			(gather1 nil)))))))))
+    (if class-slot-p				;Sure is a shame Common Lisp doesn't
+	(make-permutation-vector elements)	;give me the right kind of hash table.
+	(or (gethash elements *pvs*)
+	    (setf (gethash elements *pvs*) (make-permutation-vector elements))))))
+
+(defun make-permutation-vector (indexes)
+  (make-array (length indexes) :initial-contents indexes))
+
+(defun make-pv-type-declaration (var)
+  `(type simple-vector ,var))
+
+(defmacro pvref (pv index)
+  `(svref ,pv ,index))
+
+
+
+(defun can-optimize-access (var required-parameters env)
+  (let ((rebound? (caddr (variable-declaration 'variable-rebinding var env))))
+    (if rebound?
+	(car (memq rebound? required-parameters))
+	(car (memq var required-parameters)))))
+
+(defun optimize-slot-value (slots parameter form)
+  (destructuring-bind (ignore ignore slot-name)
+		      form
+    (optimize-instance-access slots :read parameter (eval slot-name) nil)))
+
+(defun optimize-set-slot-value (slots parameter form)
+  (destructuring-bind (ignore ignore slot-name new-value)
+		      form
+    (optimize-instance-access slots :write parameter (eval slot-name) new-value)))
+
+;;;
+;;; The <slots> argument is an alist, the CAR of each entry is the name of
+;;; a required parameter to the function.  The alist is in order, so the
+;;; position of an entry in the alist corresponds to the argument's position
+;;; in the lambda list.
+;;; 
+(defun optimize-instance-access (slots read/write parameter slot-name new-value)
+  (let* ((parameter-entry (assq parameter slots))
+	 (slot-entry      (assq slot-name (cdr parameter-entry)))
+	 (position (position parameter-entry slots)))
+    (unless parameter-entry
+      (error "Internal error in slot optimization."))
+    (unless slot-entry
+      (setq slot-entry (list slot-name))
+      (push slot-entry (cdr parameter-entry)))
+    (ecase read/write
+      (:read
+	(let ((form (list 'instance-read ''.PV-OFFSET. parameter position 
+			  `',slot-name)))
+	  (push form (cdr slot-entry))
+	  form))
+      (:write
+	(let ((form (list 'instance-write ''.PV-OFFSET. parameter position 
+			  `',slot-name '.new-value.)))
+	  (push form (cdr slot-entry))
+	  `(let ((.new-value. ,new-value)) ,form))))))
+
+(define-walker-template instance-read)
+(define-walker-template instance-write)
+
+
+(defmacro instance-read (pv-offset parameter position slot-name)
+  `(locally
+     (declare (optimize (speed 3) (safety 0) (compilation-speed 0)))
+     (let ((.INDEX. (pvref .PV. ,pv-offset)))
+       (if (and (typep .INDEX. 'fixnum)
+		(neq (setq .INDEX. (%svref ,(slot-vector-symbol position) .INDEX.))
+		     ',*slot-unbound*))
+	   .INDEX.
+	   (pv-access-trap ,parameter .PV. ,pv-offset ,slot-name)))))
+
+(defmacro instance-write (pv-offset parameter position slot-name new-value)
+  `(locally
+     (declare (optimize (speed 3) (safety 0) (compilation-speed 0)))
+     (let ((.INDEX. (pvref .PV. ,pv-offset)))
+       (if (typep .INDEX. 'fixnum)
+	   (setf (%svref ,(slot-vector-symbol position) .INDEX.) ,new-value)
+	   (pv-access-trap ,parameter .PV. ,pv-offset ,slot-name ,new-value)))))
+
+(defun pv-access-trap (instance pv offset slot-name &optional (new-value nil nvp))
+  ;;
+  ;; First thing we do is a quick check to see if this is a class variable.
+  ;; This could be done inline by moving it to INSTANCE-READ/WRITE.  I did
+  ;; not do that because I don't know whether its worth it.
+  ;;
+  (let ((cell (pvref pv offset)))
+    (if (consp cell)
+	(if nvp (setf (cdr cell) new-value) (cdr cell))
+	;;
+	;; Well, now do a slow trap.
+	;; 
+	(if nvp
+	    (setf (slot-value instance slot-name) new-value)
+	    (slot-value instance slot-name)))))
+
+;;;
+;;; This magic function has quite a job to do indeed.
+;;;
+;;; The careful reader will recall that <slots> contains all of the optimized
+;;; slot access forms produced by OPTIMIZE-INSTANCE-ACCESS.  Each of these is
+;;; a call to either INSTANCE-READ or INSTANCE-WRITE.
+;;;
+;;; At the time these calls were produced, the first argument was specified as
+;;; the symbol .PV-OFFSET.; what we have to do now is convert those pv-offset
+;;; arguments into the actual number that is the correct offset into the pv.
+;;;
+;;; But first, oh but first, we sort <slots> a bit so that for each argument
+;;; we have the slots in alphabetical order.  This canonicalizes the ISL's a
+;;; bit and will hopefully lead to having fewer PV's floating around.  Even
+;;; if the gain is only modest, it costs nothing.
+;;;  
+(defun slot-name-lists-from-slots (slots)
+  (mapcar #'(lambda (parameter-entry) (mapcar #'car (cdr parameter-entry)))
+	  (mutate-slots slots)))
+
+(defun mutate-slots (slots)
+  (let ((sorted (sort-slots slots))
+	(pv-offset -1))
+    (dolist (parameter-entry sorted)
+      (dolist (slot-entry (cdr parameter-entry))
+	(incf pv-offset)	
+	(dolist (form (cdr slot-entry))
+	  (setf (cadr form) pv-offset))))
+    sorted))
+
+(defun sort-slots (slots)
+  (mapcar #'(lambda (parameter-entry)
+	      (cons (car parameter-entry)
+		    (sort (cdr parameter-entry)	;slot entries
+			  #'(lambda (a b)
+			      (string-lessp (symbol-name (car a))
+					    (symbol-name (car b)))))))
+	  slots))
+
+
+;;;
+;;; This needs to work in terms of metatypes and also needs to work for
+;;; automatically generated reader and writer functions.
+;;;   
+(defun add-pv-binding (method-body plist required-parameters)
+  (let* ((isl (getf plist :isl))
+	 (isl-cache-symbol (make-symbol "isl-cache")))
+    (nconc plist (list :isl-cache-symbol isl-cache-symbol))
+    (with-gathering ((slot-variables (collecting))
+		     (metatypes (collecting)))
+	  (iterate ((slots (list-elements isl))
+		    (i (interval :from 0)))
+	    (cond (slots
+		   (gather (slot-vector-symbol i) slot-variables)
+		   (gather 'standard-instance     metatypes))
+		  (t
+		   (gather nil slot-variables)
+		   (gather t   metatypes))))
+      `((let ((.ISL. (locally (declare (special ,isl-cache-symbol)) ,isl-cache-symbol))
+	      (.PV. *empty-vector*)
+	      ,@(remove nil slot-variables))
+	  (declare ,(make-isl-type-declaration '.ISL.)
+		   ,(make-pv-type-declaration '.PV.))
+	
+	  (let* ((cache (%isl-cache .ISL.))
+		 (size  (%isl-size  .ISL.))
+		 (mask  (%isl-mask  .ISL.))
+		 (field (%isl-field .ISL.)))
+	    ,(generating-lap-in-lisp '(cache size mask field)
+				     required-parameters
+	       (flatten-lap
+		 (emit-pv-dlap required-parameters metatypes slot-variables))))
+
+	  ,@method-body)))))
+
+(defun emit-pv-dlap (required-parameters metatypes slot-variables)
+  (let* ((slot-regs (mapcar #'(lambda (sv) (and sv (operand :lisp-variable sv)))
+			    slot-variables))
+	 (wrappers (dlap-wrappers metatypes))
+	 (nwrappers (remove nil wrappers)))
+    (flet ((wrapper-moves (miss-label)
+	     (dlap-wrapper-moves wrappers required-parameters metatypes miss-label slot-regs)))
+      (prog1 (emit-dlap-internal
+	       nwrappers                   ;wrapper-regs
+	       (wrapper-moves 'pv-miss)    ;wrapper-moves
+	       (opcode :exit-lap-in-lisp)  ;hit
+	       (flatten-lap		   ;miss
+		 (opcode :label 'pv-miss)
+		 (opcode :move
+			 (operand :lisp `(primary-pv-cache-miss
+					  .ISL. ,@required-parameters))
+			 (operand :lisp-variable '.PV.))
+		 (apply #'flatten-lap (wrapper-moves 'pv-wrapper-miss)) ; -- Maybe the wrappers have changed.
+		 (opcode :label 'pv-wrapper-miss)
+		 (opcode :exit-lap-in-lisp))                               
+	       'pv-miss			    ;miss-label
+	       (operand :lisp-variable '.PV.)) ;value-reg
+	   (mapc #'deallocate-register nwrappers)))))
+
+(defun compute-primary-pv-cache-size (slot-name-lists)
+  (compute-cache-parameters (- (length slot-name-lists) (count nil slot-name-lists))
+			    t
+			    2))
+
+(defun pv-cache-limit-fn (nlines)
+  (default-limit-fn nlines))
+
+(defun primary-pv-cache-miss (isl &rest args)
+  (let* ((wrappers
+	   (gathering1 (collecting) 
+	     (iterate ((slot-names (list-elements (%isl-slot-name-lists isl)))
+		       (arg        (list-elements args)))
+	       (when slot-names (gather1 (check-wrapper-validity arg))))))
+	 (pv (lookup-pv isl args))
+	 (field (%isl-field isl))
+	 (cache (%isl-cache isl))
+	 (nkeys (length wrappers)))
+    (multiple-value-bind (new-field new-cache new-mask new-size)
+	(fill-cache field cache nkeys t #'pv-cache-limit-fn
+		    (if (= nkeys 1) (car wrappers) wrappers)
+		    pv)
+      (when (or (not (= new-field field))
+		(not (eq new-cache cache)))
+	(without-interrupts			;NOTE:
+	  (setf (%isl-field isl) new-field	; There is no mechanism to
+		(%isl-cache isl) new-cache	; synchronize the reading of
+		(%isl-size  isl) new-size	; these values.  But, this is
+		(%isl-mask  isl) new-mask))	; a safe order to write them
+						; in.  Stricly speaking, the
+						; use of without-interrupts
+						; is superfluous.
+	(when (neq new-cache cache) (free-cache cache))))
+    pv))
+
+
+
+(defmethod wrapper-fetcher ((class standard-class))
+  'std-instance-wrapper)
+
+(defmethod slots-fetcher ((class standard-class))
+  'std-instance-slots)
+
+(defmethod raw-instance-allocator ((class standard-class))
+  '%%allocate-instance--class)
diff --git a/clos/3.5/walk.dfasl b/clos/3.5/walk.dfasl
new file mode 100644
index 00000000..2973507f
Binary files /dev/null and b/clos/3.5/walk.dfasl differ
diff --git a/clos/3.5/walk.lisp b/clos/3.5/walk.lisp
new file mode 100644
index 00000000..2172c050
--- /dev/null
+++ b/clos/3.5/walk.lisp
@@ -0,0 +1,2005 @@
+;;;-*- Mode:LISP; Package:(WALKER LISP 1000); Base:10; Syntax:Common-lisp -*-
+;;;
+;;; *************************************************************************
+;;; Copyright (c) 1991 Venue
+;;; All rights reserved.
+;;; *************************************************************************
+;;; 
+;;; A simple code walker, based IN PART on: (roll the credits)
+;;;   Larry Masinter's Masterscope
+;;;   Moon's Common Lisp code walker
+;;;   Gary Drescher's code walker
+;;;   Larry Masinter's simple code walker
+;;;   .
+;;;   .
+;;;   boy, thats fair (I hope).
+;;;
+;;; For now at least, this code walker really only does what CLOS needs it to
+;;; do.  Maybe it will grow up someday.
+;;;
+
+;;;
+;;; This code walker used to be completely portable.  Now it is just "Real
+;;; easy to port".  This change had to happen because the hack that made it
+;;; completely portable kept breaking in different releases of different
+;;; Common Lisps, and in addition it never worked entirely anyways.  So,
+;;; its now easy to port.  To port this walker, all you have to write is one
+;;; simple macro and two simple functions.  These macros and functions are
+;;; used by the walker to manipluate the macroexpansion environments of
+;;; the Common Lisp it is running in.
+;;;
+;;; The code which implements the macroexpansion environment manipulation
+;;; mechanisms is in the first part of the file, the real walker follows it.
+;;; 
+
+(in-package 'walker)
+
+;;;
+;;; The user entry points are walk-form and nested-walked-form.  In addition,
+;;; it is legal for user code to call the variable information functions:
+;;; variable-lexical-p, variable-special-p and variable-class.  Some users
+;;; will need to call define-walker-template, they will have to figure that
+;;; out for themselves.
+;;; 
+(export '(define-walker-template
+	  walk-form
+	  nested-walk-form
+	  variable-lexical-p
+	  variable-special-p
+	  variable-globally-special-p
+	  *variable-declarations*
+	  variable-declaration
+	  ))
+
+
+
+;;;
+;;; On the following pages are implementations of the implementation specific
+;;; environment hacking functions for each of the implementations this walker
+;;; has been ported to.  If you add a new one, so this walker can run in a new
+;;; implementation of Common Lisp, please send the changes back to us so that
+;;; others can also use this walker in that implementation of Common Lisp.
+;;;
+;;; This code just hacks 'macroexpansion environments'.  That is, it is only
+;;; concerned with the function binding of symbols in the environment.  The
+;;; walker needs to be able to tell if the symbol names a lexical macro or
+;;; function, and it needs to be able to build environments which contain
+;;; lexical macro or function bindings.  It must be able, when walking a
+;;; macrolet, flet or labels form to construct an environment which reflects
+;;; the bindings created by that form.  Note that the environment created
+;;; does NOT have to be sufficient to evaluate the body, merely to walk its
+;;; body.  This means that definitions do not have to be supplied for lexical
+;;; functions, only the fact that that function is bound is important.  For
+;;; macros, the macroexpansion function must be supplied.
+;;;
+;;; This code is organized in a way that lets it work in implementations that
+;;; stack cons their environments.  That is reflected in the fact that the
+;;; only operation that lets a user build a new environment is a with-body
+;;; macro which executes its body with the specified symbol bound to the new
+;;; environment.  No code in this walker or in CLOS will hold a pointer to
+;;; these environments after the body returns.  Other user code is free to do
+;;; so in implementations where it works, but that code is not considered
+;;; portable.
+;;;
+;;; There are 3 environment hacking tools.  One macro which is used for
+;;; creating new environments, and two functions which are used to access the
+;;; bindings of existing environments.
+;;;
+;;; WITH-AUGMENTED-ENVIRONMENT
+;;;
+;;; ENVIRONMENT-FUNCTION
+;;;
+;;; ENVIRONMENT-MACRO
+;;; 
+
+(defun unbound-lexical-function (&rest args)
+  (declare (ignore args))
+  (error "The evaluator was called to evaluate a form in a macroexpansion~%~
+          environment constructed by the CLOS portable code walker.  These~%~
+          environments are only useful for macroexpansion, they cannot be~%~
+          used for evaluation.~%~
+          This error should never occur when using CLOS.~%~
+          This most likely source of this error is a program which tries to~%~
+          to use the CLOS portable code walker to build its own evaluator."))
+
+
+;;;
+;;; In Coral Common Lisp, the macroexpansion environment is just a list
+;;; of environment entries.  The cadr of each element specifies the type
+;;; of the element.  The only types that interest us are CCL::MACRO and
+;;; FUNCTION.  In these cases the element is interpreted as follows.
+;;;
+;;;   (<function-name> CCL::MACRO . macroexpansion-function)
+;;;   
+;;;   (<function-name> FUNCTION . <fn>)
+;;;   
+;;;   When in the compiler, <fn> is a gensym which will be
+;;;   a variable which bound at run-time to the function.
+;;;   When in the interpreter, <fn> is the actual function.
+;;;   
+;;;
+#+:Coral
+(progn
+
+(defmacro with-augmented-environment
+	  ((new-env old-env &key functions macros) &body body)
+  `(let ((,new-env (with-augmented-environment-internal ,old-env
+							,functions
+							,macros)))
+     ,@body))
+
+(defun with-augmented-environment-internal (env functions macros)
+  (dolist (f functions)
+    (push (list* f 'function (gensym)) env))
+  (dolist (m macros)
+    (push (list* (car m) 'ccl::macro (cadr m)) env))
+  env)
+
+(defun environment-function (env fn)
+  (let ((entry (assoc fn env :test #'equal)))
+    (and entry
+	 (eq (cadr entry) 'function)
+	 (cddr entry))))
+
+(defun environment-macro (env macro)
+  (let ((entry (assoc macro env :test #'equal)))
+    (and entry
+	 (eq (cadr entry) 'ccl::macro)
+	 (cddr entry))))
+
+);#+:Coral
+
+
+;;;
+;;; Franz Common Lisp is a lot like Coral Lisp.  The macroexpansion
+;;; environment is just a list of entries.  The cadr of each element
+;;; specifies the type of the element.  The types that interest us
+;;; are FUNCTION, EXCL::MACRO, and COMPILER::FUNCTION-VALUE.  These
+;;; are interpreted as follows:
+;;;
+;;;   (<function-name> FUNCTION . <a lexical closure>)
+;;;
+;;;      This happens in the interpreter with lexically
+;;;      bound functions.
+;;;
+;;;   (<function-name> COMPILER::FUNCTION-VALUE . <gensym>)
+;;;
+;;;      This happens in the compiler.  The gensym represents
+;;;      a variable which will be bound at run time to the
+;;;      function object.
+;;;
+;;;   (<function-name> EXCL::MACRO . <a lambda>)
+;;;
+;;;      In both interpreter and compiler, this is the
+;;;      representation used for macro definitions.
+;;;   
+;;;
+#+:ExCL
+(progn
+
+(defmacro with-augmented-environment
+	  ((new-env old-env &key functions macros) &body body)
+  `(let ((,new-env (with-augmented-environment-internal ,old-env
+							,functions
+							,macros)))
+     ,@body))
+
+(defun with-augmented-environment-internal (env functions macros)
+  (dolist (f functions)
+    (push (list* f 'function #'unbound-lexical-function) env))
+  (dolist (m macros)
+    (push (list* (car m) 'excl::macro (cadr m)) env))
+  env)
+
+(defun environment-function (env fn)
+  (let ((entry (assoc fn env :test #'equal)))
+    (and entry
+	 (or (eq (cadr entry) 'function)
+	     (eq (cadr entry) 'compiler::function-value))
+	 (cddr entry))))
+
+(defun environment-macro (env macro)
+  (let ((entry (assoc macro env :test #'equal)))
+    (and entry
+	 (eq (cadr entry) 'excl::macro)
+	 (cddr entry))))
+
+);#+:ExCL
+
+
+#+Lucid
+(progn
+  
+(proclaim '(inline
+	    %alphalex-p
+	    add-contour-to-env-shape
+	    make-function-variable
+	    make-sfc-contour
+	    sfc-contour-type
+	    sfc-contour-elements
+	    add-sfc-contour
+	    add-function-contour
+	    add-macrolet-contour
+	    find-variable-in-contour
+	    find-alist-element-in-contour
+	    find-macrolet-in-contour))
+
+(defun %alphalex-p (object)
+  #-Prime
+  (eq (cadddr (cddddr object)) 'lucid::%alphalex)
+  #+Prime
+  (eq (caddr (cddddr object)) 'lucid::%alphalex))
+
+#+Prime 
+(defun lucid::augment-lexenv-fvars-dummy (lexical vars)
+  (lucid::augment-lexenv-fvars-aux lexical vars '() '() 'flet '()))
+
+(defconstant function-contour 1)
+(defconstant macrolet-contour 5)
+
+(defstruct lucid::contour
+  type
+  elements)
+
+(defun add-contour-to-env-shape (contour-type elements env-shape)
+  (cons (make-contour :type contour-type
+		      :elements elements)
+	env-shape))
+
+(defstruct (variable (:constructor make-variable (name source-type)))
+  name
+  (identifier nil)
+  source-type)
+
+(defconstant function-sfc-contour 1)
+(defconstant macrolet-sfc-contour 8)
+(defconstant function-variable-type 1)
+
+(defun make-function-variable (name)
+  (make-variable name function-variable-type))
+
+(defun make-sfc-contour (type elements)
+  (cons type elements))
+
+(defun sfc-contour-type (sfc-contour)
+  (car sfc-contour))
+
+(defun sfc-contour-elements (sfc-contour)
+  (cdr sfc-contour))
+
+(defun add-sfc-contour (element-list environment type)
+  (cons (make-sfc-contour type element-list) environment))
+
+(defun add-function-contour (variable-list environment)
+  (add-sfc-contour variable-list environment function-sfc-contour))
+
+(defun add-macrolet-contour (alist environment)
+  (add-sfc-contour alist environment macrolet-sfc-contour))
+
+(defun find-variable-in-contour (name contour)
+  (dolist (element (sfc-contour-elements contour) nil)
+    (when (eq (variable-name element) name)
+      (return element))))
+
+(defun find-alist-element-in-contour (name contour)
+  (cdr (assoc name (sfc-contour-elements contour))))
+
+(defun find-macrolet-in-contour (name contour)
+  (find-alist-element-in-contour name contour))
+
+(defmacro do-sfc-contours ((contour-var environment &optional result)
+			   &body body)
+  `(dolist (,contour-var ,environment ,result) ,@body))
+
+
+(defmacro with-augmented-environment
+	  ((new-env old-env &key functions macros) &body body)     
+  `(let* ((,new-env (with-augmented-environment-internal ,old-env
+							 ,functions
+							 ,macros)))
+     ,@body))
+
+;;;
+;;; with-augmented-environment-internal is where the real work of augmenting
+;;; the environment happens.
+;;; 
+(defun with-augmented-environment-internal (env functions macros)
+  (let ((function-names (mapcar #'first functions))
+	(macro-names (mapcar #'first macros))
+	(macro-functions (mapcar #'second macros)))
+    (cond ((or (null env)
+	       (contour-p (first env)))
+	   (when function-names
+	     (setq env (add-contour-to-env-shape function-contour
+						 function-names
+						 env)))
+	   (when macro-names
+	     (setq env (add-contour-to-env-shape macrolet-contour
+						 (pairlis macro-names
+							  macro-functions)
+						 env))))
+	  ((%alphalex-p env)
+	   (when function-names
+	     (setq env (lucid::augment-lexenv-fvars-dummy env function-names)))
+	   (when macro-names
+	     (setq env (lucid::augment-lexenv-mvars env
+						    macro-names
+						    macro-functions))))
+	  (t
+	   (when function-names
+	     (setq env (add-function-contour
+			 (mapcar #'make-function-variable function-names)
+			 env)))
+	   (when macro-names
+	     (setq env (add-macrolet-contour
+			 (pairlis macro-names macro-functions)
+			 env)))))
+    env))
+	 
+
+(defun environment-function (env fn)
+  (cond ((null env) nil)
+	((contour-p (first env))
+	 (if (lucid::find-lexical-function fn env)
+	     t
+	     nil))
+	((%alphalex-p env)
+	 (if (lucid::lexenv-fvar fn env)
+	     t
+	     nil))
+	(t (do-sfc-contours (contour env nil)
+	     (let ((type (sfc-contour-type contour)))
+	       (cond ((eql type function-sfc-contour)
+		      (when (find-variable-in-contour fn contour)
+			(return t)))
+		     ((eql type macrolet-sfc-contour)
+		      (when (find-macrolet-in-contour fn contour)
+			(return nil)))))))))
+		      
+(defun environment-macro (env macro)
+  (cond ((null env) nil)
+	((contour-p (first env))
+	 (lucid::find-lexical-macro macro env))
+	((%alphalex-p env)
+	 (lucid::lexenv-mvar macro env))
+	(t (do-sfc-contours (contour env nil)
+	     (let ((type (sfc-contour-type contour)))
+	       (cond ((eql type function-sfc-contour)
+		      (when (find-variable-in-contour macro contour)
+			(return nil)))
+		     ((eql type macrolet-sfc-contour)
+		      (let ((fn (find-macrolet-in-contour macro contour)))
+			(when fn
+			  (return fn))))))))))
+  
+
+);#+Lucid
+
+
+
+;;;
+;;; On the 3600, the documentation for how the environments are represented
+;;; is in sys:sys;eval.lisp.  That total information is not repeated here.
+;;; The important points are that:
+;;;    si:env-variables returns a list of which each element is:
+;;;
+;;;		(symbol value)
+;;;	     or (symbol . locative)
+;;;
+;;;	The first form is for lexical variables, the second for
+;;;	special and instance variables.  In either case CADR of
+;;;	the entry is the value and SETF of CADR is used to change
+;;;	the value.  Variables are looked up with ASSQ.
+;;;
+;;;    si:env-functions returns a list of which each element is:
+;;;     
+;;;		(symbol definition)
+;;;
+;;;	where definition is anything that could go in a function cell.
+;;;	This is used for both local functions and local macros.
+;;;
+;;; The 3600 stack conses its environments (at least in the interpreter).
+;;; This means that code written using this walker and running on the 3600
+;;; must not hold on to the environment after the walk-function returns.
+;;; No code in this walker or in CLOS does that.
+;;;
+#+Genera
+(progn
+
+(defmacro with-augmented-environment
+	  ((new-env old-env &key functions macros) &body body)
+  (let ((funs (make-symbol "FNS"))
+	(macs (make-symbol "MACROS"))
+	(new  (make-symbol "NEW")))
+    `(let ((,funs ,functions)
+	   (,macs ,macros)
+	   (,new ()))
+       (dolist (f ,funs)
+	 (push `(,(car f) ,#'unbound-lexical-function) ,new))
+       (dolist (m ,macs)
+	 (push `(,(car m) (special ,(cadr m))) ,new))
+       (let* ((.old-env. ,old-env)
+	      (.old-vars. (pop .old-env.))
+	      (.old-funs. (pop .old-env.))
+	      (.old-blks. (pop .old-env.))
+	      (.old-tags. (pop .old-env.))
+	      (.old-dcls. (pop .old-env.)))
+	 (si:with-interpreter-environment (,new-env
+					   .old-env.
+					   .old-vars.
+					   (append ,new .old-funs.)
+					   .old-blks.
+					   .old-tags.
+					   .old-dcls.)
+	   ,@body)))))
+  
+
+(defun environment-function (env fn)
+  (if (null env)
+      (values nil nil)
+      (let ((entry (assoc fn (si:env-functions env) :test #'equal)))
+	(if (and entry
+		 (or (not (listp (cadr entry)))
+		     (not (eq (caadr entry) 'special))))
+	    (values (cadr entry) t)
+	    (environment-function (si:env-parent env) fn)))))
+
+(defun environment-macro (env macro)
+  (if (null env)
+      (values nil nil)
+      (let ((entry (assoc macro (si:env-functions env) :test #'equal)))
+	(if (and entry
+		 (listp (cadr entry))
+		 (eq (caadr entry) 'special))
+	    (values (cadadr entry) t)
+	    (environment-macro (si:env-parent env) macro)))))
+
+);#+Genera
+
+#+Cloe-Runtime
+(progn
+
+(defmacro with-augmented-environment
+	  ((new-env old-env &key functions macros) &body body)
+  `(let ((,new-env (with-augmented-environment-internal ,old-env ,functions ,macros)))
+     ,@body))
+
+(defun with-augmented-environment-internal (env functions macros)
+  functions
+  (dolist (m macros)
+    (setf env `(,(first m) (compiler::macro . ,(second m)) ,@env)))
+  env)
+
+(defun environment-function (env fn)
+  nil)
+
+(defun environment-macro (env macro)
+  (let ((entry (getf env macro)))
+    (if (and (consp entry)
+	     (eq (car entry) 'compiler::macro))
+	(values (cdr entry) t)
+	(values nil nil))))
+
+);#+Cloe-Runtime
+
+
+;;;
+;;; In Xerox Lisp, the compiler and interpreter use different structures for
+;;; the environment.  This doesn't cause a serious problem, the parts of the
+;;; environments we are concerned with are fairly similar.
+;;; 
+#+:Xerox
+(progn
+
+(defmacro with-augmented-environment
+	  ((new-env old-env &key functions macros) &body body)     
+  `(let* ((,new-env (with-augmented-environment-internal ,old-env
+							 ,functions
+							 ,macros)))
+     ,@body))
+
+;;;
+;;; with-augmented-environment-internal is where the real work of augmenting
+;;; the environment happens.  Before it gets there, env had better not be NIL
+;;; anymore because we have to know what kind of environment we are supposed
+;;; to be building up.  This is probably never a real concern in practice.
+;;; It better not be because we don't do anything about it.
+;;; 
+(defun with-augmented-environment-internal (env functions macros)
+  (cond
+     ((compiler::env-p env)
+	(dolist (f functions)
+	   (setq env (compiler::copy-env-with-function
+		       env f :function)))
+	(dolist (m macros)
+	   (setq env (compiler::copy-env-with-function
+	 	  env (car m) :macro (cadr m)))))
+     (t (setq env (if (il:environment-p env)
+		    (il:\\copy-environment env)
+		    (il:\\make-environment)))
+	;; The functions field of the environment is a plist of function names
+	;; and conses like (:function . fn) or (:macro . expansion-fn).
+	;; Note that we can't smash existing entries in this plist since these
+	;; are likely shared with older environments.
+	(dolist (f functions)
+	  (setf (il:environment-functions env)
+		(list* f (cons :function #'unbound-lexical-function)
+		       (il:environment-functions env))))
+	(dolist (m macros)
+	  (setf (il:environment-functions env)
+		(list* (car m) (cons :macro (cadr m))
+		       (il:environment-functions env))))))
+  env)
+
+(defun environment-function (env fn)
+  (cond ((compiler::env-p env) (eq (compiler:env-fboundp env fn) :function))
+	((il:environment-p env) (eq (getf (il:environment-functions env) fn)
+				    :function))
+	(t nil)))
+
+(defun environment-macro (env macro) 
+  (cond ((compiler::env-p env)
+	 (multiple-value-bind (type def)
+	     (compiler:env-fboundp env macro)
+	   (when (eq type :macro) def)))
+	((il:environment-p env)
+	 (xcl:destructuring-bind (type . def)
+	     (getf (il:environment-functions env) macro)
+	   (when (eq type :macro) def)))
+	(t nil)))
+
+);#+:Xerox
+
+
+;;;
+;;; In IBUKI Common Lisp, the macroexpansion environment is a three element
+;;; list.  The second element describes lexical functions and macros.  The 
+;;; function entries in this list have the form 
+;;;     (<name> . (FUNCTION . (<function-value> . nil))
+;;; The macro entries have the form 
+;;;     (<name> . (MACRO . (<macro-value> . nil)).
+;;;
+;;;
+#+(or KCL IBCL)
+(progn
+
+(defmacro with-augmented-environment
+	  ((new-env old-env &key functions macros) &body body)
+	  `(let ((,new-env (with-augmented-environment-internal ,old-env
+								,functions
+								,macros)))
+	     ,@body))
+
+(defun with-augmented-environment-internal (env functions macros)
+  (let ((first (first env))
+	(lexicals (second env))
+	(third (third env)))
+    (dolist (f functions)
+      (push `(,(car f) .  (function  . (,#'unbound-lexical-function . nil)))
+	    lexicals))
+    (dolist (m macros)
+      (push `(,(car m)  .  (macro . ( ,(cadr m) . nil))) 
+	    lexicals))
+    (list first lexicals third)))
+
+(defun environment-function (env fn)
+  (when env
+	(let ((entry (assoc fn (second env))))
+	  (and entry
+	       (eq (cadr entry) 'function)
+	       (caddr entry)))))
+
+(defun environment-macro (env macro)
+  (when env
+	(let ((entry (assoc macro (second env))))
+	  (and entry
+	       (eq (cadr entry) 'macro)
+	       (caddr entry)))))
+);#+(or KCL IBCL)
+
+
+;;;   --- TI Explorer --
+
+;;; An environment is a two element list, whose car we can ignore and
+;;; whose cadr is list of the local-definitions-frames. Each
+;;; local-definitions-frame holds either macros or functions, but not
+;;; both.  Each frame is a plist of <name> <def> <name> <def> ...  where
+;;; <name> is a locative to the function cell of the symbol that names
+;;; the function or macro, and <def> is the new def or NIL if this is function
+;;; redefinition or (cons 'ticl:macro <macro-expansion-function>) if this is a macro
+;;; redefinition.
+;;;
+;;; Here's an example.  For the form:
+;;; (defun foo ()
+;;;   (macrolet ((bar (a b) (list a b))
+;;;	         (bar2 (a b) (list a b)))
+;;;     (flet ((some-local-fn (c d) (print (list c d)))
+;;;	       (another (c d) (print (list c d))))
+;;;       (bar (some-local-fn 1 2) 3))))
+
+;;; the environment arg to macroexpand-1 when called on
+;;; (bar (some-local-fn 1 2) 3)
+;;;is 
+;;;(NIL ((#<DTP-LOCATIVE 4710602> NIL
+;;;       #<DTP-LOCATIVE 4710671> NIL)
+;;;      (#<DTP-LOCATIVE 7346562>
+;;;       (TICL:MACRO TICL:NAMED-LAMBDA (BAR (:DESCRIPTIVE-ARGLIST (A B)))
+;;;		   (SYS::*MACROARG* &OPTIONAL SYS::*MACROENVIRONMENT*)
+;;;		   (BLOCK BAR ....))
+;;;       #<DTP-LOCATIVE 4710664>
+;;;       (TICL:MACRO TICL:NAMED-LAMBDA (BAR2 (:DESCRIPTIVE-ARGLIST (A B)))
+;;;		   (SYS::*MACROARG* &OPTIONAL SYS::*MACROENVIRONMENT*)
+;;;		   (BLOCK BAR2 ....))))
+#+TI
+(progn 
+
+;;; from sys:site;macros.lisp
+(eval-when (compile load eval)
+  
+(DEFMACRO MACRO-DEF? (thing)
+  `(AND (CONSP ,thing) (EQ (CAR ,thing) 'TICL::MACRO)))
+
+;; the following macro generates code to check the 'local' environment
+;; for a macro definition for THE SYMBOL <name>. Such a definition would
+;; be set up only by a MACROLET. If a macro definition for <name> is
+;; found, its expander function is returned.
+
+(DEFMACRO FIND-LOCAL-DEFINITION (name local-function-environment)
+  `(IF ,local-function-environment
+       (LET ((vcell (ticl::LOCF (SYMBOL-FUNCTION ,name))))
+	 (DOLIST (frame  ,local-function-environment)
+	   ;; <value> is nil or a locative
+	   (LET ((value (sys::GET-LOCATION-OR-NIL (ticl::LOCF frame)
+						  vcell))) 
+	     (When value (RETURN (CAR value))))))
+       nil)))
+
+ 
+;;;Edited by Reed Hastings         13 Jan 88  16:29
+(defun environment-macro (env macro)
+  "returns what macro-function would, ie. the expansion function"
+  ;;some code picked off macroexpand-1
+  (let* ((local-definitions (cadr env))
+	 (local-def (find-local-definition macro local-definitions)))
+    (if (macro-def? local-def)
+	(cdr local-def))))
+
+;;;Edited by Reed Hastings         13 Jan 88  16:29
+;;;Edited by Reed Hastings         7 Mar 88  19:07
+(defun environment-function (env fn)
+  (let* ((local-definitions (cadr env)))
+    (dolist (frame local-definitions)
+      (let ((val (getf frame
+		       (ticl::locf (symbol-function fn))
+		       :not-found-marker)))
+	(cond ((eq val :not-found-marker))
+	      ((functionp val) (return t))
+	      ((and (listp val)
+		    (eq (car val) 'ticl::macro))
+	       (return nil))
+	      (t
+	       (error "we are confused")))))))
+	     
+
+;;;Edited by Reed Hastings         13 Jan 88  16:29
+;;;Edited by Reed Hastings         7 Mar 88  19:07
+(defun with-augmented-environment-internal (env functions macros)
+  (let ((local-definitions (cadr env))
+	(new-local-fns-frame
+	  (mapcan #'(lambda (fn)
+		      (list (ticl:locf (symbol-function (car fn)))
+			    #'unbound-lexical-function))
+		  functions))
+	 (new-local-macros-frame
+	   (mapcan #'(lambda (m)
+		       (list (ticl:locf (symbol-function (car m))) (cons 'ticl::macro (cadr m))))
+		   macros)))
+    (when new-local-fns-frame 
+      (push new-local-fns-frame local-definitions))
+    (when new-local-macros-frame
+      (push new-local-macros-frame local-definitions))   
+    `(,(car env) ,local-definitions)))
+
+
+;;;Edited by Reed Hastings         7 Mar 88  19:07
+(defmacro with-augmented-environment
+	  ((new-env old-env &key functions macros) &body body)
+  `(let ((,new-env (with-augmented-environment-internal ,old-env
+							,functions
+							,macros)))
+     ,@body))
+
+);#+TI
+
+
+#+(and dec vax common)
+(progn
+
+(defmacro with-augmented-environment
+	  ((new-env old-env &key functions macros) &body body)
+  `(let ((,new-env (with-augmented-environment-internal ,old-env
+							,functions
+							,macros)))
+     ,@body))
+
+(defun with-augmented-environment-internal (env functions macros)
+  #'(lambda (op &optional (arg nil arg-p))
+      (cond ((eq op :macro-function) 
+	     (unless arg-p (error "Invalid environment use."))
+	     (lookup-macro-function arg env functions macros))
+            (arg-p
+	     (error "Invalid environment operation: ~S ~S" op arg))
+            (t
+	     (lookup-macro-function op env functions macros)))))
+
+(defun lookup-macro-function (name env fns macros)
+  (let ((m (assoc name macros)))
+    (cond (m                (cadr m))
+          ((assoc name fns) :function)
+          (env              (funcall env name))
+          (t                nil))))
+
+(defun environment-macro (env macro)
+  (let ((m (and env (funcall env macro))))
+    (and (not (eq m :function)) 
+         m)))
+
+;;; Nobody calls environment-function.  What would it return, anyway?
+);#+(and dec vax common)
+
+
+;;;
+;;; In Golden Common Lisp, the macroexpansion environment is just a list
+;;; of environment entries.  Unless the car of the list is :compiler-menv 
+;;; it is an interpreted environment.  The cadr of each element specifies 
+;;; the type of the element.  The only types that interest us are GCL:MACRO
+;;; and FUNCTION.  In these cases the element is interpreted as follows.
+;;;
+;;; Compiled:
+;;;   (<function-name> <gensym> macroexpansion-function)
+;;;   (<function-name> <fn>)
+;;;   
+;;; Interpreted:
+;;;   (<function-name> GCL:MACRO macroexpansion-function)
+;;;   (<function-name> <fn>)
+;;;   
+;;;   When in the compiler, <fn> is a gensym which will be
+;;;   a variable which bound at run-time to the function.
+;;;   When in the interpreter, <fn> is the actual function.
+;;;   
+;;;
+#+gclisp
+(progn
+
+(defmacro with-augmented-environment
+	  ((new-env old-env &key functions macros) &body body)
+  `(let ((,new-env (with-augmented-environment-internal ,old-env
+							,functions
+							,macros)))
+     ,@body))
+
+(defun with-augmented-environment-internal (env functions macros)
+  (let ((new-entries nil))
+    (dolist (f functions)
+      (push (cons (car f) nil) new-entries))
+    (dolist (m macros)
+      (push (cons (car m)
+		  (if (eq :compiler-menv (car env))
+		      (if (eq (caadr m) 'lisp::lambda)
+			  `(,(gensym) ,(cadr m))
+			`(,(gensym) ,@(cadr m)))
+		    `(gclisp:MACRO ,@(cadr m))))
+	      new-entries))
+    (if (eq :compiler-menv (car env))
+	`(:compiler-menv ,@new-entries ,@(cdr env))
+      (append new-entries env))))
+
+(defun environment-function (env fn)
+  (let ((entry (lisp::lexical-function fn env)))
+    (and entry 
+	 (eq entry 'lisp::lexical-function)
+	 fn)))
+
+(defun environment-macro (env macro)
+  (let ((entry (assoc macro (if (eq :compiler-menv (first env))
+				 (rest env)
+			       env))))
+    (and entry
+	 (consp entry)
+	 (symbolp (car entry))			;name
+	 (symbolp (cadr entry))			;gcl:macro or gensym
+	 (nthcdr 2 entry))))
+
+);#+gclisp
+
+
+
+(defmacro with-new-definition-in-environment
+	  ((new-env old-env macrolet/flet/labels-form) &body body)
+  (let ((functions (make-symbol "Functions"))
+	(macros (make-symbol "Macros")))
+    `(let ((,functions ())
+	   (,macros ()))
+       (ecase (car ,macrolet/flet/labels-form)
+	 ((flet labels)
+	  (dolist (fn (cadr ,macrolet/flet/labels-form))
+	    (push fn ,functions)))
+	 ((macrolet)
+	  (dolist (mac (cadr ,macrolet/flet/labels-form))
+	    (push (list (car mac)
+			(convert-macro-to-lambda (cadr mac)
+						 (cddr mac)
+						 (string (car mac))))
+		  ,macros))))
+       (with-augmented-environment
+	      (,new-env ,old-env :functions ,functions :macros ,macros)
+	 ,@body))))
+
+#-Genera
+(defun convert-macro-to-lambda (llist body &optional (name "Dummy Macro"))
+  (let ((gensym (make-symbol name)))
+    (eval `(defmacro ,gensym ,llist ,@body))
+    (macro-function gensym)))
+
+#+Genera
+(defun convert-macro-to-lambda (llist body &optional (name "Dummy Macro"))
+  (si:defmacro-1
+    'sys:named-lambda 'sys:special (make-symbol name) llist body))
+
+
+
+
+
+;;;
+;;; Now comes the real walker.
+;;;
+;;; As the walker walks over the code, it communicates information to itself
+;;; about the walk.  This information includes the walk function, variable
+;;; bindings, declarations in effect etc.  This information is inherently
+;;; lexical, so the walker passes it around in the actual environment the
+;;; walker passes to macroexpansion functions.  This is what makes the
+;;; nested-walk-form facility work properly.
+;;;
+(defmacro walker-environment-bind ((var env &rest key-args)
+				      &body body)
+  `(with-augmented-environment
+     (,var ,env :macros (walker-environment-bind-1 ,env ,.key-args))
+     .,body))
+
+(defvar *key-to-walker-environment* (gensym))
+
+(defun env-lock (env)
+  (environment-macro env *key-to-walker-environment*))
+
+(defun walker-environment-bind-1 (env &key (walk-function nil wfnp)
+					   (walk-form nil wfop)
+					   (declarations nil decp)
+					   (lexical-variables nil lexp))
+  (let ((lock (environment-macro env *key-to-walker-environment*)))
+    (list
+      (list *key-to-walker-environment*
+	    (list (if wfnp walk-function     (car lock))
+		  (if wfop walk-form         (cadr lock))
+		  (if decp declarations      (caddr lock))
+		  (if lexp lexical-variables (cadddr lock)))))))
+		  
+(defun env-walk-function (env)
+  (car (env-lock env)))
+
+(defun env-walk-form (env)
+  (cadr (env-lock env)))
+
+(defun env-declarations (env)
+  (caddr (env-lock env)))
+
+(defun env-lexical-variables (env)
+  (cadddr (env-lock env)))
+
+
+(defun note-declaration (declaration env)
+  (let ((lock (env-lock env)))
+    (setf (caddr lock)
+	  (cons declaration (caddr lock)))))
+
+(defun note-lexical-binding (thing env)
+  (let ((lock (env-lock env)))
+    (setf (cadddr lock)
+	  (cons thing (cadddr lock)))))
+
+
+(defun VARIABLE-LEXICAL-P (var env)
+  (member var (env-lexical-variables env)))
+
+(defvar *VARIABLE-DECLARATIONS* '(special))
+
+(defun VARIABLE-DECLARATION (declaration var env)
+  (if (not (member declaration *variable-declarations*))
+      (error "~S is not a reckognized variable declaration." declaration)
+      (let ((id (or (member var (env-lexical-variables env)) var)))
+	(dolist (decl (env-declarations env))
+	  (when (and (eq (car decl) declaration)
+		     (eq (cadr decl) id))
+	    (return decl))))))
+
+(defun VARIABLE-SPECIAL-P (var env)
+  (or (not (null (variable-declaration 'special var env)))
+      (variable-globally-special-p var)))
+
+;;;
+;;; VARIABLE-GLOBALLY-SPECIAL-P is used to ask if a variable has been
+;;; declared globally special.  Any particular CommonLisp implementation
+;;; should customize this function accordingly and send their customization
+;;; back.
+;;;
+;;; The default version of variable-globally-special-p is probably pretty
+;;; slow, so it uses *globally-special-variables* as a cache to remember
+;;; variables that it has already figured out are globally special.
+;;;
+;;; This would need to be reworked if an unspecial declaration got added to
+;;; Common Lisp.
+;;;
+;;; Common Lisp nit:
+;;;   variable-globally-special-p should be defined in Common Lisp.
+;;;
+#-(or Genera Cloe-Runtime Lucid Xerox Excl KCL IBCL (and dec vax common) :CMU HP-HPLabs
+      GCLisp TI pyramid)
+(defvar *globally-special-variables* ())
+
+(defun variable-globally-special-p (symbol)
+  #+Genera                      (si:special-variable-p symbol)
+  #+Cloe-Runtime		(compiler::specialp symbol)
+  #+Lucid                       (lucid::proclaimed-special-p symbol)
+  #+TI                          (get symbol 'special)
+  #+Xerox                       (il:variable-globally-special-p symbol)
+  #+(and dec vax common)        (get symbol 'system::globally-special)
+  #+(or KCL IBCL)               (si:specialp symbol)
+  #+excl                        (get symbol 'excl::.globally-special.)
+  #+:CMU			(or (get symbol 'lisp::globally-special)
+				    (get symbol
+					 'clc::globally-special-in-compiler))
+  #+HP-HPLabs                   (member (get symbol 'impl:vartype)
+					'(impl:fluid impl:global)
+					:test #'eq)
+  #+:GCLISP                     (gclisp::special-p symbol)
+  #+pyramid			(or (get symbol 'lisp::globally-special)
+				    (get symbol
+					 'clc::globally-special-in-compiler))
+  #+:CORAL                      (ccl::proclaimed-special-p symbol)
+  #-(or Genera Cloe-Runtime Lucid Xerox Excl KCL IBCL (and dec vax common) :CMU HP-HPLabs
+	GCLisp TI pyramid :CORAL)
+  (or (not (null (member symbol *globally-special-variables* :test #'eq)))
+      (when (eval `(flet ((ref () ,symbol))
+		     (let ((,symbol '#,(list nil)))
+		       (and (boundp ',symbol) (eq ,symbol (ref))))))
+	(push symbol *globally-special-variables*)
+	t)))
+
+
+  ;;   
+;;;;;; Handling of special forms (the infamous 24).
+  ;;
+;;;
+;;; and I quote...
+;;; 
+;;;     The set of special forms is purposely kept very small because
+;;;     any program analyzing program (read code walker) must have
+;;;     special knowledge about every type of special form. Such a
+;;;     program needs no special knowledge about macros...
+;;;
+;;; So all we have to do here is a define a way to store and retrieve
+;;; templates which describe how to walk the 24 special forms and we are all
+;;; set...
+;;;
+;;; Well, its a nice concept, and I have to admit to being naive enough that
+;;; I believed it for a while, but not everyone takes having only 24 special
+;;; forms as seriously as might be nice.  There are (at least) 3 ways to
+;;; lose:
+;;
+;;;   1 - Implementation x implements a Common Lisp special form as a macro
+;;;       which expands into a special form which:
+;;;         - Is a common lisp special form (not likely)
+;;;         - Is not a common lisp special form (on the 3600 IF --> COND).
+;;;
+;;;     * We can safe ourselves from this case (second subcase really) by
+;;;       checking to see if there is a template defined for something
+;;;       before we check to see if we we can macroexpand it.
+;;;
+;;;   2 - Implementation x implements a Common Lisp macro as a special form.
+;;;
+;;;     * This is a screw, but not so bad, we save ourselves from it by
+;;;       defining extra templates for the macros which are *likely* to
+;;;       be implemented as special forms.  (DO, DO* ...)
+;;;
+;;;   3 - Implementation x has a special form which is not on the list of
+;;;       Common Lisp special forms.
+;;;
+;;;     * This is a bad sort of a screw and happens more than I would like
+;;;       to think, especially in the implementations which provide more
+;;;       than just Common Lisp (3600, Xerox etc.).
+;;;       The fix is not terribly staisfactory, but will have to do for
+;;;       now.  There is a hook in get walker-template which can get a
+;;;       template from the implementation's own walker.  That template
+;;;       has to be converted, and so it may be that the right way to do
+;;;       this would actually be for that implementation to provide an
+;;;       interface to its walker which looks like the interface to this
+;;;       walker.
+;;;
+
+(eval-when (compile load eval)
+
+(defmacro get-walker-template-internal (x) ;Has to be inside eval-when because
+  `(get ,x 'walker-template))		   ;Golden Common Lisp doesn't hack
+					   ;compile time definition of macros
+					   ;right for setf.
+
+(defmacro define-walker-template
+	  (name &optional (template '(nil repeat (eval))))
+  `(eval-when (load eval)
+     (setf (get-walker-template-internal ',name) ',template)))
+)
+
+(defun get-walker-template (x)
+  (cond ((symbolp x)
+	 (or (get-walker-template-internal x)
+	     (get-implementation-dependent-walker-template x)))
+	((and (listp x) (eq (car x) 'lambda))
+	 '(lambda repeat (eval)))
+	(t
+	 (error "Can't get template for ~S" x))))
+
+(defun get-implementation-dependent-walker-template (x)
+  (declare (ignore x))
+  ())
+
+
+  ;;   
+;;;;;; The actual templates
+  ;;   
+
+(define-walker-template BLOCK                (NIL NIL REPEAT (EVAL)))
+(define-walker-template CATCH                (NIL EVAL REPEAT (EVAL)))
+(define-walker-template COMPILER-LET         walk-compiler-let)
+(define-walker-template DECLARE              walk-unexpected-declare)
+(define-walker-template EVAL-WHEN            (NIL QUOTE REPEAT (EVAL)))
+(define-walker-template FLET                 walk-flet)
+(define-walker-template FUNCTION             (NIL CALL))
+(define-walker-template GO                   (NIL QUOTE))
+(define-walker-template IF                   walk-if)
+(define-walker-template LABELS               walk-labels)
+(define-walker-template LAMBDA               walk-lambda)
+(define-walker-template LET                  walk-let)
+(define-walker-template LET*                 walk-let*)
+(define-walker-template MACROLET             walk-macrolet)
+(define-walker-template MULTIPLE-VALUE-CALL  (NIL EVAL REPEAT (EVAL)))
+(define-walker-template MULTIPLE-VALUE-PROG1 (NIL RETURN REPEAT (EVAL)))
+(define-walker-template MULTIPLE-VALUE-SETQ  (NIL (REPEAT (SET)) EVAL))
+(define-walker-template MULTIPLE-VALUE-BIND  walk-multiple-value-bind)
+(define-walker-template PROGN                (NIL REPEAT (EVAL)))
+(define-walker-template PROGV                (NIL EVAL EVAL REPEAT (EVAL)))
+(define-walker-template QUOTE                (NIL QUOTE))
+(define-walker-template RETURN-FROM          (NIL QUOTE REPEAT (RETURN)))
+(define-walker-template SETQ                 (NIL REPEAT (SET EVAL)))
+(define-walker-template TAGBODY              walk-tagbody)
+(define-walker-template THE                  (NIL QUOTE EVAL))
+(define-walker-template THROW                (NIL EVAL EVAL))
+(define-walker-template UNWIND-PROTECT       (NIL RETURN REPEAT (EVAL)))
+
+;;; The new special form.
+;(define-walker-template clos::LOAD-TIME-EVAL       (NIL EVAL))
+
+;;;
+;;; And the extra templates...
+;;;
+(define-walker-template DO      walk-do)
+(define-walker-template DO*     walk-do*)
+(define-walker-template PROG    walk-prog)
+(define-walker-template PROG*   walk-prog*)
+(define-walker-template COND    (NIL REPEAT ((TEST REPEAT (EVAL)))))
+
+#+Genera
+(progn
+  (define-walker-template zl::named-lambda walk-named-lambda)
+  (define-walker-template SCL:LETF walk-let)
+  (define-walker-template SCL:LETF* walk-let*)
+  )
+
+#+Lucid
+(progn
+  (define-walker-template #+LCL3.0 lucid-common-lisp:named-lambda
+			  #-LCL3.0 sys:named-lambda walk-named-lambda)
+  )
+
+#+(or KCL IBCL)
+(progn
+  (define-walker-template lambda-block walk-named-lambda);Not really right,
+							 ;we don't hack block
+						         ;names anyways.
+  )
+
+#+TI
+(progn
+  (define-walker-template TICL::LET-IF walk-let-if)
+  )
+
+#+:Coral
+(progn
+  (define-walker-template ccl:%stack-block walk-let)
+  )
+
+
+
+(defun WALK-FORM (form
+		  &optional environment
+			    (walk-function
+			      #'(lambda (subform context env)
+				  (declare (ignore context env))
+				  subform)))
+  (walker-environment-bind (new-env environment :walk-function walk-function)
+    (walk-form-internal form :eval new-env)))
+
+;;;
+;;; nested-walk-form provides an interface that allows nested macros, each
+;;; of which must walk their body to just do one walk of the body of the
+;;; inner macro.  That inner walk is done with a walk function which is the
+;;; composition of the two walk functions.
+;;;
+;;; This facility works by having the walker annotate the environment that
+;;; it passes to macroexpand-1 to know which form is being macroexpanded.
+;;; If then the &whole argument to the macroexpansion function is eq to
+;;; the env-walk-form of the environment, nested-walk-form can be certain
+;;; that there are no intervening layers and that a nested walk is alright.
+;;;
+;;; There are some semantic problems with this facility.  In particular, if
+;;; the outer walk function returns T as its walk-no-more-p value, this will
+;;; prevent the inner walk function from getting a chance to walk the subforms
+;;; of the form.  This is almost never what you want, since it destroys the
+;;; equivalence between this nested-walk-form function and two seperate
+;;; walk-forms.
+;;;
+(defun NESTED-WALK-FORM (whole
+			 form
+			 &optional environment
+				   (walk-function
+				     #'(lambda (subform context env)
+					 (declare (ignore context env))
+					 subform)))
+  (if (eq whole (env-walk-form environment))
+      (let ((outer-walk-function (env-walk-function environment)))
+	(throw whole
+	  (walk-form
+	    form
+	    environment
+	    #'(lambda (f c e)
+		;; First loop to make sure the inner walk function
+		;; has done all it wants to do with this form.
+		;; Basically, what we are doing here is providing
+		;; the same contract walk-form-internal normally
+		;; provides to the inner walk function.
+		(let ((inner-result nil)
+		      (inner-no-more-p nil)
+		      (outer-result nil)
+		      (outer-no-more-p nil))
+		  (loop
+		    (multiple-value-setq (inner-result inner-no-more-p)
+					 (funcall walk-function f c e))
+		    (cond (inner-no-more-p (return))
+			  ((not (eq inner-result f)))
+			  ((not (consp inner-result)) (return))
+			  ((get-walker-template (car inner-result)) (return))
+			  (t
+			   (multiple-value-bind (expansion macrop)
+			       (walker-environment-bind
+				     (new-env e :walk-form inner-result)
+				 (macroexpand-1 inner-result new-env))
+			     (if macrop
+				 (setq inner-result expansion)
+				 (return)))))
+		    (setq f inner-result))
+		  (multiple-value-setq (outer-result outer-no-more-p)
+				       (funcall outer-walk-function
+						inner-result
+						c
+						e))
+		  (values outer-result
+			  (and inner-no-more-p outer-no-more-p)))))))
+      (walk-form form environment walk-function)))
+
+;;;
+;;; WALK-FORM-INTERNAL is the main driving function for the code walker. It
+;;; takes a form and the current context and walks the form calling itself or
+;;; the appropriate template recursively.
+;;;
+;;;   "It is recommended that a program-analyzing-program process a form
+;;;    that is a list whose car is a symbol as follows:
+;;;
+;;;     1. If the program has particular knowledge about the symbol,
+;;;        process the form using special-purpose code.  All of the
+;;;        standard special forms should fall into this category.
+;;;     2. Otherwise, if macro-function is true of the symbol apply
+;;;        either macroexpand or macroexpand-1 and start over.
+;;;     3. Otherwise, assume it is a function call. "
+;;;     
+
+(defun walk-form-internal (form context env
+			   &aux newform newnewform
+				walk-no-more-p macrop
+				fn template)
+  ;; First apply the walk-function to perform whatever translation
+  ;; the user wants to this form.  If the second value returned
+  ;; by walk-function is T then we don't recurse...
+  (catch form
+    (multiple-value-setq (newform walk-no-more-p)
+      (funcall (env-walk-function env) form context env))
+    (catch newform
+      (cond (walk-no-more-p newform)
+	    ((not (eq form newform))
+	     (walk-form-internal newform context env))
+	    ((not (consp newform)) newform)
+	    ((setq template (get-walker-template (setq fn (car newform))))
+	     (if (symbolp template)
+		 (funcall template newform context env)
+		 (walk-template newform template context env)))
+	    (t
+	     (multiple-value-setq (newnewform macrop)
+	       (walker-environment-bind (new-env env :walk-form newform)
+		 (macroexpand-1 newform new-env)))
+	     (cond (macrop (walk-form-internal newnewform context env))
+		   ((and (symbolp fn)
+			 (not (fboundp fn))
+			 (special-form-p fn))
+		    (error
+		      "~S is a special form, not defined in the CommonLisp.~%~
+                       manual This code walker doesn't know how to walk it.~%~
+                       Define a template for this special form and try again."
+		      fn))
+		   (t
+		    ;; Otherwise, walk the form as if its just a standard 
+		    ;; functioncall using a template for standard function
+		    ;; call.
+		    (walk-template
+		      newnewform '(call repeat (eval)) context env))))))))
+
+(defun walk-template (form template context env)
+  (if (atom template)
+      (ecase template
+        ((EVAL FUNCTION TEST EFFECT RETURN)
+         (walk-form-internal form :EVAL env))
+        ((QUOTE NIL) form)
+        (SET
+          (walk-form-internal form :SET env))
+        ((LAMBDA CALL)
+	 (cond ((symbolp form) form)
+	       #+Lispm
+	       ((sys:validate-function-spec form) form)
+	       (t (walk-form-internal form context env)))))
+      (case (car template)
+        (REPEAT
+          (walk-template-handle-repeat form
+                                       (cdr template)
+				       ;; For the case where nothing happens
+				       ;; after the repeat optimize out the
+				       ;; call to length.
+				       (if (null (cddr template))
+					   ()
+					   (nthcdr (- (length form)
+						      (length
+							(cddr template)))
+						   form))
+                                       context
+				       env))
+        (IF
+	  (walk-template form
+			 (if (if (listp (cadr template))
+				 (eval (cadr template))
+				 (funcall (cadr template) form))
+			     (caddr template)
+			     (cadddr template))
+			 context
+			 env))
+        (REMOTE
+          (walk-template form (cadr template) context env))
+        (otherwise
+          (cond ((atom form) form)
+                (t (recons form
+                           (walk-template
+			     (car form) (car template) context env)
+                           (walk-template
+			     (cdr form) (cdr template) context env))))))))
+
+(defun walk-template-handle-repeat (form template stop-form context env)
+  (if (eq form stop-form)
+      (walk-template form (cdr template) context env)
+      (walk-template-handle-repeat-1 form
+				     template
+				     (car template)
+				     stop-form
+				     context
+				     env)))
+
+(defun walk-template-handle-repeat-1 (form template repeat-template
+					   stop-form context env)
+  (cond ((null form) ())
+        ((eq form stop-form)
+         (if (null repeat-template)
+             (walk-template stop-form (cdr template) context env)       
+             (error "While handling repeat:
+                     ~%~Ran into stop while still in repeat template.")))
+        ((null repeat-template)
+         (walk-template-handle-repeat-1
+	   form template (car template) stop-form context env))
+        (t
+         (recons form
+                 (walk-template (car form) (car repeat-template) context env)
+                 (walk-template-handle-repeat-1 (cdr form)
+						template
+						(cdr repeat-template)
+						stop-form
+						context
+						env)))))
+
+(defun walk-repeat-eval (form env)
+  (and form
+       (recons form
+	       (walk-form-internal (car form) :eval env)
+	       (walk-repeat-eval (cdr form) env))))
+
+(defun recons (x car cdr)
+  (if (or (not (eq (car x) car))
+          (not (eq (cdr x) cdr)))
+      (cons car cdr)
+      x))
+
+(defun relist (x &rest args)
+  (relist-internal x args nil))
+
+(defun relist* (x &rest args)
+  (relist-internal x args 't))
+
+(defun relist-internal (x args *p)
+  (if (null (cdr args))
+      (if *p (car args) (list (car args)))
+      (recons x
+	      (car args)
+	      (relist-internal (cdr x) (cdr args) *p))))
+
+
+  ;;   
+;;;;;; Special walkers
+  ;;
+
+(defun walk-declarations (body fn env
+			       &optional doc-string-p declarations old-body
+			       &aux (form (car body)) macrop new-form)
+  (cond ((and (stringp form)			;might be a doc string
+              (cdr body)			;isn't the returned value
+              (null doc-string-p)		;no doc string yet
+              (null declarations))		;no declarations yet
+         (recons body
+                 form
+                 (walk-declarations (cdr body) fn env t)))
+        ((and (listp form) (eq (car form) 'declare))
+         ;; Got ourselves a real live declaration.  Record it, look for more.
+         (dolist (declaration (cdr form))
+	   (let ((type (car declaration))
+		 (name (cadr declaration))
+		 (args (cddr declaration)))
+	     (if (member type *variable-declarations*)
+		 (note-declaration `(,type
+				     ,(or (variable-lexical-p name env) name)
+				     ,.args)
+				   env)
+		 (note-declaration declaration env))
+	     (push declaration declarations)))
+         (recons body
+                 form
+                 (walk-declarations
+		   (cdr body) fn env doc-string-p declarations)))
+        ((and form
+	      (listp form)
+	      (null (get-walker-template (car form)))
+	      (progn
+		(multiple-value-setq (new-form macrop)
+				     (macroexpand-1 form env))
+		macrop))
+	 ;; This form was a call to a macro.  Maybe it expanded
+	 ;; into a declare?  Recurse to find out.
+	 (walk-declarations (recons body new-form (cdr body))
+			    fn env doc-string-p declarations
+			    (or old-body body)))
+	(t
+	 ;; Now that we have walked and recorded the declarations,
+	 ;; call the function our caller provided to expand the body.
+	 ;; We call that function rather than passing the real-body
+	 ;; back, because we are RECONSING up the new body.
+	 (funcall fn (or old-body body) env))))
+
+
+(defun walk-unexpected-declare (form context env)
+  (declare (ignore context env))
+  (warn "Encountered declare ~S in a place where a declare was not expected."
+	form)
+  form)
+
+(defun walk-arglist (arglist context env &optional (destructuringp nil)
+					 &aux arg)
+  (cond ((null arglist) ())
+        ((symbolp (setq arg (car arglist)))
+         (or (member arg lambda-list-keywords)
+             (note-lexical-binding arg env))
+         (recons arglist
+                 arg
+                 (walk-arglist (cdr arglist)
+                               context
+			       env
+                               (and destructuringp
+				    (not (member arg
+						 lambda-list-keywords))))))
+        ((consp arg)
+         (prog1 (if destructuringp
+                    (walk-arglist arg context env destructuringp)
+                    (recons arglist
+                            (relist* arg
+                                     (car arg)
+                                     (walk-form-internal (cadr arg) :eval env)
+                                     (cddr arg))
+                            (walk-arglist (cdr arglist) context env nil)))
+                (if (symbolp (car arg))
+                    (note-lexical-binding (car arg) env)
+                    (note-lexical-binding (cadar arg) env))
+                (or (null (cddr arg))
+                    (not (symbolp (caddr arg)))
+                    (note-lexical-binding (caddr arg) env))))
+          (t
+	   (error "Can't understand something in the arglist ~S" arglist))))
+
+(defun walk-let (form context env)
+  (walk-let/let* form context env nil))
+
+(defun walk-let* (form context env)
+  (walk-let/let* form context env t))
+
+(defun walk-prog (form context env)
+  (walk-prog/prog* form context env nil))
+
+(defun walk-prog* (form context env)
+  (walk-prog/prog* form context env t))
+
+(defun walk-do (form context env)
+  (walk-do/do* form context env nil))
+
+(defun walk-do* (form context env)
+  (walk-do/do* form context env t))
+
+(defun walk-let/let* (form context old-env sequentialp)
+  (walker-environment-bind (new-env old-env)
+    (let* ((let/let* (car form))
+	   (bindings (cadr form))
+	   (body (cddr form))
+	   (walked-bindings 
+	     (walk-bindings-1 bindings
+			      old-env
+			      new-env
+			      context
+			      sequentialp))
+	   (walked-body
+	     (walk-declarations body #'walk-repeat-eval new-env)))
+      (relist*
+	form let/let* walked-bindings walked-body))))
+
+(defun walk-prog/prog* (form context old-env sequentialp)
+  (walker-environment-bind (new-env old-env)
+    (let* ((possible-block-name (second form))
+	   (blocked-prog (and (symbolp possible-block-name)
+			      (not (eq possible-block-name 'nil)))))
+      (multiple-value-bind (let/let* block-name bindings body)
+	  (if blocked-prog
+	      (values (car form) (cadr form) (caddr form) (cdddr form))
+	      (values (car form) nil	     (cadr  form) (cddr  form)))
+	(let* ((walked-bindings 
+		 (walk-bindings-1 bindings
+				  old-env
+				  new-env
+				  context
+				  sequentialp))
+	       (walked-body
+		 (walk-declarations 
+		   body
+		   #'(lambda (real-body real-env)
+		       (walk-tagbody-1 real-body context real-env))
+		   new-env)))
+	  (if block-name
+	      (relist*
+		form let/let* block-name walked-bindings walked-body)
+	      (relist*
+		form let/let* walked-bindings walked-body)))))))
+
+(defun walk-do/do* (form context old-env sequentialp)
+  (walker-environment-bind (new-env old-env)
+    (let* ((do/do* (car form))
+	   (bindings (cadr form))
+	   (end-test (caddr form))
+	   (body (cdddr form))
+	   (walked-bindings (walk-bindings-1 bindings
+					     old-env
+					     new-env
+					     context
+					     sequentialp))
+	   (walked-body
+	     (walk-declarations body #'walk-repeat-eval new-env)))
+      (relist* form
+	       do/do*
+	       (walk-bindings-2 bindings walked-bindings context new-env)
+	       (walk-template end-test '(test repeat (eval)) context new-env)
+	       walked-body))))
+
+(defun walk-let-if (form context env)
+  (let ((test (cadr form))
+	(bindings (caddr form))
+	(body (cdddr form)))
+    (walk-form-internal
+      `(let ()
+	 (declare (special ,@(mapcar #'(lambda (x) (if (listp x) (car x) x))
+				     bindings)))
+	 (flet ((.let-if-dummy. () ,@body))
+	   (if ,test
+	       (let ,bindings (.let-if-dummy.))
+	       (.let-if-dummy.))))
+      context
+      env)))
+
+(defun walk-multiple-value-bind (form context old-env)
+  (walker-environment-bind (new-env old-env)
+    (let* ((mvb (car form))
+	   (bindings (cadr form))
+	   (mv-form (walk-template (caddr form) 'eval context old-env))
+	   (body (cdddr form))
+	   walked-bindings
+	   (walked-body
+	     (walk-declarations 
+	       body
+	       #'(lambda (real-body real-env)
+		   (setq walked-bindings
+			 (walk-bindings-1 bindings
+					  old-env
+					  new-env
+					  context
+					  nil))
+		   (walk-repeat-eval real-body real-env))
+	       new-env)))
+      (relist* form mvb walked-bindings mv-form walked-body))))
+
+(defun walk-bindings-1 (bindings old-env new-env context sequentialp)
+  (and bindings
+       (let ((binding (car bindings)))
+         (recons bindings
+                 (if (symbolp binding)
+                     (prog1 binding
+                            (note-lexical-binding binding new-env))
+                     (prog1 (relist* binding
+				     (car binding)
+				     (walk-form-internal (cadr binding)
+							 context
+							 (if sequentialp
+							     new-env
+							     old-env))
+				     (cddr binding))	;save cddr for DO/DO*
+						        ;it is the next value
+						        ;form. Don't walk it
+						        ;now though.
+                            (note-lexical-binding (car binding) new-env)))
+                 (walk-bindings-1 (cdr bindings)
+				  old-env
+				  new-env
+				  context
+				  sequentialp)))))
+
+(defun walk-bindings-2 (bindings walked-bindings context env)
+  (and bindings
+       (let ((binding (car bindings))
+             (walked-binding (car walked-bindings)))
+         (recons bindings
+		 (if (symbolp binding)
+		     binding
+		     (relist* binding
+			      (car walked-binding)
+			      (cadr walked-binding)
+			      (walk-template (cddr binding)
+					     '(eval)
+					     context
+					     env)))		 
+                 (walk-bindings-2 (cdr bindings)
+				  (cdr walked-bindings)
+				  context
+				  env)))))
+
+(defun walk-lambda (form context old-env)
+  (walker-environment-bind (new-env old-env)
+    (let* ((arglist (cadr form))
+           (body (cddr form))
+           (walked-arglist (walk-arglist arglist context new-env))
+           (walked-body
+             (walk-declarations body #'walk-repeat-eval new-env)))
+      (relist* form
+               (car form)
+	       walked-arglist
+               walked-body))))
+
+(defun walk-named-lambda (form context old-env)
+  (walker-environment-bind (new-env old-env)
+    (let* ((name (cadr form))
+	   (arglist (caddr form))
+           (body (cdddr form))
+           (walked-arglist (walk-arglist arglist context new-env))
+           (walked-body
+             (walk-declarations body #'walk-repeat-eval new-env)))
+      (relist* form
+               (car form)
+	       name
+	       walked-arglist
+               walked-body))))  
+
+(defun walk-tagbody (form context env)
+  (recons form (car form) (walk-tagbody-1 (cdr form) context env)))
+
+(defun walk-tagbody-1 (form context env)
+  (and form
+       (recons form
+               (walk-form-internal (car form)
+				   (if (symbolp (car form)) 'quote context)
+				   env)
+               (walk-tagbody-1 (cdr form) context env))))
+
+(defun walk-compiler-let (form context old-env)
+  (declare (ignore context))
+  (let ((vars ())
+	(vals ()))
+    (dolist (binding (cadr form))
+      (cond ((symbolp binding) (push binding vars) (push nil vals))
+	    (t
+	     (push (car binding) vars)
+	     (push (eval (cadr binding)) vals))))
+    (relist* form
+	     (car form)
+	     (cadr form)
+	     (progv vars vals (walk-repeat-eval (cddr form) old-env)))))
+
+(defun walk-macrolet (form context old-env)
+  (walker-environment-bind (macro-env
+			    nil
+			    :walk-function (env-walk-function old-env))
+    (labels ((walk-definitions (definitions)
+	       (and definitions
+		    (let ((definition (car definitions)))
+		      (recons definitions
+                              (relist* definition
+                                       (car definition)
+                                       (walk-arglist (cadr definition)
+						     context
+						     macro-env
+						     t)
+                                       (walk-declarations (cddr definition)
+							  #'walk-repeat-eval
+							  macro-env))
+			      (walk-definitions (cdr definitions)))))))
+      (with-new-definition-in-environment (new-env old-env form)
+	(relist* form
+		 (car form)
+		 (walk-definitions (cadr form))
+		 (walk-declarations (cddr form)
+				    #'walk-repeat-eval
+				    new-env))))))
+
+(defun walk-flet (form context old-env)
+  (labels ((walk-definitions (definitions)
+	     (if (null definitions)
+		 ()
+		 (recons definitions
+			 (walk-lambda (car definitions) context old-env)
+			 (walk-definitions (cdr definitions))))))
+    (recons form
+	    (car form)
+	    (recons (cdr form)
+		    (walk-definitions (cadr form))
+		    (with-new-definition-in-environment (new-env old-env form)
+		      (walk-declarations (cddr form)
+					 #'walk-repeat-eval
+					 new-env))))))
+
+(defun walk-labels (form context old-env)
+  (with-new-definition-in-environment (new-env old-env form)
+    (labels ((walk-definitions (definitions)
+	       (if (null definitions)
+		   ()
+		   (recons definitions
+			   (walk-lambda (car definitions) context new-env)
+			   (walk-definitions (cdr definitions))))))
+      (recons form
+	      (car form)
+	      (recons (cdr form)
+		      (walk-definitions (cadr form))
+		      (walk-declarations (cddr form)
+					 #'walk-repeat-eval
+					 new-env))))))
+
+(defun walk-if (form context env)
+  (let ((predicate (cadr form))
+	(arm1 (caddr form))
+	(arm2 
+	  (if (cddddr form)
+	      (progn
+		(warn "In the form:~%~S~%~
+                       IF only accepts three arguments, you are using ~D.~%~
+                       It is true that some Common Lisps support this, but ~
+                       it is not~%~
+                       truly legal Common Lisp.  For now, this code ~
+                       walker is interpreting ~%~
+                       the extra arguments as extra else clauses. ~
+                       Even if this is what~%~
+                       you intended, you should fix your source code."
+		      form
+		      (length (cdr form)))
+		(cons 'progn (cdddr form)))
+	      (cadddr form))))
+    (relist form
+	    'if
+	    (walk-form-internal predicate context env)
+	    (walk-form-internal arm1 context env)
+	    (walk-form-internal arm2 context env))))
+
+
+;;;
+;;; Tests tests tests
+;;;
+
+#|
+;;; 
+;;; Here are some examples of the kinds of things you should be able to do
+;;; with your implementation of the macroexpansion environment hacking
+;;; mechanism.
+;;; 
+;;; with-lexical-macros is kind of like macrolet, but it only takes names
+;;; of the macros and actual macroexpansion functions to use to macroexpand
+;;; them.  The win about that is that for macros which want to wrap several
+;;; macrolets around their body, they can do this but have the macroexpansion
+;;; functions be compiled.  See the WITH-RPUSH example.
+;;;
+;;; If the implementation had a special way of communicating the augmented
+;;; environment back to the evaluator that would be totally great.  It would
+;;; mean that we could just augment the environment then pass control back
+;;; to the implementations own compiler or interpreter.  We wouldn't have
+;;; to call the actual walker.  That would make this much faster.  Since the
+;;; principal client of this is defmethod it would make compiling defmethods
+;;; faster and that would certainly be a win.
+;;;
+(defmacro with-lexical-macros (macros &body body &environment old-env)
+  (with-augmented-environment (new-env old-env :macros macros)
+    (walk-form (cons 'progn body) :environment new-env)))
+
+(defun expand-rpush (form env)
+  `(push ,(caddr form) ,(cadr form)))
+
+(defmacro with-rpush (&body body)
+  `(with-lexical-macros ,(list (list 'rpush #'expand-rpush)) ,@body))
+
+
+;;;
+;;; Unfortunately, I don't have an automatic tester for the walker.  
+;;; Instead there is this set of test cases with a description of
+;;; how each one should go.
+;;; 
+(defmacro take-it-out-for-a-test-walk (form)
+  `(take-it-out-for-a-test-walk-1 ',form))
+
+(defun take-it-out-for-a-test-walk-1 (form)
+  (terpri)
+  (terpri)
+  (let ((copy-of-form (copy-tree form))
+	(result (walk-form form nil
+		  #'(lambda (x y env)
+		      (format t "~&Form: ~S ~3T Context: ~A" x y)
+		      (when (symbolp x)
+			(let ((lexical (variable-lexical-p x env))
+			      (special (variable-special-p x env)))
+			  (when lexical
+			    (format t ";~3T")
+			    (format t "lexically bound"))
+			  (when special
+			    (format t ";~3T")
+			    (format t "declared special"))
+			  (when (boundp x)
+			    (format t ";~3T")
+			    (format t "bound: ~S " (eval x)))))
+		      x))))
+    (cond ((not (equal result copy-of-form))
+	   (format t "~%Warning: Result not EQUAL to copy of start."))
+	  ((not (eq result form))
+	   (format t "~%Warning: Result not EQ to copy of start.")))
+    (pprint result)
+    result))
+
+(defmacro foo (&rest ignore) ''global-foo)
+
+(defmacro bar (&rest ignore) ''global-bar)
+
+(take-it-out-for-a-test-walk (list arg1 arg2 arg3))
+(take-it-out-for-a-test-walk (list (cons 1 2) (list 3 4 5)))
+
+(take-it-out-for-a-test-walk (progn (foo) (bar 1)))
+
+(take-it-out-for-a-test-walk (block block-name a b c))
+(take-it-out-for-a-test-walk (block block-name (list a) b c))
+
+(take-it-out-for-a-test-walk (catch catch-tag (list a) b c))
+;;;
+;;; This is a fairly simple macrolet case.  While walking the body of the
+;;; macro, x should be lexically bound. In the body of the macrolet form
+;;; itself, x should not be bound.
+;;; 
+(take-it-out-for-a-test-walk
+  (macrolet ((foo (x) (list x) ''inner))
+    x
+    (foo 1)))
+
+;;;
+;;; A slightly more complex macrolet case.  In the body of the macro x
+;;; should not be lexically bound.  In the body of the macrolet form itself
+;;; x should be bound.  Note that THIS CASE WILL CAUSE AN ERROR when it
+;;; tries to macroexpand the call to foo.
+;;; 
+(take-it-out-for-a-test-walk
+     (let ((x 1))
+       (macrolet ((foo () (list x) ''inner))
+	 x
+	 (foo))))
+
+;;;
+;;; A truly hairy use of compiler-let and macrolet.  In the body of the
+;;; macro x should not be lexically bound.  In the body of the macrolet
+;;; itself x should not be lexically bound.  But the macro should expand
+;;; into 1.
+;;; 
+(take-it-out-for-a-test-walk
+  (compiler-let ((x 1))
+    (let ((x 2))
+      (macrolet ((foo () x))
+	x
+	(foo)))))
+
+
+(take-it-out-for-a-test-walk
+  (flet ((foo (x) (list x y))
+	 (bar (x) (list x y)))
+    (foo 1)))
+
+(take-it-out-for-a-test-walk
+  (let ((y 2))
+    (flet ((foo (x) (list x y))
+	   (bar (x) (list x y)))
+      (foo 1))))
+
+(take-it-out-for-a-test-walk
+  (labels ((foo (x) (bar x))
+	   (bar (x) (foo x)))
+    (foo 1)))
+
+(take-it-out-for-a-test-walk
+  (flet ((foo (x) (foo x)))
+    (foo 1)))
+
+(take-it-out-for-a-test-walk
+  (flet ((foo (x) (foo x)))
+    (flet ((bar (x) (foo x)))
+      (bar 1))))
+
+(take-it-out-for-a-test-walk (compiler-let ((a 1) (b 2)) (foo a) b))
+(take-it-out-for-a-test-walk (prog () (declare (special a b))))
+(take-it-out-for-a-test-walk (let (a b c)
+                               (declare (special a b))
+                               (foo a) b c))
+(take-it-out-for-a-test-walk (let (a b c)
+                               (declare (special a) (special b))
+                               (foo a) b c))
+(take-it-out-for-a-test-walk (let (a b c)
+                               (declare (special a))
+                               (declare (special b))
+                               (foo a) b c))
+(take-it-out-for-a-test-walk (let (a b c)
+                               (declare (special a))
+                               (declare (special b))
+                               (let ((a 1))
+                                 (foo a) b c)))
+(take-it-out-for-a-test-walk (eval-when ()
+                               a
+                               (foo a)))
+(take-it-out-for-a-test-walk (eval-when (eval when load)
+                               a
+                               (foo a)))
+
+(take-it-out-for-a-test-walk (multiple-value-bind (a b) (foo a b) (list a b)))
+(take-it-out-for-a-test-walk (multiple-value-bind (a b)
+				 (foo a b)
+			       (declare (special a))
+			       (list a b)))
+(take-it-out-for-a-test-walk (progn (function foo)))
+(take-it-out-for-a-test-walk (progn a b (go a)))
+(take-it-out-for-a-test-walk (if a b c))
+(take-it-out-for-a-test-walk (if a b))
+(take-it-out-for-a-test-walk ((lambda (a b) (list a b)) 1 2))
+(take-it-out-for-a-test-walk ((lambda (a b) (declare (special a)) (list a b))
+			      1 2))
+(take-it-out-for-a-test-walk (let ((a a) (b a) (c b)) (list a b c)))
+(take-it-out-for-a-test-walk (let* ((a a) (b a) (c b)) (list a b c)))
+(take-it-out-for-a-test-walk (let ((a a) (b a) (c b))
+                               (declare (special a b))
+                               (list a b c)))
+(take-it-out-for-a-test-walk (let* ((a a) (b a) (c b))
+                               (declare (special a b))
+                               (list a b c)))
+(take-it-out-for-a-test-walk (let ((a 1) (b 2))
+                               (foo bar)
+                               (declare (special a))
+                               (foo a b)))
+(take-it-out-for-a-test-walk (multiple-value-call #'foo a b c))
+(take-it-out-for-a-test-walk (multiple-value-prog1 a b c))
+(take-it-out-for-a-test-walk (progn a b c))
+(take-it-out-for-a-test-walk (progv vars vals a b c))
+(take-it-out-for-a-test-walk (quote a))
+(take-it-out-for-a-test-walk (return-from block-name a b c))
+(take-it-out-for-a-test-walk (setq a 1))
+(take-it-out-for-a-test-walk (setq a (foo 1) b (bar 2) c 3))
+(take-it-out-for-a-test-walk (tagbody a b c (go a)))
+(take-it-out-for-a-test-walk (the foo (foo-form a b c)))
+(take-it-out-for-a-test-walk (throw tag-form a))
+(take-it-out-for-a-test-walk (unwind-protect (foo a b) d e f))
+
+(defmacro flet-1 (a b) ''outer)
+(defmacro labels-1 (a b) ''outer)
+
+(take-it-out-for-a-test-walk
+  (flet ((flet-1 (a b) () (flet-1 a b) (list a b)))
+    (flet-1 1 2)
+    (foo 1 2)))
+(take-it-out-for-a-test-walk
+  (labels ((label-1 (a b) () (label-1 a b)(list a b)))
+    (label-1 1 2)
+    (foo 1 2)))
+(take-it-out-for-a-test-walk (macrolet ((macrolet-1 (a b) (list a b)))
+                               (macrolet-1 a b)
+                               (foo 1 2)))
+
+(take-it-out-for-a-test-walk (macrolet ((foo (a) `(inner-foo-expanded ,a)))
+                               (foo 1)))
+
+(take-it-out-for-a-test-walk (progn (bar 1)
+                                    (macrolet ((bar (a)
+						 `(inner-bar-expanded ,a)))
+                                      (bar 2))))
+
+(take-it-out-for-a-test-walk (progn (bar 1)
+                                    (macrolet ((bar (s)
+						 (bar s)
+						 `(inner-bar-expanded ,s)))
+                                      (bar 2))))
+
+(take-it-out-for-a-test-walk (cond (a b)
+                                   ((foo bar) a (foo a))))
+
+
+(let ((the-lexical-variables ()))
+  (walk-form '(let ((a 1) (b 2))
+		#'(lambda (x) (list a b x y)))
+	     ()
+	     #'(lambda (form context env)
+		 (when (and (symbolp form)
+			    (variable-lexical-p form env))
+		   (push form the-lexical-variables))
+		 form))
+  (or (and (= (length the-lexical-variables) 3)
+	   (member 'a the-lexical-variables)
+	   (member 'b the-lexical-variables)
+	   (member 'x the-lexical-variables))
+      (error "Walker didn't do lexical variables of a closure properly.")))
+    
+|#
+
+()
