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

More checkEffect support

Browse Source 
svn: r10595
This commit is contained in:
Kathy Gray 2008-07-04 13:00:03 +00:00
parent 31407bea69
commit 1e30f69c6c
3 changed files with 27 additions and 12 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

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

@ -1426,7 +1426,7 @@
(define static-NullPointerException/c
(c:flat-named-contract "NullPointerException" (lambda (c) (is-a? c guard-convert-NullPointerException))))
(define stm-wrapper (interface () log get-field set-field!))
(define stm-wrapper (interface () log get-field-stm set-field-stm!))
(provide stm-wrapper)
)

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

@ -746,6 +746,7 @@
(Primary
[(PrimaryNoNewArray) $1]
[(TEST_IDENTIFIER) (make-test-id #f (build-src 1) $1)]
[(ArrayCreationExpression) $1])
(PrimaryNoNewArray
@ -886,7 +887,6 @@
(PostfixExpression
[(Primary) $1]
[(Name) (name->access $1)]
[(TEST_IDENTIFIER) (make-test-id #f (build-src 1) $1)]
[(PostIncrementExpression) $1]
[(PostDecrementExpression) $1])

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

@ -1143,12 +1143,13 @@
(define o null)
(define field-map (make-hasheq))
(define/public (log obj) (set! o obj))
(define/public (get-field field)
(define/public (get-field-stm field)
(or (hash-ref field-map field #f)
(get-field o field)))
(define/public (set-field! field value)
(eval `(get-field ,field ,o))))
(define/public (set-field-stm! field value)
(hash-set! field-map field value)
value)
(define/public (my-name) (send o my-name))
,@(generate-stm-fields fields)
,@(generate-stm-methods methods))))
#f))
@ -1668,7 +1669,8 @@
(lambda (obj)
(cond
((is-a? obj ,class) (normal-get obj))
((is-a? obj stm-wrapper) (send obj get-field))
((is-a? obj stm-wrapper)
(send obj get-field-stm (quote ,quote-name)))
(else
(send obj
,(build-identifier (format "~a-wrapped" getter))))))))
@ -1681,7 +1683,8 @@
(lambda (obj val)
(cond
[(is-a? obj ,class) (normal-set obj val)]
[(is-a? obj stm-wrapper) (send obj set-field! val)]
[(is-a? obj stm-wrapper)
(send obj set-field-stm! (quote ,quote-name) val)]
[else
(send obj ,(build-identifier (format "~a-wrapped" setter)) val)]))))
#f))
@ -3108,15 +3111,27 @@
(lambda () #f)))
(build-src src))))
;translate-check-effect: (listof id) (listof expression) (listof expression) src -> syntax
;translate-check-effect: (listof access) (listof expression) (listof expression) src -> syntax
(define (translate-check-effect ids conds test src)
(let ([cs (map (lambda (c) (create-syntax #f `(lambda () ,(translate-expression c)) #f)) conds)]
[ts (map (lambda (t) (create-syntax #f `(lambda () ,(translate-expression t)) #f)) test)])
(make-syntax #f
`(let (,@(map (lambda (id)
`(,(string->symbol (format "~a@" id)) ,(build-identifier (build-var-name id))))
(map (apply compose (list id-string local-access-name access-name))
ids)))
`(let (,@(apply
append
(map (lambda (id type)
(let ([var (build-identifier (build-var-name id))])
`((,(string->symbol (format "~a@" id)) ,var)
(,var
,(cond
[(or (prim-numeric-type? type) (eq? type 'boolean)) var]
[else
`(let ([obj@ (make-object
,(build-identifier
(string-append (ref-type-class/iface type) "-stm")))])
(send obj@ log ,var)
obj@)])))))
(map (apply compose (list id-string local-access-name access-name)) ids)
(map expr-types ids))))
,@(map (lambda (t) `(,t)) ts)
,@(map (lambda (c) `(,c)) cs))
(build-src src))))