src/code/target-eval.lisp

   1 ;;;; This software is part of the SBCL system. See the README file for
   2 ;;;; more information.
   3 ;;;;
   4 ;;;; This software is derived from the CMU CL system, which was
   5 ;;;; written at Carnegie Mellon University and released into the
   6 ;;;; public domain. The software is in the public domain and is
   7 ;;;; provided with absolutely no warranty. See the COPYING and CREDITS
   8 ;;;; files for more information.
   9
  10 (in-package "SB!EVAL")
  11
  12 ;;; This is defined here so that the printer etc. can call
  13 ;;; INTERPRETED-FUNCTION-P before the full interpreter is loaded.
  14
  15 ;;; an interpreted function
  16 (defstruct (interpreted-function
  17             (:alternate-metaclass sb!kernel:funcallable-instance
  18                                   sb!kernel:funcallable-structure-class
  19                                   sb!kernel:make-funcallable-structure-class)
  20             (:type sb!kernel:funcallable-structure)
  21             (:constructor %make-interpreted-function)
  22             (:copier nil)
  23             ;; FIXME: Binding PRINT-OBJECT isn't going to help unless
  24             ;; we fix the print-a-funcallable-instance code so that
  25             ;; it calls PRINT-OBJECT in this case.
  26             (:print-object
  27              (lambda (x stream)
  28                (print-unreadable-object (x stream :identity t)
  29                  (sb!impl::output-interpreted-function x stream)))))
  30   ;; The name of this interpreted function, or NIL if none specified.
  31   (%name nil)
  32   ;; This function's debug arglist.
  33   (arglist nil)
  34   ;; A lambda that can be converted to get the definition.
  35   (lambda nil)
  36   ;; If this function has been converted, then this is the XEP. If this is
  37   ;; false, then the function is not in the cache (or is in the process of
  38   ;; being removed.)
  39   (definition nil :type (or sb!c::clambda null))
  40   ;; The number of consecutive GCs that this function has been unused.
  41   ;; This is used to control cache replacement.
  42   (gcs 0 :type sb!c::index)
  43   ;; True if Lambda has been converted at least once, and thus warnings should
  44   ;; be suppressed on additional conversions.
  45   (converted-once nil)
  46   ;; For a closure, the closure date vector.
  47   (closure nil :type (or null simple-vector)))
  48 \f
  49 (in-package "SB!IMPL")
  50
  51 ;;;; One of the steps in building a nice debuggable macro is changing
  52 ;;;; its MACRO-FUNCTION to print as e.g.
  53 ;;;;   #<Interpreted Function "DEFMACRO BAR" {9166351}>
  54 ;;;; instead of some
  55 ;;;; weird internal representation showing the environment argument and stuff.
  56 ;;;; This function is called in order to try to make that happen.
  57 ;;;;
  58 ;;;; When we're running in the target SBCL, we own the INTERPRETED-FUNCTION
  59 ;;;; definition, and we can do this; that's what the definition below does.
  60 ;;;; When we're a Python cross-compiler running in some arbitrary ANSI Common
  61 ;;;; Lisp, we can't do this (and we don't care that much about making nice
  62 ;;;; debuggable macros anyway). In that environment, a stub no-op version of
  63 ;;;; this function is used.
  64 (defun try-to-rename-interpreted-function-as-macro (f name lambda-list)
  65   (aver (sb!eval:interpreted-function-p f))
  66   (setf (sb!eval:interpreted-function-name f)
  67         (format nil "DEFMACRO ~S" name)
  68         (sb!eval:interpreted-function-arglist f)
  69         lambda-list)
  70   (values))
  71 \f
  72 ;;;; EVAL and friends
  73
  74 ;;; This needs to be initialized in the cold load, since the top-level
  75 ;;; catcher will always restore the initial value.
  76 (defvar *eval-stack-top* 0)
  77
  78 ;;; Pick off a few easy cases, and call INTERNAL-EVAL for the rest. If
  79 ;;; *ALREADY-EVALED-THIS* is true, then we bind it to NIL before doing
  80 ;;; a call so that the effect is confined to the lexical scope of the
  81 ;;; EVAL-WHEN.
  82 (defun eval (original-exp)
  83   #!+sb-doc
  84   "Evaluates its single argument in a null lexical environment, returns the
  85   result or results."
  86   (declare (optimize (safety 1)))
  87   (let ((exp (macroexpand original-exp)))
  88     (typecase exp
  89       (symbol
  90        (ecase (info :variable :kind exp)
  91          (:constant
  92           (values (info :variable :constant-value exp)))
  93          ((:special :global)
  94           (symbol-value exp))
  95          (:alien
  96           (sb!eval:internal-eval original-exp))))
  97       (list
  98        (let ((name (first exp))
  99              (args (1- (length exp))))
 100          (case name
 101            (function
 102             (unless (= args 1)
 103               (error "wrong number of args to FUNCTION:~% ~S" exp))
 104             (let ((name (second exp)))
 105               (if (or (atom name)
 106                       (and (consp name)
 107                            (eq (car name) 'setf)))
 108                   (fdefinition name)
 109                   (sb!eval:make-interpreted-function name))))
 110            (quote
 111             (unless (= args 1)
 112               (error "wrong number of args to QUOTE:~% ~S" exp))
 113             (second exp))
 114            (setq
 115             (unless (evenp args)
 116               (error "odd number of args to SETQ:~% ~S" exp))
 117             (unless (zerop args)
 118               (do ((name (cdr exp) (cddr name)))
 119                   ((null name)
 120                    (do ((args (cdr exp) (cddr args)))
 121                        ((null (cddr args))
 122                         ;; We duplicate the call to SET so that the
 123                         ;; correct value gets returned.
 124                         (set (first args) (eval (second args))))
 125                      (set (first args) (eval (second args)))))
 126                 (let ((symbol (first name)))
 127                   (case (info :variable :kind symbol)
 128                     ;; FIXME: I took out the *TOP-LEVEL-AUTO-DECLARE*
 129                     ;; test here, and removed the *TOP-LEVEL-AUTO-DECLARE*
 130                     ;; variable; the code should now act as though that
 131                     ;; variable is NIL. This should be tested..
 132                     (:special)
 133                     (t (return (sb!eval:internal-eval original-exp))))))))
 134            ((progn)
 135             (when (> args 0)
 136               (dolist (x (butlast (rest exp)) (eval (car (last exp))))
 137                 (eval x))))
 138            ((eval-when)
 139             (if (and (> args 0)
 140                      (or (member 'eval (second exp))
 141                          (member :execute (second exp))))
 142                 (when (> args 1)
 143                   (dolist (x (butlast (cddr exp)) (eval (car (last exp))))
 144                     (eval x)))
 145                 (sb!eval:internal-eval original-exp)))
 146            (t
 147             (if (and (symbolp name)
 148                      (eq (info :function :kind name) :function))
 149                 (collect ((args))
 150                   (dolist (arg (rest exp))
 151                     (args (eval arg)))
 152                   (if sb!eval::*already-evaled-this*
 153                       (let ((sb!eval::*already-evaled-this* nil))
 154                         (apply (symbol-function name) (args)))
 155                       (apply (symbol-function name) (args))))
 156                 (sb!eval:internal-eval original-exp))))))
 157       (t
 158        exp))))
 159
 160 ;;; not needed in new from-scratch cross-compilation procedure -- WHN 19990714
 161 #|
 162 ;;; Dummy stubs for SB!EVAL:INTERNAL-EVAL and SB!EVAL:MAKE-INTERPRETED-FUNCTION
 163 ;;; in case the compiler isn't loaded yet.
 164 (defun sb!eval:internal-eval (x)
 165   (error "attempt to evaluation a complex expression:~%     ~S~@
 166           This expression must be compiled, but the compiler is not loaded."
 167          x))
 168 (defun sb!eval:make-interpreted-function (x)
 169   (error "EVAL called on #'(lambda (x) ...) when the compiler isn't loaded:~
 170           ~%     ~S~%"
 171          x))
 172 |#
 173
 174 ;;; If interpreted, use the interpreter interface. Otherwise, see
 175 ;;; whether it was compiled with COMPILE. If that fails, check for an
 176 ;;; inline expansion.
 177 (defun function-lambda-expression (fun)
 178   #!+sb-doc
 179   "Given a function, return three values:
 180    1] A lambda expression that could be used to define the function, or NIL if
 181       the definition isn't available.
 182    2] NIL if the function was definitely defined in a null lexical environment,
 183       and T otherwise.
 184    3] Some object that \"names\" the function. Although this is allowed to be
 185       any object, CMU CL always returns a valid function name or a string."
 186   (declare (type function fun))
 187   (if (sb!eval:interpreted-function-p fun)
 188       (sb!eval:interpreted-function-lambda-expression fun)
 189       (let* ((fun (%function-self fun))
 190              (name (%function-name fun))
 191              (code (sb!di::function-code-header fun))
 192              (info (sb!kernel:%code-debug-info code)))
 193         (if info
 194             (let ((source (first (sb!c::compiled-debug-info-source info))))
 195               (cond ((and (eq (sb!c::debug-source-from source) :lisp)
 196                           (eq (sb!c::debug-source-info source) fun))
 197                      (values (second (svref (sb!c::debug-source-name source) 0))
 198                              nil name))
 199                     ((stringp name)
 200                      (values nil t name))
 201                     (t
 202                      (let ((exp (info :function :inline-expansion name)))
 203                        (if exp
 204                            (values exp nil name)
 205                            (values nil t name))))))
 206             (values nil t name)))))
 207
 208 ;;; Like FIND-IF, only we do it on a compiled closure's environment.
 209 (defun find-if-in-closure (test fun)
 210   (dotimes (index (1- (get-closure-length fun)))
 211     (let ((elt (%closure-index-ref fun index)))
 212       (when (funcall test elt)
 213         (return elt)))))
 214 \f
 215 ;;; function invocation
 216
 217 (defun apply (function arg &rest args)
 218   #!+sb-doc
 219   "Applies FUNCTION to a list of arguments produced by evaluating ARGS in
 220   the manner of LIST*. That is, a list is made of the values of all but the
 221   last argument, appended to the value of the last argument, which must be a
 222   list."
 223   (cond ((atom args)
 224          (apply function arg))
 225         ((atom (cdr args))
 226          (apply function (cons arg (car args))))
 227         (t (do* ((a1 args a2)
 228                  (a2 (cdr args) (cdr a2)))
 229                 ((atom (cdr a2))
 230                  (rplacd a1 (car a2))
 231                  (apply function (cons arg args)))))))
 232
 233 (defun funcall (function &rest arguments)
 234   #!+sb-doc
 235   "Calls Function with the given Arguments."
 236   (apply function arguments))
 237 \f
 238 ;;; multiple-value forms
 239
 240 (defun values (&rest values)
 241   #!+sb-doc
 242   "Returns all arguments, in order, as values."
 243   (values-list values))
 244
 245 (defun values-list (list)
 246   #!+sb-doc
 247   "Returns all of the elements of LIST, in order, as values."
 248   (values-list list))