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

Add eof and read-accept-reader.

Browse Source 
Fix find-mutated-vars
This commit is contained in:
Sam Tobin-Hochstadt 2008-09-11 09:01:49 -04:00
parent c7b51cfd2d
commit 7cf9b36c15
3 changed files with 19 additions and 19 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

3
collects/typed-scheme/private/base-env.ss
View File

@ -560,7 +560,8 @@
[values (-polydots (a) (null (a a) . ->... . (make-ValuesDots null a 'a)))] [values (-polydots (a) (null (a a) . ->... . (make-ValuesDots null a 'a)))]
[call-with-values (-polydots (b a) ((-> (make-ValuesDots null a 'a)) (null (a a) . ->... . b) . -> . b))] [call-with-values (-polydots (b a) ((-> (make-ValuesDots null a 'a)) (null (a a) . ->... . b) . -> . b))]
[foo (N #:bar B #f . ->key . B)] [eof (-val eof)]
[read-accept-reader (-Param B B)]
) )
(begin-for-syntax (begin-for-syntax

13
collects/typed-scheme/private/mutated-vars.ss
View File

@ -14,12 +14,11 @@
;; syntax -> void ;; syntax -> void
(define (fmv/list lstx) (define (fmv/list lstx)
(for-each find-mutated-vars (syntax->list lstx))) (for-each find-mutated-vars (syntax->list lstx)))
;(printf "called with ~a~n" (syntax->datum form)) ;(when (and (pair? (syntax->datum form))) (printf "called with ~a~n" (syntax->datum form)))
(kernel-syntax-case* form #f (define-type-alias-internal define-typed-struct-internal require/typed-internal) (kernel-syntax-case* form #f (define-type-alias-internal define-typed-struct-internal require/typed-internal)
;; what we care about: set! ;; what we care about: set!
[(set! v e) [(set! v e)
(begin (begin
;(printf "mutated var found: ~a~n" (syntax-e #'v))
(module-identifier-mapping-put! table #'v #t))] (module-identifier-mapping-put! table #'v #t))]
[(define-values (var ...) expr) [(define-values (var ...) expr)
(find-mutated-vars #'expr)] (find-mutated-vars #'expr)]
@ -28,15 +27,13 @@
[(begin0 . rest) (fmv/list #'rest)] [(begin0 . rest) (fmv/list #'rest)]
[(#%plain-lambda _ . rest) (fmv/list #'rest)] [(#%plain-lambda _ . rest) (fmv/list #'rest)]
[(case-lambda (_ . rest) ...) (for-each fmv/list (syntax->list #'(rest ...)))] [(case-lambda (_ . rest) ...) (for-each fmv/list (syntax->list #'(rest ...)))]
[(if e1 e2) (begin (find-mutated-vars #'e1) (find-mutated-vars #'e2))] [(if . es) (fmv/list #'es)]
[(if e1 e2 e3) (begin (find-mutated-vars #'e1) (find-mutated-vars #'e1) (find-mutated-vars #'e3))] [(with-continuation-mark . es) (fmv/list #'es)]
[(with-continuation-mark e1 e2 e3) (begin (find-mutated-vars #'e1)
(find-mutated-vars #'e1)
(find-mutated-vars #'e3))]
[(let-values ([_ e] ...) . b) (begin (fmv/list #'(e ...)) [(let-values ([_ e] ...) . b) (begin (fmv/list #'(e ...))
(fmv/list #'b))] (fmv/list #'b))]
[(letrec-values ([_ e] ...) . b) (begin (fmv/list #'(e ...)) [(letrec-values ([_ e] ...) . b) (begin (fmv/list #'(e ...))
(fmv/list #'b))] (fmv/list #'b))]
[(#%expression e) (find-mutated-vars #'e)]
;; all the other forms don't have any expression subforms (like #%top) ;; all the other forms don't have any expression subforms (like #%top)
[_ (void)])) [_ (void)]))

22
collects/typed-scheme/utils/utils.ss
View File

@ -30,16 +30,18 @@
(syntax-case stx () (syntax-case stx ()
[(_ id ...) [(_ id ...)
(andmap identifier? (syntax->list #'(id ...))) (andmap identifier? (syntax->list #'(id ...)))
(with-syntax ([(id* ...) (map (lambda (id) (datum->syntax (with-syntax ([(id* ...)
id (map (lambda (id)
(string->symbol (datum->syntax
(string-append id
"typed-scheme/" (string->symbol
#,(symbol->string (syntax-e #'nm)) (string-append
"/" "typed-scheme/"
(symbol->string (syntax-e id)))) #,(symbol->string (syntax-e #'nm))
id id)) "/"
(syntax->list #'(id ...)))]) (symbol->string (syntax-e id))))
id id))
(syntax->list #'(id ...)))])
(syntax/loc stx (combine-in id* ...)))]))))])) (syntax/loc stx (combine-in id* ...)))]))))]))