Added (declare (stepper trace)) for functions.
[com-informatimago:com-informatimago.git] / common-lisp / lisp / stepper.lisp
1 ;;;; -*- mode:lisp;coding:utf-8 -*-
2 ;;;;**************************************************************************
3 ;;;;FILE:               stepper.lisp
4 ;;;;LANGUAGE:           Common-Lisp
5 ;;;;SYSTEM:             Common-Lisp
6 ;;;;USER-INTERFACE:     NONE
7 ;;;;DESCRIPTION
8 ;;;;    
9 ;;;;    Implements a Common Lisp stepper.
10 ;;;;    
11 ;;;;AUTHORS
12 ;;;;    <PJB> Pascal J. Bourguignon <pjb@informatimago.com>
13 ;;;;MODIFICATIONS
14 ;;;;    2012-08-03 <PJB> Created.
15 ;;;;BUGS
16 ;;;;LEGAL
17 ;;;;    AGPL3
18 ;;;;    
19 ;;;;    Copyright Pascal J. Bourguignon 2012 - 2012
20 ;;;;    
21 ;;;;    This program is free software: you can redistribute it and/or modify
22 ;;;;    it under the terms of the GNU Affero General Public License as published by
23 ;;;;    the Free Software Foundation, either version 3 of the License, or
24 ;;;;    (at your option) any later version.
25 ;;;;    
26 ;;;;    This program is distributed in the hope that it will be useful,
27 ;;;;    but WITHOUT ANY WARRANTY; without even the implied warranty of
28 ;;;;    MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
29 ;;;;    GNU Affero General Public License for more details.
30 ;;;;    
31 ;;;;    You should have received a copy of the GNU Affero General Public License
32 ;;;;    along with this program.  If not, see <http://www.gnu.org/licenses/>.
33 ;;;;**************************************************************************
34
35
36 (in-package "COM.INFORMATIMAGO.COMMON-LISP.LISP.STEPPER")
37
38
39 ;;;----------------------------------------------------------------------
40 ;;;
41 ;;; Special operators
42 ;;;
43
44 (cl:defmacro define-special-operator ((name &rest lambda-list) prefix &body body)
45   `(cl:defmacro ,name ,(append prefix lambda-list) ,@body))
46
47
48 (define-special-operator (function name) (&whole form &environment env)
49   (cl:if (and (consp name)
50               (eq 'lambda (first name)))
51     (step-simple-form (step-expression name env) form)
52     (step-simple-form `(cl:function ,name)       form)))
53
54
55 (define-special-operator (quote literal) (&whole form)
56   (step-simple-form `(cl:quote ,literal) form))
57
58
59 (define-special-operator (if test then &optional (else nil elsep)) (&whole form &environment env)
60   (simple-step `(cl:if ,(step-expression test env)
61                   ,(step-expression then env)
62                   ,(step-expression else env))
63                form))
64
65
66 (define-special-operator (block name &body body) (&whole form &environment env)
67   (simple-step `(cl:block ,name
68                   ,@(step-body :progn body env))
69                form))
70
71
72 (define-special-operator (return-from name &optional result) (&whole form &environment env)
73   (simple-step `(cl:return-from ,name ,(step-expression result env))
74                form))
75
76
77 (define-special-operator (catch object &body body) (&whole form &environment env)
78   (simple-step `(cl:catch ,(step-expression object env)
79                   ,@(step-body :progn body env))
80                form))
81
82
83 (define-special-operator (throw object result) (&whole form &environment env)
84   (simple-step `(cl:throw ,(step-expression object env) ,(step-expression result env))
85                form))
86
87
88 (define-special-operator (unwind-protect protected &body cleanup) (&whole form &environment env)
89   (simple-step `(cl:unwind-protect ,(step-expression protected env)
90                   ,@(step-body :progn cleanup env))
91                form))
92
93
94 (define-special-operator (tagbody &body body) (&whole form &environment env)
95   (simple-step `(cl:tagbody
96                    ,@(mapcan (cl:lambda (form)
97                                  (cl:if (or (symbolp form) (integerp form))
98                                    (list form
99                                          `(did-tag ',form))
100                                    (list (step-expression form env))))
101                              body))
102                form))
103
104
105 (define-special-operator (go tag) (&whole form)
106   (simple-step `(cl:go ,tag) form))
107
108
109 (define-special-operator (flet (&rest bindings) &body body) (&whole form &environment env)
110   (multiple-value-bind (ds declarations real-body) (parse-body :locally body)
111     (declare (ignore ds real-body))
112     (cl:if (stepper-declaration-p declarations 'disable)
113       (step-disabled form)
114       (simple-step
115        `(cl:flet ,(mapcar (cl:lambda (fun)
116                               (destructuring-bind (name lambda-list &body body) fun
117                                 `(,name ,lambda-list
118                                         ,@(step-function :ordinary name lambda-list body env))))
119                           bindings)
120           ,@(step-body :locally body env))
121        form))))
122
123 (define-special-operator (labels (&rest bindings) &body body) (&whole form &environment env)
124   (multiple-value-bind (ds declarations real-body) (parse-body :locally body)
125     (declare (ignore ds real-body))
126     (cl:if (stepper-declaration-p declarations 'disable)
127       (step-disabled form)
128       (simple-step
129        `(cl:labels ,(mapcar (cl:lambda (fun)
130                                 (destructuring-bind (name lambda-list &body body) fun
131                                   `(,name ,lambda-list
132                                           ,@(step-function :ordinary name lambda-list body env))))
133                             bindings)
134           ,@(step-body :locally body env))
135        form))))
136
137
138 (define-special-operator (setq var val &rest pairs) (&environment env)
139   (cond
140     ((null pairs)
141      (cl:if (eql var (macroexpand var env))
142        (simple-step `(cl:setq ,var ,(step-expression val env))
143                     `(setq ,var ,val))
144        (simple-step (macroexpand `(setf ,var ,val) env)
145                     `(setq ,var ,val))))
146     ((oddp (length pairs))
147      (error "An odd number of arguments given to SETQ in ~S" `(setq ,var ,val ,pairs)))
148     (t
149      `(cl:progn
150         ,(macroexpand `(setq ,var ,val) env)
151         ,@(loop
152             :for (var val) :on pairs :by (function cddr)
153             :collect (macroexpand `(setq ,var ,val) env))))))
154
155
156
157 (define-special-operator (let (&rest bindings) &body body) (&whole form &environment env)
158   (multiple-value-bind (ds declarations body) (parse-body :locally body)
159     (declare (ignore ds))
160     (cl:if (stepper-declaration-p declarations 'disabled)
161       (step-disabled form)
162       (simple-step `(cl:let ,(step-bindings :parallel bindings form env)
163                       ;; TODO: When we did-bind the variable, they should not be declared ignore
164                       ;;       so replace those declarations by ignorable.
165                       ,@(substitute-ignorable declarations)
166                       (unless (eq *step-mode* :run)
167                         ,@(mapcar (cl:lambda (binding)
168                                       (cl:let ((var (cl:if (atom binding)
169                                                       binding
170                                                       (first binding))))
171                                         `(did-bind ',var ,var)))
172                                   bindings))
173                       ,@(step-body :progn body env))
174                    form))))
175
176
177 (define-special-operator (let* (&rest bindings) &body body) (&whole form &environment env)
178   (multiple-value-bind (ds declarations real-body) (parse-body :locally body)
179     (declare (ignore ds real-body))
180     (cl:if (stepper-declaration-p declarations 'disabled)
181       (step-disabled form)
182       (simple-step `(cl:let* ,(step-bindings :sequential bindings form env)
183                       ,@(step-body :locally body env))
184                    form))))
185
186
187 (define-special-operator (multiple-value-call  function-form &rest arguments) (&whole form &environment env)
188   (simple-step
189    `(apply ,(step-expression function-form env)
190            (append ,@(mapcar (cl:lambda (argument)
191                                  `(cl:multiple-value-list ,(step-expression argument env)))
192                              arguments)))
193    form))
194
195
196 (define-special-operator (multiple-value-prog1 result-form &body body) (&whole form &environment env)
197   (cl:let ((result (gensym)))
198     (simple-step
199      `(cl:let ((,result (cl:multiple-value-list ,(step-expression result-form env))))
200         ,@(step-body :progn body env)
201         (values-list ,result))
202      form)))
203
204
205 (define-special-operator (progn &body body) (&environment env)
206   ;; We must preserve toplevelness.
207   `(cl:progn
208      ,@(step-body :progn body env)))
209
210
211 (define-special-operator (progv symbols values &body body) (&whole form &environment env)
212   (cl:let ((vsym (gensym))
213            (vval (gensym)))
214     (simple-step `(cl:let ((,vsym  ,(step-expression symbols env))
215                            (,vval  ,(step-expression values env)))
216                     (cl:progv ,vsym ,vval
217                       (mapc (cl:function did-bind) ,vsym ,vval)
218                       ,@(step-body :progn body env)))
219                  form)))
220
221
222 (define-special-operator (locally &body body) (&whole form &environment env)
223   (multiple-value-bind (ds declarations real-body) (parse-body :locally body)
224     (declare (ignore ds real-body))
225     (cl:if (stepper-declaration-p declarations 'disabled)
226       (step-disabled form)
227       ;; We must preserve toplevelness.
228       `(cl:locally ,@(step-body :locally body env)))))
229
230
231
232 (define-special-operator (the value-type expression) (&environment env)
233   ;; TODO: Check the semantics of (the (values t) (values 1 2 3))
234   ;;       --> It seems (values t) == (VALUES INTEGER &REST T)
235   ;; TODO: Handle (values &rest) in value-type.
236   (cl:let ((results (gensym))
237            (temp    (gensym)))
238     (simple-step
239      `(cl:let ((,results (cl:multiple-value-list ,(step-expression expression env))))
240         ,(cl:if (and (listp value-type)
241                      (eq 'values (first value-type)))
242                 `(cl:let ((,temp ,results))
243                    ,@(mapcar (cl:lambda (value-type)
244                                  `(check-type (pop ,temp) ,value-type))
245                              (rest value-type)))
246                 `(check-type ,(first results) ,value-type))
247         (cl:the ,value-type (values-list ,results)))
248      `(the ,value-type ,expression))))
249
250
251 (define-special-operator (eval-when (&rest situations) &body body) (&environment env)
252   ;; We must preserve toplevelness.
253   `(cl:eval-when (,@situations)
254      ,@(step-body :progn body env)))
255
256
257 (define-special-operator (symbol-macrolet (&rest bindings) &body body) (&whole form &environment env)
258   (multiple-value-bind (ds declarations real-body) (parse-body :locally body)
259     (declare (ignore ds real-body))
260     (cl:if (stepper-declaration-p declarations 'disabled)
261       (step-disabled form)
262       (simple-step `(cl:symbol-macrolet ,bindings
263                       ,@(step-body :locally body env))
264                    form))))
265
266 (define-special-operator (macrolet (&rest bindings) &body body) (&whole form &environment env)
267   (multiple-value-bind (ds declarations real-body) (parse-body :locally body)
268     (declare (ignore ds real-body))
269     (cl:if (stepper-declaration-p declarations 'disabled)
270       (step-disabled form)
271       (simple-step `(cl:macrolet ,bindings
272                         ,@(step-body :locally body env))
273                    form))))
274
275 (define-special-operator (load-time-value expression &optional read-only-p) (&whole form &environment env)
276   (simple-step `(cl:load-time-value ,(step-expression expression env) ,read-only-p)
277                form))
278
279
280
281
282 ;;;----------------------------------------------------------------------
283 ;;;
284 ;;; Macros
285 ;;;
286
287 (cl:defmacro defun (name lambda-list &body body &environment env)
288   `(cl:defun ,name ,lambda-list
289      ,@(step-function :ordinary name lambda-list body env)))
290
291
292 (cl:defmacro defgeneric (name lambda-list &rest options &environment env)
293   `(cl:defgeneric ,name ,lambda-list
294      ,@(mapcar (cl:lambda (option)
295                    (cl:if (and (consp option)
296                                (eq :method (car option)))
297                      (cl:let* ((arguments (rest option))
298                                (qualifiers (loop
299                                              :while (not (listp (first arguments)))
300                                              :collect (pop arguments))))
301                        (destructuring-bind (lambda-list &body body) arguments
302                          `(:method ,@qualifiers ,lambda-list
303                                    ,@(step-function :specialized name lambda-list body env))))
304                      option))
305                options)))
306
307
308 (cl:defmacro defmethod (name &rest arguments &environment env)
309   (cl:let ((qualifiers (loop
310                          :while (not (listp (first arguments)))
311                          :collect (pop arguments))))
312     (destructuring-bind (lambda-list &body body) arguments
313       `(cl:defmethod ,name ,@qualifiers ,lambda-list
314                      ,@(step-function :specialized name lambda-list body env)))))
315
316
317 (cl:defmacro lambda (&whole form &environment env lambda-list &body body)
318   (declare (ignorable lambda-list body))
319   (simple-step `(cl:function ,(step-lambda form :environment env))
320                form))
321
322 (cl:defmacro define-condition (&whole form &environment env name parent slots &rest options)
323   (simple-step
324    `(cl:define-condition ,name ,parent
325       ,slots
326       ,@(mapcar (cl:lambda (option)
327                     (cl:if (and (consp option) (eq :report (car option)))
328                       `(:report
329                         ,(step-lambda (second option) :environment env))
330                       option))
331                 options))
332    form))
333
334
335 ;;;----------------------------------------------------------------------
336 ;;;
337 ;;; Stepper
338 ;;;
339
340 (cl:defmacro step (form &optional (mode :step) &environment env)
341   `(cl:catch 'abort-stepping
342      (cl:let ((*step-mode* ,mode)
343               (*step-package* *package*))
344        ,(step-expression form env))))
345
346
347
348
349 ;; ;; Let's forward the class:
350 ;; 
351 ;; (defclass function (cl:function)
352 ;;   ())
353 ;;
354 ;; Doesn't work because of missing built-in meta-class.
355 ;; And subclassing a built-in class is not conforming.
356
357 ;;;; the END ;;;;