[Chicken-hackers] [PATCH] bug in type-validation for "deprecated" declaration

[Felix]

The attached patch fixes a bug reported by Christian. The type-validation
of "deprecated" type-specifiers returned an incorrect value. Also, a small
bug in the type-database is fixed. 

This should go into 4.8.0, I think.

>From 74d8892ad71dd85ad58df549fc23f61cd2e147ba Mon Sep 17 00:00:00 2001
From: felix <address@hidden>
Date: Fri, 7 Sep 2012 23:47:51 +0200
Subject: [PATCH] Type-validation returned incorrect result for "deprecation" 
type-specifier.
 This also fixes a bug in types.db for "record-instance?"

Fixes #918.
---
 scrutinizer.scm |   28 +++++++++++++++-------------
 types.db        |    2 +-
 2 files changed, 16 insertions(+), 14 deletions(-)

diff --git a/scrutinizer.scm b/scrutinizer.scm
index 6e03660..765ea06 100755
--- a/scrutinizer.scm
+++ b/scrutinizer.scm
@@ -157,18 +157,18 @@
             (lambda (a) 
               (cond
                ((eq? a 'deprecated)
-               (report
-                loc
-                (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)))))
+                (report
+                 loc
+                 (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 (blist-type id flow)
@@ -1992,7 +1992,9 @@
                  (symbol? (cadr t))
                  t))
            ((eq? 'deprecated (car t))
-            (and (= 2 (length t)) (symbol? (second t))))
+            (and (= 2 (length t))
+                 (symbol? (second t))
+                 '*))
            ((or (memq '--> t) (memq '-> t)) =>
             (lambda (p)
               (let* ((cleanf (eq? '--> (car p)))
diff --git a/types.db b/types.db
index 0d8b8d2..84dbab0 100644
--- a/types.db
+++ b/types.db
@@ -1497,7 +1497,7 @@
 
 (procedure-data (#(procedure #:clean #:enforce) procedure-data (procedure) *))
 (record->vector (#(procedure #:clean) record->vector (*) vector))
-(record-instance? (#(procedure #:clean) record-instance? (*) boolean))
+(record-instance? (#(procedure #:clean) record-instance? (* #!optional symbol) 
boolean))
 (record-instance-length (#(procedure #:clean) record-instance-length (*) 
fixnum))
 (record-instance-slot (#(procedure #:clean #:enforce) record-instance-slot (* 
fixnum) *))
 (record-instance-slot-set! (#(procedure #:clean #:enforce) 
record-instance-slot-set! (* fixnum *) undefined))
-- 
1.7.0.4