(DEFINE-FILE-INFO PACKAGE "PCL" READTABLE "XCL")
(il:filecreated "17-Sep-87 15:16:26" il:{phylum}<pcl>pcl-env.\;61 98052
il:|changes| il:|to:| (methods (il:inspect/as/function (method))
(inspect-title (class))
(inspect-title nil))
(il:fns il:select.fns.editor xcl::interesting-frame-p il:smartarglist)
(il:records il:bkmenuitem)
(il:functions il:attach-backtrace-menu il:backtrace-item-selected)
(il:commands "STEP-EVAL")
(il:vars il:pcl-envcoms)
il:|previous| il:|date:| "11-Sep-87 14:48:22" il:{phylum}<pcl>pcl-env.\;59)
; Copyright (c) 1987 by Xerox Corporation. All rights reserved.
(il:prettycomprint il:pcl-envcoms)
(il:rpaqq il:pcl-envcoms
(
(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:* il:|;;;| "Protect the Corporation")
(il:* il:|;;;| "")
(il:declare\: il:dontcopy il:donteval@compile (il:prop il:makefile-environment il:pcl-env)
)
(il:declare\: il:donteval@compile (il:p (format *terminal-io*
"~&;PCL-ENV Copyright (c) 1987, Xerox Corporation. All rights reserved.~%"
)))
(il:* il:|;;;| "")
(il:* il:|;;;| "Make funcallable instances (FINs) print by calling print-object.")
(il:* il:|;;;| "")
(il:p (il:defprint 'il:compiled-closure 'il:print-closure))
(il:functions il:print-closure)
(il:* il:|;;;| "")
(il:* il:|;;;| "Naming methods")
(il:* il:|;;;| "")
(il:functions generic-function-method-names full-method-name make-full-method-name)
(il:functions prompt-for-full-method-name)
(il:* il:|;;;| "")
(il:* il:|;;;| "Converting generic defining macros into DEFDEFINER macros")
(il:* il:|;;;| "")
(il:functions make-defdefiner unmake-defdefiner)
(il:* il:|;;;| "")
(il:* il:|;;;| "For tricking ED into being able to use just the generic-function-name instead of the full method name")
(il:* il:|;;;| "")
(il:functions source-manager-method-edit-fn source-manager-method-hasdef-fn
source-manager-method-setf-edit-fn source-manager-method-setf-hasdef-fn)
(il:* il:|;;;| "")
(il:* il:|;;;| "Initialize the PCL env")
(il:* il:|;;;| "")
(il:functions initialize-pcl-env)
(il:p (initialize-pcl-env))
(il:* il:|;;;| "")
(il:* il:|;;;| "Inspecting PCL objects")
(il:* il:|;;;| "")
(il:functions pcl-object-p)
(il:functions (il:* il:\; "These functions are here as an indirection between the inspector and the methods below. You see, IL:EVAL can't handle compiled-closures (and therefor generic-functions), and the inspector code uses IL:EVAL...")
\\internal-inspect-object \\internal-inspect-slot-names
\\internal-inspect-slot-value \\internal-inspect-setf-slot-value
\\internal-inspect-slot-name-command \\internal-inspect-title)
(methods (inspect-object nil)
(inspect-slot-names nil)
(inspect-slot-value nil)
(inspect-setf-slot-value nil)
(inspect-slot-name-command nil)
(inspect-title nil))
(methods (inspect-slot-names (class))
(inspect-title (class)))
(il:* il:|;;;| "")
(il:* il:|;;;| " Debugger support for PCL")
(il:* il:|;;;| "")
(il:files pcl-env-internal)
(il:* il:|;;| "")
(il:* il:|;;| "Non-PCL specific changes to the debugger")
(il:coms
(il:* il:|;;| "Redefining the standard INTERESTING-FRAME-P function. Now functions can be declared uninteresting to BT by giving them an XCL::UNINTERESTINGP property.")
(il:prop xcl::uninterestingp il:*env* evalhook xcl::nohook xcl::undohook
xcl::execa0001 xcl::execa0001a0002 il:do-event il:eval-input apply)
(il:fns xcl::interesting-frame-p)
(il:vars (il:*short-backtrace-filter* 'xcl::interesting-frame-p))
(il:* il:|;;| " Change the frame inspector to open up lexical environments")
(il:coms (il:records il:bkmenuitem)
(il:* il:\; "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. I guess the \"right\" way to do this is to have this stuff in a different file, but given that we want all the PCL-ENV stuff in a single file, I'll resort to this trickery.")
(il:p (in-package "IL"))
(il:e (in-package "IL"))
(il:structures il:frame-prop-name)
(il:p (in-package "PCL"))
(il:e (in-package "PCL")))
(il:functions il:debugger-stack-frame-prop-names il:debugger-stack-frame-fetchfn
il:debugger-stack-frame-storefn il:debugger-stack-frame-value-command
il:debugger-stack-frame-title il:debugger-stack-frame-property)
(il:* il:|;;|
"Teaching the debugger that there are other file-manager types that can appear on the stack")
(il:variables xcl::*function-types*)
(il:* il:|;;| "Redefine a couple of system functions to use the above stuff")
(il:functions il:attach-backtrace-menu il:backtrace-item-selected
il:collect-backtrace-items)
(il:fns il:select.fns.editor))
(il:* il:|;;| "")
(il:* il:|;;| "PCL specific extensions to the debugger")
(il:coms
(il:* il:|;;| "There are some new things that act as functions, and that we want to be able to edit from a backtrace window")
(il:addvars (xcl::*function-types* methods method-setfs))
(il:p (unless (generic-function-p (symbol-function 'il:inspect/as/function))
(make-specializable 'il:inspect/as/function)))
(methods (il:inspect/as/function nil)
(il:inspect/as/function (object))
(il:inspect/as/function (method)))
(il:* il:|;;| "A way to go from a stack frame to thing on that frame")
(il:functions frame-instance)
(il:* il:|;;| "A replacement for the vanilla IL:INTERESTING-FRAME-P that uses the function FRAME-INSTANCE so we can see methods and generic-functions on the stack.")
(il:functions interesting-frame-p)
(il:vars (il:*short-backtrace-filter* 'interesting-frame-p)))
(il:* il:|;;;| "")
(il:* il:|;;;| "Support for DESCRIBE")
(il:* il:|;;;| "")
(il:coms (il:p (eval-when (load)
(unless (generic-function-p (symbol-function 'describe))
(make-specializable 'describe))))
(methods (describe (class))))
(il:p
(il:* il:|;;| "When describing a symbol, note a class by that name")
(eval-when (load)
(il:* il:\;
"Take care to remove any old describe info")
(setf (get 'symbol 'si::describers)
`(,@(remove-if #'(lambda (x)
(and (consp x)
(equal (first x)
"class"))) (get 'symbol
'si::describers))
("class" ,#'(lambda (name)
(or (class-named name t)
(values nil t))))))))
(il:* il:|;;;| "")
(il:* il:|;;;| "Support for DOCUMENTATION")
(il:* il:|;;;| "")
(il:coms (il:p (eval-when (load)
(unless (generic-function-p (symbol-function 'documentation))
(make-specializable 'documentation))))
(methods (documentation (class))
(documentation (method))
(documentation :around (symbol))))
(il:* il:|;;;| "")
(il:* il:|;;;| "Support for ?= and friends")
(il:* il:|;;;| "")
(il:prop il:argnames defclass defgeneric-options defgeneric-options-setf
define-method-combination defmethod defmethod-setf multiple-value-prog2 with-slots)
(il:fns il:smartarglist)))
(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:* il:|;;;| "Protect the Corporation")
(il:* il:|;;;| "")
(il:declare\: il:dontcopy il:donteval@compile
(il:putprops il:pcl-env il:makefile-environment (:package "PCL" :readtable "XCL"))
)
(il:declare\: il:donteval@compile
(format *terminal-io* "~&;PCL-ENV Copyright (c) 1987, Xerox Corporation. All rights reserved.~%")
)
(il:* il:|;;;| "")
(il:* il:|;;;| "Make funcallable instances (FINs) print by calling print-object.")
(il:* il:|;;;| "")
(il:defprint 'il:compiled-closure 'il:print-closure)
(defun il:print-closure (x &optional stream depth)
(il:* il:|;;| "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:* il:|;;| "IL:\\CCLOSURE.DEFPRINT is the orginal system function for printing closures")
(il:\\cclosure.defprint x stream))
((streamp stream)
(il:* il:|;;| "Use the standard PCL printing method, then return T to tell the printer that we have done the printing ourselves.")
(print-object x stream)
t)
(t
(il:* il:|;;| "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))))))
(il:* il:|;;;| "")
(il:* il:|;;;| "Naming methods")
(il:* il:|;;;| "")
(defun generic-function-method-names (symbol setfp)
(let* ((spec (if setfp `(setf ,symbol) symbol))
(gf (and (gboundp spec)
(gdefinition spec))))
(when gf (mapcar #'(lambda (m)
(full-method-name m (when setfp symbol))) (
generic-function-methods
gf)))))
(defun full-method-name (method setfp) "Return the full name of the method"
(let ((specializers (mapcar #'(lambda (x)
(if (eq x 't)
't
(class-name x))) (method-type-specifiers method))))
(il:* il:|;;| "Now go through some hair to make sure that specializer is really right. Once PCL returns the right value for specializers this can be taken out.")
(let* ((arglist (method-arglist 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)))))
(if setfp (make-full-method-name setfp (method-options method)
(butlast specializers)
(last specializers))
(make-full-method-name (generic-function-name (method-generic-function method))
(method-options method)
specializers))))
(defun make-full-method-name (generic-function-name qualifiers arg-types &optional (setf-arg-types
nil setfp)) "Return the full name of a method, given the generic-function name, the method qualifiers, and the arg-types"
(il:* il:|;;| "The name of the method is:")
(il:* il:|;;| " (<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)))))))
(setq arg-types (remove-trailing-ts arg-types))
(setq setf-arg-types (remove-trailing-ts setf-arg-types))
(if setfp `(,generic-function-name ,@qualifiers ,arg-types ,setf-arg-types)
`(,generic-function-name ,@qualifiers ,arg-types))))
(defun prompt-for-full-method-name (generic-function-name setfp &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 generic-function-name setfp)))
(cond
((null method-names)
nil)
((null (cdr method-names))
(car method-names))
(t (il:menu
(il:create il:menu
il:items il:← (il:* 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 (if setfp 'method-setfs 'methods)))
`(,(with-output-to-string (s)
(dolist (x m)
(format s "~A " x))
s) ',m) nil)) method-names))
il:title il:← "Which method?"))))))
(il:* il:|;;;| "")
(il:* il:|;;;| "Converting generic defining macros into DEFDEFINER macros")
(il:* il:|;;;| "")
(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
(il:* il:|;;| "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) (il:* il:\; "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)))
(il:* il:|;;| "Make sure the type is defined")
(xcl:def-define-type (il:\\\, definer-type) ,type-description )
(il:* il:|;;| "Now redefine the definer, using DEFEDFINER and the original def'n")
(xcl:defdefiner (il:\\\, (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))))
(il:* il:|;;;| "")
(il:* il:|;;;|
"For tricking ED into being able to use just the generic-function-name instead of the full method name"
)
(il:* il:|;;;| "")
(defun source-manager-method-edit-fn (name type source editcoms options)
"Edit a method of the given name"
(let ((full-name (if (symbolp name) (il:* il:\;
"If given a symbol, it names a generic function, so try to get the full method name")
(prompt-for-full-method-name name nil t)
(il:* il:\;
"Otherwise it should name the method")
name)))
(when (not (null full-name))
(il:default.editdef full-name type source editcoms options))
(il:* il:\; "Return the name")
(or full-name name)))
(defun source-manager-method-hasdef-fn (name type &optional source)
"Is there a method defined with the given name?"
(typecase name (symbol
(il:* il:|;;| "If passed in a symbol, 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.")
(and (fboundp name)
(generic-function-p (symbol-function name))
(find-if #'(lambda (m)
(il:hasdef m type source)) (
generic-function-method-names
name nil))
name))
(list
(il:* il:|;;| "Standard methods are named (gf-name {qualifiers}* ({specializers}*))")
(when (and (>= (length name)
2)
(do ((x name (rest x)))
((null (rest x))
(listp (first x)))
(if (not (symbolp (first x)))
(return nil)))
(il:getdef name type source '(il:nocopy il:noerror)))
name))
(t
(il:* il:|;;| "Nothing else can name a method")
nil)))
(defun source-manager-method-setf-edit-fn (name type source editcoms options)
"Edit a method-setf of the given name"
(let ((full-name (if (symbolp name) (il:* il:\;
"If given a symbol, it names a generic function, so try to get the full method name")
(prompt-for-full-method-name name t t)
(il:* il:\;
"Otherwise it should name the method")
name)))
(when (not (null full-name))
(il:default.editdef full-name type source editcoms options))
(il:* il:\; "Return the name")
(or full-name name)))
(defun source-manager-method-setf-hasdef-fn (name type source)
(typecase name (symbol
(il:* il:|;;| "If passed in a symbol, pretend that there is a method by that name if there is a generic function by that name")
(let ((spec `(setf ,name)))
(and (gboundp spec)
(gdefinition spec)
(find-if #'(lambda (m)
(il:hasdef m type source)) (
generic-function-method-names
name t))
name)))
(list
(il:* il:|;;|
"Standard setf-methods are named (gf-name {qualifiers}* ({specializers}*) ({specializers}*))")
(when (and (>= (length name)
3)
(do ((x name (rest x)))
((null (cddr x))
(and (listp (first x))
(listp (second x))))
(if (not (symbolp (first x)))
(return nil)))
(il:getdef name type source '(il:nocopy il:noerror)))
name))
(t
(il:* il:|;;| "Nothing else can name a method")
nil)))
(il:* il:|;;;| "")
(il:* il:|;;;| "Initialize the PCL env")
(il:* il:|;;;| "")
(defun initialize-pcl-env nil "Initialize the Xerox PCL environment"
(il:* il:|;;| "Set up SourceManager DEFDEFINERS for classes and methods.")
(unless (il:hasdef 'classes 'il:filepkgtype)
(make-defdefiner defclass classes "class definitions"))
(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)))))))
(unless (il:hasdef 'method-setfs 'il:filepkgtype)
(make-defdefiner defmethod-setf method-setfs "method setfs"
(:name (lambda (form)
(multiple-value-bind (name qualifiers
arglist
setf-arglist)
(parse-defmethod (cdr form)
t)
(make-full-method-name name
qualifiers (
specialized-lambda-list-specializers
arglist)
(
specialized-lambda-list-specializers
setf-arglist)))))))
(il:* il:|;;| "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)
(il:filepkgtype 'method-setfs 'il:editdef '
source-manager-method-setf-edit-fn 'il:hasdef '
source-manager-method-setf-hasdef-fn)
(il:* il:|;;| "Set up the inspect macro. The right way to do this is to (MAKE-SPECIALIZEABLE 'IL:INSPECT), but for now...")
(push '((il:function pcl-object-p) . \\internal-inspect-object)
il:inspectmacros)
(il:* il:|;;| "Unmark any SourceManager changes caused by the loadup")
(dolist (com (il:filepkgchanges))
(dolist (name (cdr com))
(when (and (symbolp name)
(eq (symbol-package name)
(find-package "PCL")))
(il:unmarkaschanged name (car com))))))
(initialize-pcl-env)
(il:* il:|;;;| "")
(il:* il:|;;;| "Inspecting PCL objects")
(il:* il:|;;;| "")
(defun pcl-object-p (x) "Is the datum a PCL object?" (or (iwmc-class-p x)
(funcallable-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)
(declare (ignore v))
n) (il:* il:\;
"same effect as NIL but avoids bug in INSPECTW.CREATE")
))
(defmethod inspect-slot-names (x)
"Return a list of names of slots of the object that should be shown in the inspector"
(let ((slot-names nil))
(do ((slot (all-slots x)
(cddr slot)))
((null slot) (il:* il:\;
"Reverse the list, so the slots show up in the same order as they occur in the object")
(nreverse slot-names))
(push (car slot)
slot-names))))
(defmethod inspect-slot-value (x slot-name) (get-slot x slot-name))
(defmethod inspect-setf-slot-value (x slot-name value)
"Used by the inspector to set the value fo a slot"
(il:* il:|;;| "Make this UNDO-able")
(il:undosave `(inspect-setf-slot-value ,x ,slot-name ,(get-slot x slot-name)))
(il:* il:|;;| "Then change the value")
(setf (get-slot 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"
(il:* il:|;;| "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 PCL 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
(il:* il:|;;| "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)
'>))
(il:* il:\;
"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-slot-names ((x class)) "Return only those slots that the user should really see"
(run-super))
(defmethod inspect-title ((x class)
window) (format nil "Inspecting the class ~A" (class-name x)))
(il:* il:|;;;| "")
(il:* il:|;;;| " Debugger support for PCL")
(il:* il:|;;;| "")
(il:filesload pcl-env-internal)
(il:* il:|;;| "")
(il:* il:|;;| "Non-PCL specific changes to the debugger")
(il:* il:|;;|
"Redefining the standard INTERESTING-FRAME-P function. Now functions can be declared uninteresting to BT by giving them an XCL::UNINTERESTINGP property."
)
(il:putprops il:*env* xcl::uninterestingp t)
(il:putprops evalhook xcl::uninterestingp t)
(il:putprops xcl::nohook xcl::uninterestingp t)
(il:putprops xcl::undohook xcl::uninterestingp t)
(il:putprops xcl::execa0001 xcl::uninterestingp t)
(il:putprops xcl::execa0001a0002 xcl::uninterestingp t)
(il:putprops il:do-event xcl::uninterestingp t)
(il:putprops il:eval-input xcl::uninterestingp t)
(il:putprops apply xcl::uninterestingp t)
(il:defineq
(xcl::interesting-frame-p
(il:lambda (il:pos il:interpflg) (il:* il:\; "Edited 27-Nov-86 01:13 by lmm")
(il:* il:|;;| "Value is T if frame should be visible for backtrace, and error retry")
(il:* il:|;;| "user did write a call to the function at POS, and either INTERPFLG is T, or else the functio call would also exist if compiled")
(let ((il:name (il:|if| (il:stackp il:pos)
il:|then| (il:stkname il:pos)
il:|else| il:pos)))
(and (symbolp il:name)
(il:selectq il:name
(il:*env* (il:* il:\;
"*ENV* is used by ENVEVAL etc.")
nil)
(il:errorset (or (<= (il:stknargs il:pos)
1)
(il:neq (il:stkarg 2 il:pos nil)
'il:internal)))
(il:eval (or (<= (il:stknargs il:pos)
1)
(il:neq (il:stkarg 2 il:pos nil)
'xcl::internal)))
(il:apply (or (<= (il:stknargs il:pos)
2)
(not (il:stkarg 3 il:pos nil))))
(or (not (il:litatom il:name))
(cond
((il:fmemb il:name il:openfns)
il:interpflg)
(t (or (il:neq (il:chcon1 il:name)
(il:charcode il:\\))
(il:exprp il:name))))))))))
)
(il:rpaqq il:*short-backtrace-filter* xcl::interesting-frame-p)
(il:* il:|;;| " Change the frame inspector to open up lexical environments")
(il:declare\: il:eval@compile
(il:record il:bkmenuitem (il:label (il:bkmenuinfo il:frame-name)))
)
(il:* il:\;
"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. I guess the \"right\" way to do this is to have this stuff in a different file, but given that we want all the PCL-ENV stuff in a single file, I'll resort to this trickery."
)
(in-package "IL")
(cl:defstruct (frame-prop-name (:type 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 "PCL")
(defun il:debugger-stack-frame-prop-names (il:framespec)
(il:* il:|;;;|
"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)
(il:* il:\; "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))
(il:* il:|;;|
"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"
)
(il:* il:|;;| "Redefine a couple of system functions to use the above stuff")
(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| (il:* il:\;
"test for an attached window that has a backtrace menu in it.")
(return il:atw))) (il:* il:\;
"if there is already a backtrace window, delete the old menu from it.")
(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:* il:\;
"put bt window at left of TTY window unless ttywindow is near left edge.")
(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:* il:\;
" so that button clicks will switch TTY")
))
(il:addmenu il:bkmenu il:btw (il:|create| 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
) (il:* il:\;
"number offset from the break position of the frame")
))
(cond
((il:setq il:olditem (il:|fetch| (il:menu il:menuuserdata) il:|of| il:menu))
(il:menudeselect il:olditem il:menu)
(il:* il:\; " deselect an old one")
))
(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) (il:* il:\; "mark this one as selected")
(if (eq il:button 'il:middle)
(progn
(il:* il:|;;|
"If selected with the middle button, let the user edit the function on the stack")
(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:* il:|;;|
"If selected with the left button, bring up a frame inspector on this stack frame")
(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* (il:* il:\; "I really wish there were a handy, efficient way of collecting a list from left to right. But there isn't, so we resort to this ugly idiom.")
((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))))
(il:* il:|;;|
"There are a number of possibilities for the values returned by the filter-fn.")
(il:* il:|;;| "(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.")
(il:* il:|;;| "(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.")
(il:* il:|;;| "[Note that these two cases take care of old values of the filter-fn.]")
(il:* il:|;;| "(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.")
(il:* il:|;;| "(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* ((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)
(il:* il:\;
"Set the default value of LAST-FRAME-CONSUMED...")
(setf xcl::last-frame-consumed xcl::next-frame))
(when xcl::interesting-p (il:* il:\; "...and USEFRAME")
(when (null xcl::use-frame)
(setf xcl::use-frame xcl::last-frame-consumed))
(il:* il:\; "...and LABEL")
(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))))
(il:* il:\;
"Walk the stack until we find the frame to use")
(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)))))
(il:* il:\;
"Add the menu item to the list under construction")
(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)))
(il:* il:\; "Update NEXT-POS")
(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
(il:* il:\;
"Reuse the old stack-pointer")
xcl::next-frame)))
(return)))))))
(rest xcl::items)))
(il:defineq
(il:select.fns.editor
(il:lambda (il:fn) (il:* il:\; "Edited 15-Sep-87 18:25 by smL")
(il:* il:|;;| "gives the user a menu choice of editors.")
(let ((il:menu-items (cond
((il:ccodep il:fn)
'((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 il:fn)
'((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:menu (il:|create| il:menu
il:items il:← il:menu-items
il:centerflg il:← t)))))
)
(il:* il:|;;| "")
(il:* il:|;;| "PCL specific extensions to the debugger")
(il:* il:|;;|
"There are some new things that act as functions, and that we want to be able to edit from a backtrace window"
)
(il:addtovar xcl::*function-types* methods method-setfs)
(unless (generic-function-p (symbol-function 'il:inspect/as/function))
(make-specializable 'il:inspect/as/function))
(defmethod il:inspect/as/function (xcl::name xcl::stack-pointer xcl::debugger-window)
(il:* il:|;;| "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.")
(let ((xcl::editor (il:select.fns.editor xcl::name)))
(case xcl::editor ((nil)
(il:* il:|;;| "No editor chosen, so don't do anything")
nil)
(il:inspectcode
(il:* il:|;;| "Inspect the compiled code")
(let ((xcl::frame (xcl::stack-pointer-frame xcl::stack-pointer)))
(if (and (il:stackp xcl::stack-pointer)
(xcl::stack-frame-valid-p xcl::frame))
(il:inspectcode (let ((xcl::code-base (xcl::stack-frame-fn-header
xcl::frame)))
(cond
((eq (il:\\get-compiled-code-base xcl::name)
xcl::code-base)
xcl::name)
(t
(il:* il:|;;| "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 xcl::code-base))))
nil nil nil (xcl::stack-frame-pc xcl::frame))
(il:inspectcode xcl::name))))
(ed
(il:* il:|;;| "Use the standard editor.")
(il:* il:|;;| "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 xcl::name `(,@xcl::*function-types* :display)))
(otherwise (funcall xcl::editor xcl::name)))))
(defmethod il:inspect/as/function ((name 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 method)
stkp window)
(with-slots (x)
(let* ((generic-function-name (slot-value generic-function 'name))
(method-setf-p (and (consp generic-function-name)
(eq (first generic-function-name)
'setf)
(second generic-function-name)))
(method-name (full-method-name x method-setf-p))
(editor (il:select.fns.editor function)))
(case editor (ed (ed method-name (if method-setf-p '(:display method-setfs)
'(:display methods))))
(il:inspectcode (il:inspectcode function))
((nil)
nil)
(otherwise (funcall editor method-name))))))
(il:* il:|;;| "A way to go from a stack frame to thing on that frame")
(defun frame-instance (stack-frame) "Return the thing called in this stack frame, if we can"
(il:* il:|;;;| "If it's is a generic-function")
(il:* il:|;;;| " then return the generic-function.")
(il:* il:|;;;| "If it's is a normal function that lives in a symbol's function cell")
(il:* il:|;;;| " then return that symbol.")
(il:* il:|;;;| "If this is a method's function")
(il:* il:|;;;| " then return the method object.")
(il:* il:|;;;| "Otherwise return NIL")
(block
found-it
(let*
((stack-name (il:stkname stack-frame))
(fn-header (xcl::stack-frame-fn-header (il:\\stackargptr stack-frame)))
(code-being-run (cond
((and (consp stack-name)
(eq (xcl::stack-frame-name (il:\\stackargptr stack-frame))
'il:\\interpreter))
stack-name)
(t fn-header))))
(flet
((function-matches-frame-p (function)
(or (eq function code-being-run)
(and (typep function 'il:compiled-closure)
(eq (xcl::compiled-closure-fnheader function)
code-being-run)))))
(il:* il:|;;;| "Check things out in in order of likelyhood: Compiled funcition, Interpreted code, Compiled method, and Generic-function. Of course, this order is probably not right, but it's close, and the only thing that's even marginally important is to check for compiled functions first.")
(il:* il:|;;| "If this is a normal function call, we'll get a symbol as the name of the stack-frame, and the function cell of the symbol will contain the currently running code.")
(when (let ((symbol-function (and (symbolp stack-name)
(fboundp stack-name)
(symbol-function stack-name))))
(and symbol-function (function-matches-frame-p symbol-function)))
(return-from found-it stack-name))
(il:* il:|;;| "Check out interpreted code")
(when (consp code-being-run)
(il:* il:|;;| "This might be the frame of a interpreted method defined with defmethod. (The frame where eval is called on the lambda expression). Check to see if that is the case by checking to see if the form looks like")
(il:* il:|;;| "(lambda (...)")
(il:* il:|;;| " (declare ...)")
(il:* il:|;;| " (macrolet ((call-next-method ...)...)")
(il:* il:|;;| " ...))")
(il:* il:|;;|
"If it is, we can also extract the method-object from the def'n of call-next-method.")
(if (and (eq (car code-being-run)
'lambda)
(consp (third code-being-run))
(eq (first (third code-being-run))
'declare)
(consp (fourth code-being-run))
(eq (first (fourth code-being-run))
'macrolet)
(not (null (second (fourth code-being-run))))
(eq (first (first (second (fourth code-being-run))))
'call-next-method)) (il:* il:\;
"An interpreted method body. The body of the call-next-method def'n looks like")
(il:* il:\; "(call-next-method nil")
(il:* il:\;
" (funcall ww '(xx yy zz)))")
(il:* il:\;
"and the value of zz is the method object.")
(let ((method-object (symbol-value
(third (second (third (third (first (second (fourth
code-being-run
))))))))))
(return-from found-it (if (eq (slot-value method-object 'function)
code-being-run)
method-object nil))))
(il:* il:|;;| "Give up on any other interpreted code")
(return-from found-it nil))
(il:* il:|;;| "If this is a compiled method, then the frame name looks like |(method <gfspec> quals* (specls*))|. The cdr of the debugging info in the fn-header will be a method spec.")
(when (symbolp stack-name)
(let ((method-spec (cdr (xcl::fnheader-debugging-info fn-header)))
gf method)
(and (consp method-spec)
(eq (car method-spec)
'method)
(multiple-value-bind (gf-spec quals specls)
(parse-defmethod (cdr method-spec))
(and (gboundp gf-spec)
(generic-function-p (setq gf (gdefinition gf-spec)))
(setq method (get-method gf quals (parse-specializers specls)
nil))
(return-from found-it method))))))
(il:* il:|;;| "Check for a generic function. ")
(il:* il:|;;| "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 stack-frame))
(env nil)
(gf nil))
(when (and (> (il:stknargs stack-frame t)
n-args) (il:* il:\;
"is there at least one local?")
(setf env (il:stkarg (1+ n-args)
stack-frame))
(typep env *fin-env-type*) (il:* il:\; "and does the local contain something that might be the closure environment of a funcallable instance?")
(setf gf (fin-env-fin env))
(generic-function-p gf) (il:* il:\;
"whose fin-env-fin points to a generic function?")
(eq (xcl::compiled-closure-env gf)
env) (il:* il:\;
"whose environment is the same as env?")
(function-matches-frame-p gf) (il:* il:\;
"and whose code is the same as the code for this frame? ")
)
(return-from found-it gf)))))))
(il:* il:|;;|
"A replacement for the vanilla IL:INTERESTING-FRAME-P that uses the function FRAME-INSTANCE so we can see methods and generic-functions on the stack."
)
(defun interesting-frame-p (stack-pos &optional interp-flag)
(il:* il:|;;;| "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.")
(declare (inline internal-frame-p))
(labels
((internal-frame-p (stack-pointer)
"Does this stack pointer point to an internal frame?"
(eql (il:chcon1 (il:stkname stack-pointer))
(il:chcon1 '\\)))
(next-visible-frame (stack-pointer)
"Return the next non-internal stack frame under this one"
(do ((next-pos (il:stknth -1 stack-pointer)
(il:stknth -1 next-pos next-pos)))
((or (null next-pos)
(not (internal-frame-p next-pos)))
next-pos)))
(match-interpreter-stack (stack-pointer functions)
"Match the stack of interpreted calls against the list of funtions, returning the last matching frame"
(do ((next-pos stack-pointer (next-visible-frame next-pos))
(functions functions))
((null next-pos)
nil)
(cond
((internal-frame-p next-pos)
nil)
((not (and (eq (il:stkname next-pos)
'eval)
(consp (il:stkarg 1 next-pos))
(eq (first functions)
(first (il:stkarg 1 next-pos)))))
(return nil))
((null (rest functions))
(return next-pos))
(t (pop functions))))))
(let ((stack-name (il:stkname stack-pos))
(object (frame-instance stack-pos)))
(cond
((and object (not (eq object stack-name)))
(il:* il:|;;| "Found some other interesting object to use")
(values t stack-pos stack-pos object))
((and (eq stack-name 'eval)
(consp (il:stkarg 1 stack-pos)))
(il:* il:|;;| "An interpreted list. There are lots of tests that can be done here to elide out cruft in the intepreter.")
(block check-interpreted-frame
(il:* il:|;;| "Interpreted methods expand to (BLOCK <generic-function-name> ...) inside of (MACROLET ...) inside of the method. This should show up in the backtrace as a single frame.")
(let ((macrolet-pos (match-interpreter-stack stack-pos '(block macrolet)))
next-pos stack-object generic-function-name)
(if (and macrolet-pos (setf next-pos (next-visible-frame macrolet-pos))
(method-p (setf stack-object (frame-instance next-pos)))
(consp (method-function stack-object))
(eq (second (il:stkarg 1 stack-pos))
(if (consp (setf generic-function-name (if (method-p stack-object
)
(slot-value
(
method-generic-function
stack-object)
'name))))
(second generic-function-name)
generic-function-name)))
(return-from check-interpreted-frame (values t next-pos next-pos
stack-object))))
(il:* il:|;;|
"Other tests for interesting sets of interpreted functions can be placed here.")
(il:* il:|;;| "Otherwise, use the default")
(xcl::interesting-frame-p stack-pos interp-flag)))
(t
(il:* il:|;;| "In the normal case, use the standard INTERESTING-FRAME-P function")
(xcl::interesting-frame-p stack-pos interp-flag))))))
(il:rpaqq il:*short-backtrace-filter* interesting-frame-p)
(il:* il:|;;;| "")
(il:* il:|;;;| "Support for DESCRIBE")
(il:* il:|;;;| "")
(eval-when (load)
(unless (generic-function-p (symbol-function 'describe))
(make-specializable 'describe)))
(defmethod describe ((class class)) (describe-class class))
(il:* il:|;;| "When describing a symbol, note a class by that name")
(eval-when (load)
(il:* il:\;
"Take care to remove any old describe info")
(setf (get 'symbol 'si::describers)
`(,@(remove-if #'(lambda (x)
(and (consp x)
(equal (first x)
"class"))) (get 'symbol 'si::describers))
("class" ,#'(lambda (name)
(or (class-named name t)
(values nil t)))))))
(il:* il:|;;;| "")
(il:* il:|;;;| "Support for DOCUMENTATION")
(il:* il:|;;;| "")
(eval-when (load)
(unless (generic-function-p (symbol-function 'documentation))
(make-specializable 'documentation)))
(defmethod documentation ((x class)
&optional doc-type) (declare (ignore doc-type))
(second (assoc :documentation (class-options x))))
(defmethod documentation ((x method)
&optional doc-type) (declare (ignore doc-type))
(method-documentation x))
(defmethod documentation :around ((x symbol)
&optional doc-type)
(cond
((and (eq doc-type 'type)
(class-named x t))
(documentation (class-named x)))
((and (or (eq doc-type 'function)
(eq doc-type 'setf))
(fboundp x)
(generic-function-p (symbol-function x)))
(documentation (symbol-function x)))
(t (call-next-method))))
(il:* il:|;;;| "")
(il:* il:|;;;| "Support for ?= and friends")
(il:* il:|;;;| "")
(il:putprops defclass il:argnames (nil (class-name (#\{ superclass-name #\} #\*)
(#\{ slot-spec #\} #\*)
#\{ class-option #\} #\*)))
(il:putprops defgeneric-options il:argnames (nil (name lambda-list setf-lambda-list #\{ option #\}
#\*)))
(il:putprops defgeneric-options-setf il:argnames (nil (name lambda-list setf-lambda-list #\{ option
#\} #\*)))
(il:putprops define-method-combination il:argnames
(nil (name #\{ #\{ short-form-option #\} #\* #\| lambda-list (#\{ method-group-specifier
#\} #\*)
#\{ declaration #\| il:doc-string #\} #\* #\{ il:form #\} #\* #\})))
(il:putprops defmethod il:argnames
(nil (name #\{ method-qualifier #\} #\* specialized-lambda-list #\{ declaration #\|
il:doc-string #\} #\* #\{ il:form #\} #\*)))
(il:putprops defmethod-setf il:argnames
(nil (name #\{ method-qualifier #\} #\* specialized-lambda-list
sepcialized-setf-lambda-list #\{ declaration #\| il:doc-string #\} #\* #\{
il:form #\} #\*)))
(il:putprops multiple-value-prog2 il:argnames (nil (first second #\{ il:form #\} #\*)))
(il:putprops with-slots il:argnames (nil ((#\{ instance-form #\| (instance-form option #\*)
#\} #\*)
#\{ il:form #\} #\*)))
(il:defineq
(il:smartarglist
(il:lambda (il:fn il:explainflg il:tail) (il:* il:\; "Edited 16-Sep-87 13:58 by smL")
(il:* il:|;;| "Hacked by smL to add support for fetching arglists of generic-functions")
(prog (il:tem il:def)
(cond
((not (il:litatom il:fn))
(il:|if| (and il:explainflg (il:listp il:fn)
(eq (car il:fn)
'lambda))
il:|then| (return (il:\\simplify.cl.arglist (cadr il:fn))))
(return (il:arglist il:fn))))
il:retry
(cond
((get il:fn 'il:broken)
(return (il:smartarglist (get il:fn 'il:broken)
il:explainflg)))
((il:setq il:tem (il:getlis il:fn '(il:argnames)))
(il:* il:|;;| "gives user an override. also provides a way of ensuring that argument names stay around even if helpsys data base goes away. for example, if user wanted to advise a system subr and was worried.")
(return (cond
((or (il:nlistp (il:setq il:tem (cadr il:tem)))
(car il:tem))
(il:* il:|;;| "ARGNAMES is used for two purposes, one to provide an override, the other to have a lookup. therefore for nospread functions, we must store both the arglist to be used for explaining, and the one to be used for breaking and advising. this situation is indicated by having the value of ARGNAMES be a dotted pair of the two arglists. (note that the first one will always be a list, hence this nlistp check to distinguish the two cases.)")
il:tem)
(il:explainflg (cadr il:tem))
(t (cddr il:tem))))))
(cond
(il:explainflg (cond
((and (symbolp il:fn)
(fboundp il:fn)
(generic-function-p (symbol-function il:fn)))
(il:* il:\; "Oh boy, a generic function")
(return (generic-function-pretty-arglist (symbol-function il:fn))))
((and (il:exprp (il:setq il:def (or (get il:fn 'il:advised)
(il:getd il:fn)
(get il:fn 'il:expr))))
(il:fmemb (car (il:listp il:def))
'(lambda il:lambda il:nlambda)))
(return (il:\\simplify.cl.arglist (cadr il:def))))
((and (il:setq il:def (il:getdef il:fn 'il:functions 'il:current
'(il:noerror il:nocopy)))
(il:selectq (car il:def)
((defmacro defun )
t)
((xcl:defdefiner xcl:defcommand )
(il:|pop| il:def))
nil))
(return (il:\\simplify.cl.arglist (third (xcl:remove-comments il:def)
)))))))
(cond
((il:setq il:def (or (il:getd il:fn)
(cadr (il:getlis il:fn '(il:expr il:code)))))
(cond
((and (or (il:exprp il:def)
(il:ccodep il:def))
(or (not il:explainflg)
(not (il:fmemb (il:argtype il:def)
'(2 3)))))
(il:* il:|;;|
"Can use ARGLIST if function is defined. Want to try harder if 'EXPLAINING' rather than advising")
(return (il:arglist il:def))))))
(return (cond
((and il:explainflg (il:setq il:tem (il:getmacroprop il:fn il:compilermacroprops
)))
(il:selectq (car il:tem)
((il:lambda il:nlambda il:openlambda)
(cadr il:tem))
(= (il:smartarglist (cdr il:tem)
il:explainflg))
(nil nil)
(cond
((il:listp (car il:tem))
(return (cond
((cdr (last (car il:tem)))
(il:append (car il:tem)
(list 'il:|...| (cdr (last (car il:tem))))))
(t (car il:tem))))))))
((and (il:neq il:tem t)
il:tem))
((and (il:setq il:tem (il:fncheck il:fn t nil t il:tail))
(il:neq il:tem il:fn))
(il:setq il:fn il:tem)
(go il:retry))
(t (il:arglist il:fn)))))))
)
(il:putprops il:pcl-env il:copyright ("Xerox Corporation" 1987))
(il:declare\: il:dontcopy
(il:filemap (nil (36962 38770 (xcl::interesting-frame-p 36975 . 38768)) (71027 72049 (
il:select.fns.editor 71040 . 72047)) (92565 97958 (il:smartarglist 92578 . 97956)))))
il:stop