From 04101f15880d5198e8de4bb71f67b63b3c7cc13a Mon Sep 17 00:00:00 2001
From: Matthias Andreas Benkard <code@mail.matthias.benkard.de>
Date: Fri, 19 Jul 2013 01:04:43 +0200
Subject: Register specials in the context.

---
 sb-eval2.lisp | 27 ++++++++++++++++++++-------
 1 file changed, 20 insertions(+), 7 deletions(-)

(limited to 'sb-eval2.lisp')

diff --git a/sb-eval2.lisp b/sb-eval2.lisp
index 16e19f0..1a26aec 100644
--- a/sb-eval2.lisp
+++ b/sb-eval2.lisp
@@ -120,7 +120,8 @@
   (go-tags nil :type list)
   (symbol-macros nil :type list)
   (macros nil :type list)
-  (lexicals 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)
@@ -182,10 +183,13 @@
                                           collect current-form)))
                  (cons tag current-forms))))))
 (defun context-var-lexical-p (context var)
-  (context-find-lexical context var))
+  (and (not (find var (context-specials context) :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-add-env-lexicals (context vars)
   ;; open a new variable context
-    (let ((new-context (make-context context)))
+  (let ((new-context (make-context context)))
     (with-slots (lexicals env-hop)
         new-context
       (setq env-hop t)
@@ -194,11 +198,19 @@
                            collect (make-env-lexical v i))))
     new-context))
 (defun context-add-env-lexical! (context var)
-  ;; open a new variable context
   (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)
@@ -280,7 +292,6 @@
               (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)))
@@ -725,10 +736,11 @@
                   (let* ((values*
                            (loop for (var . value-form) in real-bindings
                                  for val* = (prepare-form value-form context)
-                                 if (or (member var specials)
+                                 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)))
@@ -826,7 +838,8 @@
            ((locally)
             (destructuring-bind (&rest exprs) (rest form)
               (with-parsed-body (body specials) exprs
-               (prepare-progn body context))))
+                (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))
-- 
cgit v1.2.3