From 87d48f63efd73a944f7af5bd161c9ffe3d5adb22 Mon Sep 17 00:00:00 2001 From: Sam Tobin-Hochstadt Date: Fri, 11 Sep 2009 17:49:50 +0000 Subject: [PATCH] Remove last uses of stxclass. svn: r15976 original commit: 5fc019ba6c8d0a9ca21c05c4a92f8476e348f407 --- collects/typed-scheme/private/prims.ss | 23 ++++++++------- .../typed-scheme/typecheck/tc-expr-unit.ss | 29 +++++-------------- collects/typed-scheme/typed-scheme.ss | 2 +- 3 files changed, 22 insertions(+), 32 deletions(-) diff --git a/collects/typed-scheme/private/prims.ss b/collects/typed-scheme/private/prims.ss index ccace1df..7af74c0f 100644 --- a/collects/typed-scheme/private/prims.ss +++ b/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) diff --git a/collects/typed-scheme/typecheck/tc-expr-unit.ss b/collects/typed-scheme/typecheck/tc-expr-unit.ss index 44addcea..77710237 100644 --- a/collects/typed-scheme/typecheck/tc-expr-unit.ss +++ b/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: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])) diff --git a/collects/typed-scheme/typed-scheme.ss b/collects/typed-scheme/typed-scheme.ss index 6ebafaf8..e17d5281 100644 --- a/collects/typed-scheme/typed-scheme.ss +++ b/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)