suzanne.soy/racket
1
0
Fork 0
Code Issues Pull Requests Actions Packages Projects Releases Wiki Activity

Various bug fixes, expansion speed improvements

Browse Source 
svn: r6837
This commit is contained in:
Kathy Gray 2007-07-07 15:31:57 +00:00
parent c29edcc918
commit 2894bc1e54
7 changed files with 292 additions and 224 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

4
collects/profj/comb-parsers/java-signatures.scm
View File

@ -67,9 +67,7 @@
(define-signature java-ops^ (math-ops shift-ops compare-ops bool-ops bit-ops assignment-ops (define-signature java-ops^ (math-ops shift-ops compare-ops bool-ops bit-ops assignment-ops
bin-ops un-assignment un-op)) bin-ops un-assignment un-op))
;Expression signatures ;Expression signatures
(define-signature expression-maker^ (simple-expression))
(define-signature expr-lits^ (boolean-lits textual-lits prim-numeric-lits null-lit numeric-lits (define-signature expr-lits^ (boolean-lits textual-lits prim-numeric-lits null-lit numeric-lits
double-lits literals all-literals)) double-lits literals all-literals))

198
collects/profj/comb-parsers/parser-units.scm
View File

@ -307,7 +307,7 @@
java-literals^ java-expression-keywords^ java-vals^ java-ids^ java-literals^ java-expression-keywords^ java-vals^ java-ids^
java-variables^ java-separators^ java-variables^ java-separators^
java-operators^ java-extras^ language-forms^) 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) (define (simple-expression exprs)
(choice exprs "expression")) (choice exprs "expression"))
@ -409,65 +409,65 @@
) )
(define-unit statements@ (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^) java-statement-keywords^ java-separators^ java-ids^ java-operators^)
(export statements^) (export statements^)
(define (if-s expr statement else?) (define (if-s stmt else?)
(cond (cond
[else? [else?
(choose ((sequence (ifT O_PAREN expr C_PAREN statement elseT statement) id) (choose ((sequence (ifT O_PAREN expression C_PAREN stmt elseT stmt) id)
(sequence (ifT O_PAREN expr C_PAREN statement) id)) "if")] (sequence (ifT O_PAREN expression C_PAREN stmt) id)) "if")]
[else (sequence (ifT O_PAREN expr C_PAREN statement elseT statement) 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 (cond
[opt? (choose ((sequence (return expr SEMI_COLON) id) [opt? (choose ((sequence (return expression SEMI_COLON) id)
(sequence (return SEMI_COLON) id)) "return statement")] (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) (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) (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) (define (block repeat?)
(sequence (O_BRACE statement C_BRACE) id "block statement")) (sequence (O_BRACE (if repeat? (repeat (eta statement)) (eta statement)) C_BRACE)
id "block statement"))
(define (expression-stmt expr) (define expression-stmt
(sequence (expr SEMI_COLON) id "statement")) (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) (define (do-while stmt)
(sequence (while O_PAREN expr C_PAREN statement) id "while loop")) (sequence (doT stmt while O_PAREN expression C_PAREN SEMI_COLON) id "do loop"))
(define (do-while expr statement) (define (for-l init i-op? t-op? update up-op? statement)
(sequence (doT statement while O_PAREN expr C_PAREN SEMI_COLON) id "do loop")) (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")]
(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")]
[no-tst (sequence (for O_PAREN init SEMI_COLON 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-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")] [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")]) [none (sequence (for O_PAREN SEMI_COLON SEMI_COLON C_PAREN statement) id "for loop")])
(cond (cond
[(and i-op? t-op? up-op?) [(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?) [(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?) [(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?) [(and i-op? up-op?)
(choice (list full no-init no-up no-iu) "for loop")] (choose (full no-init no-up no-iu) "for loop")]
[i-op? (choice (list full no-init) "for loop")] [i-op? (choose (full no-init) "for loop")]
[t-op? (choice (list full no-tst) "for loop")] [t-op? (choose (full no-tst) "for loop")]
[up-op? (choice (list full no-up) "for loop")] [up-op? (choose (full no-up) "for loop")]
[else full]))) [else full])))
(define (break-s label) (define (break-s label)
@ -629,7 +629,7 @@
(import combinator-parser^ java-operators^ java-separators^ (import combinator-parser^ java-operators^ java-separators^
java-statement-keywords^ java-type-keywords^ java-ids^ java-statement-keywords^ java-type-keywords^ java-ids^
java-types^ java-access^ java-ops^ general-productions^ java-variables^ 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^) fields^ methods^ ctors^ interfaces^ classes^ top-forms^ id^)
(export language-forms^) (export language-forms^)
@ -655,8 +655,7 @@
(sequence (unique-base (repeat unique-end)) id "expression")) (sequence (unique-base (repeat unique-end)) id "expression"))
(define statement (define statement
(make-statement (list (if-s expression (eta statement) #f) (choose ((if-s (block #f) #f) (return-s #f)) "statement"))
(return-s expression #f))))
(define field (make-field #f (value+name-type prim-type) expression #f)) (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^) (import combinator-parser^ java-operators^ java-separators^ (prefix tok: java-definition-keywords^)
java-statement-keywords^ java-type-keywords^ java-ids^ java-statement-keywords^ java-type-keywords^ java-ids^
java-types^ java-access^ java-ops^ general-productions^ java-variables^ 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^) fields^ methods^ ctors^ interfaces^ classes^ top-forms^ id^)
(export language-forms^) (export language-forms^)
@ -720,12 +719,11 @@
EQUAL)) "expression")) EQUAL)) "expression"))
(define statement (define statement
(make-statement (choose ((if-s (block #t) #f)
(list (if-s expression (eta statement) #f) (return-s #t)
(return-s expression #t) (variable-declaration (value+name-type prim-type) expression #f "local variable")
(variable-declaration (value+name-type prim-type) expression #f "local variable") (block #t)
(block (repeat (eta statement))) (sequence (stmt-expr SEMI_COLON) id)) "statement"))
(sequence (stmt-expr SEMI_COLON) id "statement"))))
(define field (make-field #f (value+name-type prim-type) expression #t)) (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^) (import combinator-parser^ java-operators^ java-separators^ (prefix tok: java-definition-keywords^)
java-statement-keywords^ java-type-keywords^ java-ids^ java-statement-keywords^ java-type-keywords^ java-ids^
java-types^ java-access^ java-ops^ general-productions^ java-variables^ 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^) fields^ methods^ ctors^ interfaces^ classes^ top-forms^ id^)
(export language-forms^) (export language-forms^)
@ -803,12 +801,11 @@
EQUAL)) "expression")) EQUAL)) "expression"))
(define statement (define statement
(make-statement (choose ((if-s (block #t) #f)
(list (if-s expression (eta statement) #f) (return-s #t)
(return-s expression #t) (variable-declaration (value+name-type prim-type) expression #f "local variable")
(variable-declaration (value+name-type prim-type) expression #f "local variable") (block #t)
(block (repeat (eta statement))) (sequence (stmt-expr SEMI_COLON) id)) "statement"))
(sequence (stmt-expr SEMI_COLON) id "statement"))))
(define field (make-field access-mods (value+name-type prim-type) expression #t)) (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^) (import combinator-parser^ java-operators^ java-separators^ (prefix tok: java-definition-keywords^)
java-statement-keywords^ java-type-keywords^ java-ids^ java-statement-keywords^ java-type-keywords^ java-ids^
java-types^ java-access^ java-ops^ general-productions^ java-variables^ 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^) fields^ methods^ ctors^ interfaces^ classes^ top-forms^ id^)
(export language-forms^) (export language-forms^)
(define unique-base (define unique-base
(simple-expression (choose
(list (literals (list null-lit boolean-lits textual-lits prim-numeric-lits double-lits)) ((literals (list null-lit boolean-lits textual-lits prim-numeric-lits double-lits))
this this
IDENTIFIER IDENTIFIER
new-class new-class
(simple-method-call (eta expression)) simple-method-call
(new-array (value+name-type prim-type) (eta expression)) (new-array (value+name-type prim-type))
(sequence (O_PAREN (eta expression) C_PAREN) id "expression") (sequence (O_PAREN (eta expression) C_PAREN) id)
(sequence (! (eta expression)) id "conditional expression") (sequence (! (eta expression)) id "conditional expression")
(sequence (MINUS (eta expression)) id "negation exxpression") (sequence (MINUS (eta expression)) id "negation exxpression")
(cast (value+name-type prim-type) (eta expression)) (cast (value+name-type prim-type))
(super-call (eta expression)) super-call
(checks (eta expression))))) checks) "expression"))
(define unique-end (define unique-end
(simple-expression (choose (field-access-end
(list field-access-end array-access-end
(array-access-end (eta expression)) method-call-end
(method-call-end (eta expression)) if-expr-end
(if-expr-end (eta expression)) (binary-expression-end (bin-ops (list math-ops compare-ops bool-ops bit-ops)))
(binary-expression-end (bin-ops (list math-ops compare-ops bool-ops bit-ops)) instanceof-back)
(eta expression)) "expression"))
instanceof-back)))
(define expression (define expression
(sequence (unique-base (repeat unique-end)) id "expression")) (sequence (unique-base (repeat unique-end)) id "expression"))
(define stmt-expr (define stmt-expr
(simple-expression (list new-class (choose (new-class
(super-call expression) super-call
(sequence (expression (sequence (expression method-call-end expression) id "method call")
(method-call-end expression)) id "method call") (assignment
(assignment (choose (identifier
(choose (identifier (sequence (expression field-access-end) id)
(sequence (expression field-access-end) id) (sequence (expression array-access-end) id))
(sequence (expression (array-access-end expression)) id)) "asignee")
"asignee") assignment-ops expression)
assignment-ops expression) (sequence (expression ++) id "unary mutation")
(sequence (expression ++) id "unary mutation") (sequence (expression --) id "unary mutation")
(sequence (expression --) id "unary mutation") (sequence (++ expression) id "unary mutation")
(sequence (++ expression) id "unary mutation") (sequence (-- expression) id "unary mutation")) "expression"))
(sequence (-- expression) id "unary mutation"))))
(define statement (define statement
(make-statement (list (if-s expression (eta statement) #t) (choose ((if-s #t (eta statement))
(return-s expression #t) (return-s #t)
(variable-declaration (value+name-type prim-type) expression #t "local variable") (variable-declaration (value+name-type prim-type) expression #t "local variable")
(block (repeat (eta statement))) (block #t)
(sequence (stmt-expr SEMI_COLON) id "statement") (sequence (stmt-expr SEMI_COLON) id)
(for-l (choose ((variable-declaration (value+name-type prim-type) expression #t "for loop variable") (for-l (choose ((variable-declaration (value+name-type prim-type) expression #t "for loop variable")
(comma-sep stmt-expr "initializations")) "for loop initialization") (comma-sep stmt-expr "initializations")) "for loop initialization")
#t #t #t
expression #t (comma-sep stmt-expr "for loop increments") #t (block #t))
(comma-sep stmt-expr "for loop increments") #t (eta statement)) (while-l (block #t))
(while-l expression (eta statement)) (do-while (block #t))
(do-while expression (eta statement)) (break-s #f)
(break-s #f) (cont-s #f)) "statement"))
(cont-s #f))))
(define field (make-field (global-mods access-mods) (value+name-type prim-type) expression #t)) (define field (make-field (global-mods access-mods) (value+name-type prim-type) expression #t))

8
collects/profj/compile.ss
View File

@ -46,7 +46,9 @@
(equal? (version) (call-with-input-file compiled-path get-version)) (equal? (version) (call-with-input-file compiled-path get-version))
(read-record type-path) (read-record type-path)
(> (file-or-directory-modify-seconds 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"))))
(call-with-input-file name (lambda (port) (compile-to-file port name level))))))) (call-with-input-file name (lambda (port) (compile-to-file port name level)))))))
((eq? dest 'file) ((eq? dest 'file)
(compile-to-file port loc level)) (compile-to-file port loc level))
@ -56,7 +58,9 @@
(type-path (build-path path-base "compiled" (path-replace-suffix file ".jinfo")))) (type-path (build-path path-base "compiled" (path-replace-suffix file ".jinfo"))))
(unless (or (and (file-exists? compiled-path) (unless (or (and (file-exists? compiled-path)
(> (file-or-directory-modify-seconds 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) (and (file-exists? type-path)
(read-record type-path))) (read-record type-path)))
(call-with-input-file (call-with-input-file

154
collects/profj/libs/java/lang/Object-composite.ss
View File

@ -130,14 +130,12 @@
(define convert-assert-Object (define convert-assert-Object
(class* object% (wrapper) (class* object% (wrapper)
(init w p n s c) (init w)
(define-values (wrapped pos-blame neg-blame src cc-marks) (values null null null null null)) (init-field pos-blame neg-blame src cc-marks)
(define wrapped null)
(set! wrapped w) (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 (get-wrapped) wrapped)
(define/public (compare obj1 obj2) (define/public (compare obj1 obj2)
(cond (cond
@ -197,21 +195,31 @@
(define/public (field-names) (send wrapped field-names)) (define/public (field-names) (send wrapped field-names))
(define/public (field-values) (send wrapped field-values)) (define/public (field-values) (send wrapped field-values))
(define/public (fields-for-display) (send wrapped fields-for-display)) (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 ()))) (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 (define dynamic-Object/c
(c:flat-named-contract "Object" (lambda (v) (is-a? v convert-assert-Object)))) (c:flat-named-contract "Object" (lambda (v) (is-a? v convert-assert-Object))))
(define guard-convert-Object (define guard-convert-Object
(class* object% (wrapper) (class* object% (wrapper)
(init w p n s c) (init w)
(define-values (wrapped pos-blame neg-blame src cc-marks) (values null null null null null)) (init-field pos-blame neg-blame src cc-marks)
(define wrapped null)
(set! wrapped w) (set! wrapped w)
(set! pos-blame p)
(set! neg-blame n)
(set! src s)
(set! cc-marks s)
(define/public (get-wrapped) wrapped) (define/public (get-wrapped) wrapped)
@ -294,8 +302,21 @@
(define/public (field-names) (send wrapped field-names)) (define/public (field-names) (send wrapped field-names))
(define/public (field-values) (send wrapped field-values)) (define/public (field-values) (send wrapped field-values))
(define/public (fields-for-display) (send wrapped fields-for-display)) (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 ()))) (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 (define static-Object/c
(c:flat-named-contract "Object" (lambda (v) (is-a? v guard-convert-Object)))) (c:flat-named-contract "Object" (lambda (v) (is-a? v guard-convert-Object))))
@ -1028,38 +1049,51 @@
(init w p n s c) (init w p n s c)
(super-instantiate (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! 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 (set-exception! exn) (send wrapped set-exception! exn))
(define/public (get-mzscheme-exception) (send wrapped get-mzscheme-exception)) (define/public (get-mzscheme-exception) (send wrapped get-mzscheme-exception))
(define/public (initCause-java.lang.Throwable cse) (define/public (initCause-java.lang.Throwable cse)
(wrap-convert-assert-Throwable (let ([pb (send this pos-blame*)]
(send wrapped initCause-java.lang.Throwable (make-object guard-convert-Throwable cse [nb (send this neg-blame*)]
pos-blame neg-blame src cc-marks) [sr (send this src*)]
pos-blame neg-blame src cc-marks))) [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) (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) (if (string? val)
(make-java-string val) (make-java-string val)
(raise (make-exn:fail (raise
(format "~a broke ~a contract here; Throwable's getMessage expects string return, given ~a" (make-exn:fail
pos-blame neg-blame val) (format "~a broke ~a contract here; Throwable's getMessage expects string return, given ~a"
cc-marks))))) pb nb val)
(define/public (getCause) cc)))))
(wrap-convert-assert-Throwable (send wrapped getCause))) (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) (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) (if (string? val)
(make-java-string val) (make-java-string val)
(raise (make-exn:fail (raise (make-exn:fail
(format "~a broke ~a contract here; Throwable's getLocalizedMessage expects string return, given ~a" (format "~a broke ~a contract here; Throwable's getLocalizedMessage expects string return, given ~a"
pos-blame neg-blame val) pb nb val)
cc-marks))))) cc)))))
(define/public (setStackTrace-java.lang.StackTraceElement1 elements) (define/public (setStackTrace-java.lang.StackTraceElement1 elements)
(send wrapped setStackTrace-java.lang.StackTraceElement1 elements)) (send wrapped setStackTrace-java.lang.StackTraceElement1 elements))
(define/public (getStackTrace) (send wrapped getStackTrace)) (define/public (getStackTrace) (send wrapped getStackTrace))
@ -1077,37 +1111,53 @@
(init w p n s c) (init w p n s c)
(super-instantiate (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! 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 (set-exception! exn) (send wrapped set-exception! exn))
(define/public (get-mzscheme-exception) (send wrapped get-mzscheme-exception)) (define/public (get-mzscheme-exception) (send wrapped get-mzscheme-exception))
(define/public (initCause-java.lang.Throwable . cse) (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)) (unless (= 1 (length cse))
(raise (make-exn:fail:contract:arity (raise (make-exn:fail:contract:arity
(format "~a broke ~a contract here: Throwable's initCause expects to be called with 1 argument, given ~n" (format "~a broke ~a contract here: Throwable's initCause expects to be called with 1 argument, given ~n"
pos-blame neg-blame (length cse)) pb nb (length cse))
cc-marks))) cc)))
(make-object guard-convert-Throwable (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) (define/public (init-cause . cse)
(unless (= 1 (length cse)) (let ([pb (send this pos-blame*)]
(raise (make-exn:fail:contract:arity [nb (send this neg-blame*)]
(format "~a broke ~a contract here: Throwable's initCause expects to be called with 1 argument, given ~n" [sr (send this src*)]
pos-blame neg-blame (length cse)) [cc (send this cc-marks*)])
cc-marks))) (unless (= 1 (length cse))
(make-object guard-convert-Throwable (raise (make-exn:fail:contract:arity
(send wrapped initCause-java.lang.Throwable (wrap-convert-assert-Throwable (car cse) pos-blame neg-blame src cc-marks)) (format "~a broke ~a contract here: Throwable's initCause expects to be called with 1 argument, given ~n"
pos-blame neg-blame src cc-marks)) 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 (getMessage) (send (send wrapped getMessage) get-mzscheme-string))
(define/public (get-message) (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 (getCause)
(define/public (get-cause) (make-object guard-convert-Throwable (let ([pb (send this pos-blame*)]
(send wrapped getCause) pos-blame neg-blame src cc-marks)) [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 (getLocalizedMessage) (send (send wrapped getLocalizedMessage) get-mzscheme-string))
(define/public (get-localized-message) (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) (define/public (setStackTrace-java.lang.StackTraceElement1 elements)

8
collects/profj/parsers/beginner-parser.ss
View File

@ -311,12 +311,12 @@
[(ReturnStatement) $1]) [(ReturnStatement) $1])
(IfThenElseStatement (IfThenElseStatement
[(if O_PAREN Expression C_PAREN StatementNoShortIf else Statement) [(if O_PAREN Expression C_PAREN O_BRACE StatementNoShortIf C_BRACE else O_BRACE Statement C_BRACE)
(make-ifS $3 $5 $7 (build-src 1) (build-src 7))]) (make-ifS $3 $6 $10 (build-src 1) (build-src 11))])
(IfThenElseStatementNoShortIf (IfThenElseStatementNoShortIf
[(if O_PAREN Expression C_PAREN StatementNoShortIf else StatementNoShortIf) [(if O_PAREN Expression C_PAREN O_BRACE StatementNoShortIf C_BRACE else O_BRACE StatementNoShortIf C_BRACE)
(make-ifS $3 $5 $7 (build-src 1) (build-src 7))]) (make-ifS $3 $6 $10 (build-src 1) (build-src 11))])
(ReturnStatement (ReturnStatement
[(return Expression SEMI_COLON) (make-return $2 #f #t (build-src 3))]) [(return Expression SEMI_COLON) (make-return $2 #f #t (build-src 3))])

141
collects/profj/to-scheme.ss
View File

@ -861,12 +861,8 @@
`(define ,name `(define ,name
(class ,super-name (class ,super-name
(init w* p* n* s* c*) (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! 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*)) (super-instantiate (w* p* n* s* c*))
,@(generate-wrapper-fields fields from-dynamic?) ,@(generate-wrapper-fields fields from-dynamic?)
@ -901,34 +897,44 @@
(let* ((name (id-string (field-name field))) (let* ((name (id-string (field-name field)))
(dynamic-access-body (dynamic-access-body
(lambda (guard-body scheme-body) (lambda (guard-body scheme-body)
`(if (is-a? wrapped-obj guard-convert-Object) `(if (is-a? wr* guard-convert-Object)
,guard-body ,guard-body
,scheme-body))) ,scheme-body)))
(get-name (create-get-name name)) (get-name (create-get-name name))
(set-name (create-set-name name)) (set-name (create-set-name name))
(get-call `(,get-name wrapped-obj)) (get-call `(,get-name wr*))
(set-call `(lambda (new-val) (,set-name wrapped-obj new-val)))) (set-call `(lambda (new-val) (,set-name wr* new-val))))
(list (list
`(define/public (,(build-identifier (format "~a-wrapped" get-name))) `(define/public (,(build-identifier (format "~a-wrapped" get-name)))
,(convert-value (let ([wr* wrapped-obj]
(if from-dynamic? [pb* (send this pos-blame*)]
(assert-value [nb* (send this neg-blame*)]
(dynamic-access-body get-call `(get-field wrapped-obj (quote ,(build-identifier name)))) [sr* (send this src*)]
(field-type field) #t 'field name) [cc* (send this cc-marks*)])
get-call) (field-type field) from-dynamic?)) ,(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)) (if (memq 'final (field-modifiers field))
null null
`(define/public (,(build-identifier (format "~a-wrapped" set-name)) new-val) `(define/public (,(build-identifier (format "~a-wrapped" set-name)) new-val)
(,(if from-dynamic? (let ([wr* wrapped-obj]
(dynamic-access-body set-call [pb* (send this pos-blame*)]
`(lambda (new-val) [nb* (send this neg-blame*)]
(define set-field null) [sr* (send this src*)]
(set-field wrapped-obj (quote ,(build-identifier name)) new-val))) [cc* (send this cc-marks*)])
set-call) (,(if from-dynamic?
,(convert-value (if (not from-dynamic?) (dynamic-access-body set-call
(assert-value 'new-val (field-type field) #t 'field name) `(lambda (new-val)
'new-val) (field-type field) from-dynamic?))))))) (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))) fields)))
;generate-wrapper-methods: (list method-record) boolean boolean -> (list sexp) ;generate-wrapper-methods: (list method-record) boolean boolean -> (list sexp)
@ -944,26 +950,40 @@
`(void)) `(void))
(from-dynamic? (from-dynamic?
`(define/public (,(build-identifier define-name) ,@list-of-args) `(define/public (,(build-identifier define-name) ,@list-of-args)
,(convert-value (assert-value `(send wrapped-obj ,(build-identifier call-name) (let ([wr* wrapped-obj]
,@(map (lambda (arg type) [pb* (send this pos-blame*)]
(convert-value (assert-value arg type #f) type #f)) [nb* (send this neg-blame*)]
list-of-args (method-record-atypes method))) [sr* (send this src*)]
(method-record-rtype method) from-dynamic? 'method-ret (method-record-name method)) [cc* (send this cc-marks*)])
(method-record-rtype method) ,(convert-value
from-dynamic?))) (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 (else
`(define/public (,(build-identifier define-name) . args) `(define/public (,(build-identifier define-name) . args)
(unless (= (length args) ,(length list-of-args)) (let ([wr* wrapped-obj]
(raise (make-exn:fail:contract:arity [pb* (send this pos-blame*)]
(format "~a broke the contract with ~a here, method ~a of ~a called with ~a args, instead of ~a" [nb* (send this neg-blame*)]
neg-blame pos-blame ,(method-record-name method) ,(class-name) (length args) ,(length list-of-args)) [sr* (send this src*)]
cc-marks))) [cc* (send this cc-marks*)])
(let (,@(map (lambda (arg type ref) (unless (= (length args) ,(length list-of-args))
`(,arg ,(convert-value (assert-value `(list-ref args ,ref) type #t 'method-arg (method-record-name method)) type #t))) (raise
list-of-args (method-record-atypes method) (list-from 0 (length list-of-args)))) (make-exn:fail:contract:arity
,(convert-value `(send wrapped-obj ,(build-identifier call-name) (format "~a broke the contract with ~a here, method ~a of ~a called with ~a args, instead of ~a"
,@list-of-args) (method-record-rtype method) #f))))))) nb* pb* ,(method-record-name method) ,(class-name) (length args) ,(length list-of-args))
methods)) 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) (define (list-from from to)
(cond (cond
@ -1000,8 +1020,8 @@
((dynamic-val? type) value) ((dynamic-val? type) value)
((array-type? type) value ((array-type? type) value
#;(if from-dynamic? #;(if from-dynamic?
`(wrap-convert-assert-array ,value pos-blame neg-blame src* cc-marks) `(wrap-convert-assert-array ,value pb* nb* sr* cc*)
`(make-object guard-convert-array ,value pos-blame neg-blame src* cc-marks))) `(make-object guard-convert-array ,value pb* nb* sr* cc*)))
((ref-type? type) ((ref-type? type)
(cond (cond
((and (equal? string-type type) from-dynamic?) `(make-java-string ,value)) ((and (equal? string-type type) from-dynamic?) `(make-java-string ,value))
@ -1011,9 +1031,9 @@
(make-ref-type "PrintStream" '("java" "io")) (make-ref-type "PrintStream" '("java" "io"))
(make-ref-type "PrintWriter" '("java" "io")))) value) (make-ref-type "PrintWriter" '("java" "io")))) value)
(from-dynamic? `(,(build-identifier (string-append "wrap-convert-assert-" (ref-type-class/iface type))) (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))) (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))) (else value)))
;assert-value: sexp type boolean -> sexp ;assert-value: sexp type boolean -> sexp
@ -1025,21 +1045,22 @@
(lambda (ok?) (lambda (ok?)
`(let ((v-1 ,value)) `(let ((v-1 ,value))
(if (,ok? v-1) v-1 (if (,ok? v-1) v-1
(raise (make-exn:fail (raise
,(case kind (make-exn:fail
((unspecified) ,(case kind
`(format "~a broke the contract with ~a here, type-mismatch expected ~a given ~a" ((unspecified)
neg-blame pos-blame (quote ,type) v-1)) `(format "~a broke the contract with ~a here, type-mismatch expected ~a given ~a"
((field) nb* pb* (quote ,type) v-1))
`(format "~a broke the contract with ~a here, type-mismatch for field ~a of class ~a: expected ~a given ~a" ((field)
neg-blame pos-blame ,name ,(class-name) (quote ,type) v-1)) `(format "~a broke the contract with ~a here, type-mismatch for field ~a of class ~a: expected ~a given ~a"
((method-arg) nb* pb* ,name ,(class-name) (quote ,type) v-1))
`(format "~a broke the contract with ~a here, type-mismatch for method argument of ~a in class ~a: expected ~a given ~a" ((method-arg)
neg-blame pos-blame ,name ,(class-name) (quote ,type) v-1)) `(format "~a broke the contract with ~a here, type-mismatch for method argument of ~a in class ~a: expected ~a given ~a"
((method-ret) nb* pb* ,name ,(class-name) (quote ,type) v-1))
`(format "~a broke the contract with ~a here, type-mismatch for method return of ~a in ~a: expected ~a given ~a" ((method-ret)
neg-blame pos-blame ,name ,(class-name) (quote ,type) v-1))) `(format "~a broke the contract with ~a here, type-mismatch for method return of ~a in ~a: expected ~a given ~a"
cc-marks))))))) nb* pb* ,name ,(class-name) (quote ,type) v-1)))
cc*)))))))
(case type (case type
((int byte short long) (check 'integer?)) ((int byte short long) (check 'integer?))
((float double) (check 'real?)) ((float double) (check 'real?))

3
collects/profj/tool.ss
View File

@ -691,7 +691,8 @@
(else (else
(let-values (((name syn) (get-module-name (expand (car mods))))) (let-values (((name syn) (get-module-name (expand (car mods)))))
(set! name-to-require name) (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))))))))) (loop (cdr mods) extras #t)))))))))
((parse-java-interactions ex loc) ((parse-java-interactions ex loc)
(let ((exp (syntax-object->datum (syntax ex)))) (let ((exp (syntax-object->datum (syntax ex))))