From 3860454c7b7d367c250f9fb0b8960ec24cbeb97b Mon Sep 17 00:00:00 2001 From: Sam Tobin-Hochstadt Date: Mon, 16 Feb 2009 23:06:23 +0000 Subject: [PATCH 1/4] Use stxclass for require/opaque-type svn: r13682 original commit: c7809e5838816fee70e74622390d05c07b809062 --- collects/typed-scheme/private/prims.ss | 46 +++++++++----------------- 1 file changed, 15 insertions(+), 31 deletions(-) diff --git a/collects/typed-scheme/private/prims.ss b/collects/typed-scheme/private/prims.ss index 3c7a1720..d34ce7dd 100644 --- a/collects/typed-scheme/private/prims.ss +++ b/collects/typed-scheme/private/prims.ss @@ -84,37 +84,21 @@ This file defines two sorts of primitives. All of them are provided into any mod 'typechecker:ignore #t)))))])) (define-syntax (require/opaque-type stx) - (syntax-case stx () - [(_ ty pred lib #:name-exists) - (begin - (unless (identifier? #'ty) - (raise-syntax-error #f "opaque type name must be an identifier" stx #'ty)) - (unless (identifier? #'pred) - (raise-syntax-error #f "opaque type predicate must be an identifier" stx #'pred)) - (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)))) - #,(internal (syntax/loc stx (define-type-alias-internal ty (Opaque pred)))) - #,(syntax-property #'(require/contract pred pred-cnt lib) - 'typechecker:ignore #t))))] - [(_ ty pred lib) - (begin - (unless (identifier? #'ty) - (raise-syntax-error #f "opaque type name must be an identifier" stx #'ty)) - (unless (identifier? #'pred) - (raise-syntax-error #f "opaque type predicate must be an identifier" stx #'pred)) - (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)))) - (define-type-alias ty (Opaque pred)) - #,(syntax-property #'(require/contract pred pred-cnt lib) - 'typechecker:ignore #t))))])) + (define-syntax-class name-exists-kw + (pattern #:name-exists)) + (syntax-parse stx + [(_ ty:id pred:id lib ([ne:name-exists-kw] #:opt) ...*) + (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 + (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) + 'typechecker:ignore #t)))])) (define-for-syntax (formal-annotation-error stx src) (let loop ([stx stx]) From 91f75661c4e428cd893a877b81abb25453f08dc9 Mon Sep 17 00:00:00 2001 From: Ryan Culpepper Date: Wed, 18 Feb 2009 04:01:52 +0000 Subject: [PATCH 2/4] 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))] From de3fec3ebcd3bee7e22ac466e26b996b7dc1e38e Mon Sep 17 00:00:00 2001 From: Eli Barzilay Date: Thu, 26 Feb 2009 14:04:39 +0000 Subject: [PATCH 3/4] fix bitwise ops svn: r13850 original commit: d10cdccca9a704f6a215660f667dd7aaaf2c8757 --- collects/typed-scheme/private/base-env.ss | 8 ++++---- 1 file changed, 4 insertions(+), 4 deletions(-) diff --git a/collects/typed-scheme/private/base-env.ss b/collects/typed-scheme/private/base-env.ss index c8e9b69a..dea4afde 100644 --- a/collects/typed-scheme/private/base-env.ss +++ b/collects/typed-scheme/private/base-env.ss @@ -395,10 +395,10 @@ [lcm (null -Integer . ->* . -Integer)] [arithmetic-shift (-Integer -Integer . -> . -Integer)] -[bitwise-and (null N . ->* . N)] -[bitwise-ior (null N . ->* . N)] -[bitwise-not (null N . ->* . N)] -[bitwise-xor (null N . ->* . N)] +[bitwise-and (null -Integer . ->* . -Integer)] +[bitwise-ior (null -Integer . ->* . -Integer)] +[bitwise-not (null -Integer . ->* . -Integer)] +[bitwise-xor (null -Integer . ->* . -Integer)] [vector (-poly (a) (->* (list) a (-vec a)))] [make-string (cl-> [(-Integer) -String] [(-Integer -Char) -String])] From ae8f85d5015fdbf06e635427560067813bce790a Mon Sep 17 00:00:00 2001 From: Jay McCarthy Date: Thu, 26 Feb 2009 17:09:26 +0000 Subject: [PATCH 4/4] new units, contracts, tests svn: r13852 original commit: 196ec00f16f726745f98d6d5b026213114d9a5e6 --- collects/tests/xml/clark-tests/not-wf/sa/032.xml | 1 + 1 file changed, 1 insertion(+) create mode 100644 collects/tests/xml/clark-tests/not-wf/sa/032.xml diff --git a/collects/tests/xml/clark-tests/not-wf/sa/032.xml b/collects/tests/xml/clark-tests/not-wf/sa/032.xml new file mode 100644 index 00000000..75952017 --- /dev/null +++ b/collects/tests/xml/clark-tests/not-wf/sa/032.xml @@ -0,0 +1 @@ +