Added some notes.
[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 (defpackage "COM.INFORMATIMAGO.COMMON-LISP.LISP.STEPPER"
36   (:use "COMMON-LISP"
37         "COM.INFORMATIMAGO.COMMON-LISP.LISP-SEXP.SOURCE-FORM")
38   (:nicknames "STEPPER")
39   (:shadow "FUNCTION-LAMBDA-EXPRESSION" "MACRO-FUNCTION" "COMPILER-MACRO-FUNCTION")
40   (:shadow "STEP")
41   (:export "STEP")
42   (:documentation "
43 Implements a Common Lisp stepper.
44 "))
45 (in-package "COM.INFORMATIMAGO.COMMON-LISP.LISP.STEPPER")
46
47
48 #|Random notes.
49
50 Note
51 ====
52
53 The term "to trace" here doen't mean CL:TRACE, but executing forms
54 while printing each subexpressions before evaluating them and printing
55 their results once they return (or informing of a non-local exit).
56 The same printing is done while stepping, but interrupted by user
57 interaction to let him decide what to do next (step into, step over,
58 trace or "run").
59
60 The terms "to run" here means to evaluate the form (or the remaining
61 of the evaluation of the form) without printing any trace.
62
63 Whenever breakpoints are implemented however, tracing and running
64 would stop at the next breakpoint encountered.
65
66
67
68 Principle of operation
69 ======================
70
71
72 Since we don't have yet the infrastructure to manage editing units
73 (text source along with sexp source, etc), we'll take a few shortcuts.
74
75 The main problem is to get at the source sexp for the functions and
76 methods to be stepped and traced.  For this, we cannot count on
77 ``function-lambda-expression``, and it would be largely insufficient
78 anyways: we want to implement the CL:STEP API allowing to step into a
79 toplevel or stand-alone form, and we may want to trace or step into
80 the loading of a lisp file too.
81
82
83 Eager Option
84 ------------
85
86 In the eager option, we instrument all the toplevel forms we read as
87 soon as we read them.
88
89 - we need to implement a LOAD function.
90 - difficulties with ASDF which tries to compile everything first, so:
91 - we need to implement a COMPILE-FILE function too.
92 - and of course, we may want to provide a REPL (⚠ slime).
93
94
95 Lazy Option
96 -----------
97
98 In the lazy option, we only instrument the forms and the functions or
99 methods needed to perform he stepping or tracing.  This require
100 keeping around the source forms.  This can be done by IBCL.
101
102 But IBCL only keeps the source of predefined macros (a subset of the
103 CL def* macros), so we may miss user defined macros
104 (define-such-and-such…), unless they expand to CL def* macros.
105
106 A macro that would expand to something like: ::
107
108     (progn
109       (setf (gethash 'some-key *some-hash*) (some-object (lambda () 'some-code)))
110       (defun something ()
111         'some-code))
112
113 would instrument the function ``something``, but not the anonymous
114 function or code possibly returned by the ``some-object`` function.
115
116
117 Problems
118 ----------
119
120 In ccl, a macro like cl:defmethod expands to implementation specific
121 special operators (ccl:nfunction) or even, to calls to internal
122 functions passing lambda expressions or other code chunks as data.
123 This would prevent their instrumenting by IBCL-like macros.
124
125
126 |#
127 ;;;----------------------------------------------------------------------
128 ;;;
129 ;;; Environment
130 ;;;
131
132
133 ;; variable symbol-macro constant
134 ;; function macro special-operator compiler-macro 
135 ;; declare
136 ;; block
137 ;; tag
138
139 (defclass binding ()
140   ((name :initarg :name :accessor binding-name
141          :documentation "A name.  Usually a symbol or a list (SETF name).
142 Binding names are compared with EQUAL.")))
143
144
145
146 (defclass var-space-binding (binding)
147   ())
148
149 (defclass variable-binding (var-space-binding)
150   ((value    :initarg :value   :accessor variable-value)
151    (specialp :initarg :special :initform nil            :reader variable-special-p)))
152
153 (defclass constant-binding (variable-binding)
154   ())
155
156 (defclass symbol-macro-binding (var-space-binding)
157   ((expansion :initarg :expansion :accessor symbol-macro-expansion)))
158
159
160
161 (defclass fun-space-binding (binding)
162   ())
163
164 (defclass function-binding (fun-space-binding)
165   ((lambda-expression :initarg :lambda-expression :accessor function-lambda-expression)))
166
167 (defclass macro-binding (fun-space-binding)
168   ((function  :initarg :function :accessor macro-function)))
169
170 (defclass compiler-macro-binding (fun-space-binding)
171   ((function  :initarg :function :accessor compiler-macro-function)))
172
173 (defclass special-operator (fun-space-binding)
174   ())
175
176
177 (defclass tag-binding (binding)
178   ()
179   (:documentation "This binds a go tag (symbol or integer)."))
180
181
182 (defclass block-binding (binding)
183   ()
184   (:documentation "This binds a symbol to a block."))
185
186
187
188 (defclass environment ()
189   ((next        :initform nil :accessor environment-next      :initarg :next)
190    (var-space   :initform '() :accessor environment-var-space)
191    (fun-space   :initform '() :accessor environment-fun-space)
192    (tag-space   :initform '() :accessor environment-tag-space)
193    (block-space :initform '() :accessor environment-block-space)))
194
195
196 (defgeneric environment-depth (environment)
197   (:method ((env null))
198     0)
199   (:method ((env environment))
200     (1+ (environment-depth (environment-next env)))))
201
202
203
204
205 (defmethod print-object ((self binding) stream)
206   (print-unreadable-object (self stream :type t :identity t)
207     (format stream "~{~S~^ ~}" (list :name (binding-name self))))
208   self)
209
210 (defmethod print-object ((self variable-binding) stream)
211   (print-unreadable-object (self stream :type t :identity t)
212     (format stream "~{~S~^ ~}" (list :name (binding-name self)
213                                      :value (if (slot-boundp self 'value)
214                                               (variable-value self)
215                                               :#<UNBOUND>)
216                                      :specialp (variable-special-p self))))
217   self)
218
219 (defmethod print-object ((self symbol-macro-binding) stream)
220   (print-unreadable-object (self stream :type t :identity t)
221     (format stream "~{~S~^ ~}" (list :name (binding-name self)
222                                      :expansion (symbol-macro-expansion self))))
223   self)
224
225 (defmethod print-object ((self environment) stream)
226   (print-unreadable-object (self stream :type t :identity t)
227     (format stream "~{~S~^ ~}"
228             (list :depth (environment-depth self)
229                   :var-space-count   (length (environment-var-space self))
230                   :fun-space-count   (length (environment-fun-space self))
231                   :tag-space-count   (length (environment-tag-space self))
232                   :block-space-count (length (environment-block-space self)))))
233   self)
234
235
236
237
238
239 (defparameter *global-environment* (make-instance 'environment))
240
241
242 (define-condition duplicate-binding-error (error)
243   ((space       :initarg :space       :reader duplicate-binding-space)
244    (old-binding :initarg :old-binding :reader duplicate-binding-old-binding)
245    (new-binding :initarg :new-binding :reader duplicate-binding-new-binding))
246   (:report (lambda (condition stream)
247                (format stream "Duplicate ~(~A~) binding: old = ~S ; new = ~S"
248                        (duplicate-binding-space       condition)
249                        (duplicate-binding-old-binding condition)
250                        (duplicate-binding-new-binding condition)))))
251
252
253
254 (defun %add-binding (new env space old-bindings adder)
255   (let ((old (find (binding-name new) old-bindings
256                    :key (function binding-name)
257                    :test (function equal))))
258     (if old
259       (error 'duplicate-binding-error :space space
260              :old-binding old :new-binding new)
261       (funcall adder)))
262   env)
263
264
265 (defgeneric add-binding (binding environment)
266   (:documentation "
267
268 BINDING:        An instance of BINDING.
269
270 ENVIRONMENT:    An instance of ENVIRONMENT or NIL (denoting *GLOBAL-ENVIRONMENT*).
271
272 DO:             Adds the BINDING in the corresponding name space of
273                 ENVIRONMENT.  If there is already a binding with the
274                 same name in the same name space, then a
275                 DUPLICATE-BINDING-ERROR is signaled.
276
277 RETURN:         The environment denoted by ENVIRONMENT.
278 ")
279   (:method (binding (env null))
280     (declare (ignorable env))
281     (add-binding binding *global-environment*))
282   (:method ((binding var-space-binding) (env environment))
283     (%add-binding binding env
284                   :variable (environment-var-space env)
285                   (lambda () (push binding (environment-var-space env)))))
286   (:method ((binding fun-space-binding) (env environment))
287     (%add-binding binding env
288                   :function (environment-fun-space env)
289                   (lambda () (push binding (environment-fun-space env)))))
290   (:method ((binding tag-binding) (env environment))
291     (%add-binding binding env
292                   :tag (environment-tag-space env)
293                   (lambda () (push binding (environment-tag-space env)))))
294   (:method ((binding block-binding) (env environment))
295     (%add-binding binding env
296                   :block (environment-block-space env)
297                   (lambda () (push binding (environment-block-space env))))))
298
299
300 (defgeneric find-binding-1 (space name environment)
301   (:documentation "
302
303 SPACE:          One of: :VAR-SPACE :FUN-SPACE, or :VARIABLE :CONSTANT
304                 :SYMBOL-MACRO :FUNCTION :MACRO :COMPILER-MACRO
305                 :SPECIAL-OPERATOR.
306
307 NAME:           A binding name.
308
309 ENVIRONMENT:    An instance of ENVIRONMENT or NIL (denoting *GLOBAL-ENVIRONMENT*).
310
311 DO:             Finds in the ENVIRONMENT (not the next ones) a binding
312                 with the same NAME in the name space indicated by
313                 SPACE.  If SPACE is not :VAR-SPACE or :FUN-SPACE then
314                 the type of the binding found is checked before
315                 returning the binding.
316
317 RETURN:         A binding named NAME in the name space SPACE of the
318                 ENVIRONMENT, or NIL if none is found.
319
320 ")
321   (:method (space name (env null))
322     (find-binding-1 space name *global-environment*))
323   (:method (space name (env environment))
324     (let ((binding
325            (find name (ecase space
326                         ((:var-space :variable :constant :symbol-macro)
327                          (environment-var-space env))
328                         ((:fun-space :function :macro :compiler-macro :special-operator)
329                          (environment-fun-space env))
330                         ((:tag-space :tag)
331                          (environment-tag-space env))
332                         ((:block-space :block)
333                          (environment-block-space env)))
334                  :key (function binding-name)
335                  :test (function equal))))
336       (when binding
337         (case space
338           ((:variable)         (check-type binding variable-binding))
339           ((:constant)         (check-type binding constant-binding))
340           ((:symbol-macro)     (check-type binding symbol-macro-binding))
341           ((:function)         (check-type binding function-binding))
342           ((:macro)            (check-type binding macro-binding))
343           ((:compiler-macro)   (check-type binding compiler-macro-binding))
344           ((:special-operator) (check-type binding special-operator-binding))
345           ((:block)            (check-type binding block-binding))
346           ((:tag)              (check-type binding tag-binding)))
347         binding))))
348
349
350 (defgeneric find-binding (space name environment)
351   (:documentation "
352
353 SPACE:          One of: :VAR-SPACE :FUN-SPACE :TAG-SPACE :BLOCK-SPACE
354                 or one of :VARIABLE :CONSTANT :SYMBOL-MACRO :FUNCTION
355                 :MACRO :COMPILER-MACRO :SPECIAL-OPERATOR :TAG :BLOCK.
356
357 NAME:           A binding name.
358
359 ENVIRONMENT:    An instance of ENVIRONMENT or NIL (denoting *GLOBAL-ENVIRONMENT*).
360
361 DO:             Finds in the ENVIRONMENT or the next ones, a binding
362                 with the same NAME in the name space indicated by
363                 SPACE.  If SPACE is not :VAR-SPACE or :FUN-SPACE then
364                 the type of the binding found is checked before
365                 returning the binding.
366
367 RETURN:         A binding named NAME in the name space SPACE, or NIL
368                 if none is found.
369
370 ")
371   (:method (space name (env null))
372     (find-binding-1 space name *global-environment*))
373   (:method (space name (env environment))
374     (or (find-binding-1 space name env)
375         (find-binding space name (environment-next env)))))
376
377
378
379
380 #||
381
382 (add-binding (make-instance 'variable-binding :name 'x :value 42) nil)
383 (add-binding (make-instance 'variable-binding :name 'z :value #c(15 3)) nil)
384 (add-binding (make-instance 'macro-binding :name 'm
385 :function (lambda (whole environment)
386 (declare (ignorable environment))
387 (block m
388 (destructuring-bind (macro-name &rest args) whole
389 (declare (ignorable macro-name))
390 `(progn ,@args)))))
391 nil)
392
393 (let ((env (make-instance 'environment)))
394 (add-binding (make-instance 'function-binding
395 :name 'm
396 :lambda-expression '(lambda (x)
397 (block 'm (list 'm x 'm))))
398 env)
399 (list *global-environment*
400 (find-binding   :fun-space 'm nil)
401 (find-binding   :fun-space 'm env)
402 (find-binding-1 :var-space 'x nil)
403 (find-binding-1 :var-space 'x env)
404 (find-binding   :var-space 'x env)))
405 (#<environment :depth 1 :var-space-count 2 :fun-space-count 1 #x302001DF04BD>
406 #<macro-binding :name m #x302001E2E0BD>
407 #<function-binding :name m #x30200204F0CD>
408 #1=#<variable-binding :name x :value 42 :specialp nil #x302001E2F8CD>
409 nil
410 #1#)
411
412 ||#
413
414
415 (defun extend-environment (environment &key var-space fun-space tag-space block-space)
416   (let ((env (make-instance 'environment
417                :next environment)))
418     (dolist (var var-space)
419       (add-binding var env))
420     (dolist (fun fun-space)
421       (add-binding fun env))
422     (dolist (tag tag-space)
423       (add-binding tag env))
424     (dolist (block block-space)
425       (add-binding block env))
426     env))
427
428
429
430
431 (defgeneric uncompile-global (object)
432   
433   (:method ((self variable-binding))
434     (if (variable-special-p self)
435       (if (slot-boundp self 'value)
436         `(defparameter ,(binding-name self) ,(list 'quote (variable-value self)))
437         `(defvar ,(binding-name self)))
438       `(deflexical ,(binding-name self)
439            ,@(if (slot-boundp self 'value)
440                  (list (list 'quote (variable-value self)))))))
441   
442   (:method ((self constant-binding))
443     `(defconstant ,(binding-name self) ,(list 'quote (selfiable-value self))))
444   
445   (:method ((self symbol-macro-binding))
446     `(define-symbol-macro ,(binding-name self) ,(symbol-macro-expansion self)))
447
448   (:method ((self function-binding))
449     (destructuring-bind (lambada lambda-list (blog name &body body))
450         (function-lambda-expression self)
451       (declare (ignore lambada blog name))
452       `(defun ,(binding-name self) ,lambda-list ,@body)))
453
454   (:method ((self macro-binding))
455     (destructuring-bind (lambada lambda-list (blog name &body body))
456         (function-lambda-expression self)
457       (declare (ignore lambada blog name))
458       `(defun ,(binding-name self) ,lambda-list ,@body)))
459
460   )
461
462
463
464
465
466
467 ;; (uncompile-global (find-binding :var-space 'x nil))
468 ;; (deflexical x '42)
469
470
471
472 (defgeneric uncompile-environment (enviroment)
473   (:method ((env null))
474     ()
475     (uncompile-environment *global-environment*))
476   (:method ((env environment))
477     ()
478     ))
479
480 ;; (find-binding :fun-space 'm
481 ;;               (extend-environment
482 ;;                (extend-environment
483 ;;                 (extend-environment
484 ;;                  nil
485 ;;                  :fun-space (list
486 ;;                              (make-instance 'function-binding
487 ;;                                :name 'f
488 ;;                                :lambda-expression '(lambda () (block f :outer)))
489 ;;                              (make-instance 'function-binding
490 ;;                                :name 'g
491 ;;                                :lambda-expression '(lambda () (block g :outer)))
492 ;;                              (make-instance 'function-binding
493 ;;                                :name 'm
494 ;;                                :lambda-expression '(lambda () (block m :outer)))))
495 ;;                 :fun-space (list
496 ;;                             (make-instance 'macro-binding
497 ;;                               :name 'm
498 ;;                               :function (cl:macro-function (defmacro m (&args)
499 ;;                                                              `(progn ,args))))))
500 ;;                :fun-space (list
501 ;;                            (make-instance 'function-binding
502 ;;                              :name 'g
503 ;;                              :lambda-expression '(lambda () (block g :inner))))))
504
505
506 (defun macro-function-p (name env)
507   (let* ((env (or env *global-environment*))
508          (binding (find-binding :fun-space name env)))
509     (cond
510       ((null binding)
511        (cl:macro-function name))
512       ((typep binding 'macro-binding)
513        binding))))
514
515
516
517 ;;;----------------------------------------------------------------------
518 ;;;
519 ;;; Stepping & Tracing
520 ;;;
521
522
523 (defvar *eval-step-mode* :trace
524   "May be :run, :trace or :step.
525
526 :run     don't print anything, just evaluate the forms.  
527
528 :trace   just prints the forms and their results as they are evaluted.
529
530 :step    prints the form, then ask the user what to do (step over,
531          step into, trace, run).
532
533 When break-points are implemented, :run and :trace will run until a
534 break-point is reached.
535
536 ")
537
538
539 (defvar *eval-step-level* 0
540   "The level.")
541
542 (defun eval-will-step (form)
543   (format *trace-output* "~&~V<~>Will evaluate ~S~%" *eval-step-level* form))
544
545 (defun eval-print-results (results)
546   (when results
547     (let ((start "-->"))
548       (dolist (result results)
549         (format *trace-output* "~V<~>~A ~S~%" *eval-step-level* start result)
550         (setf start "   ")))))
551
552 (defun eval-did-step (form results)
553   (format *trace-output* "~&~V<~>Evaluation of ~S returned ~:[no result~;~R result~:P~]~%"
554           *eval-step-level* form results (length results))
555   (eval-print-results results))
556
557
558 (defun eval-choice (&optional thunk)
559   (when thunk (funcall thunk))
560   (format *query-io* "~V<~>Step Into (s, si, RET), Step over (so), Trace (t), Run (r), Abort (a, q)? "
561           *eval-step-level*)
562   (let ((answer (string-trim " " (read-line *query-io*))))
563     (cond
564       ((member answer '("" "s" "si") :test (function string-equal))
565        :step-into)
566       ((string-equal answer "so")
567        :step-over)
568       ((string-equal answer "t")
569        :trace)
570       ((string-equal answer "r")
571        :run)
572       ((member answer '("a" "q") :test (function string-equal))
573        :abort)
574       (t
575        (eval-choice form)))))
576
577
578
579 (defun call-eval-atom (thunk display-form)
580   (flet ((do-step ()
581            (eval-will-step display-form)
582            (let ((results (multiple-value-list (funcall thunk))))
583              (eval-did-step display-form results)
584              (values-list results))))
585     (case *eval-step-mode*
586       (:run
587        (funcall thunk))
588       (:trace
589        (do-step))
590       (:step
591        (ecase (eval-choice (lambda () (eval-will-step display-form)))
592          (:abort     (throw 'abort-stepping nil))
593          (:run       (setf *eval-step-mode* :run)   (funcall thunk))
594          (:trace     (setf *eval-step-mode* :trace) (do-step))
595          (:step-into (do-step))
596          (:step-over (do-step)))))))
597
598 (defun eval-atom (atom &optional (display-atom atom))
599   `(call-eval-atom (lambda () ,atom) ',display-atom))
600
601
602 (defun call-eval-step (thunk display-form)
603   (flet ((do-step ()
604            (eval-will-step display-form)
605            (let ((results (let ((*eval-step-level* (1+ *eval-step-level*)))
606                             (multiple-value-list (funcall thunk)))))
607              (eval-did-step display-form results)
608              (values-list results))))
609     (case *eval-step-mode*
610       (:run
611        (funcall thunk))
612       (:trace
613        (do-step))
614       (:step
615        (ecase (eval-choice (lambda () (eval-will-step display-form)))
616          (:abort  (throw 'abort-stepping nil))
617          (:run
618           (setf *eval-step-mode* :run)
619           (funcall thunk))
620          (:trace
621           (setf *eval-step-mode* :trace)
622           (do-step))
623          (:step-into
624           (do-step))
625          (:step-over
626           (let ((*eval-step-mode* :run))
627             (do-step))))))))
628
629 (defun eval-step (form &optional (display-form form))
630   (if (atom form)
631     `(call-eval-atom (lambda () ,form) ',display-form)
632     `(call-eval-step (lambda () ,form) ',display-form)))
633
634
635
636 (defun call-eval-step-function (name pnames pvals thunk)
637   (labels ((report-enter (out)
638              (format out "~&~V<~>Entering ~:[anonymous ~;~]function ~:*~:[~;~:*~S~]~%"
639                      *eval-step-level* name)
640              (loop :for pname :in pnames :for pval :in pvals :do
641                (format out "~V<~>  ~16A = ~S~%" *eval-step-level* pname pval)))
642            (report-exit (non-local-exit results)
643              (format *trace-output* "~&~V<~>Exiting  ~:[anonymous ~;~]function ~:*~:[~;~S ~]~
644                           ~:[returned ~:[no result~;~R result~:P~]~;by non-local exit.~]~%"
645                      *eval-step-level* name non-local-exit results (length results))
646              (eval-print-results results))
647            (do-step ()
648              (let ((non-local-exit t)
649                    (results '()))
650                (unwind-protect
651                    (progn (setf results (let ((*eval-step-level* (1+ *eval-step-level*)))
652                                              (multiple-value-list (funcall thunk)))
653                                 non-local-exit nil))
654                  (report-exit non-local-exit results))
655                (values-list results))))
656     (case *eval-step-mode*
657       (:run
658        (funcall thunk))
659       (:trace
660        (report-enter *trace-output*)
661        (do-step))
662       (:step
663        (ecase (eval-choice (lambda () (report-enter *query-io*)))
664          (:abort  (throw 'abort-stepping nil))
665          (:run
666           (setf *eval-step-mode* :run)
667           (funcall thunk))
668          (:trace
669           (setf *eval-step-mode* :trace)
670           (do-step))
671          (:step-into
672           (do-step))
673          (:step-over
674           (let ((*eval-step-mode* :run))
675             (do-step))))))))
676
677 (defun eval-step-lambda (env lambda-form &key (kind :ordinary) name)
678   "
679
680 ENV:            An environment.
681
682 LAMBDA-FORM:    A lambda form.
683
684 KIND:           A lambda-list kind (:ordinary for functions, :generic
685                 for generic functions, :specialized for methods,
686                 :destructuring for macros, etc).
687
688 NAME:           The name of the defined function or macro.
689
690 RETURN:         A stepping lambda-form from the LAMBDA-FORM.
691
692 "
693   (destructuring-bind (lambda lambda-list &body body) lambda-form
694     (let* ((parameters (mapcar (function parameter-name)
695                                (lambda-list-parameters
696                                 (parse-lambda-list lambda-list kind))))
697            (env (extend-environment env :var-space (mapcar
698                                                     (lambda (pname)
699                                                         (make-instance 'variable-binding
700                                                           :name pname))
701                                                     parameters)))
702            (non-local-exit (gensym)))
703       `(lambda ,lambda-list
704            (call-eval-step-function
705             ',name ',parameters (list ,@parameters)
706             (lambda () ,@(eval-step-body env body)))))))
707
708
709
710 (defun eval-step-body (env body)
711   (mapcar (lambda (form)
712               (eval-expression env form))
713           body))
714
715
716
717
718
719 ;;;----------------------------------------------------------------------
720 ;;;
721 ;;; Special operators
722 ;;;
723
724
725
726
727 (defparameter *special-operators* (make-hash-table))
728
729 (defmacro define-special-operator ((name &rest destructuring-lambda-list) (env) &body body)
730   (let ((vform (gensym)))
731     `(setf (gethash ',name *special-operators*)
732            (lambda (,env ,vform)
733                (declare (ignorable ,env))
734              (block ,name
735                (destructuring-bind (,name ,@destructuring-lambda-list) ,vform
736                  (declare (ignorable ,name))
737                  ,@body))))))
738
739 (defun call-special-operator (op env form)
740   (let ((fun (gethash op *special-operators*)))
741     (unless fun
742       (error "No such special operator ~S for form ~S" op form))
743     (funcall fun env form)))
744
745
746
747
748 (define-special-operator (function funame) (env)
749   (eval-step `(cl:function ,funame)
750              `(function ,funame)))
751
752
753 (define-special-operator (quote literal) (env)
754   (eval-step `(cl:quote ,literal)
755              `(quote ,literal)))
756
757
758 (define-special-operator (if test then &optional (else nil elsep)) (env)
759   (eval-step `(cl:if ,(eval-expression env test)
760                 ,(eval-expression env then)
761                 ,(eval-expression env else))
762              `(if ,test ,then ,@(when elsep (list else)))))
763
764
765 (define-special-operator (block name &body body) (env)
766   (let ((env (extend-environment env :block-space (list
767                                                    (make-instance 'block-binding
768                                                      :name name)))))
769     (eval-step `(cl:block ,name
770                   ,@(eval-step-body env body))
771                `(block ,name ,@body))))
772
773
774 (define-special-operator (return-from name &optional result) (env)
775   (if (find-binding :block name env)
776     (eval-step `(cl:return-from ,name ,(eval-expression env result))
777                `(return-from ,name ,result))
778     (error "~S but there's no block ~S in scope." `(return-from ,name ,result) name)))
779
780
781 (define-special-operator (catch object &body body) (env)
782   (eval-step `(cl:catch ,(eval-expression env object)
783                 ,@(eval-step-body env body))
784              `(catch ,object ,@body)))
785
786
787 (define-special-operator (throw object result) (env)
788   (eval-step `(cl:throw ,(eval-expression env object) ,(eval-expression env result))
789              `(throw ,object ,result)))
790
791
792 (define-special-operator (unwind-protect protected &body cleanup) (env)
793   (eval-step `(cl:unwind-protect ,(eval-expression env protected)
794                 ,@(eval-step-body env cleanup))
795              `(unwind-protect ,protected ,@cleanup)))
796
797
798 (define-special-operator (tagbody &body body) (env)
799   (let* ((tags (remove-if-not (lambda (item)
800                                   (or (symbolp item) (integerp item)))
801                               body))
802          (env (extend-environment env
803                                   :tag-space (mapcar (lambda (tag)
804                                                          (make-instance 'tag-binding :name tag))
805                                                      tags))))
806     (eval-step `(cl:tagbody
807                    ,@(mapcan (lambda (form)
808                                  (if (or (symbolp form) (integerp form))
809                                    `(,form
810                                       (trace-step "Passed tag ~S" ',form))
811                                    (list (eval-expression env form))))
812                              body))
813                `(tagbody ,@body))))
814
815
816 (define-special-operator (go tag) (env)
817   (if (find-binding :tag tag env)
818     (eval-step `(cl:go ,tag) `(go ,tag))
819     (error "~S but there's no tag ~S in scope." `(go ,tag) tag)))
820
821
822 (define-special-operator (flet (&rest bindings) &body body) (env)
823   ;; TODO:
824   (let* ((funs (mapcar (lambda (fun)
825                            (make-instance 'function-binding
826                              :name (first fun)
827                              :lambda-expression `(lambda (second fun)
828                                                      ;; get docstring and declarations from body here.
829                                                      (block ,(first fun)
830                                                        ;; body:
831                                                        ,@(rest (rest fun))))))
832                        bindings))
833          (env (extend-environment env :fun-space funs)))
834     (eval-step `(cl:flet ,bindings
835                   ,@(eval-step-body env body))
836                `(flet ,bindings ,@body))))
837
838 (define-special-operator (labels (&rest bindings) &body body) (env)
839   ;; TODO:
840   (eval-step `(cl:labels ,bindings
841                 ,@(eval-step-body env body))
842              `(labels ,bindings ,@body)))
843
844
845 (define-special-operator (setq var val &rest pairs) (env)
846   (cond
847     ((null pairs)
848      (let ((sm (find-binding :var-space var env)))
849        (if (typep sm 'symbol-macro-binding)
850          (call-special-operator 'setf env `(setf ,(symbol-macro-expansion sm) ,val))
851          (eval-step `(cl:setq ,var ,(eval-expression env val))
852                     `(setq ,var ,val)))))
853     ((oddp (length pairs))
854      (error "An odd number of arguments given to SETQ in ~S" `(setq ,var ,val ,pairs)))
855     (t
856      `(cl:progn
857         ,(call-special-operator 'setq env `(setq ,var ,val))
858         ,@(loop
859             :for (var val) :on pairs :by (function cddr)
860             :collect (call-special-operator 'setq env `(setq ,var ,val)))))))
861
862
863 (define-special-operator (let (&rest bindings) &body body) (env)
864   (if (null bindings)
865     (call-special-operator 'locally env `(locally ,@body))
866     (let* ((vars (mapcar (lambda (binding)
867                              (make-instance 'variable-binding
868                                :name (cond
869                                        ((symbolp binding)
870                                         binding)
871                                        ((atom binding)
872                                         (error "Invalid atom ~S in binding list of ~S"
873                                                binding `(let ,bindings ,@body)))
874                                        ((/= 2 (length bindings))
875                                         (error "Invalid binding ~S in binding list of ~S"
876                                                binding `(let ,bindings ,@body)))
877                                        (t
878                                         (first binding)))))
879                          bindings))
880            (new-env (extend-environment env :var-space vars)))
881       (eval-step `(cl:let ,(mapcar (lambda (binding)
882                                        (if (symbolp binding)
883                                          binding
884                                          `(,(first binding) ,(eval-step (second binding)))))
885                                    bindings)
886                     ,@(eval-step-body new-env body))
887                  `(cl:let ,bindings ,@body)))))
888
889
890 (define-special-operator (let* (&rest bindings) &body body) (env)
891   (if (null bindings)
892     (call-special-operator 'locally env `(locally ,@body))
893     (call-special-operator 'let env `(let (,(first bindings))
894                                        (let* (,(rest bindings))
895                                          ,@body)))))
896
897
898 (define-special-operator (multiple-value-call  function-form &rest arguments) (env)
899   (eval-step `(apply ,(eval-expression env function-form)
900                      (append ,@(mapcar (lambda (argument)
901                                            `(multiple-value-list ,(eval-expression env argument)))
902                                        arguments)))
903              `(multiple-value-call ,function-form ,@arguments)))
904
905
906 (define-special-operator (multiple-value-prog1 result-form &body body) (env)
907   (let ((result (gensym)))
908     (eval-step `(let ((,result (multiple-value-list ,(eval-expression env result-form))))
909                   ,@(eval-step-body body)
910                   (values-list ,result))
911                `(multiple-value-prog1 ,result-form ,@body))))
912
913
914 (define-special-operator (progn &body body) (env)
915   (eval-step `(cl:progn
916                 ,@(eval-step-body env body))
917              `(progn ,@body)))
918
919
920 (define-special-operator (progv symbols values &body body) (env)
921   )
922
923 (define-special-operator (locally &body body) (env)
924   (eval-step `(cl:locally
925                   ;; TODO: deal with declarations
926                   ,@(eval-step-body env body))
927              `(locally ,@body)))
928
929
930 (define-special-operator (the value-type expression) (env)
931   ;; TODO: Check the semantics of (the (values t) (values 1 2 3))
932   ;;       --> It seems (values t) == (VALUES INTEGER &REST T)
933   ;; TODO: Handle (values &rest) in value-type.
934   (let ((results (gensym))
935         (temp (gensym)))
936     (eval-step
937      `(cl:let ((results (cl:multiple-value-list ,(eval-expression env expression))))
938         ,(if (and (listp value-type)
939                   (eq 'values (first value-type)))
940              `(let ((,temp ,results))
941                 ,@(mapcar (lambda (value-type)
942                               `(check-type (pop ,temp) ,value-type))
943                           (rest value-type)))
944              `(check-type ,(first result) ,value-type))
945         (cl:the ,value-type (values-list ,results)))
946      `(the ,value-type ,expression))))
947
948
949 (define-special-operator (eval-when (&rest situations) &body body) (env)
950   (eval-step `(cl:eval-when (,@situations) ,@(eval-step-body env body))
951              `(eval-when (,@situations) ,@body)))
952
953
954 (define-special-operator (symbol-macrolet (&rest bindings) &body body) (env))
955  
956 (define-special-operator (macrolet (&rest bindings) &body body) (env))
957
958 (define-special-operator (load-time-value expression &optional read-only-p) (env))
959
960
961
962
963 (define-special-operator (symbol-reference symbol) (env)
964   (declare (ignore env)) ; for now
965   (let ((binding (find-binding :var-space symbol env)))
966     (etypecase binding
967       ((or null variable-binding)
968        (eval-atom symbol))
969       (symbol-macro-binding
970        (eval-atom symbol) ; for now.
971        ;; TODO: 
972        ;; (eval-expression env expansion)
973        ))))
974
975
976 (define-special-operator (self-evaluating object) (env)
977   (declare (ignore env))
978   (eval-atom object))
979
980
981 (define-special-operator (macro-call (macro-name &rest arguments)) (env)
982   ;; find macro function
983   ;; macroexpand
984   )
985
986
987
988
989
990
991
992
993 (define-special-operator (function-call (&whole form function-name &rest arguments)) (env)
994   (if (consp function-name)
995     (if (eq 'lambda (first function-name))
996       (eval-step `(,(eval-step-lambda env function-name)
997                     ,@(mapcar (lambda (argument) (eval-expression env argument))
998                               arguments))
999                  form)
1000       (error "Invalid object used as function name ~S in function call ~S"
1001              function-name form))
1002     (let ((binding (find-binding :fun-space function-name env)))
1003       (etypecase binding
1004         ((or null function-binding)
1005          (eval-step `(,function-name
1006                       ,@(mapcar (lambda (argument) (eval-expression env argument))
1007                                 arguments))
1008                     form))))))
1009
1010
1011
1012 #+ccl (define-special-operator (ccl:compiler-let (&rest bindings) &body body) (env)
1013         (call-special-operator 'let env `(let ,bindings ,@body)))
1014
1015
1016
1017 (defun eval-expression (env form)
1018   (cond
1019     ((symbolp form)
1020      (call-special-operator 'symbol-reference env `(symbol-reference ,form)))
1021     ;; The other atoms are unchanged:
1022     ((atom form)
1023      (call-special-operator 'self-evaluating env `(self-evaluating ,form)))
1024     ;; Now we have a list.  
1025     (t
1026      (case (first form)
1027        ;; First we check the special operators:
1028        ((block catch eval-when flet function go if labels let let*
1029                load-time-value locally macrolet multiple-value-call
1030                multiple-value-prog1 progn progv quote return-from setq
1031                symbol-macrolet tagbody the throw unwind-protect)
1032         (call-special-operator (first form) env form))
1033        (otherwise
1034         (if (macro-function-p (first form) env)
1035           (call-special-operator 'macro-call    env `(macro-call ,form))
1036           (call-special-operator 'function-call env `(function-call ,form))))))))
1037
1038
1039 ;;;----------------------------------------------------------------------
1040 ;;;
1041 ;;; Stepper
1042 ;;;
1043
1044 (defmacro step (form)
1045   `(catch 'abort-stepping
1046      ,(eval-expression nil `(progn ,form))))
1047
1048
1049
1050
1051 ;; (setf *print-circle* nil)
1052 ;; (eval-step-lambda nil '(lambda (a b &optional o &rest r &key k1 k2 ((kk3 k3) nil k3p) &aux a1 a2)))
1053 ;; (lambda (a b &optional o &rest r &key k1 k2 ((kk3 k3) nil k3p) &aux a1 a2)
1054 ;;     (call-eval-step-function 'nil '#1=(a b o r k1 k2 k3 a1 a2) (list . #1#) (lambda nil)))
1055 ;; 
1056 ;; (pprint (eval-step-lambda
1057 ;;          nil
1058 ;;          '(lambda (a b &optional o &rest r &key k1 k2 ((kk3 k3) nil k3p) &aux a1 a2)
1059 ;;            (let ((c 1) (b 2)) (if (< a b) (+ (* b 3) (truncate 10 3)) (print 'hello))))))
1060 ;; 
1061 ;; 
1062 ;; (lambda (a b &optional o &rest r &key k1 k2 ((kk3 k3) nil k3p) &aux a1 a2)
1063 ;;     (call-eval-step-function
1064 ;;      'nil
1065 ;;      '(a b o r k1 k2 k3 a1 a2)
1066 ;;      (list a b o r k1 k2 k3 a1 a2)
1067 ;;      (lambda nil
1068 ;;          (call-eval-step
1069 ;;           (lambda nil
1070 ;;               (let ((c (call-eval-atom (lambda nil 1) '1)) (b (call-eval-atom (lambda nil 2) '2)))
1071 ;;                 (call-eval-step
1072 ;;                  (lambda nil
1073 ;;                      (if (call-eval-step
1074 ;;                           (lambda nil
1075 ;;                               (< (call-eval-atom (lambda nil a) 'a) (call-eval-atom (lambda nil b) 'b)))
1076 ;;                           '(< a b))
1077 ;;                        (call-eval-step
1078 ;;                         (lambda nil
1079 ;;                             (+ (call-eval-step
1080 ;;                                 (lambda nil
1081 ;;                                     (* (call-eval-atom (lambda nil b) 'b)
1082 ;;                                      (call-eval-atom (lambda nil 3) '3)))
1083 ;;                                 '(* b 3))
1084 ;;                              (call-eval-step
1085 ;;                               (lambda nil
1086 ;;                                   (truncate (call-eval-atom (lambda nil 10) '10)
1087 ;;                                    (call-eval-atom (lambda nil 3) '3)))
1088 ;;                               '(truncate 10 3))))
1089 ;;                         '(+ (* b 3) (truncate 10 3)))
1090 ;;                        (call-eval-step
1091 ;;                         (lambda nil (print (call-eval-step (lambda nil 'hello) ''hello)))
1092 ;;                         '(print 'hello))))
1093 ;;                  '(if (< a b) (+ (* b 3) (truncate 10 3)) (print 'hello)))))
1094 ;;           '(let ((c 1) (b 2)) (if (< a b) (+ (* b 3) (truncate 10 3)) (print 'hello)))))))
1095
1096 ;;;; THE END ;;;;