Changeset 9844


Ignore:
Timestamp:
Jun 27, 2008, 6:28:43 PM (11 years ago)
Author:
gz
Message:

Made loading a file not forget encapsulations. (The old behavior can be
restored by setting ccl::*loading-removes-encapsulation* to true).

Added new keyword arg to ADVISE - :dynamic-extent-arglist, if true, declares the
advised arglist to be dynamic-extent, this can be used to minimize runtime
consing when the advice form doesn't save the arglist outside the dynamic extent
of the invocation.

Changed how encapsulation (i.e. tracing and advising) of generic functions
works. Before, the encapsulating function would be installed as the dcode and
then try to guess what the gf code used to do in order to invoke the original
dcode. Now, we just save a copy of the original gf code and jump to it. This
way encapsulation is isolated from having to know details of how the dcode and
the gf interact.

Made (setf %gf-dcode) also update the GF function code to match the dcode. This
is now the only place that has knowledge of how to do that.

register-dcode-proto for %%1st-arg-dcode and %%nth-arg-dcode, since *gf-proto*
is no longer the default.

Also while in there, I consolidated and rearranged some of the encapsulation
recording, hopefully without introducing too many bugs (or at least none that
will be hard to fix).

Location:
trunk/source
Files:
9 edited

Legend:

Unmodified
Added
Removed

  • trunk/source/level-0/PPC/ppc-def.lisp

    r6178 r9844  
    12331233
    12341234
     1235(defun %copy-function (proto &optional target)
     1236  (let* ((total-size (uvsize proto))
     1237         (new (or target (allocate-typed-vector :function total-size))))
     1238    (declare (fixnum total-size))
     1239    (when target
     1240      (unless (eql total-size (uvsize target))
     1241        (error "Wrong size target ~s" target)))
     1242    (%copy-gvector-to-gvector proto 0 new 0 total-size)
     1243    new))
     1244
    12351245(defun replace-function-code (target-fn proto-fn)
    12361246  (if (typep target-fn 'function)

  • trunk/source/level-0/X86/x86-def.lisp

    r8356 r9844  
    112112      (declare (fixnum k) (list imms))
    113113      (setf (%svref newv k) (car imms)))))
     114
     115(defun %copy-function (proto &optional target)
     116  (let* ((protov (%function-to-function-vector proto))
     117         (code-words (%function-code-words proto))
     118         (total-words (uvsize protov))
     119         (newv (if target
     120                 (%function-to-function-vector target)
     121                 (allocate-typed-vector :function total-words))))
     122    (declare (fixnum code-words total-words))
     123    (when target
     124      (unless (and (eql code-words (%function-code-words target))
     125                   (eql total-words (uvsize newv)))
     126        (error "Wrong size target ~s" target)))
     127    (%copy-ivector-to-ivector protov 0 newv 0 (the fixnum (ash code-words target::word-shift)))
     128    (loop for k fixnum from code-words below total-words
     129      do (setf (%svref newv k) (%svref protov k)))
     130    (%function-vector-to-function newv)))
    114131
    115132(defun replace-function-code (target proto)

  • trunk/source/level-0/l0-def.lisp

    r6485 r9844  
    8787(%fhave 'encapsulated-function-name  ;Redefined in encapsulate - used in l1-io
    8888        (qlfun bootstrapping-encapsulated-function-name (fn)
    89           (declare (ignore fn))
    90           nil))
    91 
    92 (%fhave '%traced-p  ;Redefined in encapsulate - used in l1-io
    93         (qlfun bootstrapping-%traced-p (fn)
    94           (declare (ignore fn))
    95           nil))
    96 
    97 (%fhave '%advised-p  ;Redefined in encapsulate used in l1-io
    98         (qlfun bootstrapping-%advised-p (fn)
    9989          (declare (ignore fn))
    10090          nil))

  • trunk/source/level-1/l1-clos-boot.lisp

    r9837 r9844  
    540540;;;;;;;;;;;;;;;;;;;;;;;;;;; defmethod support ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
    541541
    542 (%fhave 'function-encapsulation ;Redefined in encapsulate
    543         (qlfun bootstrapping-function-encapsulation (name)
    544           (declare (ignore name))
    545           nil))
    546 
    547542(%fhave '%move-method-encapsulations-maybe ; Redefined in encapsulate
    548543        (qlfun boot-%move-method-encapsulations-maybe (m1 m2)
    … …  
    550545          nil))
    551546
    552 
    553547(%fhave 'find-unencapsulated-definition  ;Redefined in encapsulate
    554         (qlfun bootstrapping-unenecapsulated-def (spec)
    555           (values
    556            (typecase spec
    557              (symbol (fboundp spec))
    558              (method (%method-function spec))
    559              (t spec))
    560            spec)))
     548        (qlfun bootstrapping-find-unencapsulated-definition (fn)
     549          fn))
     550
     551(%fhave 'function-encapsulated-p  ;Redefined in encapsulate
     552        (qlfun bootstrapping-function-encapsulated-p (fn)
     553          (declare (ignore fn))
     554          nil))
    561555
    562556(let* ((class-wrapper-random-state (make-random-state))
    … …  
    570564
    571565(defun %inner-method-function (method)
    572   (let ((f (%method-function method)))
    573     (when (function-encapsulation f)
    574       (setq f (find-unencapsulated-definition f)))
    575     (closure-function f)))
    576 
     566  (closure-function
     567   (find-unencapsulated-definition
     568    (%method-function method))))
    577569
    578570(defun copy-method-function-bits (from to)
    … …  
    711703       
    712704
    713 (defun forget-encapsulations (name)
    714   (declare (ignore name))
    715   nil)
    716 
    717705(defun %anonymous-method (function specializers qualifiers  lambda-list &optional documentation
    718706                                   &aux name method-class)
    … …  
    779767  (setq method-function
    780768        (closure-function
    781          (if (function-encapsulation method-function)
    782            (find-unencapsulated-definition method-function)
    783            method-function)))
     769         (find-unencapsulated-definition method-function)))
    784770  (setq method-function (require-type method-function 'method-function))
    785771  (lfun-name method-function))
    … …  
    10961082                  multi-method-index)
    10971083                0))
    1098         (let* ((old-dcode (%gf-dcode gf))
    1099                (encapsulated-dcode-cons (and (combined-method-p old-dcode)
    1100                                              (eq '%%call-gf-encapsulation
    1101                                                  (function-name (%combined-method-dcode old-dcode)))
    1102                                              (cdr (%combined-method-methods old-dcode)))))
    1103           (when (or non-dt (neq dcode (if encapsulated-dcode-cons (cdr encapsulated-dcode-cons) old-dcode))
     1084        (let* ((old-dcode (%gf-dcode (find-unencapsulated-definition gf))))
     1085          (when (or non-dt
     1086                    (neq dcode old-dcode)
    11041087                    (neq multi-method-index (%gf-dispatch-table-argnum dt)))
    1105             (let* ((proto (if non-dt
    1106                             #'funcallable-trampoline
    1107                             (or (cdr (assq dcode dcode-proto-alist)) *gf-proto*))))
    1108               (clear-gf-dispatch-table dt)
    1109               (setf (%gf-dispatch-table-argnum dt) multi-method-index)
    1110               (if encapsulated-dcode-cons ; and more?
    1111                 (let ((old-gf (car encapsulated-dcode-cons)))
    1112                   (if (not (typep old-gf 'generic-function))
    1113                     (error "Confused"))
    1114                   ;(setf (uvref old-gf 0)(uvref proto 0))
    1115                   (setf (cdr encapsulated-dcode-cons) dcode))
    1116                 (progn
    1117                   (setf (%gf-dcode gf) dcode)
    1118                   (replace-function-code gf proto))))))
     1088            (clear-gf-dispatch-table dt)
     1089            (setf (%gf-dispatch-table-argnum dt) multi-method-index)
     1090            (if (function-encapsulated-p gf)
     1091              (%set-encapsulated-gf-dcode gf dcode)
     1092              (setf (%gf-dcode gf) dcode))))
    11191093        (values dcode multi-method-index)))))
    11201094

  • trunk/source/level-1/l1-clos.lisp

    r9240 r9844  
    14401440                                       &key &allow-other-keys)
    14411441
    1442   (replace-function-code instance *gf-proto*)
    1443   (setf (gf.dcode instance) #'%%0-arg-dcode))
    1444        
    1445                                        
     1442  (setf (%gf-dcode instance)  #'%%0-arg-dcode))
    14461443
    14471444(defmethod initialize-instance :after ((gf standard-generic-function)
    … …  
    17061703  (unless (functionp function)
    17071704    (error "~S is not a function" function))
    1708   (replace-function-code funcallable-instance #'funcallable-trampoline)
    1709   (setf (gf.dcode funcallable-instance) function))
     1705  (setf (%gf-dcode funcallable-instance) function))
    17101706
    17111707(defmethod reinitialize-instance ((slotd slot-definition) &key &allow-other-keys)
    … …  
    20312027                (t
    20322028                 #'%%1st-arg-eql-method-hack-dcode)))))
    2033 
    2034  
    2035  
    20362029
    20372030

  • trunk/source/level-1/l1-dcode.lisp

    r9386 r9844  
    515515  (gf.dcode gf))
    516516
    517 (defun %set-gf-dcode (gf val)
    518   (setf (gf.dcode gf) val))
     517(defun %set-gf-dcode (gf dcode)
     518  (let ((gf (require-type gf 'standard-generic-function))
     519        (dcode (require-type dcode 'function)))
     520    (replace-function-code gf (or (cdr (assq dcode dcode-proto-alist))
     521                                  #'funcallable-trampoline))
     522    (setf (gf.dcode gf) dcode)))
    519523
    520524(defun %set-gf-dispatch-table (gf val)
    521525  (setf (gf.dispatch-table gf) val))
    522 
    523526
    524527(defun %combined-method-methods  (cm)
    … …  
    825828      (let ((method (%find-1st-arg-combined-method dt (%car args))))
    826829        (apply method args)))))
    827 
     830(register-dcode-proto #'%%1st-arg-dcode *gf-proto*)
    828831
    829832(defun %%one-arg-dcode (dt  arg)
    … …  
    854857      (let ((method (%find-nth-arg-combined-method dt (%lexpr-ref args args-len argnum) args)))
    855858        (%apply-lexpr-tail-wise method args)))))
    856 
     859(register-dcode-proto #'%%nth-arg-dcode *gf-proto*)
    857860
    858861(defun 0-arg-combined-method-trap (gf)

  • trunk/source/level-1/l1-utils.lisp

    r8509 r9844  
    378378  x)
    379379
    380 (%fhave 'find-unencapsulated-definition #'identity)
    381 
    382380(defun coerce-to-function (arg)
    383381  (if (functionp arg)

  • trunk/source/lib/edit-callers.lisp

    r4123 r9844  
    135135      (pascal-function-p function)
    136136      (let ((name (function-name function)))
    137         (and name (function-encapsulation name) name))
     137        (and name (function-encapsulated-p name) name))
    138138      (let ((caller function) next)
    139139        (loop
    140140          (setq next (gethash caller *function-parent-table*))
    141           (if  next           
     141          (if  next
    142142            (cond ((consp next)
    143143                   (when (null the-list)(push function the-list))

  • trunk/source/lib/encapsulate.lisp

    r9386 r9844  
    1717(in-package "CCL")
    1818
    19 ;; Lets try encapsulations
    20 ;; trace is here too
    21 ;; Make trace like 1.3, trace methods, trace (setf car)
    22 
    23 
    24 (defvar *trace-alist* nil)
     19(defvar *loading-removes-encapsulation* nil
     20  "If true, loading a new method definition from a file will remove any tracing and advice on the method")
     21
    2522(defvar *trace-pfun-list* nil)
    2623(defvar *trace-enable* t)
    … …  
    3532(defvar *trace-print-hook* nil)
    3633
    37 
    38 (defvar *advise-alist* nil)
     34;;;
     35;;;  We support encapsulating three types of objects, i.e. modifying their definition
     36;;;  without changing their identity:
     37;;;    1. symbol - via the symbol-function slot
     38;;;    2. method - via the %method-function slot
     39;;;    3. standard-generic-function - via the %gf-dcode slot
     40;;;
     41;;; Encapsulation is effected by creating a new compiled function and storing it in the
     42;;; slot above. The new function references a gensym fbound to the original definition
     43;;; (except in the case of a gf, the gensym is fbound to a copy of the gf which in
     44;;; turn contains the original dcode, since we can't invoke the dcode directly).
     45;;; In addition, an ENCAPSULATION struct describing the encapsulation is created and
     46;;; stored in the *encapsulation-table* with the new compiled function as the key.
     47;;;
     48;;;
    3949
    4050(defparameter *encapsulation-table*
    41   (make-hash-table :test #'eq :rehash-size 2 :size 2))
     51  (make-hash-table :test #'eq :rehash-size 2 :size 2 :weak t))
    4252
    4353(defstruct (encapsulation)
    … …  
    4757  advice-name    ; optional
    4858  advice-when    ; :before, :after, :around
    49   owner          ; where encapsulation is installed
     59  owner          ; where encapsulation is installed (can change)
    5060)
     61
     62(defun encapsulation-old-def (cap)
     63  (fboundp (encapsulation-symbol cap)))
    5164
    5265(defun setf-function-spec-name (spec)
    … …  
    5669    spec))
    5770
    58 
    5971(defun trace-tab (direction &aux (n (min *trace-level* *trace-max-indent*)))
    6072  (fresh-line *trace-output*)
    … …  
    6274    (declare (fixnum i))
    6375    (write-char (if (and *trace-bar-frequency*
    64                         (eq 0 (mod i *trace-bar-frequency*)))
    65                   #\| #\Space) *trace-output*))
     76                        (eq 0 (mod i *trace-bar-frequency*)))
     77                  #\| #\Space) *trace-output*))
    6678  (if (eq direction :in)
    6779    (format *trace-output* "~d> " (1- *trace-level*))
    … …  
    98110    (format t "~%... Untracing ~a" name)
    99111    (%untrace-1 name))
    100   (when (%advised-p name nil nil t)
     112  (when (%advised-p name)
    101113    (format t "~%... Unadvising ~a" name)
    102     (unadvise-1 name))
     114    (%unadvise-1 name))
    103115  nil)
    104116
    105117(defun function-encapsulated-p (fn-or-method)
    106   (typecase fn-or-method
    107     ((or method symbol cons)(function-encapsulation fn-or-method))
    108     (function
    109      (or (function-traced-p fn-or-method)
    110          (function-advised-p fn-or-method )))))
    111 
    112 (defun function-traced-p (fn)
    113   (%function-in-alist fn *trace-alist*))
    114 
    115 (defun function-advised-p (fn)
    116   (%function-in-alist fn *advise-alist*))                           
    117 
    118 (defun %function-in-alist (def list)
    119   (dolist (cap list)
    120     (let ((symbol (encapsulation-owner cap)))
    121       (typecase symbol
    122         (symbol (when (eq (fboundp symbol) def)
    123                   (return cap)))
    124         (method (when (eq (%method-function symbol) def)
    125                   (return cap)))
    126         (standard-generic-function
    127          (when (eq symbol def) (return cap)))))))
    128 
    129 (defun function-encapsulation (spec)
    130   (typecase spec
    131     ((or symbol method)
    132      (gethash spec *encapsulation-table*))
    133     (function (function-encapsulated-p spec))
    134     (cons (gethash (setf-function-spec-name spec) *encapsulation-table*))))
    135 ;; i.e. old 68K clos - vs 68K target with new clos
    136 
    137 
    138 
    139 
    140 ; she works now - does the equivalent of the original gf - called from traced def
    141 (defun %%call-encapsulated-gf (thing args)
    142   ; (print 'one)(print thing)(print args)
    143   ; thing is gf . %%1st-arg-dcode
    144   ; args is ok
    145   (let* ((dcode (cdr thing))
    146          (proto (assq dcode dcode-proto-alist))  ; <<
    147          (dt (%gf-dispatch-table (car thing))))
    148     (if proto ; assume all of these special dudes want args individually
    149       (if (listp args)
    150         (apply dcode dt args)
    151         (%apply-lexpr dcode dt args))
    152       (funcall dcode dt args))))
    153    
    154 
    155 
    156                      ; (apply encapsulation args)
    157 
    158 
    159 ;; the dcode function of the original gf has been bashed with a combined method whose
    160 ;; dcode function is this. So the combined method is called with 2 args (dispatch-table
    161 ;; and args to the gf). The combined method in turn makes a lexpr of those 2 args.
    162 
    163 (defun %%call-gf-encapsulation (thing args)
    164   ; (print 'two)(print thing)(print (if (listp args) args (collect-lexpr-args args 0)))
    165   ; thing traced-blitz  gf-blitz . %%1st-arg-dcode 
    166   ; args = dispatch-table . original-args
    167   ;  dont need dispatch-table - its just there as a side effect
    168   (if (listp args)  ; this probably never happens
    169     (let ((orig-args (cadr args)))
    170       (if (listp orig-args)
    171         (apply (car thing) orig-args)
    172         (%apply-lexpr (car thing) orig-args)))
    173     (let* ((orig-args (%lexpr-ref args (%lexpr-count args) 1)))
    174       (if (listp orig-args)
    175         (apply (car thing) orig-args)
    176         ; knee deep in lexprs
    177         (%apply-lexpr (car thing) orig-args)))))
    178    
    179 
    180 (defun encapsulate (fn-spec old-def type trace-spec newsym
    181                             &optional advice-name advice-when)
    182   (let ((capsule (function-encapsulation fn-spec))
    183         gf-dcode old-encapsulation)
    184     (%fhave newsym
    185             (if (standard-generic-function-p old-def)
    186               (let ((dcode (%gf-dcode old-def)))
    187                 (setq gf-dcode
    188                       (if (and (combined-method-p dcode)
    189                                (eq '%%call-gf-encapsulation
    190                                    (function-name (%combined-method-dcode dcode))))
    191                         (let ((stuff (%combined-method-methods dcode)))
    192                           (setq old-encapsulation (car stuff))
    193                           (cdr stuff))
    194                         (cons old-def dcode)))
    195                 (replace-function-code old-def *gf-proto*)  ; <<  gotta remember to fix it
    196                 (or old-encapsulation
    197                     (%cons-combined-method old-def gf-dcode #'%%call-encapsulated-gf)))
    198               old-def))                 ; make new symbol call old definition
    199     ;; move the encapsulation from fn-spec to sym   
    200     (cond (capsule (put-encapsulation newsym capsule)))   
    201     (put-encapsulation fn-spec
    202                        (make-encapsulation
    203                         :symbol newsym
    204                         :type type
    205                         :spec trace-spec
    206                         :advice-name advice-name
    207                         :advice-when advice-when))
    208     (values newsym gf-dcode)))
    209  
    210 
    211 ;; call with cap nil to remove - for symbol anyway
    212 ;; maybe advising methods is silly - just define a before method
    213 
    214 (defun put-encapsulation (spec cap)
    215   (when cap
    216     (setf (encapsulation-owner cap) spec)
    217     (record-encapsulation cap)
    218     )
    219   (let ((key (typecase spec
    220                ((or symbol method standard-generic-function) spec)
    221                (cons (setf-function-spec-name spec))
    222                (t (report-bad-arg spec '(or symbol method cons))))))
    223     (if cap
    224       (setf (gethash key *encapsulation-table*) cap)
    225       (remhash key *encapsulation-table*)))
    226   cap)
    227 
    228 (defun remove-encapsulation (capsule &optional dont-replace)
    229   ; optional don't replace is for unadvising, tracing all on a method
    230   (let (spec nextsym newdef def)
    231     (setq spec (encapsulation-owner capsule))
    232     (setq def (typecase spec
    233                 (symbol (fboundp spec))
    234                 (method spec)))
    235     (setq nextsym (encapsulation-symbol capsule))
    236     (setq newdef (fboundp nextsym))
    237     (without-interrupts
    238      (if (standard-generic-function-p def)
    239        (if (and (combined-method-p newdef)
    240                 (eq '%%call-encapsulated-gf (function-name (%combined-method-dcode newdef))))
    241          (let* ((orig-decode (require-type (cdr (%combined-method-methods newdef)) 'function))
    242                 (proto (cdr (assq orig-decode dcode-proto-alist)))
    243                 ) ; <<
    244            (setf (%gf-dcode def) orig-decode)
    245            (replace-function-code def (or proto #'funcallable-trampoline)))
    246          (setf (car (%combined-method-methods (%gf-dcode def))) newdef))
    247        (typecase spec
    248          (symbol (%fhave spec newdef))
    249          (method (setf (%method-function spec) newdef)
    250                  (remove-obsoleted-combined-methods spec)
    251                  newdef)))
    252      (put-encapsulation spec
    253                         (if (null dont-replace)
    254                           (function-encapsulation nextsym)))
    255      (put-encapsulation nextsym nil)
    256      (unrecord-encapsulation capsule)
    257      )))
    258 
    259 
    260 (defun record-encapsulation (capsule)
    261   (ecase (encapsulation-type capsule)
    262     (trace
    263      (when (not (memq capsule *trace-alist*))
    264        (push capsule *trace-alist*)))
    265     (advice
    266      (when (not (memq capsule *advise-alist*))
    267        (push capsule *advise-alist*)))))
    268 
    269 (defun unrecord-encapsulation (capsule)
    270   (ecase (encapsulation-type capsule)
    271     (trace
    272       (setq *trace-alist* (delq capsule *trace-alist*)))
    273     (advice
    274      (setq *advise-alist* (delq capsule *advise-alist*)))))
    275 
    276 
    277 (defun find-unencapsulated-definition (spec)
    278   ;; spec is a symbol, function, or method object
    279   ;; returns a raw function ??
    280   (let (foo)
    281     (while (setq foo (function-encapsulation spec))
    282       (setq spec (encapsulation-symbol foo)))
    283     (values
    284     (typecase spec
    285       (symbol (fboundp spec))
    286       (method (%method-function spec))
    287       (t spec))
    288     spec)))
    289 
    290 (defun %trace-fboundp (spec)
    291   (typecase spec
    292     (symbol (fboundp spec))
    293     (method (%method-function spec))))
    294 
    295 
    296 (defun %trace-function-spec-p (spec &optional define-if-not undefined-ok (error-p t))
    297   ;; weed out macros and special-forms
     118  (get-encapsulation fn-or-method))
     119
     120(defun %encap-binding (thing)
     121  (require-type (etypecase thing
     122                  (symbol (fboundp thing))
     123                  (method (%method-function thing)))
     124                'function))
     125
     126(defun get-encapsulation (spec)
     127  (let* ((key (typecase spec
     128                (symbol (let* ((def (fboundp spec)))
     129                          (if (generic-function-p def)
     130                            (%gf-dcode def)
     131                            def)))
     132                (method (%method-function spec))
     133                (standard-generic-function (%gf-dcode spec))
     134                (function spec)))
     135         (cap (gethash key *encapsulation-table*)))
     136    #+gz (assert (or (null cap)
     137                     (let ((fn (%encap-binding (encapsulation-owner cap))))
     138                       (eq (if (standard-generic-function-p fn) (%gf-dcode fn) fn) key))))
     139    cap))
     140
     141(defun set-encapsulation-owner (fn owner)
     142  (let ((cap (get-encapsulation fn)))
     143    (when cap
     144      (setf (encapsulation-owner cap) owner))))
     145
     146(defun put-encapsulation (fn cap)
     147  (let* ((owner (encapsulation-owner cap))
     148         (old-def (%encap-binding owner))
     149         (newsym (encapsulation-symbol cap)))
     150    (setf (gethash fn *encapsulation-table*) cap)
     151    (set-encapsulation-owner old-def newsym)
     152    (etypecase owner
     153      (symbol
     154       (cond ((standard-generic-function-p old-def)
     155              (%fhave newsym (%copy-function old-def))
     156              (setf (%gf-dcode old-def) fn))
     157             (t
     158              (%fhave newsym old-def)
     159              (%fhave owner fn))))
     160      (method
     161       (%fhave newsym old-def)
     162       (setf (%method-function owner) fn)
     163       (remove-obsoleted-combined-methods owner)))))
     164
     165(defun remove-encapsulation (cap)
     166  (let* ((owner (encapsulation-owner cap))
     167         (cur-def (%encap-binding owner))
     168         (old-def (encapsulation-old-def cap)))
     169    (assert (eq cap (get-encapsulation cur-def)))
     170    (set-encapsulation-owner old-def owner)
     171    (typecase owner
     172      (symbol
     173       (cond ((standard-generic-function-p cur-def)
     174              (remhash (%gf-dcode cur-def) *encapsulation-table*)
     175              (setf (%gf-dcode cur-def) (%gf-dcode old-def)))
     176             (t
     177              (remhash cur-def *encapsulation-table*)
     178              (%fhave owner old-def))))
     179      (method
     180       (remhash cur-def *encapsulation-table*)
     181       (setf (%method-function owner) old-def)
     182       (remove-obsoleted-combined-methods owner)))))
     183
     184
     185(defun encapsulate (owner newdef type trace-spec newsym &optional advice-name advice-when)
     186  (let ((cap (make-encapsulation
     187              :owner owner
     188              :symbol newsym
     189              :type type
     190              :spec trace-spec
     191              :advice-name advice-name
     192              :advice-when advice-when)))
     193    (put-encapsulation newdef cap)
     194    cap))
     195
     196(defun find-unencapsulated-definition (fn)
     197  (when fn
     198    (loop for cap = (get-encapsulation fn) while cap
     199      do (setq fn (encapsulation-old-def cap)))
     200    fn))
     201
     202(defun set-unencapsulated-definition (cap newdef)
     203  (loop for owner = (encapsulation-symbol cap)
     204    do (setq cap (get-encapsulation owner)) while cap
     205    finally (%fhave owner newdef)))
     206
     207(defun %encapsulation-thing (spec &optional define-if-not (error-p t))
     208  ;; Returns either an fboundp symbol or a method, or nil.
    298209  (typecase spec
    299210    (symbol
    300      (if (or (null spec)(special-operator-p spec)(macro-function spec))
     211     ;; weed out macros and special-forms
     212     (if (or (null spec) (special-operator-p spec) (macro-function spec))
    301213       (if error-p
    302          (error "Cannot trace or advise ~S" spec)
    303          (values nil nil))
    304        (let ((res (or (fboundp spec)(and define-if-not
    305                                          (progn (warn "~S was undefined" spec)
    306                                                 (%fhave spec (%function 'trace-null-def)))))))
    307          (if res
    308            (values res spec)
    309            (if undefined-ok
    310              (values nil spec)
    311              (if error-p
    312                (error "~S is undefined." spec)
    313                (values nil nil)))))))
    314     (method
    315      (values (%method-function spec) spec))
     214         (error "Cannot trace or advise ~a~S" spec
     215                (cond ((null spec) "")
     216                      ((special-operator-p spec) "special operator ")
     217                      (t "macro ")))
     218         nil)
     219       (if (or (fboundp spec)
     220               (and define-if-not
     221                    (progn
     222                      (warn "~S was undefined" spec)
     223                      (%fhave spec (%function 'trace-null-def))
     224                      t)))
     225         spec
     226         (if error-p
     227           (error "~S is undefined." spec)
     228           nil))))
     229    (method spec)
    316230    (cons
    317231     (case (car spec)
    … …  
    326240            (cond ((setq method
    327241                         (find-method-by-names gf qualifiers specializers))
    328                    (return (values (%method-function method) method)))
     242                   (return method))
    329243                  (define-if-not
    330244                    (when (define-undefined-method spec gf qualifiers specializers)
    331245                      (go AGN)))
    332246                  (t (if error-p
    333                        (error "Method ~s qualifiers ~s specializers ~s not found."
    334                               gf qualifiers specializers)
    335                        (return (values nil nil))))))))
     247                       (error "Method ~s qualifiers ~s specializers ~s not found."
     248                              gf qualifiers specializers)
     249                       (return nil)))))))
    336250       (setf
    337251        (let ((name-or-fn (setf-function-spec-name spec)))
    338           (cond ((symbolp name-or-fn)(%trace-function-spec-p name-or-fn))
     252          (cond ((symbolp name-or-fn) (%encapsulation-thing name-or-fn))
    339253                ((functionp name-or-fn) ; it's anonymous - give it a name
    340254                 (let ((newname (gensym)))
    341255                   (%fhave newname name-or-fn)
    342256                   (store-setf-method (cadr spec) newname)
    343                    (values name-or-fn newname))))))))
     257                   newname)))))))
    344258    (t (if error-p
    345          (error "Invalid trace spec ~s" spec)
    346          (values nil nil)))))
    347    
     259         (error "Invalid trace spec ~s" spec)
     260         nil))))
    348261
    349262(defun trace-null-def (&rest ignore)
    … …  
    378291    (when (eq (symbol-package sym) pkg)
    379292      (when (traceable-symbol-p sym)
    380         (apply #'trace-function sym args))
     293        (apply #'trace-function sym args))
    381294      (when (or (%setf-method sym)
    382                 ;; Not really right.  Should construct the name if doesn't exist.
    383                 ;; But that would create a lot of garbage for little gain...
    384                 (let ((name (existing-setf-function-name sym)))
     295                ;; Not really right.  Should construct the name if doesn't exist.
     296                ;; But that would create a lot of garbage for little gain...
     297                (let ((name (existing-setf-function-name sym)))
    385298                  (traceable-symbol-p name)))
    386         (apply #'trace-function `(setf ,sym) args)))))
     299        (apply #'trace-function `(setf ,sym) args)))))
    387300
    388301(defun trace-print-body (print-form)
    … …  
    390303    (if (and (consp print-form) (eq (car print-form) 'values))
    391304      `((mapcar #'(lambda (name object)
    392                     (trace-tab :in)
    393                     (format *trace-output* "~s = ~s" name object))
    394         ',(cdr print-form)
    395         (list ,@(cdr print-form))))
     305                    (trace-tab :in)
     306                    (format *trace-output* "~s = ~s" name object))
     307        ',(cdr print-form)
     308        (list ,@(cdr print-form))))
    396309      `((let ((objects (multiple-value-list ,print-form))
    397               (i -1))
    398           (if (and objects (not (cdr objects)))
    399             (progn
    400               (trace-tab :in)
    401               (format *trace-output* "~s = ~s" ',print-form (car objects)))
    402             (dolist (object objects)
    403               (trace-tab :in)
    404               (format *trace-output* "~s [~d] = ~s" ',print-form (incf i) object))))))))
     310              (i -1))
     311          (if (and objects (not (cdr objects)))
     312            (progn
     313              (trace-tab :in)
     314              (format *trace-output* "~s = ~s" ',print-form (car objects)))
     315            (dolist (object objects)
     316              (trace-tab :in)
     317              (format *trace-output* "~s [~d] = ~s" ',print-form (incf i) object))))))))
    405318
    406319(defun trace-backtrace-body (test-form)
    407320  (when test-form
    408321    `((let ((test ,test-form))
    409         (when test
    410           (multiple-value-bind (detailed-p count)
    411               (cond ((memq test '(:detailed :verbose :full))
    412                      (values t nil))
    413                     ((integerp test)
    414                      (values nil test))
    415                     ((and (consp test)
    416                           (keywordp (car test))
    417                           (consp (cdr test))
    418                           (null (cddr test)))
    419                      (values (memq (car test) '(:detailed :verbose :full))
    420                              (and (integerp (cadr test)) (cadr test))))
    421                     (t (values nil nil)))
    422             (let ((*debug-io* *trace-output*))
    423               (print-call-history :detailed-p detailed-p
    424                                   :count (or count most-positive-fixnum))
    425               (terpri *trace-output*))))))))
     322        (when test
     323          (multiple-value-bind (detailed-p count)
     324              (cond ((memq test '(:detailed :verbose :full))
     325                     (values t nil))
     326                    ((integerp test)
     327                     (values nil test))
     328                    ((and (consp test)
     329                          (keywordp (car test))
     330                          (consp (cdr test))
     331                          (null (cddr test)))
     332                     (values (memq (car test) '(:detailed :verbose :full))
     333                             (and (integerp (cadr test)) (cadr test))))
     334                    (t (values nil nil)))
     335            (let ((*debug-io* *trace-output*))
     336              (print-call-history :detailed-p detailed-p
     337                                  :count (or count most-positive-fixnum))
     338              (terpri *trace-output*))))))))
    426339
    427340(defun trace-inside-frame-p (name)
    … …  
    437350                           (when (and sym (eq (symbol-package sym) name))
    438351                             (return-from trace-inside-frame-p t)))))
    439     (let ((fn (typecase name
    440                 (symbol (fboundp name))
    441                 (method (%method-function name)))))
     352    (let ((fn (%encap-binding name)))
    442353      (when fn
    443354        (map-call-frames #'(lambda (p)
    … …  
    496407  (when break
    497408    (setq break-before (if break-before
    498                         `(and ,break ,break-before)
    499                         break))
     409                        `(and ,break ,break-before)
     410                        break))
    500411    (setq break-after (if break-after
    501                         `(and ,break ,break-after)
    502                         break)))
     412                        `(and ,break ,break-after)
     413                        break)))
    503414  (unless backtrace-before
    504415    (setq backtrace-before backtrace))
    … …  
    526437  (when inside
    527438    (let ((tests (loop for spec in inside
    528                        as name = (or (trace-package-spec spec)
    529                                      (nth-value 1 (%trace-function-spec-p spec nil nil nil))
    530                                      (error "Cannot trace inside ~s" spec))
    531                        collect `(trace-inside-frame-p ',name))))
     439                       as name = (or (trace-package-spec spec)
     440                                     (%encapsulation-thing spec nil nil)
     441                                     (error "Cannot trace inside ~s" spec))
     442                       collect `(trace-inside-frame-p ',name))))
    532443      (setq if `(and ,if (or ,@tests)))))
    533444
    534445  (setq eval-before `(,@(trace-print-body print-before)
    535                       ,@(trace-print-body print)
    536                       ,@(and eval-before `(,eval-before))
    537                       ,@(and eval `(,eval))
    538                       ,@(and before `((apply ,before ',spec args)))
    539                       ,@(trace-backtrace-body backtrace-before)
    540                       ,@(and break-before `((when ,break-before
    541                                               (force-output *trace-output*)
    542                                               (break "~s trace entry: ~s" ',spec args))))))
     446                      ,@(trace-print-body print)
     447                      ,@(and eval-before `(,eval-before))
     448                      ,@(and eval `(,eval))
     449                      ,@(and before `((apply ,before ',spec args)))
     450                      ,@(trace-backtrace-body backtrace-before)
     451                      ,@(and break-before `((when ,break-before
     452                                              (force-output *trace-output*)
     453                                              (break "~s trace entry: ~s" ',spec args))))))
    543454  (setq eval-after `(,@(trace-backtrace-body backtrace-after)
    544                      ,@(and after `((apply ,after ',spec vals)))
    545                      ,@(and eval `(,eval))
    546                      ,@(and eval-after `(,eval-after))
    547                      ,@(trace-print-body print)
    548                      ,@(trace-print-body print-after)
    549                      ,@(and break-after `((when ,break-after
    550                                             (force-output *trace-output*)
    551                                             (break "~s trace exit: ~s" ',spec vals))))))
     455                     ,@(and after `((apply ,after ',spec vals)))
     456                     ,@(and eval `(,eval))
     457                     ,@(and eval-after `(,eval-after))
     458                     ,@(trace-print-body print)
     459                     ,@(trace-print-body print-after)
     460                     ,@(and break-after `((when ,break-after
     461                                            (force-output *trace-output*)
     462                                            (break "~s trace exit: ~s" ',spec vals))))))
    552463
    553464  (prog1
    554465      (block %trace-block
    555         ;;
    556         ;; see if we're a callback
    557         ;;
    558         (when (and (typep spec 'symbol)
    559                    (boundp spec)
    560                    (macptrp (symbol-value spec)))
    561           (let ((len (length %pascal-functions%))
    562                 (sym-name (symbol-name spec)))
    563             (declare (fixnum len))
    564             (dotimes (i len)
    565               (let ((pfe (%svref %pascal-functions% i)))
    566                 (when (and (vectorp pfe)
    567                            (string= sym-name (symbol-name (pfe.sym pfe))))
    568                   (when backtrace
    569                     (if (null before)
    570                       (setq before :print)))
    571                   (setf (pfe.trace-p pfe)
    572                         `(,@(if before `((:before . ,before)))
    573                           ,@(if after `((:after . ,after)))
    574                           ,@(if backtrace `((:backtrace . ,backtrace)))))
    575                   (push spec *trace-pfun-list*)))))
    576           (return-from %trace-block))
    577         ;;
    578         ;; now look for tracible methods.
    579         ;; It's possible, but not likely, that we will be both
    580         ;; a callback and a function or method, if so we trace both.
    581         ;; This isn't possible.
    582         ;; If we're neither, signal an error.
    583         ;;
    584         (multiple-value-bind (def trace-thing)
    585             (%trace-function-spec-p spec define-if-not)
    586           (when (null def)
    587             (return-from trace-function
    588               (warn "Trace does not understand ~S, ignored." spec)))
    589           (when (%traced-p trace-thing)
    590             (%untrace-1 trace-thing)
    591             (setq def (%trace-fboundp trace-thing)))
    592           (when (and methods (typep def 'standard-generic-function))
    593             (dolist (m (%gf-methods def))
    594               (apply #'trace-function m args)))
    595           #+old
    596           (when step               ; just check if has interpreted def
    597             (if (typep def 'standard-generic-function)
    598               (let ((methods (%gf-methods def)))
    599                                         ; should we complain if no methods? naah
    600                 (dolist (m methods) ; stick :step-gf in advice-when slot
    601                   (%trace m :step t)
    602                   (let ((e (function-encapsulation m)))
    603                     (when e (setf (encapsulation-advice-when e) :step-gf))))
    604                                         ; we choose to believe that before and after are intended for the gf
    605                 (if  (or before after)
    606                   (setq step nil)               
    607                   (return-from %trace-block)))
    608               #|(uncompile-for-stepping trace-thing nil t)|#))
    609           (let* ((newsym (gensym "TRACE"))
    610                  (method-p (typep trace-thing 'method))
    611                  (newdef (trace-global-def
    612                           spec newsym if before-if eval-before after-if eval-after method-p)))
    613             (when method-p
    614               (copy-method-function-bits def newdef))
    615             (without-interrupts
    616               (multiple-value-bind (ignore gf-dcode) (encapsulate trace-thing def 'trace spec newsym)
    617                 (declare (ignore ignore))
    618                 (cond (gf-dcode
    619                        (setf (%gf-dcode def)
    620                              (%cons-combined-method def (cons newdef gf-dcode) #'%%call-gf-encapsulation)))
    621                       ((symbolp trace-thing) (%fhave trace-thing newdef))
    622                       ((typep trace-thing 'method)
    623                        (setf (%method-function trace-thing) newdef)
    624                        (remove-obsoleted-combined-methods trace-thing)
    625                        newdef)))))))
     466        ;;
     467        ;; see if we're a callback
     468        ;;
     469        (when (and (typep spec 'symbol)
     470                   (boundp spec)
     471                   (macptrp (symbol-value spec)))
     472          (let ((len (length %pascal-functions%))
     473                (sym-name (symbol-name spec)))
     474            (declare (fixnum len))
     475            (dotimes (i len)
     476              (let ((pfe (%svref %pascal-functions% i)))
     477                (when (and (vectorp pfe)
     478                           (string= sym-name (symbol-name (pfe.sym pfe))))
     479                  (when backtrace
     480                    (if (null before)
     481                      (setq before :print)))
     482                  (setf (pfe.trace-p pfe)
     483                        `(,@(if before `((:before . ,before)))
     484                          ,@(if after `((:after . ,after)))
     485                          ,@(if backtrace `((:backtrace . ,backtrace)))))
     486                  (push spec *trace-pfun-list*)))))
     487          (return-from %trace-block))
     488        ;;
     489        ;; now look for traceable methods.
     490        ;; It's possible, but not likely, that we will be both
     491        ;; a callback and a function or method, if so we trace both.
     492        ;; This isn't possible.
     493        ;; If we're neither, signal an error.
     494        ;;
     495        (let* ((trace-thing (%encapsulation-thing spec define-if-not)) def)
     496          (%untrace-1 trace-thing)
     497          (setq def (%encap-binding trace-thing))
     498          (when (and methods (typep def 'standard-generic-function))
     499            (dolist (m (%gf-methods def))
     500              (apply #'trace-function m args)))
     501          #+old
     502          (when step               ; just check if has interpreted def
     503            (if (typep def 'standard-generic-function)
     504              (let ((methods (%gf-methods def)))
     505                ; should we complain if no methods? naah
     506                (dolist (m methods) ; stick :step-gf in advice-when slot
     507                  (%trace m :step t)
     508                  (let ((e (function-encapsulation m)))
     509                    (when e (setf (encapsulation-advice-when e) :step-gf))))
     510                ; we choose to believe that before and after are intended for the gf
     511                (if  (or before after)
     512                  (setq step nil)               
     513                  (return-from %trace-block)))
     514              #|(uncompile-for-stepping trace-thing nil t)|#))
     515          (let* ((newsym (gensym "TRACE"))
     516                 (method-p (typep trace-thing 'method))
     517                 (newdef (trace-global-def
     518                          spec newsym if before-if eval-before after-if eval-after method-p)))
     519            (when method-p
     520              (copy-method-function-bits def newdef))
     521            (encapsulate trace-thing newdef 'trace spec newsym))))
    626522    (when *trace-hook*
    627523      (apply *trace-hook* spec args))))
    628524
    629525
    630 ;; sym is either a symbol or a method
    631 
    632 (defun %traced-p (sym)
    633   (let ((foo (function-encapsulation sym)))
    634     (and foo (eq (encapsulation-type foo) 'trace))))
     526(defun %traced-p (thing)
     527  (let ((cap (get-encapsulation thing)))
     528    (and cap (eq (encapsulation-type cap) 'trace))))
    635529
    636530(defmacro untrace (&rest syms)
    … …  
    648542    val))
    649543
    650 
    651 (defun %untrace (sym)
     544(defun %untrace-all ()
     545  (dolist (pfun *trace-pfun-list*)
     546    (%untrace pfun)
     547    (when *untrace-hook*
     548      (funcall *untrace-hook* pfun)))
     549  (loop for cap being the hash-value of *encapsulation-table*
     550    when (eq (encapsulation-type cap) 'trace)
     551    collect (let ((spec (encapsulation-spec cap)))
     552              (remove-encapsulation cap)
     553              (when *untrace-hook*
     554                (funcall *untrace-hook* spec))
     555              spec)))
     556
     557(defun %untrace (sym &aux val)
    652558  (when (and (consp sym)(consp (car sym)))
    653559    (setq sym (car sym)))
    654560  (cond
    655     ((and (typep sym 'symbol)
    656         (boundp sym)
    657         (macptrp (symbol-value sym)))
    658      (%untrace-pfun sym))
    659     (t
    660      (multiple-value-bind (def trace-thing) (%trace-function-spec-p sym)
    661        (let (val)
    662          (when (typep def 'standard-generic-function)
    663            (let ((methods (%gf-methods def)))
    664              (dolist (m methods)
    665                (let ((e (function-encapsulation m)))
    666                  (when (and e (eq (encapsulation-advice-when e) :step-gf))
    667                    (remove-encapsulation e)
    668                    (push m  val))))))
    669                                         ; gf could have first been traced :step, and then just plain traced
    670                                         ; maybe the latter trace should undo the stepping??
    671          (when (%traced-p trace-thing)
    672            (%untrace-1 trace-thing)
    673            (push trace-thing val))
    674          (if (null (cdr val))(car val) val)))))
     561   ((and (typep sym 'symbol)
     562         (boundp sym)
     563         (macptrp (symbol-value sym)))
     564    (%untrace-pfun sym))
     565   (t
     566    (let* ((trace-thing (%encapsulation-thing sym))
     567           (def (%encap-binding trace-thing)))
     568      (when (typep def 'standard-generic-function)
     569        (let ((methods (%gf-methods def)))
     570          (dolist (m methods)
     571            (let ((cap (get-encapsulation m)))
     572              (when (and cap (eq (encapsulation-advice-when cap) :step-gf))
     573                (remove-encapsulation cap)
     574                (push m val))))))
     575      ; gf could have first been traced :step, and then just plain traced
     576      ; maybe the latter trace should undo the stepping??
     577      (let ((spec (%untrace-1 trace-thing)))
     578        (when spec
     579          (push spec val))))))
    675580  (when *untrace-hook*
    676     (funcall *untrace-hook* sym)))
    677 
    678 (defun %untrace-all ()
    679   (let ((val nil))
    680     (dolist (cap *trace-alist*)
    681       (push (encapsulation-spec cap) val)
    682        (remove-encapsulation cap)
    683        (when *untrace-hook*
    684        (funcall *untrace-hook* (encapsulation-spec cap))))
    685      (dolist (pfun *trace-pfun-list*)
    686        (%untrace pfun)
    687        (when *untrace-hook*
    688        (funcall *untrace-hook* pfun)))
    689     val))
     581    (funcall *untrace-hook* sym))
     582  (if (null (cdr val)) (car val) val))
    690583
    691584;; thing is a symbol or method - def is current definition
    692585;; we already know its traced
    693586(defun %untrace-1 (thing)
    694   (let (capsule)
    695     (setq capsule (function-encapsulation thing))
    696     ;; trace encapsulations must be first     
    697     (when (neq (encapsulation-type capsule) 'trace)
    698       (error "~S was not traced." thing))
    699     (remove-encapsulation capsule)
    700     (encapsulation-spec capsule)))
     587  (let ((cap (get-encapsulation thing)))
     588    (when (and cap (eq (encapsulation-type cap) 'trace))
     589      (remove-encapsulation cap)
     590      (encapsulation-spec cap))))
    701591
    702592(defun %untrace-pfun (sym)
    703593  (let ((len (length %pascal-functions%))
    704         (sym-name (symbol-name sym)))
     594        (sym-name (symbol-name sym)))
    705595    (declare (fixnum len))
    706596    (dotimes (i len)
    707597      (let ((pfe (%svref %pascal-functions% i)))
    708         (when (and (vectorp pfe)
    709                    (string= sym-name (symbol-name (pfe.sym pfe))))
    710           (setf (pfe.trace-p pfe) nil
    711                 *trace-pfun-list* (remove sym *trace-pfun-list*))
    712           (return-from %untrace-pfun sym))))
     598        (when (and (vectorp pfe)
     599                   (string= sym-name (symbol-name (pfe.sym pfe))))
     600          (setf (pfe.trace-p pfe) nil
     601                *trace-pfun-list* (remove sym *trace-pfun-list*))
     602          (return-from %untrace-pfun sym))))
    713603    nil))
    714604
    … …  
    722612  (if syms
    723613    (let ((options (loop while (keywordp (car syms))
    724                      nconc (list (pop syms) (pop syms)))))
     614                     nconc (list (pop syms) (pop syms)))))
    725615      `(%trace-0 ',syms ',options))
    726616    `(%trace-list)))
    … …  
    739629(defun %trace-list ()
    740630  (let (res)
    741     (dolist (x *trace-alist*)
    742       (push (encapsulation-spec x) res))
     631    (loop for x being the hash-value of *encapsulation-table*
     632         when (eq (encapsulation-type x) 'trace)
     633         do (push (encapsulation-spec x) res))
    743634    (dolist (x *trace-pfun-list*)
    744635      (push x res))
    … …  
    749640(defun trace-global-def (sym def if before-if eval-before after-if eval-after &optional method-p)
    750641  (let ((saved-method-var (gensym))
    751         (enable (gensym))
    752         do-it)
     642        (enable (gensym))
     643        do-it)
    753644    (setq do-it
    754645          (cond #+old (step
    755                        (setq step-it           
    756                              `(step-apply-simple ',def args))
    757                        (if (eq step t)
    758                         step-it
    759                         `(if (apply ',step ',sym args) ; gaak
    760                            ,step-it
    761                            ,(if (and before method-p)
    762                                 `(apply-with-method-context ,saved-method-var (symbol-function ',def) args)
    763                                 `(apply ',def args)))))
     646                       (setq step-it           
     647                             `(step-apply-simple ',def args))
     648                       (if (eq step t)
     649                        step-it
     650                        `(if (apply ',step ',sym args) ; gaak
     651                           ,step-it
     652                           ,(if (and before method-p)
     653                                `(apply-with-method-context ,saved-method-var (symbol-function ',def) args)
     654                                `(apply ',def args)))))
    764655                (t (if (and eval-before method-p)
    765656                     `(apply-with-method-context ,saved-method-var (symbol-function ',def) args)
    … …  
    767658    (compile-named-function-warn
    768659     `(lambda (,@(and eval-before method-p `(&method ,saved-method-var))
    769                &rest args) ; if methodp put &method on front of args - vs get-saved-method-var?
     660               &rest args) ; if methodp put &method on front of args - vs get-saved-method-var?
    770661       (declare (dynamic-extent args))
    771662       (let ((*trace-level* (1+ *trace-level*))
    772              (,enable ,if))
    773         (declare (special *trace-enable* *trace-level*))
    774         ,(when eval-before
    775            `(when (and ,enable ,before-if *trace-enable*)
    776              (when *trace-print-hook*
    777                (funcall *trace-print-hook* ',sym t))
    778              (let* ((*trace-enable* nil))
    779                ,@eval-before)
    780              (when *trace-print-hook*
    781                (funcall *trace-print-hook* ',sym nil))))
    782         ,(if eval-after
    783            `(let ((vals (multiple-value-list ,do-it)))
    784              (when (and ,enable ,after-if *trace-enable*)
    785                (when *trace-print-hook*
    786                 (funcall *trace-print-hook* ',sym t))
    787                (let* ((*trace-enable* nil))
    788                 ,@eval-after)
    789                (when *trace-print-hook*
    790                 (funcall *trace-print-hook* ',sym nil)))
    791              (values-list vals))
    792            do-it)))
     663             (,enable ,if))
     664        (declare (special *trace-enable* *trace-level*))
     665        ,(when eval-before
     666           `(when (and ,enable ,before-if *trace-enable*)
     667             (when *trace-print-hook*
     668               (funcall *trace-print-hook* ',sym t))
     669             (let* ((*trace-enable* nil))
     670               ,@eval-before)
     671             (when *trace-print-hook*
     672               (funcall *trace-print-hook* ',sym nil))))
     673        ,(if eval-after
     674           `(let ((vals (multiple-value-list ,do-it)))
     675             (when (and ,enable ,after-if *trace-enable*)
     676               (when *trace-print-hook*
     677                (funcall *trace-print-hook* ',sym t))
     678               (let* ((*trace-enable* nil))
     679                ,@eval-after)
     680               (when *trace-print-hook*
     681                (funcall *trace-print-hook* ',sym nil)))
     682             (values-list vals))
     683           do-it)))
    793684     `(traced ,sym))))
    794685
    795686; &method var tells compiler to bind var to contents of next-method-context
    796 (defun advise-global-def (function-spec def when stuff &optional method-p)
    797   (declare (ignore function-spec))
     687(defun advise-global-def (def when stuff &optional method-p dynamic-extent-arglist)
    798688  (let* ((saved-method-var (gensym)))
    799689    `(lambda (,@(if (and method-p (neq when :after))
    800690                  `(&method ,saved-method-var))
    801691              &rest arglist)
    802       ;(declare (dynamic-extent arglist))
     692       ,@(and dynamic-extent-arglist '((declare (dynamic-extent arglist))))
    803693       (let ()
    804694         ,(ecase
    … …  
    840730    result))
    841731
    842 ;; want to look like
    843 ;; (setq values (multiple-value-list (progn ,@frob)))
    844      
    845732       
    846 (defun %advised-p (thing &optional when advice-name quick)
    847   ;; thing is a symbol, result is list of encapsulations
    848   ;; Quick when used as a simple predicate
    849   (let ((nx thing) cap val)
    850     (while (setq cap (function-encapsulation nx))
    851       (when (eq (encapsulation-type cap) 'advice)
    852         (if quick (return-from %advised-p cap))
    853         (when (or (and (null when)(null advice-name))
    854                   (and (eq when (encapsulation-advice-when cap))
    855                        (equal advice-name (encapsulation-advice-name cap))))
    856           (push cap val)))
    857       (setq nx (encapsulation-symbol cap)))
    858     val)) 
    859 
     733(defun %advised-p (thing)
     734  (loop for nx = thing then (encapsulation-symbol cap)
     735    as cap = (get-encapsulation nx) while cap
     736    thereis (eq (encapsulation-type cap) 'advice)))
     737
     738(defun %advice-encapsulations (thing when advice-name)
     739  (loop for nx = thing then (encapsulation-symbol cap)
     740    as cap = (get-encapsulation nx) while cap
     741    when (and (eq (encapsulation-type cap) 'advice)
     742              (or (null when) (eq when (encapsulation-advice-when cap)))
     743              (or (null advice-name) (equal advice-name (encapsulation-advice-name cap))))
     744    collect cap))
    860745
    861746(defun advise-2 (newdef newsym method-p function-spec when advice-name define-if-not)     
    862   (let (advise-thing def orig-sym orig-def)
    863     (multiple-value-setq (def advise-thing)
    864       (%trace-function-spec-p function-spec define-if-not))
    865     (when (not def)(error "Advise does not understand ~s." function-spec))
     747  (let* ((advise-thing (%encapsulation-thing function-spec define-if-not))
     748         orig-sym)
     749    (let ((capsules (%advice-encapsulations advise-thing when advice-name)))
     750      (when capsules
     751        (unadvise-capsules capsules)))
    866752    (when (%traced-p advise-thing)
     753      ; make traced call advised
    867754      (setq orig-sym
    868             (encapsulation-symbol (function-encapsulation advise-thing)))
    869       (setq orig-def (fboundp orig-sym)))
    870     (let ((capsules (%advised-p advise-thing when advice-name)))
    871       (when capsules
    872         (unadvise-capsules capsules)
    873         ; get the right def you fool!
    874         (setq def (%trace-function-spec-p function-spec))))
    875     (without-interrupts
    876      (multiple-value-bind (ignore gf-dcode)
    877                           (encapsulate (or orig-sym advise-thing) (or orig-def def)
    878                                        'advice function-spec newsym
    879                                        advice-name when)
    880        (declare (ignore ignore))
    881        (lfun-name newdef `(advised ',function-spec))
    882        (if method-p (copy-method-function-bits def newdef))
    883        (if gf-dcode (setq newdef (%cons-combined-method def (cons newdef gf-dcode)
    884                                                         #'%%call-gf-encapsulation)))                     
    885        (cond (orig-sym
    886               (%fhave orig-sym newdef))  ; make traced call advised
    887              (t  (cond (gf-dcode (setf (%gf-dcode def) newdef))
    888                        ((symbolp advise-thing)
    889                         (%fhave advise-thing newdef))
    890                        ((typep advise-thing 'method)
    891                         (progn
    892                           (setf (%method-function advise-thing) newdef)
    893                           (remove-obsoleted-combined-methods advise-thing)
    894                           newdef)))))))))
    895 
    896 (defmacro advise (function form &key (when :before) name define-if-not)
     755            (encapsulation-symbol (get-encapsulation advise-thing))))
     756    (lfun-name newdef `(advised ',function-spec))
     757    (if method-p (copy-method-function-bits (%encap-binding advise-thing) newdef))
     758    (encapsulate (or orig-sym advise-thing) newdef 'advice function-spec newsym advice-name when)
     759    newdef))
     760
     761(defmacro advise (function form &key (when :before) name define-if-not dynamic-extent-arglist)
    897762  (let* ((newsym (gensym "ADVICE"))
    898763         ; WAS typep advise-thing 'method
    899764         (method-p (or (typep function 'method) ; can this happen?
    900765                       (and (consp function)(eq (car function) :method))))
    901          (newdef (advise-global-def function newsym when form method-p)))
     766         (newdef (advise-global-def newsym when form method-p dynamic-extent-arglist)))
    902767      `(advise-2 ,newdef ',newsym ,method-p ',function ',when ',name
    903768                 ,define-if-not)))
    … …  
    906771  `(advisedp-1 ',function-spec ',when ',name))
    907772
     773(defun encapsulation-advice-spec (cap)
     774  (list (encapsulation-spec cap)
     775        (encapsulation-advice-when cap)
     776        (encapsulation-advice-name cap)))
     777 
    908778(defun advisedp-1 (function-spec when name)
    909   (let (val)
    910     (flet ((xtract-capsule (c)
    911              (list (encapsulation-spec c)
    912                    (encapsulation-advice-when c)
    913                    (encapsulation-advice-name c))))
    914       (cond ((eq t function-spec)
    915              (dolist (c *advise-alist*)
    916                (when (and
    917                       (or (null when)(eq when (encapsulation-advice-when c)))
    918                       (or (null name)(equal name (encapsulation-advice-name c))))
    919                  (push (xtract-capsule c) val))))
    920             (t (let* ((advise-thing (nth-value 1  (%trace-function-spec-p function-spec)))
    921                       (capsules (%advised-p advise-thing when name)))
    922                  (dolist (capsule capsules)
    923                    (push (xtract-capsule capsule) val)))))
    924       val)))               
    925 
    926 
    927 (defun unadvise-1 (function-spec &optional when advice-name ignore)
     779  (cond ((eq t function-spec)
     780         (loop for c being the hash-value of *encapsulation-table*
     781           when (and (eq (encapsulation-type c) 'advice)
     782                     (or (null when)(eq when (encapsulation-advice-when c)))
     783                     (or (null name)(equal name (encapsulation-advice-name c))))
     784           collect (encapsulation-advice-spec c)))
     785        (t (let* ((advise-thing (%encapsulation-thing function-spec))
     786                  (capsules (%advice-encapsulations advise-thing when name)))
     787             (mapcar #'encapsulation-advice-spec capsules)))))
     788
     789(defun %unadvise-1 (function-spec &optional when advice-name ignore)
    928790  (declare (ignore ignore))
    929   (let ((advise-thing (nth-value 1 (%trace-function-spec-p function-spec))))
    930     (let ((capsules (%advised-p advise-thing when advice-name)))
     791  (let ((advise-thing (%encapsulation-thing function-spec)))
     792    (let ((capsules (%advice-encapsulations advise-thing when advice-name)))
    931793      (when capsules (unadvise-capsules capsules)))))
    932794
    … …  
    934796  (let (val)
    935797    (dolist (capsule capsules)
    936         (push (list (encapsulation-spec capsule)
    937                     (encapsulation-advice-when capsule)
    938                     (encapsulation-advice-name capsule))
    939               val)
     798        (push (encapsulation-advice-spec capsule) val)
    940799        (remove-encapsulation capsule))
    941800    val))
    … …  
    943802(defmacro unadvise (function &key when name)
    944803  (cond ((neq function t)
    945          `(unadvise-1 ',function ',when ',name))
     804         `(%unadvise-1 ',function ',when ',name))
    946805        (t '(%unadvise-all))))
    947806
    948807(defun %unadvise-all ()
    949   (unadvise-capsules *advise-alist*))
    950 
    951 (defun %set-unencapsulated-definition (spec newdef)
    952   (let (foo)
    953     (while (setq foo (function-encapsulation spec))
    954       (setq spec (encapsulation-symbol foo)))
    955     (typecase spec
    956       (symbol
    957        (%fhave spec newdef)) ;; or fset ?? 
    958       (method
    959        (setf (%method-function spec) newdef)
    960        (remove-obsoleted-combined-methods spec)
    961        newdef))))
    962 
    963 
    964 ;; return t if we defined it, nil otherwise
    965 
     808  (loop for cap being the hash-value of *encapsulation-table*
     809    when (eq (encapsulation-type cap) 'advice)
     810    collect (progn
     811              (remove-encapsulation cap)
     812              (encapsulation-advice-spec cap))))
     813
     814;; Called from %defun. Return t if we defined it, nil otherwise
    966815(defun %defun-encapsulated-maybe (name newdef)
    967   (let ((def (fboundp name)))
    968     (when (and def (function-encapsulated-p name))
    969       (cond ((or *loading-files* (typep def 'standard-generic-function))
     816  (assert (not (get-encapsulation newdef)))
     817  (let ((old-def (fboundp name)) cap)
     818    (when (and old-def (setq cap (get-encapsulation name)))
     819      (cond ((or (and *loading-files* *loading-removes-encapsulation*)
     820                 ;; redefining a gf as a fn.
     821                 (typep old-def 'standard-generic-function))
    970822             (forget-encapsulations name)
    971823             nil)
    972             (t (%set-unencapsulated-definition name newdef)
     824            (t (set-unencapsulated-definition cap newdef)
    973825               T)))))
    974826
    975 (defun %move-method-encapsulations-maybe (oldmethod newmethod)
    976   ;; deal with method redefinition
    977   (let (cap newdef olddef old-inner-def)
    978     (when (and (setq cap (function-encapsulation oldmethod))
    979                (neq oldmethod newmethod))     
    980       (cond (*loading-files*
    981              (when (%traced-p oldmethod)
    982                (warn "~%... Untracing ~s" (%untrace-1 oldmethod)))
    983              (when (%advised-p oldmethod nil nil t)
    984                (format t "~%... Unadvising ~s" (unadvise-1 oldmethod))))
    985             (t (setq newdef (%method-function newmethod))
    986                (setq olddef (%method-function oldmethod))
    987                (setq old-inner-def (find-unencapsulated-definition oldmethod))
    988                ;; make last encapsulation call new definition           
    989                (%set-unencapsulated-definition oldmethod newdef)
    990                (setf (%method-function newmethod) olddef)
    991                (remove-encapsulation cap t)
    992                (put-encapsulation newmethod cap)
    993                (setf (%method-function oldmethod) old-inner-def)
    994                (advise-set-method-bits newmethod newdef)
    995                )))))
    996 
    997 (defun advise-set-method-bits (spec newdef)
    998   ;; spec is a symbol, function, or method object
    999   (let (foo)
    1000     (while (setq foo (function-encapsulation spec))     
    1001       (let ((def (typecase spec
    1002                    (symbol (fboundp spec))
    1003                    (method (%method-function spec))
    1004                    (t nil))))
    1005         (if def
    1006           (copy-method-function-bits newdef def)
    1007           (error "whats going on here anyway")))
    1008       (setq spec (encapsulation-symbol foo)))))
    1009 
     827;; Called from clos when change dcode
     828(defun %set-encapsulated-gf-dcode (gf new-dcode)
     829  (loop with cap = (get-encapsulation gf)
     830    for gf-copy = (encapsulation-old-def cap)
     831    as cur-dcode = (%gf-dcode gf-copy)
     832    do (setq cap (get-encapsulation cur-dcode))
     833    ;; refresh all the gf copies, in case other info in gf changed
     834    do (%copy-function gf gf-copy)
     835    do (setf (%gf-dcode gf-copy) (if cap cur-dcode new-dcode))
     836    while cap))
     837
     838;; Called from clos when oldmethod is being replaced by newmethod in a gf.
     839(defun %move-method-encapsulations-maybe (oldmethod newmethod &aux cap)
     840  (unless (eq oldmethod newmethod)
     841    (cond ((and *loading-removes-encapsulation* *loading-files*)
     842           (when (%traced-p oldmethod)
     843             (warn "~%... Untracing ~s" (%untrace-1 oldmethod)))
     844           (when (%advised-p oldmethod)
     845             (format t "~%... Unadvising ~s" (%unadvise-1 oldmethod))))
     846          (t (when (setq cap (get-encapsulation oldmethod))
     847               (let* ((old-inner-def (find-unencapsulated-definition oldmethod))
     848                      (newdef (%method-function newmethod))
     849                      (olddef (%method-function oldmethod)))
     850                 ;; make last encapsulation call new definition
     851                 (set-unencapsulated-definition cap newdef)
     852                 (setf (%method-function newmethod) olddef)
     853                 (set-encapsulation-owner olddef newmethod)
     854                 (setf (%method-function oldmethod) old-inner-def)
     855                 (loop
     856                   for def = olddef then (encapsulation-old-def cap)
     857                   for cap = (get-encapsulation def) while cap
     858                   do (copy-method-function-bits newdef def))))))))
    1010859
    1011860#|
    1012         Change History (most recent last):
    1013         2       12/29/94        akh     merge with d13
     861        Change History (most recent last):
     862        2       12/29/94        akh     merge with d13
    1014863|# ;(do not edit past this line!!)
Note: See TracChangeset for help on using the changeset viewer.