Changeset 12089

Timestamp:

08/08/09 20:43:10 (14 years ago)

Author:

ehuelsmann

Message:

Refer to blocks upon variable creation, wherever appropriate.

File:

• trunk/abcl/src/org/armedbear/lisp/compiler-pass1.lisp (modified) (16 diffs)

trunk/abcl/src/org/armedbear/lisp/compiler-pass1.lisp

@@ -61 +61 @@
 
 ;; Returns a list of declared free specials, if any are found.
-(declaim (ftype (function (list list) list) process-declarations-for-vars))
-(defun process-declarations-for-vars (body variables)
+(declaim (ftype (function (list list block-node) list)
+                process-declarations-for-vars))
+(defun process-declarations-for-vars (body variables block)
   (let ((free-specials '()))
     (dolist (subform body)
@@ -85 +86 @@
                        (t
                         (dformat t "adding free special ~S~%" name)
-                        (push (make-variable :name name :special-p t)
+                        (push (make-variable :name name :special-p t
+                                             :block block)
                               free-specials))))))
             (TYPE
@@ -150 +152 @@
 
 (defmacro p1-let/let*-vars 
-    (varlist variables-var var body1 body2)
+    (block varlist variables-var var body1 body2)
   (let ((varspec (gensym))
   (initform (gensym))
@@ -166 +168 @@
            (,initform (p1 (%cadr ,varspec)))
            (,var (make-variable :name (check-name ,name)
-                                            :initform ,initform)))
+                                            :initform ,initform
+                                            :block ,block)))
       (push ,var ,variables-var)
       ,@body1))
          (t
-    (let ((,var (make-variable :name (check-name ,varspec))))
+    (let ((,var (make-variable :name (check-name ,varspec)
+                                           :block ,block)))
       (push ,var ,variables-var)
       ,@body1))))
@@ -176 +180 @@
 
 (defknown p1-let-vars (t) t)
-(defun p1-let-vars (varlist)
-  (p1-let/let*-vars 
+(defun p1-let-vars (block varlist)
+  (p1-let/let*-vars block
    varlist vars var
    ()
@@ -187 +191 @@
 
 (defknown p1-let*-vars (t) t)
-(defun p1-let*-vars (varlist)
-  (p1-let/let*-vars 
+(defun p1-let*-vars (block varlist)
+  (p1-let/let*-vars block
    varlist vars var
    ((push var *visible-variables*)
@@ -213 +217 @@
                 (return)))))
     (let ((vars (if (eq op 'LET)
-                    (p1-let-vars varlist)
-                    (p1-let*-vars varlist))))
+                    (p1-let-vars block varlist)
+                    (p1-let*-vars block varlist))))
       ;; Check for globally declared specials.
       (dolist (variable vars)
@@ -224 +228 @@
       ;; with the specified name.
       (setf (block-free-specials block)
-            (process-declarations-for-vars body (reverse vars)))
+            (process-declarations-for-vars body (reverse vars) block))
       (setf (block-vars block) vars)
       ;; Make free specials visible.
@@ -236 +240 @@
   (let* ((*visible-variables* *visible-variables*)
          (block (make-block-node '(LOCALLY)))
-         (free-specials (process-declarations-for-vars (cdr form) nil)))
+         (free-specials (process-declarations-for-vars (cdr form) nil block)))
     (setf (block-free-specials block) free-specials)
     (dolist (special free-specials)
@@ -262 +266 @@
     (let ((vars ()))
       (dolist (symbol varlist)
-        (let ((var (make-variable :name symbol)))
+        (let ((var (make-variable :name symbol :block block)))
           (push var vars)
           (push var *visible-variables*)
@@ -272 +276 @@
                 (block-environment-register block) t)))
       (setf (block-free-specials block)
-            (process-declarations-for-vars body vars))
+            (process-declarations-for-vars body vars block))
       (dolist (special (block-free-specials block))
         (push special *visible-variables*))
@@ -643 +647 @@
                 (*visible-variables* *visible-variables*))
            (setf (block-free-specials block)
-                 (process-declarations-for-vars body nil))
+                 (process-declarations-for-vars body nil block))
            (dolist (special (block-free-specials block))
              (push special *visible-variables*))
@@ -673 +677 @@
               (*visible-variables* *visible-variables*))
          (setf (block-free-specials block)
-               (process-declarations-for-vars body nil))
+               (process-declarations-for-vars body nil block))
          (dolist (special (block-free-specials block))
            (push special *visible-variables*))
@@ -771 +775 @@
   ;; We've already checked argument count in PRECOMPILE-PROGV.
 
-  ;; ### FIXME: we need to return a block here, so that
-  ;;  (local) GO in p2 can restore the lastSpecialBinding environment
   (let ((new-form (rewrite-progv form)))
     (when (neq new-form form)
@@ -781 +783 @@
          (*blocks* (cons block *blocks*))
          (body (cdddr form)))
+;;  The (commented out) block below means to detect compile-time
+;;  enumeration of bindings to be created (a quoted form in the symbols
+;;  position).
+;;    (when (and (quoted-form-p symbols-form)
+;;               (listp (second symbols-form)))
+;;      (dolist (name (second symbols-form))
+;;        (let ((variable (make-variable :name name :special-p t)))
+;;          (push 
     (setf (block-form block)
           `(progv ,symbols-form ,values-form ,@(p1-body body))
@@ -1110 +1120 @@
           (push var *visible-variables*)))
       (setf (compiland-arg-vars compiland) (nreverse vars))
-      (let ((free-specials (process-declarations-for-vars body vars)))
+      (let ((free-specials (process-declarations-for-vars body vars nil)))
         (setf (compiland-free-specials compiland) free-specials)
         (dolist (var free-specials)