~ chicken-core (chicken-5) 08808a813bda8f0ec96f8f2361fbd551a99c646a
commit 08808a813bda8f0ec96f8f2361fbd551a99c646a
Author: felix <felix@call-with-current-continuation.org>
AuthorDate: Fri Sep 7 23:47:51 2012 +0200
Commit: Peter Bex <peter.bex@xs4all.nl>
CommitDate: Sat Sep 8 21:08:15 2012 +0200
Type-validation returned incorrect result for "deprecation" type-specifier. This also fixes a bug in types.db for "record-instance?"
Fixes #918.
Signed-off-by: Peter Bex <peter.bex@xs4all.nl>
diff --git a/scrutinizer.scm b/scrutinizer.scm
index 6e036600..a08d2ea0 100755
--- a/scrutinizer.scm
+++ b/scrutinizer.scm
@@ -154,21 +154,21 @@
(define (global-result id loc)
(cond ((variable-mark id '##compiler#type) =>
- (lambda (a)
+ (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)
@@ -598,7 +598,9 @@
(type-typeenv rt)))
(b (assq var e)) )
(when (and type (not b)
- (not (eq? type 'deprecated))
+ (not (or (eq? type 'deprecated)
+ (and (pair? type)
+ (eq? (car type) 'deprecated))))
(not (match-types type rt typeenv)))
((if strict-variable-types report-error report)
loc
@@ -1992,7 +1994,7 @@
(symbol? (cadr t))
t))
((eq? 'deprecated (car t))
- (and (= 2 (length t)) (symbol? (second t))))
+ (and (= 2 (length t)) (symbol? (second t)) t))
((or (memq '--> t) (memq '-> t)) =>
(lambda (p)
(let* ((cleanf (eq? '--> (car p)))
diff --git a/tests/scrutiny-tests.scm b/tests/scrutiny-tests.scm
index abe01f72..49a0673e 100644
--- a/tests/scrutiny-tests.scm
+++ b/tests/scrutiny-tests.scm
@@ -1,8 +1,5 @@
;;;; scrutiny-tests.scm
-
-(pp (current-environment)) ; deprecated
-
(define (a)
(define (b)
(define (c)
@@ -141,4 +138,12 @@
(module bar ()
(import chicken scheme)
(define-type footype string)
- (the footype "bar"))
\ No newline at end of file
+ (the footype "bar"))
+
+(: deprecated-procedure deprecated)
+(define (deprecated-procedure x) (+ x x))
+(deprecated-procedure 1)
+
+(: another-deprecated-procedure (deprecated replacement-procedure))
+(define (another-deprecated-procedure x) (+ x x))
+(another-deprecated-procedure 2)
diff --git a/tests/scrutiny.expected b/tests/scrutiny.expected
index a79e854d..5faf7376 100644
--- a/tests/scrutiny.expected
+++ b/tests/scrutiny.expected
@@ -1,7 +1,4 @@
-Warning: at toplevel:
- use of deprecated library procedure `current-environment'
-
Note: in local procedure `c',
in local procedure `b',
in toplevel procedure `a':
@@ -16,10 +13,10 @@ Warning: in toplevel procedure `foo':
(if x5 (values 1 2) (values 1 2 (+ (+ ...))))
Warning: at toplevel:
- (scrutiny-tests.scm:18) in procedure call to `bar6', expected argument #2 of type `number', but was given an argument of type `symbol'
+ (scrutiny-tests.scm:15) in procedure call to `bar6', expected argument #2 of type `number', but was given an argument of type `symbol'
Warning: at toplevel:
- (scrutiny-tests.scm:20) in procedure call to `pp', expected 1 argument, but was given 0 arguments
+ (scrutiny-tests.scm:17) in procedure call to `pp', expected 1 argument, but was given 0 arguments
Warning: at toplevel:
expected in argument #1 of procedure call `(print (cpu-time))' a single result, but were given 2 results
@@ -28,16 +25,16 @@ Warning: at toplevel:
expected in argument #1 of procedure call `(print (values))' a single result, but were given zero results
Warning: at toplevel:
- (scrutiny-tests.scm:26) in procedure call to `x7', expected a value of type `(procedure () *)', but was given a value of type `fixnum'
+ (scrutiny-tests.scm:23) in procedure call to `x7', expected a value of type `(procedure () *)', but was given a value of type `fixnum'
Warning: at toplevel:
- (scrutiny-tests.scm:28) in procedure call to `+', expected argument #1 of type `number', but was given an argument of type `symbol'
+ (scrutiny-tests.scm:25) in procedure call to `+', expected argument #1 of type `number', but was given an argument of type `symbol'
Warning: at toplevel:
- (scrutiny-tests.scm:28) in procedure call to `+', expected argument #2 of type `number', but was given an argument of type `symbol'
+ (scrutiny-tests.scm:25) in procedure call to `+', expected argument #2 of type `number', but was given an argument of type `symbol'
Warning: at toplevel:
- assignment of value of type `fixnum' to toplevel variable `car' does not match declared type `(forall (a140) (procedure car ((pair a140 *)) a140))'
+ assignment of value of type `fixnum' to toplevel variable `car' does not match declared type `(forall (a147) (procedure car ((pair a147 *)) a147))'
Warning: at toplevel:
expected in `let' binding of `g8' a single result, but were given 2 results
@@ -52,34 +49,34 @@ Note: in toplevel procedure `foo':
(if bar30 3 (##core#undefined))
Warning: in toplevel procedure `foo2':
- (scrutiny-tests.scm:57) in procedure call to `string-append', expected argument #1 of type `string', but was given an argument of type `number'
+ (scrutiny-tests.scm:54) in procedure call to `string-append', expected argument #1 of type `string', but was given an argument of type `number'
Warning: at toplevel:
- (scrutiny-tests.scm:65) in procedure call to `foo3', expected argument #1 of type `string', but was given an argument of type `fixnum'
+ (scrutiny-tests.scm:62) in procedure call to `foo3', expected argument #1 of type `string', but was given an argument of type `fixnum'
Warning: in toplevel procedure `foo4':
- (scrutiny-tests.scm:70) in procedure call to `+', expected argument #1 of type `number', but was given an argument of type `string'
+ (scrutiny-tests.scm:67) in procedure call to `+', expected argument #1 of type `number', but was given an argument of type `string'
Warning: in toplevel procedure `foo5':
- (scrutiny-tests.scm:76) in procedure call to `+', expected argument #1 of type `number', but was given an argument of type `string'
+ (scrutiny-tests.scm:73) in procedure call to `+', expected argument #1 of type `number', but was given an argument of type `string'
Warning: in toplevel procedure `foo6':
- (scrutiny-tests.scm:82) in procedure call to `+', expected argument #1 of type `number', but was given an argument of type `string'
+ (scrutiny-tests.scm:79) in procedure call to `+', expected argument #1 of type `number', but was given an argument of type `string'
Warning: at toplevel:
- (scrutiny-tests.scm:89) in procedure call to `+', expected argument #1 of type `number', but was given an argument of type `string'
+ (scrutiny-tests.scm:86) in procedure call to `+', expected argument #1 of type `number', but was given an argument of type `string'
Warning: in toplevel procedure `foo10':
- (scrutiny-tests.scm:103) in procedure call to `foo9', expected argument #1 of type `string', but was given an argument of type `number'
+ (scrutiny-tests.scm:100) in procedure call to `foo9', expected argument #1 of type `string', but was given an argument of type `number'
Warning: in toplevel procedure `foo10':
- (scrutiny-tests.scm:104) in procedure call to `+', expected argument #1 of type `number', but was given an argument of type `string'
+ (scrutiny-tests.scm:101) in procedure call to `+', expected argument #1 of type `number', but was given an argument of type `string'
Note: in toplevel procedure `foo10':
expression returns a result of type `string', but is declared to return `pair', which is not a subtype
Warning: in toplevel procedure `foo10':
- (scrutiny-tests.scm:108) in procedure call to `string-append', expected argument #1 of type `string', but was given an argument of type `pair'
+ (scrutiny-tests.scm:105) in procedure call to `string-append', expected argument #1 of type `string', but was given an argument of type `pair'
Warning: in toplevel procedure `foo10':
expression returns 2 values but is declared to have a single result
@@ -91,9 +88,15 @@ Warning: in toplevel procedure `foo10':
expression returns zero values but is declared to have a single result of type `*'
Warning: in toplevel procedure `foo10':
- (scrutiny-tests.scm:111) in procedure call to `*', expected argument #1 of type `number', but was given an argument of type `string'
+ (scrutiny-tests.scm:108) in procedure call to `*', expected argument #1 of type `number', but was given an argument of type `string'
Warning: in toplevel procedure `foo#blabla':
- (scrutiny-tests.scm:136) in procedure call to `+', expected argument #2 of type `number', but was given an argument of type `symbol'
+ (scrutiny-tests.scm:133) in procedure call to `+', expected argument #2 of type `number', but was given an argument of type `symbol'
+
+Warning: at toplevel:
+ use of deprecated library procedure `deprecated-procedure'
+
+Warning: at toplevel:
+ use of deprecated library procedure `another-deprecated-procedure' - consider using `replacement-procedure' instead
-Warning: redefinition of standard binding: car
\ No newline at end of file
+Warning: redefinition of standard binding: car
diff --git a/types.db b/types.db
index 0d8b8d28..84dbab0f 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))
Trap