Changeset 8775


Ignore:
Timestamp:
Mar 13, 2008, 3:52:04 PM (11 years ago)
Author:
gz
Message:

Propagate TRACE extensions from r8742 to trunk. Add doc as well.

Location:
trunk/source
Files:
4 edited

Legend:

Unmodified
Added
Removed
  • trunk/source/doc/src/using.xml

    r8751 r8775  
    3434
    3535    <para>
    36       <command><varname>TRACE</varname> {<replaceable>spec</replaceable> |
    37         (<replaceable>spec</replaceable> {<replaceable>option-key</replaceable>
    38         <replaceable>value</replaceable>}*)}* [Macro]</command>
    39     </para>
    40 
    41     <para>
    42       The <varname>trace</varname> macro encapsulates the function named by
    43       <replaceable>spec</replaceable>, causing trace actions to take place on entry and exit from the
    44       function.  The default actions print a message on function entry and exit.
     36    <command><varname>TRACE</varname> {<replaceable>keyword</replaceable>
     37    <replaceable>global-value</replaceable>}* {<replaceable>spec</replaceable> |
     38    (<replaceable>spec</replaceable> {<replaceable>keyword</replaceable>
     39    <replaceable>local-value</replaceable>}*)}* [Macro]</command>
     40    </para>
     41
     42    <para>
     43      The <varname>trace</varname> macro encapsulates the functions named by
     44      <replaceable>spec</replaceable>s, causing trace actions to take place on entry and
     45      exit from each function.  The default actions print a message on function entry and
     46      exit. <replaceable>Keyword</replaceable>/<replaceable>value</replaceable> options
     47      can be used to specify changes in the default behavior.
    4548    </para>
    4649
     
    5356      expression of the form <varname>(setf <replaceable>symbol</replaceable>)</varname>, or a
    5457      specific method of a generic function in the form <varname>(:method
    55         <replaceable>gf-name</replaceable> {<replaceable>qualifier</replaceable>}* (
    56         {<replaceable>specializer</replaceable>}* ) )</varname>, where a
     58      <replaceable>gf-name</replaceable> {<replaceable>qualifier</replaceable>}*
     59      ({<replaceable>specializer</replaceable>}*))</varname>, where a
    5760      <replaceable>specializer</replaceable> can be the name of a class or an <varname>EQL</varname>
    5861      specializer.
    5962    </para>
    6063
    61     <para>By default, whenever a traced function is entered or exited, a short message is printed
    62       on <varname>*trace-output*</varname> showing the arguments on entry and values on exit.
    63       The following <replaceable>option-keys</replaceable> can be used to modify this behavior:</para>
     64    <para>
     65      A <replaceable>spec</replaceable> can also be a string naming a package, or equivalently a
     66      list <varname>(:package <replaceable>package-name</replaceable>)</varname>, in order to
     67      request that all functions in the package to be traced.
     68    </para>
     69
     70    <para>
     71      By default, whenever a traced function is entered or exited, a short message is
     72      printed on <varname>*trace-output*</varname> showing the arguments on entry and
     73      values on exit.  Options specified as key/value pairs can be used to modify this
     74      behavior.  Options preceding the function <replaceable>spec</replaceable>s apply to
     75      all the functions being traced.  Options specified along with a
     76      <replaceable>spec</replaceable> apply to that spec only and override any
     77      global options. The following options are supported:
     78    </para>
    6479
    6580    <variablelist>
    66       <varlistentry>
    67         <term><varname>:before</varname></term>
     81
     82      <varlistentry>
     83        <term><varname>:methods {T | nil}</varname></term>
     84        <listitem>
     85          <para> If true, and if applied to a <replaceable>spec</replaceable> naming a generic
     86          function, arranges to trace all the methods of the generic function in addition to the
     87          generic function itself.
     88          </para>
     89        </listitem>
     90      </varlistentry>
     91
     92      <varlistentry>
     93        <term><varname>:if <replaceable>form</replaceable></varname></term>
     94        <term><varname>:condition <replaceable>form</replaceable></varname></term>
     95        <listitem>
     96          <para> Evaluates <replaceable>form</replaceable> whenever the function being traced is
     97          about to be entered, and inhibits all trace actions if <replaceable>form</replaceable>
     98          returns nil. The form may reference the lexical variable <varname>ccl::args</varname>,
     99          which is a list of the arguments in this call. <varname>:condition</varname> is just a
     100          synonym for <varname>:if</varname>, though if both are specified, both must return non-nil.
     101          </para>
     102        </listitem>
     103      </varlistentry>
     104
     105      <varlistentry>
     106        <term><varname>:before-if <replaceable>form</replaceable></varname></term>
     107        <listitem>
     108          <para> Evaluates <replaceable>form</replaceable> whenever the function being traced is
     109          about to be entered, and inhibits the entry trace actions if
     110          <replaceable>form</replaceable> returns nil.  The form may reference the lexical variable
     111          <varname>ccl::args</varname>, which is a list of the arguments in this call. If both
     112          <varname>:if</varname> and <varname>:before-if</varname> are specified, both must return
     113          non-nil in order for the before entry actions to happen.
     114          </para>
     115        </listitem>
     116      </varlistentry>
     117
     118      <varlistentry>
     119        <term><varname>:after-if <replaceable>form</replaceable></varname></term>
     120        <listitem>
     121          <para> Evaluates <replaceable>form</replaceable> whenever the function being traced has
     122          just exited, and inhibits the exit trace actions if <replaceable>form</replaceable>
     123          returns nil.  The form may reference the lexical variable <varname>ccl::vals</varname>,
     124          which is a list of values returned by this call. If both <varname>:if</varname> and
     125          <varname>:after-if</varname> are specified, both must return non-nil in order for the
     126          after exit actions to happen.
     127          </para>
     128        </listitem>
     129      </varlistentry>
     130
     131      <varlistentry>
     132        <term><varname>:print-before <replaceable>form</replaceable></varname></term>
     133        <listitem>
     134          <para> Evaluates <replaceable>form</replaceable> whenever the function being traced is
     135          about to be entered, and prints the result before printing the standard entry message.
     136          The form may reference the lexical variable <varname>ccl::args</varname>, which is a list
     137          of the arguments in this call.  To see multiple forms, use <varname>values</varname>:
     138          <varname>:print-before (values (one-thing) (another-thing))</varname>.
     139          </para>
     140        </listitem>
     141      </varlistentry>
     142
     143      <varlistentry>
     144        <term><varname>:print-after <replaceable>form</replaceable></varname></term>
     145        <listitem>
     146          <para> Evaluates <replaceable>form</replaceable> whenever the function being traced has
     147          just exited, and prints the result after printing the standard exit message.  The form may
     148          reference the lexical variable <varname>ccl::vals</varname>, which is a list of values
     149          returned by this call. To see multiple forms, use <varname>values</varname>:
     150          <varname>:print-after (values (one-thing) (another-thing))</varname>.
     151          </para>
     152        </listitem>
     153      </varlistentry>
     154
     155      <varlistentry>
     156        <term><varname>:print <replaceable>form</replaceable></varname></term>
     157        <listitem>
     158          <para>Equivalent to <varname>:print-before <replaceable>form</replaceable> :print-after <replaceable>form</replaceable></varname>.
     159          </para>
     160        </listitem>
     161      </varlistentry>
     162
     163      <varlistentry>
     164        <term><varname>:eval-before <replaceable>form</replaceable></varname></term>
     165        <listitem>
     166          <para>Evaluates <replaceable>form</replaceable> whenever the function being traced is
     167          about to be entered.  The form may reference the lexical variable
     168          <varname>ccl::args</varname>, which is a list of the arguments in this call.
     169          </para>
     170        </listitem>
     171      </varlistentry>
     172
     173      <varlistentry>
     174        <term><varname>:eval-after <replaceable>form</replaceable></varname></term>
     175        <listitem>
     176          <para>Evaluates <replaceable>form</replaceable> whenever the function being has just
     177          exited.  The form may reference the lexical variable <varname>ccl::vals</varname>, which
     178          is a list of values returned by this call.
     179          </para>
     180        </listitem>
     181      </varlistentry>
     182
     183      <varlistentry>
     184        <term><varname>:eval <replaceable>form</replaceable></varname></term>
     185        <listitem>
     186          <para>Equivalent to <varname>:eval-before <replaceable>form</replaceable>
     187          :eval-after <replaceable>form</replaceable></varname>.
     188          </para>
     189        </listitem>
     190      </varlistentry>
     191
     192      <varlistentry>
     193        <term><varname>:break-before <replaceable>form</replaceable></varname></term>
     194        <listitem>
     195          <para>Evaluates <replaceable>form</replaceable> whenever the function being traced is
     196          about to be entered, and if the result is non-nil, enters a debugger break loop.  The form
     197          may reference the lexical variable <varname>ccl::args</varname>, which is a list of the
     198          arguments in this call.
     199          </para>
     200        </listitem>
     201      </varlistentry>
     202
     203      <varlistentry>
     204        <term><varname>:break-after <replaceable>form</replaceable></varname></term>
     205        <listitem>
     206          <para>Evaluates <replaceable>form</replaceable> whenever the function being traced has
     207          just exited, and if the result is non-nil, enters a debugger break loop. The form may
     208          reference the lexical variable <varname>ccl::vals</varname>, which is a list of values
     209          returned by this call.
     210          </para>
     211        </listitem>
     212      </varlistentry>
     213
     214      <varlistentry>
     215        <term><varname>:break <replaceable>form</replaceable></varname></term>
     216        <listitem>
     217          <para>Equivalent to <varname>:break-before <replaceable>form</replaceable> :break-after <replaceable>form</replaceable></varname>.
     218          </para>
     219        </listitem>
     220      </varlistentry>
     221
     222      <varlistentry>
     223        <term><varname>:backtrace-before <replaceable>form</replaceable></varname></term>
     224        <term><varname>:backtrace <replaceable>form</replaceable></varname></term>
     225        <listitem>
     226          <para>Evaluates <replaceable>form</replaceable> whenever the function being traced is
     227          about to be entered.  The form may reference the lexical variable
     228          <varname>ccl::args</varname>, which is a list of the arguments in this call. The value
     229          returned by <replaceable>form</replaceable> is intepreted as follows:
     230          </para>
     231
     232          <variablelist>
     233
     234            <varlistentry>
     235              <term><varname>nil</varname></term>
     236              <listitem><para>does nothing</para></listitem>
     237            </varlistentry>
     238
     239            <varlistentry>
     240              <term><varname>:detailed</varname></term>
     241              <listitem><para>prints a detailed backtrace to
     242              <varname>*trace-output*</varname>.</para></listitem>
     243            </varlistentry>
     244
     245            <varlistentry>
     246              <term><varname>(:detailed <replaceable>integer</replaceable>)</varname></term>
     247              <listitem><para>prints the top <replaceable>integer</replaceable> frames of detailed
     248              backtrace to <varname>*trace-output*</varname>.
     249              </para></listitem>
     250            </varlistentry>
     251
     252            <varlistentry>
     253              <term><replaceable>integer</replaceable></term>
     254              <listitem><para>prints top <replaceable>integer</replaceable> frames of a terse
     255              backtrace to <varname>*trace-output*</varname>.
     256              </para></listitem>
     257            </varlistentry>
     258
     259            <varlistentry>
     260              <term>anything else</term>
     261              <listitem><para>prints a terse backtrace to <varname>*trace-output*</varname>.
     262              </para></listitem>
     263            </varlistentry>
     264          </variablelist>
     265          <para>
     266            Note that unlike with the other options, <varname>:backtrace</varname> is equivalent to
     267            <varname>:backtrace-before</varname> only, not both before and after, since it's usually
     268            not helpful to print the same backtrace both before and after the function call.
     269          </para>
     270        </listitem>
     271      </varlistentry>
     272
     273      <varlistentry>
     274        <term><varname>:backtrace-after <replaceable>form</replaceable></varname></term>
     275        <listitem>
     276          <para>Evaluates <replaceable>form</replaceable> whenever the function being traced has
     277          just exited.  The form may reference the lexical variable <varname>ccl::vals</varname>,
     278          which is a list of values returned by this call. The value returned by
     279          <replaceable>form</replaceable> is intepreted as follows:
     280          </para>
     281
     282          <variablelist>
     283
     284            <varlistentry>
     285              <term><varname>nil</varname></term>
     286              <listitem><para>does nothing</para></listitem>
     287            </varlistentry>
     288
     289            <varlistentry>
     290              <term><varname>:detailed</varname></term>
     291              <listitem><para>prints a detailed backtrace to
     292              <varname>*trace-output*</varname>.</para></listitem>
     293            </varlistentry>
     294
     295            <varlistentry>
     296              <term><varname>(:detailed <replaceable>integer</replaceable>)</varname></term>
     297              <listitem><para>prints the top <replaceable>integer</replaceable> frames of detailed
     298              backtrace to <varname>*trace-output*</varname>.
     299              </para></listitem>
     300            </varlistentry>
     301
     302            <varlistentry>
     303              <term><replaceable>integer</replaceable></term>
     304              <listitem><para>prints top <replaceable>integer</replaceable> frames of a terse
     305              backtrace to <varname>*trace-output*</varname>.
     306              </para></listitem>
     307            </varlistentry>
     308
     309            <varlistentry>
     310              <term>anything else</term>
     311              <listitem><para>prints a terse backtrace to <varname>*trace-output*</varname>.
     312              </para></listitem>
     313            </varlistentry>
     314          </variablelist>
     315        </listitem>
     316      </varlistentry>
     317
     318      <varlistentry>
     319       <term><varname>:before</varname> <replaceable>action</replaceable></term>
     320       <listitem>
     321          <para>specifies the action to be taken just before the traced function is entered.  <replaceable>action</replaceable> is one of:</para>
     322
     323          <variablelist>
     324            <varlistentry>
     325              <term><varname>:print</varname></term>
     326              <listitem>
     327                <para>The default, prints a short indented message showing the function name and the invocation arguments</para>
     328              </listitem>
     329            </varlistentry>
     330
     331            <varlistentry>
     332              <term><varname>:break</varname></term>
     333              <listitem>
     334                <para>Equivalent to <varname>:before :print :break-before t</varname></para>
     335              </listitem>
     336            </varlistentry>
     337
     338            <varlistentry>
     339              <term><varname>:backtrace</varname></term>
     340              <listitem>
     341                <para>Equivalent to <varname>:before :print :backtrace-before t</varname></para>
     342              </listitem>
     343            </varlistentry>
     344
     345
     346            <varlistentry>
     347              <term><replaceable>function</replaceable></term>
     348              <listitem>
     349                <para>
     350                  Any other value is interpreted as a function to call on entry instead of
     351                  printing the standard entry message.  It is called with its first
     352                  argument being the name of the function being traced, the remaining
     353                  arguments being all the arguments to the function being traced, and
     354                  <varname>ccl:*trace-level*</varname> bound to the current nesting level
     355                  of trace actions. </para>
     356              </listitem>
     357            </varlistentry>
     358          </variablelist>
     359        </listitem>
     360      </varlistentry>
     361
     362      <varlistentry>
     363
     364        <term><varname>:after</varname> <replaceable>action</replaceable></term>
    68365        <listitem>
    69               <para>specifies the action to be taken just before the traced function is entered.  The
    70                 value is one of:</para>
    71               <variablelist>
    72                 <varlistentry>
    73                   <term><varname>:print</varname></term>
    74                   <listitem>
    75                     <para>The default, prints a short indented message showing the function name and the invocation arguments </para>
    76                   </listitem>
    77                 </varlistentry>
    78                 <varlistentry>
    79                   <term><varname>:break</varname></term>
    80                   <listitem>
    81                     <para>Enters the debugger after printing the standard function entry message</para>
    82                   </listitem>
    83                 </varlistentry>
    84                 <varlistentry>
    85                   <term><replaceable>function</replaceable></term>
    86                   <listitem>
    87                     <para>Any other value is interpreted as a function to
    88                       call on entry instead of printing the standard entry
    89                       message.  It is called with its first argument being
    90                       the name of the function being traced, the
    91                       remaining arguments being all the arguments to the function
    92                       being traced, and ccl:*trace-level* bound to the current
    93                       nesting level of trace actions.
    94                     </para>
    95                   </listitem>
    96                 </varlistentry>
    97               </variablelist>
    98         </listitem>
    99       </varlistentry>
    100 
    101       <varlistentry>
    102         <term><varname>:after</varname></term>
    103         <listitem>
    104               <para>specifies the action to be taken just after the traced function exits.  The
    105                 value is one of:</para>
     366
     367              <para>specifies the action to be taken just after the traced function exits.  <replaceable>action</replaceable> is one of:</para>
     368
    106369              <variablelist>
    107370                <varlistentry>
     
    112375                  </listitem>
    113376                </varlistentry>
     377
    114378                <varlistentry>
    115379                  <term><varname>:break</varname></term>
    116380                  <listitem>
    117                     <para>Enters the debugger after printing the standard function exit message</para>
     381                    <para>Equivalent to <varname>:after :print :break-after t</varname></para>
    118382                  </listitem>
    119383                </varlistentry>
     384
     385                <varlistentry>
     386                  <term><varname>:backtrace</varname></term>
     387                  <listitem>
     388                    <para>Equivalent to <varname>:after :print :backtrace-after t</varname></para>
     389                  </listitem>
     390                </varlistentry>
     391
    120392                <varlistentry>
    121393                  <term><replaceable>function</replaceable></term>
     
    135407      </varlistentry>
    136408
    137 
    138       <varlistentry>
    139         <term><varname>:backtrace</varname></term>
    140         <listitem>
    141               <para>If true, requests that a stack backtrace (in brief format) be printed whenever the function is
    142                 invoked. The value can be an integer, in which case it is the maximum number of frames to
    143                 print. Otherwise, all frames are shown.
    144               </para>
    145         </listitem>
    146       </varlistentry>
    147 
    148409    </variablelist>
     410
     411
     412    <para>
     413    <command><varname>CCL:*TRACE-LEVEL*</varname> [Variable]</command>
     414    </para>
     415
     416    <para>Variable bound to the current nesting level during execution of before and after trace actions.</para>
     417
     418    <para>
     419      <command><varname>CCL:TRACE-FUNCTION</varname> <replaceable>spec</replaceable> &key; {<replaceable>keyword</replaceable> <replaceable>value</replaceable>}*  [Function]</command>
     420    </para>
     421     
     422    <para>
     423      This is a functional version of the TRACE macro.  <replaceable>spec</replaceable> and
     424      <replaceable>keyword</replaceable>s are as for TRACE, except that all arguments are evaluated.
     425    </para>
     426
    149427  </sect1>
    150428
  • trunk/source/level-1/l1-aprims.lisp

    r8429 r8775  
    243243                 (gethash sym %setf-function-names%) setf-package-sym)))))
    244244
     245(defun existing-setf-function-name (sym)
     246  (gethash sym %setf-function-names%))
    245247
    246248(defun maybe-setf-name (sym)
  • trunk/source/lib/ccl-export-syms.lisp

    r8603 r8775  
    6262     *trace-print-length*
    6363     *trace-bar-frequency*
     64     trace-function
    6465     *ignore-extra-close-parenthesis*
    6566     advise
  • trunk/source/lib/encapsulate.lisp

    r6499 r8775  
    356356      def)))
    357357
    358 (defun %trace (sym &key before after backtrace step define-if-not) 
    359   (let (def newdef trace-thing)
    360     (prog1
     358(defun %trace-package (pkg &rest args)
     359  (declare (dynamic-extent args))
     360  (setq pkg (pkg-arg pkg))
     361  (do-present-symbols (sym pkg)
     362    ;; Don't auto-trace imported symbols, because too often these are imported
     363    ;; system functions...
     364    (when (eq (symbol-package sym) pkg)
     365      (unless (or (null sym)
     366                  (special-operator-p sym)
     367                  (macro-function sym)
     368                  (not (fboundp sym)))
     369        (apply #'trace-function sym args))
     370      (when (or (%setf-method sym)
     371                ;; Not really right.  Should construct the name and check if fboundp.
     372                ;; But that would create a lot of garbage for little gain...
     373                (existing-setf-function-name sym))
     374        (apply #'trace-function `(setf ,sym) args)))))
     375
     376(defun trace-print-body (print-form)
     377  (when print-form
     378    (if (and (consp print-form) (eq (car print-form) 'values))
     379      `((mapcar #'(lambda (name object)
     380                    (trace-tab :in)
     381                    (format *trace-output* "~s = ~s" name object))
     382         ',(cdr print-form)
     383         (list ,@(cdr print-form))))
     384      `((let ((objects (multiple-value-list ,print-form))
     385              (i -1))
     386          (if (and objects (not (cdr objects)))
     387            (progn
     388              (trace-tab :in)
     389              (format *trace-output* "~s = ~s" ',print-form (car objects)))
     390            (dolist (object objects)
     391              (trace-tab :in)
     392              (format *trace-output* "~s [~d] = ~s" ',print-form (incf i) object))))))))
     393
     394(defun trace-backtrace-body (test-form)
     395  (when test-form
     396    `((let ((test ,test-form))
     397        (when test
     398          (multiple-value-bind (detailed-p count)
     399              (cond ((memq test '(:detailed :verbose :full))
     400                     (values t nil))
     401                    ((integerp test)
     402                     (values nil test))
     403                    ((and (consp test)
     404                          (keywordp (car test))
     405                          (consp (cdr test))
     406                          (null (cddr test)))
     407                     (values (memq (car test) '(:detailed :verbose :full))
     408                             (and (integerp (cadr test)) (cadr test))))
     409                    (t (values nil nil)))
     410            (let ((*debug-io* *trace-output*))
     411              (print-call-history :detailed-p detailed-p
     412                                  :count (or count most-positive-fixnum))
     413              (terpri *trace-output*))))))))
     414
     415(defun trace-function (sym &rest args &key before after methods
     416                           (if t) (before-if t) (after-if t)
     417                           print print-before print-after
     418                           eval eval-before eval-after
     419                           break break-before break-after
     420                           backtrace backtrace-before backtrace-after
     421                           define-if-not
     422                           ;; Some synonyms, just to be nice
     423                           (condition t) (if-before t) (if-after t))
     424
     425  (declare (dynamic-extent args))
     426  (when (or (stringp sym)
     427            (packagep sym)
     428            (and (consp sym) (eq (car sym) :package)))
     429    (return-from trace-function
     430      (apply #'%trace-package
     431             (if (consp sym)
     432               (destructuring-bind (pkg) (cdr sym) pkg)
     433               sym)
     434             args)))
     435
     436  ;; A little bit of dwim, after all this _is_ an interactive tool...
     437  (unless (eq condition t)
     438    (setq if (if (eq if t) condition `(and ,if ,condition))))
     439  (unless (eq if-before t)
     440    (setq before-if (if (eq before-if t) if-before `(and ,before-if ,if-before))))
     441  (unless (eq if-after t)
     442    (setq after-if (if (eq after-if t) if-after `(and ,after-if ,if-after))))
     443  (case break
     444    (:before (setq break-before (or break-before t) break nil))
     445    (:after (setq break-after (or break-after t) break nil)))
     446  (case backtrace
     447    (:before (setq backtrace-before (or backtrace-before t) backtrace nil))
     448    (:after (setq backtrace-after (or backtrace-after t) backtrace nil)))
     449  (case before
     450    (:break (setq before :print break-before t))
     451    (:backtrace (setq before :print backtrace-before t)))
     452  (case after
     453    (:break (setq after :print break-after t))
     454    (:backtrace (setq after :print backtrace-after t)))
     455
     456  (when break
     457    (setq break-before (if break-before
     458                         `(and ,break ,break-before)
     459                         break))
     460    (setq break-after (if break-after
     461                        `(and ,break ,break-after)
     462                        break)))
     463  (unless backtrace-before
     464    (setq backtrace-before backtrace))
     465  (when (and (consp backtrace-before) (keywordp (car backtrace-before)))
     466    (setq backtrace-before `',backtrace-before))
     467  (when (and (consp backtrace-after) (keywordp (car backtrace-after)))
     468    (setq backtrace-after `',backtrace-after))
     469
     470  (when (and (null before) (null after))
     471    (setq before :print)
     472    (setq after :print))
     473  (when (and (null before) backtrace-before)
     474    (setq before :print))
     475
     476  (case before
     477    ((:print :default) (setq before #'trace-before)))
     478  (case after
     479    ((:print :default) (setq after #'trace-after)))
     480
     481  (when (or (non-nil-symbol-p before) (functionp before))
     482    (setq before `',before))
     483  (when (or (non-nil-symbol-p after) (functionp after))
     484    (setq after `',after))
     485
     486  (setq eval-before `(,@(trace-print-body print-before)
     487                      ,@(trace-print-body print)
     488                      ,@(and eval-before `(,eval-before))
     489                      ,@(and eval `(,eval))
     490                      ,@(and before `((apply ,before ',sym args)))
     491                      ,@(trace-backtrace-body backtrace-before)
     492                      ,@(and break-before `((when ,break-before
     493                                              (force-output *trace-output*)
     494                                              (break "~s trace entry: ~s" ',sym args))))))
     495  (setq eval-after `(,@(trace-backtrace-body backtrace-after)
     496                     ,@(and after `((apply ,after ',sym vals)))
     497                     ,@(and eval `(,eval))
     498                     ,@(and eval-after `(,eval-after))
     499                     ,@(trace-print-body print)
     500                     ,@(trace-print-body print-after)
     501                     ,@(and break-after `((when ,break-after
     502                                            (force-output *trace-output*)
     503                                            (break "~s trace exit: ~s" ',sym vals))))))
     504
     505  (prog1
    361506      (block %trace-block
    362507        ;;
    363508        ;; see if we're a callback
    364509        ;;
    365         (cond
    366          ((and (typep sym 'symbol)
    367                (boundp sym)
    368                (macptrp (symbol-value sym)))
     510        (when (and (typep sym 'symbol)
     511                   (boundp sym)
     512                   (macptrp (symbol-value sym)))
    369513          (let ((len (length %pascal-functions%))
    370514                (sym-name (symbol-name sym)))
     
    376520                  (when backtrace
    377521                    (if (null before)
    378                         (setq before :print)))
     522                      (setq before :print)))
    379523                  (setf (pfe.trace-p pfe)
    380524                        `(,@(if before `((:before . ,before)))
    381525                          ,@(if after `((:after . ,after)))
    382526                          ,@(if backtrace `((:backtrace . ,backtrace)))))
    383                   (push sym *trace-pfun-list*))))))
    384 
    385          ;;
    386          ;; now look for tracible methods.
    387          ;; It's possible, but not likely, that we will be both
    388          ;; a callback and a function or method, if so we trace both.
    389          ;; This isn't possible.
    390          ;; If we're neither, signal an error.
    391          ;;
    392          ((multiple-value-setq (def trace-thing)
    393             (%trace-function-spec-p sym define-if-not))
    394           (if def
    395               (let ()
    396                 (when (%traced-p trace-thing)
    397                   (%untrace-1 trace-thing)
    398                   (setq def (%trace-fboundp trace-thing)))
    399                 (when step         ; just check if has interpreted def
    400                   (if (typep def 'standard-generic-function)
    401                       (let ((methods (%gf-methods def)))
     527                  (push sym *trace-pfun-list*)))))
     528          (return-from %trace-block))
     529        ;;
     530        ;; now look for tracible methods.
     531        ;; It's possible, but not likely, that we will be both
     532        ;; a callback and a function or method, if so we trace both.
     533        ;; This isn't possible.
     534        ;; If we're neither, signal an error.
     535        ;;
     536        (multiple-value-bind (def trace-thing)
     537            (%trace-function-spec-p sym define-if-not)
     538          (when (null def)
     539            (return-from trace-function
     540              (warn "Trace does not understand ~S, ignored." sym)))
     541          (when (%traced-p trace-thing)
     542            (%untrace-1 trace-thing)
     543            (setq def (%trace-fboundp trace-thing)))
     544          (when (and methods (typep def 'standard-generic-function))
     545            (dolist (m (%gf-methods def))
     546              (apply #'trace-function m args)))
     547          #+old
     548          (when step               ; just check if has interpreted def
     549            (if (typep def 'standard-generic-function)
     550              (let ((methods (%gf-methods def)))
    402551                                        ; should we complain if no methods? naah
    403                         (dolist (m methods) ; stick :step-gf in advice-when slot
    404                           (%trace m :step t)
    405                           (let ((e (function-encapsulation m)))
    406                             (when e (setf (encapsulation-advice-when e) :step-gf))))
     552                (dolist (m methods) ; stick :step-gf in advice-when slot
     553                  (%trace m :step t)
     554                  (let ((e (function-encapsulation m)))
     555                    (when e (setf (encapsulation-advice-when e) :step-gf))))
    407556                                        ; we choose to believe that before and after are intended for the gf
    408                         (if  (or before after)
    409                             (setq step nil)               
    410                           (return-from %trace-block)))
    411                     #|(uncompile-for-stepping trace-thing nil t)|#))
    412                 (let ((newsym (gensym "TRACE"))
    413                       (method-p (typep trace-thing 'method)))
    414                   (when (and (null before)(null after)(null step))
    415                     (setq before #'trace-before)
    416                     (setq after #'trace-after))
    417                   (case before
    418                     (:print     (setq before #'trace-before)))
    419                   (case after
    420                     (:print (setq after #'trace-after)))
    421                   (when backtrace
    422                     (when (null before)
    423                       (setq before #'trace-before))
    424                     (cond
    425                      ((functionp before)
    426                       (let ((bfun before))
    427                         (if (integerp backtrace)
    428                             (setq before #'(lambda (&rest args)
    429                                              (apply bfun args)
    430                                              (let ((*debug-io* *trace-output*))
    431                                                (ccl::print-call-history :detailed-p nil :count backtrace)
    432                                                (terpri *trace-output*))))
    433                           (setq before #'(lambda (&rest args)
    434                                            (apply bfun args)
    435                                            (let ((*debug-io* *trace-output*))
    436                                              (ccl::print-call-history :detailed-p nil)
    437                                              (terpri *trace-output*)))))))
    438                      ((and (consp before) (or (eq (car before) 'function) (eq (car before) 'quote)))
    439                       (if (integerp backtrace)
    440                           (setq before `#'(lambda (&rest args)
    441                                             (apply ,before args)
    442                                             (let ((*debug-io* *trace-output*))
    443                                               (ccl::print-call-history :detailed-p nil :count ,backtrace)
    444                                               (terpri *trace-output*))))
    445                         (setq before `#'(lambda (&rest args)
    446                                           (apply ,before args)
    447                                           (let ((*debug-io* *trace-output*))
    448                                             (ccl::print-call-history :detailed-p nil)
    449                                             (terpri *trace-output*))))))
    450                      (t
    451                       (warn ":backtrace is not compatible with :before ~A" before))))
    452                   (setq newdef (trace-global-def
    453                                 sym newsym before after step method-p))
    454                   (when method-p
    455                     (copy-method-function-bits def newdef))
    456                   (without-interrupts
    457                    (multiple-value-bind (ignore gf-dcode) (encapsulate trace-thing def 'trace sym newsym)
    458                      (declare (ignore ignore))
    459                      (cond (gf-dcode
    460                             (setf (%gf-dcode def)
    461                                   (%cons-combined-method def (cons newdef gf-dcode) #'%%call-gf-encapsulation)))
    462                            ((symbolp trace-thing) (%fhave trace-thing newdef))
    463                            ((typep trace-thing 'method)
    464                             (setf (%method-function trace-thing) newdef)
    465                             (remove-obsoleted-combined-methods trace-thing)
    466                             newdef))))))
    467             (error "Trace does not understand ~S." sym)))))
    468       (when *trace-hook*
    469         (funcall *trace-hook* sym :before before :after after :backtrace backtrace :step step))
    470     )))
     557                (if  (or before after)
     558                  (setq step nil)               
     559                  (return-from %trace-block)))
     560              #|(uncompile-for-stepping trace-thing nil t)|#))
     561          (let* ((newsym (gensym "TRACE"))
     562                 (method-p (typep trace-thing 'method))
     563                 (newdef (trace-global-def
     564                          sym newsym if before-if eval-before after-if eval-after method-p)))
     565            (when method-p
     566              (copy-method-function-bits def newdef))
     567            (without-interrupts
     568              (multiple-value-bind (ignore gf-dcode) (encapsulate trace-thing def 'trace sym newsym)
     569                (declare (ignore ignore))
     570                (cond (gf-dcode
     571                       (setf (%gf-dcode def)
     572                             (%cons-combined-method def (cons newdef gf-dcode) #'%%call-gf-encapsulation)))
     573                      ((symbolp trace-thing) (%fhave trace-thing newdef))
     574                      ((typep trace-thing 'method)
     575                       (setf (%method-function trace-thing) newdef)
     576                       (remove-obsoleted-combined-methods trace-thing)
     577                       newdef)))))))
     578    (when *trace-hook*
     579      (apply *trace-hook* sym args))))
     580
    471581
    472582;; sym is either a symbol or a method
     
    558668
    559669(defmacro trace (&rest syms)
    560   "TRACE {Option Global-Value}* {Name {Option Value}*}*
     670  "TRACE {Option Global-Value}* { Name | (Name {Option Value}*) }*
    561671
    562672TRACE is a debugging tool that provides information when specified
    563673functions are called."
    564674  (if syms
    565     `(%trace-0 ',syms)
     675    (let ((options (loop while (keywordp (car syms))
     676                     nconc (list (pop syms) (pop syms)))))
     677      `(%trace-0 ',syms ',options))
    566678    `(%trace-list)))
    567679
    568 (defun %trace-0 (syms)
    569   (dolist (symbol syms)
    570        (cond ((consp symbol)
    571               (cond ((null (cdr symbol))
    572                      (%trace (car symbol) :before :print :after :print))
    573                     ((memq (car symbol) '(:method setf))
    574                      (%trace symbol :before :print :after :print))
    575                     (t (apply #'%trace symbol))))
    576              (t (%trace symbol :before :print :after :print)))))
     680(defun %trace-0 (syms &optional global-options)
     681  (dolist (spec syms)
     682    (if (or (atom spec)
     683            (memq (car spec) '(:method setf :package)))
     684      (apply #'trace-function spec global-options)
     685      (apply #'trace-function (append spec global-options)))))
    577686
    578687(defun %trace-list ()
     
    587696;; this week def is the name of an uninterned gensym whose fn-cell is original def
    588697
    589 (defun trace-global-def (sym def before after step &optional method-p)
    590   (let ((saved-method-var (gensym)) do-it step-it)
    591     (when step
    592       (setq step-it           
    593             `(step-apply-simple ',def args)))
     698(defun trace-global-def (sym def if before-if eval-before after-if eval-after &optional method-p)
     699  (let ((saved-method-var (gensym))
     700        (enable (gensym))
     701        do-it)
    594702    (setq do-it
    595           (cond (step
    596                  (if (eq step t)
    597                    step-it
    598                    `(if (apply ',step ',sym args) ; gaak
    599                       ,step-it
    600                       ,(if (and before method-p)
    601                          `(apply-with-method-context ,saved-method-var (symbol-function ',def) args)
    602                          `(apply ',def args)))))
    603                 (t (if (and before method-p)
     703          (cond #+old (step
     704                       (setq step-it           
     705                             `(step-apply-simple ',def args))
     706                       (if (eq step t)
     707                         step-it
     708                         `(if (apply ',step ',sym args) ; gaak
     709                           ,step-it
     710                           ,(if (and before method-p)
     711                                `(apply-with-method-context ,saved-method-var (symbol-function ',def) args)
     712                                `(apply ',def args)))))
     713                (t (if (and eval-before method-p)
    604714                     `(apply-with-method-context ,saved-method-var (symbol-function ',def) args)
    605715                     `(apply ',def args)))))
    606     (flet ((quoted-p (x)
    607              (and (consp x)
    608                   (case (car x)
    609                     ((function quote) t)))))
    610       (compile-named-function-warn
    611        `(lambda (,@(if (and before method-p)
    612                      `(&method ,saved-method-var))
    613                  &rest args) ; if methodp put &method on front of args - vs get-saved-method-var?
    614           (declare (dynamic-extent args))
    615           (let ((*trace-level* (1+ *trace-level*)))
    616             (declare (special *trace-enable* *trace-level*))
    617             ,(if before
    618                `(when *trace-enable*
    619                   (when *trace-print-hook*
    620                     (funcall *trace-print-hook* ',sym t))
    621                   (let* ((*trace-enable* nil))
    622                     ,(cond
    623                       ((eq before :break)
    624                        `(progn (apply #'trace-before ',sym args)
    625                                (break "~S" args)))
    626                       (t `(apply ,(if (quoted-p before) before `',before) ',sym args))))
    627                   (when *trace-print-hook*
    628                     (funcall *trace-print-hook* ',sym nil))))           
    629             ,(if after
    630                `(let ((vals (multiple-value-list ,do-it)))
    631                   (when *trace-enable*
    632                     (when *trace-print-hook*
    633                       (funcall *trace-print-hook* ',sym t))
    634                     (let* ((*trace-enable* nil))
    635                       ,(cond ((eq after :break)
    636                               `(progn
    637                                  (apply #'trace-after ',sym vals)
    638                                  (break "~S" vals)))
    639                              (t `(apply ,(if (quoted-p after) after `',after) ',sym  vals))))
    640                     (when *trace-print-hook*
    641                       (funcall *trace-print-hook* ',sym nil)))
    642                   (values-list vals))
    643                do-it)))
    644        `(traced ,sym)))))
     716    (compile-named-function-warn
     717     `(lambda (,@(and eval-before method-p `(&method ,saved-method-var))
     718               &rest args) ; if methodp put &method on front of args - vs get-saved-method-var?
     719       (declare (dynamic-extent args))
     720       (let ((*trace-level* (1+ *trace-level*))
     721             (,enable ,if))
     722         (declare (special *trace-enable* *trace-level*))
     723         ,(when eval-before
     724           `(when (and ,enable ,before-if *trace-enable*)
     725             (when *trace-print-hook*
     726               (funcall *trace-print-hook* ',sym t))
     727             (let* ((*trace-enable* nil))
     728               ,@eval-before)
     729             (when *trace-print-hook*
     730               (funcall *trace-print-hook* ',sym nil))))
     731         ,(if eval-after
     732           `(let ((vals (multiple-value-list ,do-it)))
     733             (when (and ,enable ,after-if *trace-enable*)
     734               (when *trace-print-hook*
     735                 (funcall *trace-print-hook* ',sym t))
     736               (let* ((*trace-enable* nil))
     737                 ,@eval-after)
     738               (when *trace-print-hook*
     739                 (funcall *trace-print-hook* ',sym nil)))
     740             (values-list vals))
     741           do-it)))
     742     `(traced ,sym))))
    645743
    646744; &method var tells compiler to bind var to contents of next-method-context
Note: See TracChangeset for help on using the changeset viewer.