diff --git a/collects/tests/typed-scheme/unit-tests/typecheck-tests.rkt b/collects/tests/typed-scheme/unit-tests/typecheck-tests.rkt index ef386115..058749ba 100644 --- a/collects/tests/typed-scheme/unit-tests/typecheck-tests.rkt +++ b/collects/tests/typed-scheme/unit-tests/typecheck-tests.rkt @@ -1355,6 +1355,33 @@ (promise-running? p)) B) |# + ;Kernel Structs, check that their hidden identifiers type + ;Currently broken in test-suite because of binding differences + #; + (tc-e (void exn + exn:fail + exn:fail:contract + exn:fail:contract:arity + exn:fail:contract:divide-by-zero + exn:fail:contract:non-fixnum-result + exn:fail:contract:continuation + exn:fail:contract:variable + exn:fail:syntax + exn:fail:read + exn:fail:read:eof + exn:fail:read:non-char + exn:fail:filesystem + exn:fail:filesystem:exists + exn:fail:filesystem:version + exn:fail:network + exn:fail:out-of-memory + exn:fail:unsupported + exn:fail:user + exn:break + arity-at-least + date + srcloc) -Void) + ) (test-suite diff --git a/collects/typed-scheme/base-env/base-structs.rkt b/collects/typed-scheme/base-env/base-structs.rkt index 84a33649..833de9df 100644 --- a/collects/typed-scheme/base-env/base-structs.rkt +++ b/collects/typed-scheme/base-env/base-structs.rkt @@ -9,29 +9,29 @@ (only-in (types convenience) [make-arr* make-arr]) (typecheck tc-structs)) -(require (for-template racket/base)) +(require (for-template racket/base (prefix-in k: '#%kernel))) (provide initialize-structs) (define-syntax define-hierarchy (syntax-rules (define-hierarchy) - [(_ parent ([name : type] ...) - (define-hierarchy child (spec ...) grand ...) + [(_ parent (opts ...) ([name : type] ...) + (define-hierarchy child (child-opts ...) (spec ...) grand ...) ...) (begin - (d-s parent ([name : type] ...)) - (define-sub-hierarchy [child parent] (type ...) (spec ...) grand ...) + (d-s parent ([name : type] ...) opts ...) + (define-sub-hierarchy [child parent] (type ...) (child-opts ...) (spec ...) grand ...) ...)])) (define-syntax define-sub-hierarchy (syntax-rules (define-hierarchy) - [(_ [child parent] (inheritance ...) ([name : type] ...) - (define-hierarchy grandchild (spec ...) great ...) + [(_ [child parent] (inheritance ...) (opts ...) ([name : type] ...) + (define-hierarchy grandchild (grandchild-opts ...)(spec ...) great ...) ...) (begin - (d-s [child parent] ([name : type] ...) (inheritance ...)) + (d-s [child parent] ([name : type] ...) (inheritance ...) opts ...) (define-sub-hierarchy [grandchild child] - (inheritance ... type ...) (spec ...) + (inheritance ... type ...) (grandchild-opts ...) (spec ...) great ...) ...)])) @@ -40,14 +40,14 @@ (define (initialize-structs) - (define-hierarchy srcloc + (define-hierarchy srcloc (#:kernel-maker k:srcloc) ([source : Univ] [line : (*Un -Integer (-val #f))] [column : (*Un -Integer (-val #f))] [position : (*Un -Integer (-val #f))] [span : (*Un -Integer (-val #f))])) - (define-hierarchy date + (define-hierarchy date (#:kernel-maker k:date) ([second : -Number] [minute : -Number] [hour : -Number] @@ -59,41 +59,42 @@ [dst? : -Boolean] [time-zone-offset : -Number])) - (define-hierarchy arity-at-least + (define-hierarchy arity-at-least (#:kernel-maker k:arity-at-least) ([value : -Nat])) - (define-hierarchy exn + (define-hierarchy exn (#:kernel-maker k:exn) ([message : -String] [continuation-marks : -Cont-Mark-Set]) - (define-hierarchy exn:break ([continuation : top-func])) + (define-hierarchy exn:break (#:kernel-maker k:exn:break) + ([continuation : top-func])) - (define-hierarchy exn:fail () + (define-hierarchy exn:fail (#:kernel-maker k:exn:fail) () - (define-hierarchy exn:fail:contract () - (define-hierarchy exn:fail:contract:arity ()) - (define-hierarchy exn:fail:contract:divide-by-zero ()) - (define-hierarchy exn:fail:contract:non-fixnum-result ()) - (define-hierarchy exn:fail:contract:continuation ()) - (define-hierarchy exn:fail:contract:variable ())) + (define-hierarchy exn:fail:contract (#:kernel-maker k:exn:fail:contract) () + (define-hierarchy exn:fail:contract:arity (#:kernel-maker k:exn:fail:contract:arity) ()) + (define-hierarchy exn:fail:contract:divide-by-zero (#:kernel-maker k:exn:fail:contract:divide-by-zero) ()) + (define-hierarchy exn:fail:contract:non-fixnum-result (#:kernel-maker k:exn:fail:contract:non-fixnum-result) ()) + (define-hierarchy exn:fail:contract:continuation (#:kernel-maker k:exn:fail:contract:continuation) ()) + (define-hierarchy exn:fail:contract:variable (#:kernel-maker k:exn:fail:contract:variable) ())) - (define-hierarchy exn:fail:syntax ([exprs : (-lst (-Syntax Univ))])) + (define-hierarchy exn:fail:syntax (#:kernel-maker k:exn:fail:syntax) ([exprs : (-lst (-Syntax Univ))])) - (define-hierarchy exn:fail:read + (define-hierarchy exn:fail:read (#:kernel-maker k:exn:fail:read) ([srclocs : (-lst Univ)]) ;; cce: Univ here should be srcloc - (define-hierarchy exn:fail:read:eof ()) - (define-hierarchy exn:fail:read:non-char ())) + (define-hierarchy exn:fail:read:eof (#:kernel-maker k:exn:fail:read:eof) ()) + (define-hierarchy exn:fail:read:non-char (#:kernel-maker k:exn:fail:read:non-char) ())) - (define-hierarchy exn:fail:filesystem () - (define-hierarchy exn:fail:filesystem:exists ()) - (define-hierarchy exn:fail:filesystem:version ())) + (define-hierarchy exn:fail:filesystem (#:kernel-maker k:exn:fail:filesystem) () + (define-hierarchy exn:fail:filesystem:exists (#:kernel-maker k:exn:fail:filesystem:exists) ()) + (define-hierarchy exn:fail:filesystem:version (#:kernel-maker k:exn:fail:filesystem:version) ())) - (define-hierarchy exn:fail:network ()) + (define-hierarchy exn:fail:network (#:kernel-maker k:exn:fail:network) ()) - (define-hierarchy exn:fail:out-of-memory ()) + (define-hierarchy exn:fail:out-of-memory (#:kernel-maker k:exn:fail:out-of-memory) ()) - (define-hierarchy exn:fail:unsupported ()) + (define-hierarchy exn:fail:unsupported (#:kernel-maker k:exn:fail:unsupported) ()) - (define-hierarchy exn:fail:user ()))) + (define-hierarchy exn:fail:user (#:kernel-maker k:exn:fail:user) ()))) ;; cce: adding exn:break would require a generic type for continuations (void)) diff --git a/collects/typed-scheme/typecheck/tc-structs.rkt b/collects/typed-scheme/typecheck/tc-structs.rkt index 5befcc4c..5f62b267 100644 --- a/collects/typed-scheme/typecheck/tc-structs.rkt +++ b/collects/typed-scheme/typecheck/tc-structs.rkt @@ -17,7 +17,9 @@ listof any/c or/c [->* c->*] [-> c->]) - (for-syntax scheme/base)) + (for-syntax + syntax/parse + scheme/base)) (require (for-template scheme/base @@ -282,25 +284,38 @@ ;; register a struct type ;; convenience function for built-in structs -;; tc/builtin-struct : identifier identifier Listof[identifier] Listof[Type] Listof[Type] -> void -(define/cond-contract (tc/builtin-struct nm parent flds tys #;parent-tys) +;; tc/builtin-struct : identifier Maybe[identifier] Listof[identifier] Listof[Type] Maybe[identifier] Listof[Type] -> void +(define/cond-contract (tc/builtin-struct nm parent flds tys kernel-maker #;parent-tys) (c-> identifier? (or/c #f identifier?) (listof identifier?) - (listof Type/c) #;(listof fld?) + (listof Type/c) (or/c #f identifier?) #;(listof fld?) any/c) (let* ([parent-name (if parent (make-Name parent) #f)] [parent-flds (if parent (get-parent-flds parent-name) null)]) - (mk/register-sty nm flds parent-name parent-flds tys + (let ((defs (mk/register-sty nm flds parent-name parent-flds tys #:mutable #t))) + (if kernel-maker + (let* ((result-type (lookup-type-name nm)) + (ty (->* tys result-type))) + (register-type kernel-maker ty) + (cons (make-def-binding kernel-maker ty) defs)) + defs)))) + ;; syntax for tc/builtin-struct (define-syntax (d-s stx) - (syntax-case stx (:) - [(_ (nm par) ([fld : ty] ...) (par-ty ...)) + (define-splicing-syntax-class options + (pattern (~optional (~seq #:kernel-maker maker:id)) + #:attr kernel-maker (if (attribute maker) #'(quote-syntax maker) #'#f))) + + (syntax-parse stx + [(_ (nm:id par:id) ([fld:id (~datum :) ty] ...) (par-ty ...) opts:options) #'(tc/builtin-struct #'nm #'par (list #'fld ...) - (list ty ...))] - [(_ nm ([fld : ty] ...)) + (list ty ...) + opts.kernel-maker)] + [(_ nm:id ([fld:id (~datum :) ty] ...) opts:options) #'(tc/builtin-struct #'nm #f (list #'fld ...) - (list ty ...))])) + (list ty ...) + opts.kernel-maker)]))