source: branches/working-0711/ccl/lib/encapsulate.lisp @ 11101

Last change on this file since 11101 was 11101, checked in by gz, 13 years ago

Another round of changes from the trunk, mostly just mods in internal mechanisms in support of various recent ports.

  • Property svn:eol-style set to native
  • Property svn:keywords set to Author Date Id Revision
File size: 34.6 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       (let ((*trace-level* (1+ *trace-level*))
684             (,enable ,if))
685         (declare (special *trace-enable* *trace-level*))
686         ,(when eval-before
687           `(when (and ,enable ,before-if *trace-enable*)
688             (when *trace-print-hook*
689               (funcall *trace-print-hook* ',sym t))
690             (let* ((*trace-enable* nil))
691               ,@eval-before)
692             (when *trace-print-hook*
693               (funcall *trace-print-hook* ',sym nil))))
694         ,(if eval-after
695           `(let ((vals (multiple-value-list ,do-it)))
696             (when (and ,enable ,after-if *trace-enable*)
697               (when *trace-print-hook* 
698                 (funcall *trace-print-hook* ',sym t))
699               (let* ((*trace-enable* nil))
700                 ,@eval-after)
701               (when *trace-print-hook* 
702                 (funcall *trace-print-hook* ',sym nil)))
703             (values-list vals))
704           do-it)))
705     `(traced ,sym))))
706
707; &method var tells compiler to bind var to contents of next-method-context
708(defun advise-global-def (def when stuff &optional method-p dynamic-extent-arglist)
709  (let* ((saved-method-var (gensym)))
710    `(lambda (,@(if (and method-p (neq when :after))
711                  `(&method ,saved-method-var))
712              &rest arglist)
713       ,@(and dynamic-extent-arglist '((declare (dynamic-extent arglist))))
714       (let ()
715         ,(ecase
716            when
717            (:before
718             `(block nil
719                ,stuff                 
720                (return ,(if method-p
721                           `(apply-with-method-context ,saved-method-var (symbol-function ',def) arglist)
722                           `(apply ',def arglist)))))
723            (:after         
724             `(block nil
725                (let ((values (multiple-value-list (apply (function ,def) arglist))))
726                  ;(declare (dynamic-extent values))
727                  ,stuff
728                  (return (values-list values)))))
729            (:around
730             ;; stuff is e.g. (+ 5 (:do-it))
731             (if method-p 
732               `(macrolet ((:do-it ()
733                             `(apply-with-method-context ,',saved-method-var 
734                                                         (symbol-function ',',def)
735                                                         arglist)))
736                  (block nil
737                    (return  ,stuff)))
738               `(macrolet ((:do-it ()
739                             `(apply (function ,',def) arglist)))
740                  (block nil
741                    (return  ,stuff))))))))))
742
743
744(defun compile-named-function-warn (fn name)
745  (multiple-value-bind (result warnings) (compile-named-function fn :name name)
746    (when warnings 
747      (let ((first t))
748        (dolist (w warnings)
749          (signal-compiler-warning w first nil nil nil)
750          (setq first nil))))
751    result))
752
753       
754(defun %advised-p (thing)
755  (loop for nx = thing then (encapsulation-symbol cap)
756    as cap = (get-encapsulation nx) while cap
757    thereis (eq (encapsulation-type cap) 'advice)))
758
759(defun %advice-encapsulations (thing when advice-name)
760  (loop for nx = thing then (encapsulation-symbol cap)
761    as cap = (get-encapsulation nx) while cap
762    when (and (eq (encapsulation-type cap) 'advice)
763              (or (null when) (eq when (encapsulation-advice-when cap)))
764              (or (null advice-name) (equal advice-name (encapsulation-advice-name cap))))
765    collect cap))
766
767(defun advise-2 (newdef newsym method-p function-spec when advice-name define-if-not)     
768  (let* ((advise-thing (%encapsulation-thing function-spec define-if-not))
769         orig-sym)
770    (let ((capsules (%advice-encapsulations advise-thing when advice-name)))
771      (when capsules 
772        (unadvise-capsules capsules)))
773    (when (%traced-p advise-thing)
774      ; make traced call advised
775      (setq orig-sym
776            (encapsulation-symbol (get-encapsulation advise-thing))))
777    (lfun-name newdef `(advised ',function-spec))
778    (if method-p (copy-method-function-bits (%encap-binding advise-thing) newdef))
779    (encapsulate (or orig-sym advise-thing) newdef 'advice function-spec newsym advice-name when)
780    newdef))
781
782(defmacro advise (function form &key (when :before) name define-if-not dynamic-extent-arglist)
783  (let* ((newsym (gensym "ADVICE"))
784         ; WAS typep advise-thing 'method
785         (method-p (or (typep function 'method) ; can this happen?
786                       (and (consp function)(eq (car function) :method))))
787         (newdef (advise-global-def newsym when form method-p dynamic-extent-arglist)))
788      `(advise-2 ,newdef ',newsym ,method-p ',function ',when ',name
789                 ,define-if-not)))
790
791(defmacro advisedp (function-spec &key when name)
792  `(advisedp-1 ',function-spec ',when ',name))
793
794(defun encapsulation-advice-spec (cap)
795  (list (encapsulation-spec cap)
796        (encapsulation-advice-when cap)
797        (encapsulation-advice-name cap)))
798 
799(defun advisedp-1 (function-spec when name)
800  (cond ((eq t function-spec)
801         (loop for c being the hash-value of *encapsulation-table*
802           when (and (eq (encapsulation-type c) 'advice)
803                     (or (null when)(eq when (encapsulation-advice-when c)))
804                     (or (null name)(equal name (encapsulation-advice-name c))))
805           collect (encapsulation-advice-spec c)))
806        (t (let* ((advise-thing (%encapsulation-thing function-spec))
807                  (capsules (%advice-encapsulations advise-thing when name)))
808             (mapcar #'encapsulation-advice-spec capsules)))))
809
810(defun %unadvise-1 (function-spec &optional when advice-name ignore)
811  (declare (ignore ignore))
812  (let ((advise-thing (%encapsulation-thing function-spec)))
813    (let ((capsules (%advice-encapsulations advise-thing when advice-name)))
814      (when capsules (unadvise-capsules capsules)))))
815
816(defun unadvise-capsules (capsules)
817  (let (val)
818    (dolist (capsule capsules)
819        (push (encapsulation-advice-spec capsule) val)
820        (remove-encapsulation capsule))
821    val))
822
823(defmacro unadvise (function &key when name)
824  (cond ((neq function t)
825         `(%unadvise-1 ',function ',when ',name))
826        (t '(%unadvise-all))))
827
828(defun %unadvise-all ()
829  (loop for cap being the hash-value of *encapsulation-table*
830    when (eq (encapsulation-type cap) 'advice)
831    collect (progn
832              (remove-encapsulation cap)
833              (encapsulation-advice-spec cap))))
834
835;; Called from %defun. Return t if we defined it, nil otherwise
836(defun %defun-encapsulated-maybe (name newdef)
837  (assert (not (get-encapsulation newdef)))
838  (let ((old-def (fboundp name)) cap)
839    (when (and old-def (setq cap (get-encapsulation name)))
840      (cond ((or (and *loading-files* *loading-removes-encapsulation*)
841                 ;; redefining a gf as a fn.
842                 (typep old-def 'standard-generic-function))
843             (forget-encapsulations name)
844             nil)
845            (t (set-unencapsulated-definition cap newdef)
846               T)))))
847
848;; Called from clos when change dcode
849(defun %set-encapsulated-gf-dcode (gf new-dcode)
850  (loop with cap = (get-encapsulation gf)
851    for gf-copy = (encapsulation-old-def cap)
852    as cur-dcode = (%gf-dcode gf-copy)
853    do (setq cap (get-encapsulation cur-dcode))
854    ;; refresh all the gf copies, in case other info in gf changed
855    do (%copy-function gf gf-copy)
856    do (setf (%gf-dcode gf-copy) (if cap cur-dcode new-dcode))
857    while cap))
858
859;; Called from clos when oldmethod is being replaced by newmethod in a gf.
860(defun %move-method-encapsulations-maybe (oldmethod newmethod &aux cap)
861  (unless (eq oldmethod newmethod)
862    (cond ((and *loading-removes-encapsulation* *loading-files*)
863           (when (%traced-p oldmethod)
864             (warn "~%... Untracing ~s" (%untrace-1 oldmethod)))
865           (when (%advised-p oldmethod)
866             (format t "~%... Unadvising ~s" (%unadvise-1 oldmethod))))
867          (t (when (setq cap (get-encapsulation oldmethod))
868               (let* ((old-inner-def (find-unencapsulated-definition oldmethod))
869                      (newdef (%method-function newmethod))
870                      (olddef (%method-function oldmethod)))
871                 ;; make last encapsulation call new definition
872                 (set-unencapsulated-definition cap newdef)
873                 (setf (%method-function newmethod) olddef)
874                 (set-encapsulation-owner olddef newmethod)
875                 (setf (%method-function oldmethod) old-inner-def)
876                 (loop
877                   for def = olddef then (encapsulation-old-def cap)
878                   for cap = (get-encapsulation def) while cap
879                   do (copy-method-function-bits newdef def))))))))
880
881#|
882        Change History (most recent last):
883        2       12/29/94        akh     merge with d13
884|# ;(do not edit past this line!!)
Note: See TracBrowser for help on using the repository browser.