0.7.9.21:

[sbcl.git] / src / code / eval.lisp

diff --git a/src/code/eval.lisp b/src/code/eval.lisp
index cd5b0df..f8ef5b0 100644 (file)
--- a/src/code/eval.lisp
+++ b/src/code/eval.lisp
@@ -1,3 +1,5 @@
+;;;; EVAL and friends
+

 ;;;; This software is part of the SBCL system. See the README file for
 ;;;; more information.
 ;;;;
 ;;;; This software is part of the SBCL system. See the README file for
 ;;;; more information.
 ;;;;

@@ -7,89 +9,50 @@
 ;;;; provided with absolutely no warranty. See the COPYING and CREDITS
 ;;;; files for more information.
 
 ;;;; provided with absolutely no warranty. See the COPYING and CREDITS
 ;;;; files for more information.
 

-(in-package "SB!BYTECODE")
-
-;;; This is defined here so that the printer etc. can call
-;;; INTERPRETED-FUNCTION-P before the full interpreter is loaded.
-
-;;; an interpreted function
-(defstruct (interpreted-function
-           (:alternate-metaclass sb!kernel:funcallable-instance
-                                 sb!kernel:funcallable-structure-class
-                                 sb!kernel:make-funcallable-structure-class)
-           (:type sb!kernel:funcallable-structure)
-           (:constructor %make-interpreted-function)
-           (:copier nil)
-           ;; FIXME: Binding PRINT-OBJECT isn't going to help unless
-           ;; we fix the print-a-funcallable-instance code so that
-           ;; it calls PRINT-OBJECT in this case.
-           (:print-object
-            (lambda (x stream)
-              (print-unreadable-object (x stream :identity t)
-                (interpreted-function-%name x)))))
-  ;; The name of this interpreted function, or NIL if none specified.
-  (%name nil)
-  ;; This function's debug arglist.
-  (arglist nil)
-  ;; A lambda that can be converted to get the definition.
-  (lambda nil)
-  ;; If this function has been converted, then this is the XEP. If this is
-  ;; false, then the function is not in the cache (or is in the process of
-  ;; being removed.)
-  (definition nil :type (or sb!c::clambda null))
-  ;; The number of consecutive GCs that this function has been unused.
-  ;; This is used to control cache replacement.
-  (gcs 0 :type sb!c::index)
-  ;; True if Lambda has been converted at least once, and thus warnings should
-  ;; be suppressed on additional conversions.
-  (converted-once nil)
-  ;; For a closure, the closure date vector.
-  (closure nil :type (or null simple-vector)))
-\f
-;;; FIXME: Could we make this extra IN-PACKAGE go away, so that all
-;;; this bytecode interpreter implementation stuff was in the
-;;; SB!BYTECODE package?

 (in-package "SB!IMPL")
 
 (in-package "SB!IMPL")
 

-;;;; EVAL and friends
-
-;;; This needs to be initialized in the cold load, since the top-level
-;;; catcher will always restore the initial value.
-(defvar *eval-stack-top* 0)
-

 ;;; general case of EVAL (except in that it can't handle toplevel
 ;;; general case of EVAL (except in that it can't handle toplevel

-;;; EVAL-WHEN magic properly): Delegate to the byte compiler.
-(defun sb!bytecode:internal-eval (expr)
-  (funcall (compile (gensym "EVAL-TMPFUN-")
-                   `(lambda ()
-
-                      ;; SPEED=0,DEBUG=1 => byte-compile
-                      (declare (optimize (speed 0) (debug 1))) 
-
-                      ;; Other than that, basically we care about
-                      ;; compilation speed, compilation speed, and
-                      ;; compilation speed. (There are cases where
-                      ;; the user wants something else, but we don't
-                      ;; know enough to guess that; and if he is
-                      ;; unhappy about our guessed emphasis, he
-                      ;; should explicitly compile his code, with
-                      ;; explicit declarations to tell us what to
-                      ;; emphasize.)
-                      (declare (optimize (space 1) (safety 1)))
-                      (declare (optimize (compilation-speed 3)))
-
-                      ,expr))))
+;;; EVAL-WHEN magic properly): Delegate to #'COMPILE.
+(defun %eval (expr lexenv)
+  (funcall (sb!c:compile-in-lexenv
+            (gensym "EVAL-TMPFUN-")
+            `(lambda ()
+               ,expr)
+            lexenv)))
+
+;;; Handle PROGN and implicit PROGN.
+(defun eval-progn-body (progn-body lexenv)
+  (unless (list-with-length-p progn-body)
+    (let ((*print-circle* t))
+      (error 'simple-program-error
+            :format-control
+            "~@<not a proper list in PROGN or implicit PROGN: ~2I~_~S~:>"
+            :format-arguments (list progn-body))))
+  ;; Note:
+  ;;   * We can't just use (MAP NIL #'EVAL PROGN-BODY) here, because we
+  ;;     need to take care to return all the values of the final EVAL.
+  ;;   * It's left as an exercise to the reader to verify that this
+  ;;     gives the right result when PROGN-BODY is NIL, because
+  ;;     (FIRST NIL) = (REST NIL) = NIL.
+  (do* ((i progn-body rest-i)
+       (rest-i (rest i) (rest i)))
+      (nil)
+    (if rest-i ; if not last element of list
+       (eval-in-lexenv (first i) lexenv)
+       (return (eval-in-lexenv (first i) lexenv)))))

 
 

-;;; Pick off a few easy cases, and call INTERNAL-EVAL for the rest. If
-;;; *ALREADY-EVALED-THIS* is true, then we bind it to NIL before doing
-;;; a call so that the effect is confined to the lexical scope of the
-;;; EVAL-WHEN.

 (defun eval (original-exp)
   #!+sb-doc
   "Evaluate the argument in a null lexical environment, returning the
   result or results."
 (defun eval (original-exp)
   #!+sb-doc
   "Evaluate the argument in a null lexical environment, returning the
   result or results."

+  (eval-in-lexenv original-exp (make-null-lexenv)))
+
+;;; Pick off a few easy cases, and the various top level EVAL-WHEN
+;;; magical cases, and call %EVAL for the rest.
+(defun eval-in-lexenv (original-exp lexenv)

   (declare (optimize (safety 1)))
   (declare (optimize (safety 1)))

-  (let ((exp (macroexpand original-exp)))
+  ;; (aver (lexenv-simple-p lexenv))
+  (let ((exp (macroexpand original-exp lexenv)))

     (typecase exp
       (symbol
        (ecase (info :variable :kind exp)
     (typecase exp
       (symbol
        (ecase (info :variable :kind exp)

@@ -97,29 +60,40 @@
          (values (info :variable :constant-value exp)))
         ((:special :global)
          (symbol-value exp))
          (values (info :variable :constant-value exp)))
         ((:special :global)
          (symbol-value exp))

+        ;; FIXME: This special case here is a symptom of non-ANSI
+        ;; weirdness in SBCL's ALIEN implementation, which could
+        ;; cause problems for e.g. code walkers. It'd probably be
+        ;; good to ANSIfy it by making alien variable accessors into
+        ;; ordinary forms, e.g. (SB-UNIX:ENV) and (SETF SB-UNIX:ENV),
+        ;; instead of magical symbols, e.g. plain SB-UNIX:ENV. Then
+        ;; if the old magical-symbol syntax is to be retained for
+        ;; compatibility, it can be implemented with
+        ;; DEFINE-SYMBOL-MACRO, keeping the code walkers happy.

         (:alien
         (:alien

-         (sb!bytecode:internal-eval original-exp))))
+         (%eval original-exp lexenv))))

       (list
        (let ((name (first exp))
       (list
        (let ((name (first exp))

-            (args (1- (length exp))))
+            (n-args (1- (length exp))))

         (case name
         (case name

-          (function
-           (unless (= args 1)
+          ((function)
+           (unless (= n-args 1)

              (error "wrong number of args to FUNCTION:~% ~S" exp))
            (let ((name (second exp)))
              (error "wrong number of args to FUNCTION:~% ~S" exp))
            (let ((name (second exp)))

-             (if (or (atom name)
-                     (and (consp name)
-                          (eq (car name) 'setf)))
+             (if (and (or (atom name)
+                           (and (consp name)
+                                (eq (car name) 'setf)))
+                       (not (consp (let ((sb!c:*lexenv* lexenv))
+                                     (sb!c:lexenv-find name funs)))))

                  (fdefinition name)
                  (fdefinition name)

-                 (sb!bytecode:internal-eval original-exp))))
-          (quote
-           (unless (= args 1)
+                 (%eval original-exp lexenv))))
+          ((quote)
+           (unless (= n-args 1)

              (error "wrong number of args to QUOTE:~% ~S" exp))
            (second exp))
           (setq
              (error "wrong number of args to QUOTE:~% ~S" exp))
            (second exp))
           (setq

-           (unless (evenp args)
+           (unless (evenp n-args)

              (error "odd number of args to SETQ:~% ~S" exp))
              (error "odd number of args to SETQ:~% ~S" exp))

-           (unless (zerop args)
+           (unless (zerop n-args)

              (do ((name (cdr exp) (cddr name)))
                  ((null name)
                   (do ((args (cdr exp) (cddr args)))
              (do ((name (cdr exp) (cddr name)))
                  ((null name)
                   (do ((args (cdr exp) (cddr args)))

@@ -130,75 +104,109 @@
                     (set (first args) (eval (second args)))))
                (let ((symbol (first name)))
                  (case (info :variable :kind symbol)
                     (set (first args) (eval (second args)))))
                (let ((symbol (first name)))
                  (case (info :variable :kind symbol)

-                   ;; FIXME: I took out the *TOP-LEVEL-AUTO-DECLARE*
-                   ;; test here, and removed the *TOP-LEVEL-AUTO-DECLARE*
+                   ;; FIXME: I took out the *TOPLEVEL-AUTO-DECLARE*
+                   ;; test here, and removed the *TOPLEVEL-AUTO-DECLARE*

                    ;; variable; the code should now act as though that
                    ;; variable is NIL. This should be tested..
                    (:special)
                    ;; variable; the code should now act as though that
                    ;; variable is NIL. This should be tested..
                    (:special)

-                   (t (return (sb!bytecode:internal-eval original-exp))))))))
+                   (t (return (%eval original-exp lexenv))))))))

           ((progn)
           ((progn)

-           (when (> args 0)
-             (dolist (x (butlast (rest exp)) (eval (car (last exp))))
-               (eval x))))
+           (eval-progn-body (rest exp) lexenv))

           ((eval-when)
           ((eval-when)

-           (if (and (> args 0)
-                    (or (member 'eval (second exp))
-                        (member :execute (second exp))))
-               (when (> args 1)
-                 (dolist (x (butlast (cddr exp)) (eval (car (last exp))))
-                   (eval x)))
-               (sb!bytecode:internal-eval original-exp)))
+           ;; FIXME: DESTRUCTURING-BIND returns ARG-COUNT-ERROR
+           ;; instead of PROGRAM-ERROR when there's something wrong
+           ;; with the syntax here (e.g. missing SITUATIONS). This
+           ;; could be fixed by hand-crafting clauses to catch and
+           ;; report each possibility, but it would probably be
+           ;; cleaner to write a new macro
+           ;; DESTRUCTURING-BIND-PROGRAM-SYNTAX which does
+           ;; DESTRUCTURING-BIND and promotes any mismatch to
+           ;; PROGRAM-ERROR, then to use it here and in (probably
+           ;; dozens of) other places where the same problem arises.
+           (destructuring-bind (eval-when situations &rest body) exp
+             (declare (ignore eval-when))
+             (multiple-value-bind (ct lt e)
+                 (sb!c:parse-eval-when-situations situations)
+               ;; CLHS 3.8 - Special Operator EVAL-WHEN: The use of
+               ;; the situation :EXECUTE (or EVAL) controls whether
+               ;; evaluation occurs for other EVAL-WHEN forms; that
+               ;; is, those that are not top level forms, or those in
+               ;; code processed by EVAL or COMPILE. If the :EXECUTE
+               ;; situation is specified in such a form, then the
+               ;; body forms are processed as an implicit PROGN;
+               ;; otherwise, the EVAL-WHEN form returns NIL.
+               (declare (ignore ct lt))
+               (when e
+                 (eval-progn-body body lexenv)))))
+          ((locally)
+           (multiple-value-bind (body decls) (parse-body (rest exp) nil)
+             (let ((lexenv
+                    ;; KLUDGE: Uh, yeah.  I'm not anticipating
+                    ;; winning any prizes for this code, which was
+                    ;; written on a "let's get it to work" basis.
+                    ;; These seem to be the variables that need
+                    ;; bindings for PROCESS-DECLS to work
+                    ;; (*FREE-FUNS* and *FREE-VARS* so that
+                    ;; references to free functions and variables in
+                    ;; the declarations can be noted;
+                    ;; *UNDEFINED-WARNINGS* so that warnings about
+                    ;; undefined things can be accumulated [and then
+                    ;; thrown away, as it happens]). -- CSR, 2002-10-24
+                    (let ((sb!c:*lexenv* lexenv)
+                          (sb!c::*free-funs* (make-hash-table :test 'equal))
+                          (sb!c::*free-vars* (make-hash-table :test 'eq))
+                          (sb!c::*undefined-warnings* nil))
+                      (sb!c::process-decls decls
+                                           nil nil
+                                           (sb!c::make-continuation)
+                                           lexenv))))
+               (eval-progn-body body lexenv))))
+          ((macrolet)
+           (destructuring-bind (definitions &rest body)
+               (rest exp)
+             ;; FIXME: shared code with FUNCALL-IN-FOOMACROLET-LEXENV
+             (declare (type list definitions))
+             (unless (= (length definitions)
+                        (length (remove-duplicates definitions :key #'first)))
+               (style-warn "duplicate definitions in ~S" definitions))
+             (let ((lexenv
+                    (sb!c::make-lexenv
+                     :default lexenv
+                     :funs (mapcar
+                            (sb!c::macrolet-definitionize-fun
+                             :eval
+                             ;; I'm not sure that this is the correct
+                             ;; LEXENV to be compiling local macros
+                             ;; in...
+                             lexenv)
+                            definitions))))
+               (eval-in-lexenv `(locally ,@body) lexenv))))
+          ((symbol-macrolet)
+           (destructuring-bind (definitions &rest body)
+               (rest exp)
+             ;; FIXME: shared code with FUNCALL-IN-FOOMACROLET-LEXENV
+             (declare (type list definitions))
+             (unless (= (length definitions)
+                        (length (remove-duplicates definitions :key #'first)))
+               (style-warn "duplicate definitions in ~S" definitions))
+             (let ((lexenv
+                    (sb!c::make-lexenv
+                     :default lexenv
+                     :vars (mapcar
+                            (sb!c::symbol-macrolet-definitionize-fun
+                             :eval)
+                            definitions))))
+               (eval-in-lexenv `(locally ,@body) lexenv))))

           (t
            (if (and (symbolp name)
                     (eq (info :function :kind name) :function))
                (collect ((args))
           (t
            (if (and (symbolp name)
                     (eq (info :function :kind name) :function))
                (collect ((args))

-                 (dolist (arg (rest exp))
-                   (args (eval arg)))
-                 (apply (symbol-function name) (args)))
-               (sb!bytecode:internal-eval original-exp))))))
+                         (dolist (arg (rest exp))
+                           (args (eval-in-lexenv arg lexenv)))
+                         (apply (symbol-function name) (args)))
+               (%eval exp lexenv))))))

       (t
        exp))))
       (t
        exp))))

-
-;;; Given a function, return three values:
-;;; 1] A lambda expression that could be used to define the function,
-;;;    or NIL if the definition isn't available.
-;;; 2] NIL if the function was definitely defined in a null lexical
-;;;    environment, and T otherwise.
-;;; 3] Some object that \"names\" the function. Although this is
-;;;    allowed to be any object, CMU CL always returns a valid
-;;;    function name or a string.
-;;;
-;;; If interpreted, use the interpreter interface. Otherwise, see
-;;; whether it was compiled with COMPILE. If that fails, check for an
-;;; inline expansion.
-(defun function-lambda-expression (fun)
-  (declare (type function fun))
-  (let* ((fun (%function-self fun))
-        (name (%function-name fun))
-        (code (sb!di::function-code-header fun))
-        (info (sb!kernel:%code-debug-info code)))
-    (if info
-       (let ((source (first (sb!c::compiled-debug-info-source info))))
-         (cond ((and (eq (sb!c::debug-source-from source) :lisp)
-                     (eq (sb!c::debug-source-info source) fun))
-                (values (second (svref (sb!c::debug-source-name source) 0))
-                        nil name))
-               ((stringp name)
-                (values nil t name))
-               (t
-                (let ((exp (info :function :inline-expansion name)))
-                  (if exp
-                      (values exp nil name)
-                      (values nil t name))))))
-       (values nil t name))))
-
-;;; This is like FIND-IF, except that we do it on a compiled closure's
-;;; environment.
-(defun find-if-in-closure (test fun)
-  (dotimes (index (1- (get-closure-length fun)))
-    (let ((elt (%closure-index-ref fun index)))
-      (when (funcall test elt)
-       (return elt)))))

 \f
 ;;; miscellaneous full function definitions of things which are
 ;;; ordinarily handled magically by the compiler
 \f
 ;;; miscellaneous full function definitions of things which are
 ;;; ordinarily handled magically by the compiler