~ chicken-core (chicken-5) a152154e8291bd9b7597bae20022162eb8293a02

commit a152154e8291bd9b7597bae20022162eb8293a02
Author:     felix <felix@call-with-current-continuation.org>
AuthorDate: Sat Jul 17 15:38:42 2010 +0200
Commit:     felix <felix@call-with-current-continuation.org>
CommitDate: Tue Jul 27 13:09:33 2010 +0200

    alternative deprecated type for scrutiny; bugfix in symbol-aliasing in declarations

diff --git a/compiler.scm b/compiler.scm
index 435909b0..5d064d2f 100644
--- a/compiler.scm
+++ b/compiler.scm
@@ -1251,10 +1251,12 @@
     (##sys#strip-syntax x se))
   (define stripu ##sys#strip-syntax)
   (define (globalize sym)
-    (let loop ((se se))			; ignores syntax bindings
-      (cond ((null? se) (##sys#alias-global-hook sym #f))
-	    ((and (eq? sym (caar se)) (symbol? (cdar se))) (cdar se))
-	    (else (loop (cdr se))))))
+    (if (symbol? sym)
+	(let loop ((se se))			; ignores syntax bindings
+	  (cond ((null? se) (##sys#alias-global-hook sym #f))
+		((and (eq? sym (caar se)) (symbol? (cdar se))) (cdar se))
+		(else (loop (cdr se)))))
+	sym))
   (define (globalize-all syms) (map globalize syms))
   (call-with-current-continuation
    (lambda (return)
diff --git a/scrutinizer.scm b/scrutinizer.scm
index 06ba52a3..549c5987 100644
--- a/scrutinizer.scm
+++ b/scrutinizer.scm
@@ -48,6 +48,7 @@
 ;       | (procedure (VAL1 ... [#!optional VALOPT1 ...] [#!rest [VAL | values]]) . RESULTS)
 ;       | BASIC
 ;       | deprecated
+;       | (deprecated NAME)
 ;   BASIC = * | string | symbol | char | number | boolean | list | pair | 
 ;           procedure | vector | null | eof | undefined | port | 
 ;           blob | noreturn | pointer | locative | fixnum | float
@@ -89,8 +90,14 @@
 		   ((eq? a 'deprecated)
 		    (report
 		     loc
-		     (sprintf "use of deprecated toplevel identifier `~a'" id) )
+		     (sprintf "use of deprecated library procedure `~a'" id) )
 		    '*)
+		   ((and (pair? a) (eq? (car a) 'deprecated))
+		    (report 
+		     loc
+		     (sprintf "use of deprecated library procedure `~a' - consider using `~a' instead"
+		       id (cadr a)))
+		     '*)
 		   (else (list a)))))
 	  (else '*)))
   (define (variable-result id e loc)
@@ -469,7 +476,8 @@
 		      (every procedure-type? (cdr t)))))))
   (define (procedure-argument-types t n)
     (cond ((or (memq t '(* procedure)) 
-	       (not-pair? t) )
+	       (not-pair? t) 
+	       (eq? 'deprecated (car t)))
 	   (values (make-list n '*) #f))
 	  ((eq? 'procedure (car t))
 	   (let* ((vf #f)
@@ -573,8 +581,10 @@
 			    (walk (first subs) e loc var)
 			    loc))
 		       (b (assq var e)) )
-		  (when (and type (not b)
-			     (not (eq? type 'deprecated))
+		  (when (and type
+			     (not b)
+			     (not (or (eq? type 'deprecated)
+				      (and (pair? type) (eq? 'deprecated (car type)))))
 			     (not (match type rt)))
 		    (report
 		     loc