;;;; This software is part of the SBCL system. See the README file for
;;;; more information.
;;;;
;;;; This software is derived from the CMU CL system, which was
;;;; written at Carnegie Mellon University and released into the
;;;; public domain. The software is in the public domain and is
;;;; provided with absolutely no warranty. See the COPYING and CREDITS
;;;; files for more information.

(in-package "SB-INTERPRETER")

;;; *APPLYHOOK* works more-or-less as described in CLtL2, which is
;;; not at all like the *SELF-APPLYHOOK* that hooks every call
;;; into a function as part of the function itself.
;;; Don't bind it to an interpreted-function; probably don't bind to a
;;; symbol, and definitely not a lambda expression- just a compiled function.
;;; Also note: it's never rebound to NIL around each application,
;;; because that would make EVAL non-tail-recursive.  It is assumed that
;;; anyone messing with it knows what (s)he is doing.
(defvar *applyhook* nil)

;;; Retrieve the value of the binding (either lexical or special) of
;;; the variable named by SYMBOL in the environment ENV. For symbol
;;; macros the expansion is returned instead.
;;; Second values is T if the primary value is a macroexpansion.
;;; Tertiary value is the type to assert, or NIL if no type should be asserted.
;;; That is, policy-related decisions need to be made here, not in the caller.
(defun expand-or-eval-symbol (env symbol)
  (declare (symbol symbol))
  (binding* (((binding kind nil value) (find-lexical-var env symbol))
             (type (var-type-assertion env symbol binding :read))
             ((macro-p value)
              (if kind
                  (case kind
                    (:normal (values nil value))
                    (:macro  (values t (symexpand env symbol value)))
                    (t       (values nil (symbol-value symbol))))
                  (case (info :variable :kind symbol)
                    (:macro  (values t (symexpand env symbol)))
                    (:alien  (values nil (alien-value symbol)))
                    (t       (values nil (symbol-value symbol)))))))
    (values value macro-p type)))

;; Macros must go through the hook, but we can avoid it if the hook is FUNCALL.
(defun symexpand (env sym
                  &optional (expansion (info :variable :macro-expansion sym)))
  (let ((hook (valid-macroexpand-hook)))
    (if (eq hook #'funcall)
        expansion
        (funcall hook
                 (lambda (form env) (declare (ignore form env)) expansion)
                 sym env))))

;;; Implementation note: APPLY is the main reason the interpreter conses.
;;; It would be nice if you could preallocate a DX arglist and pass that
;;; on the stack. Applying directly from a DX arglist would make the
;;; interpreter non-tail-recursive, so we don't want to do that.
;;; There is sort of a way - assuming MAKE-LIST is made to be DXable -
;;; but it is probably much worse for performance:
;;; (multiple-value-call thing
;;;    (let ((foo (make-list n)))
;;;       (setf (nth 0 foo) (eval-nth-arg ...))
;;;       (values-list foo)
;;;

(defparameter *eval-level* -1)
(defparameter *eval-verbose* nil)

;;; It looks as if at one point I thought the interpreter would allow
;;; a special operator which reimplements a macro to decline to run,
;;; or punt to the macro. I don't see that it does that....
(defun special-form-handler (fname)
  ;; Returns a cons of the deferred processor and immediate processor.
  ;; The CDR can be NIL if there is no immediate handler.
  (binding* ((info (symbol-dbinfo (truly-the symbol fname)) :exit-if-null)
             ;; This is safe: PACKED-INFO invariant requires that it have length >= 1.
             (word (truly-the fixnum (%info-ref info 0))))
    ;; Test that the first info-number is +fdefn-info-num+ and its n-infos
    ;; field is nonzero. These conditions can be tested simultaneously
    ;; using a SIMD-in-a-register idea. The low 6 bits must be nonzero
    ;; and the next 6 must be exactly #b111111, so considered together
    ;; as a 12-bit unsigned integer it must be >= #b111111000001
    (when (>= (ldb (byte (* info-number-bits 2) 0) word)
              (1+ (ash +fdefn-info-num+ info-number-bits)))
      (%info-ref info (1- (truly-the (integer 1 *)
                                     (sb-impl::packed-info-len info)))))))

(defun %eval (exp env)
  (labels
      ((%%eval (&aux fname special)
         (cond
          ((symbolp exp)
           ;; CLHS 3.1.2.1.1 Symbols as Forms
           (binding* (((val expanded-p type) (expand-or-eval-symbol env exp))
                      (eval-val (if expanded-p (%eval val env) val)))
             (when (and type (not (itypep eval-val type)))
               (typecheck-fail/ref exp eval-val type))
             eval-val))
          ;; CLHS 3.1.2.1.3 Self-Evaluating Objects
          ;; We can save a few instructions vs. testing ATOM
          ;; because SYMBOLP was already picked off.
          ((not (listp exp)) exp)
          ;; CLHS 3.1.2.1.2 Conses as Forms
          ((eq (setq fname (car exp)) 'setq)
           (eval-setq (cdr exp) env nil)) ; SEXPR = nil
          ;; CLHS 3.1.2.1.2.4 Lambda Forms
          ((typep fname '(cons (eql lambda)))
           (if (eq sb-ext:*evaluator-mode* :interpret)
               ;; It should be possible to avoid consing a function,
               ;; but this syntax isn't common enough to matter.
               (apply-it (funcall (if (must-freeze-p env) #'enclose-freeze #'enclose)
                                  (make-proto-fn fname) env nil))
               (compile-it)))
          ((not (symbolp fname))
           (%program-error "Invalid function name: ~S" fname))
          ;; CLHS 3.1.2.1.2.1 Special Forms
          ;; Pick off special forms first for speed. Special operators
          ;; can't be shadowed by local defs.
          ;; Even if *evaluator-mode* = :COMPILE, some easy-to-handle operators get
          ;; interpreted. For this to work, the operator must preserve an exact
          ;; correspondence between interpreter ENV and compiler LEXENV instances,
          ;; so that if a subform is reached having a non-simple operator, the compiler
          ;; can be invoked in the equivalent environment. In terms of speed, it scarcely
          ;; matters that we have to search in a list of 8 things here.
          ;; maybe SPECIAL-OPERATOR-P is actually redundant here?
          ((setq special (special-form-handler fname))
           (cond ((or (eq sb-ext:*evaluator-mode* :interpret)
                      (member fname '(quote eval-when if progn setq
                                      locally macrolet symbol-macrolet)))
                  (let ((handler (cdr special))) ; immediate handler
                    (if (functionp handler)
                        (funcall handler (cdr exp) env)
                        (dispatch (%sexpr exp) env))))
                 (t
                  (compile-it))))
          (t ; Everything else: macros and functions.
           (multiple-value-bind (fn macro-p) (get-function (car exp) env)
             (if macro-p
                 (%eval (funcall (valid-macroexpand-hook) fn exp env) env)
                 (apply-it fn))))))
       (compile-it () ; the escape hatch for evaluator-mode = :COMPILE.
         (sb-impl::%simple-eval
          exp (if env (lexenv-from-env env) (make-null-lexenv))))
       (apply-it (f)
         (let ((args (mapcar (lambda (arg) (%eval arg env)) (cdr exp)))
               (h *applyhook*))
           (if (or (null h)
                   (eq h (load-time-value #'funcall t))
                   (eq h 'funcall))
               (apply f args)
               (funcall h f args)))))
    ;; Binding *EVAL-LEVEL* inhibits tail-call, so try to avoid it
    (if *eval-verbose*
        (let ((*eval-level* (1+ *eval-level*)))
          (let ((*print-circle* t))
            (format t "~&~vA~S~%" *eval-level* "" `(%eval ,exp)))
          (%%eval))
        (%%eval))))

;; DIGEST-FORM both "digests" and EVALs a form.
;; It should stash an optimized handler into the SEXPR so that DIGEST-FORM
;; will (ideally) not be called again on this SEXPR.
;; The new handler is invoked right away.
;;
;; A few special-form-processors exist for standard macros. I test INFO on
;; special-forms before considering FIND-LEXICAL-FUN. After I apply my
;; globaldb speedups, it will actually be faster to use the two-part test
;; than just check the lexical environment. Usually existence of a processor
;; implies a special form, which is illegal to rebind lexically; whereas
;; technically it's legal to rebind standard macros, though weird and
;; scoring no readability points.
;;
(defun digest-form (form env sexpr)
  (declare (sexpr sexpr))
  (cond ((symbolp form) ; CLHS 3.1.2.1.1 Symbols as Forms
         (return-from digest-form (symeval form env sexpr)))
        ((not (listp form)) ; CLHS 3.1.2.1.3 Self-Evaluating Objects
         (setf (sexpr-handler sexpr) (return-constant form))
         (return-from digest-form form)))
  ;; CLHS 3.1.2.1.2 Conses as Forms
  (let ((fname (car form)))
    (cond ((eq fname 'setq)
           ;; SETQ mandates a different protocol which slightly
           ;; simplifies the treatment of symbol macros.
           (return-from digest-form
             (eval-setq (cdr form) env sexpr)))
          ((typep fname '(cons (eql lambda)))
           ;; CLHS 3.1.2.1.2.4 "A lambda form is equivalent to using funcall of
           ;; a lexical closure of the lambda expression on the given arguments."
           (return-from digest-form
             (digest-form `(funcall #',fname ,@(cdr form)) env sexpr)))
          ((not (symbolp fname))
           (%program-error "Invalid function name: ~S" fname)))
    ;; CLHS 3.1.2.1.2.1 Special Forms.
    ;; Also a macro that has a special operator.
    (when (special-form-handler fname)
      (let ((processor (car (special-form-handler fname)))) ; deferred handler
        (when (functionp processor)
          (return-from digest-form
            (let ((digested-form (funcall processor (cdr form) env)))
              (setf (sexpr-handler sexpr) digested-form)
              (%dispatch sexpr env))))))
    (let ((frame-ptr (local-fn-frame-ptr fname env)))
      (if (eq frame-ptr :macro)
          ;; CLHS 3.1.2.1.2.2 Macro Forms
          (multiple-value-bind (expansion keys)
              (tracing-macroexpand-1 form env)
            (cond (keys
                   (setf expansion (%sexpr expansion)
                           (sexpr-handler sexpr)
                           (digest-macro-form expansion fname keys))
                   (dispatch expansion env))
                  (t
                   (digest-form expansion env sexpr))))
        (progn
          (setf (sexpr-handler sexpr)
                (if frame-ptr ; a lexical function
                    (digest-local-call frame-ptr (cdr form))
                    (digest-global-call fname (cdr form) env)))
          (%dispatch sexpr env))))))

(fmakunbound 'eval-in-environment)
(defun eval-in-environment (form env)
  (incf *eval-calls*)
  (let ((interpreter-env
         (typecase env
          (sb-kernel:lexenv (if (sb-c::null-lexenv-p env) nil (env-from-lexenv env)))
          (t env))))
    (if (eq interpreter-env :compile)
        (funcall (handler-case
                     ;; Final arg of T means signal errors immediately rather
                     ;; than returning a function that signals when called.
                     (sb-c:compile-in-lexenv `(lambda () ,form) env nil nil nil nil t)
                  (error ()
                     ;; Whatever went wrong, just say "too complex"
                   (error 'compiler-environment-too-complex-error
                          :format-control
                          "~@<Lexical environment is too complex to evaluate in: ~S~:@>"
                          :format-arguments (list env)))))
        ;; FIXME: should this be (OR INTERPRETER-ENV (CAPTURE-TOPLEVEL-ENV)) ?
        ;; Whether we decide to capture the policy here or not, there will always
        ;; be some use-case that comes out wrong. Capturing it is necessary for
        ;; the following to work in the interpreter:
        #|
        (defmacro some-macro (x &environment e)
          (if (policy e (= safety 3)) (expand-to-safe-code) (expand-normally)))
        (with-compilation-unit (:policy '(optimize (safety 3)))
           (some-macro (whatever)))
        |#
        ;; because WITH-COMPILATION-UNIT rebinds *POLICY* and so we need
        ;; to look at that policy regardless of whether interpreting or compiling.
        ;; But %COERCE-TO-POLICY as used in the (POLICY) macro would return
        ;; **BASELINE-POLICY** instead of *POLICY* when given NIL as the env,
        ;; because the compiler wants that.
        ;; But if we do capture the policy up front, then we _fail_ to see
        ;; any changes that are made by PROCLAIM because those _don't_
        ;; affect the policy in an interpreter environment.
        (%eval form interpreter-env))))

;;; Return a handler that returns a constant.
;;; The %SEXPR constructor elides a handler for constants,
;;; but there are cases where NIL sneaks through and demands a callable handler.
;;; We avoid generating N copies of such handler. Same goes for 0 and T.
;;; Moved here as LOAD-TIME-VALUE has to happen after the file
;;; containing %HANDLER has been loaded.
(defun return-constant (object)
  (cond ((null object) (load-time-value (handler #'%const nil)))
        ((eq object t) (load-time-value (handler #'%const t)))
        ((eql object 0) (load-time-value (handler #'%const 0)))
        (t (handler #'%const object))))

(push
  (let ((this-pkg (find-package "SB-INTERPRETER")))
    `("SB-INTERPRETER"
      %%eval ; got inlined
      ,@(let (macros)
          (do-symbols (s "SB-INTERPRETER" macros)
            (when (and (eq (symbol-package s) this-pkg)
                       (macro-function s)
                       (not (member s '(defspecial with-subforms do-decl-spec)))) ; for SB-CLTL2
              (push s macros)))
          macros)))
  *!removable-symbols*)
