Fix types of kernel struct constructors to include parent fields.

Merge to 5.1.2.
(cherry picked from commit 7a763a2da8)
This commit is contained in:
Sam Tobin-Hochstadt 2011-07-20 14:50:45 -04:00 committed by Eli Barzilay
parent 35bbe90dcb
commit 925a6ae9f2
2 changed files with 14 additions and 13 deletions

View File

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

View File

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