1 ;;;; An interpreting EVAL
3 ;;;; This software is part of the SBCL system. See the README file for
6 ;;;; This software is derived from the CMU CL system, which was
7 ;;;; written at Carnegie Mellon University and released into the
8 ;;;; public domain. The software is in the public domain and is
9 ;;;; provided with absolutely no warranty. See the COPYING and CREDITS
10 ;;;; files for more information.
12 (in-package "SB!EVAL")
14 ;; (declaim (optimize (speed 3) (debug 1) (safety 1)))
16 ;;; Values used for marking specials/macros/etc in environments.
17 (defvar *special
* (gensym "SPECIAL"))
18 (defvar *macro
* (gensym "MACRO"))
19 (defvar *symbol-macro
* (gensym "SYMBOL-MACRO"))
20 (defvar *not-present
* (gensym "NOT-PRESENT"))
22 (define-condition interpreted-program-error
(program-error simple-condition sb
!impl
::encapsulated-condition
)
24 (:report
(lambda (condition stream
)
25 (if (slot-boundp condition
'condition
)
27 (format stream
"Error evaluating a form:~% ~A"
28 (sb!impl
::encapsulated-condition condition
)))
29 (format stream
"Error evaluating a form:~% ~?"
30 (simple-condition-format-control condition
)
31 (simple-condition-format-arguments condition
))))))
33 ;;; ANSI defines that program syntax errors should be of type
34 ;;; PROGRAM-ERROR. Therefore...
35 (define-condition arg-count-program-error
(sb!kernel
::arg-count-error
39 (defun arg-count-program-error (datum &rest arguments
)
40 (declare (ignore datum
))
41 (apply #'error
'arg-count-program-error arguments
))
43 ;; OAOOM? (see destructuring-bind.lisp)
44 (defmacro program-destructuring-bind
(lambda-list arg-list
&body body
)
45 (let ((arg-list-name (gensym "ARG-LIST-")))
46 (multiple-value-bind (body local-decls
)
47 (sb!kernel
:parse-defmacro lambda-list arg-list-name body nil
48 'program-destructuring-bind
50 :doc-string-allowed nil
52 :error-fun
'arg-count-program-error
)
53 `(let ((,arg-list-name
,arg-list
))
57 (defun ip-error (format-control &rest format-arguments
)
58 (error 'interpreted-program-error
59 :format-control format-control
60 :format-arguments format-arguments
))
62 (defmacro nconc-2
(a b
)
68 (progn (setf (cdr (last ,tmp
)) ,tmp2
) ,tmp
)
71 ;;; Construct a compiler LEXENV from the same data that's used for
72 ;;; creating an interpreter ENV. This is needed for example when
73 ;;; passing the environment to macroexpanders or when compiling an
74 ;;; interpreted function.
75 (defun fabricate-new-native-environment (old-lexenv new-funs new-expanders
76 new-vars new-symbol-expansions
78 (labels ((to-native-funs (binding)
79 ;; Non-macroexpander function entries are irrelevant for
80 ;; the LEXENV. If we're using the LEXENV for
81 ;; macro-expansion any references to local non-macro
82 ;; function bindings are undefined behaviour. If we're
83 ;; compiling an interpreted function, a lexical environment
84 ;; with non-macro functions will be too hairy to compile.
85 (if (eq (cdr binding
) *macro
*)
88 (cdr (assoc (car binding
) new-expanders
))))
91 (to-native-vars (binding)
92 ;; And likewise for symbol macros.
93 (if (eq (cdr binding
) *symbol-macro
*)
96 (cdr (assoc (car binding
) new-symbol-expansions
))))
99 (let ((lexenv (sb!c
::internal-make-lexenv
100 (nconc-2 (mapcar #'to-native-funs new-funs
)
101 (sb!c
::lexenv-funs old-lexenv
))
102 (nconc-2 (mapcar #'to-native-vars new-vars
)
103 (sb!c
::lexenv-vars old-lexenv
))
105 (sb!c
::lexenv-handled-conditions old-lexenv
)
106 (sb!c
::lexenv-disabled-package-locks old-lexenv
)
107 (sb!c
::lexenv-policy old-lexenv
)
108 (sb!c
::lexenv-user-data old-lexenv
))))
109 (dolist (declaration declarations
)
110 (unless (consp declaration
)
111 (ip-error "malformed declaration specifier ~S in ~S"
112 declaration
(cons 'declare declarations
)))
113 (case (car declaration
)
115 (dolist (element (cdr declaration
))
116 (multiple-value-bind (quality value
)
117 (if (not (consp element
))
119 (program-destructuring-bind (quality value
)
121 (values quality value
)))
122 (if (sb!c
::policy-quality-name-p quality
)
123 (push (cons quality value
)
124 (sb!c
::lexenv-%policy lexenv
))
125 (warn "ignoring unknown optimization quality ~
127 (cons 'declare declarations
))))))
128 (sb!ext
:muffle-conditions
129 (setf (sb!c
::lexenv-handled-conditions lexenv
)
130 (sb!c
::process-muffle-conditions-decl
132 (sb!c
::lexenv-handled-conditions lexenv
))))
133 (sb!ext
:unmuffle-conditions
134 (setf (sb!c
::lexenv-handled-conditions lexenv
)
135 (sb!c
::process-unmuffle-conditions-decl
137 (sb!c
::lexenv-handled-conditions lexenv
))))
138 ((sb!ext
:disable-package-locks sb
!ext
:enable-package-locks
)
139 (setf (sb!c
::lexenv-disabled-package-locks lexenv
)
140 (sb!c
::process-package-lock-decl
142 (sb!c
::lexenv-disabled-package-locks lexenv
))))))
146 (:constructor %make-env
147 (parent vars funs expanders symbol-expansions
148 tags blocks declarations native-lexenv
)))
159 (defun make-env (&key parent vars funs expanders
160 symbol-expansions tags blocks declarations
)
162 (append vars
(env-vars parent
))
163 (append funs
(env-funs parent
))
164 (append expanders
(env-expanders parent
))
165 (append symbol-expansions
(env-symbol-expansions parent
))
166 (nconc-2 tags
(env-tags parent
))
167 (nconc-2 blocks
(env-blocks parent
))
169 (fabricate-new-native-environment (env-native-lexenv parent
)
171 vars symbol-expansions
174 (defun make-null-environment ()
175 (%make-env nil nil nil nil nil nil nil nil
176 (sb!c
::internal-make-lexenv
178 nil nil nil nil nil nil nil
182 ;;; Augment ENV with a special or lexical variable binding
183 (declaim (inline push-var
))
184 (defun push-var (name value env
)
185 (push (cons name value
) (env-vars env
))
186 (push (cons name
:bogus
) (sb!c
::lexenv-vars
(env-native-lexenv env
))))
188 ;;; Augment ENV with a local function binding
189 (declaim (inline push-fun
))
190 (defun push-fun (name value calling-env body-env
)
192 (let ((sb!c
:*lexenv
* (env-native-lexenv calling-env
)))
193 (program-assert-symbol-home-package-unlocked
194 :eval name
"binding ~A as a local function")))
195 (push (cons name value
) (env-funs body-env
))
196 (push (cons name
:bogus
) (sb!c
::lexenv-funs
(env-native-lexenv body-env
))))
198 (sb!int
:def
!method print-object
((env env
) stream
)
199 (print-unreadable-object (env stream
:type t
:identity t
)))
201 (macrolet ((define-get-binding (name accessor
&key
(test '#'eq
))
202 ;; A macro, sadly, because an inline function here is
204 `(defmacro ,name
(symbol env
)
205 `(assoc ,symbol
(,',accessor
,env
) :test
,',test
))))
206 (define-get-binding get-binding env-vars
)
207 (define-get-binding get-fbinding env-funs
:test
#'equal
)
208 (define-get-binding get-expander-binding env-expanders
)
209 (define-get-binding get-symbol-expansion-binding env-symbol-expansions
)
210 (define-get-binding get-tag-binding env-tags
:test
#'eql
)
211 (define-get-binding get-block-binding env-blocks
))
213 ;;; Return a list of all symbols that are declared special in the
214 ;;; declarations listen in DECLS.
215 (defun declared-specials (decls)
216 (let ((specials nil
))
218 (when (eql (car decl
) 'special
)
219 (dolist (var (cdr decl
))
220 (push var specials
))))
223 ;;; Given a list of variables that should be marked as special in an
224 ;;; environment, return the appropriate binding forms to be given
226 (defun special-bindings (specials env
)
227 (mapcar #'(lambda (var)
228 (let ((sb!c
:*lexenv
* (env-native-lexenv env
)))
229 (program-assert-symbol-home-package-unlocked
230 :eval var
"declaring ~A special"))
231 (cons var
*special
*))
234 ;;; Return true if SYMBOL has been declared special either globally
235 ;;; or is in the DECLARED-SPECIALS list.
236 (defun specialp (symbol declared-specials
)
237 (let ((type (sb!int
:info
:variable
:kind symbol
)))
240 ;; Horrible place for this, but it works.
241 (ip-error "Can't bind constant symbol: ~S" symbol
))
244 (ip-error "Can't bind a global variable: ~S" symbol
))
245 ((eq type
:special
) t
)
246 ((member symbol declared-specials
:test
#'eq
)
250 (defun binding-name (binding)
251 (if (consp binding
) (first binding
) binding
))
252 (defun binding-value (binding)
253 (if (consp binding
) (second binding
) nil
))
254 (defun supplied-p-parameter (spec)
255 (if (consp spec
) (third spec
) nil
))
256 (defun keyword-name (spec)
258 (if (consp (first spec
))
259 (second (first spec
))
262 (defun keyword-key (spec)
264 (if (consp (first spec
))
266 (intern (symbol-name (first spec
)) "KEYWORD"))
267 (intern (symbol-name spec
) "KEYWORD")))
268 (defun keyword-default-value (spec)
269 (if (consp spec
) (second spec
) nil
))
271 ;;; Given a list of ARGUMENTS and a LAMBDA-LIST, return two values:
272 ;;; * An alist[*] mapping the required parameters of the function to
273 ;;; the corresponding argument values
274 ;;; * An alist mapping the keyword, optional and rest parameters of
275 ;;; the function to the corresponding argument values (if supplied)
276 ;;; or to the parameter's default expression (if not). Supplied-p
277 ;;; parameters and aux variables are handled in a similar manner.
279 ;;; For example given the argument list of (1 2) and the lambda-list of
280 ;;; (A &OPTIONAL (B A) (C (1+ A))), we'd return the values
281 ;;; (A . '1) and ((B . '2) (C . (1+ A))).
283 ;;; Used only for implementing calls to interpreted functions.
284 (defun parse-arguments (arguments lambda-list
)
285 (multiple-value-bind (required optional rest-p rest keyword-p
286 keyword allow-other-keys-p aux-p aux
)
287 (handler-bind ((style-warning #'muffle-warning
))
288 (sb!int
:parse-lambda-list lambda-list
))
289 (let* ((original-arguments arguments
)
290 (arguments-present (length arguments
))
291 (required-length (length required
))
292 (optional-length (length optional
))
293 (non-keyword-arguments (+ required-length optional-length
))
294 (optionals-present (- (min non-keyword-arguments arguments-present
)
296 (keywords-present-p (> arguments-present non-keyword-arguments
))
297 (let-like-bindings nil
)
298 (let*-like-bindings nil
))
300 ((< arguments-present required-length
)
301 (ip-error "~@<Too few arguments in ~S to satisfy lambda list ~S.~:@>"
302 arguments lambda-list
))
303 ((and (not (or rest-p keyword-p
)) keywords-present-p
)
304 (ip-error "~@<Too many arguments in ~S to satisfy lambda list ~S.~:@>"
305 arguments lambda-list
))
306 ((and keyword-p keywords-present-p
307 (oddp (- arguments-present non-keyword-arguments
)))
308 (ip-error "~@<Odd number of &KEY arguments in ~S for ~S.~:@>"
309 arguments lambda-list
)))
310 (dotimes (i required-length
)
311 (push (cons (pop required
) (pop arguments
)) let-like-bindings
))
312 (do ((optionals-parsed 0 (1+ optionals-parsed
)))
314 (let ((this-optional (pop optional
))
315 (supplied-p (< optionals-parsed optionals-present
)))
316 (push (cons (binding-name this-optional
)
318 (list 'quote
(pop arguments
))
319 (binding-value this-optional
)))
321 (when (supplied-p-parameter this-optional
)
322 (push (cons (supplied-p-parameter this-optional
)
323 (list 'quote supplied-p
))
324 let
*-like-bindings
))))
325 (let ((keyword-plist arguments
))
327 (push (cons rest
(list 'quote keyword-plist
)) let
*-like-bindings
))
329 (unless (or allow-other-keys-p
330 (getf keyword-plist
:allow-other-keys
))
331 (loop for
(key value
) on keyword-plist by
#'cddr doing
332 (when (and (not (eq key
:allow-other-keys
))
333 (not (member key keyword
:key
#'keyword-key
)))
334 (ip-error "~@<Unknown &KEY argument ~S in ~S for ~S.~:@>"
335 key original-arguments lambda-list
))))
336 (dolist (keyword-spec keyword
)
337 (let ((supplied (getf keyword-plist
(keyword-key keyword-spec
)
339 (push (cons (keyword-name keyword-spec
)
340 (if (eq supplied
*not-present
*)
341 (keyword-default-value keyword-spec
)
342 (list 'quote supplied
)))
344 (when (supplied-p-parameter keyword-spec
)
345 (push (cons (supplied-p-parameter keyword-spec
)
346 (list 'quote
(not (eq supplied
*not-present
*))))
347 let
*-like-bindings
))))))
351 (let ((this-aux (pop aux
)))
352 (push (cons (binding-name this-aux
)
353 (binding-value this-aux
))
354 let
*-like-bindings
))))
355 (values (nreverse let-like-bindings
) (nreverse let
*-like-bindings
)))))
357 ;;; Evaluate LET*-like (sequential) bindings.
359 ;;; Given an alist of BINDINGS, evaluate the value form of the first
360 ;;; binding in ENV, bind the variable to the value in ENV, and then
361 ;;; evaluate the next binding form. Once all binding forms have been
362 ;;; handled, END-ACTION is funcalled.
364 ;;; SPECIALS is a list of variables that have a bound special declaration.
365 ;;; These variables (and those that have been declaimed as special) are
366 ;;; bound as special variables.
367 (defun eval-next-let*-binding
(bindings specials env end-action
)
368 (flet ((maybe-eval (exp)
369 ;; Pick off the easy (QUOTE x) case which is very common
370 ;; due to function calls. (see PARSE-ARGUMENTS)
371 (if (and (consp exp
) (eq (car exp
) 'quote
))
375 (let* ((binding-name (car (car bindings
)))
376 (binding-value (cdr (car bindings
))))
377 (if (specialp binding-name specials
)
380 (list (maybe-eval binding-value
))
381 ;; Mark the variable as special in this environment
382 (push-var binding-name
*special
* env
)
383 (eval-next-let*-binding
(cdr bindings
)
384 specials env end-action
))
386 (push-var binding-name
(maybe-eval binding-value
) env
)
387 (eval-next-let*-binding
(cdr bindings
)
388 specials env end-action
))))
389 (funcall end-action
))))
391 ;;; Create a new environment based on OLD-ENV by adding the variable
392 ;;; bindings in BINDINGS to it, and call FUNCTION with the new environment
393 ;;; as the only parameter. DECLARATIONS are the declarations that were
394 ;;; in a source position where bound declarations for the bindings could
397 ;;; FREE-SPECIALS-P controls whether all special declarations should
398 ;;; end cause the variables to be marked as special in the environment
399 ;;; (when true), or only bound declarations (when false). Basically
400 ;;; it'll be T when handling a LET, and NIL when handling a call to an
401 ;;; interpreted function.
402 (defun call-with-new-env (old-env bindings declarations
403 free-specials-p function
)
404 (let* ((specials (declared-specials declarations
))
406 (dynamic-values nil
))
407 ;; To check for package-lock violations
408 (special-bindings specials old-env
)
409 (flet ((generate-binding (binding)
410 (if (specialp (car binding
) specials
)
411 ;; If the variable being bound is globally special or
412 ;; there's a bound special declaration for it, record it
413 ;; in DYNAMIC-VARS / -VALUES separately:
414 ;; * To handle the case of FREE-SPECIALS-P == T more
416 ;; * The dynamic variables will be bound with PROGV just
419 (push (car binding
) dynamic-vars
)
420 (push (cdr binding
) dynamic-values
)
422 ;; Otherwise it's a lexical binding, and the value
423 ;; will be recorded in the environment.
425 (let ((new-env (make-env
427 :vars
(mapcan #'generate-binding bindings
)
428 :declarations declarations
)))
429 (dolist (special (if free-specials-p specials dynamic-vars
))
430 (push-var special
*special
* new-env
))
432 (progv dynamic-vars dynamic-values
433 (funcall function new-env
))
434 ;; When there are no specials, the PROGV would be a no-op,
435 ;; but it's better to elide it completely, since the
436 ;; funcall is then in tail position.
437 (funcall function new-env
))))))
439 ;;; Create a new environment based on OLD-ENV by binding the argument
440 ;;; list ARGUMENTS to LAMBDA-LIST, and call FUNCTION with the new
441 ;;; environment as argument. DECLARATIONS are the declarations that
442 ;;; were in a source position where bound declarations for the
443 ;;; bindings could be introduced.
444 (defun call-with-new-env-full-parsing
445 (old-env lambda-list arguments declarations function
)
446 (multiple-value-bind (let-like-bindings let
*-like-binding
)
447 (parse-arguments arguments lambda-list
)
448 (let ((specials (declared-specials declarations
))
449 var-specials free-specials
)
450 ;; Separate the bound and free special declarations
451 (dolist (special specials
)
452 (if (or (member special let-like-bindings
:key
#'car
)
453 (member special let
*-like-binding
:key
#'car
))
454 (push special var-specials
)
455 (push special free-specials
)))
456 ;; First introduce the required parameters into the environment
457 ;; with CALL-WITH-NEW-ENV
459 old-env let-like-bindings declarations nil
461 ;; Then deal with optionals / keywords / etc.
462 (eval-next-let*-binding
463 let
*-like-binding var-specials env
465 ;; And now that we have evaluated all the
466 ;; initialization forms for the bindings, add the free
467 ;; special declarations to the environment. To see why
468 ;; this is the right thing to do (instead of passing
469 ;; FREE-SPECIALS-P == T to CALL-WITH-NEW-ENV),
472 ;; (eval '(let ((*a* 1))
473 ;; (declare (special *a*))
475 ;; (funcall (lambda (&optional (b *a*))
476 ;; (declare (special *a*))
477 ;; (values b *a*))))))
479 ;; *A* should be special in the body of the lambda, but
480 ;; not when evaluating the default value of B.
481 (dolist (special free-specials
)
482 (push-var special
*special
* env
))
483 (funcall function env
))))))))
485 ;;; Set the VALUE of the binding (either lexical or special) of the
486 ;;; variable named by SYMBOL in the environment ENV.
487 (defun set-variable (symbol value env
)
488 (let ((binding (get-binding symbol env
)))
491 ((eq (cdr binding
) *special
*)
492 (setf (symbol-value symbol
) value
))
493 ((eq (cdr binding
) *symbol-macro
*)
494 (error "Tried to set a symbol-macrolet!"))
495 (t (setf (cdr binding
) value
)))
496 (case (sb!int
:info
:variable
:kind symbol
)
497 (:macro
(error "Tried to set a symbol-macrolet!"))
498 (:alien
(let ((type (sb!int
:info
:variable
:alien-info symbol
)))
499 (setf (sb!alien
::%heap-alien type
) value
)))
501 (let ((type (sb!c
::info
:variable
:type symbol
)))
503 (let ((type-specifier (sb!kernel
:type-specifier type
)))
504 (unless (typep value type-specifier
)
507 :expected-type type-specifier
))))
508 (setf (symbol-value symbol
) value
)))))))
510 ;;; Retrieve the value of the binding (either lexical or special) of
511 ;;; the variable named by SYMBOL in the environment ENV. For symbol
512 ;;; macros the expansion is returned instead.
513 (defun get-variable (symbol env
)
514 (let ((binding (get-binding symbol env
)))
517 ((eq (cdr binding
) *special
*)
518 (values (symbol-value symbol
) :variable
))
519 ((eq (cdr binding
) *symbol-macro
*)
520 (values (cdr (get-symbol-expansion-binding symbol env
))
522 (t (values (cdr binding
) :variable
)))
523 (case (sb!int
:info
:variable
:kind symbol
)
524 (:macro
(values (macroexpand-1 symbol
) :expansion
))
525 (:alien
(let ((type (sb!int
:info
:variable
:alien-info symbol
)))
526 (values (sb!alien
::%heap-alien type
)
528 (t (values (symbol-value symbol
) :variable
))))))
530 ;;; Retrieve the function/macro binding of the symbol NAME in
531 ;;; environment ENV. The second return value will be :MACRO for macro
532 ;;; bindings, :FUNCTION for function bindings.
533 (defun get-function (name env
)
534 (let ((binding (get-fbinding name env
)))
537 ((eq (cdr binding
) *macro
*)
538 (values (cdr (get-expander-binding name env
)) :macro
))
539 (t (values (cdr binding
) :function
)))
541 ((and (symbolp name
) (macro-function name
))
542 (values (macro-function name
) :macro
))
543 (t (values (%coerce-name-to-fun name
) :function
))))))
545 ;;; Return true if EXP is a lambda form.
547 (case (car exp
) ((lambda
549 sb
!kernel
:instance-lambda
)
552 ;;; Split off the declarations (and the docstring, if
553 ;;; DOC-STRING-ALLOWED is true) from the actual forms of BODY.
554 ;;; Returns three values: the cons in BODY containing the first
555 ;;; non-header subform, the docstring, and a list of the declarations.
557 ;;; FIXME: The name of this function is somewhat misleading. It's not
558 ;;; used just for parsing the headers from lambda bodies, but for all
559 ;;; special forms that have attached declarations.
560 (defun parse-lambda-headers (body &key doc-string-allowed
)
561 (loop with documentation
= nil
562 with declarations
= nil
565 ((and doc-string-allowed
(stringp (car form
)))
566 (if (cdr form
) ; CLHS 3.4.11
568 (ip-error "~@<Duplicate doc string ~S.~:@>" (car form
))
569 (setf documentation
(car form
)))
570 (return (values form documentation declarations
))))
571 ((and (consp (car form
)) (eql (caar form
) 'declare
))
572 (setf declarations
(append declarations
(cdar form
))))
573 (t (return (values form documentation declarations
))))
574 finally
(return (values nil documentation declarations
))))
576 ;;; Create an interpreted function from the lambda-form EXP evaluated
577 ;;; in the environment ENV.
578 (defun eval-lambda (exp env
)
580 ((lambda sb
!kernel
:instance-lambda
)
581 (multiple-value-bind (body documentation declarations
)
582 (parse-lambda-headers (cddr exp
) :doc-string-allowed t
)
583 (make-interpreted-function :lambda-list
(second exp
)
585 :documentation documentation
586 :source-location
(sb!c
::make-definition-source-location
)
587 :declarations declarations
)))
588 ((sb!int
:named-lambda
)
589 (multiple-value-bind (body documentation declarations
)
590 (parse-lambda-headers (cdddr exp
) :doc-string-allowed t
)
591 (make-interpreted-function :name
(second exp
)
592 :lambda-list
(third exp
)
594 :documentation documentation
595 :source-location
(sb!c
::make-definition-source-location
)
596 :declarations declarations
)))))
598 (defun eval-progn (body env
)
599 (let ((previous-exp nil
))
602 (%eval previous-exp env
))
603 (setf previous-exp exp
))
604 ;; Preserve tail call
605 (%eval previous-exp env
)))
607 (defun eval-if (body env
)
608 (program-destructuring-bind (test if-true
&optional if-false
) body
611 (%eval if-false env
))))
613 (defun eval-let (body env
)
614 (program-destructuring-bind (bindings &body body
) body
615 ;; First evaluate the bindings in parallel
616 (let ((bindings (mapcar
618 (cons (binding-name binding
)
619 (%eval
(binding-value binding
) env
)))
621 (multiple-value-bind (body documentation declarations
)
622 (parse-lambda-headers body
:doc-string-allowed nil
)
623 (declare (ignore documentation
))
624 ;; Then establish them into the environment, and evaluate the
626 (call-with-new-env env bindings declarations t
628 (eval-progn body env
)))))))
630 (defun eval-let* (body old-env
)
631 (program-destructuring-bind (bindings &body body
) body
632 (multiple-value-bind (body documentation declarations
)
633 (parse-lambda-headers body
:doc-string-allowed nil
)
634 (declare (ignore documentation
))
635 ;; First we separate the special declarations into bound and
636 ;; free declarations.
637 (let ((specials (declared-specials declarations
))
638 var-specials free-specials
)
639 (dolist (special specials
)
640 (if (member special bindings
:key
#'binding-name
)
641 (push special var-specials
)
642 (push special free-specials
)))
643 (let ((env (make-env :parent old-env
644 :declarations declarations
)))
645 ;; Then we establish the bindings into the environment
647 (eval-next-let*-binding
648 (mapcar #'(lambda (binding)
649 (cons (binding-name binding
)
650 (binding-value binding
)))
654 ;; Now that we're done evaluating the bindings, add the
655 ;; free special declarations. See also
656 ;; CALL-WITH-NEW-ENV-FULL-PARSING.
657 (dolist (special free-specials
)
658 (push-var special
*special
* env
))
659 (eval-progn body env
))))))))
661 ;; Return a named local function in the environment ENV, made from the
662 ;; definition form FUNCTION-DEF.
663 (defun eval-local-function-def (function-def env
)
664 (program-destructuring-bind (name lambda-list
&body local-body
) function-def
665 (multiple-value-bind (local-body documentation declarations
)
666 (parse-lambda-headers local-body
:doc-string-allowed t
)
667 (%eval
`#'(sb!int
:named-lambda
,name
,lambda-list
671 (declare ,@declarations
)
672 (block ,(cond ((consp name
) (second name
))
677 (defun eval-flet (body env
)
678 (program-destructuring-bind ((&rest local-functions
) &body body
) body
679 (multiple-value-bind (body documentation declarations
)
680 (parse-lambda-headers body
:doc-string-allowed nil
)
681 (declare (ignore documentation
))
682 (let* ((specials (declared-specials declarations
))
683 (new-env (make-env :parent env
684 :vars
(special-bindings specials env
)
685 :declarations declarations
)))
686 (dolist (function-def local-functions
)
687 (push-fun (car function-def
)
688 ;; Evaluate the function definitions in ENV.
689 (eval-local-function-def function-def env
)
690 ;; Do package-lock checks in ENV.
692 ;; But add the bindings to the child environment.
694 (eval-progn body new-env
)))))
696 (defun eval-labels (body old-env
)
697 (program-destructuring-bind ((&rest local-functions
) &body body
) body
698 (multiple-value-bind (body documentation declarations
)
699 (parse-lambda-headers body
:doc-string-allowed nil
)
700 (declare (ignore documentation
))
701 ;; Create a child environment, evaluate the function definitions
702 ;; in it, and add them into the same environment.
703 (let ((env (make-env :parent old-env
704 :declarations declarations
)))
705 (dolist (function-def local-functions
)
706 (push-fun (car function-def
)
707 (eval-local-function-def function-def env
)
710 ;; And then add an environment for the body of the LABELS. A
711 ;; separate environment from the one where we added the
712 ;; functions to is needed, since any special variable
713 ;; declarations need to be in effect in the body, but not in
714 ;; the bodies of the local functions.
715 (let* ((specials (declared-specials declarations
))
716 (new-env (make-env :parent env
717 :vars
(special-bindings specials env
))))
718 (eval-progn body new-env
))))))
720 ;; Return a local macro-expander in the environment ENV, made from the
721 ;; definition form FUNCTION-DEF.
722 (defun eval-local-macro-def (function-def env
)
723 (program-destructuring-bind (name lambda-list
&body local-body
) function-def
724 (multiple-value-bind (local-body documentation declarations
)
725 (parse-lambda-headers local-body
:doc-string-allowed t
)
726 ;; HAS-ENVIRONMENT and HAS-WHOLE will be either NIL or the name
727 ;; of the variable. (Better names?)
728 (let (has-environment has-whole
)
729 ;; Filter out &WHOLE and &ENVIRONMENT from the lambda-list, and
730 ;; do some syntax checking.
731 (when (eq (car lambda-list
) '&whole
)
732 (setf has-whole
(second lambda-list
))
733 (setf lambda-list
(cddr lambda-list
)))
736 for element in lambda-list
740 (setf has-environment element
)
742 ((eq element
'&environment
)
744 (ip-error "Repeated &ENVIRONMENT.")
747 ((eq element
'&whole
)
748 (ip-error "&WHOLE may only appear first ~
749 in MACROLET lambda-list."))
752 (let ((outer-whole (gensym "WHOLE"))
753 (environment (or has-environment
(gensym "ENVIRONMENT")))
754 (macro-name (gensym "NAME")))
755 (%eval
`#'(lambda (,outer-whole
,environment
)
759 (declare ,@(unless has-environment
760 `((ignore ,environment
))))
761 (program-destructuring-bind
763 (list '&whole has-whole
)
765 ,macro-name
,@lambda-list
)
767 (declare (ignore ,macro-name
)
769 (block ,name
,@local-body
)))
772 (defun eval-macrolet (body env
)
773 (program-destructuring-bind ((&rest local-functions
) &body body
) body
774 (flet ((generate-fbinding (macro-def)
775 (cons (car macro-def
) *macro
*))
776 (generate-mbinding (macro-def)
777 (let ((name (car macro-def
))
778 (sb!c
:*lexenv
* (env-native-lexenv env
)))
780 (program-assert-symbol-home-package-unlocked
781 :eval name
"binding ~A as a local macro"))
782 (cons name
(eval-local-macro-def macro-def env
)))))
783 (multiple-value-bind (body documentation declarations
)
784 (parse-lambda-headers body
:doc-string-allowed nil
)
785 (declare (ignore documentation
))
786 (let* ((specials (declared-specials declarations
))
787 (new-env (make-env :parent env
788 :vars
(special-bindings specials env
)
789 :funs
(mapcar #'generate-fbinding
791 :expanders
(mapcar #'generate-mbinding
793 :declarations declarations
)))
794 (eval-progn body new-env
))))))
796 (defun eval-symbol-macrolet (body env
)
797 (program-destructuring-bind ((&rest bindings
) &body body
) body
798 (flet ((generate-binding (binding)
799 (cons (car binding
) *symbol-macro
*))
800 (generate-sm-binding (binding)
801 (let ((name (car binding
))
802 (sb!c
:*lexenv
* (env-native-lexenv env
)))
803 (when (or (boundp name
)
804 (eq (sb!int
:info
:variable
:kind name
) :macro
))
805 (program-assert-symbol-home-package-unlocked
806 :eval name
"binding ~A as a local symbol-macro"))
807 (cons name
(second binding
)))))
808 (multiple-value-bind (body documentation declarations
)
809 (parse-lambda-headers body
:doc-string-allowed nil
)
810 (declare (ignore documentation
))
811 (let ((specials (declared-specials declarations
)))
812 (dolist (binding bindings
)
813 (when (specialp (binding-name binding
) specials
)
814 (ip-error "~@<Can't bind SYMBOL-MACROLET of special ~
816 (binding-name binding
)))))
817 (let* ((specials (declared-specials declarations
))
818 (new-env (make-env :parent env
819 :vars
(nconc-2 (mapcar #'generate-binding
821 (special-bindings specials env
))
822 :symbol-expansions
(mapcar
823 #'generate-sm-binding
825 :declarations declarations
)))
826 (eval-progn body new-env
))))))
828 (defun eval-progv (body env
)
829 (program-destructuring-bind (vars vals
&body body
) body
830 (progv (%eval vars env
) (%eval vals env
)
831 (eval-progn body env
))))
833 (defun eval-function (body env
)
834 (program-destructuring-bind (name) body
836 ;; LAMBDAP assumes that the argument is a cons, so we need the
837 ;; initial symbol case, instead of relying on the fall-through
838 ;; case that has the same function body.
839 ((symbolp name
) (nth-value 0 (get-function name env
)))
840 ((lambdap name
) (eval-lambda name env
))
841 (t (nth-value 0 (get-function name env
))))))
843 (defun eval-eval-when (body env
)
844 (program-destructuring-bind ((&rest situation
) &body body
) body
845 ;; FIXME: check that SITUATION only contains valid situations
846 (if (or (member :execute situation
)
847 (member 'eval situation
))
848 (eval-progn body env
))))
850 (defun eval-quote (body env
)
851 (declare (ignore env
))
852 (program-destructuring-bind (object) body
855 (defun eval-setq (pairs env
)
856 (when (oddp (length pairs
))
857 (ip-error "~@<Odd number of args to SETQ: ~S~:@>" (cons 'setq pairs
)))
859 (loop for
(var new-val
) on pairs by
#'cddr do
861 (multiple-value-bind (expansion type
) (get-variable var env
)
865 (%eval
(list 'setf expansion new-val
) env
)))
867 (setf last
(set-variable var
(%eval new-val env
)
869 (unbound-variable (c)
871 (setf last
(setf (symbol-value var
)
872 (%eval new-val env
))))))
875 (defun eval-multiple-value-call (body env
)
876 (program-destructuring-bind (function-form &body forms
) body
877 (%apply
(%eval function-form env
)
878 (loop for form in forms
879 nconc
(multiple-value-list (%eval form env
))))))
881 (defun eval-multiple-value-prog1 (body env
)
882 (program-destructuring-bind (first-form &body forms
) body
883 (multiple-value-prog1 (%eval first-form env
)
884 (eval-progn forms env
))))
886 (defun eval-catch (body env
)
887 (program-destructuring-bind (tag &body forms
) body
888 (catch (%eval tag env
)
889 (eval-progn forms env
))))
891 (defun eval-tagbody (body old-env
)
892 (let ((env (make-env :parent old-env
))
897 (flet ((go-to-tag (tag)
898 (setf target-tag tag
)
900 ;; For each tag, store a trampoline function into the environment
901 ;; and the location in the body into the TAGS alist.
902 (do ((form body
(cdr form
)))
904 (when (atom (car form
))
905 (when (assoc (car form
) tags
)
906 (ip-error "The tag :A appears more than once in a tagbody."))
907 (push (cons (car form
) (cdr form
)) tags
)
908 (push (cons (car form
) #'go-to-tag
) (env-tags env
)))))
909 ;; And then evaluate the forms in the body, starting from the
913 ;; The trampoline has set the TARGET-TAG. Restart evaluation of
914 ;; the body from the location in body that matches the tag.
915 (setf start
(cdr (assoc target-tag tags
)))
918 (when (not (atom form
))
919 (%eval form env
))))))
921 (defun eval-go (body env
)
922 (program-destructuring-bind (tag) body
923 (let ((target (get-tag-binding tag env
)))
925 ;; Call the GO-TO-TAG trampoline
926 (funcall (cdr target
) tag
)
927 (ip-error "~@<Attempt to GO to nonexistent tag: ~S~:@>" tag
)))))
929 (defun eval-block (body old-env
)
930 (flet ((return-from-eval-block (&rest values
)
931 (return-from eval-block
(values-list values
))))
932 (program-destructuring-bind (name &body body
) body
933 (unless (symbolp name
)
934 (ip-error "~@<The block name ~S is not a symbol.~:@>" name
))
936 :blocks
(list (cons name
#'return-from-eval-block
))
938 (eval-progn body env
)))))
940 (defun eval-return-from (body env
)
941 (program-destructuring-bind (name &optional result
) body
942 (let ((target (get-block-binding name env
)))
944 (multiple-value-call (cdr target
) (%eval result env
))
945 (ip-error "~@<Return for unknown block: ~S~:@>" name
)))))
947 (defun eval-the (body env
)
948 (program-destructuring-bind (value-type form
) body
949 (declare (ignore value-type
))
950 ;; FIXME: We should probably check the types here, even though
951 ;; the consequences of the values not being of the asserted types
952 ;; are formally undefined.
955 (defun eval-unwind-protect (body env
)
956 (program-destructuring-bind (protected-form &body cleanup-forms
) body
957 (unwind-protect (%eval protected-form env
)
958 (eval-progn cleanup-forms env
))))
960 (defun eval-throw (body env
)
961 (program-destructuring-bind (tag result-form
) body
962 (throw (%eval tag env
)
963 (%eval result-form env
))))
965 (defun eval-load-time-value (body env
)
966 (program-destructuring-bind (form &optional read-only-p
) body
967 (declare (ignore read-only-p
))
970 (defun eval-locally (body env
)
971 (multiple-value-bind (body documentation declarations
)
972 (parse-lambda-headers body
:doc-string-allowed nil
)
973 (declare (ignore documentation
))
974 (let* ((specials (declared-specials declarations
))
975 (new-env (if (or specials declarations
)
976 (make-env :parent env
977 :vars
(special-bindings specials env
)
978 :declarations declarations
)
980 (eval-progn body new-env
))))
982 (defun eval-args (args env
)
983 (mapcar #'(lambda (arg) (%eval arg env
)) args
))
985 ;;; The expansion of SB-SYS:WITH-PINNED-OBJECTS on GENCGC uses some
986 ;;; VOPs which can't be reasonably implemented in the interpreter. So
987 ;;; we special-case the macro.
988 (defun eval-with-pinned-objects (args env
)
989 (program-destructuring-bind (values &body body
) args
991 (eval-progn body env
)
992 (sb!sys
:with-pinned-objects
((car values
))
993 (eval-with-pinned-objects (cons (cdr values
) body
) env
)))))
995 (define-condition macroexpand-hook-type-error
(type-error)
997 (:report
(lambda (condition stream
)
998 (format stream
"The value of *MACROEXPAND-HOOK* is not a designator for a compiled function: ~A"
999 (type-error-datum condition
)))))
1001 (defvar *eval-dispatch-functions
* nil
)
1003 ;;; Dispatch to the appropriate EVAL-FOO function based on the contents of EXP.
1004 (declaim (inline %%eval
))
1005 (defun %%eval
(exp env
)
1008 ;; CLHS 3.1.2.1.1 Symbols as Forms
1009 (multiple-value-bind (value kind
) (get-variable exp env
)
1012 (:expansion
(%eval value env
)))))
1013 ;; CLHS 3.1.2.1.3 Self-Evaluating Objects
1015 ;; CLHS 3.1.2.1.2 Conses as Forms
1018 ;; CLHS 3.1.2.1.2.1 Special Forms
1019 ((block) (eval-block (cdr exp
) env
))
1020 ((catch) (eval-catch (cdr exp
) env
))
1021 ((eval-when) (eval-eval-when (cdr exp
) env
))
1022 ((flet) (eval-flet (cdr exp
) env
))
1023 ((function) (eval-function (cdr exp
) env
))
1024 ((go) (eval-go (cdr exp
) env
))
1025 ((if) (eval-if (cdr exp
) env
))
1026 ((labels) (eval-labels (cdr exp
) env
))
1027 ((let) (eval-let (cdr exp
) env
))
1028 ((let*) (eval-let* (cdr exp
) env
))
1029 ((load-time-value) (eval-load-time-value (cdr exp
) env
))
1030 ((locally) (eval-locally (cdr exp
) env
))
1031 ((macrolet) (eval-macrolet (cdr exp
) env
))
1032 ((multiple-value-call) (eval-multiple-value-call (cdr exp
) env
))
1033 ((multiple-value-prog1) (eval-multiple-value-prog1 (cdr exp
) env
))
1034 ((progn) (eval-progn (cdr exp
) env
))
1035 ((progv) (eval-progv (cdr exp
) env
))
1036 ((quote) (eval-quote (cdr exp
) env
))
1037 ((return-from) (eval-return-from (cdr exp
) env
))
1038 ((setq) (eval-setq (cdr exp
) env
))
1039 ((symbol-macrolet) (eval-symbol-macrolet (cdr exp
) env
))
1040 ((tagbody) (eval-tagbody (cdr exp
) env
))
1041 ((the) (eval-the (cdr exp
) env
))
1042 ((throw) (eval-throw (cdr exp
) env
))
1043 ((unwind-protect) (eval-unwind-protect (cdr exp
) env
))
1045 ((sb!ext
:truly-the
) (eval-the (cdr exp
) env
))
1046 ;; Not a special form, but a macro whose expansion wouldn't be
1047 ;; handled correctly by the evaluator.
1048 ((sb!sys
:with-pinned-objects
) (eval-with-pinned-objects (cdr exp
) env
))
1050 (let ((dispatcher (getf *eval-dispatch-functions
* (car exp
))))
1053 (funcall dispatcher exp env
))
1054 ;; CLHS 3.1.2.1.2.4 Lambda Forms
1055 ((and (consp (car exp
)) (eq (caar exp
) 'lambda
))
1056 (interpreted-apply (eval-function (list (car exp
)) env
)
1057 (eval-args (cdr exp
) env
)))
1059 (multiple-value-bind (function kind
) (get-function (car exp
) env
)
1061 ;; CLHS 3.1.2.1.2.3 Function Forms
1062 (:function
(%apply function
(eval-args (cdr exp
) env
)))
1063 ;; CLHS 3.1.2.1.2.2 Macro Forms
1065 (let ((hook *macroexpand-hook
*))
1066 ;; Having an interpreted function as the
1067 ;; macroexpander hook could cause an infinite
1069 (unless (compiled-function-p
1072 (symbol (symbol-function hook
))))
1073 (error 'macroexpand-hook-type-error
1075 :expected-type
'compiled-function
))
1076 (%eval
(funcall hook
1079 (env-native-lexenv env
))
1082 (defun %eval
(exp env
)
1085 ;; Dynamically binding *EVAL-LEVEL* will prevent tail call
1086 ;; optimization. So only do it when its value will be used for
1087 ;; printing debug output.
1088 (let ((*eval-level
* (1+ *eval-level
*)))
1089 (let ((*print-circle
* t
))
1090 (format t
"~&~vA~S~%" *eval-level
* "" `(%eval
,exp
)))
1094 (defun %apply
(fun args
)
1096 (interpreted-function (interpreted-apply fun args
))
1097 (function (apply fun args
))
1098 (symbol (apply fun args
))))
1100 (defun interpreted-apply (fun args
)
1101 (let ((lambda-list (interpreted-function-lambda-list fun
))
1102 (env (interpreted-function-env fun
))
1103 (body (interpreted-function-body fun
))
1104 (declarations (interpreted-function-declarations fun
)))
1105 (call-with-new-env-full-parsing
1106 env lambda-list args declarations
1108 (eval-progn body env
)))))
1110 ;;; We need separate conditions for the different *-TOO-COMPLEX-ERRORs to
1111 ;;; avoid spuriously triggering the handler in EVAL-IN-NATIVE-ENVIRONMENT
1114 ;;; (let ((sb-ext:*evaluator-mode* :interpret))
1115 ;;; (let ((fun (eval '(let ((a 1)) (lambda () a)))))
1116 ;;; (eval `(compile nil ,fun))))
1118 ;;; FIXME: should these be exported?
1119 (define-condition interpreter-environment-too-complex-error
(simple-error)
1121 (define-condition compiler-environment-too-complex-error
(simple-error)
1124 ;;; Try to compile an interpreted function. If the environment
1125 ;;; contains local functions or lexical variables we'll punt on
1127 (defun prepare-for-compile (function)
1128 (let ((env (interpreted-function-env function
)))
1129 (when (or (env-tags env
)
1131 (find-if-not #'(lambda (x) (eq x
*macro
*))
1132 (env-funs env
) :key
#'cdr
)
1133 (find-if-not #'(lambda (x) (eq x
*symbol-macro
*))
1136 (error 'interpreter-environment-too-complex-error
1138 "~@<Lexical environment of ~S is too complex to compile.~:@>"
1142 `(sb!int
:named-lambda
,(interpreted-function-name function
)
1143 ,(interpreted-function-lambda-list function
)
1144 (declare ,@(interpreted-function-declarations function
))
1145 ,@(interpreted-function-body function
))
1146 (env-native-lexenv env
))))
1148 ;;; Convert a compiler LEXENV to an interpreter ENV. This is needed
1149 ;;; for EVAL-IN-LEXENV.
1150 (defun make-env-from-native-environment (lexenv)
1151 (let ((native-funs (sb!c
::lexenv-funs lexenv
))
1152 (native-vars (sb!c
::lexenv-vars lexenv
)))
1153 (flet ((is-macro (thing)
1154 (and (consp thing
) (eq (car thing
) 'sb
!sys
:macro
))))
1155 (when (or (sb!c
::lexenv-blocks lexenv
)
1156 (sb!c
::lexenv-cleanup lexenv
)
1157 (sb!c
::lexenv-lambda lexenv
)
1158 (sb!c
::lexenv-tags lexenv
)
1159 (sb!c
::lexenv-type-restrictions lexenv
)
1160 (find-if-not #'is-macro native-funs
:key
#'cdr
)
1161 (find-if-not #'is-macro native-vars
:key
#'cdr
))
1162 (error 'compiler-environment-too-complex-error
1164 "~@<Lexical environment is too complex to evaluate in: ~S~:@>"
1167 (flet ((make-binding (native)
1168 (cons (car native
) *symbol-macro
*))
1169 (make-sm-binding (native)
1170 (cons (car native
) (cddr native
)))
1171 (make-fbinding (native)
1172 (cons (car native
) *macro
*))
1173 (make-mbinding (native)
1174 (cons (car native
) (cddr native
))))
1176 (mapcar #'make-binding native-vars
)
1177 (mapcar #'make-fbinding native-funs
)
1178 (mapcar #'make-mbinding native-funs
)
1179 (mapcar #'make-sm-binding native-vars
)
1185 (defun eval-in-environment (form env
)
1188 (defun eval-in-native-environment (form lexenv
)
1190 ((sb!impl
::eval-error
1192 (error 'interpreted-program-error
1193 :condition
(sb!int
:encapsulated-condition condition
)
1195 (sb!c
:compiler-error
1197 (if (boundp 'sb
!c
::*compiler-error-bailout
*)
1198 ;; if we're in the compiler, delegate either to a higher
1199 ;; authority or, if that's us, back down to the
1200 ;; outermost compiler handler...
1204 ;; ... if we're not in the compiler, better signal the
1205 ;; error straight away.
1206 (invoke-restart 'sb
!c
::signal-error
)))))
1208 (let ((env (make-env-from-native-environment lexenv
)))
1210 (compiler-environment-too-complex-error (condition)
1211 (declare (ignore condition
))
1212 (sb!int
:style-warn
'sb
!kernel
:lexical-environment-too-complex
1213 :form form
:lexenv lexenv
)
1214 (sb!int
:simple-eval-in-lexenv form lexenv
)))))