(DEFINE-FILE-INFO PACKAGE (LET (*PACKAGE*) (* ;
"avoid side effecting other loads") (CL IN-PACKAGE "WEB"
NICKNAMES (QUOTE ("WEB-EDITOR")) USE (QUOTE ("PCL" "CL"
"XCL"))) (IMPORT (QUOTE (PCL OBJECT PCL CLASS PCL METHOD)
)) (EXPORT (CL MAPCAR (CL FUNCTION CL INTERN) (QUOTE (
"BROWSE-CLASS")))) (CL SHADOW (CL MAPCAR (CL FUNCTION
CL INTERN) (QUOTE ("DELETE")))) *PACKAGE*) READTABLE "XCL")
(il:filecreated " 9-Nov-87 18:10:33"
il:{eris}<lispcore>cml>test>clos-browser.\;1 45812
il:|changes| il:|to:| (pcl::methods (
menu-local-methods
(
clos-browser-node
)))
il:|previous| il:|date:| " 9-Nov-87 15:33:43"
il:{phylum}<pcl>clos-browser.\;13)
; Copyright (c) 1987 by Xerox Corporation. All rights reserved.
(il:prettycomprint il:clos-browsercoms)
(il:rpaqq il:clos-browsercoms
(
(il:* il:|;;;| "***************************************")
(il:* il:|;;;| " Copyright (c) 1987 by Xerox Corporation. All rights reserved.")
(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:|;;;| "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:|;;;| "Any person obtaining a copy of this software is requested to send their name and post office or electronic mail address to:")
(il:* il:|;;;| " CLOS Coordinator")
(il:* il:|;;;| " Xerox Artifical Intelligence Systems ")
(il:* il:|;;;| " 2550 Hanover St.")
(il:* il:|;;;| " Palo Alto, CA 94303")
(il:* il:|;;;|
"(or send internet mail to CLOSSupport.pa@Xerox.arpa)")
(il:* il:|;;;| " ****************************************")
(il:* il:|;;;| "")
(il:* il:|;;;| "Print out a copyright notice when loading")
(il:* il:|;;;| "")
(il:p (format t "~&;CLOS-BROWSER Copyright (c) 1987, Xerox Corporation. All rights reserved.~%"
))
(il:* il:|;;| "")
(il:* il:|;;;| "DEPENDENT FILES")
(il:files il:web-editor il:ed-patch)
(il:* il:|;;| "")
(il:* il:|;;;| "PACKAGE STUFF ")
(il:prop il:makefile-environment il:clos-browser
)
(il:p
(il:* il:|;;|
"make web-editor available from xcl and xcl-user")
(use-package (find-package "WEB")
(find-package "XCL"))
(use-package (find-package "WEB")
(find-package "XCL-USER")))
(il:* il:|;;| "")
(il:* il:|;;;| "SYSTEM PATCHES")
(il:* il:|;;| "initialize built-in-class-of so compiler use of a gf does not infinitely recurse")
(il:p (class-of 1))
(il:* il:|;;| "")
(il:* il:|;;|
"remove a left-over bootstrapped method-function")
(il:p
(eval
'(let
((the-t-one
(ignore-errors
(get-method (get-setf-generic-function
'pcl::method-function)
nil
(list (class-named '
pcl::basic-method)
t))))
(the-ok-one
(ignore-errors
(get-method (get-setf-generic-function
'pcl::method-function)
nil
(list (class-named '
pcl::basic-method))))
))
(when (and the-t-one the-ok-one)
(remove-method (
get-setf-generic-function
'pcl::method-function)
the-t-one)))))
(il:* il:|;;| "")
(il:* il:|;;| "add break functions")
(il:variables pcl::*broken-methods*)
(il:functions pcl::break-method
pcl::break-method-internal
pcl::unbreak-method)
(il:* il:|;;| "")
(il:* il:|;;| "specialize il:getdef ")
(il:p (eval-when
(load)
(unless (pcl::generic-function-p
(symbol-function `il:getdef))
(pcl::make-specializable
'il:getdef :arglist
'(il:object &optional type
il:source il:options)))))
(pcl::methods (il:getdef (class))
(il:getdef (method)))
(il:* il:|;;| "")
(il:* il:|;;| "mix-in cached menu updating advice (given that qualifiers are not implemented) after add-method")
(il:functions after-add-method)
(il:p
(when nil
(setf (slot-value
(get-method (symbol-function
'add-method))
'function)
(symbol-function `after-add-method)
)))
(il:* il:|;;| "")
(il:* il:|;;;| "CLOS-BROWSER CLASS")
(il:functions browse-class collect-family
make-nodes)
(il:functions classes-in-package)
(pcl::classes clos-browser)
(pcl::methods (new-item (clos-browser))
(recompute (clos-browser))
(clear-method-menu-caches (clos-browser))
(icon-title (clos-browser)))
(il:* il:|;;| "")
(il:* il:|;;;| "CLOS-BROWSER-NODE CLASS")
(pcl::classes clos-browser-node)
(pcl::methods (object-name (clos-browser-node)))
(il:vars (*method-prompt-string*
(concatenate 'string
"Left button to edit the method."
"
" "Middle button provides a menu of operations.")))
(il:functions make-method-menu-items
make-top-level-method-menu-items
make-multi-method-sub-menu)
(il:* il:|;;| "")
(il:* il:|;;|
"OPERATORS ON CLASS (via clos-browser-node)")
(pcl::methods (edit-class (clos-browser-node))
(inspect-class (clos-browser-node))
(menu-local-methods (clos-browser-node))
(make-local-methods-whenselectedfn (
clos-browser-node
))
(add-method (clos-browser-node list))
(describe-class (clos-browser-node))
(documentation-class (clos-browser-node))
(print-class (clos-browser-node)))
(il:* il:|;;| "")
(il:* il:|;;| "OPERATORS ON PCL::METHOD")
(pcl::methods (delete (method))
(il:* il:\;
"note cl:delete is shadowed above")
(print-definition (method))
(copy (method class))
(move (method class))
(rename (method))
(update-cached-menues (method)))
(il:functions replace-specializers)
(il:* il:|;;| "")
))
(il:* il:|;;;| "***************************************")
(il:* il:|;;;|
" Copyright (c) 1987 by Xerox Corporation. All rights reserved."
)
(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:|;;;|
"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:|;;;|
"Any person obtaining a copy of this software is requested to send their name and post office or electronic mail address to:"
)
(il:* il:|;;;| " CLOS Coordinator")
(il:* il:|;;;| " Xerox Artifical Intelligence Systems ")
(il:* il:|;;;| " 2550 Hanover St.")
(il:* il:|;;;| " Palo Alto, CA 94303")
(il:* il:|;;;|
"(or send internet mail to CLOSSupport.pa@Xerox.arpa)")
(il:* il:|;;;| " ****************************************")
(il:* il:|;;;| "")
(il:* il:|;;;| "Print out a copyright notice when loading")
(il:* il:|;;;| "")
(format t "~&;CLOS-BROWSER Copyright (c) 1987, Xerox Corporation. All rights reserved.~%"
)
(il:* il:|;;| "")
(il:* il:|;;;| "DEPENDENT FILES")
(il:filesload il:web-editor il:ed-patch)
(il:* il:|;;| "")
(il:* il:|;;;| "PACKAGE STUFF ")
(il:putprops il:clos-browser il:makefile-environment
(:package (let (*package*)
(il:* il:\;
"avoid side effecting other loads")
(in-package "WEB" :nicknames
'("WEB-EDITOR") :use
'("PCL" "CL" "XCL"))
(import '(object class method))
(export (mapcar #'intern
'("BROWSE-CLASS"
)))
(shadow (mapcar #'intern
'("DELETE")))
*package*)
:readtable "XCL"))
(il:* il:|;;|
"make web-editor available from xcl and xcl-user")
(use-package (find-package "WEB")
(find-package "XCL"))
(use-package (find-package "WEB")
(find-package "XCL-USER"))
(il:* il:|;;| "")
(il:* il:|;;;| "SYSTEM PATCHES")
(il:* il:|;;|
"initialize built-in-class-of so compiler use of a gf does not infinitely recurse"
)
(class-of 1)
(il:* il:|;;| "")
(il:* il:|;;|
"remove a left-over bootstrapped method-function")
(eval
'(let ((the-t-one (ignore-errors
(get-method (get-setf-generic-function
'pcl::method-function)
nil
(list (class-named '
pcl::basic-method)
t))))
(the-ok-one
(ignore-errors (get-method
(get-setf-generic-function
'pcl::method-function)
nil
(list (class-named '
pcl::basic-method))))
))
(when (and the-t-one the-ok-one)
(remove-method (get-setf-generic-function
'pcl::method-function)
the-t-one))))
(il:* il:|;;| "")
(il:* il:|;;| "add break functions")
(defvar pcl::*broken-methods* )
(defun pcl::break-method (pcl::spec)
(multiple-value-bind (pcl::gf method pcl::name)
(pcl::parse-method-or-spec pcl::spec)
(pcl::put-slot-always method 'unbreak
(list pcl::name (pcl::method-function
method)))
(push method pcl::*broken-methods*)
(pcl::break-method-internal pcl::gf method
pcl::name)
method))
(defun pcl::break-method-internal (pcl::gf method pcl::name
)
(let (pcl::fcn (pcl::method-function method))
(eval `(unbreak ,pcl::name))
(setf (symbol-function pcl::name)
pcl::fcn)
(break-function pcl::name)
(setf (pcl::method-function method)
(symbol-function pcl::name))))
(defun pcl::unbreak-method (&optional pcl::spec)
(flet
((pcl::unbreak-it
(pcl::m)
(let
((unbreak (or (and (pcl::slot-exists-p pcl::m
'unbreak)
(ignore-errors
(slot-value pcl::m 'unbreak)))
(and (pcl::slot-exists-p pcl::m
'untrace)
(ignore-errors
(slot-value pcl::m 'untrace)))))
)
(if unbreak
(progn (eval `(unbreak ,(car unbreak)))
(setf (pcl::method-function pcl::m)
(cadr unbreak))
(pcl::remove-dynamic-slot pcl::m
'unbreak))
(error "~S is not a broken method?" pcl::m)))))
(cond
((not (null pcl::spec))
(multiple-value-bind (pcl::gf method)
(pcl::parse-method-or-spec pcl::spec)
(when (pcl::method-generic-function method)
(pcl::unbreak-it method)
(setq pcl::*broken-methods*
(cl:delete method
pcl::*broken-methods*))
(list pcl::*broken-methods*))))
(t (dolist (pcl::m pcl::*broken-methods*)
(pcl::unbreak-it pcl::m))
(prog1 pcl::*broken-methods* (setq
pcl::*broken-methods*
nil))))))
(il:* il:|;;| "")
(il:* il:|;;| "specialize il:getdef ")
(eval-when (load)
(unless (pcl::generic-function-p (symbol-function
`il:getdef))
(pcl::make-specializable 'il:getdef :arglist
'(il:object &optional type il:source
il:options))))
(defmethod il:getdef ((self class)
&optional ignore source options)
(il:getdef (pcl::class-name self)
`il:classes source options))
(defmethod il:getdef ((self method)
&optional ignore il:source il:options
) (il:getdef (pcl::full-method-name
self nil)
'il:method il:source
il:options))
(il:* il:|;;| "")
(il:* il:|;;|
"mix-in cached menu updating advice (given that qualifiers are not implemented) after add-method"
)
(defun after-add-method (generic-function method)
(il:* il:|;;| "mix-in cached menu updating advice after add-method (given that qualifiers are not implemented)")
(when (pcl::real-add-method generic-function method)
(update-cached-menues method)))
(when nil (setf (slot-value (get-method (symbol-function
'add-method))
'function)
(symbol-function `after-add-method)))
(il:* il:|;;| "")
(il:* il:|;;;| "CLOS-BROWSER CLASS")
(defun browse-class (class-name-or-list &key (direction
:sub)
(window-or-title "CLOS-browser")
good-classes position)
(il:* il:\;
"Edited 16-Jul-87 11:07 by Rao")
(let* ((root-classes (if (listp class-name-or-list)
(mapcar #'class-named
class-name-or-list)
(cons (class-named
class-name-or-list))
))
(nodes (make-nodes (collect-family nil root-classes
)))
(clos-browser (make-instance 'clos-browser)))
(initialize clos-browser)
(setf (slot-value clos-browser 'root-classes)
root-classes)
(browse clos-browser nodes window-or-title
good-classes position)))
(defun collect-family (family class-list)
(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 class-list
(let ((first-class (car class-list))
(rest (cdr class-list)))
(if (member first-class family)
(progn
(il:* il:|;;|
"skip gathering class-direct-subclasses ")
(collect-family family rest))
(progn (push first-class family)
(collect-family family
(append rest (
pcl::class-direct-subclasses
first-class))))))
family))
(defun make-nodes (class-list)
(let*
((node-hash (make-hash-table))
(node-list
(map 'list
#'(lambda (class &aux (node (make-instance
'clos-browser-node)
))
(setf (slot-value node 'class)
class)
(setf (slot-value node 'name)
(pcl::class-name class))
(setf (gethash class node-hash)
node)
node) class-list)))
(dolist (node node-list)
(setf (slot-value node 'to-links)
(map 'list #'(lambda (sub)
(gethash sub node-hash
))
(pcl::class-direct-subclasses
(slot-value node 'class)))))
node-list))
(defun classes-in-package (package &optional 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
((classes))
(setq package (find-package package))
(if map-on-package
(do-symbols (sym package)
(if (and (eq (symbol-package sym)
package)
(class-named sym t))
(push sym classes)))
(maphash #'(lambda (key val)
(if (eq (symbol-package key)
package)
(push key classes)))
pcl::*class-name-hash-table*))
classes))
(defclass clos-browser (web-editor)
((root-classes)
(title-items :allocation :class
(il:* il:|;;|
"Items for menu of selections in title of window")
:initform
(("Recompute" recompute
"Recompute lattice from starting objects"
(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"
)
("Clear caches"
clear-method-menu-caches
"Clear cached menues of methods."
)))
("Browser looks" nil "" (il:subitems
("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"
)))
("Add root " add-root
"Add named item to startingList for browser"
)
(il:* il:|;;| "(\"Unhide class\" remove-from-bad-list \"Restore item previously deleted from browser\")")
))
(left-button-items :allocation :class
(il:* il:|;;| "Menu items for LeftButton seletion -- Value sent as message to object or browser -- see local-commands")
:initform box-node)
(middle-button-items
:allocation :class
(il:* il:|;;| "Menu items for MiddleButton seletion -- Value sent as message to object or browser -- see local-commands")
:initform
(("Edit" edit-class "Edit the class."
(il:subitems ("Edit" edit-class
"Edit the class.")
("Inspect" inspect-class
"Bring up an inspector on the class."
)
("Rename" rename-class
"Not Implemented")
("Delete" delete-class
"Not Implemented")))
("Add method" add-method "Add a method to the class."
)
("Browse" browse-subs "Not Implemented"
(il:subitems ("sub classes" browse-subs
"Not Implemented")
("super classes" browse-supers
"Not Implemented")))
("Print" print-class
"Print the form defining the class."
(il:subitems ("Print" print-class
"Print the form defining the class."
)
("Describe" describe-class
"Print a description of the class."
)
("Documentation" documentation-class
"Display the documentation for the class."
)))
("Specialize" specialize-class)
("------" edit-class "Above this line operates on the class.
Below this line operates on individual slots and methods.")
("slots" edit-class "Edit the defclass definition."
(il:subitems ("local" (dispatch-slots
edit-slot local)
"Not Implemented")
("inherited" (dispatch-slots edit-slot
all)
"Not Implemented")
("all" (dispatch-slots edit-slot all)
"Not Implemented")))
("methods" (menu-local-methods)
"Build a menu of methods local to this class."
(il:subitems ("local"
(menu-local-methods)
"Show a menu of methods local to this class.."
(il:subitems ("Use cached menu"
(
menu-local-methods
)
"Do not recompute the menu of methods"
)
("Recompute menu"
(menu-local-methods
nil nil :recompute t)
"Recompute the menu of methods"
)))
("inherited" ("not implemented")
"not implemented")
("all" ("not implemented")
"not implemented")))))
(title :initform "CLOS Browser"
(il:* il:\;
"Title passed to GRAPHER package")
)))
(defmethod new-item ((self clos-browser)
new-item)
(car (make-nodes (list (class-named (or new-item
(prompt-read
self
"Give name of the class to be added"
)))))))
(defmethod recompute ((self clos-browser)
&optional dont-reshape-flg)
(setf
(slot-value self 'starting-list)
(make-nodes
(collect-family
nil
(il:for each il:in (reverse (il:* il:\;
"so they come out in the original order")
(slot-value self
'starting-list))
il:collect (slot-value each `class)))))
(call-next-method)
(when destination-browser
(il:* il:|;;| "Node has been invalidated, so get rid of this pointer to it. ")
(setf (slot-value destination-browser 'boxed-node)
nil)
(setq destination-browser nil)))
(defmethod clear-method-menu-caches ((self clos-browser))
(dolist (node (slot-value self 'starting-list
(il:* il:\;
"starting-list is really all the nodes in the browser.")
))
(setf (slot-value node 'menu-cache)
nil)))
(defmethod icon-title ((self clos-browser))
(pcl::class-name (car (slot-value self `root-classes))))
(il:* il:|;;| "")
(il:* il:|;;;| "CLOS-BROWSER-NODE CLASS")
(defclass clos-browser-node (web-node)
((class (il:* il:\;
"The class represented by this node")
)
(menu-cache) (il:* il:\;
"Menus of methods and slots")
(menu-cache-switch :allocation :class :initform :none
(il:* il:|;;| "valid values:")
(il:* il:|;;| ":none for never use cache")
(il:* il:|;;| ":eager for re-compute and cache menu whenever a method is created or removed")
(il:* il:|;;| ":lazy for invalidate cache at method create or remove time causing re-compute and cache at menu request time.")
)
(large-menu-size :allocation :class :initform 22)
(large-menu-font :allocation :class :initform
(il:fontcreate `(il:helvetica 8)))
(local-method-operations
:allocation :class :initform
(("Edit" 'ed
"Bring up the editor on this method's definition."
(il:subitems ("Inspect" 'inspect
"Inspect this method")))
("Print" 'print-definition
"Pretty Print this method's definition."
(il:subitems ("Print" 'print
"Print this method's definition."
)
("Describe" 'describe
"Describe this method.")
("Documentation" 'documentation
"Print this method's documentation."
)))
("Delete" 'delete "Remove this method.")
("Copy" 'copy "Copy this method to boxed class.")
("Move" 'move "Move this method to boxed class.")
("Rename" 'rename
"Change the name of this method to new name you specify"
)
("Break" 'pcl::break-method
"Cause a break window whenever this method is invoked."
)
("Trace" 'pcl::trace-method "Trace this method.")
("UnBreak" 'pcl::unbreak-method
"Unbreak this method.")))))
(defmethod object-name ((self clos-browser-node)) (
call-next-method
))
(il:rpaq *method-prompt-string* (concatenate 'string
"Left button to edit the method."
"
" "Middle button provides a menu of operations."))
(defun make-method-menu-items (methods class)
"gather method-list into menu items list"
(let
((method-menu-items (make-top-level-method-menu-items
methods))
(extra-menu-item-positions))
(let
((previous.item nil)
(this.position 0)
gf-name)
(dolist
(this.item method-menu-items)
(setq gf-name (car this.item))
(incf this.position)
(if
(not (and previous.item (eq (first previous.item)
(first this.item))))
(il:* il:|;;| "then go on to the next")
(setq previous.item this.item)
(il:* il:|;;| "otherwise we have multi-methods")
(progn
(il:* il:|;;|
"build a sub-menu of all the multi-methods")
(if (not (fourth previous.item))
(il:* il:|;;| "then create the sub-menu")
(nconc previous.item
(list (list 'il:subitems
(make-multi-method-sub-menu
(second previous.item)
class)
(make-multi-method-sub-menu
(second this.item)
class))))
(il:* il:|;;|
"otherwise add another item to the sub-menu")
(nconc (fourth previous.item)
(list (make-multi-method-sub-menu
(second this.item)
class))))
(il:* il:|;;|
"collect the position of the extra multi-method menu item")
(push this.position extra-menu-item-positions)))))
(il:* il:|;;|
"remove extra multi-method menu items last first.")
(dolist (each.position extra-menu-item-positions)
(setq method-menu-items (delete-if #'true
method-menu-items
:start
(- each.position
1)
:end
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."
)) method-menu-items)))
(defun make-top-level-method-menu-items (methods)
"gather local-methods into menu items list"
(sort (il:for each.method il:in methods il:bind
method-name
il:unless (typep each.method '
pcl::standard-reader/writer-method
)
(il:* il:|;;| "users seem to want to weed out auto-generated slot access methods ")
il:eachtime (setq method-name (car (pcl::full-method-name
each.method nil)))
il:collect (list method-name each.method
*method-prompt-string*))
#'il:alphorder :key #'car))
(defun make-multi-method-sub-menu (method class)
(let
(sub-item-name)
(dolist
(type-specifier (slot-value method '
pcl::type-specifiers))
(setq sub-item-name
(concatenate
'string sub-item-name (when sub-item-name " ")
(if (eq class type-specifier)
(il:* il:|;;| "then lets just do a plus sign")
"+"
(il:* il:|;;| "else print the name")
(prin1-to-string
(il:* il:|;;| "test until class-name works properly")
(if (typep type-specifier
'pcl::essential-class)
(pcl::class-name type-specifier)
type-specifier))))))
(list sub-item-name method *method-prompt-string*)))
(il:* il:|;;| "")
(il:* il:|;;| "OPERATORS ON CLASS (via clos-browser-node)")
(defmethod edit-class ((node clos-browser-node))
(with-slots (node)
(in-package (package-name (symbol-package
(pcl::class-name
class))))
(ed class 'classes)))
(defmethod inspect-class ((object clos-browser-node))
(inspect (slot-value object 'class)))
(defmethod menu-local-methods ((node clos-browser-node)
&optional items fix-flag
&key recompute) "pops up a menu of the local methods for the class representing the node"
(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")
(il:* il:|;;|
"this gets called recursively to fix a menu ")
(il:* il:|;;|
"23Sep87 kirk: created local-method-menu-items method")
(let
((menu (unless (and recompute
(eq (slot-value node '
menu-cache-switch)
:none))
(rest (assoc 'local-methods-menu
(slot-value node
'menu-cache)))))
(class (slot-value node 'class)))
(unless
(and menu (il:type? il:menu menu))
(unless items (setq items (make-method-menu-items
(pcl::class-direct-methods
class)
class)))
(setq menu
(il:create il:menu
il:title il:← (if fix-flag (
pcl::class-name
class)
"methods")
il:menufont il:←
(when (> (length items)
(slot-value node '
large-menu-size))
(eval (slot-value node '
large-menu-font)))
il:menuuserdata il:← '(:escape t)
(il:* il:\; "cause symbols to print in mouse process's read-table & package")
il:whenselectedfn il:← (
make-local-methods-whenselectedfn
node items)
il:items il:←
(append items
(unless fix-flag
'(("Fix menu" nil "Place this menu on the screen. WARNING: cached menues are not kept up-to-date"
))))))
(if (slot-value node 'menu-cache)
(il:* il:|;;| "then cache our menu")
(acons 'local-methods-menu menu
(slot-value node 'menu-cache))
(il:* il:|;;| "otherwise start the alist")
(setf (slot-value node 'menu-cache)
(cons 'local-methods-menu menu
(slot-value node 'menu-cache)))))
(if fix-flag
(il:* il:|;;| "ask user to position menu")
(il:movew (il:addmenu menu))
(il:* il:|;;| "otherwise just pop it up")
(il:menu menu))))
(defmethod make-local-methods-whenselectedfn ((node
clos-browser-node
)
&optional
items)
`(lambda
(menu-item ignore mouse-key)
(let
((method-name (first menu-item))
(method (second menu-item)))
(if
(null method)
(il:* il:|;;| "do the non-method items")
(cond
((string= method-name "Add method")
(add-method ',node nil))
((string= method-name "Fix menu")
(il:* il:|;;|
"call MENU-LOCAL-METHODS again to create fixed menu ")
(menu-local-methods ',node ',items t))
(t operation))
(il:* il:|;;| "got a method, lets get an operation")
(let
((operation
(case
mouse-key
(il:left 'ed)
(il:middle
(il:menu (il:create il:menu
il:title il:← method-name
il:items il:←
(slot-value ',node '
local-method-operations)
))))))
(il:* il:|;;|
"got an operation, lets use it on the method")
(case operation ((nil)
nil)
((copy move) (il:* il:\;
"need to supply destination")
(funcall operation method
(il:* il:|;;| "to class")
(progn (unless destination-browser
(error
"Please box a destination class, then say OK."
))
(slot-value
(slot-value
destination-browser
`boxed-node)
`class))
(il:* il:|;;| "from class")
(slot-value ',node 'class)))
(otherwise (funcall operation method))))))))
(defmethod add-method ((node clos-browser-node)
(form list))
(let ((class-name (pcl::class-name (slot-value
node
'class))))
(unless form
(setq form (list 'defmethod
il:|\\\\basic.gap|
(list (list (intern "SELF")
class-name))
(list 'break))))
(setq context (il:sedit form
(list 'name
(format nil
"New method on ~A"
class-name)
:dontwait))))
(xcl::set-completion-fn context
`((lambda (ignore structure)
(eval structure)))))
(defmethod describe-class ((self clos-browser-node))
(describe (slot-value self `class)))
(defmethod documentation-class ((self clos-browser-node))
(documentation (slot-value self 'class)))
(defmethod print-class ((self clos-browser-node))
(pprint (il:getdef (slot-value self `class))))
(il:* il:|;;| "")
(il:* il:|;;| "OPERATORS ON PCL::METHOD")
(defmethod delete ((self method))
(let ((method-name (pcl::full-method-name self)))
(when (remove-method (pcl::method-generic-function
self)
self)
(format t "~%~A deleted." method-name))))
(defmethod print-definition ((self method))
(pprint (il:getdef self)))
(defmethod copy ((method method)
(to-class class)
&optional from-class)
(when (eq to-class from-class)
(return-from 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
((method-definition (copy-tree (ignore-errors
(il:getdef method))))
(non-t-classes
(mapcar #'(lambda (class)
(unless (eq class 't)
class)) (
pcl::method-type-specifiers
method))))
(unless method-definition (format t
"The definition for ~A is not loaded"
(pcl::full-method-name
method nil))
(return-from copy nil))
(if
from-class
(il:* il:|;;|
"method should be specialized on from-class.")
(unless (member from-class non-t-classes)
(error
"The ~A method is not specialized on the ~A class"
(pcl::full-method-name method nil)
(pcl::class-name from-class)))
(il:* il:|;;|
"otherwise see if we can deduce FROM-CLASS ")
(case (length non-t-classes)
(0 (format t
"Unspecialized methods cannot be copied. ~A"
(pcl::full-method-name method nil)))
(1 (setq from-class (car non-t-classes)))
(otherwise
(setq from-class
(class-named (il:promptforword
(format nil
"Which class in ~A do you wish to move from?"
(
pcl::full-method-name
method nil))))))))
(il:* il:|;;| "should contain from-class. If it is not the same, abort.")
(replace-specializers method-definition (
pcl::class-name
from-class)
(pcl::class-name to-class))
(print (eval method-definition))))
(defmethod move ((method method)
(to-class class)
&optional from-class)
(when (eq to-class from-class)
(return-from move))
(if (copy method to-class from-class)
(delete method)
(format t "copy of ~A to ~A failed"
(ignore-errors (pcl::full-method-name method)
)
(ignore-errors (pcl::class-name to-class)))))
(defmethod rename ((method method)
new-name)
(unless new-name
(setq new-name
(read (make-string-input-stream
(il:promptforword
(format nil "~%New name for ~A"
(pcl::full-method-name
method)))))))
(let ((method-definition (ignore-errors (il:getdef
method))))
(unless method-definition (format t
"The definition for ~A is not loaded"
(
pcl::full-method-name
method nil))
(return-from rename nil))
(if (and (setf (second method-definition)
new-name)
(print (eval method-definition)))
(delete method)
(format t "~%Rename of ~A to ~A failed"
(ignore-errors (pcl::full-method-name
method))
new-name))))
(defmethod update-cached-menues ((self method)) (break))
(defun replace-specializers (method-definition
from-class-name
to-class-name &key
in-lamda-list-only-flag)
(nsubst to-class-name from-class-name
(if in-lamda-list-only-flag
(il:* il:|;;| "get the lamba list")
(third (multiple-value-list
(pcl::parse-defmethod (cdr
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")
method-definition)))
(il:* il:|;;| "")
(il:putprops il:clos-browser il:copyright (
"Xerox Corporation" 1987))
(il:declare\: il:dontcopy
(il:filemap (nil)))
il:stop