diff --git a/collects/typed-scheme/private/mutated-vars.ss b/collects/typed-scheme/private/mutated-vars.ss index da057e5d82..6e7a2c2da9 100644 --- a/collects/typed-scheme/private/mutated-vars.ss +++ b/collects/typed-scheme/private/mutated-vars.ss @@ -14,8 +14,8 @@ ;; syntax -> void (define (fmv/list lstx) (for-each find-mutated-vars (syntax->list lstx))) - ;(printf "called with ~a~n" (syntax-object->datum form)) - (kernel-syntax-case* form #f (define-type-alias-internal define-typed-struct-internal require/typed-internal #%app lambda) + ;(printf "called with ~a~n" (syntax->datum form)) + (kernel-syntax-case* form #f (define-type-alias-internal define-typed-struct-internal require/typed-internal) ;; what we care about: set! [(set! v e) (begin @@ -23,10 +23,10 @@ (module-identifier-mapping-put! table #'v #t))] [(define-values (var ...) expr) (find-mutated-vars #'expr)] - [(#%app . rest) (fmv/list #'rest)] + [(#%plain-app . rest) (fmv/list #'rest)] [(begin . rest) (fmv/list #'rest)] [(begin0 . rest) (fmv/list #'rest)] - [(lambda _ . rest) (fmv/list #'rest)] + [(#%plain-lambda _ . rest) (fmv/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 e1 e2 e3) (begin (find-mutated-vars #'e1) (find-mutated-vars #'e1) (find-mutated-vars #'e3))] diff --git a/collects/typed-scheme/private/planet-requires.ss b/collects/typed-scheme/private/planet-requires.ss index 3e46e27dea..14f4b28651 100644 --- a/collects/typed-scheme/private/planet-requires.ss +++ b/collects/typed-scheme/private/planet-requires.ss @@ -1,11 +1,27 @@ #lang scheme/base -(require (for-syntax scheme/base scheme/require-transform)) +(require (for-syntax scheme/base scheme/require-transform) + scheme/require-syntax) (define-for-syntax (splice-requires specs) (define subs (map (compose cons expand-import) specs)) (values (apply append (map car subs)) (apply append (map cdr subs)))) +(define-syntax define-module + (syntax-rules () + [(_ nm spec ...) + + (define-syntax nm + (make-require-transformer + (lambda (stx) + (splice-requires (list (syntax-local-introduce (quote-syntax spec)) ...))))) + #; + (define-require-syntax nm + (lambda (stx) + (syntax-case stx () + [(_) (datum->syntax stx (syntax->datum #'(combine-in spec ...)))])))])) + +#; (define-syntax define-module (lambda (stx) (syntax-case stx () @@ -38,6 +54,10 @@ (define-module galore (prefix-in table: "tables.ss")) +(require (galore)) + +(void (table:alist->eq '())) + (define-module schemeunit (planet/multiple ("schematics" "schemeunit.plt" 2 3) "test.ss" diff --git a/collects/typed-scheme/private/tables.ss b/collects/typed-scheme/private/tables.ss index 41842a851c..c7b28535dc 100644 --- a/collects/typed-scheme/private/tables.ss +++ b/collects/typed-scheme/private/tables.ss @@ -7,8 +7,12 @@ (for/hasheq ([e l]) (values (car e) (cdr e)))) +(define (sexp->eq l) + (for/hasheq ([e l]) + (values (car e) (cadr e)))) + ;; to-sexp : table -> Listof(List k v) -(define (to-sexp t) (hash-map list t)) +(define (to-sexp t) (hash-map t list)) ;; union/value : table(k,v) table(k,v) [(v v -> v)] -> table(k,v) (define (union/value t1 t2 [f (lambda (x y) x)]) @@ -20,7 +24,7 @@ [else (hash-set new-table k v)]))) -(define make-eq make-immutable-hasheq) +(define (make-eq) (make-immutable-hasheq null)) (define (lookup k t) (hash-ref t k #f))