? level-1/l1-pathnames.lisp-w-frameworks
? lib/*xx
? lib/.step.lisp.swp
? lib/install-framework.lisp
Index: level-1/l1-callbacks.lisp
===================================================================
RCS file: /usr/local/tmpcvs/ccl-0.14-dev/ccl/level-1/l1-callbacks.lisp,v
retrieving revision 1.1.1.1
diff -c -r1.1.1.1 l1-callbacks.lisp
*** level-1/l1-callbacks.lisp	19 Oct 2003 08:57:10 -0000	1.1.1.1
--- level-1/l1-callbacks.lisp	7 Feb 2005 01:03:38 -0000
***************
*** 27,36 ****
  (def-accessor-macros %svref
    pfe.routine-descriptor
    pfe.proc-info
!   pfe.lisp-function)
  
  (defun %cons-pfe (routine-descriptor proc-info lisp-function sym without-interrupts)
!   (vector routine-descriptor proc-info lisp-function sym without-interrupts))
  
  ; (defcallback ...) on the PPC expands into a call to this function.
  (defun define-callback-function (lisp-function  &optional doc-string (without-interrupts t) monitor-exception-ports
--- 27,39 ----
  (def-accessor-macros %svref
    pfe.routine-descriptor
    pfe.proc-info
!   pfe.lisp-function
!   pfe.sym
!   pfe.without-interrupts
!   pfe.trace-p)
  
  (defun %cons-pfe (routine-descriptor proc-info lisp-function sym without-interrupts)
!   (vector routine-descriptor proc-info lisp-function sym without-interrupts nil))
  
  ; (defcallback ...) on the PPC expands into a call to this function.
  (defun define-callback-function (lisp-function  &optional doc-string (without-interrupts t) monitor-exception-ports
***************
*** 87,101 ****
    (with-lock-grabbed (*callback-lock*)
      (let* ((pfe (svref %pascal-functions% index)))
        (values (pfe.lisp-function pfe)
!               (pfe.without-interrupts pfe)))))
  
  
  ;; The kernel only really knows how to call back to one function,
  ;; and you're looking at it ...
  (defun %pascal-functions% (index args-ptr-fixnum)
    (declare (optimize (speed 3) (safety 0)))
!   (multiple-value-bind (lisp-function without-interrupts)
        (%lookup-pascal-function index)
!     (if without-interrupts
!       (without-interrupts (funcall lisp-function args-ptr-fixnum))
!       (funcall lisp-function args-ptr-fixnum))))
--- 90,107 ----
    (with-lock-grabbed (*callback-lock*)
      (let* ((pfe (svref %pascal-functions% index)))
        (values (pfe.lisp-function pfe)
!               (pfe.without-interrupts pfe)
!               (pfe.trace-p pfe)))))
  
  
  ;; The kernel only really knows how to call back to one function,
  ;; and you're looking at it ...
  (defun %pascal-functions% (index args-ptr-fixnum)
    (declare (optimize (speed 3) (safety 0)))
!   (multiple-value-bind (lisp-function without-interrupts trace-p)
        (%lookup-pascal-function index)
!     (let ((*callback-trace-p* trace-p))
!       (declare (special *callback-trace-p*))
!       (if without-interrupts
! 	  (without-interrupts (funcall lisp-function args-ptr-fixnum))
! 	(funcall lisp-function args-ptr-fixnum)))))
Index: lib/encapsulate.lisp
===================================================================
RCS file: /usr/local/tmpcvs/ccl-0.14-dev/ccl/lib/encapsulate.lisp,v
retrieving revision 1.2
diff -c -r1.2 encapsulate.lisp
*** lib/encapsulate.lisp	6 May 2004 06:29:07 -0000	1.2
--- lib/encapsulate.lisp	7 Feb 2005 01:03:39 -0000
***************
*** 23,28 ****
--- 23,29 ----
  
  
  (defvar *trace-alist* nil)
+ (defvar *trace-pfun-list* nil)
  (defvar *trace-enable* t)
  (defvar *trace-level* 0)
  (defparameter *trace-max-indent* 40)
***************
*** 61,67 ****
  			 (eq 0 (mod i *trace-bar-frequency*)))
  		  #\| #\Space) *trace-output*)))
  
! (defun trace-before  (&rest args)
    (declare (dynamic-extent args))
    (trace-tab)
    (let* ((*print-level* *trace-print-level*)
--- 62,68 ----
  			 (eq 0 (mod i *trace-bar-frequency*)))
  		  #\| #\Space) *trace-output*)))
  
! (defun trace-before (&rest args)
    (declare (dynamic-extent args))
    (trace-tab)
    (let* ((*print-level* *trace-print-level*)
***************
*** 287,293 ****
      (method (%method-function spec))))
  
  
! (defun %trace-function-spec-p (spec &optional define-if-not)
    ;; weed out macros and special-forms
    (typecase spec
      (symbol
--- 288,294 ----
      (method (%method-function spec))))
  
  
! (defun %trace-function-spec-p (spec &optional define-if-not undefined-ok)
    ;; weed out macros and special-forms
    (typecase spec
      (symbol
***************
*** 296,302 ****
       (let ((res (or (fboundp spec)(and define-if-not
                                         (progn (warn "~S was undefined" spec)
                                                (%fhave spec (%function 'trace-null-def)))))))
!        (when (not res)(error "~S is undefined." spec))
         (values res spec)))
      (method
       (values (%method-function spec) spec))
--- 297,306 ----
       (let ((res (or (fboundp spec)(and define-if-not
                                         (progn (warn "~S was undefined" spec)
                                                (%fhave spec (%function 'trace-null-def)))))))
!        (when (not res)
! 	 (if undefined-ok
! 	     (values nil spec)
! 	   (error "~S is undefined." spec)))
         (values res spec)))
      (method
       (values (%method-function spec) spec))
***************
*** 346,398 ****
        (when def (warn "~S was undefined" spec))
        def)))
  
! (defun %trace (sym &key before after step define-if-not)  
!   (let (def newdef trace-thing)
!     (multiple-value-setq (def trace-thing) 
!       (%trace-function-spec-p sym define-if-not))
!     (if def
!       (let ()
!         (when (%traced-p trace-thing)
!           (%untrace-1 trace-thing)
!           (setq def (%trace-fboundp trace-thing)))
!         (when step   ; just check if has interpreted def
!           (if (typep def 'standard-generic-function)
!             (let ((methods (%gf-methods def)))
!               ; should we complain if no methods? naah
!               (dolist (m methods) ; stick :step-gf in advice-when slot
!                 (%trace m :step t)
!                 (let ((e (function-encapsulation m)))
!                   (when e (setf (encapsulation-advice-when e) :step-gf))))
!               ; we choose to believe that before and after are intended for the gf
!               (if  (or before after)
!                 (setq step nil)                
!                 (return-from %trace)))
!             #|(uncompile-for-stepping trace-thing nil t)|#))
!         (let ((newsym (gensym "TRACE"))
!               (method-p (typep trace-thing 'method)))
!           (when (and (null before)(null after)(null step))
!             (setq before #'trace-before)
!             (setq after #'trace-after))
!           (case before 
!             (:print (setq before #'trace-before)))
!           (case after
!             (:print (setq after #'trace-after)))
!           (setq newdef (trace-global-def 
!                         sym newsym before after step method-p))
!           (when method-p
!             (copy-method-function-bits def newdef))
!           (without-interrupts
!            (multiple-value-bind (ignore gf-dcode) (encapsulate trace-thing def 'trace sym newsym)
!              (declare (ignore ignore))
!              (cond (gf-dcode 
!                     (setf (%gf-dcode def)
!                           (%cons-combined-method def (cons newdef gf-dcode) #'%%call-gf-encapsulation)))
!                    ((symbolp trace-thing) (%fhave trace-thing newdef))
!                    ((typep trace-thing 'method)
!                     (setf (%method-function trace-thing) newdef)
!                     (remove-obsoleted-combined-methods trace-thing)
!                     newdef))))))
!       (error "Trace does not understand ~S." sym))))
  
  ;; sym is either a symbol or a method
  
--- 350,465 ----
        (when def (warn "~S was undefined" spec))
        def)))
  
! (defun %trace (sym &key before after backtrace step define-if-not)  
!   (let (def 
! 	newdef
! 	trace-thing)
! 
!     ;;
!     ;; see if we're a callback
!     ;;
!     (cond
!      ((and (typep sym 'symbol)
! 	   (boundp sym)
! 	   (macptrp (symbol-value sym)))
!       (let ((len (length %pascal-functions%))
! 	    (sym-name (symbol-name sym)))
! 	(declare (fixnum len))
! 	(dotimes (i len)
! 	  (let ((pfe (%svref %pascal-functions% i)))
! 	    (when (and (vectorp pfe)
! 		       (string= sym-name (symbol-name (pfe.sym pfe))))
! 	      (when backtrace
! 		(if (null before)
! 		    (setq before :print)))
! 	      (setf (pfe.trace-p pfe)
! 		    `(,@(if before `((:before . ,before)))
! 		      ,@(if after `((:after . ,after)))
! 		      ,@(if backtrace `((:backtrace . ,backtrace)))))
! 	      (push sym *trace-pfun-list*))))))
! 
!      ;;
!      ;; now look for tracible methods.
!      ;; It's possible, but not likely, that we will be both
!      ;; a callback and a function or method, if so we trace both.
!      ;; If we're neither, signal an error.
!      ;;
!      ((multiple-value-setq (def trace-thing) 
! 	(%trace-function-spec-p sym define-if-not))
!       (if def
! 	  (let ()
! 	    (when (%traced-p trace-thing)
! 	      (%untrace-1 trace-thing)
! 	      (setq def (%trace-fboundp trace-thing)))
! 	    (when step		   ; just check if has interpreted def
! 	      (if (typep def 'standard-generic-function)
! 		  (let ((methods (%gf-methods def)))
! 					; should we complain if no methods? naah
! 		    (dolist (m methods)	; stick :step-gf in advice-when slot
! 		      (%trace m :step t)
! 		      (let ((e (function-encapsulation m)))
! 			(when e (setf (encapsulation-advice-when e) :step-gf))))
! 					; we choose to believe that before and after are intended for the gf
! 		    (if  (or before after)
! 			(setq step nil)                
! 		      (return-from %trace)))
! 		#|(uncompile-for-stepping trace-thing nil t)|#))
! 	    (let ((newsym (gensym "TRACE"))
! 		  (method-p (typep trace-thing 'method)))
! 	      (when (and (null before)(null after)(null step))
! 		(setq before #'trace-before)
! 		(setq after #'trace-after))
! 	      (case before
! 	        (:print	(setq before #'trace-before)))
! 	      (case after
! 		(:print (setq after #'trace-after)))
! 	      (when backtrace
! 		(when (null before)
! 		  (setq before #'trace-before))
! 		(cond
! 		 ((functionp before)
! 		  (let ((bfun before))
! 		    (if (integerp backtrace)
! 			(setq before #'(lambda (&rest args)
! 					 (apply bfun args)
! 					 (let ((*debug-io* *trace-output*))
! 					   (ccl::print-call-history :detailed-p nil :count backtrace)
! 					   (terpri *trace-output*))))
! 		      (setq before #'(lambda (&rest args)
! 				       (apply bfun args)
! 				       (let ((*debug-io* *trace-output*))
! 					 (ccl::print-call-history :detailed-p nil)
! 					 (terpri *trace-output*)))))))
! 		 ((and (consp before) (or (eq (car before) 'function) (eq (car before) 'quote)))
! 		  (if (integerp backtrace)
! 		      (setq before `#'(lambda (&rest args)
! 					 (apply ,before args)
! 					 (let ((*debug-io* *trace-output*))
! 					   (ccl::print-call-history :detailed-p nil :count ,backtrace)
! 					   (terpri *trace-output*))))
! 		    (setq before `#'(lambda (&rest args)
! 					 (apply ,before args)
! 					 (let ((*debug-io* *trace-output*))
! 					   (ccl::print-call-history :detailed-p nil)
! 					   (terpri *trace-output*))))))
! 		 (t
! 		  (warn ":backtrace is not compatible with :before ~A" before))))
! 	      (setq newdef (trace-global-def 
! 			    sym newsym before after step method-p))
! 	      (when method-p
! 		(copy-method-function-bits def newdef))
! 	      (without-interrupts
! 	       (multiple-value-bind (ignore gf-dcode) (encapsulate trace-thing def 'trace sym newsym)
! 		 (declare (ignore ignore))
! 		 (cond (gf-dcode 
! 			(setf (%gf-dcode def)
! 			      (%cons-combined-method def (cons newdef gf-dcode) #'%%call-gf-encapsulation)))
! 		       ((symbolp trace-thing) (%fhave trace-thing newdef))
! 		       ((typep trace-thing 'method)
! 			(setf (%method-function trace-thing) newdef)
! 			(remove-obsoleted-combined-methods trace-thing)
! 			newdef))))))
! 	(error "Trace does not understand ~S." sym))))))
  
  ;; sym is either a symbol or a method
  
***************
*** 412,442 ****
        (when x (push x val)))
      val))
  
- 
  (defun %untrace (sym)
    (when (and (consp sym)(consp (car sym)))
      (setq sym (car sym)))
!   (multiple-value-bind (def trace-thing) (%trace-function-spec-p sym)
!     (let (val)
!       (when (typep def 'standard-generic-function)
!         (let ((methods (%gf-methods def)))
!           (dolist (m methods)
!             (let ((e (function-encapsulation m)))
!               (when (and e (eq (encapsulation-advice-when e) :step-gf))
!                 (remove-encapsulation e)
!                 (push m  val))))))
!       ; gf could have first been traced :step, and then just plain traced
!       ; maybe the latter trace should undo the stepping??
!       (when (%traced-p trace-thing)
!         (%untrace-1 trace-thing)
!         (push trace-thing val))
!       (if (null (cdr val))(car val) val))))
  
  (defun %untrace-all ()
    (let ((val nil))
      (dolist (cap *trace-alist*)
        (push (encapsulation-spec cap) val)
        (remove-encapsulation cap))
      val))
  
  ;; thing is a symbol or method - def is current definition
--- 479,516 ----
        (when x (push x val)))
      val))
  
  (defun %untrace (sym)
    (when (and (consp sym)(consp (car sym)))
      (setq sym (car sym)))
!   (cond
!    ((and (typep sym 'symbol)
! 	 (boundp sym)
! 	 (macptrp (symbol-value sym)))
!     (%untrace-pfun sym))
!    (t 
!     (multiple-value-bind (def trace-thing) (%trace-function-spec-p sym)
!       (let (val)
! 	(when (typep def 'standard-generic-function)
! 	  (let ((methods (%gf-methods def)))
! 	    (dolist (m methods)
! 	      (let ((e (function-encapsulation m)))
! 		(when (and e (eq (encapsulation-advice-when e) :step-gf))
! 		  (remove-encapsulation e)
! 		  (push m  val))))))
! 					; gf could have first been traced :step, and then just plain traced
! 					; maybe the latter trace should undo the stepping??
! 	(when (%traced-p trace-thing)
! 	  (%untrace-1 trace-thing)
! 	  (push trace-thing val))
! 	(if (null (cdr val))(car val) val))))))
  
  (defun %untrace-all ()
    (let ((val nil))
      (dolist (cap *trace-alist*)
        (push (encapsulation-spec cap) val)
        (remove-encapsulation cap))
+     (dolist (pfun *trace-pfun-list*)
+       (%untrace pfun))
      val))
  
  ;; thing is a symbol or method - def is current definition
***************
*** 444,455 ****
  (defun %untrace-1 (thing)
    (let (capsule)
      (setq capsule (function-encapsulation thing))
!     ;; trace encapsulations must be first      
      (when (neq (encapsulation-type capsule) 'trace)
        (error "~S was not traced." thing))
      (remove-encapsulation capsule)
      (encapsulation-spec capsule)))
  
  
  (defmacro trace (&rest syms)
    (if syms
--- 518,541 ----
  (defun %untrace-1 (thing)
    (let (capsule)
      (setq capsule (function-encapsulation thing))
!     ;; trace encapsulations must be first
      (when (neq (encapsulation-type capsule) 'trace)
        (error "~S was not traced." thing))
      (remove-encapsulation capsule)
      (encapsulation-spec capsule)))
  
+ (defun %untrace-pfun (sym)
+   (let ((len (length %pascal-functions%))
+ 	(sym-name (symbol-name sym)))
+     (declare (fixnum len))
+     (dotimes (i len)
+       (let ((pfe (%svref %pascal-functions% i)))
+ 	(when (and (vectorp pfe)
+ 		   (string= sym-name (symbol-name (pfe.sym pfe))))
+ 	  (setf (pfe.trace-p pfe) nil
+ 		*trace-pfun-list* (remove sym *trace-pfun-list*))
+ 	  (return-from %untrace-pfun sym))))
+     nil))
  
  (defmacro trace (&rest syms)
    (if syms
***************
*** 470,475 ****
--- 556,563 ----
    (let (res)
      (dolist (x *trace-alist*)
        (push (encapsulation-spec x) res))
+     (dolist (x *trace-pfun-list*)
+       (push x res))
      res))
  
  
Index: lib/macros.lisp
===================================================================
RCS file: /usr/local/tmpcvs/ccl-0.14-dev/ccl/lib/macros.lisp,v
retrieving revision 1.20
diff -c -r1.20 macros.lisp
*** lib/macros.lisp	25 Sep 2004 21:36:06 -0000	1.20
--- lib/macros.lisp	7 Feb 2005 01:03:40 -0000
***************
*** 686,692 ****
    pfe.proc-info
    pfe.lisp-function
    pfe.sym
!   pfe.without-interrupts)
  
  (defmacro cond (&rest args &aux clause)
    (when args
--- 686,693 ----
    pfe.proc-info
    pfe.lisp-function
    pfe.sym
!   pfe.without-interrupts
!   pfe.trace-p)
  
  (defmacro cond (&rest args &aux clause)
    (when args
***************
*** 2101,2112 ****
--- 2102,2131 ----
  (defmacro %get-single-float-from-double-ptr (ptr offset)
    `(%double-float->short-float (%get-double-float ,ptr ,offset)))
  
+ (defvar *trace-print-functions* nil)
+ (defun %trace-print-arg (stream arg val type)
+   (format stream " ")
+   (let ((fn (assoc type *trace-print-functions*)))
+     (if fn
+ 	(funcall (cdr fn) stream arg val)
+       (progn
+ 	(when arg
+ 	  (format stream "~A = " arg))
+ 	(if (and type (not (eq type :void)))
+ 	    (format stream "[:~A] ~A~%" type val)
+ 	  (format stream ":VOID~%" val))))))
+ 
+ (defun def-trace-print-function (type fn)
+   (push (cons type fn) *trace-print-functions*))
+ 
  (defun define-callback (name args body env)
    (let* ((stack-word (gensym))
           (stack-ptr (gensym))
           (arg-names ())
           (arg-types ())
+ 	 (trace-args ())
           (return-type :void)
+          (trace-return-type :void)
           (args args)
           (woi nil)
  	 (monitor nil)
***************
*** 2115,2121 ****
      (loop
        (when (null args) (return))
        (when (null (cdr args))
!         (setq return-type (car args))
          (return))
        (if (eq (car args) :without-interrupts)
          (setq woi (cadr args) args (cddr args))
--- 2134,2141 ----
      (loop
        (when (null args) (return))
        (when (null (cdr args))
!         (setq return-type (car args)
! 	      trace-return-type (car args))
          (return))
        (if (eq (car args) :without-interrupts)
          (setq woi (cadr args) args (cddr args))
***************
*** 2128,2137 ****
                                             :error-return)
                    args (cddr args))
              (progn
                (push (foreign-type-to-representation-type (pop args)) arg-types)
                (push (pop args) arg-names))))))
      (setq arg-names (nreverse arg-names)
!           arg-types (nreverse arg-types))
      (setq return-type (foreign-type-to-representation-type return-type))
      (when (eq return-type :void)
        (setq return-type nil))
--- 2148,2159 ----
                                             :error-return)
                    args (cddr args))
              (progn
+ 	      (push (cons (cadr args) (car args)) trace-args)
                (push (foreign-type-to-representation-type (pop args)) arg-types)
                (push (pop args) arg-names))))))
      (setq arg-names (nreverse arg-names)
!           arg-types (nreverse arg-types)
! 	  trace-args (nreverse trace-args))
      (setq return-type (foreign-type-to-representation-type return-type))
      (when (eq return-type :void)
        (setq return-type nil))
***************
*** 2232,2270 ****
             (define-callback-function
               (nfunction ,name
                          (lambda (,stack-word)
!                           (declare (ignorable ,stack-word))
                            (block ,name
                              (with-macptrs (,@(and need-stack-pointer (list `(,stack-ptr))))
                                ,(when need-stack-pointer
                                   `(%setf-macptr-to-object ,stack-ptr ,stack-word))
!                               ,(defcallback-body stack-ptr lets dynamic-extent-names
                                                   decls body return-type error-return
                                                   #+poweropen-target
                                                   (- ppc32::c-frame.savelr ppc32::c-frame.param0)
!                                                  #-poweropen-target 0)))))
               ,doc
               ,woi
  	     ,monitor))))))
  
! (defun defcallback-body (stack-ptr lets dynamic-extent-names decls body return-type error-return error-delta)
    (let* ((result (gensym))
           (condition-name (if (atom error-return) 'error (car error-return)))
           (error-return-function (if (atom error-return) error-return (cadr error-return)))
           (body
!           `(let ,lets
! 	    (declare (dynamic-extent ,@dynamic-extent-names))
! 	    ,@decls
! 	    (let ((,result (progn ,@body)))
! 	      (declare (ignorable ,result))
! 	      , (when return-type
! 		  `(setf (,
! 			  (case return-type
! 			    (:address '%get-ptr)
! 			    (:signed-doubleword '%%get-signed-longlong)
! 			    (:unsigned-doubleword '%%get-unsigned-longlong)
! 			    (:double-float '%get-double-float)
! 			    (:single-float '%get-single-float)
! 			    (t '%get-long)) ,stack-ptr) ,result))))))
      (if error-return
        (let* ((cond (gensym)))
          `(handler-case ,body
--- 2254,2330 ----
             (define-callback-function
               (nfunction ,name
                          (lambda (,stack-word)
!                           (declare (ignorable ,stack-word)
! 				   (special *callback-trace-p*))
                            (block ,name
                              (with-macptrs (,@(and need-stack-pointer (list `(,stack-ptr))))
                                ,(when need-stack-pointer
                                   `(%setf-macptr-to-object ,stack-ptr ,stack-word))
!                               ,(defcallback-body name stack-ptr lets dynamic-extent-names
                                                   decls body return-type error-return
                                                   #+poweropen-target
                                                   (- ppc32::c-frame.savelr ppc32::c-frame.param0)
!                                                  #-poweropen-target 0
! 						 trace-args trace-return-type)))))
               ,doc
               ,woi
  	     ,monitor))))))
  
! (defun defcallback-body (name stack-ptr lets dynamic-extent-names decls body return-type error-return error-delta trace-args trace-result-type)
    (let* ((result (gensym))
           (condition-name (if (atom error-return) 'error (car error-return)))
           (error-return-function (if (atom error-return) error-return (cadr error-return)))
           (body
! 	  `(let* ((trace-before (assoc :before *callback-trace-p*))
! 		  (trace-backtrace (assoc :backtrace *callback-trace-p*))
! 		  (trace-after (assoc :after *callback-trace-p*))
! 		  ;;
! 		  ;; it would be nice if we only bound this when we were tracing
! 		  ;;
! 		  (*trace-level* (if (or trace-before trace-after)
! 				     (1+ *trace-level*)
! 				   *trace-level*)))
! 	     (declare (special *trace-level*))
! 	     (let ,lets
! 	       (declare (dynamic-extent ,@dynamic-extent-names))
! 	       ,@decls
! 	       (when trace-before
! 		 (case (cdr trace-before)
! 		   (:print
! 		    (let ,lets
! 		      (trace-tab)
! 		      (format *trace-output* "CALLING ~A sp=~X~%" ',name ,stack-ptr)
! 		      ,@(let (result)
! 			  (dolist (l trace-args)
! 			    (push '(trace-tab) result)
! 			    (push `(%trace-print-arg *trace-output* ',(car l) ,(car l) ',(cdr l)) result))
! 			  (nreverse result))
! 		      (cond
! 		       ((integerp trace-backtrace)
! 			(ccl::print-call-history :detailed-p nil :count (cdr trace-backtrace)))
! 		       (trace-backtrace
! 			(ccl::print-call-history :detailed-p nil)))))
! 		   (:break
! 		    (break))))
! 	       (let ((,result (progn ,@body)))
! 		 (declare (ignorable ,result))
! 		 (when trace-after
! 		   (case (cdr trace-after)
! 		     (:print
! 		      (trace-tab)
! 		       (format *trace-output* " ~A returned " ',name)
! 		       (%trace-print-arg *trace-output* nil ,result ,trace-result-type))
! 		     (:break
! 		      (break))))
! 		 ,(when return-type
! 		    `(setf (,
! 			    (case return-type
! 			      (:address '%get-ptr)
! 			      (:signed-doubleword '%%get-signed-longlong)
! 			      (:unsigned-doubleword '%%get-unsigned-longlong)
! 			      (:double-float '%get-double-float)
! 			      (:single-float '%get-single-float)
! 			      (t '%get-long)) ,stack-ptr) ,result)))))))
      (if error-return
        (let* ((cond (gensym)))
          `(handler-case ,body