source: branches/qres/ccl/lib/encapsulate.lisp @ 14259

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

r13066, r13067 from trunk: copyrights etc

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