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

Remove last uses of stxclass.

Browse Source 
svn: r15976

original commit: 5fc019ba6c8d0a9ca21c05c4a92f8476e348f407
This commit is contained in:
Sam Tobin-Hochstadt 2009-09-11 17:49:50 +00:00
parent 8898a34829
commit 87d48f63ef
3 changed files with 22 additions and 32 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

23
collects/typed-scheme/private/prims.ss
View File

@ -26,7 +26,7 @@ This file defines two sorts of primitives. All of them are provided into any mod
(require (except-in "../utils/utils.ss" extend))
(require (for-syntax
stxclass
syntax/parse
stxclass/util
scheme/base
(rep type-rep)
@ -64,28 +64,31 @@ This file defines two sorts of primitives. All of them are provided into any mod
#:attributes (nm ty)
(pattern [nm:opt-rename ty]))
(define-syntax-class struct-clause
#:literals (struct)
;#:literals (struct)
#:attributes (nm (body 1))
(pattern [struct nm:opt-rename (body ...)]))
(pattern [struct nm:opt-rename (body ...)]
#:fail-unless (eq? 'struct (syntax-e #'struct)) #f))
(define-syntax-class opaque-clause
#:literals (opaque)
;#:literals (opaque)
#:attributes (ty pred opt)
(pattern [opaque ty:id pred:id]
#:fail-unless (eq? 'opaque (syntax-e #'opaque)) #f
#:with opt #'())
(pattern [opaque ty:id pred:id #:name-exists]
#:fail-unless (eq? 'opaque (syntax-e #'opaque)) #f
#:with opt #'(#:name-exists)))
(syntax-parse stx
[(_ lib (~or [sc:simple-clause] [strc:struct-clause] [oc:opaque-clause]) ...)
[(_ lib (~or sc:simple-clause strc:struct-clause oc:opaque-clause) ...)
#'(begin
(require/opaque-type oc.ty oc.pred lib . oc.opt) ...
(require/typed sc.nm sc.ty lib) ...
(require-typed-struct strc.nm (strc.body ...) lib) ...)]
[(_ nm:opt-rename ty lib (~or [#:struct-maker parent] #:opt) ...)
[(_ nm:opt-rename ty lib (~optional [~seq #:struct-maker parent]) ...)
(with-syntax ([cnt* (generate-temporary #'nm.nm)]
[sm (if #'parent
[sm (if (attribute parent)
#'(#:struct-maker parent)
#'())])
(let ([prop-name (if #'parent
(let ([prop-name (if (attribute parent)
'typechecker:contract-def/maker
'typechecker:contract-def)])
(quasisyntax/loc stx
@ -101,14 +104,14 @@ This file defines two sorts of primitives. All of them are provided into any mod
(define-syntax-class name-exists-kw
(pattern #:name-exists))
(syntax-parse stx
[(_ ty:id pred:id lib (~or [ne:name-exists-kw] #:opt) ...)
[(_ ty:id pred:id lib (~optional ne:name-exists-kw) ...)
(register-type-name #'ty (make-Opaque #'pred (syntax-local-certifier)))
(quasisyntax/loc stx
(begin
#,(syntax-property #'(define pred-cnt (any/c . c-> . boolean?))
'typechecker:ignore #t)
#,(internal #'(require/typed-internal pred (Any -> Boolean : (Opaque pred))))
#,(if #'ne
#,(if (attribute ne)
(internal (syntax/loc stx (define-type-alias-internal ty (Opaque pred))))
(syntax/loc stx (define-type-alias ty (Opaque pred))))
#,(syntax-property #'(require/contract pred pred-cnt lib)

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

@ -8,11 +8,11 @@
(types utils convenience union subtype)
(private-in parse-type type-annotation)
(rep type-rep)
(except-in (utils tc-utils stxclass-util) define-pred-stxclass 3d atom byte-pregexp byte-regexp regexp bytes)
(except-in (utils tc-utils stxclass-util))
(env lexical-env)
(only-in (env type-environments) lookup current-tvars extend-env)
scheme/private/class-internal
(except-in stxclass id)
(except-in syntax/parse id)
(only-in srfi/1 split-at))
(require (for-template scheme/base scheme/private/class-internal))
@ -20,36 +20,23 @@
(import tc-if^ tc-lambda^ tc-app^ tc-let^ check-subforms^)
(export tc-expr^)
(define-syntax-class (3d pred)
(pattern s
#:with datum (syntax-e #'s)
#:when (pred #'datum)))
(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?)
;; return the type of a literal value
;; scheme-value -> type
(define (tc-literal v-stx [expected #f])
(define-syntax-class exp
(pattern i
#:when expected
#:fail-unless expected #f
#:with datum (syntax-e #'i)
#:when (subtype (-val #'datum) expected)))
#:fail-unless (subtype (-val #'datum) expected) #f))
(syntax-parse v-stx
[i:exp expected]
[i:boolean (-val #'i.datum)]
[i:identifier (-val #'i.datum)]
[i:boolean (-val (syntax-e #'i))]
[i:identifier (-val (syntax-e #'i))]
[i:exact-integer -Integer]
[i:number -Number]
[i:str -String]
[i:char -Char]
[i:keyword (-val #'i.datum)]
[i:keyword (-val (syntax-e #'i))]
[i:bytes -Bytes]
[i:byte-pregexp -Byte-PRegexp]
[i:byte-regexp -Byte-Regexp]
@ -57,7 +44,7 @@
[(i ...)
(-Tuple (map tc-literal (syntax->list #'(i ...))))]
[i #:declare i (3d vector?)
(make-Vector (apply Un (map tc-literal (vector->list #'i.datum))))]
(make-Vector (apply Un (map tc-literal (vector->list (syntax-e #'i)))))]
[_ Univ]))

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

@ -4,7 +4,7 @@
(require (private base-types)
(for-syntax
(except-in stxclass id)
(except-in syntax/parse id)
scheme/base
(private type-contract)
(types utils convenience)