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

Remove almost all uses of `stxclass' library.

Browse Source 
svn: r15944
This commit is contained in:
Sam Tobin-Hochstadt 2009-09-09 21:24:05 +00:00
parent f1179528a8
commit eda69b472a
13 changed files with 98 additions and 97 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

25
collects/typed-scheme/rep/interning.ss
View File

@ -1,21 +1,19 @@
#lang scheme/base #lang scheme/base
(require syntax/boundmap (for-syntax scheme/base stxclass) (require syntax/boundmap (for-syntax scheme/base syntax/parse))
#;macro-debugger/stepper)
(provide defintern hash-id) (provide defintern hash-id)
(define-syntax (defintern stx) (define-syntax (defintern stx)
(syntax-parse stx (syntax-parse stx
[(_ name+args make-name key (~or [#:extra-arg e:expr] #:opt) ...) [(_ name+args make-name key (~optional (~seq #:extra-arg e:expr)) ...)
(if #'e (if (attribute e)
#'(defintern name+args (lambda () (make-hash #;'weak)) make-name key #:extra-arg e) #'(defintern name+args (lambda () (make-hash #;'weak)) make-name key #:extra-arg e)
#'(defintern name+args (lambda () (make-hash #;'weak)) make-name key))] #'(defintern name+args (lambda () (make-hash #;'weak)) make-name key))]
[(_ (*name:id arg:id ...) make-ht make-name key-expr (~or [#:extra-arg e:expr]) ...) [(_ (*name:id arg:id ...) make-ht make-name key-expr (~seq #:extra-arg e:expr) ...)
#'(define *name #'(define *name
(let ([table (make-ht)]) (let ([table (make-ht)])
(lambda (arg ...) (lambda (arg ...)
#;(all-count!)
(let ([key key-expr]) (let ([key key-expr])
(hash-ref table key (hash-ref table key
(lambda () (lambda ()
@ -23,24 +21,13 @@
(hash-set! table key new) (hash-set! table key new)
new)))))))])) new)))))))]))
(define (make-count!) (define (make-count!)
(let ([state 0]) (let ([state 0])
(lambda () (begin0 state (set! state (add1 state))))) (lambda () (begin0 state (set! state (add1 state))))))
#;
(let ([ch (make-channel)])
(thread (lambda () (let loop ([n 0]) (channel-put ch n) (loop (add1 n)))))
(lambda () (channel-get ch))))
(provide #;count! #;all-count! union-count!)
(define count! (make-count!)) (define count! (make-count!))
(define union-count! (make-count!))
(define all-count! (make-count!))
(define id-count! (make-count!)) (define id-count! (make-count!))
(define identifier-table (make-module-identifier-mapping)) (define identifier-table (make-module-identifier-mapping))
(define (hash-id id) (define (hash-id id)

68
collects/typed-scheme/rep/rep-utils.ss
View File

@ -12,12 +12,14 @@
scheme/list scheme/list
stxclass/util stxclass/util
scheme/match scheme/match
stxclass (except-in syntax/parse id identifier keyword)
scheme/base scheme/base
syntax/struct syntax/struct
syntax/stx syntax/stx
scheme/contract scheme/contract
(utils utils))) (rename-in (except-in (utils utils stxclass-util) bytes byte-regexp regexp byte-pregexp #;pregexp)
[id* id]
[keyword* keyword])))
(provide == defintern hash-id (for-syntax fold-target)) (provide == defintern hash-id (for-syntax fold-target))
@ -65,34 +67,36 @@
#:with e #'#'ex)) #:with e #'#'ex))
(lambda (stx) (lambda (stx)
(syntax-parse stx (syntax-parse stx
[(dform nm:id flds:idlist (~or [[#:key key-expr:expr]] #:opt [(dform nm:id flds:idlist (~or
[[#:intern intern?:expr]] #:opt (~optional [#:key key-expr:expr])
[[#:frees . frees:frees-pat]] #:opt (~optional [#:intern intern?:expr])
[[#:fold-rhs fold-rhs:fold-pat]] #:opt (~optional [#:frees . frees:frees-pat])
[[#:contract cnt:expr]] #:opt (~optional [#:fold-rhs fold-rhs:fold-pat])
[no-provide?:no-provide-kw] #:opt) ...) (~optional [#:contract cnt:expr])
(~optional no-provide?:no-provide-kw)) ...)
(with-syntax* (with-syntax*
([ex (mk-id #'nm #'nm ":")] ([ex (mk-id #'nm #'nm ":")]
[fold-name (mk-id #f #'nm "-fold")] [fold-name (mk-id #f #'nm "-fold")]
[kw-stx (string->keyword (symbol->string #'nm.datum))] [kw-stx (string->keyword (symbol->string (attribute nm.datum)))]
[parent par] [parent par]
[(s:ty maker pred acc ...) (build-struct-names #'nm (syntax->list #'flds.fs) #f #t #'nm)] [(s:ty maker pred acc ...) (build-struct-names #'nm (syntax->list #'flds.fs) #f #t #'nm)]
[*maker (mk-id #'nm "*" #'nm)] [*maker (mk-id #'nm "*" #'nm)]
[**maker (mk-id #'nm "**" #'nm)] [**maker (mk-id #'nm "**" #'nm)]
[*maker-cnt (if enable-contracts? [*maker-cnt (if enable-contracts?
(or #'cnt #'(flds.cnt ... . -> . pred)) (or (attribute cnt) #'(flds.cnt ... . -> . pred))
#'any/c)] #'any/c)]
[ht-stx ht-stx] [ht-stx ht-stx]
[bfs-fold-rhs (cond [#'fold-rhs #`(procedure-rename [bfs-fold-rhs (cond [(attribute fold-rhs)
(lambda () #,#'fold-rhs.e) #`(procedure-rename
'fold-name)] (lambda () #,#'fold-rhs.e)
'fold-name)]
;; otherwise we assume that everything is a type, ;; otherwise we assume that everything is a type,
;; and recur on all the arguments ;; and recur on all the arguments
[else #'(procedure-rename [else #'(procedure-rename
(lambda () (lambda ()
#`(*maker (#,type-rec-id flds.i) ...)) #`(*maker (#,type-rec-id flds.i) ...))
'fold-name)])] 'fold-name)])]
[provides (if #'no-provide? [provides (if (attribute no-provide?)
#'(begin) #'(begin)
#`(begin #`(begin
(provide #;nm ex pred acc ...) (provide #;nm ex pred acc ...)
@ -100,18 +104,18 @@
[intern [intern
(let ([mk (lambda (int) (let ([mk (lambda (int)
(if key? (if key?
#`(defintern (**maker . flds.fs) maker #,int #:extra-arg key-expr) #`(defintern (**maker . flds.fs) maker #,int #:extra-arg #,(attribute key-expr))
#`(defintern (**maker . flds.fs) maker #,int)))]) #`(defintern (**maker . flds.fs) maker #,int)))])
(syntax-parse #'flds.fs (syntax-parse #'flds.fs
[_ #:when #'intern? [_ #:fail-unless (attribute intern?) #f
(mk #'intern?)] (mk #'intern?)]
[() (mk #'#f)] [() (mk #'#f)]
[(f) (mk #'f)] [(f) (mk #'f)]
[_ (mk #'(list . flds.fs))]))] [_ (mk #'(list . flds.fs))]))]
[(ign-pats ...) (if key? #'(_ _) #'(_))] [(ign-pats ...) (if key? #'(_ _) #'(_))]
[frees-def (if #'frees #'frees.def #'(begin))] [frees-def (if (attribute frees) #'frees.def #'(begin))]
[frees [frees
(with-syntax ([(f1 f2) (if #'frees (with-syntax ([(f1 f2) (if (attribute frees)
#'(frees.f1 frees.f2) #'(frees.f1 frees.f2)
(list (combiner #'free-vars* #'flds.fs) (list (combiner #'free-vars* #'flds.fs)
(combiner #'free-idxs* #'flds.fs)))]) (combiner #'free-idxs* #'flds.fs)))])
@ -168,7 +172,7 @@
(define-syntax-class clause (define-syntax-class clause
(pattern (pattern
(k:keyword #:matcher mtch pats ... e:expr) (k:keyword #:matcher mtch pats ... e:expr)
#:with kw #'k.datum #:with kw (attribute k.datum)
#:with val (list #'mtch #:with val (list #'mtch
(syntax/loc this-syntax (pats ...)) (syntax/loc this-syntax (pats ...))
(lambda () #'e) (lambda () #'e)
@ -188,13 +192,13 @@
(define-syntax-class (keyword-in kws) (define-syntax-class (keyword-in kws)
#:attributes (datum) #:attributes (datum)
(pattern k:keyword (pattern k:keyword
#:when (memq #'k.datum kws) #:fail-unless (memq (attribute k.datum) kws) #f
#:with datum #'k.datum)) #:with datum (attribute k.datum)))
(define-syntax-class (sized-list kws) (define-syntax-class (sized-list kws)
#:description (format "keyword expr pairs matching with keywords in the list ~a" kws) #:description (format "keyword expr pairs matching with keywords in the list ~a" kws)
(pattern ((~or [k e:expr]) ...) (pattern ((~or (~seq k e:expr)) ...)
#:declare k (keyword-in kws) #:declare k (keyword-in kws)
#:when (equal? (length (attribute k.datum)) (length (remove-duplicates (attribute k.datum)))) #:fail-unless (equal? (length (attribute k.datum)) (length (remove-duplicates (attribute k.datum)))) #f
#:with mapping (for/hash ([k* (attribute k.datum)] #:with mapping (for/hash ([k* (attribute k.datum)]
[e* (attribute e)]) [e* (attribute e)])
(values k* e*)) (values k* e*))
@ -225,26 +229,32 @@
#:attributes (i lower-s first-letter key? (fld-names 1)) #:attributes (i lower-s first-letter key? (fld-names 1))
#:transparent #:transparent
(pattern i:id (pattern i:id
#:with lower-s (string-downcase (symbol->string #'i.datum)) #:with lower-s (string-downcase (symbol->string (attribute i.datum)))
#:with (fld-names ...) default-flds #:with (fld-names ...) default-flds
#:with key? #'#f #:with key? #'#f
#:with first-letter (string-ref #'lower-s 0)) #:with first-letter (string-ref #'lower-s 0))
(pattern [i:id #:d d-name:id] (pattern [i:id #:d d-name:id]
#:with (fld-names ...) default-flds #:with (fld-names ...) default-flds
#:with lower-s (string-downcase (symbol->string #'i.datum)) #:with lower-s (string-downcase (symbol->string (attribute i.datum)))
#:with key? #'#f #:with key? #'#f
#:with first-letter (symbol->string #'d-name.datum)) #:with first-letter (symbol->string (attribute d-name.datum)))
(pattern [i:id #:key] (pattern [i:id #:key]
#:with (fld-names ...) (datum->syntax #f (append (syntax->list default-flds) #:with (fld-names ...) (datum->syntax #f (append (syntax->list default-flds)
(syntax->list #'(key)))) (syntax->list #'(key))))
#:with lower-s (string-downcase (symbol->string #'i.datum)) #:with lower-s (string-downcase (symbol->string (attribute i.datum)))
#:with key? #'#t #:with key? #'#t
#:with first-letter (string-ref #'lower-s 0))) #:with first-letter (string-ref #'lower-s 0)))
(define-syntax-class type-name (define-syntax-class type-name
#:transparent #:transparent
(pattern :type-name-base #:attributes (i lower-s first-letter key? (fld-names 1) name keyword tmp-rec-id case printer ht rec-id d-id pred? (accs 1))
(pattern tnb:type-name-base
#:with i #'tnb.i
#:with lower-s (attribute tnb.lower-s)
#:with first-letter (attribute tnb.first-letter)
#:with key? #'tnb.key?
#:with (fld-names ...) #'(tnb.fld-names ...)
#:with name #'i #:with name #'i
#:with keyword (string->keyword (symbol->string (syntax-e #'i))) #:with keyword (datum->syntax #f (string->keyword (symbol->string (syntax-e #'i))))
#:with tmp-rec-id (generate-temporary) #:with tmp-rec-id (generate-temporary)
#:with case (mk-id #'i #'lower-s "-case") #:with case (mk-id #'i #'lower-s "-case")
#:with printer (mk-id #'i "print-" #'lower-s "*") #:with printer (mk-id #'i "print-" #'lower-s "*")

4
collects/typed-scheme/typecheck/find-annotation.ss
View File

@ -1,6 +1,6 @@
#lang scheme/base #lang scheme/base
(require "../utils/utils.ss" stxclass (require "../utils/utils.ss" syntax/parse
scheme/contract scheme/contract
(rep type-rep) (rep type-rep)
(private type-annotation)) (private type-annotation))
@ -53,7 +53,7 @@
[c:lv-clause [c:lv-clause
#:with (#%plain-app reverse n:id) #'c.e #:with (#%plain-app reverse n:id) #'c.e
#:with (v) #'(c.v ...) #:with (v) #'(c.v ...)
#:when (free-identifier=? name #'n) #:fail-unless (free-identifier=? name #'n) #f
(type-annotation #'v)] (type-annotation #'v)]
[_ #f])) [_ #f]))
(syntax-parse stx (syntax-parse stx

41
collects/typed-scheme/typecheck/tc-app.ss
View File

@ -3,8 +3,13 @@
(require (rename-in "../utils/utils.ss" [infer r:infer]) (require (rename-in "../utils/utils.ss" [infer r:infer])
"signatures.ss" "tc-metafunctions.ss" "signatures.ss" "tc-metafunctions.ss"
"tc-app-helper.ss" "find-annotation.ss" "tc-app-helper.ss" "find-annotation.ss"
stxclass scheme/match mzlib/trace scheme/list syntax/parse scheme/match mzlib/trace scheme/list
(for-syntax stxclass scheme/base) ;; fixme - don't need to be bound in this phase - only to make syntax/parse happy
scheme/bool
(only-in scheme/private/class-internal make-object do-make-object)
(only-in '#%kernel [apply k:apply])
;; end fixme
(for-syntax syntax/parse scheme/base (utils tc-utils))
(private type-annotation) (private type-annotation)
(types utils abbrev union subtype resolve convenience) (types utils abbrev union subtype resolve convenience)
(utils tc-utils) (utils tc-utils)
@ -14,7 +19,7 @@
(r:infer infer) (r:infer infer)
(for-template (for-template
(only-in '#%kernel [apply k:apply]) (only-in '#%kernel [apply k:apply])
"internal-forms.ss" scheme/base "internal-forms.ss" scheme/base scheme/bool
(only-in scheme/private/class-internal make-object do-make-object))) (only-in scheme/private/class-internal make-object do-make-object)))
(import tc-expr^ tc-lambda^ tc-dots^ tc-let^) (import tc-expr^ tc-lambda^ tc-dots^ tc-let^)
@ -417,12 +422,12 @@
(ret ts fs os))])] (ret ts fs os))])]
;; special case for keywords ;; special case for keywords
[(#%plain-app [(#%plain-app
(#%plain-app cpce s:kp fn kpe kws num) (#%plain-app cpce s-kp fn kpe kws num)
kw-list kw-list
(#%plain-app list . kw-arg-list) (#%plain-app list . kw-arg-list)
. pos-args) . pos-args)
#:declare cpce (id-from 'checked-procedure-check-and-extract 'scheme/private/kw) #:declare cpce (id-from 'checked-procedure-check-and-extract 'scheme/private/kw)
#:declare s:kp (id-from 'struct:keyword-procedure 'scheme/private/kw) #:declare s-kp (id-from 'struct:keyword-procedure 'scheme/private/kw)
#:declare kpe (id-from 'keyword-procedure-extract 'scheme/private/kw) #:declare kpe (id-from 'keyword-procedure-extract 'scheme/private/kw)
(match (tc-expr #'fn) (match (tc-expr #'fn)
[(tc-result1: (Function: arities)) [(tc-result1: (Function: arities))
@ -431,9 +436,9 @@
"Cannot apply expression of type ~a, since it is not a function type" t)])] "Cannot apply expression of type ~a, since it is not a function type" t)])]
;; even more special case for match ;; even more special case for match
[(#%plain-app (letrec-values ([(lp) (#%plain-lambda args . body)]) lp*) . actuals) [(#%plain-app (letrec-values ([(lp) (#%plain-lambda args . body)]) lp*) . actuals)
#:when expected #:fail-unless expected #f
#:when (not (andmap type-annotation (syntax->list #'args))) #:fail-unless (not (andmap type-annotation (syntax->list #'args))) #f
#:when (free-identifier=? #'lp #'lp*) #:fail-unless (free-identifier=? #'lp #'lp*) #f
(let-loop-check form #'lp #'actuals #'args #'body expected)] (let-loop-check form #'lp #'actuals #'args #'body expected)]
;; special cases for classes ;; special cases for classes
[(#%plain-app make-object cl . args) [(#%plain-app make-object cl . args)
@ -442,11 +447,11 @@
(check-do-make-object #'cl #'pos-args #'(names ...) #'(named-args ...))] (check-do-make-object #'cl #'pos-args #'(names ...) #'(named-args ...))]
;; ormap/andmap of ... argument ;; ormap/andmap of ... argument
[(#%plain-app or/andmap:id f arg) [(#%plain-app or/andmap:id f arg)
#:when (or (free-identifier=? #'or/andmap #'ormap) #:fail-unless (or (free-identifier=? #'or/andmap #'ormap)
(free-identifier=? #'or/andmap #'andmap)) (free-identifier=? #'or/andmap #'andmap)) #f
#:when (with-handlers ([exn:fail? (lambda _ #f)]) #:fail-unless (with-handlers ([exn:fail? (lambda _ #f)])
(tc/dots #'arg) (tc/dots #'arg)
#t) #t) #f
(let-values ([(ty bound) (tc/dots #'arg)]) (let-values ([(ty bound) (tc/dots #'arg)])
(parameterize ([current-tvars (extend-env (list bound) (parameterize ([current-tvars (extend-env (list bound)
(list (make-DottedBoth (make-F bound))) (list (make-DottedBoth (make-F bound)))
@ -493,18 +498,18 @@
(ret (foldr make-Pair last tys)))] (ret (foldr make-Pair last tys)))]
;; inference for ((lambda ;; inference for ((lambda
[(#%plain-app (#%plain-lambda (x ...) . body) args ...) [(#%plain-app (#%plain-lambda (x ...) . body) args ...)
#:when (= (length (syntax->list #'(x ...))) #:fail-unless (= (length (syntax->list #'(x ...)))
(length (syntax->list #'(args ...)))) (length (syntax->list #'(args ...)))) #f
(tc/let-values #'((x) ...) #'(args ...) #'body (tc/let-values #'((x) ...) #'(args ...) #'body
#'(let-values ([(x) args] ...) . body) #'(let-values ([(x) args] ...) . body)
expected)] expected)]
;; inference for ((lambda with dotted rest ;; inference for ((lambda with dotted rest
[(#%plain-app (#%plain-lambda (x ... . rst:id) . body) args ...) [(#%plain-app (#%plain-lambda (x ... . rst:id) . body) args ...)
#:when (<= (length (syntax->list #'(x ...))) #:fail-unless (<= (length (syntax->list #'(x ...)))
(length (syntax->list #'(args ...)))) (length (syntax->list #'(args ...)))) #f
;; FIXME - remove this restriction - doesn't work because the annotation ;; FIXME - remove this restriction - doesn't work because the annotation
;; on rst is not a normal annotation, may have * or ... ;; on rst is not a normal annotation, may have * or ...
#:when (not (type-annotation #'rst)) #:fail-unless (not (type-annotation #'rst)) #f
(let-values ([(fixed-args varargs) (split-at (syntax->list #'(args ...)) (length (syntax->list #'(x ...))))]) (let-values ([(fixed-args varargs) (split-at (syntax->list #'(args ...)) (length (syntax->list #'(x ...))))])
(with-syntax ([(fixed-args ...) fixed-args] (with-syntax ([(fixed-args ...) fixed-args]
[varg #`(#%plain-app list #,@varargs)]) [varg #`(#%plain-app list #,@varargs)])

2
collects/typed-scheme/typecheck/tc-expr-unit.ss
View File

@ -8,7 +8,7 @@
(types utils convenience union subtype) (types utils convenience union subtype)
(private-in parse-type type-annotation) (private-in parse-type type-annotation)
(rep type-rep) (rep type-rep)
(utils tc-utils stxclass-util) (except-in (utils tc-utils stxclass-util) define-pred-stxclass 3d atom byte-pregexp byte-regexp regexp bytes)
(env lexical-env) (env lexical-env)
(only-in (env type-environments) lookup current-tvars extend-env) (only-in (env type-environments) lookup current-tvars extend-env)
scheme/private/class-internal scheme/private/class-internal

4
collects/typed-scheme/typecheck/tc-let-unit.ss
View File

@ -8,7 +8,7 @@
syntax/free-vars syntax/free-vars
mzlib/trace mzlib/trace
scheme/match scheme/match
syntax/kerncase stxclass syntax/kerncase syntax/parse
(for-template (for-template
scheme/base scheme/base
"internal-forms.ss")) "internal-forms.ss"))
@ -92,7 +92,7 @@
(define ((tc-expr-t/maybe-expected expected) e) (define ((tc-expr-t/maybe-expected expected) e)
(syntax-parse e #:literals (#%plain-lambda) (syntax-parse e #:literals (#%plain-lambda)
[(#%plain-lambda () _) [(#%plain-lambda () _)
#:when (and expected (syntax-property e 'typechecker:called-in-tail-position)) #:fail-unless (and expected (syntax-property e 'typechecker:called-in-tail-position)) #f
(tc-expr/check e (ret (-> (tc-results->values expected))))] (tc-expr/check e (ret (-> (tc-results->values expected))))]
[_ (tc-expr e)])) [_ (tc-expr e)]))

8
collects/typed-scheme/types/abbrev.ss
View File

@ -9,7 +9,7 @@
scheme/match scheme/match
scheme/promise scheme/promise
(prefix-in c: scheme/contract) (prefix-in c: scheme/contract)
(for-syntax scheme/base stxclass) (for-syntax scheme/base syntax/parse)
(for-template scheme/base scheme/contract scheme/tcp)) (for-template scheme/base scheme/contract scheme/tcp))
(provide (all-defined-out) (provide (all-defined-out)
@ -160,7 +160,7 @@
(define-syntax (->* stx) (define-syntax (->* stx)
(define-syntax-class c (define-syntax-class c
(pattern x:id #:when (eq? ': (syntax-e #'x)))) (pattern x:id #:fail-unless (eq? ': (syntax-e #'x)) #f))
(syntax-parse stx (syntax-parse stx
[(_ dom rng) [(_ dom rng)
#'(make-Function (list (make-arr* dom rng)))] #'(make-Function (list (make-arr* dom rng)))]
@ -177,7 +177,7 @@
(define-syntax (-> stx) (define-syntax (-> stx)
(define-syntax-class c (define-syntax-class c
(pattern x:id #:when (eq? ': (syntax-e #'x)))) (pattern x:id #:fail-unless (eq? ': (syntax-e #'x)) #f))
(syntax-parse stx (syntax-parse stx
[(_ dom ... rng _:c filters _:c objects) [(_ dom ... rng _:c filters _:c objects)
#'(->* (list dom ...) rng : filters : objects)] #'(->* (list dom ...) rng : filters : objects)]
@ -216,7 +216,7 @@
(define-syntax (->key stx) (define-syntax (->key stx)
(syntax-parse stx (syntax-parse stx
[(_ ty:expr ... (~or (k:keyword kty:expr opt:boolean)) ... rng) [(_ ty:expr ... (~seq k:keyword kty:expr opt:boolean) ... rng)
#'(make-Function #'(make-Function
(list (list
(make-arr* (list ty ...) (make-arr* (list ty ...)

12
collects/typed-scheme/types/convenience.ss
View File

@ -1,15 +1,11 @@
#lang scheme/base #lang scheme/base
(require "../utils/utils.ss") (require "../utils/utils.ss"
(rep type-rep filter-rep object-rep)
(require (rep type-rep filter-rep object-rep)
(utils tc-utils) (utils tc-utils)
"abbrev.ss" "abbrev.ss"
(types comparison printer union subtype utils) (types comparison printer union subtype utils)
scheme/list scheme/list scheme/match scheme/promise
scheme/match (for-syntax syntax/parse scheme/base)
scheme/promise
(for-syntax stxclass)
(for-syntax scheme/base)
(for-template scheme/base)) (for-template scheme/base))
(provide (all-defined-out) (provide (all-defined-out)

7
collects/typed-scheme/types/subtype.ss
View File

@ -1,14 +1,13 @@
#lang scheme/base #lang scheme/base
(require "../utils/utils.ss") (require "../utils/utils.ss"
(rep type-rep filter-rep object-rep rep-utils)
(require (rep type-rep filter-rep object-rep rep-utils)
(utils tc-utils) (utils tc-utils)
(types utils comparison resolve abbrev) (types utils comparison resolve abbrev)
(env type-name-env) (env type-name-env)
(only-in (infer infer-dummy) unify) (only-in (infer infer-dummy) unify)
scheme/match scheme/match
mzlib/trace mzlib/trace
(for-syntax scheme/base stxclass)) (for-syntax scheme/base syntax/parse))
;; exn representing failure of subtyping ;; exn representing failure of subtyping
;; s,t both types ;; s,t both types

2
collects/typed-scheme/types/utils.ss
View File

@ -9,7 +9,7 @@
scheme/list scheme/list
mzlib/trace mzlib/trace
scheme/contract scheme/contract
(for-syntax scheme/base stxclass)) (for-syntax scheme/base syntax/parse))
(provide fv fv/list (provide fv fv/list
substitute substitute

12
collects/typed-scheme/utils/stxclass-util.ss
View File

@ -1,8 +1,9 @@
#lang scheme/base #lang scheme/base
(require syntax/parse (for-syntax syntax/parse scheme/base stxclass/util)) (require (except-in syntax/parse id keyword) (for-syntax syntax/parse scheme/base stxclass/util))
(provide (except-out (all-defined-out) define-pred-stxclass)) (provide (except-out (all-defined-out) id keyword)
(rename-out [id id*] [keyword keyword*]))
(define-syntax (parse/get stx) (define-syntax (parse/get stx)
(syntax-parse stx (syntax-parse stx
@ -27,12 +28,15 @@
#:fail-unless (pred #'datum) #f)) #:fail-unless (pred #'datum) #f))
(define-syntax-rule (define-pred-stxclass name pred) (define-syntax-rule (define-pred-stxclass name pred)
(define-syntax-class name #:attributes () (define-syntax-class name #:attributes (datum)
(pattern x (pattern x
#:fail-unless (pred (syntax-e #'x)) #f))) #:fail-unless (pred (syntax-e #'x)) #f
#:with datum (syntax-e #'x))))
(define-pred-stxclass atom atom?) (define-pred-stxclass atom atom?)
(define-pred-stxclass byte-pregexp byte-pregexp?) (define-pred-stxclass byte-pregexp byte-pregexp?)
(define-pred-stxclass byte-regexp byte-regexp?) (define-pred-stxclass byte-regexp byte-regexp?)
(define-pred-stxclass regexp regexp?) (define-pred-stxclass regexp regexp?)
(define-pred-stxclass bytes bytes?) (define-pred-stxclass bytes bytes?)
(define-pred-stxclass id symbol?)
(define-pred-stxclass keyword keyword?)

4
collects/typed-scheme/utils/tc-utils.ss
View File

@ -6,7 +6,7 @@ don't depend on any other portion of the system
|# |#
(provide (all-defined-out)) (provide (all-defined-out))
(require "syntax-traversal.ss" stxclass (for-syntax scheme/base stxclass) scheme/match) (require "syntax-traversal.ss" syntax/parse (for-syntax scheme/base syntax/parse) scheme/match)
;; a parameter representing the original location of the syntax being currently checked ;; a parameter representing the original location of the syntax being currently checked
(define current-orig-stx (make-parameter #'here)) (define current-orig-stx (make-parameter #'here))
@ -181,4 +181,4 @@ don't depend on any other portion of the system
(define-syntax-class (id-from sym mod) (define-syntax-class (id-from sym mod)
(pattern i:id (pattern i:id
#:when (id-from? #'i sym mod))) #:fail-unless (id-from? #'i sym mod) #f))

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

@ -5,10 +5,10 @@ This file is for utilities that are of general interest,
at least theoretically. at least theoretically.
|# |#
(require (for-syntax scheme/base stxclass scheme/string) (require (for-syntax scheme/base syntax/parse scheme/string)
scheme/contract mzlib/plt-match scheme/require-syntax scheme/provide-syntax scheme/contract mzlib/plt-match scheme/require-syntax scheme/provide-syntax
mzlib/struct scheme/unit mzlib/struct scheme/unit
(except-in stxclass id)) (except-in syntax/parse id))
(provide with-syntax* syntax-map start-timing do-time reverse-begin printf/log (provide with-syntax* syntax-map start-timing do-time reverse-begin printf/log
with-logging-to-file log-file-name == with-logging-to-file log-file-name ==
@ -286,7 +286,7 @@ at least theoretically.
#:literals () #:literals ()
#:attributes (i) #:attributes (i)
(pattern [rename out:id in:id cnt:expr] (pattern [rename out:id in:id cnt:expr]
#:when (eq? (syntax-e #'rename) 'rename) #:fail-unless (eq? (syntax-e #'rename) 'rename) #f
#:with i #'(rename-out [out in])) #:with i #'(rename-out [out in]))
(pattern [i:id cnt:expr])) (pattern [i:id cnt:expr]))
(syntax-parse stx (syntax-parse stx