(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}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}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