Correcting a bug with returning a dynamic value
svn: r1588
This commit is contained in:
Kathy Gray
parent
caeb044b7d
commit
fedbf9e0c8
|
|
@ -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))
|
||||
|
|
|
|||
|
|
@ -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)))
|
||||
|
|
|
|||
|
|
@ -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
|
||||
|
||||
|
|
|
|||
|
|
@ -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
|
||||
|
|
|
|||
|
|
@ -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))])
|
||||
|
|
|
|||
|
|
@ -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
|
||||
|
||||
|
|
|
|||
|
|
@ -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)))
|
||||
|
|
|
|||
|
|
@ -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)
|
||||
|
|
|
|||
|
|
@ -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))
|
||||
|
|
|
|||
|
|
@ -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; }}"
|
||||
|
|
|
|||
Loading…
Reference in New Issue
Block a user