suzanne.soy/racket
1
0
Fork 0
Code Issues Pull Requests Actions Packages Projects Releases Wiki Activity

Add types for kernel struct constructors.

Browse Source
This commit is contained in:
Eric Dobson 2011-07-04 14:46:34 -04:00 committed by Vincent St-Amour
parent fc8ed9772a
commit 046d476970
3 changed files with 85 additions and 42 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

27
collects/tests/typed-scheme/unit-tests/typecheck-tests.rkt
View File

@ -1355,6 +1355,33 @@
(promise-running? p)) B) (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 (test-suite

65
collects/typed-scheme/base-env/base-structs.rkt
View File

@ -9,29 +9,29 @@
(only-in (types convenience) [make-arr* make-arr]) (only-in (types convenience) [make-arr* make-arr])
(typecheck tc-structs)) (typecheck tc-structs))
(require (for-template racket/base)) (require (for-template racket/base (prefix-in k: '#%kernel)))
(provide initialize-structs) (provide initialize-structs)
(define-syntax define-hierarchy (define-syntax define-hierarchy
(syntax-rules (define-hierarchy) (syntax-rules (define-hierarchy)
[(_ parent ([name : type] ...) [(_ parent (opts ...) ([name : type] ...)
(define-hierarchy child (spec ...) grand ...) (define-hierarchy child (child-opts ...) (spec ...) grand ...)
...) ...)
(begin (begin
(d-s parent ([name : type] ...)) (d-s parent ([name : type] ...) opts ...)
(define-sub-hierarchy [child parent] (type ...) (spec ...) grand ...) (define-sub-hierarchy [child parent] (type ...) (child-opts ...) (spec ...) grand ...)
...)])) ...)]))
(define-syntax define-sub-hierarchy (define-syntax define-sub-hierarchy
(syntax-rules (define-hierarchy) (syntax-rules (define-hierarchy)
[(_ [child parent] (inheritance ...) ([name : type] ...) [(_ [child parent] (inheritance ...) (opts ...) ([name : type] ...)
(define-hierarchy grandchild (spec ...) great ...) (define-hierarchy grandchild (grandchild-opts ...)(spec ...) great ...)
...) ...)
(begin (begin
(d-s [child parent] ([name : type] ...) (inheritance ...)) (d-s [child parent] ([name : type] ...) (inheritance ...) opts ...)
(define-sub-hierarchy [grandchild child] (define-sub-hierarchy [grandchild child]
(inheritance ... type ...) (spec ...) (inheritance ... type ...) (grandchild-opts ...) (spec ...)
great great
...) ...)
...)])) ...)]))
@ -40,14 +40,14 @@
(define (initialize-structs) (define (initialize-structs)
(define-hierarchy srcloc (define-hierarchy srcloc (#:kernel-maker k:srcloc)
([source : Univ] ([source : Univ]
[line : (*Un -Integer (-val #f))] [line : (*Un -Integer (-val #f))]
[column : (*Un -Integer (-val #f))] [column : (*Un -Integer (-val #f))]
[position : (*Un -Integer (-val #f))] [position : (*Un -Integer (-val #f))]
[span : (*Un -Integer (-val #f))])) [span : (*Un -Integer (-val #f))]))
(define-hierarchy date (define-hierarchy date (#:kernel-maker k:date)
([second : -Number] ([second : -Number]
[minute : -Number] [minute : -Number]
[hour : -Number] [hour : -Number]
@ -59,41 +59,42 @@
[dst? : -Boolean] [dst? : -Boolean]
[time-zone-offset : -Number])) [time-zone-offset : -Number]))
(define-hierarchy arity-at-least (define-hierarchy arity-at-least (#:kernel-maker k:arity-at-least)
([value : -Nat])) ([value : -Nat]))
(define-hierarchy exn (define-hierarchy exn (#:kernel-maker k:exn)
([message : -String] [continuation-marks : -Cont-Mark-Set]) ([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 (#:kernel-maker k:exn:fail:contract) ()
(define-hierarchy exn:fail:contract:arity ()) (define-hierarchy exn:fail:contract:arity (#:kernel-maker k:exn:fail:contract:arity) ())
(define-hierarchy exn:fail:contract:divide-by-zero ()) (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 ()) (define-hierarchy exn:fail:contract:non-fixnum-result (#:kernel-maker k:exn:fail:contract:non-fixnum-result) ())
(define-hierarchy exn:fail:contract:continuation ()) (define-hierarchy exn:fail:contract:continuation (#:kernel-maker k:exn:fail:contract:continuation) ())
(define-hierarchy exn:fail:contract:variable ())) (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 ([srclocs : (-lst Univ)]) ;; cce: Univ here should be srcloc
(define-hierarchy exn:fail:read:eof ()) (define-hierarchy exn:fail:read:eof (#:kernel-maker k:exn:fail:read:eof) ())
(define-hierarchy exn:fail:read:non-char ())) (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 (#:kernel-maker k:exn:fail:filesystem) ()
(define-hierarchy exn:fail:filesystem:exists ()) (define-hierarchy exn:fail:filesystem:exists (#:kernel-maker k:exn:fail:filesystem:exists) ())
(define-hierarchy exn:fail:filesystem:version ())) (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 ;; cce: adding exn:break would require a generic type for continuations
(void)) (void))

35
collects/typed-scheme/typecheck/tc-structs.rkt
View File

@ -17,7 +17,9 @@
listof any/c or/c listof any/c or/c
[->* c->*] [->* c->*]
[-> c->]) [-> c->])
(for-syntax scheme/base)) (for-syntax
syntax/parse
scheme/base))
(require (for-template scheme/base (require (for-template scheme/base
@ -282,25 +284,38 @@
;; register a struct type ;; register a struct type
;; convenience function for built-in structs ;; convenience function for built-in structs
;; tc/builtin-struct : identifier identifier Listof[identifier] Listof[Type] Listof[Type] -> void ;; 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 #;parent-tys) (define/cond-contract (tc/builtin-struct nm parent flds tys kernel-maker #;parent-tys)
(c-> identifier? (or/c #f identifier?) (listof identifier?) (c-> identifier? (or/c #f identifier?) (listof identifier?)
(listof Type/c) #;(listof fld?) (listof Type/c) (or/c #f identifier?) #;(listof fld?)
any/c) any/c)
(let* ([parent-name (if parent (make-Name parent) #f)] (let* ([parent-name (if parent (make-Name parent) #f)]
[parent-flds (if parent (get-parent-flds parent-name) null)]) [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))) #: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 ;; syntax for tc/builtin-struct
(define-syntax (d-s stx) (define-syntax (d-s stx)
(syntax-case stx (:) (define-splicing-syntax-class options
[(_ (nm par) ([fld : ty] ...) (par-ty ...)) (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 #'(tc/builtin-struct #'nm #'par
(list #'fld ...) (list #'fld ...)
(list ty ...))] (list ty ...)
[(_ nm ([fld : ty] ...)) opts.kernel-maker)]
[(_ nm:id ([fld:id (~datum :) ty] ...) opts:options)
#'(tc/builtin-struct #'nm #f #'(tc/builtin-struct #'nm #f
(list #'fld ...) (list #'fld ...)
(list ty ...))])) (list ty ...)
opts.kernel-maker)]))