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

Last change on this file since 12194 was 12194, checked in by gz, 10 years ago

merge r12191 into trunk

  • Property svn:eol-style set to native
  • Property svn:keywords set to Author Date Id Revision
File size: 34.7 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"
225                (cond ((null spec) "")
226                      ((special-operator-p spec) "special operator ")
227                      (t "macro "))
228                spec)
229         nil)
230       (if (or (fboundp spec)
231               (and define-if-not
232                    (progn
233                      (warn "~S was undefined" spec)
234                      (%fhave spec (%function 'trace-null-def))
235                      t)))
236         spec
237         (if error-p
238           (error "~S is undefined." spec)
239           nil))))
240    (method spec)
241    (cons
242     (case (car spec)
243       (:method 
244        (let ((gf (cadr spec))
245              (qualifiers (butlast (cddr spec)))
246              (specializers (car (last (cddr spec))))
247              method)
248          (setq specializers (require-type specializers 'list))
249          (prog ()
250            AGN
251            (cond ((setq method
252                         (find-method-by-names gf qualifiers specializers))
253                   (return method))
254                  (define-if-not
255                    (when (define-undefined-method spec gf qualifiers specializers)
256                      (go AGN)))
257                  (t (if error-p
258                       (error "Method ~s qualifiers ~s specializers ~s not found."
259                              gf qualifiers specializers)
260                       (return nil)))))))
261       (setf
262        (let ((name-or-fn (setf-function-spec-name spec)))
263          (cond ((symbolp name-or-fn) (%encapsulation-thing name-or-fn))
264                ((functionp name-or-fn) ; it's anonymous - give it a name
265                 (let ((newname (gensym)))
266                   (%fhave newname name-or-fn)
267                   (store-setf-method (cadr spec) newname)
268                   newname)))))))
269    (t (if error-p
270         (error "Invalid trace spec ~s" spec)
271         nil))))
272
273(defun trace-null-def (&rest ignore)
274  (declare (ignore ignore)))
275
276(defun define-undefined-method (spec gf qualifiers specializers)
277  (let (vars def)   
278    (flet ((blob (e)
279                 (let ((v (gensym)))
280                   (push v vars)
281                   (list v e))))
282      (declare (dynamic-extent #'blob))
283      (setq def
284            (let ((lambda-list (mapcar #' blob specializers)))
285              (eval
286               `(defmethod ,gf ,@qualifiers (,@lambda-list &rest ignore)
287                  (declare (ignore ignore ,@vars))))))
288      (when def (warn "~S was undefined" spec))
289      def)))
290
291(defun traceable-symbol-p (sym)
292  (and sym
293       (not (special-operator-p sym))
294       (not (macro-function sym))
295       (fboundp sym)))
296
297(defun %trace-package (pkg &rest args)
298  (declare (dynamic-extent args))
299  (do-present-symbols (sym pkg)
300    ;; Don't auto-trace imported symbols, because too often these are imported
301    ;; system functions...
302    (when (eq (symbol-package sym) pkg)
303      (when (traceable-symbol-p sym)
304        (apply #'trace-function sym args))
305      (when (or (%setf-method sym)
306                ;; Not really right.  Should construct the name if doesn't exist.
307                ;; But that would create a lot of garbage for little gain...
308                (let ((name (existing-setf-function-name sym)))
309                  (traceable-symbol-p name)))
310        (apply #'trace-function `(setf ,sym) args)))))
311
312(defun trace-print-body (print-form)
313  (when print-form
314    (if (and (consp print-form) (eq (car print-form) 'values))
315      `((mapcar #'(lambda (name object)
316                    (trace-tab :in)
317                    (format *trace-output* "~s = ~s" name object))
318         ',(cdr print-form)
319         (list ,@(cdr print-form))))
320      `((let ((objects (multiple-value-list ,print-form))
321              (i -1))
322          (if (and objects (not (cdr objects)))
323            (progn
324              (trace-tab :in)
325              (format *trace-output* "~s = ~s" ',print-form (car objects)))
326            (dolist (object objects)
327              (trace-tab :in)
328              (format *trace-output* "~s [~d] = ~s" ',print-form (incf i) object))))))))
329
330(defun trace-backtrace-body (test-form)
331  (when test-form
332    `((let ((test ,test-form))
333        (when test
334          (multiple-value-bind (detailed-p count)
335              (cond ((memq test '(:detailed :verbose :full))
336                     (values t nil))
337                    ((integerp test)
338                     (values nil test))
339                    ((and (consp test)
340                          (keywordp (car test))
341                          (consp (cdr test))
342                          (null (cddr test)))
343                     (values (memq (car test) '(:detailed :verbose :full))
344                             (and (integerp (cadr test)) (cadr test))))
345                    (t (values nil nil)))
346            (let ((*debug-io* *trace-output*))
347              (print-call-history :detailed-p detailed-p
348                                  :count (or count most-positive-fixnum))
349              (terpri *trace-output*))))))))
350
351(defun trace-inside-frame-p (name)
352  (if (packagep name)
353    (map-call-frames #'(lambda (p)
354                         (let* ((fn (cfp-lfun p))
355                                (fname (and fn (function-name fn)))
356                                (sym (typecase fname
357                                       (method (method-name fname))
358                                       (cons (and (setf-function-name-p fname) (cadr fname)))
359                                       (symbol fname)
360                                       (t nil))))
361                           (when (and sym (eq (symbol-package sym) name))
362                             (return-from trace-inside-frame-p t)))))
363    (let ((fn (%encap-binding name)))
364      (when fn
365        (map-call-frames #'(lambda (p)
366                             (when (eq (cfp-lfun p) fn)
367                               (return-from trace-inside-frame-p t))))))))
368
369(defun trace-package-spec (spec)
370  (when (or (stringp spec)
371            (packagep spec)
372            (and (consp spec) (eq (car spec) :package)))
373    (let ((pkg (if (consp spec)
374                 (destructuring-bind (pkg) (cdr spec) pkg)
375                 spec)))
376      (pkg-arg pkg))))
377
378(defun trace-function (spec &rest args &key before after methods
379                            (if t) (before-if t) (after-if t)
380                            print print-before print-after
381                            eval eval-before eval-after
382                            break break-before break-after
383                            backtrace backtrace-before backtrace-after
384                            inside
385                            define-if-not
386                            ;; Some synonyms, just to be nice
387                            (condition t) (if-before t) (if-after t) (wherein nil))
388
389  (declare (dynamic-extent args))
390  (let ((pkg (trace-package-spec spec)))
391    (when pkg
392      (return-from trace-function (apply #'%trace-package pkg args))))
393
394  ;; A little bit of dwim, after all this _is_ an interactive tool...
395  (unless (eq condition t)
396    (setq if (if (eq if t) condition `(and ,if ,condition))))
397  (unless (eq if-before t)
398    (setq before-if (if (eq before-if t) if-before `(and ,before-if ,if-before))))
399  (unless (eq if-after t)
400    (setq after-if (if (eq after-if t) if-after `(and ,after-if ,if-after))))
401  (when (and inside (trace-spec-p inside))
402    (setq inside (list inside)))
403  (when wherein
404    (setq inside (append inside (if (trace-spec-p wherein) (list wherein) wherein))))
405  (case break
406    (:before (setq break-before (or break-before t) break nil))
407    (:after (setq break-after (or break-after t) break nil)))
408  (case backtrace
409    (:before (setq backtrace-before (or backtrace-before t) backtrace nil))
410    (:after (setq backtrace-after (or backtrace-after t) backtrace nil)))
411  (case before
412    (:break (setq before :print break-before t))
413    (:backtrace (setq before :print backtrace-before t)))
414  (case after
415    (:break (setq after :print break-after t))
416    (:backtrace (setq after :print backtrace-after t)))
417
418  (when break
419    (setq break-before (if break-before
420                         `(and ,break ,break-before)
421                         break))
422    (setq break-after (if break-after
423                        `(and ,break ,break-after)
424                        break)))
425  (unless backtrace-before
426    (setq backtrace-before backtrace))
427  (when (and (consp backtrace-before) (keywordp (car backtrace-before)))
428    (setq backtrace-before `',backtrace-before))
429  (when (and (consp backtrace-after) (keywordp (car backtrace-after)))
430    (setq backtrace-after `',backtrace-after))
431
432  (when (and (null before) (null after))
433    (setq before :print)
434    (setq after :print))
435  (when (and (null before) backtrace-before)
436    (setq before :print))
437
438  (case before
439    ((:print :default) (setq before #'trace-before)))
440  (case after
441    ((:print :default) (setq after #'trace-after)))
442
443  (when (or (non-nil-symbol-p before) (functionp before))
444    (setq before `',before))
445  (when (or (non-nil-symbol-p after) (functionp after))
446    (setq after `',after))
447
448  (when inside
449    (let ((tests (loop for spec in inside
450                       as name = (or (trace-package-spec spec)
451                                     (%encapsulation-thing spec nil nil)
452                                     (error "Cannot trace inside ~s" spec))
453                       collect `(trace-inside-frame-p ',name))))
454      (setq if `(and ,if (or ,@tests)))))
455
456  (setq eval-before `(,@(trace-print-body print-before)
457                      ,@(trace-print-body print)
458                      ,@(and eval-before `(,eval-before))
459                      ,@(and eval `(,eval))
460                      ,@(and before `((apply ,before ',spec args)))
461                      ,@(trace-backtrace-body backtrace-before)
462                      ,@(and break-before `((when ,break-before
463                                              (force-output *trace-output*)
464                                              (break "~s trace entry: ~s" ',spec args))))))
465  (setq eval-after `(,@(trace-backtrace-body backtrace-after)
466                     ,@(and after `((apply ,after ',spec vals)))
467                     ,@(and eval `(,eval))
468                     ,@(and eval-after `(,eval-after))
469                     ,@(trace-print-body print)
470                     ,@(trace-print-body print-after)
471                     ,@(and break-after `((when ,break-after
472                                            (force-output *trace-output*)
473                                            (break "~s trace exit: ~s" ',spec vals))))))
474
475  (prog1
476      (block %trace-block
477        ;;
478        ;; see if we're a callback
479        ;;
480        (when (and (typep spec 'symbol)
481                   (boundp spec)
482                   (macptrp (symbol-value spec)))
483          (let ((len (length %pascal-functions%))
484                (sym-name (symbol-name spec)))
485            (declare (fixnum len))
486            (dotimes (i len)
487              (let ((pfe (%svref %pascal-functions% i)))
488                (when (and (vectorp pfe)
489                           (string= sym-name (symbol-name (pfe.sym pfe))))
490                  (when backtrace
491                    (if (null before)
492                      (setq before :print)))
493                  (setf (pfe.trace-p pfe)
494                        `(,@(if before `((:before . ,before)))
495                          ,@(if after `((:after . ,after)))
496                          ,@(if backtrace `((:backtrace . ,backtrace)))))
497                  (push spec *trace-pfun-list*)))))
498          (return-from %trace-block))
499        ;;
500        ;; now look for traceable methods.
501        ;; It's possible, but not likely, that we will be both
502        ;; a callback and a function or method, if so we trace both.
503        ;; This isn't possible.
504        ;; If we're neither, signal an error.
505        ;;
506        (let* ((trace-thing (%encapsulation-thing spec define-if-not)) def)
507          (%untrace-1 trace-thing)
508          (setq def (%encap-binding trace-thing))
509          (when (and methods (typep def 'standard-generic-function))
510            (dolist (m (%gf-methods def))
511              (apply #'trace-function m args)))
512          #+old
513          (when step               ; just check if has interpreted def
514            (if (typep def 'standard-generic-function)
515              (let ((methods (%gf-methods def)))
516                ; should we complain if no methods? naah
517                (dolist (m methods) ; stick :step-gf in advice-when slot
518                  (%trace m :step t)
519                  (let ((e (function-encapsulation m)))
520                    (when e (setf (encapsulation-advice-when e) :step-gf))))
521                ; we choose to believe that before and after are intended for the gf
522                (if  (or before after)
523                  (setq step nil)               
524                  (return-from %trace-block)))
525              #|(uncompile-for-stepping trace-thing nil t)|#))
526          (let* ((newsym (gensym "TRACE"))
527                 (method-p (typep trace-thing 'method))
528                 (newdef (trace-global-def 
529                          spec newsym if before-if eval-before after-if eval-after method-p)))
530            (when method-p
531              (copy-method-function-bits def newdef))
532            (encapsulate trace-thing newdef 'trace spec newsym))))
533    (when *trace-hook*
534      (apply *trace-hook* spec args))))
535
536
537(defun %traced-p (thing)
538  (let ((cap (get-encapsulation thing)))
539    (and cap (eq (encapsulation-type cap) 'trace))))
540
541(defmacro untrace (&rest syms)
542  "Remove tracing from the specified functions. With no args, untrace all
543   functions."
544  (if syms
545    `(%untrace-0 ',syms)
546    `(%untrace-all)))
547
548(defun %untrace-0 (syms)
549  (let (val x)
550    (dolist (symbol syms)
551      (setq x (%untrace symbol))
552      (when x (push x val)))
553    val))
554
555(defun %untrace-all ()
556  (dolist (pfun *trace-pfun-list*)
557    (%untrace pfun)
558    (when *untrace-hook*
559      (funcall *untrace-hook* pfun)))
560  (loop for cap being the hash-value of *encapsulation-table*
561    when (eq (encapsulation-type cap) 'trace)
562    collect (let ((spec (encapsulation-spec cap)))
563              (remove-encapsulation cap)
564              (when *untrace-hook*
565                (funcall *untrace-hook* spec))
566              spec)))
567
568(defun %untrace (sym &aux val)
569  (when (and (consp sym)(consp (car sym)))
570    (setq sym (car sym)))
571  (cond
572   ((and (typep sym 'symbol)
573         (boundp sym)
574         (macptrp (symbol-value sym)))
575    (%untrace-pfun sym))
576   (t 
577    (let* ((trace-thing (%encapsulation-thing sym))
578           (def (%encap-binding trace-thing)))
579      (when (typep def 'standard-generic-function)
580        (let ((methods (%gf-methods def)))
581          (dolist (m methods)
582            (let ((cap (get-encapsulation m)))
583              (when (and cap (eq (encapsulation-advice-when cap) :step-gf))
584                (remove-encapsulation cap)
585                (push m val))))))
586      ; gf could have first been traced :step, and then just plain traced
587      ; maybe the latter trace should undo the stepping??
588      (let ((spec (%untrace-1 trace-thing)))
589        (when spec
590          (push spec val))))))
591  (when *untrace-hook*
592    (funcall *untrace-hook* sym))
593  (if (null (cdr val)) (car val) val))
594
595;; thing is a symbol or method - def is current definition
596;; we already know its traced
597(defun %untrace-1 (thing)
598  (let ((cap (get-encapsulation thing)))
599    (when (and cap (eq (encapsulation-type cap) 'trace))
600      (remove-encapsulation cap)
601      (encapsulation-spec cap))))
602
603(defun %untrace-pfun (sym)
604  (let ((len (length %pascal-functions%))
605        (sym-name (symbol-name sym)))
606    (declare (fixnum len))
607    (dotimes (i len)
608      (let ((pfe (%svref %pascal-functions% i)))
609        (when (and (vectorp pfe)
610                   (string= sym-name (symbol-name (pfe.sym pfe))))
611          (setf (pfe.trace-p pfe) nil
612                *trace-pfun-list* (remove sym *trace-pfun-list*))
613          (return-from %untrace-pfun sym))))
614    nil))
615
616
617
618(defmacro trace (&rest syms)
619  "TRACE {Option Global-Value}* { Name | (Name {Option Value}*) }*
620
621TRACE is a debugging tool that provides information when specified
622functions are called."
623  (if syms
624    (let ((options (loop while (keywordp (car syms))
625                     nconc (list (pop syms) (pop syms)))))
626      `(%trace-0 ',syms ',options))
627    `(%trace-list)))
628
629(defun trace-spec-p (arg)
630  (or (atom arg)
631      (memq (car arg) '(:method setf :package))))
632
633
634(defun %trace-0 (syms &optional global-options)
635  (dolist (spec syms)
636    (if (trace-spec-p spec)
637      (apply #'trace-function spec global-options)
638      (apply #'trace-function (append spec global-options)))))
639
640(defun %trace-list ()
641  (let (res)
642    (loop for x being the hash-value of *encapsulation-table*
643         when (eq (encapsulation-type x) 'trace)
644         do (push (encapsulation-spec x) res))
645    (dolist (x *trace-pfun-list*)
646      (push x res))
647    res))
648
649(defmacro with-traces (syms &body body)
650 `(unwind-protect
651       (progn
652         (let ((*trace-output* (make-broadcast-stream)))
653           ;; if you're tracing ccl internals you'll get trace output as it encapsulates the
654           ;; functions so hide all the trace output while eval'ing the trace form itself.
655           (trace ,@syms))
656         ,@body)
657    (untrace ,@syms)))
658
659;; this week def is the name of an uninterned gensym whose fn-cell is original def
660
661(defun trace-global-def (sym def if before-if eval-before after-if eval-after &optional method-p)
662  (let ((saved-method-var (gensym))
663        (enable (gensym))
664        do-it)
665    (setq do-it
666          (cond #+old (step
667                       (setq step-it           
668                             `(step-apply-simple ',def args))
669                       (if (eq step t)
670                         step-it
671                         `(if (apply ',step ',sym args) ; gaak
672                           ,step-it
673                           ,(if (and before method-p)
674                                `(apply-with-method-context ,saved-method-var (symbol-function ',def) args)
675                                `(apply ',def args)))))
676                (t (if (and eval-before method-p)
677                     `(apply-with-method-context ,saved-method-var (symbol-function ',def) args)
678                     `(apply ',def args)))))
679    (compile-named-function-warn
680     `(lambda (,@(and eval-before method-p `(&method ,saved-method-var))
681               &rest args) ; if methodp put &method on front of args - vs get-saved-method-var?
682       (declare (dynamic-extent args))
683       (declare (ftype function ,def))
684       (let ((*trace-level* (1+ *trace-level*))
685             (,enable ,if))
686         (declare (special *trace-enable* *trace-level*))
687         ,(when eval-before
688           `(when (and ,enable ,before-if *trace-enable*)
689             (when *trace-print-hook*
690               (funcall *trace-print-hook* ',sym t))
691             (let* ((*trace-enable* nil))
692               ,@eval-before)
693             (when *trace-print-hook*
694               (funcall *trace-print-hook* ',sym nil))))
695         ,(if eval-after
696           `(let ((vals (multiple-value-list ,do-it)))
697             (when (and ,enable ,after-if *trace-enable*)
698               (when *trace-print-hook* 
699                 (funcall *trace-print-hook* ',sym t))
700               (let* ((*trace-enable* nil))
701                 ,@eval-after)
702               (when *trace-print-hook* 
703                 (funcall *trace-print-hook* ',sym nil)))
704             (values-list vals))
705           do-it)))
706     `(traced ,sym)
707     :keep-symbols t)))
708
709; &method var tells compiler to bind var to contents of next-method-context
710(defun advise-global-def (def when stuff &optional method-p dynamic-extent-arglist)
711  (let* ((saved-method-var (gensym)))
712    `(lambda (,@(if (and method-p (neq when :after))
713                  `(&method ,saved-method-var))
714              &rest arglist)
715       ,@(and dynamic-extent-arglist '((declare (dynamic-extent arglist))))
716       (declare (ftype function ,def))
717       (let ()
718         ,(ecase
719            when
720            (:before
721             `(block nil
722                ,stuff                 
723                (return ,(if method-p
724                           `(apply-with-method-context ,saved-method-var (symbol-function ',def) arglist)
725                           `(apply ',def arglist)))))
726            (:after         
727             `(block nil
728                (let ((values (multiple-value-list (apply (function ,def) arglist))))
729                  ;(declare (dynamic-extent values))
730                  ,stuff
731                  (return (values-list values)))))
732            (:around
733             ;; stuff is e.g. (+ 5 (:do-it))
734             (if method-p 
735               `(macrolet ((:do-it ()
736                             `(apply-with-method-context ,',saved-method-var 
737                                                         (symbol-function ',',def)
738                                                         arglist)))
739                  (block nil
740                    (return  ,stuff)))
741               `(macrolet ((:do-it ()
742                             `(apply (function ,',def) arglist)))
743                  (block nil
744                    (return  ,stuff))))))))))
745
746
747(defun compile-named-function-warn (fn name &rest keys)
748  (declare (dynamic-extent keys))
749  (multiple-value-bind (result warnings) (apply #'compile-named-function fn :name name keys)
750    (when warnings 
751      (let ((first t))
752        (dolist (w warnings)
753          (signal-compiler-warning w first nil nil nil)
754          (setq first nil))))
755    result))
756
757       
758(defun %advised-p (thing)
759  (loop for nx = thing then (encapsulation-symbol cap)
760    as cap = (get-encapsulation nx) while cap
761    thereis (eq (encapsulation-type cap) 'advice)))
762
763(defun %advice-encapsulations (thing when advice-name)
764  (loop for nx = thing then (encapsulation-symbol cap)
765    as cap = (get-encapsulation nx) while cap
766    when (and (eq (encapsulation-type cap) 'advice)
767              (or (null when) (eq when (encapsulation-advice-when cap)))
768              (or (null advice-name) (equal advice-name (encapsulation-advice-name cap))))
769    collect cap))
770
771(defun advise-2 (newdef newsym method-p function-spec when advice-name define-if-not)     
772  (let* ((advise-thing (%encapsulation-thing function-spec define-if-not))
773         orig-sym)
774    (let ((capsules (%advice-encapsulations advise-thing when advice-name)))
775      (when capsules 
776        (unadvise-capsules capsules)))
777    (when (%traced-p advise-thing)
778      ; make traced call advised
779      (setq orig-sym
780            (encapsulation-symbol (get-encapsulation advise-thing))))
781    (lfun-name newdef `(advised ',function-spec))
782    (if method-p (copy-method-function-bits (%encap-binding advise-thing) newdef))
783    (encapsulate (or orig-sym advise-thing) newdef 'advice function-spec newsym advice-name when)
784    newdef))
785
786(defmacro advise (function form &key (when :before) name define-if-not dynamic-extent-arglist)
787  (let* ((newsym (gensym "ADVICE"))
788         ; WAS typep advise-thing 'method
789         (method-p (or (typep function 'method) ; can this happen?
790                       (and (consp function)(eq (car function) :method))))
791         (newdef (advise-global-def newsym when form method-p dynamic-extent-arglist)))
792      `(advise-2 ,newdef ',newsym ,method-p ',function ',when ',name
793                 ,define-if-not)))
794
795(defmacro advisedp (function-spec &key when name)
796  `(advisedp-1 ',function-spec ',when ',name))
797
798(defun encapsulation-advice-spec (cap)
799  (list (encapsulation-spec cap)
800        (encapsulation-advice-when cap)
801        (encapsulation-advice-name cap)))
802 
803(defun advisedp-1 (function-spec when name)
804  (cond ((eq t function-spec)
805         (loop for c being the hash-value of *encapsulation-table*
806           when (and (eq (encapsulation-type c) 'advice)
807                     (or (null when)(eq when (encapsulation-advice-when c)))
808                     (or (null name)(equal name (encapsulation-advice-name c))))
809           collect (encapsulation-advice-spec c)))
810        (t (let* ((advise-thing (%encapsulation-thing function-spec))
811                  (capsules (%advice-encapsulations advise-thing when name)))
812             (mapcar #'encapsulation-advice-spec capsules)))))
813
814(defun %unadvise-1 (function-spec &optional when advice-name ignore)
815  (declare (ignore ignore))
816  (let ((advise-thing (%encapsulation-thing function-spec)))
817    (let ((capsules (%advice-encapsulations advise-thing when advice-name)))
818      (when capsules (unadvise-capsules capsules)))))
819
820(defun unadvise-capsules (capsules)
821  (let (val)
822    (dolist (capsule capsules)
823        (push (encapsulation-advice-spec capsule) val)
824        (remove-encapsulation capsule))
825    val))
826
827(defmacro unadvise (function &key when name)
828  (cond ((neq function t)
829         `(%unadvise-1 ',function ',when ',name))
830        (t '(%unadvise-all))))
831
832(defun %unadvise-all ()
833  (loop for cap being the hash-value of *encapsulation-table*
834    when (eq (encapsulation-type cap) 'advice)
835    collect (progn
836              (remove-encapsulation cap)
837              (encapsulation-advice-spec cap))))
838
839;; Called from %defun. Return t if we defined it, nil otherwise
840(defun %defun-encapsulated-maybe (name newdef)
841  (assert (not (get-encapsulation newdef)))
842  (let ((old-def (fboundp name)) cap)
843    (when (and old-def (setq cap (get-encapsulation name)))
844      (cond ((or (and *loading-files* *loading-removes-encapsulation*)
845                 ;; redefining a gf as a fn.
846                 (typep old-def 'standard-generic-function))
847             (forget-encapsulations name)
848             nil)
849            (t (set-unencapsulated-definition cap newdef)
850               T)))))
851
852;; Called from clos when change dcode
853(defun %set-encapsulated-gf-dcode (gf new-dcode)
854  (loop with cap = (get-encapsulation gf)
855    for gf-copy = (encapsulation-old-def cap)
856    as cur-dcode = (%gf-dcode gf-copy)
857    do (setq cap (get-encapsulation cur-dcode))
858    ;; refresh all the gf copies, in case other info in gf changed
859    do (%copy-function gf gf-copy)
860    do (setf (%gf-dcode gf-copy) (if cap cur-dcode new-dcode))
861    while cap))
862
863;; Called from clos when oldmethod is being replaced by newmethod in a gf.
864(defun %move-method-encapsulations-maybe (oldmethod newmethod &aux cap)
865  (unless (eq oldmethod newmethod)
866    (cond ((and *loading-removes-encapsulation* *loading-files*)
867           (when (%traced-p oldmethod)
868             (warn "~%... Untracing ~s" (%untrace-1 oldmethod)))
869           (when (%advised-p oldmethod)
870             (format t "~%... Unadvising ~s" (%unadvise-1 oldmethod))))
871          (t (when (setq cap (get-encapsulation oldmethod))
872               (let* ((old-inner-def (find-unencapsulated-definition oldmethod))
873                      (newdef (%method-function newmethod))
874                      (olddef (%method-function oldmethod)))
875                 ;; make last encapsulation call new definition
876                 (set-unencapsulated-definition cap newdef)
877                 (setf (%method-function newmethod) olddef)
878                 (set-encapsulation-owner olddef newmethod)
879                 (setf (%method-function oldmethod) old-inner-def)
880                 (loop
881                   for def = olddef then (encapsulation-old-def cap)
882                   for cap = (get-encapsulation def) while cap
883                   do (copy-method-function-bits newdef def))))))))
884
885#|
886        Change History (most recent last):
887        2       12/29/94        akh     merge with d13
888|# ;(do not edit past this line!!)
Note: See TracBrowser for help on using the repository browser.