~ chicken-core (chicken-5) 8fdfb877d30433bf61b39427a84cd9cd11b4ec86

commit 8fdfb877d30433bf61b39427a84cd9cd11b4ec86
Author:     felix <felix@call-with-current-continuation.org>
AuthorDate: Mon Aug 29 04:27:23 2011 +0200
Commit:     felix <felix@call-with-current-continuation.org>
CommitDate: Mon Aug 29 04:27:23 2011 +0200

    ignore and report notice on named declarations of local vars

diff --git a/compiler.scm b/compiler.scm
index 0ac5a0f7..91dc28ab 100644
--- a/compiler.scm
+++ b/compiler.scm
@@ -1140,7 +1140,10 @@
 			 (walk
 			  `(##core#begin
 			     ,@(map (lambda (d)
-				      (process-declaration d se))
+				      (process-declaration 
+				       d se
+				       (lambda (id)
+					 (memq (lookup id se) e))))
 				    (cdr x) ) )
 			  e '() #f #f h) )
 	     
@@ -1290,7 +1293,7 @@
    '() (##sys#current-environment) #f #f #f) ) )
 
 
-(define (process-declaration spec se)
+(define (process-declaration spec se local?)
   (define (check-decl spec minlen . maxlen)
     (let ([n (length (cdr spec))])
       (if (or (< n minlen) (> n (optional maxlen 99999)))
@@ -1300,7 +1303,17 @@
   (define (strip x)			; raw symbol
     (##sys#strip-syntax x))
   (define stripu ##sys#strip-syntax)
-  (define (globalize-all syms) (map (cut ##sys#globalize <> se) syms))
+  (define (globalize-all syms)
+    (filter-map
+     (lambda (var)
+       (cond ((local? var) 
+	      (note-local var)
+	      #f)
+	     (else (##sys#globalize var se))))
+     syms))
+  (define (note-local var)
+    (##sys#notice 
+     (sprintf "ignoring declaration for locally bound variable `~a'" var)))
   (call-with-current-continuation
    (lambda (return)
      (unless (pair? spec)
@@ -1504,30 +1517,32 @@
 	       (warning "illegal type declaration" (##sys#strip-syntax spec))
 	       (let ((name (##sys#globalize (car spec) se))
 		     (type (##sys#strip-syntax (cadr spec))))
-		 (let-values (((type pred pure) (validate-type type name)))
-		   (cond (type
-			  ;; HACK: since `:' doesn't have access to the SE, we
-			  ;; fixup the procedure name if type is a named procedure type
-			  ;; (We only have access to the SE for ##sys#globalize in here).
-			  ;; Quite terrible.
-			  (when (and (pair? type) 
-				     (eq? 'procedure (car type)) 
-				     (symbol? (cadr type)))
-			    (set-car! (cdr type) name))
-			  (mark-variable name '##compiler#type type)
-			  (mark-variable name '##compiler#declared-type)
-			  (when pure
-			    (mark-variable name '##compiler#pure #t))
-			  (when pred
-			    (mark-variable name '##compiler#predicate pred))
-			  (when (pair? (cddr spec))
-			    (install-specializations 
-			     name 
-			     (##sys#strip-syntax (cddr spec)))))
-			 (else
-			  (warning 
-			   "illegal `type' declaration"
-			   (##sys#strip-syntax spec))))))))
+		 (if (local? (car spec))
+		     (note-local (car spec))
+		     (let-values (((type pred pure) (validate-type type name)))
+		       (cond (type
+			      ;; HACK: since `:' doesn't have access to the SE, we
+			      ;; fixup the procedure name if type is a named procedure type
+			      ;; (We only have access to the SE for ##sys#globalize in here).
+			      ;; Quite terrible.
+			      (when (and (pair? type) 
+					 (eq? 'procedure (car type)) 
+					 (symbol? (cadr type)))
+				(set-car! (cdr type) name))
+			      (mark-variable name '##compiler#type type)
+			      (mark-variable name '##compiler#declared-type)
+			      (when pure
+				(mark-variable name '##compiler#pure #t))
+			      (when pred
+				(mark-variable name '##compiler#predicate pred))
+			      (when (pair? (cddr spec))
+				(install-specializations 
+				 name 
+				 (##sys#strip-syntax (cddr spec)))))
+			     (else
+			      (warning 
+			       "illegal `type' declaration"
+			       (##sys#strip-syntax spec)))))))))
 	 (cdr spec)))
        ((predicate)
 	(for-each
@@ -1535,13 +1550,15 @@
 	   (cond ((and (list? spec) (symbol? (car spec)) (= 2 (length spec)))
 		  (let ((name (##sys#globalize (car spec) se))
 			(type (##sys#strip-syntax (cadr spec))))
-		    (let-values (((type pred pure) (validate-type type name)))
-		      (if (and type (not pred))
-			  (mark-variable name '##compiler#predicate type)
-			  (warning "illegal `predicate' declaration" spec)))))
+		    (if (local? (car spec))
+			(note-local (car spec))
+			(let-values (((type pred pure) (validate-type type name)))
+			  (if (and type (not pred))
+			      (mark-variable name '##compiler#predicate type)
+			      (warning "illegal `predicate' declaration" spec))))))
 		 (else
 		  (warning "illegal `type' declaration item" spec))))
-	 (globalize-all (cdr spec))))
+	 (cdr spec)))
        ((specialize)
 	(set! enable-specialization #t))
        ((strict-types)