diff options
| -rw-r--r-- | sb-eval2.lisp | 170 |
1 files changed, 66 insertions, 104 deletions
diff --git a/sb-eval2.lisp b/sb-eval2.lisp index e2116cc..d69b817 100644 --- a/sb-eval2.lisp +++ b/sb-eval2.lisp @@ -440,6 +440,11 @@ (incf ,x ,num) ,old-x))) +(defmacro nlet (loop-var bindings &body body) + `(labels ((,loop-var ,(mapcar #'first bindings) + ,@body)) + (,loop-var ,@(mapcar #'second bindings)))) + (declaim (ftype (function * eval-closure) prepare-lambda)) (defun prepare-lambda (lambda-form context) (destructuring-bind (lambda-list &rest exprs) lambda-form @@ -493,34 +498,30 @@ (body* (prepare-progn body new-context)) (unbound (gensym))) (setq varspecs (nreverse varspecs)) - (let (*new-env*) - (declare (special *new-env*)) - (flet - ((handle-arguments (&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. - (let* ((rest - (when (or restp keyp) - (loop for i - from (+ required-num optional-num) - below (length args) - collect (elt args i)))) - (restnum (- (length args) (+ required-num optional-num))) - (keys-checked-p nil) - (my-default-values* default-values*) - (my-keywords keywords) - (my-varspecs varspecs) - (saved-binding-pointer - (sb-c::%primitive - sb-c::current-binding-pointer)) - (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 + (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. + (nlet iter + ((rest + (when (or restp keyp) + (loop for i + from (+ required-num optional-num) + below (length args) + collect (elt args i)))) + (restnum (- (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 @@ -530,14 +531,17 @@ (let ((varspec (pop my-varspecs))) (if (eq varspec :lexical) (setf - (environment-value *new-env* 0 (incff vari)) + (environment-value new-env 0 (incff vari)) value) - (progn + (let ((var (cdr varspec))) (assert (eq :special (car varspec)) (varspec)) - (sb-c::%primitive - sb-c::bind value (cdr 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 @@ -562,7 +566,7 @@ (go keys)) (let ((val* (pop my-default-values*))) (push-args (funcall (the eval-closure val*) - *new-env*) + new-env) nil)) (go missing-optionals) keys @@ -613,7 +617,7 @@ (go rest)) (let ((val* (pop my-default-values*))) (push-args (funcall (the eval-closure val*) - *new-env*))) + new-env))) (go aux) rest (assert (null my-default-values*) @@ -622,24 +626,19 @@ (push-args rest)) final-call (return - (unwind-protect - (funcall body* *new-env*) - (sb-c::%primitive - sb-c::unbind-to-here saved-binding-pointer)))))))) - ;;(declare (inline handle-arguments)) + (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))) - (declare (special *new-env*)) - (apply #'handle-arguments 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) - (declare (special *new-env*)) - (apply #'handle-arguments args)))))))))))) + (with-dynamic-extent-environment (new-env env varnum) + (apply #'handle-arguments new-env args))))))))))) (defun context->native-environment (context) (let ((functions @@ -647,13 +646,15 @@ collect `(,name . (sb-c::macro . ,expander)))) (vars (loop for (name . form) in (context-collect context 'context-symbol-macros) - collect `(,name . (sb-c::macro . form))))) + collect `(,name . (sb-c::macro . ,form))))) (sb-c::internal-make-lexenv functions vars nil nil nil nil nil nil nil nil nil))) -#+(or) (defun native-environment->context (lexenv) - (with-slots (functions vars) lexenv - (let ((macros% + (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)))) @@ -662,10 +663,10 @@ when (eq (car form) 'sb-c::macro) collect `(,name . ,(cdr form))))) (with-slots (macros symbol-macros) - (make-context nil) + context (setq macros macros%) - (setq symbol-macros symbol-macros%))))) - + (setq symbol-macros symbol-macros%)) + context))) (defun globally-special-p (var) (eq :special (sb-int:info :variable :kind var))) @@ -877,60 +878,21 @@ slav-laiceps (funcall body* new-env))))))))))) ((let*) - ;; FIXME: SPECIAL declarations! (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) - (some (lambda (x) (maybe-closes-over-p context x vars)) - (mapcar #'cdr real-bindings)))) - (new-context - (make-lexical-context context)) - lexical-values* - special-bindings*) - (loop for (var . value-form) in real-bindings - for val* = (prepare-form value-form new-context) - if (globally-special-p var) - collect (cons var val*) into specials - else - collect val* into lexicals - and do (context-add-env-lexical! new-context var) - finally - (setq lexical-values* lexicals - special-bindings* specials)) - (let ((body* (prepare-progn body new-context)) - (special-vars (mapcar #'car special-bindings*)) - (special-vals* (mapcar #'cdr special-bindings*))) - (if envp - (lambda (env) - (let ((new-env (make-environment env varnum))) - (loop for i from 0 below varnum - for val* in lexical-values* - do (setf (environment-value new-env 0 i) - (funcall (the eval-closure val*) new-env))) - (progv - special-vars - (loop for val* in special-vals* - collect (funcall (the eval-closure val*) new-env)) - (funcall body* new-env)))) - (lambda (env) - (with-dynamic-extent-environment (new-env env varnum) - (loop for i from 0 below varnum - for val* in lexical-values* - do (setf (environment-value new-env 0 i) - (funcall (the eval-closure val*) new-env))) - (progv - special-vars - (loop for val* in special-vals* - collect (funcall (the eval-closure val*) new-env)) - (funcall body* new-env)))))))))) + (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 |