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
(require syntax/boundmap (for-syntax scheme/base stxclass)
#;macro-debugger/stepper)
(require syntax/boundmap (for-syntax scheme/base syntax/parse))
(provide defintern hash-id)
(define-syntax (defintern stx)
(syntax-parse stx
[(_ name+args make-name key (~or [#:extra-arg e:expr] #:opt) ...)
(if #'e
[(_ name+args make-name key (~optional (~seq #:extra-arg e:expr)) ...)
(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))]
[(_ (*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
(let ([table (make-ht)])
(lambda (arg ...)
#;(all-count!)
(let ([key key-expr])
(hash-ref table key
(lambda ()
@ -23,24 +21,13 @@
(hash-set! table key new)
new)))))))]))
(define (make-count!)
(define (make-count!)
(let ([state 0])
(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!)
(lambda () (begin0 state (set! state (add1 state))))))
(define count! (make-count!))
(define union-count! (make-count!))
(define all-count! (make-count!))
(define id-count! (make-count!))
(define identifier-table (make-module-identifier-mapping))
(define (hash-id id)

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

@ -12,12 +12,14 @@
scheme/list
stxclass/util
scheme/match
stxclass
(except-in syntax/parse id identifier keyword)
scheme/base
syntax/struct
syntax/stx
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))
@ -65,34 +67,36 @@
#:with e #'#'ex))
(lambda (stx)
(syntax-parse stx
[(dform nm:id flds:idlist (~or [[#:key key-expr:expr]] #:opt
[[#:intern intern?:expr]] #:opt
[[#:frees . frees:frees-pat]] #:opt
[[#:fold-rhs fold-rhs:fold-pat]] #:opt
[[#:contract cnt:expr]] #:opt
[no-provide?:no-provide-kw] #:opt) ...)
[(dform nm:id flds:idlist (~or
(~optional [#:key key-expr:expr])
(~optional [#:intern intern?:expr])
(~optional [#:frees . frees:frees-pat])
(~optional [#:fold-rhs fold-rhs:fold-pat])
(~optional [#:contract cnt:expr])
(~optional no-provide?:no-provide-kw)) ...)
(with-syntax*
([ex (mk-id #'nm #'nm ":")]
[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]
[(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-cnt (if enable-contracts?
(or #'cnt #'(flds.cnt ... . -> . pred))
(or (attribute cnt) #'(flds.cnt ... . -> . pred))
#'any/c)]
[ht-stx ht-stx]
[bfs-fold-rhs (cond [#'fold-rhs #`(procedure-rename
(lambda () #,#'fold-rhs.e)
'fold-name)]
[bfs-fold-rhs (cond [(attribute fold-rhs)
#`(procedure-rename
(lambda () #,#'fold-rhs.e)
'fold-name)]
;; otherwise we assume that everything is a type,
;; and recur on all the arguments
[else #'(procedure-rename
(lambda ()
#`(*maker (#,type-rec-id flds.i) ...))
'fold-name)])]
[provides (if #'no-provide?
[provides (if (attribute no-provide?)
#'(begin)
#`(begin
(provide #;nm ex pred acc ...)
@ -100,18 +104,18 @@
[intern
(let ([mk (lambda (int)
(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)))])
(syntax-parse #'flds.fs
[_ #:when #'intern?
[_ #:fail-unless (attribute intern?) #f
(mk #'intern?)]
[() (mk #'#f)]
[(f) (mk #'f)]
[_ (mk #'(list . flds.fs))]))]
[(ign-pats ...) (if key? #'(_ _) #'(_))]
[frees-def (if #'frees #'frees.def #'(begin))]
[frees-def (if (attribute frees) #'frees.def #'(begin))]
[frees
(with-syntax ([(f1 f2) (if #'frees
(with-syntax ([(f1 f2) (if (attribute frees)
#'(frees.f1 frees.f2)
(list (combiner #'free-vars* #'flds.fs)
(combiner #'free-idxs* #'flds.fs)))])
@ -168,7 +172,7 @@
(define-syntax-class clause
(pattern
(k:keyword #:matcher mtch pats ... e:expr)
#:with kw #'k.datum
#:with kw (attribute k.datum)
#:with val (list #'mtch
(syntax/loc this-syntax (pats ...))
(lambda () #'e)
@ -188,13 +192,13 @@
(define-syntax-class (keyword-in kws)
#:attributes (datum)
(pattern k:keyword
#:when (memq #'k.datum kws)
#:with datum #'k.datum))
#:fail-unless (memq (attribute k.datum) kws) #f
#:with datum (attribute k.datum)))
(define-syntax-class (sized-list 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)
#: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)]
[e* (attribute e)])
(values k* e*))
@ -225,26 +229,32 @@
#:attributes (i lower-s first-letter key? (fld-names 1))
#:transparent
(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 key? #'#f
#:with first-letter (string-ref #'lower-s 0))
(pattern [i:id #:d d-name:id]
#: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 first-letter (symbol->string #'d-name.datum))
#:with first-letter (symbol->string (attribute d-name.datum)))
(pattern [i:id #:key]
#:with (fld-names ...) (datum->syntax #f (append (syntax->list default-flds)
(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 first-letter (string-ref #'lower-s 0)))
(define-syntax-class type-name
#: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 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 case (mk-id #'i #'lower-s "-case")
#: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
(require "../utils/utils.ss" stxclass
(require "../utils/utils.ss" syntax/parse
scheme/contract
(rep type-rep)
(private type-annotation))
@ -53,7 +53,7 @@
[c:lv-clause
#:with (#%plain-app reverse n:id) #'c.e
#:with (v) #'(c.v ...)
#:when (free-identifier=? name #'n)
#:fail-unless (free-identifier=? name #'n) #f
(type-annotation #'v)]
[_ #f]))
(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])
"signatures.ss" "tc-metafunctions.ss"
"tc-app-helper.ss" "find-annotation.ss"
stxclass scheme/match mzlib/trace scheme/list
(for-syntax stxclass scheme/base)
syntax/parse scheme/match mzlib/trace scheme/list
;; 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)
(types utils abbrev union subtype resolve convenience)
(utils tc-utils)
@ -14,7 +19,7 @@
(r:infer infer)
(for-template
(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)))
(import tc-expr^ tc-lambda^ tc-dots^ tc-let^)
@ -417,12 +422,12 @@
(ret ts fs os))])]
;; special case for keywords
[(#%plain-app
(#%plain-app cpce s:kp fn kpe kws num)
(#%plain-app cpce s-kp fn kpe kws num)
kw-list
(#%plain-app list . kw-arg-list)
. pos-args)
#: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)
(match (tc-expr #'fn)
[(tc-result1: (Function: arities))
@ -431,9 +436,9 @@
"Cannot apply expression of type ~a, since it is not a function type" t)])]
;; even more special case for match
[(#%plain-app (letrec-values ([(lp) (#%plain-lambda args . body)]) lp*) . actuals)
#:when expected
#:when (not (andmap type-annotation (syntax->list #'args)))
#:when (free-identifier=? #'lp #'lp*)
#:fail-unless expected #f
#:fail-unless (not (andmap type-annotation (syntax->list #'args))) #f
#:fail-unless (free-identifier=? #'lp #'lp*) #f
(let-loop-check form #'lp #'actuals #'args #'body expected)]
;; special cases for classes
[(#%plain-app make-object cl . args)
@ -442,11 +447,11 @@
(check-do-make-object #'cl #'pos-args #'(names ...) #'(named-args ...))]
;; ormap/andmap of ... argument
[(#%plain-app or/andmap:id f arg)
#:when (or (free-identifier=? #'or/andmap #'ormap)
(free-identifier=? #'or/andmap #'andmap))
#:when (with-handlers ([exn:fail? (lambda _ #f)])
(tc/dots #'arg)
#t)
#:fail-unless (or (free-identifier=? #'or/andmap #'ormap)
(free-identifier=? #'or/andmap #'andmap)) #f
#:fail-unless (with-handlers ([exn:fail? (lambda _ #f)])
(tc/dots #'arg)
#t) #f
(let-values ([(ty bound) (tc/dots #'arg)])
(parameterize ([current-tvars (extend-env (list bound)
(list (make-DottedBoth (make-F bound)))
@ -493,18 +498,18 @@
(ret (foldr make-Pair last tys)))]
;; inference for ((lambda
[(#%plain-app (#%plain-lambda (x ...) . body) args ...)
#:when (= (length (syntax->list #'(x ...)))
(length (syntax->list #'(args ...))))
#:fail-unless (= (length (syntax->list #'(x ...)))
(length (syntax->list #'(args ...)))) #f
(tc/let-values #'((x) ...) #'(args ...) #'body
#'(let-values ([(x) args] ...) . body)
expected)]
;; inference for ((lambda with dotted rest
[(#%plain-app (#%plain-lambda (x ... . rst:id) . body) args ...)
#:when (<= (length (syntax->list #'(x ...)))
(length (syntax->list #'(args ...))))
#:fail-unless (<= (length (syntax->list #'(x ...)))
(length (syntax->list #'(args ...)))) #f
;; FIXME - remove this restriction - doesn't work because the annotation
;; 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 ...))))])
(with-syntax ([(fixed-args ...) fixed-args]
[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)
(private-in parse-type type-annotation)
(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)
(only-in (env type-environments) lookup current-tvars extend-env)
scheme/private/class-internal

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

@ -8,7 +8,7 @@
syntax/free-vars
mzlib/trace
scheme/match
syntax/kerncase stxclass
syntax/kerncase syntax/parse
(for-template
scheme/base
"internal-forms.ss"))
@ -92,7 +92,7 @@
(define ((tc-expr-t/maybe-expected expected) e)
(syntax-parse e #:literals (#%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 e)]))

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

@ -9,7 +9,7 @@
scheme/match
scheme/promise
(prefix-in c: scheme/contract)
(for-syntax scheme/base stxclass)
(for-syntax scheme/base syntax/parse)
(for-template scheme/base scheme/contract scheme/tcp))
(provide (all-defined-out)
@ -160,7 +160,7 @@
(define-syntax (->* stx)
(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
[(_ dom rng)
#'(make-Function (list (make-arr* dom rng)))]
@ -177,7 +177,7 @@
(define-syntax (-> stx)
(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
[(_ dom ... rng _:c filters _:c objects)
#'(->* (list dom ...) rng : filters : objects)]
@ -216,7 +216,7 @@
(define-syntax (->key 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
(list
(make-arr* (list ty ...)

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

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

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

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

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

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

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

@ -1,8 +1,9 @@
#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)
(syntax-parse stx
@ -27,12 +28,15 @@
#:fail-unless (pred #'datum) #f))
(define-syntax-rule (define-pred-stxclass name pred)
(define-syntax-class name #:attributes ()
(define-syntax-class name #:attributes (datum)
(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 byte-pregexp byte-pregexp?)
(define-pred-stxclass byte-regexp byte-regexp?)
(define-pred-stxclass regexp regexp?)
(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))
(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
(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)
(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.
|#
(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
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
with-logging-to-file log-file-name ==
@ -286,7 +286,7 @@ at least theoretically.
#:literals ()
#:attributes (i)
(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]))
(pattern [i:id cnt:expr]))
(syntax-parse stx