diff --git a/collects/profj/comb-parsers/java-signatures.scm b/collects/profj/comb-parsers/java-signatures.scm index 8e98f71142..6879d023fd 100644 --- a/collects/profj/comb-parsers/java-signatures.scm +++ b/collects/profj/comb-parsers/java-signatures.scm @@ -67,9 +67,7 @@ (define-signature java-ops^ (math-ops shift-ops compare-ops bool-ops bit-ops assignment-ops bin-ops un-assignment un-op)) - ;Expression signatures - (define-signature expression-maker^ (simple-expression)) - + ;Expression signatures (define-signature expr-lits^ (boolean-lits textual-lits prim-numeric-lits null-lit numeric-lits double-lits literals all-literals)) diff --git a/collects/profj/comb-parsers/parser-units.scm b/collects/profj/comb-parsers/parser-units.scm index fc4e7f8bd1..aa143bea84 100644 --- a/collects/profj/comb-parsers/parser-units.scm +++ b/collects/profj/comb-parsers/parser-units.scm @@ -307,7 +307,7 @@ java-literals^ java-expression-keywords^ java-vals^ java-ids^ java-variables^ java-separators^ java-operators^ java-extras^ language-forms^) - (export expression-maker^ expr-lits^ expr-terms+^ expr-tails^) + (export expr-lits^ expr-terms+^ expr-tails^) (define (simple-expression exprs) (choice exprs "expression")) @@ -409,65 +409,65 @@ ) (define-unit statements@ - (import combinator-parser^ general-productions^ id^ + (import combinator-parser^ general-productions^ id^ language-forms^ java-statement-keywords^ java-separators^ java-ids^ java-operators^) (export statements^) - (define (if-s expr statement else?) + (define (if-s stmt else?) (cond [else? - (choose ((sequence (ifT O_PAREN expr C_PAREN statement elseT statement) id) - (sequence (ifT O_PAREN expr C_PAREN statement) id)) "if")] - [else (sequence (ifT O_PAREN expr C_PAREN statement elseT statement) id "if")])) + (choose ((sequence (ifT O_PAREN expression C_PAREN stmt elseT stmt) id) + (sequence (ifT O_PAREN expression C_PAREN stmt) id)) "if")] + [else (sequence (ifT O_PAREN expression C_PAREN stmt elseT stmt) id "if")])) - (define (return-s expr opt?) + (define (return-s opt?) (cond - [opt? (choose ((sequence (return expr SEMI_COLON) id) + [opt? (choose ((sequence (return expression SEMI_COLON) id) (sequence (return SEMI_COLON) id)) "return statement")] - [else (sequence (return expr SEMI_COLON) id "return statement")])) + [else (sequence (return expression SEMI_COLON) id "return statement")])) - (define (this-call expr) + (define this-call (choose ((sequence (this O_PAREN C_PAREN SEMI_COLON) id) - (sequence (this O_PAREN (comma-sep expr "arguments") C_PAREN SEMI_COLON) id)) "this constructor call")) + (sequence (this O_PAREN (comma-sep expression "arguments") C_PAREN SEMI_COLON) id)) "this constructor call")) - (define (super-ctor-call expr) + (define super-ctor-call (choose ((sequence (super O_PAREN C_PAREN SEMI_COLON) id) - (sequence (super O_PAREN (comma-sep expr "arguments") C_PAREN SEMI_COLON) id)) "super constructor call")) + (sequence (super O_PAREN (comma-sep expression "arguments") C_PAREN SEMI_COLON) id)) "super constructor call")) - (define (block statement) - (sequence (O_BRACE statement C_BRACE) id "block statement")) + (define (block repeat?) + (sequence (O_BRACE (if repeat? (repeat (eta statement)) (eta statement)) C_BRACE) + id "block statement")) - (define (expression-stmt expr) - (sequence (expr SEMI_COLON) id "statement")) + (define expression-stmt + (sequence (expression SEMI_COLON) id "statement")) + (define (while-l stmt) + (sequence (while O_PAREN expression C_PAREN stmt) id "while loop")) - (define (while-l expr statement) - (sequence (while O_PAREN expr C_PAREN statement) id "while loop")) + (define (do-while stmt) + (sequence (doT stmt while O_PAREN expression C_PAREN SEMI_COLON) id "do loop")) - (define (do-while expr statement) - (sequence (doT statement while O_PAREN expr C_PAREN SEMI_COLON) id "do loop")) - - (define (for-l init i-op? expr t-op? update up-op? statement) - (let ([full (sequence (for O_PAREN init SEMI_COLON expr SEMI_COLON update C_PAREN statement) id "for loop")] - [no-init (sequence (for O_PAREN SEMI_COLON expr SEMI_COLON update C_PAREN statement) id "for loop")] + (define (for-l init i-op? t-op? update up-op? statement) + (let ([full (sequence (for O_PAREN init SEMI_COLON expression SEMI_COLON update C_PAREN statement) id "for loop")] + [no-init (sequence (for O_PAREN SEMI_COLON expression SEMI_COLON update C_PAREN statement) id "for loop")] [no-tst (sequence (for O_PAREN init SEMI_COLON SEMI_COLON update C_PAREN statement) id "for loop")] - [no-up (sequence (for O_PAREN init SEMI_COLON expr SEMI_COLON C_PAREN statement) id "for loop")] + [no-up (sequence (for O_PAREN init SEMI_COLON expression SEMI_COLON C_PAREN statement) id "for loop")] [no-it (sequence (for O_PAREN SEMI_COLON SEMI_COLON update C_PAREN statement) id "for loop")] - [no-iu (sequence (for O_PAREN SEMI_COLON expr SEMI_COLON C_PAREN statement) id "for loop")] + [no-iu (sequence (for O_PAREN SEMI_COLON expression SEMI_COLON C_PAREN statement) id "for loop")] [no-tu (sequence (for O_PAREN init SEMI_COLON SEMI_COLON C_PAREN statement) id "for loop")] [none (sequence (for O_PAREN SEMI_COLON SEMI_COLON C_PAREN statement) id "for loop")]) (cond [(and i-op? t-op? up-op?) - (choice (list full no-init no-tst no-up no-it no-iu no-tu none) "for loop")] + (choose (full no-init no-tst no-up no-it no-iu no-tu none) "for loop")] [(and t-op? up-op?) - (choice (list full no-tst no-up no-tu) "for loop")] + (choose (full no-tst no-up no-tu) "for loop")] [(and i-op? t-op?) - (choice (list full no-init no-tst no-it) "for loop")] + (choose (full no-init no-tst no-it) "for loop")] [(and i-op? up-op?) - (choice (list full no-init no-up no-iu) "for loop")] - [i-op? (choice (list full no-init) "for loop")] - [t-op? (choice (list full no-tst) "for loop")] - [up-op? (choice (list full no-up) "for loop")] + (choose (full no-init no-up no-iu) "for loop")] + [i-op? (choose (full no-init) "for loop")] + [t-op? (choose (full no-tst) "for loop")] + [up-op? (choose (full no-up) "for loop")] [else full]))) (define (break-s label) @@ -629,7 +629,7 @@ (import combinator-parser^ java-operators^ java-separators^ java-statement-keywords^ java-type-keywords^ java-ids^ java-types^ java-access^ java-ops^ general-productions^ java-variables^ - expression-maker^ expr-lits^ expr-terms+^ expr-tails^ statements^ + expr-lits^ expr-terms+^ expr-tails^ statements^ fields^ methods^ ctors^ interfaces^ classes^ top-forms^ id^) (export language-forms^) @@ -655,8 +655,7 @@ (sequence (unique-base (repeat unique-end)) id "expression")) (define statement - (make-statement (list (if-s expression (eta statement) #f) - (return-s expression #f)))) + (choose ((if-s (block #f) #f) (return-s #f)) "statement")) (define field (make-field #f (value+name-type prim-type) expression #f)) @@ -682,7 +681,7 @@ (import combinator-parser^ java-operators^ java-separators^ (prefix tok: java-definition-keywords^) java-statement-keywords^ java-type-keywords^ java-ids^ java-types^ java-access^ java-ops^ general-productions^ java-variables^ - expression-maker^ expr-lits^ expr-terms+^ expr-tails^ statements^ + expr-lits^ expr-terms+^ expr-tails^ statements^ fields^ methods^ ctors^ interfaces^ classes^ top-forms^ id^) (export language-forms^) @@ -720,12 +719,11 @@ EQUAL)) "expression")) (define statement - (make-statement - (list (if-s expression (eta statement) #f) - (return-s expression #t) - (variable-declaration (value+name-type prim-type) expression #f "local variable") - (block (repeat (eta statement))) - (sequence (stmt-expr SEMI_COLON) id "statement")))) + (choose ((if-s (block #t) #f) + (return-s #t) + (variable-declaration (value+name-type prim-type) expression #f "local variable") + (block #t) + (sequence (stmt-expr SEMI_COLON) id)) "statement")) (define field (make-field #f (value+name-type prim-type) expression #t)) @@ -765,7 +763,7 @@ (import combinator-parser^ java-operators^ java-separators^ (prefix tok: java-definition-keywords^) java-statement-keywords^ java-type-keywords^ java-ids^ java-types^ java-access^ java-ops^ general-productions^ java-variables^ - expression-maker^ expr-lits^ expr-terms+^ expr-tails^ statements^ + expr-lits^ expr-terms+^ expr-tails^ statements^ fields^ methods^ ctors^ interfaces^ classes^ top-forms^ id^) (export language-forms^) @@ -803,12 +801,11 @@ EQUAL)) "expression")) (define statement - (make-statement - (list (if-s expression (eta statement) #f) - (return-s expression #t) - (variable-declaration (value+name-type prim-type) expression #f "local variable") - (block (repeat (eta statement))) - (sequence (stmt-expr SEMI_COLON) id "statement")))) + (choose ((if-s (block #t) #f) + (return-s #t) + (variable-declaration (value+name-type prim-type) expression #f "local variable") + (block #t) + (sequence (stmt-expr SEMI_COLON) id)) "statement")) (define field (make-field access-mods (value+name-type prim-type) expression #t)) @@ -848,70 +845,67 @@ (import combinator-parser^ java-operators^ java-separators^ (prefix tok: java-definition-keywords^) java-statement-keywords^ java-type-keywords^ java-ids^ java-types^ java-access^ java-ops^ general-productions^ java-variables^ - expression-maker^ expr-lits^ expr-terms+^ expr-tails^ statements^ + expr-lits^ expr-terms+^ expr-tails^ statements^ fields^ methods^ ctors^ interfaces^ classes^ top-forms^ id^) (export language-forms^) (define unique-base - (simple-expression - (list (literals (list null-lit boolean-lits textual-lits prim-numeric-lits double-lits)) - this - IDENTIFIER - new-class - (simple-method-call (eta expression)) - (new-array (value+name-type prim-type) (eta expression)) - (sequence (O_PAREN (eta expression) C_PAREN) id "expression") - (sequence (! (eta expression)) id "conditional expression") - (sequence (MINUS (eta expression)) id "negation exxpression") - (cast (value+name-type prim-type) (eta expression)) - (super-call (eta expression)) - (checks (eta expression))))) + (choose + ((literals (list null-lit boolean-lits textual-lits prim-numeric-lits double-lits)) + this + IDENTIFIER + new-class + simple-method-call + (new-array (value+name-type prim-type)) + (sequence (O_PAREN (eta expression) C_PAREN) id) + (sequence (! (eta expression)) id "conditional expression") + (sequence (MINUS (eta expression)) id "negation exxpression") + (cast (value+name-type prim-type)) + super-call + checks) "expression")) (define unique-end - (simple-expression - (list field-access-end - (array-access-end (eta expression)) - (method-call-end (eta expression)) - (if-expr-end (eta expression)) - (binary-expression-end (bin-ops (list math-ops compare-ops bool-ops bit-ops)) - (eta expression)) - instanceof-back))) + (choose (field-access-end + array-access-end + method-call-end + if-expr-end + (binary-expression-end (bin-ops (list math-ops compare-ops bool-ops bit-ops))) + instanceof-back) + "expression")) (define expression - (sequence (unique-base (repeat unique-end)) id "expression")) + (sequence (unique-base (repeat unique-end)) id "expression")) (define stmt-expr - (simple-expression (list new-class - (super-call expression) - (sequence (expression - (method-call-end expression)) id "method call") - (assignment - (choose (identifier - (sequence (expression field-access-end) id) - (sequence (expression (array-access-end expression)) id)) - "asignee") - assignment-ops expression) - (sequence (expression ++) id "unary mutation") - (sequence (expression --) id "unary mutation") - (sequence (++ expression) id "unary mutation") - (sequence (-- expression) id "unary mutation")))) + (choose (new-class + super-call + (sequence (expression method-call-end expression) id "method call") + (assignment + (choose (identifier + (sequence (expression field-access-end) id) + (sequence (expression array-access-end) id)) + "asignee") + assignment-ops expression) + (sequence (expression ++) id "unary mutation") + (sequence (expression --) id "unary mutation") + (sequence (++ expression) id "unary mutation") + (sequence (-- expression) id "unary mutation")) "expression")) (define statement - (make-statement (list (if-s expression (eta statement) #t) - (return-s expression #t) - (variable-declaration (value+name-type prim-type) expression #t "local variable") - (block (repeat (eta statement))) - (sequence (stmt-expr SEMI_COLON) id "statement") - (for-l (choose ((variable-declaration (value+name-type prim-type) expression #t "for loop variable") - (comma-sep stmt-expr "initializations")) "for loop initialization") - #t - expression #t - (comma-sep stmt-expr "for loop increments") #t (eta statement)) - (while-l expression (eta statement)) - (do-while expression (eta statement)) - (break-s #f) - (cont-s #f)))) + (choose ((if-s #t (eta statement)) + (return-s #t) + (variable-declaration (value+name-type prim-type) expression #t "local variable") + (block #t) + (sequence (stmt-expr SEMI_COLON) id) + (for-l (choose ((variable-declaration (value+name-type prim-type) expression #t "for loop variable") + (comma-sep stmt-expr "initializations")) "for loop initialization") + #t #t + (comma-sep stmt-expr "for loop increments") #t (block #t)) + (while-l (block #t)) + (do-while (block #t)) + (break-s #f) + (cont-s #f)) "statement")) (define field (make-field (global-mods access-mods) (value+name-type prim-type) expression #t)) diff --git a/collects/profj/compile.ss b/collects/profj/compile.ss index a2533cd5bf..8f74929327 100644 --- a/collects/profj/compile.ss +++ b/collects/profj/compile.ss @@ -46,7 +46,9 @@ (equal? (version) (call-with-input-file compiled-path get-version)) (read-record type-path) (> (file-or-directory-modify-seconds compiled-path) - (file-or-directory-modify-seconds (build-path name)))) + (file-or-directory-modify-seconds (build-path name))) + (> (file-or-directory-modify-seconds compiled-path) + (file-or-directory-modify-seconds (build-path (collection-path "mzlib") "contract.ss")))) (call-with-input-file name (lambda (port) (compile-to-file port name level))))))) ((eq? dest 'file) (compile-to-file port loc level)) @@ -56,7 +58,9 @@ (type-path (build-path path-base "compiled" (path-replace-suffix file ".jinfo")))) (unless (or (and (file-exists? compiled-path) (> (file-or-directory-modify-seconds compiled-path) - (file-or-directory-modify-seconds (build-path name)))) + (file-or-directory-modify-seconds (build-path name))) + (> (file-or-directory-modify-seconds compiled-path) + (file-or-directory-modify-seconds (build-path (collection-path "mzlib") "contract.ss")))) (and (file-exists? type-path) (read-record type-path))) (call-with-input-file diff --git a/collects/profj/libs/java/lang/Object-composite.ss b/collects/profj/libs/java/lang/Object-composite.ss index 6bcb288dae..4a6fa49ca0 100644 --- a/collects/profj/libs/java/lang/Object-composite.ss +++ b/collects/profj/libs/java/lang/Object-composite.ss @@ -130,14 +130,12 @@ (define convert-assert-Object (class* object% (wrapper) - (init w p n s c) - (define-values (wrapped pos-blame neg-blame src cc-marks) (values null null null null null)) + (init w) + (init-field pos-blame neg-blame src cc-marks) + + (define wrapped null) (set! wrapped w) - (set! pos-blame p) - (set! neg-blame n) - (set! src s) - (set! cc-marks c) - + (define/public (get-wrapped) wrapped) (define/public (compare obj1 obj2) (cond @@ -197,21 +195,31 @@ (define/public (field-names) (send wrapped field-names)) (define/public (field-values) (send wrapped field-values)) (define/public (fields-for-display) (send wrapped fields-for-display)) + + (public-final pos-blame* neg-blame* src* cc-marks*) + (define (pos-blame*) (ca-pos-blame* this)) + (define (neg-blame*) (ca-neg-blame* this)) + (define (src*) (ca-src* this)) + (define (cc-marks*) (ca-cc-marks* this)) + (super-instantiate ()))) + (define ca-pos-blame* (class-field-accessor convert-assert-Object pos-blame)) + (define ca-neg-blame* (class-field-accessor convert-assert-Object neg-blame)) + (define ca-src* (class-field-accessor convert-assert-Object src)) + (define ca-cc-marks* (class-field-accessor convert-assert-Object cc-marks)) + (define dynamic-Object/c (c:flat-named-contract "Object" (lambda (v) (is-a? v convert-assert-Object)))) (define guard-convert-Object (class* object% (wrapper) - (init w p n s c) - (define-values (wrapped pos-blame neg-blame src cc-marks) (values null null null null null)) + (init w) + (init-field pos-blame neg-blame src cc-marks) + + (define wrapped null) (set! wrapped w) - (set! pos-blame p) - (set! neg-blame n) - (set! src s) - (set! cc-marks s) (define/public (get-wrapped) wrapped) @@ -294,8 +302,21 @@ (define/public (field-names) (send wrapped field-names)) (define/public (field-values) (send wrapped field-values)) (define/public (fields-for-display) (send wrapped fields-for-display)) + (define/public (get-pos) (gc-pos-blame* this)) + + (public-final pos-blame* neg-blame* src* cc-marks*) + (define (pos-blame*) (gc-pos-blame* this)) + (define (neg-blame*) (gc-neg-blame* this)) + (define (src*) (gc-src* this)) + (define (cc-marks*) (gc-cc-marks* this)) + (super-instantiate ()))) + (define gc-pos-blame* (class-field-accessor guard-convert-Object pos-blame)) + (define gc-neg-blame* (class-field-accessor guard-convert-Object neg-blame)) + (define gc-src* (class-field-accessor guard-convert-Object src)) + (define gc-cc-marks* (class-field-accessor guard-convert-Object cc-marks)) + (define static-Object/c (c:flat-named-contract "Object" (lambda (v) (is-a? v guard-convert-Object)))) @@ -1028,38 +1049,51 @@ (init w p n s c) (super-instantiate (w p n s c)) - (define-values (wrapped pos-blame neg-blame src cc-marks) (values null null null null null)) + (define wrapped null) (set! wrapped w) - (set! pos-blame p) - (set! neg-blame n) - (set! src s) - (set! cc-marks c) - + (define/public (set-exception! exn) (send wrapped set-exception! exn)) (define/public (get-mzscheme-exception) (send wrapped get-mzscheme-exception)) (define/public (initCause-java.lang.Throwable cse) - (wrap-convert-assert-Throwable - (send wrapped initCause-java.lang.Throwable (make-object guard-convert-Throwable cse - pos-blame neg-blame src cc-marks) - pos-blame neg-blame src cc-marks))) + (let ([pb (send this pos-blame*)] + [nb (send this neg-blame*)] + [sr (send this src*)] + [cc (send this cc-marks*)]) + (wrap-convert-assert-Throwable + (send wrapped initCause-java.lang.Throwable + (make-object guard-convert-Throwable cse pb nb sr cc)) + pb nb sr cc))) (define/public (getMessage) - (let ((val (send wrapped getMessage))) + (let ([val (send wrapped getMessage)] + [pb (send this pos-blame*)] + [nb (send this neg-blame*)] + [sr (send this src*)] + [cc (send this cc-marks*)]) (if (string? val) (make-java-string val) - (raise (make-exn:fail - (format "~a broke ~a contract here; Throwable's getMessage expects string return, given ~a" - pos-blame neg-blame val) - cc-marks))))) - (define/public (getCause) - (wrap-convert-assert-Throwable (send wrapped getCause))) + (raise + (make-exn:fail + (format "~a broke ~a contract here; Throwable's getMessage expects string return, given ~a" + pb nb val) + cc))))) + (define/public (getCause) + (let ([pb (send this pos-blame*)] + [nb (send this neg-blame*)] + [sr (send this src*)] + [cc (send this cc-marks*)]) + (wrap-convert-assert-Throwable (send wrapped getCause) pb nb sr cc))) (define/public (getLocalizedMessage) - (let ((val (send wrapped getLocalizedMessage))) + (let ([val (send wrapped getLocalizedMessage)] + [pb (send this pos-blame*)] + [nb (send this neg-blame*)] + [sr (send this src*)] + [cc (send this cc-marks*)]) (if (string? val) (make-java-string val) (raise (make-exn:fail (format "~a broke ~a contract here; Throwable's getLocalizedMessage expects string return, given ~a" - pos-blame neg-blame val) - cc-marks))))) + pb nb val) + cc))))) (define/public (setStackTrace-java.lang.StackTraceElement1 elements) (send wrapped setStackTrace-java.lang.StackTraceElement1 elements)) (define/public (getStackTrace) (send wrapped getStackTrace)) @@ -1077,37 +1111,53 @@ (init w p n s c) (super-instantiate (w p n s c)) - (define-values (wrapped pos-blame neg-blame src cc-marks) (values null null null null null)) + + (define wrapped null) (set! wrapped w) - (set! pos-blame p) - (set! neg-blame n) - (set! src s) - (set! cc-marks s) (define/public (set-exception! exn) (send wrapped set-exception! exn)) (define/public (get-mzscheme-exception) (send wrapped get-mzscheme-exception)) (define/public (initCause-java.lang.Throwable . cse) + (let ([pb (send this pos-blame*)] + [nb (send this neg-blame*)] + [sr (send this src*)] + [cc (send this cc-marks*)]) (unless (= 1 (length cse)) (raise (make-exn:fail:contract:arity (format "~a broke ~a contract here: Throwable's initCause expects to be called with 1 argument, given ~n" - pos-blame neg-blame (length cse)) - cc-marks))) + pb nb (length cse)) + cc))) (make-object guard-convert-Throwable - (send wrapped initCause-java.lang.Throwable (wrap-convert-assert-Throwable (car cse))))) + (send wrapped initCause-java.lang.Throwable + (wrap-convert-assert-Throwable (car cse) pb nb sr cc))))) (define/public (init-cause . cse) - (unless (= 1 (length cse)) - (raise (make-exn:fail:contract:arity - (format "~a broke ~a contract here: Throwable's initCause expects to be called with 1 argument, given ~n" - pos-blame neg-blame (length cse)) - cc-marks))) - (make-object guard-convert-Throwable - (send wrapped initCause-java.lang.Throwable (wrap-convert-assert-Throwable (car cse) pos-blame neg-blame src cc-marks)) - pos-blame neg-blame src cc-marks)) + (let ([pb (send this pos-blame*)] + [nb (send this neg-blame*)] + [sr (send this src*)] + [cc (send this cc-marks*)]) + (unless (= 1 (length cse)) + (raise (make-exn:fail:contract:arity + (format "~a broke ~a contract here: Throwable's initCause expects to be called with 1 argument, given ~n" + pb nb (length cse)) + cc))) + (make-object guard-convert-Throwable + (send wrapped initCause-java.lang.Throwable + (wrap-convert-assert-Throwable (car cse) pb nb sr cc)) + pb nb sr cc))) (define/public (getMessage) (send (send wrapped getMessage) get-mzscheme-string)) (define/public (get-message) (send (send wrapped getMessage) get-mzscheme-string)) - (define/public (getCause) (make-object guard-convert-Throwable (send wrapped getCause) pos-blame neg-blame src cc-marks)) - (define/public (get-cause) (make-object guard-convert-Throwable - (send wrapped getCause) pos-blame neg-blame src cc-marks)) + (define/public (getCause) + (let ([pb (send this pos-blame*)] + [nb (send this neg-blame*)] + [sr (send this src*)] + [cc (send this cc-marks*)]) + (make-object guard-convert-Throwable (send wrapped getCause) pb nb sr cc))) + (define/public (get-cause) + (let ([pb (send this pos-blame*)] + [nb (send this neg-blame*)] + [sr (send this src*)] + [cc (send this cc-marks*)]) + (make-object guard-convert-Throwable (send wrapped getCause) pb nb sr cc))) (define/public (getLocalizedMessage) (send (send wrapped getLocalizedMessage) get-mzscheme-string)) (define/public (get-localized-message) (send (send wrapped getLocalizedMessage) get-mzscheme-string)) (define/public (setStackTrace-java.lang.StackTraceElement1 elements) diff --git a/collects/profj/parsers/beginner-parser.ss b/collects/profj/parsers/beginner-parser.ss index 2f5fc037fd..4b24e6bbf7 100644 --- a/collects/profj/parsers/beginner-parser.ss +++ b/collects/profj/parsers/beginner-parser.ss @@ -311,12 +311,12 @@ [(ReturnStatement) $1]) (IfThenElseStatement - [(if O_PAREN Expression C_PAREN StatementNoShortIf else Statement) - (make-ifS $3 $5 $7 (build-src 1) (build-src 7))]) + [(if O_PAREN Expression C_PAREN O_BRACE StatementNoShortIf C_BRACE else O_BRACE Statement C_BRACE) + (make-ifS $3 $6 $10 (build-src 1) (build-src 11))]) (IfThenElseStatementNoShortIf - [(if O_PAREN Expression C_PAREN StatementNoShortIf else StatementNoShortIf) - (make-ifS $3 $5 $7 (build-src 1) (build-src 7))]) + [(if O_PAREN Expression C_PAREN O_BRACE StatementNoShortIf C_BRACE else O_BRACE StatementNoShortIf C_BRACE) + (make-ifS $3 $6 $10 (build-src 1) (build-src 11))]) (ReturnStatement [(return Expression SEMI_COLON) (make-return $2 #f #t (build-src 3))]) diff --git a/collects/profj/to-scheme.ss b/collects/profj/to-scheme.ss index 84f0f91e08..41371f0a2f 100644 --- a/collects/profj/to-scheme.ss +++ b/collects/profj/to-scheme.ss @@ -861,12 +861,8 @@ `(define ,name (class ,super-name (init w* p* n* s* c*) - (define-values (wrapped-obj pos-blame neg-blame src* cc-marks) (values null null null null null)) + (define wrapped-obj null) (set! wrapped-obj w*) - (set! pos-blame p*) - (set! neg-blame n*) - (set! src* s*) - (set! cc-marks c*) (super-instantiate (w* p* n* s* c*)) ,@(generate-wrapper-fields fields from-dynamic?) @@ -901,34 +897,44 @@ (let* ((name (id-string (field-name field))) (dynamic-access-body (lambda (guard-body scheme-body) - `(if (is-a? wrapped-obj guard-convert-Object) + `(if (is-a? wr* guard-convert-Object) ,guard-body ,scheme-body))) (get-name (create-get-name name)) (set-name (create-set-name name)) - (get-call `(,get-name wrapped-obj)) - (set-call `(lambda (new-val) (,set-name wrapped-obj new-val)))) + (get-call `(,get-name wr*)) + (set-call `(lambda (new-val) (,set-name wr* new-val)))) (list `(define/public (,(build-identifier (format "~a-wrapped" get-name))) - ,(convert-value - (if from-dynamic? - (assert-value - (dynamic-access-body get-call `(get-field wrapped-obj (quote ,(build-identifier name)))) - (field-type field) #t 'field name) - get-call) (field-type field) from-dynamic?)) + (let ([wr* wrapped-obj] + [pb* (send this pos-blame*)] + [nb* (send this neg-blame*)] + [sr* (send this src*)] + [cc* (send this cc-marks*)]) + ,(convert-value + (if from-dynamic? + (assert-value + (dynamic-access-body get-call `(get-field wr* (quote ,(build-identifier name)))) + (field-type field) #t 'field name) + get-call) (field-type field) from-dynamic?))) (if (memq 'final (field-modifiers field)) null `(define/public (,(build-identifier (format "~a-wrapped" set-name)) new-val) - (,(if from-dynamic? - (dynamic-access-body set-call - `(lambda (new-val) - (define set-field null) - (set-field wrapped-obj (quote ,(build-identifier name)) new-val))) - set-call) - ,(convert-value (if (not from-dynamic?) - (assert-value 'new-val (field-type field) #t 'field name) - 'new-val) (field-type field) from-dynamic?))))))) + (let ([wr* wrapped-obj] + [pb* (send this pos-blame*)] + [nb* (send this neg-blame*)] + [sr* (send this src*)] + [cc* (send this cc-marks*)]) + (,(if from-dynamic? + (dynamic-access-body set-call + `(lambda (new-val) + (define set-field null) + (set-field wr* (quote ,(build-identifier name)) new-val))) + set-call) + ,(convert-value (if (not from-dynamic?) + (assert-value 'new-val (field-type field) #t 'field name) + 'new-val) (field-type field) from-dynamic?)))))))) fields))) ;generate-wrapper-methods: (list method-record) boolean boolean -> (list sexp) @@ -944,26 +950,40 @@ `(void)) (from-dynamic? `(define/public (,(build-identifier define-name) ,@list-of-args) - ,(convert-value (assert-value `(send wrapped-obj ,(build-identifier call-name) - ,@(map (lambda (arg type) - (convert-value (assert-value arg type #f) type #f)) - list-of-args (method-record-atypes method))) - (method-record-rtype method) from-dynamic? 'method-ret (method-record-name method)) - (method-record-rtype method) - from-dynamic?))) + (let ([wr* wrapped-obj] + [pb* (send this pos-blame*)] + [nb* (send this neg-blame*)] + [sr* (send this src*)] + [cc* (send this cc-marks*)]) + ,(convert-value + (assert-value + `(send wr* ,(build-identifier call-name) + ,@(map (lambda (arg type) + (convert-value (assert-value arg type #f) type #f)) + list-of-args (method-record-atypes method))) + (method-record-rtype method) from-dynamic? + 'method-ret (method-record-name method)) + (method-record-rtype method) + from-dynamic?)))) (else `(define/public (,(build-identifier define-name) . args) - (unless (= (length args) ,(length list-of-args)) - (raise (make-exn:fail:contract:arity - (format "~a broke the contract with ~a here, method ~a of ~a called with ~a args, instead of ~a" - neg-blame pos-blame ,(method-record-name method) ,(class-name) (length args) ,(length list-of-args)) - cc-marks))) - (let (,@(map (lambda (arg type ref) - `(,arg ,(convert-value (assert-value `(list-ref args ,ref) type #t 'method-arg (method-record-name method)) type #t))) - list-of-args (method-record-atypes method) (list-from 0 (length list-of-args)))) - ,(convert-value `(send wrapped-obj ,(build-identifier call-name) - ,@list-of-args) (method-record-rtype method) #f))))))) - methods)) + (let ([wr* wrapped-obj] + [pb* (send this pos-blame*)] + [nb* (send this neg-blame*)] + [sr* (send this src*)] + [cc* (send this cc-marks*)]) + (unless (= (length args) ,(length list-of-args)) + (raise + (make-exn:fail:contract:arity + (format "~a broke the contract with ~a here, method ~a of ~a called with ~a args, instead of ~a" + nb* pb* ,(method-record-name method) ,(class-name) (length args) ,(length list-of-args)) + cc*))) + (let (,@(map (lambda (arg type ref) + `(,arg ,(convert-value (assert-value `(list-ref args ,ref) type #t 'method-arg (method-record-name method)) type #t))) + list-of-args (method-record-atypes method) (list-from 0 (length list-of-args)))) + ,(convert-value `(send wr* ,(build-identifier call-name) + ,@list-of-args) (method-record-rtype method) #f)))))))) + methods)) (define (list-from from to) (cond @@ -1000,8 +1020,8 @@ ((dynamic-val? type) value) ((array-type? type) value #;(if from-dynamic? - `(wrap-convert-assert-array ,value pos-blame neg-blame src* cc-marks) - `(make-object guard-convert-array ,value pos-blame neg-blame src* cc-marks))) + `(wrap-convert-assert-array ,value pb* nb* sr* cc*) + `(make-object guard-convert-array ,value pb* nb* sr* cc*))) ((ref-type? type) (cond ((and (equal? string-type type) from-dynamic?) `(make-java-string ,value)) @@ -1011,9 +1031,9 @@ (make-ref-type "PrintStream" '("java" "io")) (make-ref-type "PrintWriter" '("java" "io")))) value) (from-dynamic? `(,(build-identifier (string-append "wrap-convert-assert-" (ref-type-class/iface type))) - ,value pos-blame neg-blame src* cc-marks)) + ,value pb* nb* sr* cc*)) (else `(make-object ,(build-identifier (string-append "guard-convert-" (ref-type-class/iface type))) - ,value pos-blame neg-blame src* cc-marks)))) + ,value pb* nb* sr* cc*)))) (else value))) ;assert-value: sexp type boolean -> sexp @@ -1025,21 +1045,22 @@ (lambda (ok?) `(let ((v-1 ,value)) (if (,ok? v-1) v-1 - (raise (make-exn:fail - ,(case kind - ((unspecified) - `(format "~a broke the contract with ~a here, type-mismatch expected ~a given ~a" - neg-blame pos-blame (quote ,type) v-1)) - ((field) - `(format "~a broke the contract with ~a here, type-mismatch for field ~a of class ~a: expected ~a given ~a" - neg-blame pos-blame ,name ,(class-name) (quote ,type) v-1)) - ((method-arg) - `(format "~a broke the contract with ~a here, type-mismatch for method argument of ~a in class ~a: expected ~a given ~a" - neg-blame pos-blame ,name ,(class-name) (quote ,type) v-1)) - ((method-ret) - `(format "~a broke the contract with ~a here, type-mismatch for method return of ~a in ~a: expected ~a given ~a" - neg-blame pos-blame ,name ,(class-name) (quote ,type) v-1))) - cc-marks))))))) + (raise + (make-exn:fail + ,(case kind + ((unspecified) + `(format "~a broke the contract with ~a here, type-mismatch expected ~a given ~a" + nb* pb* (quote ,type) v-1)) + ((field) + `(format "~a broke the contract with ~a here, type-mismatch for field ~a of class ~a: expected ~a given ~a" + nb* pb* ,name ,(class-name) (quote ,type) v-1)) + ((method-arg) + `(format "~a broke the contract with ~a here, type-mismatch for method argument of ~a in class ~a: expected ~a given ~a" + nb* pb* ,name ,(class-name) (quote ,type) v-1)) + ((method-ret) + `(format "~a broke the contract with ~a here, type-mismatch for method return of ~a in ~a: expected ~a given ~a" + nb* pb* ,name ,(class-name) (quote ,type) v-1))) + cc*))))))) (case type ((int byte short long) (check 'integer?)) ((float double) (check 'real?)) diff --git a/collects/profj/tool.ss b/collects/profj/tool.ss index 0296c73ab7..f9feeaf3fa 100644 --- a/collects/profj/tool.ss +++ b/collects/profj/tool.ss @@ -691,7 +691,8 @@ (else (let-values (((name syn) (get-module-name (expand (car mods))))) (set! name-to-require name) - (syntax-as-top (old-current-eval syn)) + (syntax-as-top (eval (compile syn)) + #;(old-current-eval (compile syn))) (loop (cdr mods) extras #t))))))))) ((parse-java-interactions ex loc) (let ((exp (syntax-object->datum (syntax ex))))