Changeset 8360 for trunk/j/src/org/armedbear/lisp/jvm.lisp

Timestamp:

01/14/05 22:02:20 (17 years ago)

Author:

piso

Message:

Work in progress (tested).

File:

• trunk/j/src/org/armedbear/lisp/jvm.lisp (modified) (9 diffs)

trunk/j/src/org/armedbear/lisp/jvm.lisp

@@ -2 +2 @@
 ;;;
 ;;; Copyright (C) 2003-2005 Peter Graves
-;;; $Id: jvm.lisp,v 1.349 2005-01-14 03:25:48 piso Exp $
+;;; $Id: jvm.lisp,v 1.350 2005-01-14 22:02:20 piso Exp $
 ;;;
 ;;; This program is free software; you can redistribute it and/or
@@ -245 +245 @@
   ;; If non-nil, register containing saved dynamic environment for this block.
   environment-register
-  ;; Only used in LET/LET* nodes.
+  ;; Only used in LET/LET*/M-V-B nodes.
   vars
+  free-specials
   )
 
@@ -311 +312 @@
             (eq (car varspec) (cadr varspec))
             (return nil))))
-    (let ((vars (if (eq op 'LET) (p1-let-vars varlist) (p1-let*-vars varlist))))
+    (let ((vars (if (eq op 'LET) (p1-let-vars varlist) (p1-let*-vars varlist)))
+          (free-specials '()))
       (dformat t "p1-let/let* vars = ~S~%" (mapcar #'variable-name vars))
       ;; Check for globally declared specials.
@@ -326 +328 @@
               (SPECIAL
                (dolist (sym (cdr decl))
-                 (dolist (variable vars)
-                   (when (eq sym (variable-name variable))
-                     (setf (variable-special-p variable) t)))))
+;;                  (dolist (variable vars)
+;;                    (when (eq sym (variable-name variable))
+;;                      (setf (variable-special-p variable) t)))
+                 (let ((variable (find sym vars :key #'variable-name)))
+                   (cond (variable
+                          (setf (variable-special-p variable) t))
+                         (t
+                          (dformat t "adding free special ~S~%" sym)
+                          (push (make-variable :name sym :special-p t) free-specials))))
+                 ))
               (TYPE
                (dolist (sym (cddr decl))
@@ -334 +343 @@
                    (when (eq sym (variable-name variable))
                      (setf (variable-declared-type variable) (cadr decl))))))))))
-      (setf (block-vars block) vars))
+      (setf (block-vars block) vars)
+      (setf (block-free-specials block) free-specials))
     (setf body (mapcar #'p1 body))
     (setf (block-form block) (list* op varlist body))
@@ -406 +416 @@
          (*visible-tags* *visible-tags*)
          (body (cdr form)))
+    ;; Make all the tags visible before processing the body forms.
     (dolist (subform body)
       (when (or (symbolp subform) (integerp subform))
         (let* ((tag (make-tag :name subform :label (gensym) :block block)))
           (push tag *visible-tags*))))
-    (setf (block-form block) (list* 'TAGBODY (mapcar #'p1 (cdr form))))
+    (let ((new-body '()))
+      (dolist (subform body)
+        (push (if (or (symbolp subform) (integerp subform))
+                  subform
+                  (p1 subform))
+              new-body))
+      (setf (block-form block) (list* 'TAGBODY (nreverse new-body))))
     block))
 
@@ -417 +434 @@
          (tag (find-tag name)))
     (unless tag
-      (error "COMPILE-GO: tag not found: ~S" name))
+      (error "p1-go: tag not found: ~S" name))
     (unless (eq (tag-compiland tag) *current-compiland*)
       (setf (block-non-local-go-p (tag-block tag)) t)))
@@ -3366 +3383 @@
          (form (block-form block))
          (*visible-variables* *visible-variables*)
-         (varlist (cadr form))
          (specialp nil))
     ;; Are we going to bind any special variables?
@@ -3385 +3401 @@
       (LET*
        (p2-let*-bindings block)))
+    ;; Make declarations of free specials visible.
+    (dolist (variable (block-free-specials block))
+      (push variable *visible-variables*))
     ;; Body of LET/LET*.
     (compile-progn-body (cddr form) target)