From 91f75661c4e428cd893a877b81abb25453f08dc9 Mon Sep 17 00:00:00 2001 From: Ryan Culpepper Date: Wed, 18 Feb 2009 04:01:52 +0000 Subject: [PATCH] stxclass: added and- and or-patterns, box and vector patterns svn: r13721 original commit: 59727cc4bcdb2f4955f3f5206207a8d482736d0a --- collects/typed-scheme/private/parse-type.ss | 2 +- collects/typed-scheme/private/prims.ss | 4 ++-- collects/typed-scheme/private/type-abbrev.ss | 2 +- collects/typed-scheme/rep/interning.ss | 4 ++-- collects/typed-scheme/rep/rep-utils.ss | 10 +++++----- 5 files changed, 11 insertions(+), 11 deletions(-) diff --git a/collects/typed-scheme/private/parse-type.ss b/collects/typed-scheme/private/parse-type.ss index 526d9184..135384af 100644 --- a/collects/typed-scheme/private/parse-type.ss +++ b/collects/typed-scheme/private/parse-type.ss @@ -251,7 +251,7 @@ (pattern (case-lambda f:fun-ty/one ...) #:with t (make-Function (syntax->datum #'(f.arr ...)))) - (pattern (t:Class (pos-args:type ...) ([fname:id fty:type ((rest:boolean) #:opt) ...*] ...) ([mname:id mty:type] ...)) + (pattern (t:Class (pos-args:type ...) ([fname:id fty:type (~or (rest:boolean) #:opt) ...] ...) ([mname:id mty:type] ...)) #:with t (make-Class (syntax->datum #'(pos-args.t ...)) diff --git a/collects/typed-scheme/private/prims.ss b/collects/typed-scheme/private/prims.ss index d34ce7dd..3988110b 100644 --- a/collects/typed-scheme/private/prims.ss +++ b/collects/typed-scheme/private/prims.ss @@ -66,7 +66,7 @@ This file defines two sorts of primitives. All of them are provided into any mod (syntax-parse stx [(_ lib [nm:opt-rename ty] ...) #'(begin (require/typed nm ty lib) ...)] - [(_ nm:opt-rename ty lib ([#:struct-maker parent] #:opt) ...*) + [(_ nm:opt-rename ty lib (~or [#:struct-maker parent] #:opt) ...) (with-syntax ([cnt* (generate-temporary #'nm.nm)] [sm (if #'parent #'(#:struct-maker parent) @@ -87,7 +87,7 @@ 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 ([ne:name-exists-kw] #:opt) ...*) + [(_ ty:id pred:id lib (~or [ne:name-exists-kw] #:opt) ...) (register-type-name #'ty (make-Opaque #'pred (syntax-local-certifier))) (quasisyntax/loc stx (begin diff --git a/collects/typed-scheme/private/type-abbrev.ss b/collects/typed-scheme/private/type-abbrev.ss index 3a33b0f3..35de27f4 100644 --- a/collects/typed-scheme/private/type-abbrev.ss +++ b/collects/typed-scheme/private/type-abbrev.ss @@ -82,7 +82,7 @@ (define-syntax (->key stx) (syntax-parse stx - [(_ ty:expr ... ((k:keyword kty:expr opt:boolean)) ...* rng) + [(_ ty:expr ... (~or (k:keyword kty:expr opt:boolean)) ... rng) #'(make-Function (list (make-arr* (list ty ...) diff --git a/collects/typed-scheme/rep/interning.ss b/collects/typed-scheme/rep/interning.ss index 2430ee4a..fa696eb8 100644 --- a/collects/typed-scheme/rep/interning.ss +++ b/collects/typed-scheme/rep/interning.ss @@ -7,9 +7,9 @@ (define-syntax (defintern stx) (syntax-parse stx - [(_ name+args make-name key ([#:extra-arg e:expr]) ...*) + [(_ name+args make-name key (~or [#:extra-arg e:expr]) ...) #'(defintern name+args (lambda () (make-hash #;'weak)) make-name key #:extra-arg e ...)] - [(_ (*name:id arg:id ...) make-ht make-name key-expr ([#:extra-arg e:expr]) ...*) + [(_ (*name:id arg:id ...) make-ht make-name key-expr (~or [#:extra-arg e:expr]) ...) #'(define *name (let ([table (make-ht)]) (lambda (arg ...) diff --git a/collects/typed-scheme/rep/rep-utils.ss b/collects/typed-scheme/rep/rep-utils.ss index 2d2ecc7d..1d97957d 100644 --- a/collects/typed-scheme/rep/rep-utils.ss +++ b/collects/typed-scheme/rep/rep-utils.ss @@ -70,11 +70,11 @@ (define (mk par ht-stx) (lambda (stx) (syntax-parse stx - [(dform nm:id flds:idlist ([[#:key key-expr:expr]] #:opt - [[#:intern intern?:expr]] #:opt - [[#:frees . frees:frees-pat]] #:opt - [[#:fold-rhs fold-rhs:fold-pat]] #:opt - [no-provide?:no-provide-kw] #:opt) ...*) + [(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 + [no-provide?:no-provide-kw] #:opt) ...) (with-syntax* ([ex (mk-id #'nm #'nm ":")] [kw-stx (string->keyword (symbol->string #'nm.datum))]