Changeset 9844
- Timestamp:
- Jun 27, 2008, 6:28:43 PM (13 years ago)
- Location:
- trunk/source
- Files:
-
- 9 edited
Legend:
- Unmodified
- Added
- Removed
-
trunk/source/level-0/PPC/ppc-def.lisp
r6178 r9844 1233 1233 1234 1234 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 1235 1245 (defun replace-function-code (target-fn proto-fn) 1236 1246 (if (typep target-fn 'function) -
trunk/source/level-0/X86/x86-def.lisp
r8356 r9844 112 112 (declare (fixnum k) (list imms)) 113 113 (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))) 114 131 115 132 (defun replace-function-code (target proto) -
trunk/source/level-0/l0-def.lisp
r6485 r9844 87 87 (%fhave 'encapsulated-function-name ;Redefined in encapsulate - used in l1-io 88 88 (qlfun bootstrapping-encapsulated-function-name (fn) 89 (declare (ignore fn))90 nil))91 92 (%fhave '%traced-p ;Redefined in encapsulate - used in l1-io93 (qlfun bootstrapping-%traced-p (fn)94 (declare (ignore fn))95 nil))96 97 (%fhave '%advised-p ;Redefined in encapsulate used in l1-io98 (qlfun bootstrapping-%advised-p (fn)99 89 (declare (ignore fn)) 100 90 nil)) -
trunk/source/level-1/l1-clos-boot.lisp
r9837 r9844 540 540 ;;;;;;;;;;;;;;;;;;;;;;;;;;; defmethod support ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 541 541 542 (%fhave 'function-encapsulation ;Redefined in encapsulate543 (qlfun bootstrapping-function-encapsulation (name)544 (declare (ignore name))545 nil))546 547 542 (%fhave '%move-method-encapsulations-maybe ; Redefined in encapsulate 548 543 (qlfun boot-%move-method-encapsulations-maybe (m1 m2) … … 550 545 nil)) 551 546 552 553 547 (%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)) 561 555 562 556 (let* ((class-wrapper-random-state (make-random-state)) … … 570 564 571 565 (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)))) 577 569 578 570 (defun copy-method-function-bits (from to) … … 711 703 712 704 713 (defun forget-encapsulations (name)714 (declare (ignore name))715 nil)716 717 705 (defun %anonymous-method (function specializers qualifiers lambda-list &optional documentation 718 706 &aux name method-class) … … 779 767 (setq method-function 780 768 (closure-function 781 (if (function-encapsulation method-function) 782 (find-unencapsulated-definition method-function) 783 method-function))) 769 (find-unencapsulated-definition method-function))) 784 770 (setq method-function (require-type method-function 'method-function)) 785 771 (lfun-name method-function)) … … 1096 1082 multi-method-index) 1097 1083 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) 1104 1087 (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)))) 1119 1093 (values dcode multi-method-index))))) 1120 1094 -
trunk/source/level-1/l1-clos.lisp
r9240 r9844 1440 1440 &key &allow-other-keys) 1441 1441 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)) 1446 1443 1447 1444 (defmethod initialize-instance :after ((gf standard-generic-function) … … 1706 1703 (unless (functionp function) 1707 1704 (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)) 1710 1706 1711 1707 (defmethod reinitialize-instance ((slotd slot-definition) &key &allow-other-keys) … … 2031 2027 (t 2032 2028 #'%%1st-arg-eql-method-hack-dcode))))) 2033 2034 2035 2036 2029 2037 2030 -
trunk/source/level-1/l1-dcode.lisp
r9386 r9844 515 515 (gf.dcode gf)) 516 516 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))) 519 523 520 524 (defun %set-gf-dispatch-table (gf val) 521 525 (setf (gf.dispatch-table gf) val)) 522 523 526 524 527 (defun %combined-method-methods (cm) … … 825 828 (let ((method (%find-1st-arg-combined-method dt (%car args)))) 826 829 (apply method args))))) 827 830 (register-dcode-proto #'%%1st-arg-dcode *gf-proto*) 828 831 829 832 (defun %%one-arg-dcode (dt arg) … … 854 857 (let ((method (%find-nth-arg-combined-method dt (%lexpr-ref args args-len argnum) args))) 855 858 (%apply-lexpr-tail-wise method args))))) 856 859 (register-dcode-proto #'%%nth-arg-dcode *gf-proto*) 857 860 858 861 (defun 0-arg-combined-method-trap (gf) -
trunk/source/level-1/l1-utils.lisp
r8509 r9844 378 378 x) 379 379 380 (%fhave 'find-unencapsulated-definition #'identity)381 382 380 (defun coerce-to-function (arg) 383 381 (if (functionp arg) -
trunk/source/lib/edit-callers.lisp
r4123 r9844 135 135 (pascal-function-p function) 136 136 (let ((name (function-name function))) 137 (and name (function-encapsulat ionname) name))137 (and name (function-encapsulated-p name) name)) 138 138 (let ((caller function) next) 139 139 (loop 140 140 (setq next (gethash caller *function-parent-table*)) 141 (if next 141 (if next 142 142 (cond ((consp next) 143 143 (when (null the-list)(push function the-list)) -
trunk/source/lib/encapsulate.lisp
r9386 r9844 17 17 (in-package "CCL") 18 18 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 25 22 (defvar *trace-pfun-list* nil) 26 23 (defvar *trace-enable* t) … … 35 32 (defvar *trace-print-hook* nil) 36 33 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 ;;; 39 49 40 50 (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)) 42 52 43 53 (defstruct (encapsulation) … … 47 57 advice-name ; optional 48 58 advice-when ; :before, :after, :around 49 owner ; where encapsulation is installed 59 owner ; where encapsulation is installed (can change) 50 60 ) 61 62 (defun encapsulation-old-def (cap) 63 (fboundp (encapsulation-symbol cap))) 51 64 52 65 (defun setf-function-spec-name (spec) … … 56 69 spec)) 57 70 58 59 71 (defun trace-tab (direction &aux (n (min *trace-level* *trace-max-indent*))) 60 72 (fresh-line *trace-output*) … … 62 74 (declare (fixnum i)) 63 75 (write-char (if (and *trace-bar-frequency* 64 65 76 (eq 0 (mod i *trace-bar-frequency*))) 77 #\| #\Space) *trace-output*)) 66 78 (if (eq direction :in) 67 79 (format *trace-output* "~d> " (1- *trace-level*)) … … 98 110 (format t "~%... Untracing ~a" name) 99 111 (%untrace-1 name)) 100 (when (%advised-p name nil nil t)112 (when (%advised-p name) 101 113 (format t "~%... Unadvising ~a" name) 102 ( unadvise-1 name))114 (%unadvise-1 name)) 103 115 nil) 104 116 105 117 (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. 298 209 (typecase spec 299 210 (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)) 301 213 (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) 316 230 (cons 317 231 (case (car spec) … … 326 240 (cond ((setq method 327 241 (find-method-by-names gf qualifiers specializers)) 328 (return (values (%method-function method) method)))242 (return method)) 329 243 (define-if-not 330 244 (when (define-undefined-method spec gf qualifiers specializers) 331 245 (go AGN))) 332 246 (t (if error-p 333 334 335 (return (values nil nil))))))))247 (error "Method ~s qualifiers ~s specializers ~s not found." 248 gf qualifiers specializers) 249 (return nil))))))) 336 250 (setf 337 251 (let ((name-or-fn (setf-function-spec-name spec))) 338 (cond ((symbolp name-or-fn) (%trace-function-spec-pname-or-fn))252 (cond ((symbolp name-or-fn) (%encapsulation-thing name-or-fn)) 339 253 ((functionp name-or-fn) ; it's anonymous - give it a name 340 254 (let ((newname (gensym))) 341 255 (%fhave newname name-or-fn) 342 256 (store-setf-method (cadr spec) newname) 343 (values name-or-fn newname))))))))257 newname))))))) 344 258 (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)))) 348 261 349 262 (defun trace-null-def (&rest ignore) … … 378 291 (when (eq (symbol-package sym) pkg) 379 292 (when (traceable-symbol-p sym) 380 293 (apply #'trace-function sym args)) 381 294 (when (or (%setf-method sym) 382 383 384 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))) 385 298 (traceable-symbol-p name))) 386 299 (apply #'trace-function `(setf ,sym) args))))) 387 300 388 301 (defun trace-print-body (print-form) … … 390 303 (if (and (consp print-form) (eq (car print-form) 'values)) 391 304 `((mapcar #'(lambda (name object) 392 393 394 395 305 (trace-tab :in) 306 (format *trace-output* "~s = ~s" name object)) 307 ',(cdr print-form) 308 (list ,@(cdr print-form)))) 396 309 `((let ((objects (multiple-value-list ,print-form)) 397 398 399 400 401 402 403 404 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)))))))) 405 318 406 319 (defun trace-backtrace-body (test-form) 407 320 (when test-form 408 321 `((let ((test ,test-form)) 409 410 411 412 413 414 415 416 417 418 419 420 421 422 423 424 425 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*)))))))) 426 339 427 340 (defun trace-inside-frame-p (name) … … 437 350 (when (and sym (eq (symbol-package sym) name)) 438 351 (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))) 442 353 (when fn 443 354 (map-call-frames #'(lambda (p) … … 496 407 (when break 497 408 (setq break-before (if break-before 498 499 409 `(and ,break ,break-before) 410 break)) 500 411 (setq break-after (if break-after 501 502 412 `(and ,break ,break-after) 413 break))) 503 414 (unless backtrace-before 504 415 (setq backtrace-before backtrace)) … … 526 437 (when inside 527 438 (let ((tests (loop for spec in inside 528 529 ( nth-value 1 (%trace-function-spec-p spec nil nil nil))530 531 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)))) 532 443 (setq if `(and ,if (or ,@tests))))) 533 444 534 445 (setq eval-before `(,@(trace-print-body print-before) 535 536 537 538 539 540 541 542 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)))))) 543 454 (setq eval-after `(,@(trace-backtrace-body backtrace-after) 544 545 546 547 548 549 550 551 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)))))) 552 463 553 464 (prog1 554 465 (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)))) 626 522 (when *trace-hook* 627 523 (apply *trace-hook* spec args)))) 628 524 629 525 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)))) 635 529 636 530 (defmacro untrace (&rest syms) … … 648 542 val)) 649 543 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) 652 558 (when (and (consp sym)(consp (car sym))) 653 559 (setq sym (car sym))) 654 560 (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)))))) 675 580 (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)) 690 583 691 584 ;; thing is a symbol or method - def is current definition 692 585 ;; we already know its traced 693 586 (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)))) 701 591 702 592 (defun %untrace-pfun (sym) 703 593 (let ((len (length %pascal-functions%)) 704 594 (sym-name (symbol-name sym))) 705 595 (declare (fixnum len)) 706 596 (dotimes (i len) 707 597 (let ((pfe (%svref %pascal-functions% i))) 708 709 710 711 712 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)))) 713 603 nil)) 714 604 … … 722 612 (if syms 723 613 (let ((options (loop while (keywordp (car syms)) 724 614 nconc (list (pop syms) (pop syms))))) 725 615 `(%trace-0 ',syms ',options)) 726 616 `(%trace-list))) … … 739 629 (defun %trace-list () 740 630 (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)) 743 634 (dolist (x *trace-pfun-list*) 744 635 (push x res)) … … 749 640 (defun trace-global-def (sym def if before-if eval-before after-if eval-after &optional method-p) 750 641 (let ((saved-method-var (gensym)) 751 752 642 (enable (gensym)) 643 do-it) 753 644 (setq do-it 754 645 (cond #+old (step 755 756 757 758 759 760 761 762 763 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))))) 764 655 (t (if (and eval-before method-p) 765 656 `(apply-with-method-context ,saved-method-var (symbol-function ',def) args) … … 767 658 (compile-named-function-warn 768 659 `(lambda (,@(and eval-before method-p `(&method ,saved-method-var)) 769 660 &rest args) ; if methodp put &method on front of args - vs get-saved-method-var? 770 661 (declare (dynamic-extent args)) 771 662 (let ((*trace-level* (1+ *trace-level*)) 772 773 774 775 776 777 778 779 780 781 782 783 784 785 786 787 788 789 790 791 792 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))) 793 684 `(traced ,sym)))) 794 685 795 686 ; &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) 798 688 (let* ((saved-method-var (gensym))) 799 689 `(lambda (,@(if (and method-p (neq when :after)) 800 690 `(&method ,saved-method-var)) 801 691 &rest arglist) 802 ;(declare (dynamic-extent arglist))692 ,@(and dynamic-extent-arglist '((declare (dynamic-extent arglist)))) 803 693 (let () 804 694 ,(ecase … … 840 730 result)) 841 731 842 ;; want to look like843 ;; (setq values (multiple-value-list (progn ,@frob)))844 845 732 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)) 860 745 861 746 (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))) 866 752 (when (%traced-p advise-thing) 753 ; make traced call advised 867 754 (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) 897 762 (let* ((newsym (gensym "ADVICE")) 898 763 ; WAS typep advise-thing 'method 899 764 (method-p (or (typep function 'method) ; can this happen? 900 765 (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))) 902 767 `(advise-2 ,newdef ',newsym ,method-p ',function ',when ',name 903 768 ,define-if-not))) … … 906 771 `(advisedp-1 ',function-spec ',when ',name)) 907 772 773 (defun encapsulation-advice-spec (cap) 774 (list (encapsulation-spec cap) 775 (encapsulation-advice-when cap) 776 (encapsulation-advice-name cap))) 777 908 778 (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) 928 790 (declare (ignore ignore)) 929 (let ((advise-thing ( nth-value 1 (%trace-function-spec-p function-spec))))930 (let ((capsules (%advi sed-padvise-thing when advice-name)))791 (let ((advise-thing (%encapsulation-thing function-spec))) 792 (let ((capsules (%advice-encapsulations advise-thing when advice-name))) 931 793 (when capsules (unadvise-capsules capsules))))) 932 794 … … 934 796 (let (val) 935 797 (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) 940 799 (remove-encapsulation capsule)) 941 800 val)) … … 943 802 (defmacro unadvise (function &key when name) 944 803 (cond ((neq function t) 945 `( unadvise-1 ',function ',when ',name))804 `(%unadvise-1 ',function ',when ',name)) 946 805 (t '(%unadvise-all)))) 947 806 948 807 (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 966 815 (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)) 970 822 (forget-encapsulations name) 971 823 nil) 972 (t ( %set-unencapsulated-definition namenewdef)824 (t (set-unencapsulated-definition cap newdef) 973 825 T))))) 974 826 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)))))))) 1010 859 1011 860 #| 1012 1013 2 12/29/94 akhmerge with d13861 Change History (most recent last): 862 2 12/29/94 akh merge with d13 1014 863 |# ;(do not edit past this line!!)
Note: See TracChangeset
for help on using the changeset viewer.