;;;-*-Mode:LISP; Package:(PCL (LISP WALKER)); Base:10; Syntax:Common-lisp -*-
;;;
;;; *************************************************************************
;;; Copyright (c) 1985, 1986, 1987, 1988, 1989 Xerox Corporation.
;;; All rights reserved.
;;;
;;; Use and copying of this software and preparation of derivative works
;;; based upon this software are permitted.  Any distribution of this
;;; software or derivative works must comply with all applicable United
;;; States export control laws.
;;; 
;;; This software is made available AS IS, and Xerox Corporation makes no
;;; warranty about the software, its performance or its conformity to any
;;; specification.
;;; 
;;; Any person obtaining a copy of this software is requested to send their
;;; name and post office or electronic mail address to:
;;;   CommonLoops Coordinator
;;;   Xerox PARC
;;;   3333 Coyote Hill Rd.
;;;   Palo Alto, CA 94304
;;; (or send Arpanet mail to CommonLoops-Coordinator.pa@Xerox.com)
;;;
;;; Suggestions, comments and requests for improvements are also welcome.
;;; *************************************************************************
;;;
;;; Xerox-Lisp specific environment hacking for PCL

(in-package "PCL")

;; 
;; Protect the Corporation
;; 
(eval-when (eval load)
  (format *terminal-io*
    "~&;PCL-ENV Copyright (c) 1987, 1988, 1989, by ~
        Xerox Corporation.  All rights reserved.~%"))


;;; Make funcallable instances (FINs) print by calling print-object.

(eval-when (eval load)
  (il:defprint 'il:compiled-closure 'il:print-closure))

(defun il:print-closure (x &optional stream depth)
  ;; See the IRM, section 25.3.3.  Unfortunatly, that documentation is
  ;; not correct.  In particular, it makes no mention of the third argument.
  (cond ((not (funcallable-instance-p x))
	 ;; IL:\CCLOSURE.DEFPRINT is the orginal system function for
	 ;; printing closures
	 (il:\\cclosure.defprint x stream))
	((streamp stream)
	 ;; Use the standard PCL printing method, then return T to tell
	 ;; the printer that we have done the printing ourselves.
	 (print-object x stream)
	 t)
	(t 
	 ;; Internal printing (again, see the IRM section 25.3.3). 
	 ;; Return a list containing the string of characters that
	 ;; would be printed, if the object were being printed for
	 ;; real.
	 (with-output-to-string (stream)
	   (list (print-object x stream))))))


;;; Naming methods

(defun gf-named (gf-name)
  (let ((spec (cond ((symbolp gf-name) gf-name)
		    ((and (consp gf-name)
			  (eq (first gf-name) 'setf)
			  (symbolp (second gf-name))
			  (null (cddr gf-name)))
		     (get-setf-function-name (second gf-name)))
		    (t nil))))
    (if (and (fboundp spec)
	     (generic-function-p (symbol-function spec)))
	(symbol-function spec)
	nil)))

(defun generic-function-method-names (gf-name hasdefp)
  (if hasdefp
      (let ((names nil))
        (maphash #'(lambda (key value)
                     (declare (ignore value))
                     (when (and (consp key) (eql (car key) gf-name))
                       (pushnew key names)))
                 (gethash 'methods xcl:*definition-hash-table*))
        names)
      (let ((gf (gf-named gf-name)))
        (when gf
          (mapcar #'full-method-name (generic-function-methods gf))))))

(defun full-method-name (method)
  "Return the full name of the method"
  (let ((specializers (mapcar #'(lambda (x)
		                  (cond ((eq x 't) t)
		                        ((consp x) x)
		                        (t (class-name x))))
		       (method-type-specifiers method))))
    ;; 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)))))
    (make-full-method-name (generic-function-name
			       (method-generic-function method))
			   (method-qualifiers method)
			   specializers)))

(defun make-full-method-name (generic-function-name qualifiers arg-types)
  "Return the full name of a method, given the generic-function name, the method
qualifiers, and the arg-types"
  ;; The name of the method is:
  ;;      (<generic-function-name> <qualifier-1> .. 
  ;;         (<arg-specializer-1>..))
  (labels ((remove-trailing-ts (l)
	     (if (null l)
		 nil
		 (let ((tail (remove-trailing-ts (cdr l))))
		   (if (null tail)
		       (if (eq (car l) 't)
			   nil
			   (list (car l)))
		       (if (eq l tail)
			   l
			   (cons (car l) tail)))))))
    `(,generic-function-name ,@qualifiers
      ,(remove-trailing-ts arg-types))))

(defun parse-full-method-name (method-name)
  "Parse the method name, returning the gf-name, the qualifiers, and the
arg-types."
  (values (first method-name)
	  (butlast (rest method-name))
	  (car (last method-name))))

(defun prompt-for-full-method-name (gf-name &optional has-def-p)
  "Prompt the user for the full name of a method on the given generic function name"
  (let ((method-names (generic-function-method-names gf-name has-def-p)))
    (cond ((null method-names)
	   nil)
	  ((null (cdr method-names))
	   (car method-names))
	  (t (il:menu
	      (il:create
	       il:menu il:items il:_	;If HAS-DEF-P, include only
					; those methods that have a
					; symbolic def'n that we can
					; find
	       (remove-if #'null
			  (mapcar #'(lambda (m)
				      (if (or (not has-def-p)
					      (il:hasdef m 'methods))
					  `(,(with-output-to-string (s)
					       (dolist (x m)
						 (format s "~A " x))
					       s)
					    ',m)
					  nil))
				  method-names))
	       il:title il:_ "Which method?"))))))


;;; Converting generic defining macros into DEFDEFINER macros

(defmacro make-defdefiner (definer-name definer-type type-description &body 
					definer-options)
  "Make the DEFINER-NAME use DEFDEFINER, defining items of type DEFINER-TYPE"
  (let ((old-definer-macro-name (intern (string-append definer-name
						       " old definition")
					(symbol-package definer-name)))
	(old-definer-macro-expander (intern (string-append definer-name 
							   " old expander")
					    (symbol-package definer-name))))
    `(progn 
      ;; First, move the current defining function off to some safe
      ;; place
      (unmake-defdefiner ',definer-name)
      (cond ((not (fboundp ',definer-name))
	     (error "~A has no definition!" ',definer-name))
	    ((fboundp ',old-definer-macro-name))
	    ((macro-function ',definer-name)
					; We have to move the macro
					; expansion function as well,
					; so it won't get clobbered
					; when the original macro is
					; redefined.  See AR 7410.
	     (let* ((expansion-function (macro-function ',definer-name)))
	       (setf (symbol-function ',old-definer-macro-expander)
		     (loop (if (symbolp expansion-function)
			       (setq expansion-function
				     (symbol-function expansion-function))
			       (return expansion-function))))
	       (setf (macro-function ',old-definer-macro-name)
		     ',old-definer-macro-expander)
	       (setf (get ',definer-name 'make-defdefiner) expansion-function)))
	    (t (error "~A does not name a macro." ',definer-name)))
      ;; Make sure the type is defined
      (xcl:def-define-type ,definer-type ,type-description)
      ;; Now redefine the definer, using DEFEDFINER and the original def'n
      (xcl:defdefiner ,(if definer-options
			   (cons definer-name definer-options)
			   definer-name)
	  ,definer-type	(&body b) `(,',old-definer-macro-name ,@,'b)))))

(defun unmake-defdefiner (definer-name)
  (let ((old-expander (get definer-name 'make-defdefiner)))
    (when old-expander
      (setf (macro-function definer-name old-expander))
      (remprop definer-name 'make-defdefiner))))


;;; For tricking ED into being able to use just the generic-function-name
;;; instead of the full method name

(defun source-manager-method-edit-fn (name type source editcoms options)
  "Edit a method of the given name"
  (let ((full-name (if (gf-named name)
					;If given the name of a
					; generic-function, try to get
					; the full method name
		       (prompt-for-full-method-name name t)
					; Otherwise it should name the
					; method
		       name)))
    (when (not (null full-name))
      (il:default.editdef full-name type source editcoms options))
    (or full-name name)))		;Return the name

(defun source-manager-method-hasdef-fn (name type &optional source)
  "Is there a method defined with the given name?"
  (cond ((not (eq type 'methods)) nil)
	((or (symbolp name)
	     (and (consp name)
		  (eq (first name) 'setf)
		  (symbolp (second name))
		  (null (cddr name))))
	 ;; If passed in the name of a generic-function, pretend that
	 ;; there is a method by that name if there is a generic function
	 ;; by that name, and there is a method whose source we can find.
	 (if (and (not (null (gf-named name)))
		  (find-if #'(lambda (m)
			       (il:hasdef m type source))
			   (generic-function-method-names name t)))
	     name
	     nil))
	((and (consp name) (>= (length name) 2))
	 ;; Standard methods are named (gf-name {qualifiers}* ({specializers}*))
	 (when (il:getdef name type source '(il:nocopy il:noerror))
	   name))
	(t
	 ;; Nothing else can name a method
	 nil)))

;;; Initialize the PCL env

(defun initialize-pcl-env nil
  "Initialize the Xerox PCL environment" 
  ;; Set up SourceManager DEFDEFINERS for classes and methods.
  ;;
  ;; Make sure to define methods before classes, so that (IL:FILES?) will build
  ;; filecoms that have classes before methods. 
  (unless (il:hasdef 'methods 'il:filepkgtype)
    (make-defdefiner defmethod methods "methods"
		     (:name (lambda (form)
			      (multiple-value-bind (name qualifiers arglist)
				  (parse-defmethod (cdr form))
				(make-full-method-name name qualifiers
				    (extract-specializer-names
					arglist)))))
		     (:undefiner
		      (lambda (method-name)
			(multiple-value-bind
			      (name qualifiers arg-types)
			    (parse-full-method-name method-name)
			  (let* ((gf (gf-named name))
				 (method (when gf
					   (get-method gf qualifiers
						       (mapcar #'find-class 
							       arg-types)))))
			    (when method (remove-method gf method))))))))
  ;; Include support for DEFGENERIC, if that is defined
  (unless (or (not (fboundp 'defgeneric))
	      (il:hasdef 'generic-functions 'il:filepkgtype))
    (make-defdefiner defgeneric generic-functions "generic-function definitions"))
  ;; DEFCLASS FileManager stuff
  (unless (il:hasdef 'classes 'il:filepkgtype)
    (make-defdefiner defclass classes "class definitions"
		     (:undefiner (lambda (name)
				   (when (find-class name t)
				     (setf (find-class name) nil)))))
    ;; CLASSES "include" TYPES.
    (il:filepkgcom 'classes 'il:contents
		   #'(lambda (com name type &optional reason)
		       (declare (ignore name reason))
		       (if (member type '(il:types classes) :test #'eq)
			   (cdr com)
			   nil))))
  ;; Set up the hooks so that ED can be handed the name of a generic function,
  ;; and end up editing a method instead
  (il:filepkgtype 'methods 'il:editdef 'source-manager-method-edit-fn
		  'il:hasdef 'source-manager-method-hasdef-fn)
  ;; Set up the inspect macro.  The right way to do this is to
  ;; (ENSURE-GENERIC-FUNCTION 'IL:INSPECT...), but for now...
  (push '((il:function pcl-object-p) . \\internal-inspect-object)
	il:inspectmacros)
  ;; Unmark any SourceManager changes caused by this loadup
  (dolist (com (il:filepkgchanges))
    (dolist (name (cdr com))
      (when (and (symbolp name)
		 (eq (symbol-package name) (find-package "PCL")))
	(il:unmarkaschanged name (car com))))))

(eval-when (eval load)
  (initialize-pcl-env))


;;; Inspecting PCL objects

(defun pcl-object-p (x)
  "Is the datum a PCL object?"
  (or (std-instance-p x)
      (fsc-instance-p x)))

(defun \\internal-inspect-object (x type where)
  (inspect-object x type where))

(defun \\internal-inspect-slot-names (x)
  (inspect-slot-names x))

(defun \\internal-inspect-slot-value (x slot-name)
  (inspect-slot-value x slot-name))

(defun \\internal-inspect-setf-slot-value (x slot-name value)
  (inspect-setf-slot-value x slot-name value))

(defun \\internal-inspect-slot-name-command (slot-name x window)
  (inspect-slot-name-command slot-name x window))

(defun \\internal-inspect-title (x y)
  (inspect-title x y))

(defmethod inspect-object (x type where)
  "Open an insect window on the object x"
  (il:inspectw.create x '\\internal-inspect-slot-names
              '\\internal-inspect-slot-value
              '\\internal-inspect-setf-slot-value
              '\\internal-inspect-slot-name-command nil nil 
              '\\internal-inspect-title nil where
              #'(lambda (n v)		;Same effect as NIL, but avoids bug in
		  (declare (ignore v))	; INSPECTW.CREATE
		  n)))

(defmethod inspect-slot-names (x)
  "Return a list of names of slots of the object that should be shown in the
inspector"
  (mapcar #'(lambda (slotd) (slot-value slotd 'name))
	  (slots-to-inspect (class-of x) x)))

(defmethod inspect-slot-value (x slot-name)
  (cond ((not (slot-exists-p x slot-name)) "** no such slot **")
	((not (slot-boundp x slot-name)) "** slot not bound **")
	(t (slot-value x slot-name))))

(defmethod inspect-setf-slot-value (x slot-name value)
  "Used by the inspector to set the value fo a slot"
  ;; Make this UNDO-able
  (il:undosave `(inspect-setf-slot-value ,x ,slot-name
		 ,(slot-value x slot-name)))
  ;; Then change the value
  (setf (slot-value x slot-name) value))

(defmethod inspect-slot-name-command (slot-name x window)
  "Allows the user to select a menu item to change a slot value in an inspect
window"
  ;; This code is a very slightly hacked version of the system function
  ;; DEFAULT.INSPECTW.PROPCOMMANDFN.  We have to do this because the
  ;; standard version makes some nasty assumptions about
  ;; structure-objects that are not true for 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 
     ;; The user want to set the value
     (il:ersetq (prog ((il:oldvalueitem (il:itemofpropertyvalue slot-name 
								window))
		       il:newvalue il:pwindow)
		   (il:ttydisplaystream (il:setq il:pwindow
						 (il:getpromptwindow window 3)))
		   (il:clearbuf t t)
		   (il:resetlst
		    (il:resetsave (il:\\itemw.flipitem il:oldvalueitem window)
				  (list 'il:\\itemw.flipitem 
					il:oldvalueitem window))
		    (il:resetsave (il:tty.process (il:this.process)))
		    (il:resetsave (il:printlevel 4 3))
		    (il:|printout| t "Enter the new " 
			slot-name " for " x t 
			"The expression read will be EVALuated."
			t "> ")
		    (il:setq il:newvalue (il:lispx (il:lispxread t t)
						   '>))
					; clear tty buffer because it
					; sometimes has stuff left.
		    (il:clearbuf t t))
		   (il:closew il:pwindow)
		   (return (il:inspectw.replace window slot-name il:newvalue)))))))

(defmethod inspect-title (x window)
  "Return the title to use in an inspect window viewing x"
  (format nil "Inspecting a ~A" (class-name (class-of x))))

(defmethod inspect-title ((x standard-class) window)
  (format nil "Inspecting the class ~A" (class-name x)))


;;;  Debugger support for PCL


(il:filesload pcl-env-internal)

;; Non-PCL specific changes to the debugger

;; Redefining the standard INTERESTING-FRAME-P function.  Now functions can be
;; declared uninteresting to BT by giving them an XCL::UNINTERESTINGP
;; property.

(dolist (fn '(si::*unwind-protect* il:*env*
	      evalhook xcl::nohook xcl::undohook
	      xcl::execa0001 xcl::execa0001a0002
	      xcl::|interpret-UNDOABLY|
	      cl::|interpret-IF| cl::|interpret-FLET|
	      cl::|interpret-LET| cl::|interpret-LETA0001|
	      cl::|interpret-BLOCK| cl::|interpret-BLOCKA0001|
	      il:do-event il:eval-input
	      apply t))
  (setf (get fn 'xcl::uninterestingp) t))

(defun xcl::interesting-frame-p (xcl::pos &optional xcl::interpflg)
  "Return TRUE iff the frame should be visible for a short backtrace."
  (declare (special il:openfns))
  (let ((xcl::name (if (il:stackp xcl::pos) (il:stkname xcl::pos) xcl::pos)))
    (typecase xcl::name
      (symbol (case xcl::name
		(il:*env*
		 ;; *ENV* is used by ENVEVAL etc.
		 nil)
		(il:errorset
		 (or (<= (il:stknargs xcl::pos) 1)
		     (not (eq (il:stkarg 2 xcl::pos nil)
			      'il:internal))))
		(il:eval
		 (or (<= (il:stknargs xcl::pos) 1)
		     (not (eq (il:stkarg 2 xcl::pos nil)
			      'xcl::internal))))
		(il:apply
		 (or (<= (il:stknargs xcl::pos) 2)
		     (not (il:stkarg 3 xcl::pos nil))))
		(otherwise
		 (cond ((get xcl::name 'xcl::uninterestingp)
			;; Explicitly declared uninteresting.
			nil)
		       ((eq (il:chcon1 xcl::name) (char-code #\\))
			;; Implicitly declared uninteresting by starting the
			;; name with a "\".
			nil)
		       ((or (member xcl::name il:openfns :test #'eq)
			    (eq xcl::name 'funcall))
			;;The function won't be seen when compiled, so only show
			;;it if INTERPFLG it true
			xcl::interpflg)
		       (t 
			;; Interesting by default.
			t)))))
       (cons (case (car xcl::name)
	       (:broken t)
	       (otherwise nil)))
       (otherwise nil))))

(setq il:*short-backtrace-filter* 'xcl::interesting-frame-p)


(eval-when (eval compile)
  (il:record il:bkmenuitem (il:label (il:bkmenuinfo il:frame-name))))


;;  Change the frame inspector to open up lexical environments

  ;; Since the DEFSTRUCT is going to build the accessors in the package that is
  ;; current at read-time, and we want the accessors to reside in the IL
  ;; package, we have got to make sure that the defstruct happens when the
  ;; package is IL.

(in-package "IL")

(cl:defstruct (frame-prop-name (:type cl:list))
  (label-fn 'nill)
  (value-fn
   (function
    (lambda (prop-name framespec)
     (frame-prop-name-data prop-name))))
  (setf-fn 'nill)
  (inspect-fn
   (function
    (lambda (value prop-name framespec window)
     (default.inspectw.valuecommandfn value prop-name (car framespec) window))))
  (data nil))

(cl:in-package "PCL")

(defun il:debugger-stack-frame-prop-names (il:framespec) 
  ;; Frame prop-names are structures of the form
  ;; (LABEL-FN VALUE-FN SETF-FN EDIT-FN DATA)
  (let ((il:pos (car il:framespec))
	(il:backtrace-item (cadr il:framespec)))
    (il:if (eq 'eval (il:stkname il:pos))
     il:then
     (let ((il:expression (il:stkarg 1 il:pos))
	   (il:environment (il:stkarg 2 il:pos)))
       `(,(il:make-frame-prop-name :inspect-fn
	   (il:function
	    (il:lambda (il:value il:prop-name il:framespec il:window)
	      (il:inspect/as/function il:value (car il:framespec) il:window)))
	   :data il:expression)
	 ,(il:make-frame-prop-name :data "ENVIRONMENT")
	 ,@(il:for il:aspect il:in
	    `((,(and il:environment (il:environment-vars il:environment))
	       "vars")
	      (,(and il:environment (il:environment-functions il:environment))
	       "functions")
	      (,(and il:environment (il:environment-blocks il:environment))
	       "blocks")
	      (,(and il:environment (il:environment-tagbodies il:environment))
	       "tag bodies"))
	    il:bind il:group-name il:p-list
	    il:eachtime (il:setq il:group-name (cadr il:aspect))
	                (il:setq il:p-list (car il:aspect))
	    il:when (not (null il:p-list))
	    il:join
	    `(,(il:make-frame-prop-name :data il:group-name)
	      ,@(il:for il:p il:on il:p-list il:by cddr il:collect
		 (il:make-frame-prop-name :label-fn
		  (il:function (il:lambda (il:prop-name il:framespec)
				 (car (il:frame-prop-name-data il:prop-name))))
		  :value-fn
		  (il:function (il:lambda (il:prop-name il:framespec)
				 (cadr (il:frame-prop-name-data il:prop-name))))
		  :setf-fn
		  (il:function (il:lambda (il:prop-name il:framespec il:new-value)
				 (il:change (cadr (il:frame-prop-name-data
						   il:prop-name))
					    il:new-value)))
		  :data il:p))))))
     il:else
     (flet ((il:build-name (&key il:arg-name il:arg-number)
	      (il:make-frame-prop-name :label-fn
		  (il:function (il:lambda (il:prop-name il:framespec)
				 (car (il:frame-prop-name-data il:prop-name))))
		  :value-fn
		  (il:function (il:lambda (il:prop-name il:framespec)
				 (il:stkarg (cadr (il:frame-prop-name-data
						   il:prop-name))
					    (car il:framespec))))
		  :setf-fn
		  (il:function (il:lambda (il:prop-name il:framespec il:new-value)
				 (il:setstkarg (cadr (il:frame-prop-name-data
						      il:prop-name))
					       (car il:framespec)
					       il:new-value)))
		  :data
		  (list il:arg-name il:arg-number))))
       (let ((il:nargs (il:stknargs il:pos t))
	     (il:nargs1 (il:stknargs il:pos))
	     (il:fnname (il:stkname il:pos))
	     il:argname
	     (il:arglist))
	 (and (il:litatom il:fnname)
	      (il:ccodep il:fnname)
	      (il:setq il:arglist (il:listp (il:smartarglist il:fnname))))
	 `(,(il:make-frame-prop-name :inspect-fn
	     (il:function (il:lambda (il:value il:prop-name il:framespec
					       il:window)
			    (il:inspect/as/function il:value
						    (car il:framespec)
						    il:window)))
	     :data
	     (il:fetch (il:bkmenuitem il:frame-name) il:of il:backtrace-item))
	   ,@(il:bind il:mode il:for il:i il:from 1 il:to il:nargs1 il:collect
	      (progn (il:while (il:fmemb (il:setq il:argname (il:pop il:arglist))
					 lambda-list-keywords)
			       il:do
			       (il:setq il:mode il:argname))
		     (il:build-name :arg-name
				    (or (il:stkargname il:i il:pos)
					; special
					(if (case il:mode
					      ((nil &optional) il:argname)
					      (t nil))
					    (string il:argname)
					    (il:concat "arg " (- il:i 1))))
				    :arg-number il:i)))
	   ,@(let* ((il:novalue "No value")
		    (il:slots (il:for il:pvar il:from 0 il:as il:i il:from
				      (il:add1 il:nargs1)
				      il:to il:nargs il:by 1 il:when
				      (and (il:neq il:novalue (il:stkarg il:i il:pos
									 il:novalue))
					   (or (il:setq il:argname (il:stkargname
								    il:i il:pos))
					       (il:setq il:argname (il:concat 
								    "local " 
								    il:pvar)))
					   )
				      il:collect
				      (il:build-name :arg-name il:argname 
						     :arg-number il:i))))
               (and il:slots (cons (il:make-frame-prop-name :data "locals")
                                   il:slots)))))))))

(defun il:debugger-stack-frame-fetchfn (il:framespec il:prop-name)
  (il:apply* (il:frame-prop-name-value-fn il:prop-name)
	     il:prop-name il:framespec))

(defun il:debugger-stack-frame-storefn (il:framespec il:prop-name il:newvalue)
  (il:apply* (il:frame-prop-name-setf-fn il:prop-name)
	     il:prop-name il:framespec il:newvalue))

(defun il:debugger-stack-frame-value-command (il:datum il:prop-name 
						       il:framespec il:window)
  (il:apply* (il:frame-prop-name-inspect-fn il:prop-name)
	     il:datum il:prop-name il:framespec il:window))

(defun il:debugger-stack-frame-title (il:framespec &optional il:window)
  (declare (ignore il:window))
  (il:concat (il:stkname (car il:framespec)) "  Frame"))

(defun il:debugger-stack-frame-property (il:prop-name il:framespec)
  (il:apply* (il:frame-prop-name-label-fn il:prop-name)
	     il:prop-name il:framespec))

;; Teaching the debugger that there are other file-manager types that can
;; appear on the stack

(defvar xcl::*function-types* '(il:fns il:functions)
  "Manager types that can appear on the stack")

;; Redefine a couple of system functions to use the above stuff

#+Xerox-Lyric
(progn

(defun il:attach-backtrace-menu (&optional (il:ttywindow
					    (il:wfromds (il:ttydisplaystream)))
					   il:skip)
  (let ((il:bkmenu (il:|create| il:menu
		       il:items il:_
		       (il:collect-backtrace-items il:ttywindow il:skip)
		       il:whenselectedfn il:_
		       (il:function il:backtrace-item-selected)
		       il:whenheldfn il:_
		       #'(il:lambda (il:item il:menu il:button)
			   (declare (ignore il:item il:menu))
			   (case il:button
			     (il:left (il:promptprint 
				       "Open a frame inspector on this stack frame"
				       ))
			     (il:middle (il:promptprint 
					 "Inspect/Edit this function"))
			     ))
		       il:menuoutlinesize il:_ 0
		       il:menufont il:_ il:backtracefont
		       il:menucolumns il:_ 1))
	(il:ttyregion (il:windowprop il:ttywindow 'il:region))
	il:btw)
    (cond
      ((il:setq il:btw (il:|for| il:atw il:|in| (il:attachedwindows il:ttywindow)
			   il:|when| (and (il:setq il:btw (il:windowprop il:atw 'il:menu))
					  (eql (il:|fetch| (il:menu il:whenselectedfn)
						   il:|of| (car il:btw))
					       (il:function il:backtrace-item-selected)))
			   il:|do|                       
			   (return il:atw)))       
       (il:deletemenu (car (il:windowprop il:btw 'il:menu))
		      nil il:btw)
       (il:windowprop il:btw 'il:extent nil)
       (il:clearw il:btw))
      ((il:setq il:btw (il:createw (il:region-next-to (il:windowprop il:ttywindow 'il:region)
						      (il:widthifwindow (il:imin (il:|fetch| (il:menu 
											      il:imagewidth
											      )
										     il:|of| il:bkmenu)
										 il:|MaxBkMenuWidth|))
						      (il:|fetch| (il:region il:height) il:|of| il:ttyregion
							  )
						      'il:left)))   
       (il:attachwindow il:btw il:ttywindow (cond
					      ((il:igreaterp (il:|fetch| (il:region il:left)
								 il:|of| (il:windowprop
									  il:btw
									  'il:region))
							     (il:|fetch| (il:region il:left)
								 il:|of| il:ttyregion))
					       'il:right)
					      (t 'il:left))
			nil
			'il:localclose)
       (il:windowprop il:btw 'il:process (il:windowprop il:ttywindow 'il:process))

       ))
    (il:addmenu il:bkmenu il:btw (il:|create| il:_ il:position
				     il:xcoord il:_ 0
				     il:ycoord il:_ (il:idifference (il:windowprop
								     il:btw
								     'il:height)
								    (il:|fetch| (il:menu il:imageheight
											 ) il:|of| 
											   il:bkmenu
											   ))))))

(defun il:backtrace-item-selected (il:item il:menu il:button)
  (il:resetlst
   (prog (il:olditem il:ttywindow il:bkpos il:pos il:positions il:framewindow
		     (il:framespecn (il:|fetch| (il:bkmenuitem il:bkmenuinfo) il:|of| il:item)

				    ))
      (cond
	((il:setq il:olditem (il:|fetch| (il:menu il:menuuserdata) il:|of| il:menu))
	 (il:menudeselect il:olditem il:menu)        
	 ))
      (il:setq il:ttywindow (il:windowprop (il:wfrommenu il:menu)
					   'il:mainwindow))
      (il:setq il:bkpos (il:windowprop il:ttywindow 'il:stack-position))
      (il:setq il:pos (il:stknth (- il:framespecn)
				 il:bkpos))
      (let ((il:lp (il:windowprop il:ttywindow 'il:lastpos)))
	(and il:lp (il:stknth 0 il:pos il:lp)))
      (il:menuselect il:item il:menu)                
      (if (eq il:button 'il:middle)
	  (progn 


	    (il:resetsave nil (list 'il:relstk il:pos))
	    (il:inspect/as/function (il:|fetch| (il:bkmenuitem il:frame-name)
					il:|of| il:item)
				    il:pos il:ttywindow))
	  (progn 


	    (il:setq il:framewindow
		     (xcl:with-profile (il:process.eval
						  (il:windowprop il:ttywindow 'il:process)
						  '(let ((il:profile (xcl:copy-profile (xcl:find-profile
											"READ-PRINT"))))
						    (setf (xcl::profile-entry-value '
							   xcl:*eval-function* il:profile)
						     xcl:*eval-function*)
						    (xcl:save-profile il:profile))
						  t)
		       (il:inspectw.create (list il:pos il:item)
				   'il:debugger-stack-frame-prop-names
				   'il:debugger-stack-frame-fetchfn
				   'il:debugger-stack-frame-storefn nil '
				   il:debugger-stack-frame-value-command nil '
				   il:debugger-stack-frame-title nil (
								      il:make-frame-inspect-window
								      il:ttywindow)
				   'il:debugger-stack-frame-property)))
	    (cond
	      ((not (il:windowprop il:framewindow 'il:mainwindow))
	       (il:attachwindow il:framewindow il:ttywindow
				(cond
				  ((il:igreaterp (il:|fetch| (il:region il:bottom)
						     il:|of| (il:windowprop il:framewindow
									    'il:region))
						 (il:|fetch| (il:region il:bottom)
						     il:|of| (il:windowprop il:ttywindow 'il:region)))
				   'il:top)
				  (t 'il:bottom))
				nil
				'il:localclose)
	       (il:windowaddprop il:framewindow 'il:closefn (il:function il:detachwindow
									 ))))))
      (return))))

(defun il:collect-backtrace-items (xcl::tty-window xcl::skip)
   (let* ((xcl::items (cons nil nil))
          (xcl::items-tail xcl::items))
         (macrolet ((xcl::collect-item (xcl::new-item)
                           `(progn (setf (rest xcl::items-tail)
                                         (cons ,xcl::new-item nil))
                                   (pop xcl::items-tail))))
                (let* ((xcl::filter-fn (cond
                                          ((null xcl::skip)
                                           #'xcl:true)
                                          ((eq xcl::skip t)
                                           il:*short-backtrace-filter*)
                                          (t xcl::skip)))
                       (xcl::top-frame (il:stknth 0 (il:getwindowprop xcl::tty-window '
                                                           il:stack-position)))
                       (xcl::next-frame xcl::top-frame)
                       (xcl::frame-number 0)
                       xcl::interesting-p xcl::last-frame-consumed xcl::use-frame xcl::label)
                      (loop (when (null xcl::next-frame)
                                  (return))
                            (multiple-value-setq (xcl::interesting-p xcl::last-frame-consumed 
                                                        xcl::use-frame xcl::label)
                                   (funcall xcl::filter-fn xcl::next-frame))
                            (when (null xcl::last-frame-consumed)
                                                            
                                (setf xcl::last-frame-consumed xcl::next-frame))
                            (when xcl::interesting-p        
                                (when (null xcl::use-frame)
                                      (setf xcl::use-frame xcl::last-frame-consumed))
                                                             
                                (when (null xcl::label)
                                    (setf xcl::label (il:stkname xcl::use-frame))
                                    (if (member xcl::label '(eval il:eval il:apply apply)
                                               :test
                                               'eq)
                                        (setf xcl::label (il:stkarg 1 xcl::use-frame))))
                                                            
                                (loop (cond
                                         ((not (typep xcl::next-frame 'il:stackp))
                                          (error "~%Use-frame ~S not found" xcl::use-frame))
                                         ((xcl::stack-eql xcl::next-frame xcl::use-frame)
                                          (return))
                                         (t (incf xcl::frame-number)
                                            (setf xcl::next-frame (il:stknth -1 xcl::next-frame 
                                                                         xcl::next-frame)))))
                                                             
                                (xcl::collect-item (il:|create| il:bkmenuitem
                                                          il:label il:_ (let ((*print-level* 2)
                                                                              (*print-length* 3)
                                                                              (*print-escape* t)
                                                                              (*print-gensym* t)
                                                                              (*print-pretty* nil)
                                                                              (*print-circle* nil)
                                                                              (*print-radix* 10)
                                                                              (*print-array* nil)
                                                                              (il:*print-structure*
                                                                               nil))
                                                                             (prin1-to-string 
                                                                                    xcl::label))
                                                          il:bkmenuinfo il:_ xcl::frame-number
                                                          il:frame-name il:_ xcl::label)))
                                                             
                            (loop (cond
                                     ((not (typep xcl::next-frame 'il:stackp))
                                      (error "~%Last-frame-consumed ~S not found" 
                                             xcl::last-frame-consumed))
                                     ((prog1 (xcl::stack-eql xcl::next-frame xcl::last-frame-consumed
                                                    )
                                          (incf xcl::frame-number)
                                          (setf xcl::next-frame (il:stknth -1 xcl::next-frame 
                                                             
                                                                       xcl::next-frame)))
                                      (return)))))))
         (rest xcl::items)))

)
#+Xerox-Medley
(progn

(defun dbg::attach-backtrace-menu (&optional tty-window skip)
  (declare (special il:\\term.ofd il:backtracefont))
  (or tty-window (il:setq tty-window (il:wfromds (il:ttydisplaystream))))
  (prog (btw bkmenu
	     (tty-region (il:windowprop tty-window 'il:region))
	     ;; And, for the FORMAT below...
	     (*print-level* 2)
	     (*print-length* 3)
	     (*print-escape* t)
	     (*print-gensym* t)
	     (*print-pretty* nil)
	     (*print-circle* nil)
	     (*print-radix* 10)
	     (*print-array* nil)
	     (il:*print-structure* nil))
     (setq bkmenu
	   (il:|create| il:menu
	       il:items il:_ (dbg::collect-backtrace-items tty-window skip)
	       il:whenselectedfn il:_ 'dbg::backtrace-item-selected
	       il:menuoutlinesize il:_ 0
	       il:menufont il:_ il:backtracefont 
	       il:menucolumns il:_ 1
	       il:whenheldfn il:_
	       #'(il:lambda (item menu button)
		   (declare (ignore item menu))
		   (case button
		     (il:left
		      (il:promptprint
		       "Open a frame inspector on this stack frame"))
		     (il:middle
		      (il:promptprint "Inspect/Edit this function"))))))
     (cond ((setq btw
		  (dolist (atw  (il:attachedwindows tty-window))
		    ;; Test for an attached window that has a backtrace menu in
		    ;; it.
		    (when (and (setq btw (il:windowprop atw 'il:menu))
			   (eq (il:|fetch| (il:menu il:whenselectedfn)
				   il:|of| (car btw))
			       'dbg::backtrace-item-selected))
		      (return atw))))
	    ;; If there is alread a backtrace window, delete the old menu from
	    ;; it.
	    (il:deletemenu (car (il:windowprop btw 'il:menu)) nil btw)
	    (il:windowprop btw 'il:extent nil)
	    (il:clearw btw))
	   ((setq btw
		  (il:createw (dbg::region-next-to
			       (il:windowprop tty-window 'il:region)
			       (il:widthifwindow
				(il:imin (il:|fetch| (il:menu il:imagewidth)
					     il:|of| bkmenu)
					 il:|MaxBkMenuWidth|))
			       (il:|fetch| (il:region il:height)
				   il:|of| tty-region)
			       :left)))
					; put bt window at left of TTY
					; window unless ttywindow is
					; near left edge.
	    (il:attachwindow btw tty-window
			     (if (il:igreaterp (il:|fetch| (il:region il:left)
						   il:|of|
						   (il:windowprop btw
								  'il:region))
					       (il:|fetch| (il:region il:left)
						   il:|of| tty-region))
				 'il:right
				 'il:left)
			     nil
			     'il:localclose)
	    ;; So that button clicks will switch the TTY
	    (il:windowprop btw 'il:process
			   (il:windowprop tty-window 'il:process))))
     (il:addmenu bkmenu btw (il:|create| il:position
				il:xcoord il:_ 0 
				il:ycoord il:_ (- (il:windowprop btw 'il:height)
						  (il:|fetch| (il:menu 
							       il:imageheight)
						      il:|of| bkmenu))))
     ;; IL:ADDMENU sets up buttoneventfn for window that we don't
     ;; want.  We want to catch middle button events before the menu
     ;; handler, so that we can pop up edit/inspect menu for the frame
     ;; currently selected.  So replace the buttoneventfn, and can
     ;; nuke the cursorin and cursormoved guys, cause don't need them.
     (il:windowprop btw 'il:buttoneventfn 'dbg::backtrace-menu-buttoneventfn)
     (il:windowprop btw 'il:cursorinfn nil)
     (il:windowprop btw 'il:cursormovedfn nil)))

(defun dbg::collect-backtrace-items (tty-window skip)
  (xcl:with-collection
      ;;
      ;; There are a number of possibilities for the values returned by the
      ;; filter-fn.
      ;;
      ;; (1) INTERESTING-P is false, and the other values are all NIL.  This
      ;; is the simple case where the stack frame NEXT-POS should be ignored
      ;; completly, and processing should continue with the next frame.
      ;;
      ;; (2) INTERESTING-P is true, and the other values are all NIL.  This
      ;; is the simple case where the stack frame NEXT-POS should appear in
      ;; the backtrace as is, and processing should continue with the next
      ;; frame.
      ;;
      ;; [Note that these two cases take care of old values of the
      ;; filter-fn.]
      ;;
      ;; (3) INTERESTING-P is false, and LAST-FRAME-CONSUMED is a stack
      ;; frame.  In that case, ignore all stack frames from NEXT-POS to
      ;; LAST-FRAME-CONSUMED, inclusive.
      ;;
      ;; (4) INTERESTING-P is true, and LAST-FRAME-CONSUMED is a stack
      ;; frame.  In this case, the backtrace should include a single entry
      ;; coresponding to the frame USE-FRAME (which defaults to
      ;; LAST-FRAME-CONSUMED), and processing should continue with the next
      ;; frame after LAST-FRAME-CONSUMED.  If LABEL is non-NIL, it will be
      ;; the label that appears in the backtrace menu; otherwise the name of
      ;; USE-FRAME will be used (or the form being EVALed if the frame is an
      ;; EVAL frame).
      ;;
      (let* ((filter (cond ((null skip) #'xcl:true)
			   ((eq skip t) il:*short-backtrace-filter*)
			   (t skip)))
	     (top-frame (il:stknth 0 (il:getwindowprop tty-window
					      'dbg::stack-position)))
	     (next-frame top-frame)
	     (frame-number 0)
	     interestingp last-frame-consumed frame-to-use label-to-use)
	(loop (when (null next-frame) (return))
	      ;; Get the values of INTERSTINGP, LAST-FRAME-CONSUMED,
	      ;; FRAME-TO-USE, and LABEL-TO-USE
	      (multiple-value-setq (interestingp last-frame-consumed 
						 frame-to-use label-to-use)
		(funcall filter next-frame))
	      (when (null last-frame-consumed)
		(setf last-frame-consumed next-frame))
	      (when interestingp
		(when (null frame-to-use)
		  (setf frame-to-use last-frame-consumed))
		(when (null label-to-use)
		  (setf label-to-use (il:stkname frame-to-use))
		  (if (member label-to-use '(eval il:eval il:apply apply)
			      :test 'eq)
		      (setf label-to-use (il:stkarg 1 frame-to-use))))

		;; Walk the stack until we find the frame to use
		(loop (cond ((not (typep next-frame 'il:stackp))
			     (error "~%Use-frame ~S not found" frame-to-use))
			    ((xcl::stack-eql next-frame frame-to-use)
			     (return))
			    (t (incf frame-number)
			       (setf next-frame
				     (il:stknth -1 next-frame next-frame)))))

		;; Add the menu item to the list under construction
		(xcl:collect (il:|create| il:bkmenuitem
				 il:label il:_ (let ((*print-level* 2)
						     (*print-length* 3)
						     (*print-escape* t)
						     (*print-gensym* t)
						     (*print-pretty* nil)
						     (*print-circle* nil)
						     (*print-radix* 10)
						     (*print-array* nil)
						     (il:*print-structure* nil))
						 (prin1-to-string label-to-use))
				 il:bkmenuinfo il:_ frame-number
				 il:frame-name il:_ label-to-use)))

	      ;; Update NEXT-POS
	      (loop (cond ((not (typep next-frame 'il:stackp))
			   (error "~%Last-frame-consumed ~S not found" 
				  last-frame-consumed))
			  ((prog1
			       (xcl::stack-eql next-frame last-frame-consumed)
			     (incf frame-number)
			     (setf next-frame (il:stknth -1 next-frame
							 next-frame)))
			   (return))))))))

(defun dbg::backtrace-menu-buttoneventfn (window &aux menu)
  (setq menu (car (il:listp (il:windowprop window 'il:menu))))
  (unless (or (il:lastmousestate il:up) (null menu))
    (il:totopw window)
    (cond ((il:lastmousestate il:middle)
	   ;; look for a selected frame in this menu, and then pop up
	   ;; the editor invoke menu for that frame.  don't change the
	   ;; selection, just present the edit menu.
	   (let* ((selection (il:menu.handler menu
					  (il:windowprop window 'il:dsp)))
		  (tty-window (il:windowprop window 'il:mainwindow))
		  (last-pos (il:windowprop tty-window 'dbg::lastpos)))
                        
	     ;; don't have to worry about releasing POS because we
	     ;; only look at it here (nobody here hangs on to it)
	     ;; and we will be around for less time than LASTPOS. 
	     ;; The debugger is responsible for releasing LASTPOS.
	     (il:inspect/as/function (cond
				       ((and selection
					     (il:|fetch| (il:bkmenuitem il:frame-name)
						 il:|of| (car selection))))
				       ((and (symbolp (il:stkname last-pos))
					     (il:getd (il:stkname last-pos)))
					(il:stkname last-pos))
				       (t 'il:nill))
				     last-pos tty-window)))
	  (t (let ((selection (il:menu.handler menu
					   (il:windowprop window 'il:dsp))))
	       (when selection
		 (il:doselecteditem menu (car selection) (cdr selection))))))))

;; This function isn't really redefined, but it needs to be recomiled since we
;; changed the def'n of the BKMENUITEM record.

(defun dbg::backtrace-item-selected (item menu button)
  ;;When a frame name is selected in the backtrace menu, this is the function
  ;;that gets called.
  (declare (special il:brkenv) (ignore button))
  (let* ((frame-spec (il:|fetch| (il:bkmenuitem il:bkmenuinfo) il:|of| item))
	 (tty-window (il:windowprop (il:wfrommenu menu) 'il:mainwindow))
	 (bkpos (il:windowprop tty-window 'dbg::stack-position))
	 (pos (il:stknth (- frame-spec) bkpos)))
    (let ((lp (il:windowprop tty-window 'dbg::lastpos)))
      (and lp (il:stknth 0 pos lp)))
    ;; change the item selected from OLDITEM to ITEM.  Only do this on left
    ;; buttons now.  Middle just pops up the edit menu, doesn't select. -woz
    (let ((old-item (il:|fetch| (il:menu il:menuuserdata) il:|of| menu)))
      (when old-item (il:menudeselect old-item menu))
      (il:menuselect item menu))
    ;; Change the lexical environment so it is the one in effect as of this
    ;; frame.
    (il:process.eval (il:windowprop tty-window (quote dbg::process))
	       `(setq il:brkenv ',(il:find-lexical-environment pos))
	       t)
    (let ((frame-window (xcl:with-profile
			    (il:process.eval (il:windowprop tty-window
							    'il:process)
				       `(let ((profile (xcl:copy-profile
							(xcl:find-profile
							 "READ-PRINT"))))
					 (setf
					  (xcl::profile-entry-value
					   'xcl:*eval-function* profile)
					  xcl:*eval-function*)
					 (xcl:save-profile profile))
				       t)
			  (il:inspectw.create pos
				      #'(lambda (pos)
					  (dbg::stack-frame-properties pos t))
				      'dbg::stack-frame-fetchfn
				      'dbg::stack-frame-storefn
				      nil
				      'dbg::stack-frame-value-command
				      nil
				      (format nil "~S  Frame" (il:stkname pos))
				      nil (dbg::make-frame-inspect-window
					   tty-window)
				      'dbg::stack-frame-property))))
      (when (not (il:windowprop frame-window 'il:mainwindow))
	(il:attachwindow frame-window tty-window
			 (if (> (il:|fetch| (il:region il:bottom) il:|of|
				    (il:windowprop frame-window 'il:region))
				(il:|fetch| (il:region il:bottom) il:|of|
				    (il:windowprop tty-window 'il:region)))
			     'il:top 'il:bottom)
			 nil 'il:localclose)
	(il:windowaddprop frame-window 'il:closefn 'il:detachwindow)))))

)					;end of Xerox-Medley

(defun il:select.fns.editor (&optional function)
    ;; gives the user a menu choice of editors.
    (il:menu (il:|create| il:menu
		 il:items il:_ (cond ((il:ccodep function)
				      '((il:|InspectCode| 'il:inspectcode 
					 "Shows the compiled code.")
					(il:|DisplayEdit| 'ed 
					 "Edit it with the display editor")
					(il:|TtyEdit| 'il:ef 
					 "Edit it with the standard editor")))
				     ((il:closure-p function)
				      '((il:|Inspect| 'inspect 
					 "Inspect this object")))
				     (t '((il:|DisplayEdit| 'ed 
					   "Edit it with the display editor")
					  (il:|TtyEdit| 'il:ef 
					   "Edit it with the standard editor"))))
		 il:centerflg il:_ t)))

;; 


;; PCL specific extensions to the debugger


;; There are some new things that act as functions, and that we want to be
;; able to edit from a backtrace window

(pushnew 'methods xcl::*function-types*)

(eval-when (eval compile load)
  (unless (generic-function-p (symbol-function 'il:inspect/as/function))
    (make-specializable 'il:inspect/as/function)))

(defmethod il:inspect/as/function (name stack-pointer debugger-window)
  ;; Calls an editor on function NAME.  STKP and WINDOW are the stack pointer
  ;; and window of the break in which this inspect command was called.
  (declare (ignore debugger-window))
  (let ((editor (il:select.fns.editor name)))
    (case editor
      ((nil) 
       ;; No editor chosen, so don't do anything
       nil)
      (il:inspectcode 
       ;; Inspect the compiled code
       (let ((frame (xcl::stack-pointer-frame stack-pointer)))
	 (if (and (il:stackp stack-pointer)
		  (xcl::stack-frame-valid-p frame))
	     (il:inspectcode (let ((code-base (xcl::stack-frame-fn-header frame)))
			       (cond ((eq (il:\\get-compiled-code-base name)
					  code-base)
				      name)
				     (t 
				      ;; Function executing in this frame is not
				      ;; the one in the definition cell of its
				      ;; name, so fetch the real code.  Have to
				      ;; pass a CCODEP
				      (il:make-compiled-closure code-base))))
                             nil nil nil (xcl::stack-frame-pc frame))
	     (il:inspectcode name))))
      (ed 
       ;; Use the standard editor.
       ;; This used to take care to apply the editor in the debugger
       ;; process, so forms evaluated in the editor happen in the
       ;; context of the break.  But that doesn't count for much any
       ;; more, now that lexical variables are the way to go.  Better to
       ;; use the LEX debugger command (thank you, Herbie) and
       ;; shift-select pieces of code from the editor into the debugger
       ;; window. 
       (ed name `(,@xcl::*function-types* :display)))
      (otherwise (funcall editor name)))))

(defmethod il:inspect/as/function ((name standard-object) stkp window)
  (when (il:menu (il:|create| il:menu
		     il:items il:_ '(("Inspect" t "Inspect this object"))))
    (inspect name)))

(defmethod il:inspect/as/function ((x standard-method) stkp window)
  (let* ((generic-function-name (slot-value (slot-value x 'generic-function)
					    'name))
	 (method-name (full-method-name x))
	 (editor (il:select.fns.editor method-name)))
    (il:allow.button.events)
    (case editor
      (ed (ed method-name '(:display methods)))
      (il:inspectcode (il:inspectcode (slot-value x 'function)))
      ((nil) nil)
      (otherwise (funcall editor method-name)))))

;; A replacement for the vanilla IL:INTERESTING-FRAME-P so we can see methods
;; and generic-functions on the stack.

(defun interesting-frame-p (stack-pos &optional interp-flag)
  ;; Return up to four values:  INTERESTING-P LAST-FRAME-CONSUMED USE-FRAME and
  ;; LABEL.  See the function IL:COLLECT-BACKTRACE-ITEMS for a full description
  ;; of how these values are used.
  (labels
      ((function-matches-frame-p (function frame)
	   "Is the function being called in this frame?"
	   (let* ((frame-name (il:stkname frame))
		  (code-being-run (cond
				    ((typep frame-name 'il:closure)
				     frame-name)
				    ((and (consp frame-name)
					  (eq 'il:\\interpreter
					      (xcl::stack-frame-name
					       (il:\\stackargptr frame))))
				     frame-name)
				    (t (xcl::stack-frame-fn-header
					(il:\\stackargptr frame))))))
	     (or (eq function code-being-run)
		 (and (typep function 'il:compiled-closure)
		      (eq (xcl::compiled-closure-fnheader function)
			  code-being-run)))))
       (generic-function-from-frame (frame)
	 "If this the frame of a generic function return the gf, otherwise
          return NIL."
	 ;; Generic functions are implemented as compiled closures.  On the
	 ;; stack, we only see the fnheader for the the closure.  This could
	 ;; be a discriminator code, or in the default method only case it
	 ;; will be the actual method function.  To tell if this is a generic
	 ;; function frame, we have to check very carefully to see if the
	 ;; right stuff is on the stack.  Specifically, the closure's ccode,
	 ;; and the first local variable has to be a ptrhunk big enough to be
	 ;; a FIN environment, and fin-env-fin of that ptrhunk has to point
	 ;; to a generic function whose ccode and environment match. 
	 (let ((n-args (il:stknargs frame))
	       (env nil)
	       (gf nil))
	   (if (and ;; is there at least one local?
		(> (il:stknargs frame t) n-args)
		;; and does the local contain something that might be
		;; the closure environment of a funcallable instance?
		(setf env (il:stkarg (1+ n-args) frame))
		;; and does the local contain something that might be
		;; the closure environment of a funcallable instance?
		(typep env *fin-env-type*)
		(setf gf (fin-env-fin env))
		;; whose fin-env-fin points to a generic function?
		(generic-function-p gf)
		;; whose environment is the same as env?
		(eq (xcl::compiled-closure-env gf) env)
		;; and whose code is the same as the code for this
		;; frame? 
		(function-matches-frame-p gf frame))
	       gf
	       nil))))
    (let ((frame-name (il:stkname stack-pos)))
      ;; See if there is a generic-function on the stack at this
      ;; location.
      (let ((gf (generic-function-from-frame stack-pos)))
	(when gf
	  (return-from interesting-frame-p (values t stack-pos stack-pos gf))))
      ;; See if this is an interpreted method.  The method body is
      ;; wrapped in a (BLOCK <function-name> ...).  We look for an
      ;; interpreted call to BLOCK whose block-name is the name of
      ;; generic-function.
      (when (and (eq frame-name 'eval)
		 (consp (il:stkarg 1 stack-pos))
		 (eq (first (il:stkarg 1 stack-pos)) 'block)
		 (symbolp (second (il:stkarg 1 stack-pos)))
		 (fboundp (second (il:stkarg 1 stack-pos)))
		 (generic-function-p
		     (symbol-function (second (il:stkarg 1 stack-pos)))))
	(let* ((form (il:stkarg 1 stack-pos))
	       (block-name (second form))
	       (generic-function (symbol-function block-name))
	       (methods (generic-function-methods (symbol-function block-name))))
	  ;; If this is really a method being called from a
	  ;; generic-function, the g-f should be no more than a
	  ;; few(?) frames up the stack.  Check for the method call
	  ;; by looking for a call to APPLY, where the function
	  ;; being applied is the code in one of the methods.
	  (do ((i 100 (1- i))
	       (previous-pos stack-pos current-pos)
	       (current-pos (il:stknth -1 stack-pos) (il:stknth -1 current-pos))
	       (found-method nil)
	       (method-pos))
	      ((or (null current-pos) (<= i 0)) nil)
	    (cond ((equalp generic-function
			   (generic-function-from-frame current-pos))
		   (if found-method
		       (return-from interesting-frame-p
			 (values t previous-pos method-pos found-method))
		       (return)))
		  (found-method nil)
		  ((eq (il:stkname current-pos) 'apply)
		   (dolist (method methods)
		     (when (eq (method-function method)
			       (il:stkarg 1 current-pos))
		       (setq method-pos current-pos)
		       (setq found-method method)
		       (return))))))))
      ;; Try to handle compiled methods
      (when (and (symbolp frame-name)
		 (not (fboundp frame-name))
		 (eq (il:chcon1 frame-name)
		     (il:charcode il:\())
		 (or (string-equal "(method " (symbol-name frame-name)
			      :start2 0 :end2 13)
		     (string-equal "(method " (symbol-name frame-name)
			      :start2 0 :end2 12)
		     (string-equal "(method " (symbol-name frame-name)
			      :start2 0 :end2 8)))
	;; Looks like a name that PCL consed up.  See if there is a
	;; GF nearby up the stack.  If there is, use it to help
	;; determine which method we have.
	(do ((i 30 (1- i))
	     (current-pos (il:stknth -1 stack-pos)
			  (il:stknth -1 current-pos))
	     (gf))
	    ((or (null current-pos)
		 (<= i 0))
	     nil)
	  (setq gf (generic-function-from-frame current-pos))
	  (when gf
	    (dolist (method (generic-function-methods gf))
	      (when (function-matches-frame-p (method-function method)
					      stack-pos)
		(return-from interesting-frame-p
		  (values t stack-pos stack-pos method))))
	    (return))))
      ;; If we haven't already returned, use the default method.
      (xcl::interesting-frame-p stack-pos interp-flag))))


(setq il:*short-backtrace-filter* 'interesting-frame-p)

;;; Support for undo

 (defun undoable-setf-slot-value (object slot-name new-value)
    (if (slot-boundp object slot-name)
      (il:undosave (list 'undoable-setf-slot-value
                         object slot-name (slot-value object slot-name)))
      (il:undosave (list 'slot-makunbound object slot-name)))
    (setf (slot-value object slot-name) new-value))

  (setf (get 'slot-value :undoable-setf-inverse) 'undoable-setf-slot-value)


;;; Support for ?= and friends

;; The arglists for generic-functions are built using gensyms, and don't reflect
;; any keywords (they are all included in an &REST arg).  Rather then use the
;; arglist in the code, we use the one that PCL kindly keeps in the generic-function.

(xcl:advise-function 'il:smartarglist
  '(if (and il:explainflg
	(symbolp il:fn)
	(fboundp il:fn)
	(generic-function-p (symbol-function il:fn)))
    (generic-function-pretty-arglist (symbol-function il:fn))
    (xcl:inner))
  :when :around :priority :last)

(setf (get 'defclass 'il:argnames)
      '(nil (class-name (#\{ superclass-name #\} #\*)
	     (#\{ slot-specifier #\} #\*)
	     #\{ slot-option #\} #\*)))

(setf (get 'defmethod 'il:argnames)
      '(nil (#\{ name #\| (setf name) #\} #\{ method-qualifier #\} #\*
	     specialized-lambda-list #\{ declaration #\| doc-string #\} #\*
	     #\{ form #\} #\*)))

;;; Prettyprinting support, the result of Harley Davis.

;; Support the standard Prettyprinter.  This is really minimal right now.  If
;; anybody wants to fix this, I'd be happy to include their code.  In fact,
;; there is almost no support for Commonlisp in the standard Prettyprinter, so
;; the field is wide open to hackers with time on their hands.


(setf (get 'defmethod :definition-print-template) ;Not quite right, since it
      '(:name :arglist :body))		          ; doesn't handle qualifiers,
		          		          ; but it will have to do.

(defun defclass-prettyprint (form)
  (let ((left (il:dspxposition))
	(char-width (il:charwidth (il:charcode x) *standard-output*)))
    (xcl:destructuring-bind (defclass name supers slots . options) form
      (princ "(")
      (prin1 defclass)
      (princ " ")
      (prin1 name)
      (princ " ")
      (if (null supers)
	  (princ "()")			;Print "()" instead of "nil"
	  (il:sequential.prettyprint (list supers) (il:dspxposition)))
      (if (null slots)
	  (progn (il:prinendline (+ left (* 4 char-width)) *standard-output*)
		 (princ "()"))
	  (il:sequential.prettyprint (list slots) (+ left (* 4 char-width))))
      (when options
	(il:sequential.prettyprint options (+ left (* 2 char-width))))
      (princ ")")
      nil)))

(let ((pprint-macro (assoc 'defclass il:prettyprintmacros)))
  (if (null pprint-macro)
      (push (cons 'defclass 'defclass-prettyprint)
	    il:prettyprintmacros)
      (setf (cdr pprint-macro) 'defclass-prettyprint)))

(defun binder-prettyprint (form)
  ;; Prettyprints expressions like MULTIPLE-VALUE-BIND and WITH-SLOTS
  ;; that are of the form (fn (var ...) form &rest body).
  ;; This code is far from correct, but it's better than nothing.
  (if (and (consp form)
	   (not (null (cdddr form))))
      ;; I have no idea what I'm doing here.  Seems I can copy and edit somebody
      ;; elses code without understanding it.
      (let ((body-indent (+ (il:dspxposition)
			    (* 2 (il:charwidth (il:charcode x)
					       *standard-output*))))
	    (form-indent (+ (il:dspxposition)
			    (* 4 (il:charwidth (il:charcode x)
					       *standard-output*)))))
	(princ "(")
	(prin1 (first form))
	(princ " ")
	(il:superprint (second form) form nil *standard-output*)
	(il:sequential.prettyprint (list (third form)) form-indent)
	(il:sequential.prettyprint (cdddr form) body-indent)
	(princ ")")
	nil)				;Return NIL to indicate that we did
					; the printing
      t))				;Return true to use default printing


(dolist (fn '(multiple-value-bind with-accessors with-slots))
  (let ((pprint-macro (assoc fn 'il:prettyprintmacros)))
    (if (null pprint-macro)
	(push (cons fn 'binder-prettyprint)
	      il:prettyprintmacros)
	(setf (cdr pprint-macro) 'binder-prettyprint))))



;; SEdit has its own prettyprinter, so we need to support that too.  This is due
;; to Harley Davis.  Really.

(push (cons :slot-spec
	    '(((sedit::prev-keyword? (sedit::next-inline? 1 break sedit::from-indent . 1)
		break sedit::from-indent . 0)
	       (sedit::set-indent . 1)
	       (sedit::next-inline? 1 break sedit::from-indent . 1)
	       (sedit::prev-keyword? (sedit::next-inline? 1 break sedit::from-indent . 1)
		break sedit::from-indent . 0))
	      ((sedit::prev-keyword? (sedit::next-inline? 1 break sedit::from-indent . 1)
		break sedit::from-indent . 0)
	       (sedit::set-indent . 1)
	       (sedit::next-inline? 1 break sedit::from-indent . 1)
	       (sedit::prev-keyword? (sedit::next-inline? 1 break sedit::from-indent . 1)
		break sedit::from-indent . 0))))
    sedit:*indent-alist*)

(setf (sedit:get-format :slot-spec)
      '(:indent :slot-spec :inline t))

(setf (sedit:get-format :slot-spec-list)
      '(:indent :binding-list :args (:slot-spec) :inline nil))

(setf (sedit:get-format 'defclass)
      '(:indent ((2) 1)
	:args (:keyword nil nil :slot-spec-list nil)
	:sublists (4)))

(setf (sedit:get-format 'defmethod)
      '(:indent ((2))
	:args (:keyword nil :lambda-list nil)
	:sublists (3)))

(setf (sedit:get-format 'defgeneric) 'defun)

(setf (sedit:get-format 'generic-flet) 'flet)

(setf (sedit:get-format 'generic-labels) 'flet)

(setf (sedit:get-format 'call-next-method)
      '(:indent (1) :args (:keyword nil)))

(setf (sedit:get-format 'symbol-macrolet) 'let)

(setf (sedit:get-format 'with-accessors)
      '(:indent ((1) 1)
	:args (:keyword :binding-list nil)
	:sublists (2)
	:miser :never))

(setf (sedit:get-format 'with-slots) 'with-accessors)

(setf (sedit:get-format 'make-instance)
      '(:indent ((1))
	:args (:keyword nil :slot-spec-list)))

(setf (sedit:get-format '*make-instance) 'make-instance)

;;; PrettyFileIndex stuff, the product of Harley Davis.

(defvar *pfi-class-type* '(class defclass pfi-class-namer))

(defvar *pfi-method-type* '(method defmethod pfi-method-namer)
  "Handles method for prettyfileindex")

(defvar *pfi-index-accessors* nil
  "t -> each slot accessor gets a listing in the index.")

(defvar *pfi-method-index* :group
  ":group, :separate, :both, or nil")

(defun pfi-add-class-type ()
  (pushnew *pfi-class-type* il:*pfi-types*))

(defun pfi-add-method-type ()
  (pushnew *pfi-method-type* il:*pfi-types*))

(defun pfi-class-namer (expression entry)
  (let ((class-name (second expression)))
    ;; Following adds all slot readers/writers/accessors as separate entries in
    ;; the index.  Probably a mistake.
    (if *pfi-index-accessors*
	(let ((slot-list (fourth expression))
	      (accessor-names nil))
	  (labels ((add-accessor (method-index name-index)
		     (push (case *pfi-method-index*
			     (:group method-index)
			     (:separate name-index)
			     ((t :both) (list method-index name-index))
			     ((nil) nil)
			     (otherwise (error "Illegal value for *pfi-method-index*: ~S"
					       *pfi-method-index*)))
			   accessor-names))
		   (add-reader (reader-name)
		     (add-accessor `(method (,reader-name (,class-name)))
				   `(,reader-name (,class-name))))
		   (add-writer (writer-name)
		     (add-accessor `(method ((setf ,writer-name) (t ,class-name)))
				   `((setf ,writer-name) (t ,class-name)))))
	    (dolist (slot-def slot-list)
	      (do* ((rest-slot-args (cdr slot-def) (cddr rest-slot-args))
		    (slot-arg (first  rest-slot-args)  (first rest-slot-args)))
		   ((null rest-slot-args))
 		(case slot-arg
		  (:reader (add-reader (second rest-slot-args)))
		  (:writer (add-writer (second rest-slot-args)))
		  (:accessor (add-reader (second rest-slot-args))
			     (add-writer (second rest-slot-args)))
		  (otherwise nil))))
	    (cons `(class (,class-name)) accessor-names)))
	class-name)))

(defun pfi-method-namer (expression entry)
  (let ((method-name (second expression))
	(specializers nil)
	(qualifiers nil)
	lambda-list)
    (do* ((rest-qualifiers (cddr expression) (cdr rest-qualifiers))
	  (qualifier (first rest-qualifiers) (first rest-qualifiers)))
	 ((listp qualifier) (setq lambda-list qualifier)
	                    (setq qualifiers (reverse qualifiers)) qualifiers)
      (push qualifier qualifiers))
    (do* ((rest-lambda-list lambda-list (cdr rest-lambda-list))
	  (arg (first rest-lambda-list) (first rest-lambda-list)))
	 ((or (member arg lambda-list-keywords) (null rest-lambda-list))
	  (setq specializers (reverse specializers)))
      (push (if (listp arg) (second arg) t) specializers))
    (let ((method-index `(method (,method-name ,@qualifiers ,specializers)))
	  (name-index `(,method-name ,@qualifiers ,specializers)))
      (case *pfi-method-index*
	(:group method-index)
	(:separate name-index)
	((t :both) (list method-index name-index))
	((nil) nil)
	(otherwise (error "Illegal value for *pfi-method-index*: ~S" *pfi-method-index*))))))

(defun pfi-install-pcl ()
  (pfi-add-method-type)
  (pfi-add-class-type))

(eval-when (eval load)
  (when (boundp (quote il:*pfi-types*))
    (pfi-install-pcl))
  )