define constructor accessors
This commit is contained in:
parent
e75af5ae1c
commit
d523dc7937
|
@ -617,6 +617,11 @@
|
||||||
#:with TypeConsExpander (format-id #'TypeCons "~~~a" #'TypeCons)
|
#:with TypeConsExpander (format-id #'TypeCons "~~~a" #'TypeCons)
|
||||||
#:with TypeConsExtraInfo (format-id #'TypeCons "~a-extra-info" #'TypeCons)
|
#:with TypeConsExtraInfo (format-id #'TypeCons "~a-extra-info" #'TypeCons)
|
||||||
#:with (StructName Cons- type-tag) (generate-temporaries #'(Cons Cons Cons))
|
#:with (StructName Cons- type-tag) (generate-temporaries #'(Cons Cons Cons))
|
||||||
|
#:with (accessor ...) (for/list ([slot-name (in-syntax #'(slot ...))])
|
||||||
|
(format-id slot-name "~a-~a" #'Cons slot-name))
|
||||||
|
#:with (accessor- ...) (for/list ([slot-name (in-syntax #'(slot ...))])
|
||||||
|
(format-id #'StructName "~a-~a" #'StructName slot-name))
|
||||||
|
#:with (acc-defs ...) (mk-accessors #'(accessor ...) #'(accessor- ...) #'TypeCons #'(slot ...))
|
||||||
(define arity (stx-length #'(slot ...)))
|
(define arity (stx-length #'(slot ...)))
|
||||||
#`(begin-
|
#`(begin-
|
||||||
(struct- StructName (slot ...) #:reflection-name 'Cons #:transparent)
|
(struct- StructName (slot ...) #:reflection-name 'Cons #:transparent)
|
||||||
|
@ -630,7 +635,14 @@
|
||||||
(define-syntax GetTypeParams (mk-type-params-fetcher #'TypeCons))
|
(define-syntax GetTypeParams (mk-type-params-fetcher #'TypeCons))
|
||||||
(define-syntax Cons
|
(define-syntax Cons
|
||||||
(user-ctor #'Cons- #'StructName 'type-tag))
|
(user-ctor #'Cons- #'StructName 'type-tag))
|
||||||
(define-syntax Cons- (mk-constructor-type-rule #,arity #'StructName #'TypeCons)))]))
|
(define-syntax Cons- (mk-constructor-type-rule #,arity #'StructName #'TypeCons))
|
||||||
|
#,@(mk-accessors #'(accessor ...) #'(accessor- ...) #'TypeCons #'(slot ...)))]))
|
||||||
|
|
||||||
|
(define-for-syntax (mk-accessors accessors accessors- TypeCons slots)
|
||||||
|
(for/list ([accessor (in-syntax accessors)]
|
||||||
|
[accessor- (in-syntax accessors-)]
|
||||||
|
[slot (in-syntax slots)])
|
||||||
|
#`(define-typed-variable-rename+ #,accessor ≫ #,accessor- : (∀+ #,slots (→fn (#,TypeCons #,@slots) #,slot)))))
|
||||||
|
|
||||||
;; (require-struct chicken #:as Chicken #:from "some-mod.rkt") will
|
;; (require-struct chicken #:as Chicken #:from "some-mod.rkt") will
|
||||||
;; - extract the struct-info for chicken, and ensure that it is immutable, has a set number of fields
|
;; - extract the struct-info for chicken, and ensure that it is immutable, has a set number of fields
|
||||||
|
@ -1449,6 +1461,11 @@
|
||||||
(make-variable-like-transformer (add-orig (attach #'x- ': (deserialize-syntax #'serialized-τ)) #'x)))
|
(make-variable-like-transformer (add-orig (attach #'x- ': (deserialize-syntax #'serialized-τ)) #'x)))
|
||||||
(define- x- e))]))
|
(define- x- e))]))
|
||||||
|
|
||||||
|
(define-simple-macro (define-typed-variable-rename+ x:id (~datum ≫) x-:id (~datum :) τ:type)
|
||||||
|
#:with serialized-τ (serialize-syntax #'τ.norm)
|
||||||
|
(define-syntax x
|
||||||
|
(make-variable-like-transformer (add-orig (attach #'x- ': (deserialize-syntax #'serialized-τ)) #'x))))
|
||||||
|
|
||||||
;; copied from ext-stlc
|
;; copied from ext-stlc
|
||||||
(define-typed-syntax define
|
(define-typed-syntax define
|
||||||
[(_ x:id (~datum :) τ:type e:expr) ≫
|
[(_ x:id (~datum :) τ:type e:expr) ≫
|
||||||
|
|
Loading…
Reference in New Issue