summaryrefslogtreecommitdiff
diff options
context:
space:
mode:
authorMatthias Andreas Benkard <code@mail.matthias.benkard.de>2013-07-20 14:53:19 +0200
committerMatthias Andreas Benkard <code@mail.matthias.benkard.de>2013-07-20 14:58:32 +0200
commitfcdc37967c1266cd077e05bedac7aafbe2c20d95 (patch)
tree9a8db18b3fef343a9b01eeb9354944421ffe490d
parent8569c8e2da3bb1ced48ef25c527e808f756b9207 (diff)
SETQ, MULTIPLE-VALUE-SETQ: Handle symbol macros.
-rw-r--r--sb-eval2.lisp117
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)