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

Fix types of kernel struct constructors to include parent fields.

Browse Source 
Merge to 5.1.2.
This commit is contained in:
Sam Tobin-Hochstadt 2011-07-20 14:50:45 -04:00
parent 59f0732fa0
commit 7a763a2da8
2 changed files with 14 additions and 13 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

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

@ -1385,9 +1385,10 @@
exn:break exn:break
arity-at-least arity-at-least
date date
srcloc) -Void) srcloc)
-Void)
[tc-e (raise (exn:fail:contract "1" (current-continuation-marks))) (t:Un)]
[tc-err (exn:fail:contract)]
) )
(test-suite (test-suite
"check-type tests" "check-type tests"

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

@ -288,16 +288,16 @@
(c-> identifier? (or/c #f identifier?) (listof identifier?) (c-> identifier? (or/c #f identifier?) (listof identifier?)
(listof Type/c) (or/c #f identifier?) #;(listof fld?) (listof Type/c) (or/c #f identifier?) #;(listof fld?)
any/c) any/c)
(let* ([parent-name (if parent (make-Name parent) #f)] (define parent-name (if parent (make-Name parent) #f))
[parent-flds (if parent (get-parent-flds parent-name) null)]) (define parent-flds (if parent (get-parent-flds parent-name) null))
(let ((defs (mk/register-sty nm flds parent-name parent-flds tys (define parent-tys (map fld-t parent-flds))
#:mutable #t))) (define defs (mk/register-sty nm flds parent-name parent-flds tys #:mutable #t))
(if kernel-maker (if kernel-maker
(let* ((result-type (lookup-type-name nm)) (let* ([result-type (lookup-type-name nm)]
(ty (->* tys result-type))) [ty (->* (append parent-tys tys) result-type)])
(register-type kernel-maker ty) (register-type kernel-maker ty)
(cons (make-def-binding kernel-maker ty) defs)) (cons (make-def-binding kernel-maker ty) defs))
defs)))) defs))
;; syntax for tc/builtin-struct ;; syntax for tc/builtin-struct