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. > This should go into 4.8.0, I think. I agree. It's an annoying bug which causes breakage. Cheers, Peter -- http://sjamaan.ath.cx -- "The process of preparing programs for a digital computer is especially attractive, not only because it can be economically and scientifically rewarding, but also because it can be an aesthetic experience much like composing poetry or music." -- Donald Knuth
>From 89b11e77e80a4095aa87624ebb56c6f701745daf Mon Sep 17 00:00:00 2001 From: felix <[email protected]> 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..c5d71bf 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 (= 2 (length 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.1
_______________________________________________ Chicken-hackers mailing list [email protected] https://lists.nongnu.org/mailman/listinfo/chicken-hackers
