source: trunk/source/lib/encapsulate.lisp @ 9846

Last change on this file since 9846 was 9846, checked in by gz, 12 years ago

Make untrace more tolerant of bindings having changed behind its back

  • Property svn:eol-style set to native
  • Property svn:keywords set to Author Date Id Revision
File size: 34.2 KB
Line 
1;;;-*-Mode: LISP; Package: CCL -*-
2;;;
3;;;   Copyright (C) 1994-2001 Digitool, Inc
4;;;   This file is part of OpenMCL. 
5;;;
6;;;   OpenMCL is licensed under the terms of the Lisp Lesser GNU Public
7;;;   License , known as the LLGPL and distributed with OpenMCL as the
8;;;   file "LICENSE".  The LLGPL consists of a preamble and the LGPL,
9;;;   which is distributed with OpenMCL as the file "LGPL".  Where these
10;;;   conflict, the preamble takes precedence. 
11;;;
12;;;   OpenMCL is referenced in the preamble as the "LIBRARY."
13;;;
14;;;   The LLGPL is also available online at
15;;;   http://opensource.franz.com/preamble.html
16
17(in-package "CCL")
18
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
22(defvar *trace-pfun-list* nil)
23(defvar *trace-enable* t)
24(defvar *trace-level* 0)
25(defparameter *trace-max-indent* 40)
26(defvar *trace-print-level* nil)
27(defvar *trace-print-length* nil)
28;(defparameter *trace-define-if-undefined* nil)
29(defparameter *trace-bar-frequency* nil)
30(defvar *trace-hook* nil)
31(defvar *untrace-hook* nil)
32(defvar *trace-print-hook* nil)
33
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;;;
49
50(defparameter *encapsulation-table*
51  (make-hash-table :test #'eq :rehash-size 2 :size 2 :weak t))
52
53(defstruct (encapsulation)
54  symbol         ; the uninterned name containing original def
55  type           ; trace or advise
56  spec           ; the original function spec
57  advice-name    ; optional
58  advice-when    ; :before, :after, :around
59  owner          ; where encapsulation is installed (can change)
60)
61
62(defun encapsulation-old-def (cap)
63  (fboundp (encapsulation-symbol cap)))
64
65(defun setf-function-spec-name (spec)
66  (if (and (consp spec) (eq (car spec) 'setf))
67    (or (%setf-method (cadr spec)) ; this can be an anonymous function
68        (setf-function-name (cadr spec)))
69    spec))
70
71(defun trace-tab (direction &aux (n (min *trace-level* *trace-max-indent*)))
72  (fresh-line *trace-output*)
73  (dotimes (i (1- n))
74    (declare (fixnum i))
75    (write-char (if (and *trace-bar-frequency* 
76                         (eq 0 (mod i *trace-bar-frequency*)))
77                  #\| #\Space) *trace-output*))
78  (if (eq direction :in)
79    (format *trace-output* "~d> " (1- *trace-level*))
80    (format *trace-output* "<~d " (1- *trace-level*))))
81
82(defun trace-before  (&rest args)
83  (declare (dynamic-extent args))
84  (trace-tab :in)
85  (let* ((*print-level* *trace-print-level*)
86         (*print-length* *trace-print-length*)
87         (*print-readably* nil))
88    (format *trace-output* "Calling ~S ~%" args)
89    (force-output *trace-output*)))
90
91(defun trace-after (sym &rest args &aux (n (length args)))
92  (declare (dynamic-extent args))
93  (let* ((*print-level* *trace-print-level*)
94         (*print-length* *trace-print-length*)
95         (*print-readably* nil))
96    (if (eq n 1)
97      (progn
98        (trace-tab :out)
99        (format *trace-output* "~S returned ~S~%" sym (%car args)))
100      (progn
101        (trace-tab :out)
102        (format *trace-output* "~S returned ~S values :" sym n)
103        (dolist (val args)
104          (trace-tab :out)
105          (format *trace-output* "     ~S" val))))
106    (force-output *trace-output*)))
107
108(defun forget-encapsulations (name)
109  (when (%traced-p name)
110    (format t "~%... Untracing ~a" name) 
111    (%untrace-1 name))
112  (when (%advised-p name)
113    (format t "~%... Unadvising ~a" name) 
114    (%unadvise-1 name))
115  nil)
116
117(defun function-encapsulated-p (fn-or-method)
118  (get-encapsulation fn-or-method))
119
120(defun %encap-fboundp (thing)
121  (etypecase thing
122    (symbol (fboundp thing))
123    (method (%method-function thing))))
124 
125(defun %encap-binding (thing)
126  (require-type (etypecase thing
127                  (symbol (fboundp thing))
128                  (method (%method-function thing)))
129                'function))
130
131(defun get-encapsulation (spec)
132  (let* ((key (typecase spec
133                (symbol (let* ((def (fboundp spec)))
134                          (if (generic-function-p def)
135                            (%gf-dcode def)
136                            def)))
137                (method (%method-function spec))
138                (standard-generic-function (%gf-dcode spec))
139                (function spec)))
140         (cap (gethash key *encapsulation-table*)))
141    #+gz (assert (or (null cap)
142                     (let ((fn (%encap-binding (encapsulation-owner cap))))
143                       (eq (if (standard-generic-function-p fn) (%gf-dcode fn) fn) key))))
144    cap))
145
146(defun set-encapsulation-owner (fn owner)
147  (let ((cap (get-encapsulation fn)))
148    (when cap
149      (setf (encapsulation-owner cap) owner))))
150
151(defun put-encapsulation (fn cap)
152  (let* ((owner (encapsulation-owner cap))
153         (old-def (%encap-binding owner))
154         (newsym (encapsulation-symbol cap)))
155    (setf (gethash fn *encapsulation-table*) cap)
156    (set-encapsulation-owner old-def newsym)
157    (etypecase owner
158      (symbol
159       (cond ((standard-generic-function-p old-def)
160              (%fhave newsym (%copy-function old-def))
161              (setf (%gf-dcode old-def) fn))
162             (t
163              (%fhave newsym old-def)
164              (%fhave owner fn))))
165      (method
166       (%fhave newsym old-def)
167       (setf (%method-function owner) fn)
168       (remove-obsoleted-combined-methods owner)))))
169
170(defun remove-encapsulation (cap)
171  (let* ((owner (encapsulation-owner cap))
172         (cur-def (%encap-fboundp owner))
173         (old-def (encapsulation-old-def cap)))
174    (typecase owner
175      (symbol
176       (cond ((or (null cur-def)
177                  (not (eq cap (get-encapsulation cur-def))))
178              ;; rebound behind our back, oh well.
179              nil)
180             ((standard-generic-function-p cur-def)
181              (remhash (%gf-dcode cur-def) *encapsulation-table*)
182              (set-encapsulation-owner old-def owner)
183              (setf (%gf-dcode cur-def) (%gf-dcode old-def)))
184             (t
185              (remhash cur-def *encapsulation-table*)
186              (set-encapsulation-owner old-def owner)
187              (%fhave owner old-def))))
188      (method
189       (remhash cur-def *encapsulation-table*)
190       (set-encapsulation-owner old-def owner)
191       (setf (%method-function owner) old-def)
192       (remove-obsoleted-combined-methods owner)))))
193
194
195(defun encapsulate (owner newdef type trace-spec newsym &optional advice-name advice-when)
196  (let ((cap (make-encapsulation
197              :owner owner
198              :symbol newsym
199              :type type
200              :spec trace-spec
201              :advice-name advice-name
202              :advice-when advice-when)))
203    (put-encapsulation newdef cap)
204    cap))
205
206(defun find-unencapsulated-definition (fn)
207  (when fn
208    (loop for cap = (get-encapsulation fn) while cap
209      do (setq fn (encapsulation-old-def cap)))
210    fn))
211
212(defun set-unencapsulated-definition (cap newdef)
213  (loop for owner = (encapsulation-symbol cap)
214    do (setq cap (get-encapsulation owner)) while cap
215    finally (%fhave owner newdef)))
216
217(defun %encapsulation-thing (spec &optional define-if-not (error-p t))
218  ;; Returns either an fboundp symbol or a method, or nil.
219  (typecase spec
220    (symbol
221     ;; weed out macros and special-forms
222     (if (or (null spec) (special-operator-p spec) (macro-function spec))
223       (if error-p
224         (error "Cannot trace or advise ~a~S" spec
225                (cond ((null spec) "")
226                      ((special-operator-p spec) "special operator ")
227                      (t "macro ")))
228         nil)
229       (if (or (fboundp spec)
230               (and define-if-not
231                    (progn
232                      (warn "~S was undefined" spec)
233                      (%fhave spec (%function 'trace-null-def))
234                      t)))
235         spec
236         (if error-p
237           (error "~S is undefined." spec)
238           nil))))
239    (method spec)
240    (cons
241     (case (car spec)
242       (:method 
243        (let ((gf (cadr spec))
244              (qualifiers (butlast (cddr spec)))
245              (specializers (car (last (cddr spec))))
246              method)
247          (setq specializers (require-type specializers 'list))
248          (prog ()
249            AGN
250            (cond ((setq method
251                         (find-method-by-names gf qualifiers specializers))
252                   (return method))
253                  (define-if-not
254                    (when (define-undefined-method spec gf qualifiers specializers)
255                      (go AGN)))
256                  (t (if error-p
257                       (error "Method ~s qualifiers ~s specializers ~s not found."
258                              gf qualifiers specializers)
259                       (return nil)))))))
260       (setf
261        (let ((name-or-fn (setf-function-spec-name spec)))
262          (cond ((symbolp name-or-fn) (%encapsulation-thing name-or-fn))
263                ((functionp name-or-fn) ; it's anonymous - give it a name
264                 (let ((newname (gensym)))
265                   (%fhave newname name-or-fn)
266                   (store-setf-method (cadr spec) newname)
267                   newname)))))))
268    (t (if error-p
269         (error "Invalid trace spec ~s" spec)
270         nil))))
271
272(defun trace-null-def (&rest ignore)
273  (declare (ignore ignore)))
274
275(defun define-undefined-method (spec gf qualifiers specializers)
276  (let (vars def)   
277    (flet ((blob (e)
278                 (let ((v (gensym)))
279                   (push v vars)
280                   (list v e))))
281      (declare (dynamic-extent #'blob))
282      (setq def
283            (let ((lambda-list (mapcar #' blob specializers)))
284              (eval
285               `(defmethod ,gf ,@qualifiers (,@lambda-list &rest ignore)
286                  (declare (ignore ignore ,@vars))))))
287      (when def (warn "~S was undefined" spec))
288      def)))
289
290(defun traceable-symbol-p (sym)
291  (and sym
292       (not (special-operator-p sym))
293       (not (macro-function sym))
294       (fboundp sym)))
295
296(defun %trace-package (pkg &rest args)
297  (declare (dynamic-extent args))
298  (do-present-symbols (sym pkg)
299    ;; Don't auto-trace imported symbols, because too often these are imported
300    ;; system functions...
301    (when (eq (symbol-package sym) pkg)
302      (when (traceable-symbol-p sym)
303        (apply #'trace-function sym args))
304      (when (or (%setf-method sym)
305                ;; Not really right.  Should construct the name if doesn't exist.
306                ;; But that would create a lot of garbage for little gain...
307                (let ((name (existing-setf-function-name sym)))
308                  (traceable-symbol-p name)))
309        (apply #'trace-function `(setf ,sym) args)))))
310
311(defun trace-print-body (print-form)
312  (when print-form
313    (if (and (consp print-form) (eq (car print-form) 'values))
314      `((mapcar #'(lambda (name object)
315                    (trace-tab :in)
316                    (format *trace-output* "~s = ~s" name object))
317         ',(cdr print-form)
318         (list ,@(cdr print-form))))
319      `((let ((objects (multiple-value-list ,print-form))
320              (i -1))
321          (if (and objects (not (cdr objects)))
322            (progn
323              (trace-tab :in)
324              (format *trace-output* "~s = ~s" ',print-form (car objects)))
325            (dolist (object objects)
326              (trace-tab :in)
327              (format *trace-output* "~s [~d] = ~s" ',print-form (incf i) object))))))))
328
329(defun trace-backtrace-body (test-form)
330  (when test-form
331    `((let ((test ,test-form))
332        (when test
333          (multiple-value-bind (detailed-p count)
334              (cond ((memq test '(:detailed :verbose :full))
335                     (values t nil))
336                    ((integerp test)
337                     (values nil test))
338                    ((and (consp test)
339                          (keywordp (car test))
340                          (consp (cdr test))
341                          (null (cddr test)))
342                     (values (memq (car test) '(:detailed :verbose :full))
343                             (and (integerp (cadr test)) (cadr test))))
344                    (t (values nil nil)))
345            (let ((*debug-io* *trace-output*))
346              (print-call-history :detailed-p detailed-p
347                                  :count (or count most-positive-fixnum))
348              (terpri *trace-output*))))))))
349
350(defun trace-inside-frame-p (name)
351  (if (packagep name)
352    (map-call-frames #'(lambda (p)
353                         (let* ((fn (cfp-lfun p))
354                                (fname (and fn (function-name fn)))
355                                (sym (typecase fname
356                                       (method (method-name fname))
357                                       (cons (and (setf-function-name-p fname) (cadr fname)))
358                                       (symbol fname)
359                                       (t nil))))
360                           (when (and sym (eq (symbol-package sym) name))
361                             (return-from trace-inside-frame-p t)))))
362    (let ((fn (%encap-binding name)))
363      (when fn
364        (map-call-frames #'(lambda (p)
365                             (when (eq (cfp-lfun p) fn)
366                               (return-from trace-inside-frame-p t))))))))
367
368(defun trace-package-spec (spec)
369  (when (or (stringp spec)
370            (packagep spec)
371            (and (consp spec) (eq (car spec) :package)))
372    (let ((pkg (if (consp spec)
373                 (destructuring-bind (pkg) (cdr spec) pkg)
374                 spec)))
375      (pkg-arg pkg))))
376
377(defun trace-function (spec &rest args &key before after methods
378                            (if t) (before-if t) (after-if t)
379                            print print-before print-after
380                            eval eval-before eval-after
381                            break break-before break-after
382                            backtrace backtrace-before backtrace-after
383                            inside
384                            define-if-not
385                            ;; Some synonyms, just to be nice
386                            (condition t) (if-before t) (if-after t) (wherein nil))
387
388  (declare (dynamic-extent args))
389  (let ((pkg (trace-package-spec spec)))
390    (when pkg
391      (return-from trace-function (apply #'%trace-package pkg args))))
392
393  ;; A little bit of dwim, after all this _is_ an interactive tool...
394  (unless (eq condition t)
395    (setq if (if (eq if t) condition `(and ,if ,condition))))
396  (unless (eq if-before t)
397    (setq before-if (if (eq before-if t) if-before `(and ,before-if ,if-before))))
398  (unless (eq if-after t)
399    (setq after-if (if (eq after-if t) if-after `(and ,after-if ,if-after))))
400  (when (and inside (trace-spec-p inside))
401    (setq inside (list inside)))
402  (when wherein
403    (setq inside (append inside (if (trace-spec-p wherein) (list wherein) wherein))))
404  (case break
405    (:before (setq break-before (or break-before t) break nil))
406    (:after (setq break-after (or break-after t) break nil)))
407  (case backtrace
408    (:before (setq backtrace-before (or backtrace-before t) backtrace nil))
409    (:after (setq backtrace-after (or backtrace-after t) backtrace nil)))
410  (case before
411    (:break (setq before :print break-before t))
412    (:backtrace (setq before :print backtrace-before t)))
413  (case after
414    (:break (setq after :print break-after t))
415    (:backtrace (setq after :print backtrace-after t)))
416
417  (when break
418    (setq break-before (if break-before
419                         `(and ,break ,break-before)
420                         break))
421    (setq break-after (if break-after
422                        `(and ,break ,break-after)
423                        break)))
424  (unless backtrace-before
425    (setq backtrace-before backtrace))
426  (when (and (consp backtrace-before) (keywordp (car backtrace-before)))
427    (setq backtrace-before `',backtrace-before))
428  (when (and (consp backtrace-after) (keywordp (car backtrace-after)))
429    (setq backtrace-after `',backtrace-after))
430
431  (when (and (null before) (null after))
432    (setq before :print)
433    (setq after :print))
434  (when (and (null before) backtrace-before)
435    (setq before :print))
436
437  (case before
438    ((:print :default) (setq before #'trace-before)))
439  (case after
440    ((:print :default) (setq after #'trace-after)))
441
442  (when (or (non-nil-symbol-p before) (functionp before))
443    (setq before `',before))
444  (when (or (non-nil-symbol-p after) (functionp after))
445    (setq after `',after))
446
447  (when inside
448    (let ((tests (loop for spec in inside
449                       as name = (or (trace-package-spec spec)
450                                     (%encapsulation-thing spec nil nil)
451                                     (error "Cannot trace inside ~s" spec))
452                       collect `(trace-inside-frame-p ',name))))
453      (setq if `(and ,if (or ,@tests)))))
454
455  (setq eval-before `(,@(trace-print-body print-before)
456                      ,@(trace-print-body print)
457                      ,@(and eval-before `(,eval-before))
458                      ,@(and eval `(,eval))
459                      ,@(and before `((apply ,before ',spec args)))
460                      ,@(trace-backtrace-body backtrace-before)
461                      ,@(and break-before `((when ,break-before
462                                              (force-output *trace-output*)
463                                              (break "~s trace entry: ~s" ',spec args))))))
464  (setq eval-after `(,@(trace-backtrace-body backtrace-after)
465                     ,@(and after `((apply ,after ',spec vals)))
466                     ,@(and eval `(,eval))
467                     ,@(and eval-after `(,eval-after))
468                     ,@(trace-print-body print)
469                     ,@(trace-print-body print-after)
470                     ,@(and break-after `((when ,break-after
471                                            (force-output *trace-output*)
472                                            (break "~s trace exit: ~s" ',spec vals))))))
473
474  (prog1
475      (block %trace-block
476        ;;
477        ;; see if we're a callback
478        ;;
479        (when (and (typep spec 'symbol)
480                   (boundp spec)
481                   (macptrp (symbol-value spec)))
482          (let ((len (length %pascal-functions%))
483                (sym-name (symbol-name spec)))
484            (declare (fixnum len))
485            (dotimes (i len)
486              (let ((pfe (%svref %pascal-functions% i)))
487                (when (and (vectorp pfe)
488                           (string= sym-name (symbol-name (pfe.sym pfe))))
489                  (when backtrace
490                    (if (null before)
491                      (setq before :print)))
492                  (setf (pfe.trace-p pfe)
493                        `(,@(if before `((:before . ,before)))
494                          ,@(if after `((:after . ,after)))
495                          ,@(if backtrace `((:backtrace . ,backtrace)))))
496                  (push spec *trace-pfun-list*)))))
497          (return-from %trace-block))
498        ;;
499        ;; now look for traceable methods.
500        ;; It's possible, but not likely, that we will be both
501        ;; a callback and a function or method, if so we trace both.
502        ;; This isn't possible.
503        ;; If we're neither, signal an error.
504        ;;
505        (let* ((trace-thing (%encapsulation-thing spec define-if-not)) def)
506          (%untrace-1 trace-thing)
507          (setq def (%encap-binding trace-thing))
508          (when (and methods (typep def 'standard-generic-function))
509            (dolist (m (%gf-methods def))
510              (apply #'trace-function m args)))
511          #+old
512          (when step               ; just check if has interpreted def
513            (if (typep def 'standard-generic-function)
514              (let ((methods (%gf-methods def)))
515                ; should we complain if no methods? naah
516                (dolist (m methods) ; stick :step-gf in advice-when slot
517                  (%trace m :step t)
518                  (let ((e (function-encapsulation m)))
519                    (when e (setf (encapsulation-advice-when e) :step-gf))))
520                ; we choose to believe that before and after are intended for the gf
521                (if  (or before after)
522                  (setq step nil)               
523                  (return-from %trace-block)))
524              #|(uncompile-for-stepping trace-thing nil t)|#))
525          (let* ((newsym (gensym "TRACE"))
526                 (method-p (typep trace-thing 'method))
527                 (newdef (trace-global-def 
528                          spec newsym if before-if eval-before after-if eval-after method-p)))
529            (when method-p
530              (copy-method-function-bits def newdef))
531            (encapsulate trace-thing newdef 'trace spec newsym))))
532    (when *trace-hook*
533      (apply *trace-hook* spec args))))
534
535
536(defun %traced-p (thing)
537  (let ((cap (get-encapsulation thing)))
538    (and cap (eq (encapsulation-type cap) 'trace))))
539
540(defmacro untrace (&rest syms)
541  "Remove tracing from the specified functions. With no args, untrace all
542   functions."
543  (if syms
544    `(%untrace-0 ',syms)
545    `(%untrace-all)))
546
547(defun %untrace-0 (syms)
548  (let (val x)
549    (dolist (symbol syms)
550      (setq x (%untrace symbol))
551      (when x (push x val)))
552    val))
553
554(defun %untrace-all ()
555  (dolist (pfun *trace-pfun-list*)
556    (%untrace pfun)
557    (when *untrace-hook*
558      (funcall *untrace-hook* pfun)))
559  (loop for cap being the hash-value of *encapsulation-table*
560    when (eq (encapsulation-type cap) 'trace)
561    collect (let ((spec (encapsulation-spec cap)))
562              (remove-encapsulation cap)
563              (when *untrace-hook*
564                (funcall *untrace-hook* spec))
565              spec)))
566
567(defun %untrace (sym &aux val)
568  (when (and (consp sym)(consp (car sym)))
569    (setq sym (car sym)))
570  (cond
571   ((and (typep sym 'symbol)
572         (boundp sym)
573         (macptrp (symbol-value sym)))
574    (%untrace-pfun sym))
575   (t 
576    (let* ((trace-thing (%encapsulation-thing sym))
577           (def (%encap-binding trace-thing)))
578      (when (typep def 'standard-generic-function)
579        (let ((methods (%gf-methods def)))
580          (dolist (m methods)
581            (let ((cap (get-encapsulation m)))
582              (when (and cap (eq (encapsulation-advice-when cap) :step-gf))
583                (remove-encapsulation cap)
584                (push m val))))))
585      ; gf could have first been traced :step, and then just plain traced
586      ; maybe the latter trace should undo the stepping??
587      (let ((spec (%untrace-1 trace-thing)))
588        (when spec
589          (push spec val))))))
590  (when *untrace-hook*
591    (funcall *untrace-hook* sym))
592  (if (null (cdr val)) (car val) val))
593
594;; thing is a symbol or method - def is current definition
595;; we already know its traced
596(defun %untrace-1 (thing)
597  (let ((cap (get-encapsulation thing)))
598    (when (and cap (eq (encapsulation-type cap) 'trace))
599      (remove-encapsulation cap)
600      (encapsulation-spec cap))))
601
602(defun %untrace-pfun (sym)
603  (let ((len (length %pascal-functions%))
604        (sym-name (symbol-name sym)))
605    (declare (fixnum len))
606    (dotimes (i len)
607      (let ((pfe (%svref %pascal-functions% i)))
608        (when (and (vectorp pfe)
609                   (string= sym-name (symbol-name (pfe.sym pfe))))
610          (setf (pfe.trace-p pfe) nil
611                *trace-pfun-list* (remove sym *trace-pfun-list*))
612          (return-from %untrace-pfun sym))))
613    nil))
614
615
616
617(defmacro trace (&rest syms)
618  "TRACE {Option Global-Value}* { Name | (Name {Option Value}*) }*
619
620TRACE is a debugging tool that provides information when specified
621functions are called."
622  (if syms
623    (let ((options (loop while (keywordp (car syms))
624                     nconc (list (pop syms) (pop syms)))))
625      `(%trace-0 ',syms ',options))
626    `(%trace-list)))
627
628(defun trace-spec-p (arg)
629  (or (atom arg)
630      (memq (car arg) '(:method setf :package))))
631
632
633(defun %trace-0 (syms &optional global-options)
634  (dolist (spec syms)
635    (if (trace-spec-p spec)
636      (apply #'trace-function spec global-options)
637      (apply #'trace-function (append spec global-options)))))
638
639(defun %trace-list ()
640  (let (res)
641    (loop for x being the hash-value of *encapsulation-table*
642         when (eq (encapsulation-type x) 'trace)
643         do (push (encapsulation-spec x) res))
644    (dolist (x *trace-pfun-list*)
645      (push x res))
646    res))
647
648;; this week def is the name of an uninterned gensym whose fn-cell is original def
649
650(defun trace-global-def (sym def if before-if eval-before after-if eval-after &optional method-p)
651  (let ((saved-method-var (gensym))
652        (enable (gensym))
653        do-it)
654    (setq do-it
655          (cond #+old (step
656                       (setq step-it           
657                             `(step-apply-simple ',def args))
658                       (if (eq step t)
659                         step-it
660                         `(if (apply ',step ',sym args) ; gaak
661                           ,step-it
662                           ,(if (and before method-p)
663                                `(apply-with-method-context ,saved-method-var (symbol-function ',def) args)
664                                `(apply ',def args)))))
665                (t (if (and eval-before method-p)
666                     `(apply-with-method-context ,saved-method-var (symbol-function ',def) args)
667                     `(apply ',def args)))))
668    (compile-named-function-warn
669     `(lambda (,@(and eval-before method-p `(&method ,saved-method-var))
670               &rest args) ; if methodp put &method on front of args - vs get-saved-method-var?
671       (declare (dynamic-extent args))
672       (let ((*trace-level* (1+ *trace-level*))
673             (,enable ,if))
674         (declare (special *trace-enable* *trace-level*))
675         ,(when eval-before
676           `(when (and ,enable ,before-if *trace-enable*)
677             (when *trace-print-hook*
678               (funcall *trace-print-hook* ',sym t))
679             (let* ((*trace-enable* nil))
680               ,@eval-before)
681             (when *trace-print-hook*
682               (funcall *trace-print-hook* ',sym nil))))
683         ,(if eval-after
684           `(let ((vals (multiple-value-list ,do-it)))
685             (when (and ,enable ,after-if *trace-enable*)
686               (when *trace-print-hook* 
687                 (funcall *trace-print-hook* ',sym t))
688               (let* ((*trace-enable* nil))
689                 ,@eval-after)
690               (when *trace-print-hook* 
691                 (funcall *trace-print-hook* ',sym nil)))
692             (values-list vals))
693           do-it)))
694     `(traced ,sym))))
695
696; &method var tells compiler to bind var to contents of next-method-context
697(defun advise-global-def (def when stuff &optional method-p dynamic-extent-arglist)
698  (let* ((saved-method-var (gensym)))
699    `(lambda (,@(if (and method-p (neq when :after))
700                  `(&method ,saved-method-var))
701              &rest arglist)
702       ,@(and dynamic-extent-arglist '((declare (dynamic-extent arglist))))
703       (let ()
704         ,(ecase
705            when
706            (:before
707             `(block nil
708                ,stuff                 
709                (return ,(if method-p
710                           `(apply-with-method-context ,saved-method-var (symbol-function ',def) arglist)
711                           `(apply ',def arglist)))))
712            (:after         
713             `(block nil
714                (let ((values (multiple-value-list (apply (function ,def) arglist))))
715                  ;(declare (dynamic-extent values))
716                  ,stuff
717                  (return (values-list values)))))
718            (:around
719             ;; stuff is e.g. (+ 5 (:do-it))
720             (if method-p 
721               `(macrolet ((:do-it ()
722                             `(apply-with-method-context ,',saved-method-var 
723                                                         (symbol-function ',',def)
724                                                         arglist)))
725                  (block nil
726                    (return  ,stuff)))
727               `(macrolet ((:do-it ()
728                             `(apply (function ,',def) arglist)))
729                  (block nil
730                    (return  ,stuff))))))))))
731
732
733(defun compile-named-function-warn (fn name)
734  (multiple-value-bind (result warnings)(compile-named-function fn name)   
735    (when warnings 
736      (let ((first t))
737        (dolist (w warnings)
738          (signal-compiler-warning w first nil nil nil)
739          (setq first nil))))
740    result))
741
742       
743(defun %advised-p (thing)
744  (loop for nx = thing then (encapsulation-symbol cap)
745    as cap = (get-encapsulation nx) while cap
746    thereis (eq (encapsulation-type cap) 'advice)))
747
748(defun %advice-encapsulations (thing when advice-name)
749  (loop for nx = thing then (encapsulation-symbol cap)
750    as cap = (get-encapsulation nx) while cap
751    when (and (eq (encapsulation-type cap) 'advice)
752              (or (null when) (eq when (encapsulation-advice-when cap)))
753              (or (null advice-name) (equal advice-name (encapsulation-advice-name cap))))
754    collect cap))
755
756(defun advise-2 (newdef newsym method-p function-spec when advice-name define-if-not)     
757  (let* ((advise-thing (%encapsulation-thing function-spec define-if-not))
758         orig-sym)
759    (let ((capsules (%advice-encapsulations advise-thing when advice-name)))
760      (when capsules 
761        (unadvise-capsules capsules)))
762    (when (%traced-p advise-thing)
763      ; make traced call advised
764      (setq orig-sym
765            (encapsulation-symbol (get-encapsulation advise-thing))))
766    (lfun-name newdef `(advised ',function-spec))
767    (if method-p (copy-method-function-bits (%encap-binding advise-thing) newdef))
768    (encapsulate (or orig-sym advise-thing) newdef 'advice function-spec newsym advice-name when)
769    newdef))
770
771(defmacro advise (function form &key (when :before) name define-if-not dynamic-extent-arglist)
772  (let* ((newsym (gensym "ADVICE"))
773         ; WAS typep advise-thing 'method
774         (method-p (or (typep function 'method) ; can this happen?
775                       (and (consp function)(eq (car function) :method))))
776         (newdef (advise-global-def newsym when form method-p dynamic-extent-arglist)))
777      `(advise-2 ,newdef ',newsym ,method-p ',function ',when ',name
778                 ,define-if-not)))
779
780(defmacro advisedp (function-spec &key when name)
781  `(advisedp-1 ',function-spec ',when ',name))
782
783(defun encapsulation-advice-spec (cap)
784  (list (encapsulation-spec cap)
785        (encapsulation-advice-when cap)
786        (encapsulation-advice-name cap)))
787 
788(defun advisedp-1 (function-spec when name)
789  (cond ((eq t function-spec)
790         (loop for c being the hash-value of *encapsulation-table*
791           when (and (eq (encapsulation-type c) 'advice)
792                     (or (null when)(eq when (encapsulation-advice-when c)))
793                     (or (null name)(equal name (encapsulation-advice-name c))))
794           collect (encapsulation-advice-spec c)))
795        (t (let* ((advise-thing (%encapsulation-thing function-spec))
796                  (capsules (%advice-encapsulations advise-thing when name)))
797             (mapcar #'encapsulation-advice-spec capsules)))))
798
799(defun %unadvise-1 (function-spec &optional when advice-name ignore)
800  (declare (ignore ignore))
801  (let ((advise-thing (%encapsulation-thing function-spec)))
802    (let ((capsules (%advice-encapsulations advise-thing when advice-name)))
803      (when capsules (unadvise-capsules capsules)))))
804
805(defun unadvise-capsules (capsules)
806  (let (val)
807    (dolist (capsule capsules)
808        (push (encapsulation-advice-spec capsule) val)
809        (remove-encapsulation capsule))
810    val))
811
812(defmacro unadvise (function &key when name)
813  (cond ((neq function t)
814         `(%unadvise-1 ',function ',when ',name))
815        (t '(%unadvise-all))))
816
817(defun %unadvise-all ()
818  (loop for cap being the hash-value of *encapsulation-table*
819    when (eq (encapsulation-type cap) 'advice)
820    collect (progn
821              (remove-encapsulation cap)
822              (encapsulation-advice-spec cap))))
823
824;; Called from %defun. Return t if we defined it, nil otherwise
825(defun %defun-encapsulated-maybe (name newdef)
826  (assert (not (get-encapsulation newdef)))
827  (let ((old-def (fboundp name)) cap)
828    (when (and old-def (setq cap (get-encapsulation name)))
829      (cond ((or (and *loading-files* *loading-removes-encapsulation*)
830                 ;; redefining a gf as a fn.
831                 (typep old-def 'standard-generic-function))
832             (forget-encapsulations name)
833             nil)
834            (t (set-unencapsulated-definition cap newdef)
835               T)))))
836
837;; Called from clos when change dcode
838(defun %set-encapsulated-gf-dcode (gf new-dcode)
839  (loop with cap = (get-encapsulation gf)
840    for gf-copy = (encapsulation-old-def cap)
841    as cur-dcode = (%gf-dcode gf-copy)
842    do (setq cap (get-encapsulation cur-dcode))
843    ;; refresh all the gf copies, in case other info in gf changed
844    do (%copy-function gf gf-copy)
845    do (setf (%gf-dcode gf-copy) (if cap cur-dcode new-dcode))
846    while cap))
847
848;; Called from clos when oldmethod is being replaced by newmethod in a gf.
849(defun %move-method-encapsulations-maybe (oldmethod newmethod &aux cap)
850  (unless (eq oldmethod newmethod)
851    (cond ((and *loading-removes-encapsulation* *loading-files*)
852           (when (%traced-p oldmethod)
853             (warn "~%... Untracing ~s" (%untrace-1 oldmethod)))
854           (when (%advised-p oldmethod)
855             (format t "~%... Unadvising ~s" (%unadvise-1 oldmethod))))
856          (t (when (setq cap (get-encapsulation oldmethod))
857               (let* ((old-inner-def (find-unencapsulated-definition oldmethod))
858                      (newdef (%method-function newmethod))
859                      (olddef (%method-function oldmethod)))
860                 ;; make last encapsulation call new definition
861                 (set-unencapsulated-definition cap newdef)
862                 (setf (%method-function newmethod) olddef)
863                 (set-encapsulation-owner olddef newmethod)
864                 (setf (%method-function oldmethod) old-inner-def)
865                 (loop
866                   for def = olddef then (encapsulation-old-def cap)
867                   for cap = (get-encapsulation def) while cap
868                   do (copy-method-function-bits newdef def))))))))
869
870#|
871        Change History (most recent last):
872        2       12/29/94        akh     merge with d13
873|# ;(do not edit past this line!!)
Note: See TracBrowser for help on using the repository browser.