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
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))

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

@ -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))

8
collects/profj/compile.ss
View File

@ -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

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

@ -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)

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

@ -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))])

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

@ -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?))

3
collects/profj/tool.ss
View File

@ -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))))