Replaced global variable *funs* by the new compiler environment.

src/cmp/cmpcall.lsp

@@ -28,7 +28,7 @@
 ;;; Like macro-function except it searches the lexical environment,
 ;;; to determine if the macro is shadowed by a function or a macro.
 (defun cmp-macro-function (name)
-  (or (sch-local-macro name)
+  (or (cmp-env-search-macro name)
       (macro-function name)))
 
 (defun c1funcall (args)

src/cmp/cmpdefs.lsp

@@ -359,18 +359,10 @@ The default value is NIL.")
 (defvar *exit*)
 (defvar *unwind-exit*)
 
-;;; --cmpflet.lsp--
-;;;
-;;; During Pass 1, *funs* holds a list of fun objects, local macro definitions
-;;; and the symbol 'CB' (Closure Boundary) or 'LB' (Level Boundary).
-;;; 'CB' will be pushed on *funs* when the compiler begins to process a closure.
-;;; 'LB' will be pushed on *funs* when the compiler begins to process a local
-;;; function.
-;;; A local macro definition is a list ( macro-name expansion-function).
-
-(defvar *funs* nil)
 (defvar *current-function* nil)
 
+(defvar *cmp-env* (cons nil nil))
+
 ;;; --cmplog.lsp--
 ;;;
 ;;; Destination of output of different forms. See cmploc.lsp for types

src/cmp/cmpenv.lsp

@@ -117,10 +117,13 @@
 
 (defun add-function-declaration (fname arg-types return-types)
   (if (si::valid-function-name-p fname)
-      (push (list (sch-local-fun fname)
-		  (function-arg-types arg-types)
-		  (function-return-type return-types))
-	    *function-declarations*)
+      (let ((fun (cmp-env-search-function fname *cmp-env* t)))
+	(if (functionp fun)
+	    (warn "Found function declaration for local macro ~A" fname)
+	    (push (list fun
+			(function-arg-types arg-types)
+			(function-return-type return-types))
+		  *function-declarations*)))
       (warn "In (DECLARE (FTYPE ...)): ~s is not a valid function name" fname)))
 
 (defun get-arg-types (fname)
@@ -417,3 +420,58 @@
     (unless (member x vnames)
       (cmpwarn "Ignore declaration was found for not bound variable ~s." x)))
   )
+
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;;;
+;;; COMPILER ENVIRONMENT
+;;;
+
+(defmacro cmp-env-new ()
+  '(cons nil nil))
+
+(defun cmp-env-copy (&optional (env *cmp-env*))
+  (cons (car env) (cdr env)))
+
+(defmacro cmp-env-variables (&optional (env '*cmp-env*))
+  `(car ,env))
+
+(defmacro cmp-env-functions (&optional (env '*cmp-env*))
+  `(cdr ,env))
+
+(defun cmp-env-register-function (fun &optional (env *cmp-env*))
+  (push (list (fun-name fun) 'function fun)
+	(cmp-env-functions env)))
+
+(defun cmp-env-register-macro (name function &optional (env *cmp-env*))
+  (push (list name 'si::macro function)
+	(cmp-env-functions env)))
+
+(defun cmp-env-search-function (name &optional (env *cmp-env*) macro-allowed)
+  (let ((ccb nil)
+	(clb nil)
+	(unw nil)
+	(found nil))
+    (dolist (record (cmp-env-functions env))
+      (cond ((eq record 'CB)
+	     (setf ccb t))
+	    ((eq record 'LB)
+	     (setf clb t))
+	    ((eq record 'UNWIND-PROTECT)
+	     (setf unw t))
+	    ((atom record)
+	     (baboon))
+	    ((eq (first record) name)
+	     (setf found (first (last record)))
+	     (when (and (functionp found) (not macro-allowed))
+	       ;; Macro definition appears in #'.... This should not happen.
+	       (cmperr "The name of a macro ~A was found in special form FUNCTION." name))
+	     (return))))
+    (values found ccb clb unw)))
+
+(defun cmp-env-search-macro (name &optional (env *cmp-env*))
+  (let ((f (cmp-env-search-function name env t)))
+    (if (functionp f) f nil)))
+
+(defun cmp-env-mark (mark &optional (env *cmp-env*))
+  (cons (cons mark (car env))
+	(cons mark (cdr env))))

src/cmp/cmpeval.lsp

@@ -47,7 +47,7 @@
 (defun c1call-symbol (fname args &aux fd)
   (cond ((setq fd (get-sysprop fname 'c1special)) (funcall fd args))
 	((c1call-local fname args))
-	((setq fd (sch-local-macro fname))
+	((setq fd (cmp-env-search-macro fname))
 	 (c1expr (cmp-expand-macro fd (list* fname args))))
 	((and (setq fd (get-sysprop fname 'C1))
 	      (inline-possible fname))

src/cmp/cmpflet.lsp

@@ -18,7 +18,7 @@
 
 (defun c1labels/flet (origin args)
   (check-args-number origin args 1)
-  (let ((new-funs *funs*)
+  (let ((new-env (cmp-env-copy))
 	(defs '())
 	(local-funs '())
 	(fnames '())
@@ -38,12 +38,12 @@
       (let* ((name (car def))
 	     (var (make-var :name name :kind :object))
 	     (fun (make-fun :name name :var var)))
-	(push (list (fun-name fun) 'FUNCTION fun) new-funs)
+	(cmp-env-register-function fun new-env)
 	(push (cons fun (cdr def)) defs)))
 
     ;; Now we compile the functions, either in an empty environment
     ;; in which there are no new functions
-    (let ((*funs* (if (eq origin 'FLET) *funs* new-funs)))
+    (let ((*cmp-env* (cmp-env-copy (if (eq origin 'FLET) *cmp-env* new-env))))
       (dolist (def (nreverse defs))
 	(let ((fun (first def)))
 	  ;; The closure type will be fixed later on by COMPUTE-...
@@ -61,7 +61,7 @@
 
     ;; Now we can compile the body itself.
     (let ((*vars* *vars*)
-          (*funs* new-funs))
+          (*cmp-env* new-env))
       (multiple-value-bind (body ss ts is other-decl)
 	  (c1body (rest args) t)
 	(c1declare-specials ss)
@@ -195,16 +195,16 @@
     (check-vdecl nil ts is)
     (c1decl-body other-decl body)))
 
-(defun c1macrolet (args &aux (*funs* *funs*))
+(defun c1macrolet (args)
   (check-args-number 'MACROLET args 1)
-  (dolist (def (car args))
-    (let ((name (first def)))
-      (cmpck (or (endp def) (not (symbolp name)) (endp (cdr def)))
-	     "The macro definition ~s is illegal." def)
-      (push (list name 'MACRO
-		  (si::eval-with-env (sys::expand-defmacro name (second def) (cddr def))))
-	    *funs*)))
-  (c1locally (cdr args)))
+  (let ((*cmp-env* (cmp-env-copy)))
+    (dolist (def (car args))
+      (let ((name (first def)))
+	(cmpck (or (endp def) (not (symbolp name)) (endp (cdr def)))
+	       "The macro definition ~s is illegal." def)
+	(cmp-env-register-macro name
+		    (si::eval-with-env (sys::expand-defmacro name (second def) (cddr def))))))
+    (c1locally (cdr args))))
 
 (defun c1symbol-macrolet (args &aux (*vars* *vars*))
   (check-args-number 'SYMBOL-MACROLET args 1)
@@ -214,55 +214,25 @@
     (push def *vars*))
   (c1locally (cdr args)))
 
-(defun local-function-ref (fname &optional build-object &aux (ccb nil) (clb nil))
-  (dolist (fun *funs*)
-    (cond ((eq fun 'CB)
-           (setq ccb t))
-	  ((eq fun 'LB)
-           (setq clb t))
-	  ((and (consp fun)
-                (equal fname (first fun))
-                (eq (second fun) 'MACRO))
-           ;; a macro
-	   (when build-object
-	     (cmperr "The name of a macro ~A was found in a call to FUNCTION."
-		     fname))
-	   (return nil))
-          ((and (consp fun)
-                (same-fname-p (first fun) fname)
-                (eq (second fun) 'FUNCTION))
-            ;; it is a function definition -- extract the actual function record
-            (let ((fun (third fun)))
-	      (incf (fun-ref fun))
-	      (cond (build-object
-		     (setf (fun-ref-ccb fun) t))
-		    (*current-function*
-		     (push fun (fun-referred-funs *current-function*))))
-	      ;; we introduce a variable to hold the funob
-	      (let ((var (fun-var fun)))
-	        (cond (ccb (when build-object
-			     (setf (var-ref-ccb var) t
-				   (var-kind var) 'CLOSURE))
-			   (setf (fun-ref-ccb fun) t))
-		      (clb (when build-object 
-			     (setf (var-ref-clb var) t
-				   (var-kind var) 'LEXICAL)))))
-	       (return fun))))))
-
-(defun sch-local-fun (fname)
-  ;; Returns fun-ob for the local function (not locat macro) named FNAME,
-  ;; if any.  Otherwise, returns FNAME itself.
-  (dolist (fun *funs* fname)
-    (when (and (not (eq fun 'CB))
-               (not (consp fun))
-               (same-fname-p (fun-name fun) fname))
-          (return fun))))
-
-(defun sch-local-macro (fname)
-  (dolist (fun *funs*)
-    (when (and (consp fun)
-               (eq (first fun) fname))
-          (return (third fun)))))
+(defun local-function-ref (fname &optional build-object)
+  (multiple-value-bind (fun ccb clb unw)
+      (cmp-env-search-function fname *cmp-env* (not build-object))
+    (when fun
+      (incf (fun-ref fun))
+      (cond (build-object
+	     (setf (fun-ref-ccb fun) t))
+	    (*current-function*
+	     (push fun (fun-referred-funs *current-function*))))
+      ;; we introduce a variable to hold the funob
+      (let ((var (fun-var fun)))
+	(cond (ccb (when build-object
+		     (setf (var-ref-ccb var) t
+			   (var-kind var) 'CLOSURE))
+		   (setf (fun-ref-ccb fun) t))
+	      (clb (when build-object 
+		     (setf (var-ref-clb var) t
+			   (var-kind var) 'LEXICAL))))))
+    fun))
 
 (defun c2call-local (fun args &optional narg)
   (declare (type fun fun))

src/cmp/cmplam.lsp

@@ -73,7 +73,7 @@
     (push fun (fun-child-funs *current-function*)))
   (let* ((*current-function* fun)
 	 (*vars* (cons CB/LB *vars*))
-	 (*funs* (cons CB/LB *funs*))
+	 (*cmp-env* (cmp-env-mark CB/LB))
 	 (*blocks* (cons CB/LB *blocks*))
 	 (*tags* (cons CB/LB *tags*))
 	 (setjmps *setjmps*)

src/cmp/cmptop.lsp

@@ -14,7 +14,7 @@
 
 (defun t1expr (form)
   (let ((*vars* nil)
-	(*funs* nil)
+	(*cmp-env* (cmp-env-new))
 	(*blocks* nil)
 	(*tags* nil))
     (push (t1expr* form) *top-level-forms*)))
@@ -47,11 +47,8 @@
 		      (cmp-expand-macro fd form))
 		    success))
 	     (t1expr* fd))
-	    ((setq fd (macro-function fun))
+	    ((setq fd (cmp-macro-function fun))
 	     (t1expr* (cmp-expand-macro fd form)))
-	    ((and (setq fd (assoc fun *funs*))
-		  (eq (second fd) 'MACRO))
-	     (t1expr* (cmp-expand-macro (third fd) form)))
 	    (t (t1ordinary form))
 	   )))))
 

src/cmp/cmputil.lsp

@@ -136,14 +136,14 @@
                  ~%;;; You are recommended to compile again.~%"
 	      form))))
 
-(defun cmp-macroexpand (form &optional (env (and *funs* (cons nil *funs*))))
+(defun cmp-macroexpand (form &optional (env (cons nil (cdr *cmp-env*))))
   (with-cmp-protection (macroexpand form env)
     (let ((*print-case* :upcase))
       (print-current-form)
       (format t "~&;;; The macro form ~S was not expanded successfully.~
                  ~%;;; You are recommended to compile again.~%" form))))
 
-(defun cmp-expand-macro (fd form &optional (env (and *funs* (cons nil *funs*))))
+(defun cmp-expand-macro (fd form &optional (env (cons nil (cdr *cmp-env*))))
   (with-cmp-protection
     (let ((new-form (funcall *macroexpand-hook* fd form env)))
       (values new-form (not (eql new-form form))))