From 0282accc82e509b0977843d4022d54f5359437da Mon Sep 17 00:00:00 2001 From: Matthias Andreas Benkard Date: Tue, 16 Jul 2013 23:58:13 +0200 Subject: LET, LET*: Support globally special variables. --- sb-eval2.lisp | 125 ++++++++++++++++++++++++++++++++++++++++------------------ 1 file changed, 86 insertions(+), 39 deletions(-) diff --git a/sb-eval2.lisp b/sb-eval2.lisp index b6cef70..33494c8 100644 --- a/sb-eval2.lisp +++ b/sb-eval2.lisp @@ -475,6 +475,9 @@ (declare (ignore context)) (sb-c::internal-make-lexenv nil nil nil nil nil nil nil nil nil nil nil)) +(defun globally-special-p (var) + (eq :special (sb-int:info :variable :kind var))) + (declaim (ftype (function (* &optional context) eval-closure) prepare-form)) (defun prepare-form (form &optional (context (make-null-context))) ;;(declare (optimize speed (safety 0) (space 1) (debug 0))) @@ -615,26 +618,44 @@ (n (length (the list bindings))) (new-context (context-add-env-lexicals context (list))) - (values* (loop for (var . value-form) in real-bindings - collect (prepare-form value-form context) - do (context-add-env-lexical! context var))) - (body* - (prepare-progn body new-context))) - (if envp - (lambda (env) - (let ((new-env (make-environment env n))) - (loop for i from 0 below n - for val* in values* - do (setf (environment-value new-env 0 i) - (funcall (the eval-closure val*) env))) - (funcall body* new-env))) - (lambda (env) - (with-dynamic-extent-environment (new-env env n) - (loop for i from 0 below n - for val* in values* - do (setf (environment-value new-env 0 i) - (funcall (the eval-closure val*) env))) - (funcall body* new-env))))))) + lexical-values* + special-bindings*) + (loop for (var . value-form) in real-bindings + for val* = (prepare-form value-form 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 n))) + (loop for i from 0 below n + for val* in lexical-values* + do (setf (environment-value new-env 0 i) + (funcall (the eval-closure val*) env))) + (progv + special-vars + (loop for val* in special-vals* + collect (funcall (the eval-closure val*) env)) + (funcall body* new-env)))) + (lambda (env) + (with-dynamic-extent-environment (new-env env n) + (loop for i from 0 below n + for val* in lexical-values* + do (setf (environment-value new-env 0 i) + (funcall (the eval-closure val*) env))) + (progv + special-vars + (loop for val* in special-vals* + collect (funcall (the eval-closure val*) env)) + (funcall body* new-env))))))))) ((let*) ;; FIXME: SPECIAL declarations! (destructuring-bind (bindings &rest body) (rest form) @@ -651,25 +672,51 @@ (new-context (context-add-env-lexicals context (list))) (values* (loop for (var . value-form) in real-bindings - collect (prepare-form value-form new-context) - do (context-add-env-lexical! context var))) - (body* - (prepare-progn body new-context))) - (if envp - (lambda (env) - (let ((new-env (make-environment env n))) - (loop for i from 0 below n - for val* in values* - do (setf (environment-value new-env 0 i) - (funcall (the eval-closure val*) new-env))) - (funcall body* new-env))) - (lambda (env) - (with-dynamic-extent-environment (new-env env n) - (loop for i from 0 below n - for val* in values* - do (setf (environment-value new-env 0 i) - (funcall (the eval-closure val*) new-env))) - (funcall body* new-env))))))) + 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! context var))) + + 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 n))) + (loop for i from 0 below n + for val* in 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*) env)) + (funcall body* new-env)))) + (lambda (env) + (with-dynamic-extent-environment (new-env env n) + (loop for i from 0 below n + for val* in 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*) env)) + (funcall body* new-env))))))))) ((load-time-value) (let ((load-form (cadr form))) ;; FIXME -- cgit v1.2.3