path: root/sb-eval2.lisp

(defpackage "SB-EVAL2"
  (:use "COMMON-LISP")
  (:shadow "EVAL" "LOAD")
  (:export "EVAL" "LOAD"))

(in-package "SB-EVAL2")

;;(declaim (optimize (debug 3) (space 0) (speed 0) (safety 3) (compilation-speed 0)))
(declaim (optimize (debug 0) (space 0) (speed 3) (safety 0) (compilation-speed 0)))

(defconstant +stack-max+ 8)

(defmacro specialize (var value possible-values &body body)
  `(ecase ,value
     ,@(loop for x in (cl:eval possible-values)
             collect
                `((,x) ,(cl:eval `(let ((,var ,x)) ,@body))))))

(declaim (inline %make-environment))
(defstruct (environment (:constructor %make-environment))
  (parent nil :type (or null environment))
  (data nil :type (or null simple-vector)))

(declaim (inline make-null-environment))
(defun make-null-environment () (make-environment nil 0))

(declaim (inline make-environment))
(defun make-environment (parent
                         &optional (size 0)
                         &aux (data
                               (unless (zerop (the fixnum size))
                                 (make-array
                                  (list size)))))
  (%make-environment :parent parent :data data))

(defmacro with-dynamic-extent-environment ((var parent size) &body body)
  (let ((data% (gensym))
        (size% (gensym)))
    `(let* ((,size% ,size)
            (,data% (make-array (list ,size%)))
            (,var (%make-environment :parent ,parent :data ,data%)))
       (declare (type (mod #.(1+ +stack-max+)) ,size%)
                ;; we must not allocate environment objects on the
                ;; stack unless we can be sure that all child
                ;; environments will also be allocated on the stack,
                ;; but we can't really know that.
                ;(dynamic-extent ,var)
                (dynamic-extent ,data%))
       ,@body)))

(defclass lexical ()
  ((name    :accessor lexical-name    :initarg :name    :type (or symbol list))))

(defclass env-lexical (lexical)
  ((offset  :accessor lexical-offset  :initarg :offset  :type fixnum)
   (nesting :accessor lexical-nesting :initarg :nesting :type fixnum)))

(defun make-env-lexical (name offset &optional (nesting -1))
  (make-instance 'env-lexical :name name :offset offset :nesting nesting))

(defun lexical-with-nesting (lexical nesting)
  (make-env-lexical (lexical-name lexical) (lexical-offset lexical) nesting))

(defun maybe-references-p/env (form vars env)
  ;; Use `(function ,name) for local functions.
  ;;
  ;; FIXME: This doesn't do macro expansion, so it's probably
  ;; incorrect.
  (let ((sb-walker::*walk-form-expand-macros-p* t))
    (sb-walker:walk-form
     form
     env
     (lambda (x ctx env)
       (declare (ignore ctx))
       (when (and (member x vars :test #'equal)
                  (not (sb-walker:var-special-p x env))
                  (not (sb-walker:var-lexical-p x env)))
         (return-from maybe-references-p/env t))
       x)))
  nil)

(defun maybe-closes-over-p (context form vars)
  (handler-case
      (maybe-closes-over-p/env form vars (context->native-environment context))
    (serious-condition () t)))

(defun maybe-closes-over-p/env (form vars env)
  (let ((sb-walker::*walk-form-expand-macros-p* t))
    (sb-walker:walk-form
     form
     env
     (lambda (x ctx env)
       (declare (ignore ctx))
       (typecase x
         (cons
          (destructuring-bind (a . b) x
            (case a
              ((lambda)
               (when (maybe-references-p/env form vars env)
                 (return-from maybe-closes-over-p/env t)))
              ((flet labels)
               (typecase b
                 (cons
                  (destructuring-bind (bindings . rest) form
                    (when (or (maybe-references-p/env bindings vars env)
                              (maybe-closes-over-p/env rest vars env))
                      (return-from maybe-closes-over-p/env t))))
                 (t
                  (when (maybe-closes-over-p/env b vars env)
                    (return-from maybe-closes-over-p/env t)))))))))
       x)))
  nil)

(defstruct (context (:constructor make-context (&optional parent)))
  parent
  (env-hop nil :type boolean)
  (block-tags nil :type list)
  (go-tags nil :type list)
  (symbol-macros nil :type list)
  (macros nil :type list)
  (lexicals nil :type list)
  (specials nil :type list))
(defun make-null-context ()
  (make-context nil))
(defun context-add-block-tag (context block tag)
  (let ((new-context (make-context context)))
    (with-slots (block-tags)
        new-context
      (setq block-tags (acons block tag block-tags)))
    new-context))
(defun context-block-tag (context block)
  (let ((parent (context-parent context)))
    (or (cdr (assoc (the symbol block) (context-block-tags context)))
        (and parent (context-block-tag parent block)))))
(defun context-add-go-tags (context new-go-tags catch-tag)
  (let ((new-context (make-context context)))
    (with-slots (go-tags)
        new-context
      (dolist (new-go-tag new-go-tags)
        (setq go-tags (acons new-go-tag catch-tag go-tags))))
    new-context))
(defun context-collect (context f)
  (let ((parent (context-parent context)))
    (append (funcall f context) (and parent (context-collect parent f)))))
(defun context-find-go-tag (context go-tag)
  (let ((parent (context-parent context)))
    (or (cdr (assoc (the atom go-tag) (context-go-tags context)))
        (and parent (context-find-go-tag parent go-tag)))))
(defun context-find-symbol-macro (context symmac)
  (let ((parent (context-parent context)))
    (and (not (member symmac
                      (context-lexicals context)
                      :test #'equal
                      :key #'lexical-name))
         (not (member symmac (context-specials context) :test #'equal))
         (or (cdr (assoc (the symbol symmac) (context-symbol-macros context)))
             (and parent (context-find-symbol-macro parent symmac))))))
(defun context-find-macro (context mac)
  (let ((parent (context-parent context)))
    (and (not (member `(function ,mac)
                      (context-lexicals context)
                      :test #'equal
                      :key #'lexical-name))
         (or (cdr (assoc (the (or symbol list) mac)
                         (context-macros context)
                         :test #'equal))
             (and parent (context-find-macro parent mac))))))
(defun context-add-symbol-macros (context bindings)
  (let ((new-context (make-context context)))
    (with-slots (symbol-macros)
        new-context
      (setq symbol-macros (append bindings symbol-macros)))
    new-context))
(defun context-add-macros (context bindings)
  (let ((new-context (make-context context)))
    (with-slots (macros)
        new-context
      (setq macros (append bindings macros)))
    new-context))
(defun parse-tagbody-tags-and-bodies (forms)
  (let ((next-form (gensym))
        (finishp nil))
    (loop until finishp
          collect
             (progn
               (unless forms
                 (setq finishp (null forms)))
               (let ((tag next-form)
                     (current-forms (loop for current-form = (pop forms)
                                          do (setq next-form current-form)
                                          until (atom current-form)
                                          collect current-form)))
                 (cons tag current-forms))))))
(defun context-var-symbol-macro-p (context var)
  (and (not (find var (context-specials context) :test #'equal))
       (not (find var (context-lexicals context) :key #'lexical-name :test #'equal))
       (or (find var (context-symbol-macros context) :key #'car :test #'equal)
           (and (context-parent context)
                (context-var-symbol-macro-p (context-parent context) var)))))
(defun context-var-lexical-p (context var)
  (and (not (find var (context-specials context) :test #'equal))
       (not (find var (context-symbol-macros context) :key #'car :test #'equal))
       (or (find var (context-lexicals context) :key #'lexical-name :test #'equal)
           (and (context-parent context)
                (context-var-lexical-p (context-parent context) var)))))
(defun context-var-special-p (context var)
  (and (not (find var (context-lexicals context) :key #'lexical-name :test #'equal))
       (not (find var (context-symbol-macros context) :key #'car :test #'equal))
       (or (find var (context-specials context) :test #'equal)
           (and (context-parent context)
                (context-var-special-p (context-parent context) var)))))
(defun context-add-env-lexicals (context vars)
  ;; open a new variable context
  (let ((new-context (make-context context)))
    (with-slots (lexicals env-hop)
        new-context
      (setq env-hop t)
      (setq lexicals (loop for i fixnum from 0
                           for v in vars
                           collect (make-env-lexical v i))))
    new-context))
(defun make-lexical-context (context)
  (let ((new-context (make-context context)))
    (setf (context-env-hop new-context) t)
    new-context))
(defun context-add-env-lexical! (context var)
  (with-slots (lexicals)
      context
    (push (make-env-lexical var (length lexicals)) lexicals))
  (values))
(defun context-add-specials (context vars)
  (let ((new-context (make-context context)))
    (setf (context-specials new-context) vars)
    new-context))
(defun context-add-special! (context var)
  (with-slots (specials)
      context
    (push var specials))
  (values))
(defun context-add-env-functions (context fs)
  (context-add-env-lexicals context (mapcar (lambda (x) `(function ,x)) fs)))
(defun context-find-lexical (context var)
  (loop with env-level = 0
        until (null context)
        for record = (find var
                           (context-lexicals context)
                           :key #'lexical-name
                           :test #'equal)
        when record
          do (return
               (etypecase record
                 (env-lexical   (lexical-with-nesting record env-level))))
        when (context-env-hop context)
          do (incf env-level)
        do (setq context (context-parent context))))

(deftype eval-closure () `(function (environment) *))

(declaim (inline environment-value))
(defun environment-value (env nesting offset)
  (dotimes (i (the fixnum nesting))
    (setq env (environment-parent env)))
  (svref (environment-data env) offset))

(declaim (inline (setf environment-value)))
(defun (setf environment-value) (val env nesting offset)
  (dotimes (i (the fixnum nesting))
    (setq env (environment-parent env)))
  (setf (svref (environment-data env) offset) val))

(declaim (ftype (function (symbol context) eval-closure) prepare-ref))
(defun prepare-ref (var context)
  (if (context-var-lexical-p context var)
      (let* ((lexical (context-find-lexical context var))
             (nesting (lexical-nesting lexical))
             (offset (lexical-offset lexical)))
        (etypecase lexical
          (env-lexical
           (lambda (env)
             (environment-value env nesting offset)))))
      (lambda (env)
        (declare (ignore env))
        (symbol-value var))))


(defun body-decls&forms (exprs)
  (let* ((decl-exprs
           (loop while (and (consp (first exprs))
                            (eq 'declare (first (first exprs))))
                 for expr = (pop exprs)
                 collect expr))
         (decls (reduce #'append (mapcar #'rest decl-exprs))))
    (values decls exprs)))

(defun decl-specials (declaration)
  (when (eq (first declaration) 'special)
    (rest declaration)))

(defmacro with-parsed-body ((forms-var specials-var) exprs &body body)
  (let ((decls (gensym)))
    `(multiple-value-bind (,decls ,forms-var) (body-decls&forms ,exprs)
       (let ((,specials-var (mapcan #'decl-specials ,decls)))
         ,@body))))


(declaim (ftype (function ((or symbol list) context) eval-closure) prepare-function-ref))
(defun prepare-function-ref (function-name context)
  (if (context-var-lexical-p context `(function ,function-name))
      (let* ((lexical (context-find-lexical context `(function ,function-name)))
             (nesting (lexical-nesting lexical))
             (offset  (lexical-offset lexical)))
        (lambda (env)
          (environment-value env nesting offset)))
      (let ((f* (sb-c::fdefinition-object function-name t)))
        (lambda (env)
          (declare (ignore env))
          (or (sb-c::fdefn-fun f*)
              (error 'undefined-function :name function-name))))))


(declaim (ftype (function (context (or symbol list)) *) context-find-function))
(defun context-find-function (context f)
  (context-find-lexical context `(function ,f)))

(declaim (ftype (function (context (or symbol list)) *) local-function-p))
(defun local-function-p (context f)
  (context-find-function context f))

(declaim (ftype (function () eval-closure) prepare-nil))
(defun prepare-nil ()
  (lambda (env) (declare (ignore env))))

(declaim (ftype (function ((or symbol list) list context) eval-closure) prepare-local-call))
(defun prepare-local-call (f args context)
  (let* ((args* (mapcar (lambda (form) (prepare-form form context)) args))
         (flex (context-find-function context f))
         (offset (lexical-offset flex))
         (nesting (lexical-nesting flex)))
    (if (< (length args) 20)
        (specialize m% (length args) (loop for i from 0 below 20 collect i)
          (let ((argvars (loop for i from 0 below m%
                               collect (gensym (format nil "ARG~D-" i)))))
            `(let ,(loop for var in argvars
                         for i from 0 below m%
                         collect `(,var (nth ,i args*)))
               (lambda (env)
                 (funcall (the function (environment-value env nesting offset))
                          ,@(loop for var in argvars
                                  collect `(funcall (the eval-closure ,var) env)))))))
        (lambda (env)
          (apply (the function (environment-value env nesting offset))
                 (mapcar (lambda (x) (funcall (the eval-closure x) env)) args*))))))

(declaim (ftype (function ((or symbol list) list context) eval-closure) prepare-global-call))
(defun prepare-global-call (f args context)
  (let ((args* (mapcar (lambda (form) (prepare-form form context)) args))
        (f* (sb-c::fdefinition-object f t)))
    (if (< (length args) 20)
        (specialize m% (length args) (loop for i from 0 below 20 collect i)
          (let ((argvars (loop for i from 0 below m%
                               collect (gensym (format nil "ARG~D-" i)))))
            `(let ,(loop for var in argvars
                         for i from 0 below m%
                         collect `(,var (nth ,i args*)))
               (lambda (env)
                 (declare (ignorable env))
                 (funcall (or (sb-c::fdefn-fun f*)
                              (error 'undefined-function :name f))
                          ,@(loop for var in argvars
                                  collect `(funcall (the eval-closure ,var) env)))))))
        (lambda (env)
          (apply (or (sb-c::fdefn-fun f*)
                     (error 'undefined-function :name f))
                 (mapcar (lambda (x) (funcall (the eval-closure x) env))
                         args*))))))

(declaim (ftype (function (eval-closure list context) eval-closure) prepare-direct-call))
(defun prepare-direct-call (f args context)
  (let ((args* (mapcar (lambda (form) (prepare-form form context)) args)))
    (lambda (env)
      (apply (the (or symbol function) (funcall (the eval-closure f) env))
             (mapcar (lambda (x) (funcall (the eval-closure x) env)) args*)))))

(declaim (ftype (function (list context &optional symbol)
                          (values eval-closure &rest nil))
                prepare-progn))
(defun prepare-progn (forms context &optional (*mode* *mode*))
  (let ((body* (mapcar (lambda (form) (prepare-form form context)) forms)))
    (if (null body*)
        (prepare-nil)
        (let ((forms* (butlast body*))
              (last-form* (first (last body*))))
          (lambda (env)
            (dolist (form* forms*)
              (funcall (the eval-closure form*) env))
            (funcall (the eval-closure last-form*) env))))))

(defun lambda-binding-vars (entry kind)
  (check-type kind (member :aux :optional :key :required))
  (ecase kind
    ((:key :optional)
     (etypecase entry
       (cons   (list (etypecase (first entry)
                       (cons   (second (first entry)))
                       (symbol (first entry)))
                     (if (cddr entry)
                         (third entry)
                         (gensym))))
       (symbol (list entry (gensym)))))
    ((:required)
     (etypecase entry
       (cons   (list (first entry)))
       (symbol entry)))
    ((:aux)
     (etypecase entry
       (cons   (list (first entry)))
       (symbol entry)))))

(defun lambda-binding-main-var (entry)
  (etypecase entry
    (cons   (etypecase (first entry)
              (cons   (second (first entry)))
              (symbol (first entry))))
    (symbol entry)))

(defun lambda-simple-binding-vars (entry)
  (etypecase entry
    (cons   (list (first entry)))
    (symbol (list entry))))

(defun lambda-binding-default (entry)
  (etypecase entry
    (cons   (second entry))
    (symbol nil)))

(defun lambda-key (entry)
  (flet ((keywordify (sym)
           (intern (symbol-name sym) "KEYWORD")))
    (etypecase entry
      (cons   (etypecase (first entry)
                (cons   (first (first entry)))
                (symbol (keywordify (first entry)))))
      (symbol (keywordify entry)))))

(declaim (ftype (function * eval-closure) prepare-macro-lambda))
(defun prepare-macro-lambda (name lambda-form context)
  (destructuring-bind (lambda-list &rest body)
      lambda-form
    (let* ((whole (gensym "WHOLE"))
           (env   (gensym "ENV"))
           (body-form (sb-kernel:parse-defmacro lambda-list
                                                whole
                                                body
                                                name
                                                'macrolet
                                                :environment env)))
      (prepare-lambda `((,whole ,env) ,body-form)
                      context
                      ;;:name name
                      ))))

(defmacro incff (x &optional (num 1))
  (let ((old-x (gensym)))
    `(let ((,old-x ,x))
       (incf ,x ,num)
       ,old-x)))

(defmacro nlet (loop-var bindings &body body)
  `(labels ((,loop-var ,(mapcar #'first bindings)
              ,@body))
     (,loop-var ,@(mapcar #'second bindings))))

(defmacro dnlet (loop-var bindings &body body)
  `(labels ((,loop-var ,(mapcar #'first bindings)
              ,@body))
     (declare (dynamic-extent #',loop-var))
     (,loop-var ,@(mapcar #'second bindings))))

(declaim (ftype (function * eval-closure) prepare-lambda))
(defun prepare-lambda (lambda-form context &key (name nil namep))
  (destructuring-bind (lambda-list &rest exprs) lambda-form
    (with-parsed-body (body specials) exprs
      (multiple-value-bind (required optional restp rest keyp keys allowp auxp aux
                            morep more-context more-count)
          (sb-int:parse-lambda-list lambda-list)
        (declare (ignore more-context more-count))
        (declare (ignorable auxp))
        (when morep
          (error "The interpreter does not support the lambda-list keyword ~S"
                 'sb-int:&more))
        (let* ((argvars (append required
                                (mapcan (lambda (x) (lambda-binding-vars x :optional)) optional)
                                (and restp (list rest))
                                (mapcan (lambda (x) (lambda-binding-vars x :key)) keys)
                                (mapcan (lambda (x) (lambda-binding-vars x :aux)) aux)))
               (keywords (mapcar #'lambda-key keys))
               (required-num (length required))
               (optional-num (length optional))
               (key-num (length keys))
               (aux-num (length aux))
               (default-values (append (mapcar #'lambda-binding-default optional)
                                       (mapcar #'lambda-binding-default keys)
                                       (mapcar #'lambda-binding-default aux)))
               (new-context (make-lexical-context context))
               (varspecs (list))
               (varnum 0)
               (default-values*
                 (flet ((register-var (var)
                          (if (or (member var specials :test #'eq)
                                  (globally-special-p var))
                              (progn
                                (context-add-special! new-context var)
                                (push (cons :special var) varspecs))
                              (progn
                                (context-add-env-lexical! new-context var)
                                (push :lexical varspecs)
                                (incf (the fixnum varnum))))))
                   (mapc #'register-var required)
                   (flet ((process-bindings (bindings kind)
                            (loop for binding in bindings
                                  for default-value = (lambda-binding-default binding)
                                  for vars = (lambda-binding-vars binding kind)
                                  collect (prepare-form default-value new-context)
                                  do (mapc #'register-var vars))))
                     (append (process-bindings optional :optional)
                             (progn (when restp (register-var rest)) '())
                             (process-bindings keys :key)
                             (process-bindings aux :aux)))))
               (envp (or (> varnum +stack-max+)
                         (maybe-closes-over-p context `(progn ,@body) argvars)
                         (some (lambda (x) (maybe-closes-over-p context x argvars))
                               default-values)))
               (body-context (context-add-specials new-context specials))
               (body* (prepare-form
                       (if namep
                           `(block ,(sb-int:fun-name-block-name name) ,@body)
                           `(progn ,@body))
                       body-context))
               (unbound (gensym)))
          (setq varspecs (nreverse varspecs))
          (flet
              ((handle-arguments (new-env &rest args)
                 ;;(declare (dynamic-extent args))
                 ;; All this ELT and LENGTH stuff is not as
                 ;; inefficient as it looks.  SBCL transforms
                 ;; &rest into &more here.
                 (dnlet iter
                     ((rest
                       (when (or restp keyp)
                         (loop for i
                               from (+ required-num optional-num)
                               below (length args)
                               collect (elt args i))))
                      (restnum (max 0 (- (length args) (+ required-num optional-num))))
                      (keys-checked-p nil)
                      (my-default-values* default-values*)
                      (my-keywords keywords)
                      (my-varspecs varspecs)
                      (argi 0)        ;how many actual arguments have
                                      ;been processed
                      (vari 0)        ;how many lexical vars have been
                                      ;bound
                      (i 0))          ;how many formal arguments have
                                      ;been processed
                     (declare (fixnum restnum argi vari i))
                     (flet ((push-args (&rest values)
                              ;; Push VALUES onto the
                              ;; environment.
                              (incf i)
                              (dolist (value values)
                                (let ((varspec (pop my-varspecs)))
                                  (if (eq varspec :lexical)
                                      (setf
                                       (environment-value new-env 0 (incff vari))
                                       value)
                                      (let ((var (cdr varspec)))
                                        (assert (eq :special
                                                    (car varspec))
                                                (varspec))
                                        (return-from iter
                                          (progv (list var) (list value)
                                            (iter rest restnum keys-checked-p
                                                  my-default-values* my-keywords
                                                  my-varspecs argi vari i)))))))))
                       (declare (inline push-args))
                       (prog ()
                        positional
                          (when (>= argi (length args))
                            (go missing-optionals))
                          (when (>= argi (the fixnum
                                              (+ required-num optional-num)))
                            (go rest))
                          (if (>= argi required-num)
                              (progn
                                (pop my-default-values*)
                                (push-args (elt args (incff argi)) t))
                              (push-args (elt args (incff argi))))
                          (go positional)
                        missing-optionals
                          (unless (>= argi required-num)
                            (error 'sb-int:simple-program-error
                                   :format-control "invalid number of arguments: ~D"
                                   :format-arguments (list (length args))))
                          (when (>= i (the fixnum (+ required-num
                                                     optional-num)))
                            (go rest))
                          (let ((val* (pop my-default-values*)))
                            (push-args (funcall (the eval-closure val*)
                                                new-env)
                                       nil))
                          (go missing-optionals)
                        rest
                          (when (>= i (the fixnum
                                           (+ (if restp 1 0)
                                              (the fixnum
                                                   (+ required-num optional-num)))))
                            (go keys))
                          (when restp
                            (push-args rest))
                        keys
                          (unless keyp
                            (unless (or restp (= argi (length args)))
                              (error 'sb-int:simple-program-error
                                     :format-control "invalid number of arguments: ~D"
                                     :format-arguments (list (length args))))
                            (go aux))
                          (unless (evenp restnum)
                            (error 'sb-int:simple-program-error
                                   :format-control "odd number of keyword arguments: ~S"
                                   :format-arguments (list rest)))
                          (when (>= i
                                    (the fixnum
                                         (+ (if restp 1 0)
                                            (the fixnum
                                                 (+ required-num
                                                    (the fixnum
                                                         (+ optional-num
                                                            key-num)))))))
                            (unless (or keys-checked-p
                                        allowp
                                        (getf rest :allow-other-keys nil))
                              (loop for (k v) on rest by #'cddr
                                    unless (or (eq k :allow-other-keys)
                                               (member k keywords :test #'eq))
                                    do (error 'sb-int:simple-program-error
                                              :format-control "unknown &KEY argument: ~A"
                                              :format-arguments (list k)))
                              (setq keys-checked-p t))
                            (go aux))
                          (let* ((key  (the symbol (pop my-keywords)))
                                 (val* (pop my-default-values*))
                                 (x    (getf rest key unbound)))
                            (if (eq unbound x)
                                (progn
                                  (push-args (funcall (the eval-closure val*) new-env)
                                             nil))
                                (progn
                                  (push-args x t))))
                          (go keys)
                        aux
                          (when (>= i
                                    (+ (if restp 1 0)
                                       (the fixnum
                                            (+ required-num
                                               (the fixnum
                                                    (+ optional-num
                                                       key-num))
                                               aux-num))))
                            (go final-call))
                          (let ((val* (pop my-default-values*)))
                            (push-args (funcall (the eval-closure val*)
                                                new-env)))
                          (go aux)
                        final-call
                          (assert (null my-default-values*)
                                  (my-default-values*))
                          (return
                            (funcall body* new-env)))))))
              ;;(declare (inline handle-arguments))  ;crashes the compiler! lp#1203260
              (if envp
                  (lambda (env)
                    (lambda (&rest args)
                      (declare (dynamic-extent args))
                      (let ((new-env (make-environment env varnum)))
                        (apply #'handle-arguments new-env args))))
                  (lambda (env)
                    (lambda (&rest args)
                      (declare (dynamic-extent args))
                      (with-dynamic-extent-environment (new-env env varnum)
                        (apply #'handle-arguments new-env args)))))))))))

(defun context->native-environment (context)
  (let ((functions
          (loop for (name . expander) in (context-collect context 'context-macros)
                collect `(,name . (sb-c::macro . ,expander))))
        (vars
          (loop for (name . form) in (context-collect context 'context-symbol-macros)
                collect `(,name . (sb-c::macro . ,form)))))
    (sb-c::internal-make-lexenv functions vars nil nil nil nil nil nil nil nil nil)))

(defun native-environment->context (lexenv)
  (with-accessors ((functions sb-c::lexenv-funs)
                   (vars      sb-c::lexenv-vars))
      lexenv
    (let ((context (make-context nil))
          (macros%
            (loop for (name . functional) in vars
                  when (eq (car functional) 'sb-c::macro)
                  collect `(,name . ,(cdr functional))))
          (symbol-macros%
            (loop for (name . form) in functions
                  when (eq (car form) 'sb-c::macro)
                  collect `(,name . ,(cdr form)))))
      (with-slots (macros symbol-macros)
          context
        (setq macros macros%)
        (setq symbol-macros symbol-macros%))
      context)))

(defun globally-special-p (var)
  (eq :special (sb-int:info :variable :kind var)))

(defun assume-special (context var)
  (unless (context-var-special-p context var)
    (warn 'simple-warning
          :format-control "Undefined variable: ~S"
          :format-arguments (list var))))

(defvar *mode* :not-compile-time)

(declaim (ftype (function (* context &optional symbol) eval-closure) prepare-form))
(defun prepare-form (form context &optional (mode *mode*) &aux (*mode* :execute))
  ;;(declare (optimize speed (safety 0) (space 1) (debug 0)))
  ;;(print form)
  (values
   (cond
     ((sb-int:self-evaluating-p form)
      (lambda (env) (declare (ignore env)) form))
     (t
      (etypecase form
        (symbol
         (let ((macro? (context-find-symbol-macro context form)))
           (if macro?
               (prepare-form macro? context mode)
               (prepare-ref form context))))
        (cons
         (case (first form)
           ((if)
            (destructuring-bind (a b &optional c) (rest form)
              (let ((a* (prepare-form a context))
                    (b* (prepare-form b context))
                    (c* (prepare-form c context)))
                (lambda (env) (if (funcall a* env) (funcall b* env) (funcall c* env))))))
           ((function)
            (let ((fun-form (second form)))
              (etypecase fun-form
                (symbol
                 (prepare-function-ref fun-form context))
                (cons
                 (ecase (first fun-form)
                   ((lambda)
                    (prepare-lambda (rest fun-form) context))
                   ((sb-int:named-lambda)
                    (prepare-lambda (cddr fun-form) context))
                   ((setf sb-pcl::slot-accessor)
                    (prepare-function-ref fun-form context)))))))
           ((lambda)
            (prepare-lambda (rest form) context))
           ((setq)
            (let ((binding-forms (rest form)))
              (let ((bindings
                      (loop for (var valform) on binding-forms by #'cddr
                            collect var
                            collect
                               (cond ((context-var-symbol-macro-p context var)
                                      (let ((form
                                              (context-find-symbol-macro context var)))
                                        (prepare-form `(setf ,form ,valform)
                                                      context)))
                                     ((context-var-lexical-p context var)
                                      (context-find-lexical context var))
                                     (t
                                      (assume-special context var)
                                      :special))
                            collect (prepare-form valform context))))
                (lambda (env)
                  (loop for (var info val*) on bindings by #'cdddr
                        for value = (funcall (the eval-closure val*) env)
                        for result =
                           (progn
                             (etypecase info
                               (function ;symbol macro setter
                                (funcall info env))
                               (lexical
                                (setf (environment-value env
                                                         (lexical-nesting info)
                                                         (lexical-offset info))
                                      value))
                               (keyword
                                (setf (symbol-value var) value))))
                        finally (return result))))))
           ((catch)
            (destructuring-bind (tag &body body) (rest form)
              (let ((tag* (prepare-form tag context))
                    (body* (prepare-progn body context)))
                (lambda (env)
                  (catch (funcall tag* env)
                    (funcall body* env))))))
           ((block)
            (destructuring-bind (name &body body) (rest form)
              (let* ((tag (gensym (concatenate 'string "BLOCK-" (symbol-name name))))
                     (body* (prepare-progn body (context-add-block-tag context name tag))))
                (lambda (env)
                  (catch tag
                    (funcall body* env))))))
           ((declare)
            (warn "DECLARE in form context.")
            (prepare-nil))
           ((eval-when)
            (destructuring-bind ((&rest times) &body body) (rest form)
              (cond ((member mode '(:not-compile-time :compile-time-too))
                     (let ((ct (or (member :compile-toplevel times)
                                   (member 'cl:compile times)))
                           (lt (or (member :load-toplevel times)
                                   (member 'cl:load times)))
                           (e  (or (member :execute times)
                                   (member 'cl:eval times))))
                       (cond ((and lt ct)
                              (prepare-progn body context :compile-time-too))
                             ((and lt e)
                              (prepare-progn body context mode))
                             (lt
                              (prepare-progn body context :not-compile-time))
                             (ct
                              (prepare-progn body context))
                             ((and e (eq mode :compile-time-too))
                              (prepare-progn body context))
                             (t
                              (prepare-nil)))))
                    ((or (member :execute times)
                         (member 'cl:eval times))
                     (prepare-progn body context))
                    (t
                     (prepare-nil)))))
           ((flet)
            (destructuring-bind (bindings &rest exprs) (rest form)
              (with-parsed-body (body specials) exprs
                (let* ((bindings* (mapcar (lambda (form)
                                            (if (listp form)
                                                (cons (first form)
                                                      (prepare-lambda (rest form)
                                                                      context
                                                                      :name (first form)))
                                                (cons form (prepare-nil))))
                                          bindings))
                       (new-context
                         (context-add-env-functions context (mapcar #'first bindings*)))
                       (functions (mapcar #'cdr bindings*))
                       (n (length functions))
                       (body* (prepare-progn body
                                             (context-add-specials new-context
                                                                   specials))))
                  (lambda (env)
                    (let ((new-env (make-environment env n)))
                      (loop for i from 0 to n
                            for f in functions
                            do (setf (environment-value new-env 0 i)
                                     (funcall (the eval-closure f) env)))
                      (funcall body* new-env)))))))
           ((labels)
            (destructuring-bind (bindings &rest exprs) (rest form)
              (with-parsed-body (body specials) exprs
                (let* ((new-context (context-add-env-functions context (mapcar #'first bindings)))
                       (bindings* (mapcar (lambda (form)
                                            (if (listp form)
                                                (cons (first form)
                                                      (prepare-lambda (rest form) new-context :name (first form)))
                                                (cons form (prepare-nil))))
                                          bindings))
                       (functions (mapcar #'cdr bindings*))
                       (n (length functions))
                       (body* (prepare-progn body (context-add-specials new-context
                                                                        specials))))
                  (lambda (env)
                    (let ((new-env (make-environment env n)))
                      (loop for i from 0 to n
                            for f in functions
                            do (setf (environment-value new-env 0 i)
                                     (funcall (the eval-closure f) new-env)))
                      (funcall body* new-env)))))))
           ((let)
            (destructuring-bind (bindings &rest exprs) (rest form)
              (with-parsed-body (body specials) exprs
                (let* ((real-bindings (mapcar (lambda (form)
                                                (if (listp form)
                                                    (cons (first form) (second form))
                                                    (cons form nil)))
                                              bindings))
                       (vars (mapcar #'car real-bindings))
                       (varnum (length vars))
                       (envp (or (> varnum +stack-max+)
                                 (maybe-closes-over-p context `(progn ,@body) vars)))
                       (new-context
                         (context-add-env-lexicals context (list)))
                       srav-laiceps)
                  (let* ((values*
                           (loop for (var . value-form) in real-bindings
                                 for val* = (prepare-form value-form context)
                                 if (or (member (the symbol var) specials)
                                        (globally-special-p var))
                                 collect (cons t   val*)
                                 and do (push var srav-laiceps)
                                        (context-add-special! new-context var)
                                 else
                                 collect (cons nil val*)
                                 and do (context-add-env-lexical! new-context var)))
                         (body* (prepare-progn body
                                               (context-add-specials
                                                new-context
                                                specials))))
                    (if envp
                        (lambda (env)
                          (let ((new-env (make-environment env varnum))
                                (slav-laiceps (list)))
                            (loop with i fixnum = 0
                                  for (specialp . val*) in values*
                                  when specialp
                                  do (push (funcall (the eval-closure val*) env)
                                           slav-laiceps)
                                  else
                                  do (setf (environment-value new-env 0 i)
                                           (funcall (the eval-closure val*) env))
                                     (incf i))
                            (progv
                                srav-laiceps
                                slav-laiceps
                              (funcall body* new-env))))
                        (lambda (env)
                          (with-dynamic-extent-environment (new-env env varnum)
                            (let ((slav-laiceps (list)))
                              (loop with i fixnum = 0
                                    for (specialp . val*) in values*
                                    when specialp
                                    do (push (funcall (the eval-closure val*) env)
                                             slav-laiceps)
                                    else
                                    do (setf (environment-value new-env 0 i)
                                             (funcall (the eval-closure val*) env))
                                       (incf i))
                              (progv
                                  srav-laiceps
                                  slav-laiceps
                                (funcall body* new-env)))))))))))
           ((let*)
            (destructuring-bind (bindings &rest exprs) (rest form)
              (with-parsed-body (body specials) exprs
                (labels ((build-nested-let (bindings)
                           (if (null bindings)
                               `(progn ,@body)
                               (let* ((binding-form (first bindings))
                                      (var (if (listp binding-form) (first binding-form) binding-form))
                                      (val (if (listp binding-form) (second binding-form) nil)))
                                 `(let ((,var ,val))
                                    (declare (special
                                              ,@(if (or (member var specials)
                                                        (globally-special-p var))
                                                    (list var)
                                                    nil)))
                                    ,(build-nested-let (rest bindings)))))))
                  (prepare-form (build-nested-let bindings) context)))))
           ((load-time-value)
            (let ((load-form (cadr form)))
              ;; FIXME
              (prepare-form load-form context)))
           ((locally)
            (destructuring-bind (&rest exprs) (rest form)
              (with-parsed-body (body specials) exprs
                (let ((new-context (context-add-specials context specials)))
                  (prepare-progn body new-context)))))
           ((multiple-value-call)
            (destructuring-bind (f &rest argforms) (rest form)
              (let ((f* (prepare-form f context))
                    (argforms* (mapcar (lambda (x) (prepare-form x context)) argforms)))
                (lambda (env)
                  (apply (funcall (the eval-closure f*) env)
                         (mapcan (lambda (arg)
                                   (multiple-value-list
                                    (funcall (the eval-closure arg) env)))
                                 argforms*))))))
           ((multiple-value-prog1)
            (destructuring-bind (values-form &body body) (rest form)
              (let ((values-form* (prepare-form values-form context))
                    (body*        (prepare-progn body context)))
                (lambda (env)
                  (multiple-value-prog1
                      (funcall values-form* env)
                    (funcall body* env))))))
           ((multiple-value-setq)
            (destructuring-bind (vars values-form) (rest form)
              (if vars
                  (prepare-form `(values (setf (values ,@vars) ,values-form)) context)
                  (prepare-form `(values ,values-form) context))))
           ((multiple-value-bind)
            ;; FIXME: SPECIAL declarations!
            (destructuring-bind (vars value-form &body exprs) (rest form)
              (with-parsed-body (body specials) exprs
                (let* ((value-form*  (prepare-form value-form context))
                       (varspecs     (loop for var in vars
                                           collect (if (or (member var specials)
                                                           (globally-special-p var))
                                                       (cons :special var)
                                                       :lexical)))
                       (lexicals     (loop for var in vars
                                           for spec in varspecs
                                           when (eq spec :lexical)
                                           collect var))
                       (our-specials (loop for var in vars
                                           for spec in varspecs
                                           unless (eq spec :lexical)
                                           collect var))
                       (nlexicals    (list-length lexicals))
                       (new-context  (context-add-specials
                                      (context-add-env-lexicals context lexicals)
                                      specials))
                       (body*        (prepare-progn body new-context)))
                  (lambda (env)
                    (let* ((new-env (make-environment env nlexicals))
                           (values  (multiple-value-list (funcall value-form* env))))
                      (progv our-specials '()
                        (loop with i = 0
                              for spec in varspecs
                              when (eq spec :lexical)
                                do (setf (environment-value new-env 0 i) (pop values))
                                   (incf i)
                              else
                                do (setf (symbol-value (cdr spec)) (pop values)))
                        (funcall body* new-env))))))))
           ((progn)
            (prepare-progn (rest form) context mode))
           ((progv)
            (destructuring-bind (vals vars &body body) (rest form)
              (let ((vals* (prepare-form vals context))
                    (vars* (prepare-form vars context))
                    (body* (prepare-progn body context)))
                (lambda (env)
                  (progv (funcall vals* env) (funcall vars* env)
                    (funcall body* env))))))
           ((quote)
            (let ((quoted-object (cadr form)))
              (lambda (env)
                (declare (ignore env))
                quoted-object)))
           ((return-from)
            (destructuring-bind (name &optional value) (rest form)
              (let ((value* (prepare-form value context))
                    (tag    (context-block-tag context name)))
                (lambda (env)
                  (throw tag (funcall value* env))))))
           ((the)
            (prepare-form (third form) context))
           ((throw)
            (destructuring-bind (tag result) (rest form)
              (let ((tag*    (prepare-form tag    context))
                    (result* (prepare-form result context)))
                (lambda (env)
                  (throw (funcall tag* env) (funcall result* env))))))
           ((unwind-protect)
            (destructuring-bind (protected &body body) (rest form)
              (let ((protected* (prepare-form  protected context))
                    (body*      (prepare-progn body      context)))
                (lambda (env)
                  (unwind-protect (funcall protected* env)
                    (funcall body* env))))))
           ((sb-ext:truly-the)
            (prepare-form (third form) context))
           ((sb-int:named-lambda)
            (prepare-lambda (cddr form) context))
           ((symbol-macrolet)
            (destructuring-bind (bindings &rest exprs) (rest form)
              (with-parsed-body (body specials) exprs
                (let ((bindings (mapcar (lambda (form)
                                          (destructuring-bind (var macro-form) form
                                            (when (or (globally-special-p var)
                                                      (member var specials))
                                              (error 'sb-int:simple-program-error
                                                     :format-control "Attempt to bind a special variable with SYMBOL-MACROLET: ~S"
                                                     :format-arguments (list var)))
                                            (when (constantp var)
                                              (error 'sb-int:simple-program-error
                                                     :format-control "Attempt to bind a special variable with SYMBOL-MACROLET: ~S"
                                                     :format-arguments (list var)))
                                            (cons var macro-form)))
                                        bindings)))
                  (prepare-progn body
                                 (context-add-specials
                                  (context-add-symbol-macros context bindings)
                                  specials)
                                 mode)))))
           ((macrolet)
            (destructuring-bind (bindings &rest exprs) (rest form)
              (with-parsed-body (body specials) exprs
                (let ((bindings (mapcar (lambda (form)
                                          (cons (first form)
                                                (funcall
                                                 (prepare-macro-lambda (first form)
                                                                       (rest form)
                                                                       context)
                                                 (make-null-environment))))
                                        bindings)))
                  (prepare-progn body
                                 (context-add-specials
                                  (context-add-macros context bindings)
                                  specials)
                                 mode)))))
           ((go)
            (let* ((go-tag    (second form))
                   (catch-tag (context-find-go-tag context go-tag)))
              (lambda (env)
                (declare (ignore env))
                (throw catch-tag go-tag))))
           ((tagbody)
            ;; 1. set up catch handler
            ;; 2. save go-tag -> tagbody-catch-tag mapping
            (let* ((jump (gensym "JUMP"))
                   (tags-and-bodies (parse-tagbody-tags-and-bodies (rest form)))
                   (new-context (context-add-go-tags context (mapcar #'car tags-and-bodies) jump))
                   (tags-and-bodies* (mapcar (lambda (x)
                                               (destructuring-bind (tag . body) x
                                                 (cons tag (prepare-progn body new-context))))
                                             tags-and-bodies)))
              (lambda (env)
                (block tagbody-loop
                  (let ((code tags-and-bodies*))
                    (loop
                      (setq code
                            (member (catch jump
                                      (dolist (tag-and-body* code)
                                        (funcall (the eval-closure (cdr tag-and-body*))
                                                 env))
                                      (return-from tagbody-loop))
                                    tags-and-bodies*
                                    :key #'car))
                      (unless code
                        (return-from tagbody-loop)))))
                nil)))
           (otherwise
            ;; FIXME: Handle SETF expanders?
            (destructuring-bind (f . args) form
              (check-type f (or list symbol))
              (let ((local-macro? (context-find-macro context f))
                    (global-macro? (and (symbolp f) (macro-function f))))
                (cond
                  (local-macro?
                   (let ((macro-function local-macro?))
                     (prepare-form (funcall (the function macro-function)
                                            form
                                            (context->native-environment context))
                                   context)))
                  ((local-function-p context f)
                   (prepare-local-call f args context))
                  (global-macro?
                   (prepare-form (funcall global-macro? form (context->native-environment context)) context))
                  ((and (listp f)
                        (eq 'lambda (first f)))
                   (let ((lambda-fn (prepare-lambda (rest f) context)))
                     (prepare-direct-call lambda-fn args context)))
                  (t
                   (prepare-global-call f args context)))))))))))
   t))

(defun eval (form)
  (funcall (prepare-form form (make-null-context)) (make-null-environment)))


(defun load (filename)
  ;;FIXME: set :LOAD-TOPLEVEL time.
  (let ((eof (gensym)))
    (with-open-file (in filename)
      (loop for form = (read in nil eof nil)
            until (eq form eof)
            do (eval form)))))


#+(or)
(funcall (prepare-form '(funcall
                         (funcall
                          (lambda (x)
                            (lambda (y z)
                              (setq x (+ x (* y z)))
                              x))
                          3)
                         5 7)
                       (make-null-context))
         (make-null-environment))

#+(or)
(funcall (funcall
          (prepare-form
           '(lambda (a b &optional c (d 10 dp) &rest r &key e (f 12 fp) (g 12 gp) &aux (h 1) (i 2))
             (list a b c d dp e f fp g gp r h i)))
          (make-null-environment))
         1 2 3 4 :f 5 :e 6)
;; => (1 2 3 4 T 6 5 T 12 NIL (:F 5 :E 6) 1 2)