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

Assorted bug fixes

Browse Source 
svn: r11142
This commit is contained in:
Kathy Gray 2008-08-08 10:58:17 +00:00
parent 78689061f5
commit 14484e2ba6
6 changed files with 130 additions and 114 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

13
collects/combinator-parser/private-combinator/errors.scm
View File

@ -24,7 +24,7 @@
(list? (car (fail-type-src fail-type)))) (list? (car (fail-type-src fail-type))))
(car (fail-type-src fail-type)) (car (fail-type-src fail-type))
(fail-type-src fail-type))))]) (fail-type-src fail-type))))])
#;(printf "fail-type->message ~a~n" fail-type) (printf "fail-type->message ~a~n" fail-type)
(cond (cond
[(terminal-fail? fail-type) [(terminal-fail? fail-type)
(collapse-message (collapse-message
@ -233,16 +233,17 @@
(narrow-opts chance-may-use chance-used-winners)] (narrow-opts chance-may-use chance-used-winners)]
[winners (narrow-opts chance chance-may-winners)]) [winners (narrow-opts chance chance-may-winners)])
#;(printf "all options: ~a~n" opts-list) (printf "all options: ~a~n" opts-list)
#;(printf "~a ~a ~a ~a ~n" (printf "~a ~a ~a ~a ~a~n"
(map fail-type-name opts-list) (map fail-type-name opts-list)
(map fail-type-chance opts-list) (map fail-type-chance opts-list)
(map fail-type-used opts-list) (map fail-type-used opts-list)
(map fail-type-may-use opts-list)) (map fail-type-may-use opts-list)
#;(printf "composite round: ~a ~a ~n" (map composite opts-list))
(printf "composite round: ~a ~a ~n"
(map fail-type-name composite-winners) (map fail-type-name composite-winners)
(map composite composite-winners)) (map composite composite-winners))
#;(printf "final sorting: ~a~n" (map fail-type-name winners)) (printf "final sorting: ~a~n" (map fail-type-name winners))
winners)) winners))
(define (first-n n lst) (define (first-n n lst)

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

@ -710,6 +710,17 @@
super-call super-call
checks) "expression")) checks) "expression"))
(define assignee-base
(choose (this
identifier
new-class
simple-method-call
(sequence (O_PAREN (eta expression) C_PAREN) id "parened expression")
(sequence (! (eta expression)) id "conditional expression")
(sequence (MINUS (eta expression)) id "negation expression")
(cast (value+name-type prim-type))
super-call) "assignee"))
(define unique-end (define unique-end
(choose (field-access-end (choose (field-access-end
method-call-end method-call-end
@ -726,7 +737,7 @@
(sequence (unique-base (repeat unique-end) method-call-end) id "method call") (sequence (unique-base (repeat unique-end) method-call-end) id "method call")
(assignment (assignment
(choose (identifier (choose (identifier
(sequence (unique-base (repeat unique-end) field-access-end) id)) (sequence (assignee-base (repeat unique-end) field-access-end) id))
"assignee") "assignee")
EQUAL)) "expression")) EQUAL)) "expression"))

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

@ -445,7 +445,7 @@
[(LeftHandSide AssignmentOperator #;CheckExpression IDENTIFIER) [(LeftHandSide AssignmentOperator #;CheckExpression IDENTIFIER)
(make-assignment #f (build-src 3) $1 $2 #;$3 (make-assignment #f (build-src 3) $1 $2 #;$3
(make-access #f (build-src 3 3) (make-access #f (build-src 3 3)
(make-local-access (list
(make-id $3 (build-src 3 3)))) (build-src 2 2))]) (make-id $3 (build-src 3 3)))) (build-src 2 2))])
(LeftHandSide (LeftHandSide

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

@ -498,7 +498,7 @@
(append (accesses-public fields) (accesses-package fields) (append (accesses-public fields) (accesses-package fields)
(accesses-protected fields))) (accesses-protected fields)))
(generate-contract-defs (class-name)))) (generate-contract-defs (class-name))))
(stm-class (generate-stm-class (class-name) #;(stm-class (generate-stm-class (class-name)
(parent-name) (parent-name)
(class-record-methods class-rec) (class-record-methods class-rec)
(class-record-fields class-rec))) (class-record-fields class-rec)))
@ -695,7 +695,7 @@
,@(map ,@(map
(lambda (m) (lambda (m)
`((and (< ,(m-start m) x) (< x ,(m-stop m))) `((and (< ,(m-start m) x) (< x ,(m-stop m)))
(let ((m-list (assq ,(m-name m) srcs))) (let-values (((m-list) (assq ,(m-name m) srcs)))
(unless (null? (car (cdr m-list))) (unless (null? (car (cdr m-list)))
(set-cdr! m-list (list (,remove x (car (cdr m-list))))) (set-cdr! m-list (list (,remove x (car (cdr m-list)))))
(when (null? (car (cdr m-list))) (when (null? (car (cdr m-list)))
@ -712,7 +712,7 @@
(or (assq class-name (list ,@tested-methods-expr-srcs)) (or (assq class-name (list ,@tested-methods-expr-srcs))
(super testedMethodsSrcs-dynamic class-name))) (super testedMethodsSrcs-dynamic class-name)))
#;`(define/override (testCoverage-boolean-int report? src) #;`(define/override (testCoverage-boolean-int report? src)
(let ((class/lookups (list ,@class/lookup-funcs))) (let-values (((class/lookups) (list ,@class/lookup-funcs)))
(if report? (if report?
(append (map (lambda (c) (list (car c) (cadr c))) (append (map (lambda (c) (list (car c) (cadr c)))
class/lookups) class/lookups)
@ -731,7 +731,7 @@
)) ))
,@wrapper-classes ,@wrapper-classes
,@(if (testcase-ext?) (list stm-class) null) #;,@(if (testcase-ext?) (list stm-class) null)
#;,@(create-generic-methods (append (accesses-public methods) #;,@(create-generic-methods (append (accesses-public methods)
(accesses-package methods) (accesses-package methods)
@ -827,7 +827,7 @@
(dynamic-callables (refine-method-list wrapped-methods-initial class-name))) (dynamic-callables (refine-method-list wrapped-methods-initial class-name)))
(list (list
`(define (,(build-identifier (string-append "wrap-convert-assert-" class-name)) obj p n s c) `(define (,(build-identifier (string-append "wrap-convert-assert-" class-name)) obj p n s c)
(let ((raise-error (let-values (((raise-error)
(lambda (method-name num-args) (lambda (method-name num-args)
(raise (make-exn:fail (raise (make-exn:fail
(format "~a broke the contract with ~a here, expected an object with a method ~a accepting ~a args" (format "~a broke the contract with ~a here, expected an object with a method ~a accepting ~a args"
@ -859,11 +859,11 @@
(list (list
`(define/public (,(build-identifier (format "~a-wrapped" get-name))) `(define/public (,(build-identifier (format "~a-wrapped" get-name)))
(let ([wr* wrapped-obj] (let-values ([(wr*) wrapped-obj]
[pb* (send this pos-blame*)] [(pb*) (send this pos-blame*)]
[nb* (send this neg-blame*)] [(nb*) (send this neg-blame*)]
[sr* (send this src*)] [(sr*) (send this src*)]
[cc* (send this cc-marks*)]) [(cc*) (send this cc-marks*)])
,(convert-value ,(convert-value
(if from-dynamic? (if from-dynamic?
(assert-value (assert-value
@ -873,11 +873,11 @@
(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)
(let ([wr* wrapped-obj] (let-values ([(wr*) wrapped-obj]
[pb* (send this pos-blame*)] [(pb*) (send this pos-blame*)]
[nb* (send this neg-blame*)] [(nb*) (send this neg-blame*)]
[sr* (send this src*)] [(sr*) (send this src*)]
[cc* (send this cc-marks*)]) [(cc*) (send this cc-marks*)])
(,(if from-dynamic? (,(if from-dynamic?
(dynamic-access-body set-call (dynamic-access-body set-call
`(lambda (new-val) `(lambda (new-val)
@ -902,11 +902,11 @@
`(void)) `(void))
(from-dynamic? (from-dynamic?
`(define/public (,(build-identifier define-name) ,@list-of-args) `(define/public (,(build-identifier define-name) ,@list-of-args)
(let ([wr* wrapped-obj] (let-values ([(wr*) wrapped-obj]
[pb* (send this pos-blame*)] [(pb*) (send this pos-blame*)]
[nb* (send this neg-blame*)] [(nb*) (send this neg-blame*)]
[sr* (send this src*)] [(sr*) (send this src*)]
[cc* (send this cc-marks*)]) [(cc*) (send this cc-marks*)])
,(convert-value ,(convert-value
(assert-value (assert-value
`(send wr* ,(build-identifier call-name) `(send wr* ,(build-identifier call-name)
@ -919,11 +919,11 @@
from-dynamic?)))) from-dynamic?))))
(else (else
`(define/public (,(build-identifier define-name) . args) `(define/public (,(build-identifier define-name) . args)
(let ([wr* wrapped-obj] (let-values ([(wr*) wrapped-obj]
[pb* (send this pos-blame*)] [(pb*) (send this pos-blame*)]
[nb* (send this neg-blame*)] [(nb*) (send this neg-blame*)]
[sr* (send this src*)] [(sr*) (send this src*)]
[cc* (send this cc-marks*)]) [(cc*) (send this cc-marks*)])
(unless (= (length args) ,(length list-of-args)) (unless (= (length args) ,(length list-of-args))
(raise (raise
(make-exn:fail:contract:arity (make-exn:fail:contract:arity
@ -1096,7 +1096,7 @@
;build-method-table: (list method) (list symbol) -> sexp ;build-method-table: (list method) (list symbol) -> sexp
(define (build-method-table methods generics) (define (build-method-table methods generics)
`(let ((table (make-hasheq))) `(let-values (((table) (make-hasheq)))
(for-each (lambda (method generic) (for-each (lambda (method generic)
(hash-set! table (string->symbol method) generic)) (hash-set! table (string->symbol method) generic))
(list ,@(map (lambda (m) (list ,@(map (lambda (m)
@ -1108,14 +1108,14 @@
;build-field-table: (string->string) symbol accesses -> sexp ;build-field-table: (string->string) symbol accesses -> sexp
(define (build-field-table maker type fields) (define (build-field-table maker type fields)
`(let ((table (make-hasheq))) `(let-values (((table) (make-hasheq)))
(for-each (lambda (field field-method) (for-each (lambda (field field-method)
(hash-set! table (string->symbol field) field-method)) (hash-set! table (string->symbol field) field-method))
,@(let ((non-private-fields (map (lambda (n) (id-string (field-name n))) ,@(let-values (((non-private-fields) (map (lambda (n) (id-string (field-name n)))
(append (accesses-public fields) (append (accesses-public fields)
(accesses-package fields) (accesses-package fields)
(accesses-protected fields)))) (accesses-protected fields))))
(private-fields (map (lambda (n) (id-string (field-name n))) ((private-fields) (map (lambda (n) (id-string (field-name n)))
(accesses-private fields)))) (accesses-private fields))))
(list `(list ,@(append non-private-fields private-fields)) (list `(list ,@(append non-private-fields private-fields))
`(list ,@(append `(list ,@(append
@ -1212,7 +1212,7 @@
(parm-types (map field-type #;(lambda (p) (type-spec-to-type (field-type-spec p) #f 'full type-recs)) parms))) (parm-types (map field-type #;(lambda (p) (type-spec-to-type (field-type-spec p) #f 'full type-recs)) parms)))
(make-syntax #f (make-syntax #f
`(define/public (,(build-identifier (mangle-method-name ctor-name parm-types)) ,@translated-parms) `(define/public (,(build-identifier (mangle-method-name ctor-name parm-types)) ,@translated-parms)
(let ((temp-obj (make-object ,(build-identifier class-name) (let-values (((temp-obj) (make-object ,(build-identifier class-name)
this ,@encls-this))) this ,@encls-this)))
(send temp-obj ,(build-identifier (build-constructor-name class-name parm-types)) (send temp-obj ,(build-identifier (build-constructor-name class-name parm-types))
,@translated-parms) ,@translated-parms)
@ -1665,7 +1665,7 @@
(final (final? (map modifier-kind (field-modifiers field))))) (final (final? (map modifier-kind (field-modifiers field)))))
(append (cons (make-syntax #f (append (cons (make-syntax #f
`(define ,getter `(define ,getter
(let ((normal-get (class-field-accessor ,class ,quote-name))) (let-values (((normal-get) (class-field-accessor ,class ,quote-name)))
(lambda (obj) (lambda (obj)
(cond (cond
((is-a? obj ,class) (normal-get obj)) ((is-a? obj ,class) (normal-get obj))
@ -1679,7 +1679,7 @@
(list (list
(make-syntax #f (make-syntax #f
`(define ,setter `(define ,setter
(let ((normal-set (class-field-mutator ,class ,quote-name))) (let-values (((normal-set) (class-field-mutator ,class ,quote-name)))
(lambda (obj val) (lambda (obj val)
(cond (cond
[(is-a? obj ,class) (normal-set obj val)] [(is-a? obj ,class) (normal-set obj val)]
@ -1869,8 +1869,8 @@
;translate-throw: syntax src src -> syntax ;translate-throw: syntax src src -> syntax
(define translate-throw (define translate-throw
(lambda (expr key src) (lambda (expr key src)
(create-syntax #f `(let* ((obj ,expr) (create-syntax #f `(let*-values (((obj) ,expr)
(exn (make-java:exception ((exn) (make-java:exception
(send (send obj |getMessage|) get-mzscheme-string) (send (send obj |getMessage|) get-mzscheme-string)
(current-continuation-marks) obj))) (current-continuation-marks) obj)))
(send obj set-exception! exn) (send obj set-exception! exn)
@ -2190,14 +2190,14 @@
(case type (case type
((int short long byte float double boolean char dynamic void) val) ((int short long byte float double boolean char dynamic void) val)
((string String) ((string String)
`(let ((val ,val)) `(let-values (((val) ,val))
(if (string? val) (if (string? val)
(make-java-string val) (make-java-string val)
(raise (make-exn:fail (format "~a broke infered contract here: expected String received ~a" (raise (make-exn:fail (format "~a broke infered contract here: expected String received ~a"
,(class-name) val) ,(class-name) val)
(current-continuation-marks)))))))) (current-continuation-marks))))))))
((unknown-ref? type) ((unknown-ref? type)
`(let ((val ,val)) `(let-values (((val) ,val))
(if (string? val) (if (string? val)
(make-java-string val) (make-java-string val)
(c:contract ,(type->contract type #t) val '|| (quote ,(string->symbol (class-name))))))) (c:contract ,(type->contract type #t) val '|| (quote ,(string->symbol (class-name)))))))
@ -2322,12 +2322,12 @@
;translate-literal: symbol value src -> syntax ;translate-literal: symbol value src -> syntax
(define (translate-literal type value src) (define (translate-literal type value src)
(let ((make-string `(let ((temp-obj (make-object String))) (let ((make-string `(let-values (((temp-obj) (make-object String)))
(send temp-obj make-mzscheme-string ,value) (send temp-obj make-mzscheme-string ,value)
temp-obj)) temp-obj))
(make-image (make-image
(lambda () (lambda ()
`(let ((temp-obj (make-object ,(if (send (types) require-prefix? `(let-values (((temp-obj) (make-object ,(if (send (types) require-prefix?
'("Image" "graphics") (lambda () #f)) '("Image" "graphics") (lambda () #f))
'graphics.Image 'graphics.Image
'Image)))) 'Image))))
@ -2460,7 +2460,7 @@
(if (dynamic-val? type) (if (dynamic-val? type)
(let ((local-syntax (cond (let ((local-syntax (cond
((unknown-ref? (dynamic-val-type type)) ((unknown-ref? (dynamic-val-type type))
`(let ((val-1 ,var)) `(let-values (((val-1) ,var))
(if (string? val-1) (if (string? val-1)
(make-java-string val-1) (make-java-string val-1)
val-1))) val-1)))
@ -2489,7 +2489,7 @@
(let ((access-syntax (let ((access-syntax
(cond (cond
((unknown-ref? (dynamic-val-type type)) ((unknown-ref? (dynamic-val-type type))
`(let ((val-1 ,(translate-id static-name field-src))) `(let-values (((val-1) ,(translate-id static-name field-src)))
(if (string? val-1) (if (string? val-1)
(make-java-string val-1) (make-java-string val-1)
val-1))) val-1)))
@ -2528,7 +2528,7 @@
(if (dynamic-val? type) (if (dynamic-val? type)
(let ((access-syntax (cond (let ((access-syntax (cond
((unknown-ref? (dynamic-val-type type)) ((unknown-ref? (dynamic-val-type type))
`(let ((val-1 ,get-syntax)) `(let-values (((val-1) ,get-syntax))
(if (string? val-1) (if (string? val-1)
(make-java-string val-1) (make-java-string val-1)
val-1))) val-1)))
@ -2547,7 +2547,7 @@
(if cant-be-null? (if cant-be-null?
(make-syntax #f `(,id ,expr) (build-src src)) (make-syntax #f `(,id ,expr) (build-src src))
(make-syntax #f (make-syntax #f
`(let ([val~1 ,expr]) `(let-values ([(val~1) ,expr])
(if (null? val~1) (if (null? val~1)
,(create-syntax #f '(javaRuntime:nullError 'field (current-continuation-marks)) ,(create-syntax #f '(javaRuntime:nullError 'field (current-continuation-marks))
expr) expr)
@ -2556,7 +2556,7 @@
(if (dynamic-val? type) (if (dynamic-val? type)
(let ((access-syntax (cond (let ((access-syntax (cond
((unknown-ref? (dynamic-val-type type)) ((unknown-ref? (dynamic-val-type type))
`(let ((val-1 ,get-syntax)) `(let-values (((val-1) ,get-syntax))
(if (string? val-1) (if (string? val-1)
(make-java-string val-1) (make-java-string val-1)
val-1))) val-1)))
@ -2614,7 +2614,7 @@
((not expr) ((not expr)
`(send-generic this ,generic-c-name ,@args)) `(send-generic this ,generic-c-name ,@args))
(else (else
`(let ((,unique-name ,expression)) `(let-values (((,unique-name) ,expression))
(if (null? ,unique-name) (if (null? ,unique-name)
,(create-syntax #f '(javaRuntime:nullError 'method (current-continuation-marks)) ,(create-syntax #f '(javaRuntime:nullError 'method (current-continuation-marks))
expression) expression)
@ -2624,7 +2624,7 @@
(if cant-be-null? (if cant-be-null?
(create-syntax #f `(send ,(if expr expression 'this) ,c-name ,@translated-args) (build-src src)) (create-syntax #f `(send ,(if expr expression 'this) ,c-name ,@translated-args) (build-src src))
(create-syntax #f (create-syntax #f
`(let ((,unique-name ,expression)) `(let-values (((,unique-name) ,expression))
(if (null? ,unique-name) (if (null? ,unique-name)
,(create-syntax #f `(javaRuntime:nullError 'method (current-continuation-marks)) ,(create-syntax #f `(javaRuntime:nullError 'method (current-continuation-marks))
expression) expression)
@ -2699,7 +2699,7 @@
(static? (create-syntax #f `(begin ,expression (,name ,@translated-args)) (build-src src))) (static? (create-syntax #f `(begin ,expression (,name ,@translated-args)) (build-src src)))
(else (else
(create-syntax #f (create-syntax #f
`(let ((,unique-name ,expression)) `(let-values (((,unique-name) ,expression))
(if (null? ,unique-name) (if (null? ,unique-name)
(javaRuntime:nullError 'method (javaRuntime:nullError 'method
,(create-syntax #f ,(create-syntax #f
@ -2754,7 +2754,7 @@
#f #f
(cond (cond
(local-inner? (local-inner?
`(let ((new-o (make-object ,default-name `(let-values (((new-o) (make-object ,default-name
,@(if (static-method) ,@(if (static-method)
null null
(let loop ((d (current-depth))) (let loop ((d (current-depth)))
@ -2777,7 +2777,7 @@
(method-record-atypes ctor-record)) (method-record-atypes ctor-record))
(id-src class-id)) (id-src class-id))
,@args)) ,@args))
(else `(let ((new-o (make-object ,default-name))) (else `(let-values (((new-o) (make-object ,default-name)))
(send new-o ,default-ctor ,@args) (send new-o ,default-ctor ,@args)
new-o))) new-o)))
(build-src src)))) (build-src src))))
@ -2855,16 +2855,16 @@
[memb-field? [memb-field?
(let ([field-name (id-string (field-access-field (access-name exp)))] (let ([field-name (id-string (field-access-field (access-name exp)))]
[class-name (var-access-class (field-access-access (access-name exp)))]) [class-name (var-access-class (field-access-access (access-name exp)))])
`(let* ([,set-id ,(translate-expression (field-access-object (access-name exp)))] `(let*-values ([(,set-id) ,(translate-expression (field-access-object (access-name exp)))]
[,set-val-id (,(create-get-name field-name class-name) [(,set-val-id) (,(create-get-name field-name class-name)
,set-id)]) ,set-id)])
(,(create-set-name field-name class-name) ,set-id (,op ,set-val-id)) (,(create-set-name field-name class-name) ,set-id (,op ,set-val-id))
,set-val-id))] ,set-val-id))]
[array? [array?
(let ([index-id (gensym 'index-)]) (let ([index-id (gensym 'index-)])
`(let* ([,set-id ,(translate-expression (array-access-name exp))] `(let*-values ([(,set-id) ,(translate-expression (array-access-name exp))]
[,index-id ,(translate-expression (array-access-index exp))] [(,index-id) ,(translate-expression (array-access-index exp))]
[,set-val-id (send ,set-id access ,index-id)]) [(,set-val-id) (send ,set-id access ,index-id)])
(send ,set-id set ,index-id (,op ,set-val-id)) (send ,set-id set ,index-id (,op ,set-val-id))
,set-val-id))] ,set-val-id))]
[else `(begin0 ,expr (set! ,expr (,op ,expr)))]) [else `(begin0 ,expr (set! ,expr (,op ,expr)))])
@ -2886,16 +2886,16 @@
[memb-field? [memb-field?
(let ([field-name (id-string (field-access-field (access-name exp)))] (let ([field-name (id-string (field-access-field (access-name exp)))]
[class-name (var-access-class (field-access-access (access-name exp)))]) [class-name (var-access-class (field-access-access (access-name exp)))])
`(let* ([,set-id ,(translate-expression (field-access-object (access-name exp)))] `(let*-values ([(,set-id) ,(translate-expression (field-access-object (access-name exp)))]
[,set-val-id (,op (,(create-get-name field-name class-name) [(,set-val-id) (,op (,(create-get-name field-name class-name)
,set-id))]) ,set-id))])
(,(create-set-name field-name class-name) ,set-id ,set-val-id) (,(create-set-name field-name class-name) ,set-id ,set-val-id)
,set-val-id))] ,set-val-id))]
[array? [array?
(let ([index-id (gensym 'index-)]) (let ([index-id (gensym 'index-)])
`(let* ([,set-id ,(translate-expression (array-access-name exp))] `(let*-values ([(,set-id) ,(translate-expression (array-access-name exp))]
[,index-id ,(translate-expression (array-access-index exp))] [(,index-id) ,(translate-expression (array-access-index exp))]
[,set-val-id (,op (send ,set-id access ,index-id))]) [(,set-val-id) (,op (send ,set-id access ,index-id))])
(send ,set-id set ,index-id ,set-val-id) (send ,set-id set ,index-id ,set-val-id)
,set-val-id))] ,set-val-id))]
[else `(begin (set! ,expr (,op ,expr)) ,expr)]) [else `(begin (set! ,expr (,op ,expr)) ,expr)])
@ -3018,8 +3018,8 @@
(name (gensym 'field-obj)) (name (gensym 'field-obj))
(new-val (gensym 'val))) (new-val (gensym 'val)))
(make-syntax #f (make-syntax #f
`(let* ((,name ,expr) `(let*-values (((,name) ,expr)
(,new-val ,(expression `(,getter ,name)))) ((,new-val) ,(expression `(,getter ,name))))
(,setter ,name ,new-val) (,setter ,name ,new-val)
,new-val) ,new-val)
src-h)))))))))))) src-h))))))))))))
@ -3032,9 +3032,9 @@
(index (gensym 'my-index)) (index (gensym 'my-index))
(new-val (gensym 'val))) (new-val (gensym 'val)))
(make-syntax #f (make-syntax #f
`(let* ((,name ,array-name) `(let*-values (((,name) ,array-name)
(,index ,array-index) ((,index) ,array-index)
(,new-val ,(expression `(send ,name access ,index)))) ((,new-val) ,(expression `(send ,name access ,index))))
(send ,name set ,index ,new-val) (send ,name set ,index ,new-val)
,new-val) ,new-val)
(build-src src)))) (build-src src))))

4
collects/profj/tool.ss
View File

@ -1030,11 +1030,11 @@
(src (old-current-eval (syntax (quote s))))) (src (old-current-eval (syntax (quote s)))))
(execution? #t) (execution? #t)
(set! execute-types (create-type-record)) (set! execute-types (create-type-record))
(let* ((compilation-units (compile-ast exp level execute-types)) (let* ((compilation-units (time (compile-ast exp level execute-types)))
(examples (if (testcase-ext?) (examples (if (testcase-ext?)
(list (send execute-types get-test-classes) null) (list (send execute-types get-test-classes) null)
(find-examples compilation-units)))) (find-examples compilation-units))))
#;(printf "ProfJ compilation complete~n") (printf "ProfJ compilation complete~n")
(let ((name-to-require #f) (let ((name-to-require #f)
(tests-run? #f)) (tests-run? #f))
(let loop ((mods (order compilation-units)) (let loop ((mods (order compilation-units))

6
collects/test-engine/java-tests.scm
View File

@ -97,7 +97,7 @@
(let ([res ((cadr tc))]) (let ([res ((cadr tc))])
(send test-info complete-testcase res))] ; insert with-handlers (send test-info complete-testcase res))] ; insert with-handlers
[(test-method-name? (car tc)) [(test-method-name? (car tc))
(send test-info add-malformed-test (car tc))] (send test-info add-malformed-testcase (car tc))]
[(close-to-test-name? (car tc)) [(close-to-test-name? (car tc))
(send test-info add-nearly-testcase (car tc))] (send test-info add-nearly-testcase (car tc))]
[else (void)])) [else (void)]))
@ -187,13 +187,17 @@
(class* java-test-info% () (class* java-test-info% ()
(define nearly-tests null) (define nearly-tests null)
(define nearly-testcases null) (define nearly-testcases null)
(define malformed-testcases null)
(define/public (add-nearly-test name) (define/public (add-nearly-test name)
(set! nearly-tests (cons name nearly-tests))) (set! nearly-tests (cons name nearly-tests)))
(define/public (add-nearly-testcase name) (define/public (add-nearly-testcase name)
(set! nearly-testcases (cons name nearly-testcases))) (set! nearly-testcases (cons name nearly-testcases)))
(define/public (add-malformed-testcase name)
(set! malformed-testcases (cons name malformed-testcases)))
(define/public (close-tests) nearly-tests) (define/public (close-tests) nearly-tests)
(define/public (close-testcases) nearly-testcases) (define/public (close-testcases) nearly-testcases)
(define/public (bad-testcases) malformed-testcases)
(super-instantiate ()))) (super-instantiate ())))