diff options
Diffstat (limited to 'sb-eval2.lisp')
| -rw-r--r-- | sb-eval2.lisp | 117 |
1 files changed, 87 insertions, 30 deletions
diff --git a/sb-eval2.lisp b/sb-eval2.lisp index 9ffda51..6ad54ed 100644 --- a/sb-eval2.lisp +++ b/sb-eval2.lisp @@ -180,11 +180,24 @@ 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))) @@ -629,23 +642,42 @@ (apply #'handle-arguments args)))))))))))) (defun context->native-environment (context) - ;;FIXME (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))))) + 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) - ;;FIXME - (declare (ignore lexenv)) - (make-null-context)) + (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)))) + (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))) @@ -689,23 +721,32 @@ (let ((bindings (loop for (var valform) on binding-forms by #'cddr collect var - collect (context-find-lexical context var) + collect + (cond ((context-var-symbol-macro-p context var) + (let ((form + (context-find-symbol-macro context var))) + (prepare-form `(lambda (v) (setf ,form v)) + 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 lexical? val*) on bindings by #'cdddr + (loop for (var info val*) on bindings by #'cdddr for value = (funcall (the eval-closure val*) env) for result = (progn - (check-type var symbol) - (etypecase lexical? ; XXX could lift the - ; case distinction - ; out of the lambda - (env-lexical + (etypecase info + (function ;symbol macro setter + (funcall (funcall info env) value)) + (lexical (setf (environment-value env - (lexical-nesting lexical?) - (lexical-offset lexical?)) + (lexical-nesting info) + (lexical-offset info)) value)) - (null + (keyword (setf (symbol-value var) value)))) finally (return result)))))) ((catch) @@ -921,22 +962,40 @@ (funcall body* env)))))) ((multiple-value-setq) (destructuring-bind (vars values-form) (rest form) - (let ((values-form* (prepare-form values-form context)) - (lexicals (mapcar (lambda (v) - (context-find-lexical context v)) - vars))) + (let ((values-form* + (prepare-form values-form context)) + (lexicals + (mapcar (lambda (v) + (context-find-lexical context v)) + vars)) + (symbol-macro-setters* + (mapcar (lambda (var) + (when (context-var-symbol-macro-p context var) + (let ((form + (context-find-symbol-macro context var))) + (prepare-form `(lambda (v) (setf ,form v)) + context)))) + vars))) (lambda (env) - (let* ((values (multiple-value-list (funcall values-form* env))) - (primary-value (first values))) + (let* ((values (multiple-value-list (funcall values-form* env))) + (primary-value (first values)) + (my-symbol-macro-setters* symbol-macro-setters*)) (loop for lexical? in lexicals - for value in values + for value = (pop values) for var in vars - do (if lexical? - (setf (environment-value env - (lexical-nesting lexical?) - (lexical-offset lexical?)) - value) - (setf (symbol-value var) value))) + do (cond + ((context-var-lexical-p context var) + (setf (environment-value env + (lexical-nesting lexical?) + (lexical-offset lexical?)) + value)) + ((context-var-symbol-macro-p context var) + (funcall (funcall (pop my-symbol-macro-setters*) + env) + value)) + (t + (assume-special context var) + (setf (symbol-value var) value)))) primary-value))))) ((multiple-value-bind) ;; FIXME: SPECIAL declarations! @@ -1003,8 +1062,6 @@ (context-add-symbol-macros context bindings) specials)))))) ((macrolet) - ;; FIXME: This doesn't actually work because we disregard - ;; the lambda list when calling the macro. (destructuring-bind (bindings &rest exprs) (rest form) (with-parsed-body (body specials) exprs (let ((bindings (mapcar (lambda (form) |