typed: fix required struct type constructors to know their arity
This commit is contained in:
parent
e4f72519f0
commit
fc038877f5
|
@ -778,6 +778,7 @@
|
||||||
(define-syntax (require-struct stx)
|
(define-syntax (require-struct stx)
|
||||||
(syntax-parse stx
|
(syntax-parse stx
|
||||||
[(_ ucons:id #:as ty-cons:id #:from lib (~optional (~and omit-accs #:omit-accs)))
|
[(_ ucons:id #:as ty-cons:id #:from lib (~optional (~and omit-accs #:omit-accs)))
|
||||||
|
;; TBH I'm not sure why I don't need to SLIAB TypeCons and Cons-
|
||||||
(with-syntax* ([TypeCons #'ty-cons]
|
(with-syntax* ([TypeCons #'ty-cons]
|
||||||
[MakeTypeCons (format-id #'TypeCons "make-~a" #'TypeCons)]
|
[MakeTypeCons (format-id #'TypeCons "make-~a" #'TypeCons)]
|
||||||
[GetTypeParams (format-id #'TypeCons "get-~a-type-params" #'TypeCons)]
|
[GetTypeParams (format-id #'TypeCons "get-~a-type-params" #'TypeCons)]
|
||||||
|
@ -800,27 +801,44 @@
|
||||||
(raise-syntax-error #f "structs with super-type not supported" #'#,stx #'ucons))
|
(raise-syntax-error #f "structs with super-type not supported" #'#,stx #'ucons))
|
||||||
(define arity (length accs/rev))
|
(define arity (length accs/rev))
|
||||||
)
|
)
|
||||||
(define-for-syntax (TypeConsExtraInfo stx)
|
(define-syntax finish-type-defs
|
||||||
(list #'type-tag #'MakeTypeCons #'GetTypeParams)
|
(finish-require-struct-typedef #'lib #'Cons- #'TypeConsExtraInfo #'type-tag #'MakeTypeCons #'GetTypeParams #'orig-struct-info #'accs/rev arity #,(attribute omit-accs)))
|
||||||
)
|
(finish-type-defs ucons TypeCons)
|
||||||
|
)))]))
|
||||||
|
|
||||||
|
;; This is so that the arity of the struct can be included in the generated typedef
|
||||||
|
(define-for-syntax ((finish-require-struct-typedef lib
|
||||||
|
Cons-
|
||||||
|
TypeConsExtraInfo
|
||||||
|
type-tag
|
||||||
|
MakeTypeCons
|
||||||
|
GetTypeParams
|
||||||
|
orig-struct-info
|
||||||
|
accs/rev
|
||||||
|
arity
|
||||||
|
omit-accs?)
|
||||||
|
stx)
|
||||||
|
(syntax-parse stx
|
||||||
|
[(_ ucons:id TypeCons:id)
|
||||||
|
(quasisyntax/loc #'ucons
|
||||||
|
(begin-
|
||||||
|
(define-for-syntax (#,TypeConsExtraInfo stx)
|
||||||
|
(list #'#,type-tag #'#,MakeTypeCons #'#,GetTypeParams))
|
||||||
(define-product-type TypeCons
|
(define-product-type TypeCons
|
||||||
;; issue: arity needs to parse as an exact-nonnegative-integer
|
#:arity = #,arity
|
||||||
;; fix: check arity in MakeTypeCons
|
#:extra-info #,TypeConsExtraInfo
|
||||||
#:arity >= 0
|
|
||||||
#:extra-info TypeConsExtraInfo
|
|
||||||
#:implements get-resugar-info (resugar-ctor #'TypeCons))
|
#:implements get-resugar-info (resugar-ctor #'TypeCons))
|
||||||
(define-syntax MakeTypeCons (mk-ctor-rewriter #'TypeCons))
|
(define-syntax #,MakeTypeCons (mk-ctor-rewriter #'TypeCons))
|
||||||
(define-syntax GetTypeParams (mk-type-params-fetcher #'TypeCons))
|
(define-syntax #,GetTypeParams (mk-type-params-fetcher #'TypeCons))
|
||||||
(define-syntax Cons- (mk-constructor-type-rule arity #'orig-struct-info #'TypeCons))
|
(define-syntax #,Cons- (mk-constructor-type-rule #,arity #'#,orig-struct-info #'TypeCons))
|
||||||
(define-syntax ucons
|
(define-syntax ucons
|
||||||
(user-ctor #'Cons- #'orig-struct-info 'type-tag #'TypeCons (cleanup-accs #'ucons accs/rev)))
|
(user-ctor #'#,Cons- #'#,orig-struct-info '#,type-tag #'TypeCons (cleanup-accs #'ucons #,accs/rev)))
|
||||||
#,(unless (attribute omit-accs)
|
#,(unless omit-accs?
|
||||||
(quasisyntax/loc stx
|
(quasisyntax/loc #'ucons
|
||||||
(begin-
|
(begin-
|
||||||
(define-syntax mk-struct-accs
|
(define-syntax mk-struct-accs
|
||||||
(define-struct-accs accs/rev #'TypeCons #'lib))
|
(define-struct-accs #,accs/rev #'TypeCons #'#,lib))
|
||||||
(mk-struct-accs ucons))))
|
(mk-struct-accs ucons))))))]))
|
||||||
)))]))
|
|
||||||
|
|
||||||
(begin-for-syntax
|
(begin-for-syntax
|
||||||
(define-syntax ~constructor-extra-info
|
(define-syntax ~constructor-extra-info
|
||||||
|
|
Loading…
Reference in New Issue