Hi,
On Sat, 8 Sep 2012 14:06:28 +0200 Peter Bex <peter....@xs4all.nl> wrote:
> On Fri, Sep 07, 2012 at 11:51:14PM +0200, Felix wrote:
>> 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.
>
> I decided to add some regression tests for this and found that there's
> a second bug. Before, deprecated procedures which have a suggested
> alternative would cause the compiler to crash, but with this patch
> they do not get an error message shown, because their assigned type
> is '(*) now, which breaks the global-result type dispatch.
>
> Attached is a modified version of your patch which fixes the bug,
> and contains a regression test. I also removed the older deprecation
> regression test because we probably want to eventually get rid of
> get-environment-variable, so we can't keep using it in our tests.
> This makes a bigger diff because all the line numbers moved and the
> gensymed names are different.
While testing Peter's patch, I noticed it breaks boot-chicken. The
build of library.scm is aborted with:
Error: (length) bad argument type - not a proper list: (procedure
return-to-host () . *)
The following part was causing that error:
(when (and type (not b)
- (not (eq? type 'deprecated))
+ (not (or (eq? type 'deprecated)
+ (and (= 2 (length type))
+ (eq? (car type) 'deprecated))))
So Peter suggested
(when (and type (not b)
(not (or (eq? type 'deprecated)
- (and (= 2 (length type))
- (eq? (car type) 'deprecated))))
+ (and (pair? type)
+ (eq? (car type) 'deprecated))))
instead (diff against Peter's patch). That seems to do the trick.
Attached is Felix's patch with Peter's changes plus the fix above.
Best wishes.
Mario
--
http://parenteses.org/mario
>From 04194887f1d0588e86b2497316809b62c555fbea Mon Sep 17 00:00:00 2001
From: felix <fe...@call-with-current-continuation.org>
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 | 32 +++++++++++++++++---------------
tests/scrutiny-tests.scm | 13 +++++++++----
tests/scrutiny.expected | 45 ++++++++++++++++++++++++---------------------
types.db | 2 +-
4 files changed, 51 insertions(+), 41 deletions(-)
diff --git a/scrutinizer.scm b/scrutinizer.scm
index 6e03660..a08d2ea 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 abe01f7..49a0673 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 a79e854..5faf737 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 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.9.5
_______________________________________________
Chicken-hackers mailing list
Chicken-hackers@nongnu.org
https://lists.nongnu.org/mailman/listinfo/chicken-hackers
