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

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

Some changes in support of Slime:

Implement CCL:COMPUTE-APPLICABLE-METHODS-USING-CLASSES

Add a :stream-args argument to CCL:ACCEPT-CONNECTION, for one-time initargs for the stream being created. E.g. (accept-connection listener :stream-args `(:external-format ,external-format-for-this-connection-only))

Add CCL:TEMP-PATHNAME

Bind new var CCL:*TOP-ERROR-FRAME* to the error frame in break loops, to make it available to debugger/break hooks.

Add CCL:*SELECT-INTERACTIVE-PROCESS-HOOK* and call it to select the process to use for handling SIGINT.

Add CCL:*MERGE-COMPILER-WARNINGS* to control whether warnings with the same format string and args but different source locations should be merged.

Export CCL:COMPILER-WARNING, CCL:STYLE-WARNING, CCL:COMPILER-WARNING-FUNCTION-NAME and CCL:COMPILER-WARNING-SOURCE-NOTE.

Create a CCL:COMPILER-WARNING-SOURCE-NOTE even if not otherwise saving source locations, just using the fasl file and toplevel stream position, but taking into account compile-file-original-truename and compiler-file-original-buffer-offset. Get rid of stream-position and file-name slots in compiler warnings.

Export CCL:REPORT-COMPILER-WARNING, and make it accept a :SHORT keyword arg to skip the textual representation of the warning location.

Export CCL:NAME-OF, and make it return the fully qualified name for methods, return object for eql-specializer

Make CCL:FIND-DEFINITION-SOURCES handle xref-entries.

Export CCL:SETF-FUNCTION-SPEC-NAME, make it explicitly ignore the long-form setf method case.

Export the basic inspector API from the inspector package.

Export EQL-SPECIALIZER and SLOT-DEFINITION-DOCUMENTATION from OPENMCL-MOP

Refactor things a bit in backtrace code, define and export an API for examining backtraces:

CCL:MAP-CALL-FRAMES
CCL:FRAME-FUNCTION
CCL:FRAME-SUPPLIED-ARGUMENTS
CCL:FRAME-NAMED-VARIABLES

other misc new exports:

CCL:DEFINITION-TYPE
CCL;CALLER-FUNCTIONS
CCL:SLOT-DEFINITION-DOCUMENTATION
CCL:*SAVE-ARGLIST-INFO*
CCL:NATIVE-TRANSLATED-NAMESTRING
CCL:NATIVE-TO-PATHNAME
CCL:HASH-TABLE-WEAK-P
CCL;PROCESS-SERIAL-NUMBER
CCL:PROCESS-EXHAUSTED-P
CCL:APPLY-IN-FRAME

Other misc tweaks:

Make cbreak-loop use the break message when given a uselessly empty condition.

Use setf-function-name-p more consistently

Make find-applicable-methods handle eql specializers better.

Try to more consistently recognize lists of the form (:method ...) as method names.

Add xref-entry-full-name (which wasn't needed in the end)

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