Incorporate tags in the environment.

src/cmp/cmpcatch.lsp

@@ -50,7 +50,7 @@
   (let (form)
     (let ((*blocks* (cons 'UNWIND-PROTECT *blocks*))
 	  ;;(*vars* (cons 'LB *vars*))
-	  (*tags* (cons 'UNWIND-PROTECT *tags*)))
+	  (*cmp-env* (cmp-env-mark 'UNWIND-PROTECT)))
       (setq form (c1expr (first args))))
     (make-c1form* 'UNWIND-PROTECT :type (c1form-type form) :sp-change t
 		  :args form (c1progn (rest args)))))

src/cmp/cmpdefs.lsp

@@ -361,7 +361,31 @@ The default value is NIL.")
 
 (defvar *current-function* nil)
 
-(defvar *cmp-env* (cons nil nil))
+(defvar *cmp-env* (cons nil nil)
+"The compiler environment consists of a pair or cons of two
+lists, one containing variable records, the other one macro and
+function recors:
+
+variable-record = (:block block-name) |
+                  (:tag ({tag-name}*)) |
+                  (:function function-name) |
+                  (var-name {:special | nil} bound-p) |
+                  (symbol si::symbol-macro macro-function) |
+                  CB | LB | UNWIND-PROTECT
+macro-record =	(function-name function) |
+                (macro-name si::macro macro-function)
+                CB | LB | UNWIND-PROTECT
+
+A *-NAME is a symbol. A TAG-ID is either a symbol or a number. A
+MACRO-FUNCTION is a function that provides us with the expansion
+for that local macro or symbol macro. BOUND-P is true when the
+variable has been bound by an enclosing form, while it is NIL if
+the variable-record corresponds just to a special declaration.
+CB, LB and UNWIND-PROTECT are only used by the C compiler and
+they denote closure, lexical environment and unwind-protect
+boundaries. Note that compared with the bytecodes compiler, these
+records contain an additional variable, block, tag or function
+object at the end.")
 
 ;;; --cmplog.lsp--
 ;;;
@@ -429,12 +453,6 @@ coprocessor).")
 ;;; Compiler program and flags.
 ;;;
 
-;;; --cmptag.lsp--
-;;;
-;;; List of tags with marks for closure boundaries.
-;;;
-(defvar *tags* nil)
-
 ;;; --cmptop.lsp--
 ;;;
 (defvar *compiler-phase* nil)
@@ -493,19 +511,14 @@ lines are inserted, but the order is preserved")
 ;;; *reservations* holds (... ( cmacro . value ) ...).
 ;;; *reservation-cmacro* holds the cmacro current used as vs reservation.
 
+;;; *global-entries* holds (... ( fname cfun return-types arg-type ) ...).
 (defvar *global-entries* nil)
 
-;;; *self-destructing-fasl* = T means that, when a FASL module is
-;;; being unloaded (for instance during garbage collection), the
-;;; associated file will be deleted. We need this because on windows
-;;; DLLs cannot be deleted if they have been opened with LoadLibrary.
-;;; Thus, (COMPILE ...) cannot create a DLL, load it and delete it
-;;; while it is being used.
-(defvar *self-destructing-fasl* nil)
+(defvar *self-destructing-fasl* '()
+"A value T means that, when a FASL module is being unloaded (for
+instance during garbage collection), the associated file will be
+deleted. We need this for #'COMPILE because windows DLLs cannot
+be deleted if they have been opened with LoadLibrary.")
 
-;;; *global-entries* holds (... ( fname cfun return-types arg-type ) ...).
-
-;;; --cmpvar.lsp--
-;;;
 (defvar *vars* nil)
 (defvar *undefined-vars* nil)

src/cmp/cmpenv.lsp

@@ -450,6 +450,10 @@
   (push (list :block (blk-name blk) blk)
 	(cmp-env-variables env)))
 
+(defun cmp-env-register-tag (tag &optional (env *cmp-env*))
+  (push (list :tag (list (tag-name tag)) tag)
+	(cmp-env-variables env)))
+
 (defun cmp-env-search-function (name &optional (env *cmp-env*))
   (let ((ccb nil)
 	(clb nil)
@@ -484,12 +488,14 @@
 	    ((atom record)
 	     (baboon))
 	    ((not (eq (first record) type)))
-	    ((and (eq type :block) (eq name (second record)))
-	     (setf found record)
-	     (return))
-	    ((and (eq type :tag) (member name (second record)))
-	     (setf found record)
-	     (return))
+	    ((eq type :block)
+	     (when (eq name (second record))
+	       (setf found record)
+	       (return)))
+	    ((eq type :tag)
+	     (when (member name (second record) :test #'eql)
+	       (setf found record)
+	       (return)))
 	    ((eq (second record) 'si::symbol-macro)
 	     (when (eq name 'si::symbol-macro)
 	       (setf found record))

src/cmp/cmplam.lsp

@@ -75,7 +75,6 @@
 	 (*vars* (cons CB/LB *vars*))
 	 (*cmp-env* (cmp-env-mark CB/LB))
 	 (*blocks* (cons CB/LB *blocks*))
-	 (*tags* (cons CB/LB *tags*))
 	 (setjmps *setjmps*)
 	 (decl (si::process-declarations (rest lambda-list-and-body)))
 	 (lambda-expr (c1lambda-expr lambda-list-and-body

src/cmp/cmptag.lsp

@@ -13,12 +13,6 @@
 
 (in-package "COMPILER")
 
-;;; During Pass 1, *tags* holds a list of tag objects and the symbols 'CB'
-;;; (Closure Boundary), 'LB' (Level Boundary) or 'UNWIND-PROTECT'.
-;;; 'CB' will be pushed on *tags* when the compiler begins to process
-;;;  a closure.
-;;; 'LB' will be pushed on *tags* when *level* is incremented.
-;;; 'UNWIND-PROTECT' is pushed when entering an unwind-protect.
 ;;;  A dummy variable is created to hold the tag identifier and one tag
 ;;;  structure (containing reference to such variable) is created for each
 ;;;  label in the body.
@@ -71,7 +65,7 @@
 	    (setq end w)))))))
 
 ;; FIXME! The variable name should not be a usable one!
-(defun c1tagbody (body &aux (*tags* *tags*)
+(defun c1tagbody (body &aux (*cmp-env* (cmp-env-copy))
                        (tag-var (make-var :name 'TAGBODY :kind NIL))
 		       (tag-index 0))
   ;;; Establish tags.
@@ -80,7 +74,7 @@
          #'(lambda (x)
              (if (not (consp x))
                (let ((tag (make-tag :name x :var tag-var :index tag-index)))
-                 (push tag *tags*)
+                 (cmp-env-register-tag tag)
 		 (incf tag-index)
                  tag)
                x))
@@ -176,33 +170,25 @@
 
 (defun c1go (args)
   (check-args-number 'GO args 1 1)
-  (unless (or (symbolp (car args)) (integerp (car args)))
-    (cmperr "The tag name ~s is not a symbol nor an integer." (car args)))
-  (do ((tags *tags* (cdr tags))
-       (name (car args))
-       (ccb) (clb) (unw) (tag) (var))
-      ((endp tags) (cmperr "The tag ~s is undefined." name))
-    (declare (type var var))
-    (setq tag (car tags))
-    (case tag
-      (CB (setq ccb t))
-      (LB (setq clb t))
-      (UNWIND-PROTECT (setq unw T))
-      (T (when (eql (tag-name tag) name)
-	   (setq var (tag-var tag))
-	   (cond (ccb (setf (tag-ref-ccb tag) t
-			    (var-ref-ccb var) T
-			    (var-kind var) 'CLOSURE))
-		 (clb (setf (tag-ref-clb tag) t
-			    (var-ref-clb var) t
-			    (var-kind var) 'LEXICAL))
-		 (unw (unless (var-kind var)
-			(setf (var-kind var) :OBJECT))))
-	   (incf (var-ref var))
-	   (incf (tag-ref tag))
-	   (return (add-to-read-nodes var (make-c1form* 'GO :args tag
-							(or ccb clb unw))))
-	   )))))
+  (let ((name (first args)))
+    (unless (or (symbolp name) (integerp name))
+      (cmperr "The tag name ~s is not a symbol nor an integer." name))
+    (multiple-value-bind (tag ccb clb unw)
+	(cmp-env-search-tag name)
+      (unless tag
+	(cmperr "Undefined tag ~A" name))
+      (setq var (tag-var tag))
+      (cond (ccb (setf (tag-ref-ccb tag) t
+		       (var-ref-ccb var) T
+		       (var-kind var) 'CLOSURE))
+	    (clb (setf (tag-ref-clb tag) t
+		       (var-ref-clb var) t
+		       (var-kind var) 'LEXICAL))
+	    (unw (unless (var-kind var)
+		   (setf (var-kind var) :OBJECT))))
+      (incf (var-ref var))
+      (incf (tag-ref tag))
+      (add-to-read-nodes var (make-c1form* 'GO :args tag (or ccb clb unw))))))
 
 (defun c2go (tag nonlocal)
   (if nonlocal

src/cmp/cmptop.lsp

@@ -15,8 +15,7 @@
 (defun t1expr (form)
   (let ((*vars* nil)
 	(*cmp-env* (cmp-env-new))
-	(*blocks* nil)
-	(*tags* nil))
+	(*blocks* nil))
     (push (t1expr* form) *top-level-forms*)))
 
 (defvar *toplevel-forms-to-print*