From 67da3391b028e3106eb1c8a0bcbd9668c0e35d74 Mon Sep 17 00:00:00 2001
From: ram <ram>
Date: Sat, 12 May 1990 20:29:56 +0000
Subject: [PATCH] Fixed "declared inline but no expansion" not to say the
 declaration is global when it may not be.  Also, this note is inhibited when
 the function is known. Changed type declaration parsing to allow declarations
 on non-bound variables, though this may not be quite up to ANSII yet. Changed
 the policy test for deleting the unknown keyword arg checks to be (= safety
 0). Changed undefined variable references to be flamed about using the
 undefined warning mechanism, mainly so that you will only be flamed a fixed
 number of times per variable in a compilation unit.

---
 compiler/ir1tran.lisp | 59 +++++++++++++++++++++++--------------------
 1 file changed, 31 insertions(+), 28 deletions(-)

diff --git a/compiler/ir1tran.lisp b/compiler/ir1tran.lisp
index f5faa7378..cb6454737 100644
--- a/compiler/ir1tran.lisp
+++ b/compiler/ir1tran.lisp
@@ -391,8 +391,9 @@
 	   (expansion
 	    (ir1-convert-global-inline start cont form var inlinep expansion))
 	   (t
-	    (when (and (eq inlinep :inline) (policy nil (> speed brevity)))
-	      (compiler-note "~S is declared globally inline, but has no expansion."
+	    (when (and (eq inlinep :inline) (policy nil (> speed brevity))
+		       (not (info function info name)))
+	      (compiler-note "~S is declared inline, but has no expansion."
 			     name))
 	    (ir1-convert-ok-combination start cont form var)))))))))
 
@@ -738,29 +739,31 @@
 ;;; Process-Type-Declaration  --  Internal
 ;;;
 ;;;    Called by Process-Declarations to deal with a variable type declaration.
+;;; We return a list of new *TYPE-RESTRICTIONS*.
 ;;;
 (proclaim '(function process-type-declaration (list list) void))
 (defun process-type-declaration (decl vars)
   (let ((type (specifier-type (first decl))))
-    (dolist (var-name (rest decl))
-      (let ((var (find-in-bindings vars var-name)))
-	(cond
-	 ((not var)
-	  (compiler-warning "Type declaration for unbound variable: ~S."
-			    var-name))
-	 ((or (function-type-p type)
-	      (function-type-p (leaf-type var)))
-	  ;;
-	  ;; ### For now, just quietly set type...
-	  (setf (leaf-type var) type))
-	 (t
-	  (let ((int (type-intersection (leaf-type var) type)))
-	    (if (eq int *empty-type*)
-		(compiler-warning
-		 "Conflicting type declarations ~S and ~S for ~S."
-		 (type-specifier (leaf-type var))
-		 (type-specifier type) var-name)
-		(setf (leaf-type var) int)))))))))
+    (collect ((res))
+      (dolist (var-name (rest decl))
+	(let* ((bound-var (find-in-bindings vars var-name))
+	       (var (or bound-var
+			(cdr (assoc var-name *venv*))
+			(find-free-variable var-name)))
+	       (old-type (or (cdr (assoc var *type-restrictions*))
+			     (leaf-type var)))
+	       (int (if (or (function-type-p type)
+			    (function-type-p old-type))
+			type
+			(type-intersection old-type type))))
+	  (cond ((eq int *empty-type*)
+		 (compiler-warning
+		  "Conflicting type declarations ~S and ~S for ~S."
+		  (type-specifier old-type) (type-specifier type) var-name))
+		(bound-var (setf (leaf-type bound-var) int))
+		(t
+		 (res (cons var int))))))
+      (res))))
 
 
 ;;; Process-Ftype-Declaration  --  Internal
@@ -864,14 +867,15 @@
 	    (optimize
 	     (setq new-cookie (process-optimize-declaration spec new-cookie)))
 	    (type
-	     (process-type-declaration (cdr spec) vars))
+	     (new-restrictions (process-type-declaration (cdr spec) vars)))
 	    (t
 	     (let ((what (first spec)))
 	       (cond ((member what type-specifier-symbols)
-		      (process-type-declaration spec vars))
+		      (new-restrictions (process-type-declaration spec vars)))
 		     ((info declaration recognized what))
 		     (t
-		      (compiler-warning "Unrecognized declaration: ~S." spec))))))))
+		      (compiler-warning "Unrecognized declaration: ~S."
+					spec))))))))
 
       (values (nconc (new-venv) *venv*) (nconc (new-inlines) *inlines*)
 	      (new-restrictions) new-cookie))))
@@ -1151,9 +1155,8 @@
 	      (n-value-temp (gensym))
 	      (n-allowp (gensym))
 	      (n-losep (gensym))
-	      (allowp
-	       (or (optional-dispatch-allowp res)
-		   (policy nil (or (> space safety) (> speed safety))))))
+	      (allowp (or (optional-dispatch-allowp res)
+			  (policy nil (zerop safety)))))
 	  
 	  (temps `(,n-index 0) n-key n-value-temp)
 	  (body `(declare (fixnum ,n-index) (ignorable ,n-key ,n-value-temp)))
@@ -1525,7 +1528,7 @@
 	    (type (info variable type name))
 	    (where-from (info variable where-from name)))
 	(when (and (eq where-from :assumed) (eq kind :global))
-	  (compiler-warning "Unknown variable: ~S." name))
+	  (note-undefined-reference name :variable))
 
 	(multiple-value-bind (val valp)
 			     (info variable constant-value name)
-- 
GitLab