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

Add types for kernel struct constructors.

Browse Source 
original commit: 046d4769704809840c3850b501ec378cdbcdf7e7
This commit is contained in:
Eric Dobson 2011-07-04 14:46:34 -04:00 committed by Vincent St-Amour
parent f07f04b81d
commit 1c0f8a6df8
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)
|#
;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

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

@ -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))

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

@ -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)]))