From fedbf9e0c86e4e230edecfdbe8173ac420290d05 Mon Sep 17 00:00:00 2001 From: Kathy Gray Date: Mon, 12 Dec 2005 03:51:20 +0000 Subject: [PATCH] Correcting a bug with returning a dynamic value svn: r1588 --- collects/profj/ast.ss | 4 +- collects/profj/check.ss | 16 +- collects/profj/parsers/advanced-parser.ss | 4 +- collects/profj/parsers/beginner-parser.ss | 2 +- collects/profj/parsers/full-parser.ss | 4 +- collects/profj/parsers/intermediate-parser.ss | 4 +- collects/profj/profj-testing.ss | 3 +- collects/profj/to-scheme.ss | 162 +++++++++--------- collects/profj/types.ss | 6 +- collects/tests/profj/full-tests.ss | 12 ++ 10 files changed, 118 insertions(+), 99 deletions(-) diff --git a/collects/profj/ast.ss b/collects/profj/ast.ss index 0cad2d5eb0..44b5d159f4 100644 --- a/collects/profj/ast.ss +++ b/collects/profj/ast.ss @@ -128,8 +128,8 @@ ;(make-throw Expression src src) (p-define-struct throw (expr key-src src)) - ;(make-return Expression boolean src) - (p-define-struct return (expr in-tail? src)) + ;(make-return Expression (U #f type) boolean src) + (p-define-struct return (expr exp-type in-tail? src)) ;(make-while Expression Statement src) (p-define-struct while (cond loop src)) diff --git a/collects/profj/check.ss b/collects/profj/check.ss index f317c2fb88..c606b5c77a 100644 --- a/collects/profj/check.ss +++ b/collects/profj/check.ss @@ -938,7 +938,8 @@ interactions? type-recs)) ((return? statement) - (check-return (return-expr statement) + (check-return statement + (return-expr statement) return env check-e-no-change @@ -1063,15 +1064,16 @@ (send type-recs add-req (make-req "Throwable" (list "java" "lang"))))) exp/env)) - ;check-return: expression type env (expression -> type/env) src bool symbol type-records -> type/env - (define (check-return ret-expr return env check src interact? level type-recs) + ;check-return: statement expression type env (expression -> type/env) src bool symbol type-records -> type/env + (define (check-return stmt ret-expr return env check src interact? level type-recs) (cond (interact? (check ret-expr)) ((and ret-expr (not (eq? 'void return))) - (let ((ret/env (check ret-expr))) - (if (assignment-conversion return (type/env-t ret/env) type-recs) - ret/env - (return-error 'not-equal (type/env-t ret/env) return src)))) + (set-return-exp-type! stmt return) + (let ((ret/env (check ret-expr))) + (if (assignment-conversion return (type/env-t ret/env) type-recs) + ret/env + (return-error 'not-equal (type/env-t ret/env) return src)))) ((and ret-expr (eq? 'void return)) (return-error 'void #f return src)) ((and (not ret-expr) (not (eq? 'void return))) diff --git a/collects/profj/parsers/advanced-parser.ss b/collects/profj/parsers/advanced-parser.ss index 0b3469b9d8..1d0b9b0a1e 100644 --- a/collects/profj/parsers/advanced-parser.ss +++ b/collects/profj/parsers/advanced-parser.ss @@ -545,8 +545,8 @@ [(continue SEMI_COLON) (make-continue #f (build-src 2))]) (ReturnStatement - [(return Expression SEMI_COLON) (make-return $2 #f (build-src 3))] - [(return SEMI_COLON) (make-return #f #f (build-src 2))]) + [(return Expression SEMI_COLON) (make-return $2 #f #f (build-src 3))] + [(return SEMI_COLON) (make-return #f #f #f (build-src 2))]) ;; 19.12 diff --git a/collects/profj/parsers/beginner-parser.ss b/collects/profj/parsers/beginner-parser.ss index 4ec267315a..8a3f39e9f6 100644 --- a/collects/profj/parsers/beginner-parser.ss +++ b/collects/profj/parsers/beginner-parser.ss @@ -317,7 +317,7 @@ (make-ifS $3 $5 $7 (build-src 1) (build-src 7))]) (ReturnStatement - [(return Expression SEMI_COLON) (make-return $2 #t (build-src 3))]) + [(return Expression SEMI_COLON) (make-return $2 #f #t (build-src 3))]) ;; 19.12 (Primary diff --git a/collects/profj/parsers/full-parser.ss b/collects/profj/parsers/full-parser.ss index 0f36c1395a..f32d766840 100644 --- a/collects/profj/parsers/full-parser.ss +++ b/collects/profj/parsers/full-parser.ss @@ -639,8 +639,8 @@ [(continue SEMI_COLON) (make-continue #f (build-src 2))]) (ReturnStatement - [(return Expression SEMI_COLON) (make-return $2 #f (build-src 3))] - [(return SEMI_COLON) (make-return #f #f (build-src 2))]) + [(return Expression SEMI_COLON) (make-return $2 #f #f (build-src 3))] + [(return SEMI_COLON) (make-return #f #f #f (build-src 2))]) (ThrowStatement [(throw Expression SEMI_COLON) (make-throw $2 (build-src 1) (build-src 3))]) diff --git a/collects/profj/parsers/intermediate-parser.ss b/collects/profj/parsers/intermediate-parser.ss index 1f380f4511..6b363ddf73 100644 --- a/collects/profj/parsers/intermediate-parser.ss +++ b/collects/profj/parsers/intermediate-parser.ss @@ -422,8 +422,8 @@ [(StatementExpressionList COMMA StatementExpression) (cons $3 $1)]) (ReturnStatement - [(return Expression SEMI_COLON) (make-return $2 #f (build-src 3))] - [(return SEMI_COLON) (make-return #f #f (build-src 2))]) + [(return Expression SEMI_COLON) (make-return $2 #f #f (build-src 3))] + [(return SEMI_COLON) (make-return #f #f #f (build-src 2))]) ;; 19.12 diff --git a/collects/profj/profj-testing.ss b/collects/profj/profj-testing.ss index 6d1ab19704..a374e40545 100644 --- a/collects/profj/profj-testing.ss +++ b/collects/profj/profj-testing.ss @@ -94,7 +94,8 @@ msg ent (exn-message exn)) (interaction-msgs))))))]) (let ((new-val (eval `(begin (require (lib "class.ss") - (prefix javaRuntime: (lib "runtime.scm" "profj" "libs" "java"))) + (prefix javaRuntime: (lib "runtime.scm" "profj" "libs" "java")) + (prefix c: (lib "contract.ss"))) ,(compile-interactions st st type-recs level))))) (unless (java-equal? (eval val) new-val null null) (interaction-errors (add1 (interaction-errors))) diff --git a/collects/profj/to-scheme.ss b/collects/profj/to-scheme.ss index 555faaacfc..6892749c90 100644 --- a/collects/profj/to-scheme.ss +++ b/collects/profj/to-scheme.ss @@ -1485,83 +1485,84 @@ ;Converted ;translate-statement: statement string type-records -> syntax - (define translate-statement - (lambda (statement type-recs) - (cond - ((ifS? statement) - (translate-if (translate-expression (ifS-cond statement)) - (translate-statement (ifS-then statement) type-recs) - (if (ifS-else statement) - (translate-statement (ifS-else statement) type-recs) - 'void) - (ifS-key-src statement) - (ifS-src statement))) - ((throw? statement) - (translate-throw (translate-expression (throw-expr statement)) - (throw-key-src statement) - (throw-src statement))) - ((return? statement) - (translate-return (if (return-expr statement) - (translate-expression (return-expr statement)) - (make-syntax #f '(void) #f)) - (return-in-tail? statement) - (return-src statement))) - ((while? statement) - (translate-while (translate-expression (while-cond statement)) - (translate-statement (while-loop statement) type-recs) - (while-src statement))) - ((doS? statement) - (translate-do (translate-statement (doS-loop statement) type-recs) - (translate-expression (doS-cond statement)) - (doS-src statement))) - ((for? statement) - (translate-for (for-init statement) - (translate-expression (for-cond statement)) - (map translate-expression (for-incr statement)) - (translate-statement (for-loop statement) type-recs) - (for-src statement) - type-recs)) - ((try? statement) - (translate-try (translate-statement (try-body statement) type-recs) - (try-catches statement) - (and (try-finally statement) - (translate-statement (try-finally statement) type-recs)) - (try-key-src statement) - (try-src statement) - type-recs)) - ((switch? statement) - (translate-switch (translate-expression (switch-expr statement)) - (switch-cases statement) - (switch-src statement) - type-recs)) - ((block? statement) - (translate-block (block-stmts statement) (block-src statement) type-recs)) - ((def? statement) - (current-local-classes (cons statement (current-local-classes))) - (create-syntax #f '(void) #f)) - ((break? statement) - (translate-break (break-label statement) (break-src statement))) - ((continue? statement) - (translate-continue (continue-label statement) (continue-src statement))) - ((label? statement) - (translate-label (label-label statement) - (translate-statement (label-stmt statement) type-recs) - (label-src statement))) - ((synchronized? statement) - (translate-synchronized (translate-expression (synchronized-expr statement)) - (translate-statement (synchronized-stmt statement) type-recs) - (synchronized-src statement))) - ((statement-expression? statement) - (translate-expression statement)) - (else - (error 'translate-statement (format "translate-statement given unsupported: ~s" statement)))))) + (define (translate-statement statement type-recs) + (cond + ((ifS? statement) + (translate-if (translate-expression (ifS-cond statement)) + (translate-statement (ifS-then statement) type-recs) + (if (ifS-else statement) + (translate-statement (ifS-else statement) type-recs) + 'void) + (ifS-key-src statement) + (ifS-src statement))) + ((throw? statement) + (translate-throw (translate-expression (throw-expr statement)) + (throw-key-src statement) + (throw-src statement))) + ((return? statement) + (translate-return (if (return-expr statement) + (translate-expression (return-expr statement)) + (make-syntax #f '(void) #f)) + (and (return-expr statement) + (expr-types (return-expr statement))) + (return-exp-type statement) + (return-in-tail? statement) + (return-src statement))) + ((while? statement) + (translate-while (translate-expression (while-cond statement)) + (translate-statement (while-loop statement) type-recs) + (while-src statement))) + ((doS? statement) + (translate-do (translate-statement (doS-loop statement) type-recs) + (translate-expression (doS-cond statement)) + (doS-src statement))) + ((for? statement) + (translate-for (for-init statement) + (translate-expression (for-cond statement)) + (map translate-expression (for-incr statement)) + (translate-statement (for-loop statement) type-recs) + (for-src statement) + type-recs)) + ((try? statement) + (translate-try (translate-statement (try-body statement) type-recs) + (try-catches statement) + (and (try-finally statement) + (translate-statement (try-finally statement) type-recs)) + (try-key-src statement) + (try-src statement) + type-recs)) + ((switch? statement) + (translate-switch (translate-expression (switch-expr statement)) + (switch-cases statement) + (switch-src statement) + type-recs)) + ((block? statement) + (translate-block (block-stmts statement) (block-src statement) type-recs)) + ((def? statement) + (current-local-classes (cons statement (current-local-classes))) + (create-syntax #f '(void) #f)) + ((break? statement) + (translate-break (break-label statement) (break-src statement))) + ((continue? statement) + (translate-continue (continue-label statement) (continue-src statement))) + ((label? statement) + (translate-label (label-label statement) + (translate-statement (label-stmt statement) type-recs) + (label-src statement))) + ((synchronized? statement) + (translate-synchronized (translate-expression (synchronized-expr statement)) + (translate-statement (synchronized-stmt statement) type-recs) + (synchronized-src statement))) + ((statement-expression? statement) + (translate-expression statement)) + (else + (error 'translate-statement (format "translate-statement given unsupported: ~s" statement))))) ;Converted ;translate-if: syntax syntax syntax src src -> syntax - (define translate-if - (lambda (if? then else key src) - (create-syntax #f `(,(create-syntax #f `if (build-src key)) ,if? ,then ,else) (build-src src)))) + (define (translate-if if? then else key src) + (create-syntax #f `(,(create-syntax #f `if (build-src key)) ,if? ,then ,else) (build-src src))) ;Converted ;translate-throw: syntax src src -> syntax @@ -1577,11 +1578,14 @@ ;return -> call to a continuation ;Presently a no-op in the interactions window, although this is incorrect for advanced and full - ;translate-return: syntax bool src -> syntax - (define (translate-return expr in-tail? src) - (if (or (interactions?) in-tail?) - (make-syntax #f expr #f) - (make-syntax #f `(return-k ,expr) (build-src src)))) + ;translate-return: syntax type type bool src -> syntax + (define (translate-return expr expr-type exp-type in-tail? src) + (let ((expr (if (and expr-type (eq? 'dynamic exp-type)) + (guard-convert-value expr expr-type) + expr))) + (if (or (interactions?) in-tail?) + (make-syntax #f expr #f) + (make-syntax #f `(return-k ,expr) (build-src src))))) ;translate-while: syntax syntax src -> syntax (define (translate-while cond body src) @@ -1889,7 +1893,7 @@ `(let ((val ,val)) (if (string? val) (make-java-string val) - val))) + (c:contract ,(type->contract type #t) val '|| (quote ,(string->symbol (class-name))))))) ((ref-type? type) (cond ((equal? type string-type) diff --git a/collects/profj/types.ss b/collects/profj/types.ss index 04e69ad865..c3f97f01b9 100644 --- a/collects/profj/types.ss +++ b/collects/profj/types.ss @@ -315,13 +315,13 @@ (define-struct scheme-record (name path dir provides)) ;;(make-dynamic-val (U type method-contract unknown-ref)) - (define-struct dynamic-val (type)) + (define-struct dynamic-val (type) (make-inspector)) ;;(make-unknown-ref (U method-contract field-contract)) - (define-struct unknown-ref (access)) + (define-struct unknown-ref (access) (make-inspector)) ;;(make-method-contract string type (list type) (U #f string)) - (define-struct method-contract (name return args prefix)) + (define-struct method-contract (name return args prefix) (make-inspector)) ;;(make-field-contract string type) (define-struct field-contract (name type)) diff --git a/collects/tests/profj/full-tests.ss b/collects/tests/profj/full-tests.ss index 68925911c9..b944d00090 100644 --- a/collects/tests/profj/full-tests.ss +++ b/collects/tests/profj/full-tests.ss @@ -4,6 +4,18 @@ (prepare-for-tests "Full") + (parameterize ((dynamic? #t)) + (interact-test + "interface I { int m( int x); } + class C implements I { + int m(int x) { return x; } + boolean n(boolean y) { return !y; } + dynamic q(I x) { return x; } + }" 'full + '("(new C().q(new C())).n(true)" "(new C().q(new C())).m(5)") + '(error 5) + "Returning a dynamic value, properly quarded. Should not be send")) + (parameterize ((dynamic? #t)) (interact-test "class X{ int x( int i) { return i; }}"