Remove last uses of stxclass.

svn: r15976

collects/typed-scheme/private/prims.ss

@@ -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)

collects/typed-scheme/typecheck/tc-expr-unit.ss

@@ -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:boolean (-val (syntax-e #'i))]
-    [i:identifier (-val #'i.datum)]
+    [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]))
 
 

collects/typed-scheme/typed-scheme.ss

@@ -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)