Added (declare (stepper trace)) for functions.
[com-informatimago:com-informatimago.git] / common-lisp / lisp / stepper-functions.lisp
1 ;;;; -*- mode:lisp;coding:utf-8 -*-
2 ;;;;**************************************************************************
3 ;;;;FILE:               stepper-functions.lisp
4 ;;;;LANGUAGE:           Common-Lisp
5 ;;;;SYSTEM:             Common-Lisp
6 ;;;;USER-INTERFACE:     NONE
7 ;;;;DESCRIPTION
8 ;;;;    
9 ;;;;    An internal package of the Common Lisp stepper.
10 ;;;;    This package exports the stepper generator functions
11 ;;;;    and defines the stepper interactive functions.
12 ;;;;    
13 ;;;;AUTHORS
14 ;;;;    <PJB> Pascal J. Bourguignon <pjb@informatimago.com>
15 ;;;;MODIFICATIONS
16 ;;;;    2012-08-09 <PJB> Extracted from stepper.lisp
17 ;;;;BUGS
18 ;;;;LEGAL
19 ;;;;    AGPL3
20 ;;;;    
21 ;;;;    Copyright Pascal J. Bourguignon 2012 - 2012
22 ;;;;    
23 ;;;;    This program is free software: you can redistribute it and/or modify
24 ;;;;    it under the terms of the GNU Affero General Public License as published by
25 ;;;;    the Free Software Foundation, either version 3 of the License, or
26 ;;;;    (at your option) any later version.
27 ;;;;    
28 ;;;;    This program is distributed in the hope that it will be useful,
29 ;;;;    but WITHOUT ANY WARRANTY; without even the implied warranty of
30 ;;;;    MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
31 ;;;;    GNU Affero General Public License for more details.
32 ;;;;    
33 ;;;;    You should have received a copy of the GNU Affero General Public License
34 ;;;;    along with this program.  If not, see <http://www.gnu.org/licenses/>.
35 ;;;;**************************************************************************
36
37
38 (in-package "COM.INFORMATIMAGO.COMMON-LISP.LISP.STEPPER")
39
40 ;; When instrumenting is disabled with a declaration, all the forms and
41 ;; subforms in the scope must use the CL operators instead of the stepper
42 ;; macros.  Since subforms and their expansions may use those stepper
43 ;; macros, we would need a code walker to process them.  A simpler and
44 ;; more portable solution is to use macrolet and to shadow all those
45 ;; stepper macros.
46
47 (cl:defun com.informatimago.common-lisp.lisp.stepper.internal:step-disabled (form)
48   "
49 RETURN:         A form where FORM is evaluated in an environment where
50                 all the stepper special operator macros expand to CL
51                 special operators.
52 "
53   `(cl:macrolet
54        ((function (name) (cl:if (and (consp name)
55                                      (eq 'lambda (first name)))
56                            `(cl:function (cl:lambda ,@(rest (first name))))
57                            `(cl:function ,name)))
58         (quote (literal) `(cl:quote ,literal))
59         (if (&whole form test then &optional else)
60           (declare (ignorable test then else))
61           `(cl:if ,@(rest form)))
62         (block (&whole form name &body body)
63           (declare (ignorable name body))
64           `(cl:block ,@(rest form)))
65         (return-from (&whole form name &optional result)
66           (declare (ignorable name result))
67           `(cl:return-from ,@(rest form)))
68         (catch (&whole form object &body body)
69           (declare (ignorable object body))
70           `(cl:catch ,@(rest form)))
71         (throw (&whole form object result)
72           (declare (ignorable object result))
73           `(cl:throw ,@(rest form)))
74         (unwind-protect (&whole form protected &body cleanup)
75           (declare (ignorable protected cleanup))
76           `(cl:unwind-protect ,@(rest form)))
77         (tagbody (&whole form &body body)
78            (declare (ignorable body))
79            `(cl:tagbody ,@(rest form)))
80         (go (tag) `(cl:go ,tag))
81         (flet (&whole form (&rest bindings) &body body)
82           (declare (ignorable bindings body))
83           `(cl:flet ,@(rest form)))
84         (labels (&whole form (&rest bindings) &body body)
85           (declare (ignorable bindings body))
86           `(cl:labels ,@(rest form)))
87         (macrolet (&whole form (&rest bindings) &body body)
88             (declare (ignorable bindings body))
89           `(cl:macrolet ,@(rest form)))
90         (symbol-macrolet (&whole form (&rest bindings) &body body)
91           (declare (ignorable bindings body))
92           `(cl:symbol-macrolet ,@(rest form)))
93         (let (&whole form (&rest bindings) &body body)
94           (declare (ignorable bindings body))
95           `(cl:let ,@(rest form)))
96         (let* (&whole form (&rest bindings) &body body)
97           (declare (ignorable bindings body))
98           `(cl:let* ,@(rest form)))
99         (setq (&whole form var val &rest pairs)
100               (declare (ignorable var val pairs))
101               `(cl:setq ,@(rest form)))
102         (multiple-value-call (&whole form function-form &rest arguments)
103           (declare (ignore function-form arguments))
104           `(cl:multiple-value-call ,@(rest form)))
105         (multiple-value-prog1 (&whole form result-form &body body)
106           (declare (ignore result-form body))
107           `(cl:multiple-value-prog1 ,@(rest form)))
108         (locally (&whole form &body body)
109           (declare (ignore body))
110           `(cl:locally ,@(rest form)))
111         (progn (&whole form &body body)
112                (declare (ignore body))
113                `(cl:progn ,@(rest form)))
114         (progv (&whole form symbols values &body body)
115             (declare (ignore symbols values body))
116           `(cl:progv ,@(rest form)))
117         (the (&whole form value-type expression)
118           (declare (ignore value-type expression))
119           `(cl:the ,@(rest form)))
120         (eval-when (&whole form (&rest situations) &body body)
121           (declare (ignore situations body))
122           `(cl:eval-when ,@(rest form)))
123         (load-time-value (&whole form expression &optional read-only-p)
124                          (declare (ignore expression read-only-p))
125                          `(cl:load-time-value ,@(rest form))))
126        ,form))
127
128
129 (in-package "COM.INFORMATIMAGO.COMMON-LISP.LISP.STEPPER.INTERNAL")
130
131
132 (defvar *step-mode* :run
133   "
134 May be :run, :function :trace or :step.
135
136 :run       don't print anything, just evaluate the forms.
137
138 :function just prints the function calls and their results.
139
140 :trace    just prints the forms and their results as they are evaluted.
141
142 :step     prints the form, then ask the user what to do (step over,
143           step into, trace, run).
144
145 When break-points are implemented, :run, :function and :trace will run
146 until a break-point is reached.
147
148 ")
149
150
151 (defvar *step-max-trace-depth* nil
152   "The maximum depth of function calls that should be traced.  When
153 more than that depth of calls occur, the *step-mode* switches to
154 :run.")
155
156 (defvar *step-current-trace-depth* 0
157   "The current depth of instrumented function calls.")
158
159
160     ;; (STEP-TRACE f)        T           T           F           F
161     ;; (STEP-NOTRACE f)      T           F           T           F
162     ;; *STEP-MODE*       :r :t :s    :r :t :s    :r :t :s    :r :t :s
163     ;; ----------------------------------------------------------------
164     ;; Action:            r  r  s     t  t  s     r  r  s     r  t  s
165     ;; r = run, t = trace, s = step (in or over).
166
167
168 (defvar *trace-functions* '()
169   "A list of function names that we must trace with the stepper.
170 SEE: STEP-TRACE, STEP-UNTRACE.")
171
172 (defvar *break-functions-entry* '()
173   "A list of function names that we must break into the stepper upon entry.
174 SEE: STEP-BREAK-ENTRY, STEP-UNBREAK-ENTRY.")
175
176 (defvar *break-functions-exit* '()
177   "A list of function names that we must break into the stepper upon exit.
178 SEE: STEP-BREAK-EXIT, STEP-UNBREAK-EXIT.")
179
180
181
182 (defmacro step-trace-function (&rest fnames)
183   "
184 DO:             Enable tracing of functions named by FNAMES.
185
186 FNAMES:         A list of function names.
187
188 NOTE:           The functions must have been compiled with the operators from
189                 the CL-STEPPER package not the CL package.
190
191 RETURN:         The list of function names added.
192 "
193   ;; We use :test 'equal for (setf fname).
194   `(setf *trace-functions*
195          (delete-duplicates (union *trace-functions* ',fnames
196                                    :test (function equal))
197                             :test (function equal))))
198
199
200 (defmacro step-untrace-function (&rest fnames)
201   "
202 DO:             Disable tracing of functions named by FNAMES.
203
204 FNAMES:         A list of function names.
205
206 NOTE:           The functions must have been compiled with the operators from
207                 the CL-STEPPER package not the CL package.
208
209 RETURN:         The list of step-traced functions remaining.
210 "
211   `(setf *trace-functions* (set-difference *trace-functions* ',fnames
212                                            :test (function equal))))
213
214
215 (defmacro step-break-entry (&rest fnames)
216   "
217 DO:             Enable breaking on entry of functions named by FNAMES.
218
219 FNAMES:         A list of function names.
220
221 NOTE:           The functions must have been compiled with the operators from
222                 the CL-STEPPER package not the CL package.
223
224 RETURN:         The list of function names added.
225 "
226   `(setf *break-entry-functions*
227          (delete-duplicates (union *break-entry-functions* ',fnames
228                                    :test (function equal))
229                             :test (function equal))))
230
231
232 (defmacro step-unbreak-entry (&rest fnames)
233   "
234 DO:             Disable breaking on entry of functions named by FNAMES.
235
236 FNAMES:         A list of function names.
237
238 NOTE:           The functions must have been compiled with the operators from
239                 the CL-STEPPER package not the CL package.
240
241 RETURN:         The list of step-break-entry functions remaining.
242 "
243   `(setf *break-entry-functions* (set-difference *break-entry-functions* ',fnames
244                                                  :test (function equal))))
245
246
247 (defmacro step-break-exit (&rest fnames)
248   "
249 DO:             Enable breaking on exit of functions named by FNAMES.
250
251 FNAMES:         A list of function names.
252
253 NOTE:           The functions must have been compiled with the operators from
254                 the CL-STEPPER package not the CL package.
255
256 RETURN:         The list of function names added.
257 "
258   `(setf *break-exit-functions*
259          (delete-duplicates (union *break-exit-functions* ',fnames
260                                    :test (function equal))
261                             :test (function equal))))
262
263
264 (defmacro step-unbreak-exit (&rest fnames)
265   "
266 DO:             Disable breaking on exit of functions named by FNAMES.
267
268 FNAMES:         A list of function names.
269
270 NOTE:           The functions must have been compiled with the operators from
271                 the CL-STEPPER package not the CL package.
272
273 RETURN:         The list of step-break-entry functions remaining.
274 "
275   `(setf *break-exit-functions* (set-difference *break-exit-functions* ',fnames
276                                                 :test (function equal))))
277
278
279
280 (defvar *step-level* 0
281   "The level.")
282
283 (defvar *step-package*         (find-package :cl-user)
284   "The package bound to *PACKAGE* while printing tracing logs.")
285
286 (defvar *step-print-readably* nil
287   "The value bound to *PRINT-READABLY* while printing tracing logs.")
288
289
290 (defvar *step-print-length*    10
291   "The value bound to *PRINT-LENGTH* while printing tracing logs.")
292
293 (defvar *step-print-level*      3
294   "The value bound to *PRINT-LEVEl* while printing tracing logs.")
295
296 (defvar *step-print-case*     :downcase
297   "The value bound to *PRINT-CASE* while printing tracing logs.")
298
299 (defvar *step-trace-output* (make-synonym-stream '*trace-output*)
300   "The stream where the stepper traces are written to.")
301
302 (defmacro with-step-printing (&body body)
303   `(let ((*print-length*   *step-print-length*)
304          (*print-level*    *step-print-level*)
305          (*print-readably* *step-print-readably*)
306          (*print-case*     *step-print-case*)
307          (*package*        *step-package*))
308      ,@body))
309
310
311
312 ;; Tracing steps:
313
314 (defun will-step (form &optional (stream *step-trace-output*))
315   (with-step-printing
316       (format stream "~&~V<~>(Will evaluate ~S~%" *step-level* form)))
317
318 (defun did-bind (variable value &optional (stream *step-trace-output*))
319   "
320 RETURN: VALUE
321 "
322   (unless (eq :run *step-mode*)
323    (with-step-printing
324        (format stream "~&~V<~>(Bind ~16A to ~S)~%" *step-level* variable value)))
325   value)
326
327 (defun print-step-results (results &optional (stream *step-trace-output*))
328   (when results
329     (with-step-printing
330         (let ((start "==>"))
331           (dolist (result results)
332             (format stream "~%~V<~>~A ~S" *step-level* start result)
333             (setf start "   "))))))
334
335 (defun did-step (form results &optional (stream *step-trace-output*))
336   (with-step-printing
337       (format stream "~&~V<~>Evaluation of ~S returned ~:[no result~;~R result~:P~]"
338               *step-level* form results (length results)))
339   (print-step-results results)
340   (format stream ")~%"))
341
342 (defun did-tag (tag &optional (stream *step-trace-output*))
343   (unless (eq :run *step-mode*)
344     (with-step-printing
345         (format stream "~&~V<~>(Passed tag ~S)~%" *step-level* tag))))
346
347
348 ;; Interactive stepping:
349
350 (define-condition step-condition (condition)
351   ((message :initarg :message :initform "Step" :reader step-message))
352   (:report (lambda (condition stream)
353                (format stream "~A" (step-message condition)))))
354
355 (defun step-choice (&optional thunk)
356   (when thunk (funcall thunk *step-trace-output*))
357   (with-step-printing
358       (format *query-io* "~V<~>~{~A~^, ~}?"
359               *step-level*
360               '("Step Into (s, si, RET)" "Step over (so)" "Trace (t)"
361                 "Function (f)" "Run (r)" "Debugger (d)" "Abort (a, q)")))
362   (let ((answer (string-trim " " (read-line *query-io*))))
363     (cond
364       ((member answer '("" "s" "si") :test (function string-equal))
365        :step-into)
366       ((string-equal answer "so")
367        :step-over)
368       ((string-equal answer "f")
369        :function)
370       ((string-equal answer "t")
371        :trace)
372       ((string-equal answer "r")
373        :run)
374       ((string-equal answer "d")
375        (restart-case
376            (progn (invoke-debugger (make-condition 'step-condition
377                                                    :message (if thunk
378                                                               (with-output-to-string (out)
379                                                                 (funcall thunk out))
380                                                               "Step")))
381                   :step-into)
382          (step-into     () :report "Step Into"      (progn :step-into))
383          (step-over     () :report "Step Over"      (progn :step-over))
384          (step-trace    () :report "Trace"          (progn :trace))
385          (step-function () :report "Function"       (progn :function))
386          (step-run      () :report "Run"            (progn :run))
387          (abort         () :Report "Abort Stepping" (progn :abort))))
388       ((member answer '("a" "q") :test (function string-equal))
389        :abort)
390       (t
391        (step-choice thunk)))))
392
393
394 ;; Instrumentation:
395 ;; The step-* functions are called by macros to generate the stepping
396 ;; code. Usually, calling a call-step-* function that does the actual
397 ;; work.
398
399 (defun substitute-ignorable (declarations)
400   (mapcar (lambda (declaration)
401               (destructuring-bind (declare &rest items) declaration
402                 `(,declare
403                   ,@(mapcar (lambda (item)
404                                 (if (consp item)
405                                   (destructuring-bind (op &rest args) item
406                                     (if (eq 'ignore op)
407                                       `(ignorable ,@args)
408                                       item))
409                                   item))
410                             items))))
411           declarations))
412
413 (assert (equalp
414          (substitute-ignorable '((declare (type q x) (ignore x))
415                                  (declare (ignore z))
416                                  (declare (type p z))
417                                  (declare thing)))
418          '((declare (type q x) (ignorable x))
419            (declare (ignorable z))
420            (declare (type p z))
421            (declare thing))))
422
423
424 (defun call-step-atom (atom thunk)
425   (flet ((do-step ()
426            (let ((results (let ((*step-level* (1+ *step-level*)))
427                             (multiple-value-list (funcall thunk)))))
428              (if (= 1 (length results))
429                (with-step-printing
430                    (if (or (symbolp atom) (consp atom))
431                      (format *step-trace-output* "~V<~>(~S ==> ~S)~%" *step-level* atom (first results))
432                      (format *step-trace-output* "~V<~>(--> ~S)~%" *step-level* atom)))
433                (progn
434                  ;; (will-step display-form)
435                  (did-step atom results)))
436              (values-list results))))
437     (case *step-mode*
438       ((:run :function) (funcall thunk))
439       (:trace  (do-step))
440       (:step   (ecase (step-choice (lambda (out) (will-step atom out)))
441                  (:abort     (throw 'abort-stepping nil))
442                  (:run       (setf *step-mode* :run)      (funcall thunk))
443                  (:function  (setf *step-mode* :function) (funcall thunk))
444                  (:trace     (setf *step-mode* :trace)    (do-step))
445                  (:step-into (do-step))
446                  (:step-over (let ((*step-mode* :run)) (do-step))))))))
447
448
449 (defun step-atom (object)
450   `(call-step-atom ',object (lambda () ,object)))
451
452 (defun step-simple-form (actual &optional (form actual))
453   `(call-step-atom ',form (lambda () ,actual)))
454
455
456 (defun call-simple-step (thunk display-form)
457   (flet ((do-step ()
458            (will-step display-form)
459            (let ((results (let ((*step-level* (1+ *step-level*)))
460                             (multiple-value-list (funcall thunk)))))
461              (did-step display-form results)
462              (values-list results))))
463     (case *step-mode*
464       ((:run :function)  (funcall thunk))
465       (:trace  (do-step))
466       (:step   (ecase (step-choice (lambda (out) (will-step display-form out)))
467                  (:abort     (throw 'abort-stepping nil))
468                  (:run       (setf *step-mode* :run)      (funcall thunk))
469                  (:function  (setf *step-mode* :function) (do-step))
470                  (:trace     (setf *step-mode* :trace)    (do-step))
471                  (:step-into (do-step))
472                  (:step-over (let ((*step-mode* :run))    (do-step))))))))
473
474 (defun simple-step (form &optional (display-form form))
475   `(call-simple-step (lambda () ,form) ',display-form))
476
477
478 (defun step-body (where body env)
479   (multiple-value-bind (docstring declarations body) (parse-body where body)
480     (append (when docstring (list docstring))
481             (substitute-ignorable declarations)
482             (mapcar (lambda (form)
483                         (step-expression form env))
484                     body))))
485
486
487 (defun call-step-function (name pnames pvals thunk)
488   (labels ((report-enter (out)
489              (with-step-printing
490                  (format out "~&~V<~>(Entering ~:[anonymous ~;~]function ~:*~:[~;~:*~S~]~%"
491                          *step-level* name))
492              (let ((*step-level* (1+ *step-level*)))
493                (mapc (function did-bind) pnames pvals)))
494            (report-exit (non-local-exit results out)
495              (with-step-printing
496                  (format out "~&~V<~>Exiting  ~:[anonymous ~;~]function ~:*~:[~;~:*~S ~]~
497                           ~:[returned ~:[no result~;~R result~:P~]~;by non-local exit.~]"
498                          *step-level* name non-local-exit results (length results)))
499              (print-step-results results)
500              (format out ")~%"))
501            (do-step ()
502              (let ((results        '())
503                    (non-local-exit t))
504                (unwind-protect
505                    (setf results (let ((*step-level* (1+ *step-level*)))
506                                    (multiple-value-list (funcall thunk)))
507                          non-local-exit nil)
508                  (unless (eq *step-mode* :run)
509                    (report-exit non-local-exit results *step-trace-output*))
510                  (when (member name *break-functions-exit* :test (function equal))
511                    (ecase (step-choice (lambda (out) (declare (ignore out))))
512                      (:abort     (throw 'abort-stepping nil))
513                      (:run       (setf *step-mode* :run))
514                      (:function  (setf *step-mode* :function))
515                      (:trace     (setf *step-mode* :trace))
516                      (:step-into (setf *step-mode* :step))
517                      (:step-over (setf *step-mode* :step)))))
518                (values-list results)))
519            (choice (report)
520              (ecase (step-choice report)
521                (:abort     (throw 'abort-stepping nil))
522                (:run       (setf *step-mode* :run)      (do-step))
523                (:function  (setf *step-mode* :function) (do-step))
524                (:trace     (setf *step-mode* :trace)    (do-step))
525                (:step-into (do-step))
526                (:step-over (let ((*step-mode* :run)) (do-step))))))
527     (let ((*step-current-trace-depth* (1+ *step-current-trace-depth*)))
528       (if (member name *break-functions-entry* :test (function equal))
529         (choice (function report-enter))
530         (case *step-mode*
531           ((:run)
532            ;; (print (list (not (not (member name *trace-functions* :test (function equal)))) name *trace-functions*))
533            (if (member name *trace-functions* :test (function equal))
534              (let ((*step-mode* :trace)
535                    (*step-current-trace-depth* 0)) ; reset it
536                (report-enter *step-trace-output*)
537                (do-step))
538              (do-step)))
539           ((:function :trace)
540            (if (and *step-max-trace-depth*
541                     (< *step-max-trace-depth* *step-current-trace-depth*))
542              (let ((*step-mode* :run))
543                (do-step))
544              (progn
545                (report-enter *step-trace-output*)
546                (do-step))))
547           ((:step)
548            (choice (function report-enter))))))))
549
550
551
552 (declaim (declaration stepper))
553 (pushnew :com.informatimago.common-lisp.lisp.cl-stepper *features*)
554
555 (defun stepper-declaration-p (declarations keyword)
556   (find-if (lambda (declaration)
557                (and (consp declaration)
558                 (eq 'declare (first declaration))
559                 (find-if (lambda (specifier)
560                              (and (consp specifier)
561                               (eq 'stepper (first specifier))
562                               (member keyword (rest specifier))))
563                          (rest declaration))))
564            declarations))
565
566 ;; (stepper-declaration-p '((declare (ignorable object) (stepper disable))) 'disable)
567 ;; (stepper-declaration-p '((declare (type integer x)) (declare (stepper trace))) 'trace)
568
569
570
571 (defun step-function (kind name lambda-list body env)
572   "
573 KIND:           A lambda-list kind (:ordinary for functions,
574                 :specialized for methods,
575                 :destructuring for macros).
576
577 NAME:           The name of the defined function or macro.
578
579 LAMBDA-FORM:    A lambda form.
580
581 BODY:           A list of forms, the body of the function.
582
583 RETURN:         A stepping body.
584 "
585   (let ((parameters (mapcar (function parameter-name)
586                             (lambda-list-parameters
587                              (parse-lambda-list lambda-list kind)))))
588     (multiple-value-bind (docstring declarations real-body) (parse-body :lambda body)
589       (if (stepper-declaration-p declarations 'disabled)
590         (append (when docstring (list docstring))
591                 declarations
592                 (list (step-disabled `(progn ,@real-body))))
593         (append (when docstring (list docstring))
594                 (substitute-ignorable declarations)
595                 (let ((form `((call-step-function
596                                ',name ',parameters (list ,@parameters)
597                                (lambda ()
598                                    ,@(if name
599                                          `((block ,(if (consp name) (second name) name)
600                                              ;; inner block for non-local exit.
601                                              ,@(step-body :progn real-body env)))
602                                          (step-body :progn real-body env)))))))
603                   (if (stepper-declaration-p declarations 'trace)
604                     `(let ((*step-mode* :trace))
605                        ,form)
606                     form)))))))
607
608
609 (defun step-lambda (lambda-form &key (kind :ordinary) name environment)
610   "
611
612 ENV:            An environment.
613
614 LAMBDA-FORM:    A lambda form.
615
616 KIND:           A lambda-list kind (:ordinary for functions, :generic
617                 for generic functions, :specialized for methods,
618                 :destructuring for macros, etc).
619
620 NAME:           The name of the defined function or macro.
621
622 RETURN:         A stepping lambda-form from the LAMBDA-FORM.
623
624 "
625   (destructuring-bind (lambda lambda-list &body body) lambda-form
626     (declare (ignore lambda))
627     `(lambda ,lambda-list
628          ,@(step-function kind name lambda-list body environment))))
629
630
631 (defun step-bindings (mode bindings form env)
632   (flet ((binding-step (var expr)
633            (if (eq :sequential mode)
634              `(,var (did-bind ',var ,(step-expression expr env)))
635              `(,var ,(step-expression expr env)))))
636     (mapcar (lambda (binding)
637                 (cond
638                   ((symbolp binding)
639                    (binding-step binding 'nil))
640                   ((atom binding)
641                    (error "Invalid atom ~S in binding list of ~S"
642                           binding form))
643                   ((< 2 (length binding))
644                    (error "Invalid binding ~S in binding list of ~S"
645                           binding form))
646                   (t
647                    (binding-step (first binding) (second binding)))))
648             bindings)))
649
650
651 (defmacro symbol-reference (symbol &environment env)
652   (let ((expansion  (macroexpand symbol env)))
653     (if (eq symbol expansion)
654       (step-atom symbol)
655       (step-expression expansion env))))
656
657 (defmacro self-evaluating (object)
658   (step-atom object))
659
660 (defun step-function-call (form env)
661   (destructuring-bind (function-name &rest arguments) form
662     (if (consp function-name)
663       (if (member (first function-name)
664                   '(com.informatimago.common-lisp.lisp.stepper:lambda lambda))
665         (simple-step `(,(step-lambda function-name :environment env)
666                         ,@(mapcar (lambda (argument) (step-expression argument env))
667                                   arguments))
668                      form)
669         (error "Invalid object used as function name ~S in function call ~S"
670                function-name form))
671       (simple-step `(,function-name
672                      ,@(mapcar (lambda (argument) (step-expression argument env))
673                                arguments))
674                    form))))
675
676
677 (defun step-expression (form env)
678   ;; Operators in CL-STEPPER are macros, so they're taken care of
679   ;; automatically.
680   (cond
681     ((symbolp form)  `(symbol-reference ,form))
682     ;; The other atoms are unchanged:
683     ((atom form)     `(self-evaluating ,form))
684     ;; Now we have a list.  
685     (t
686      (case (first form)
687        
688        ;; First we check the real CL special operators:
689        ;; We just step them wholesale. (If there are macros inside
690        ;; they'll be expanded and we may step them.
691        ((function quote)
692         (step-simple-form form))
693        ((block catch eval-when flet go if labels let let*
694                load-time-value locally macrolet multiple-value-call
695                multiple-value-prog1 progn progv return-from setq
696                symbol-macrolet tagbody the throw unwind-protect)
697         (simple-step form))
698
699        ;; Next we check for the stepper macros.  Since they already
700        ;; expand to simple-step, we just use them as is, unless
701        ;; they're toplevelness protected forms:
702        ((com.informatimago.common-lisp.lisp.stepper:function
703          com.informatimago.common-lisp.lisp.stepper:quote)
704         (step-simple-form form))
705        ((com.informatimago.common-lisp.lisp.stepper:block
706             com.informatimago.common-lisp.lisp.stepper:catch
707           ;; com.informatimago.common-lisp.lisp.stepper:eval-when
708           com.informatimago.common-lisp.lisp.stepper:flet
709           com.informatimago.common-lisp.lisp.stepper:go
710           com.informatimago.common-lisp.lisp.stepper:if
711           com.informatimago.common-lisp.lisp.stepper:labels
712           com.informatimago.common-lisp.lisp.stepper:let
713           com.informatimago.common-lisp.lisp.stepper:let*
714           com.informatimago.common-lisp.lisp.stepper:load-time-value
715           ;; com.informatimago.common-lisp.lisp.stepper:locally
716           com.informatimago.common-lisp.lisp.stepper:macrolet
717           com.informatimago.common-lisp.lisp.stepper:multiple-value-call
718           com.informatimago.common-lisp.lisp.stepper:multiple-value-prog1
719           ;; com.informatimago.common-lisp.lisp.stepper:progn
720           com.informatimago.common-lisp.lisp.stepper:progv
721           com.informatimago.common-lisp.lisp.stepper:return-from
722           com.informatimago.common-lisp.lisp.stepper:setq
723           com.informatimago.common-lisp.lisp.stepper:symbol-macrolet
724           com.informatimago.common-lisp.lisp.stepper:tagbody
725           com.informatimago.common-lisp.lisp.stepper:the
726           com.informatimago.common-lisp.lisp.stepper:throw
727           com.informatimago.common-lisp.lisp.stepper:unwind-protect)
728         form)
729        (otherwise
730         (if (macro-function (first form) env)
731           ;; For a macro, we let the host CL expand it:
732           (simple-step form)
733           ;; For a function, we step the arguments:
734           (step-function-call form env)))))))
735
736
737
738 ;;;; THE END ;;;;