Add prop:struct-field-info
This commit adds `prop:struct-field-info` which is implemented to provide static information about field names. The property is attached to all struct types generated by `define-struct`. The commit also modifies kernstructs to have the property. Finally, the commit switches `struct-copy` to use the static field name information when it's available. It remains to change `contract-out` and `match`'s `struct*` to recognize/attach this new property, but this could be done separately in the future. This PR is largely based on racket/racket#732, though the approach is slightly different.
This commit is contained in:
sorawee
GitHub
parent
1118705bef
commit
dff6259ff0
|
|
@ -789,7 +789,8 @@ derived from @racket[struct:struct-info] or with the
|
|||
@racket[prop:struct-info] property that also implements
|
||||
@racket[prop:procedure], and where the instance is further is wrapped
|
||||
by @racket[make-set!-transformer]. In addition, the representation may
|
||||
implement the @racket[prop:struct-auto-info] property.
|
||||
implement the @racket[prop:struct-auto-info] and
|
||||
@racket[prop:struct-field-info] properties.
|
||||
|
||||
Use @racket[struct-info?] to recognize all allowed forms of the
|
||||
information, and use @racket[extract-struct-info] to obtain a list
|
||||
|
|
@ -919,6 +920,36 @@ subset of the accessor identifiers for the structure type described by
|
|||
@racket[sai], and the second list should be a subset of the mutator
|
||||
identifiers. The two subsets correspond to @racket[#:auto] fields.}
|
||||
|
||||
@deftogether[(
|
||||
@defthing[prop:struct-field-info struct-type-property?]
|
||||
@defproc[(struct-field-info? [v any/c]) boolean?]
|
||||
@defproc[(struct-field-info-list [sfi struct-field-info?]) (listof symbol?)])]{
|
||||
|
||||
The @racket[prop:struct-field-info] property is implemented to provide
|
||||
static information about field names in a structure type. The property
|
||||
value must be a procedure that accepts an instance structure to which
|
||||
the property is given, and the result must be a list of symbols
|
||||
suitable as a result from @racket[struct-field-info-list].
|
||||
|
||||
The @racket[struct-field-info?] predicate recognizes values that
|
||||
implement the @racket[prop:struct-field-info] property.
|
||||
|
||||
The @racket[struct-field-info-list] function extracts a list of
|
||||
symbols from a value that implements the @racket[prop:struct-field-info] property.
|
||||
The list should contain every immediate field name
|
||||
(that is, not including fields from its super struct type)
|
||||
in the reverse order.
|
||||
|
||||
@examples[#:escape no-escape
|
||||
#:eval struct-eval
|
||||
(struct foo (x))
|
||||
(struct bar foo (y z))
|
||||
(define-syntax (get-bar-field-names stx)
|
||||
#`'#,(struct-field-info-list (syntax-local-value #'bar)))
|
||||
(get-bar-field-names)
|
||||
]
|
||||
}
|
||||
|
||||
@; ----------------------------------------------------------------------
|
||||
|
||||
@close-eval[struct-eval]
|
||||
|
|
|
|||
|
|
@ -1467,4 +1467,14 @@
|
|||
|
||||
;; ----------------------------------------
|
||||
|
||||
(let ()
|
||||
(struct foo (x))
|
||||
(struct bar foo (y z))
|
||||
(define-syntax (get-bar-field-names stx)
|
||||
#`'#,(struct-field-info-list (syntax-local-value #'bar)))
|
||||
(define (get-bar-field-names*) (get-bar-field-names))
|
||||
(test '(z y) get-bar-field-names*))
|
||||
|
||||
;; ----------------------------------------
|
||||
|
||||
(report-errs)
|
||||
|
|
|
|||
|
|
@ -20,13 +20,25 @@
|
|||
(for-syntax
|
||||
(rename checked-struct-info-rec? checked-struct-info?)))
|
||||
|
||||
(define-values-for-syntax
|
||||
(struct:struct-field-info
|
||||
make-struct-field-info
|
||||
struct-field-info-rec?
|
||||
struct-field-info-ref
|
||||
struct-field-info-set!)
|
||||
(make-struct-type 'struct-field-info struct:struct-info
|
||||
1 0 #f
|
||||
(list (cons prop:struct-field-info
|
||||
(lambda (rec)
|
||||
(struct-field-info-ref rec 0))))))
|
||||
|
||||
(define-values-for-syntax
|
||||
(struct:struct-auto-info
|
||||
make-struct-auto-info
|
||||
struct-auto-info-rec?
|
||||
struct-auto-info-ref
|
||||
struct-auto-info-set!)
|
||||
(make-struct-type 'struct-auto-info struct:struct-info
|
||||
(make-struct-type 'struct-auto-info struct:struct-field-info
|
||||
1 0 #f
|
||||
(list (cons prop:struct-auto-info
|
||||
(lambda (rec)
|
||||
|
|
@ -48,10 +60,10 @@
|
|||
"bad syntax;\n identifier for static struct-type information cannot be used as an expression"
|
||||
stx))
|
||||
null
|
||||
(lambda (proc autos info)
|
||||
(lambda (proc fields autos info)
|
||||
(if (and (procedure? proc)
|
||||
(procedure-arity-includes? proc 0))
|
||||
(values proc autos)
|
||||
(values proc fields autos)
|
||||
(raise-argument-error 'make-struct-info
|
||||
"(procedure-arity-includes/c 0)"
|
||||
proc)))))
|
||||
|
|
@ -412,7 +424,7 @@
|
|||
(and (identifier? #'id)
|
||||
(identifier? #'super-id))
|
||||
(values #'id #'super-id)]
|
||||
[else
|
||||
[_
|
||||
(raise-syntax-error
|
||||
#f
|
||||
"bad syntax;\n expected <id> for structure-type name or (<id> <id>) for name and supertype\n name"
|
||||
|
|
@ -725,6 +737,7 @@
|
|||
(if super-expr
|
||||
#f
|
||||
#t))))
|
||||
'#,(map field-id (reverse fields))
|
||||
#,@(if include-autos?
|
||||
(list #`(list (list #,@(map protect
|
||||
(list-tail sels (- (length sels) auto-count)))
|
||||
|
|
@ -896,26 +909,46 @@
|
|||
"unable to cope with a struct type whose predicate doesn't end with `?'"
|
||||
orig-stx)]))
|
||||
|
||||
(define-for-syntax (find-accessor the-struct-info fld stx)
|
||||
(define-for-syntax (find-accessor/no-field-info the-struct-info fld stx)
|
||||
(define accessors (list-ref the-struct-info 3))
|
||||
(define parent (list-ref the-struct-info 5))
|
||||
(define num-fields (length accessors))
|
||||
(define num-super-fields
|
||||
(if (identifier? parent) (length (cadddr (id->struct-info parent stx))) 0))
|
||||
(if (identifier? parent)
|
||||
(let-values ([(parent-struct-info _) (id->struct-info parent stx)])
|
||||
(length (cadddr parent-struct-info)))
|
||||
0))
|
||||
(define num-own-fields (- num-fields num-super-fields))
|
||||
(define own-accessors (take accessors num-own-fields))
|
||||
(define struct-name (predicate->struct-name stx (list-ref the-struct-info 2)))
|
||||
(define accessor-name (string->symbol (format "~a-~a" struct-name (syntax-e fld))))
|
||||
(or (findf (λ (a) (eq? accessor-name (syntax-e a))) own-accessors)
|
||||
(raise-syntax-error
|
||||
#f "accessor name not associated with the given structure type"
|
||||
#f "field name not associated with the given structure type"
|
||||
stx fld)))
|
||||
|
||||
(define-for-syntax (find-accessor/field-info the-struct-info the-field-info fld stx)
|
||||
(define accessors (list-ref the-struct-info 3))
|
||||
(define num-own-fields (length the-field-info))
|
||||
(define own-accessors (take accessors num-own-fields))
|
||||
(car
|
||||
(or (findf (λ (a) (eq? (syntax-e fld) (cdr a))) (map cons own-accessors the-field-info))
|
||||
(raise-syntax-error
|
||||
#f "field name not associated with the given structure type"
|
||||
stx fld))))
|
||||
|
||||
(define-for-syntax (find-accessor the-struct-info maybe-field-info fld stx)
|
||||
(if maybe-field-info
|
||||
(find-accessor/field-info the-struct-info maybe-field-info fld stx)
|
||||
(find-accessor/no-field-info the-struct-info fld stx)))
|
||||
|
||||
(define-for-syntax (id->struct-info id stx)
|
||||
(define the-struct-info (syntax-local-value id (lambda () #f)))
|
||||
(unless (struct-info? the-struct-info)
|
||||
(define compile-time-info (syntax-local-value id (lambda () #f)))
|
||||
(unless (struct-info? compile-time-info)
|
||||
(raise-syntax-error #f "identifier is not bound to a structure type" stx id))
|
||||
(extract-struct-info the-struct-info))
|
||||
(values (extract-struct-info compile-time-info)
|
||||
(and (struct-field-info? compile-time-info)
|
||||
(struct-field-info-list compile-time-info))))
|
||||
|
||||
(define-for-syntax (struct-copy-core stx)
|
||||
(with-syntax ([(form-name info struct-expr field+val ...) stx])
|
||||
|
|
@ -953,7 +986,7 @@
|
|||
an)]))
|
||||
ans)
|
||||
|
||||
(define the-struct-info (id->struct-info #'info stx))
|
||||
(define-values (the-struct-info maybe-field-info) (id->struct-info #'info stx))
|
||||
(define construct (cadr the-struct-info))
|
||||
(define pred (caddr the-struct-info))
|
||||
(define accessors (cadddr the-struct-info))
|
||||
|
|
@ -970,7 +1003,8 @@
|
|||
[else
|
||||
(let ([v (syntax-local-value parent (lambda () #f))])
|
||||
(unless (struct-info? v)
|
||||
(raise-syntax-error #f "unknown parent struct" stx id)) ;; probably won't happen(?)
|
||||
;; this is possible: https://gist.github.com/deeglaze/6ae7424cc2d093661df2
|
||||
(raise-syntax-error #f "unknown parent struct" stx id))
|
||||
(let ([v (extract-struct-info v)])
|
||||
(loop (list-ref v 5))))])))
|
||||
|
||||
|
|
@ -978,15 +1012,16 @@
|
|||
(map (lambda (an)
|
||||
(syntax-case an ()
|
||||
[(field expr)
|
||||
(list (find-accessor the-struct-info #'field stx)
|
||||
(list (find-accessor the-struct-info maybe-field-info #'field stx)
|
||||
#'expr
|
||||
(car (generate-temporaries (list #'field))))]
|
||||
[(field #:parent id expr)
|
||||
(begin
|
||||
(ensure-really-parent #'id)
|
||||
(list (find-accessor (id->struct-info #'id stx) #'field stx)
|
||||
#'expr
|
||||
(car (generate-temporaries (list #'field)))))]))
|
||||
(let-values ([(the-struct-info maybe-field-info) (id->struct-info #'id stx)])
|
||||
(list (find-accessor the-struct-info maybe-field-info #'field stx)
|
||||
#'expr
|
||||
(car (generate-temporaries (list #'field))))))]))
|
||||
ans))
|
||||
|
||||
;; new-binding-for : syntax[field-name] -> (union syntax[expression] #f)
|
||||
|
|
|
|||
|
|
@ -6,12 +6,28 @@
|
|||
(#%require "define.rkt")
|
||||
(#%require (for-syntax "struct-info.rkt"))
|
||||
(#%provide (all-defined))
|
||||
(define-values-for-syntax
|
||||
(struct:struct-field-info
|
||||
make-struct-field-info
|
||||
struct-field-info-rec?
|
||||
struct-field-info-ref
|
||||
struct-field-info-set!)
|
||||
(make-struct-type
|
||||
'struct-field-info
|
||||
struct:struct-info
|
||||
1
|
||||
0
|
||||
#f
|
||||
(list
|
||||
(cons
|
||||
prop:struct-field-info
|
||||
(lambda (rec) (struct-field-info-ref rec 0))))))
|
||||
(define-values-for-syntax
|
||||
(make-self-ctr-struct-info)
|
||||
(letrec-values (((struct: make- ? ref set!)
|
||||
(make-struct-type
|
||||
'self-ctor-struct-info
|
||||
struct:struct-info
|
||||
struct:struct-field-info
|
||||
1
|
||||
0
|
||||
#f
|
||||
|
|
@ -46,6 +62,7 @@
|
|||
(quote-syntax exn-message))
|
||||
'(#f #f)
|
||||
#t))
|
||||
'(continuation-marks message)
|
||||
(λ () (quote-syntax kernel:exn)))))
|
||||
(begin
|
||||
(#%require (rename '#%kernel kernel:exn:fail exn:fail))
|
||||
|
|
@ -62,6 +79,7 @@
|
|||
(quote-syntax exn-message))
|
||||
'(#f #f)
|
||||
(quote-syntax exn)))
|
||||
'()
|
||||
(λ () (quote-syntax kernel:exn:fail)))))
|
||||
(begin
|
||||
(#%require (rename '#%kernel kernel:exn:fail:contract exn:fail:contract))
|
||||
|
|
@ -78,6 +96,7 @@
|
|||
(quote-syntax exn-message))
|
||||
'(#f #f)
|
||||
(quote-syntax exn:fail)))
|
||||
'()
|
||||
(λ () (quote-syntax kernel:exn:fail:contract)))))
|
||||
(begin
|
||||
(#%require
|
||||
|
|
@ -95,6 +114,7 @@
|
|||
(quote-syntax exn-message))
|
||||
'(#f #f)
|
||||
(quote-syntax exn:fail:contract)))
|
||||
'()
|
||||
(λ () (quote-syntax kernel:exn:fail:contract:arity)))))
|
||||
(begin
|
||||
(#%require
|
||||
|
|
@ -115,6 +135,7 @@
|
|||
(quote-syntax exn-message))
|
||||
'(#f #f)
|
||||
(quote-syntax exn:fail:contract)))
|
||||
'()
|
||||
(λ () (quote-syntax kernel:exn:fail:contract:divide-by-zero)))))
|
||||
(begin
|
||||
(#%require
|
||||
|
|
@ -135,6 +156,7 @@
|
|||
(quote-syntax exn-message))
|
||||
'(#f #f)
|
||||
(quote-syntax exn:fail:contract)))
|
||||
'()
|
||||
(λ () (quote-syntax kernel:exn:fail:contract:non-fixnum-result)))))
|
||||
(begin
|
||||
(#%require
|
||||
|
|
@ -155,6 +177,7 @@
|
|||
(quote-syntax exn-message))
|
||||
'(#f #f)
|
||||
(quote-syntax exn:fail:contract)))
|
||||
'()
|
||||
(λ () (quote-syntax kernel:exn:fail:contract:continuation)))))
|
||||
(begin
|
||||
(#%require
|
||||
|
|
@ -175,6 +198,7 @@
|
|||
(quote-syntax exn-message))
|
||||
'(#f #f #f)
|
||||
(quote-syntax exn:fail:contract)))
|
||||
'(id)
|
||||
(λ () (quote-syntax kernel:exn:fail:contract:variable)))))
|
||||
(begin
|
||||
(#%require (rename '#%kernel kernel:exn:fail:syntax exn:fail:syntax))
|
||||
|
|
@ -192,6 +216,7 @@
|
|||
(quote-syntax exn-message))
|
||||
'(#f #f #f)
|
||||
(quote-syntax exn:fail)))
|
||||
'(exprs)
|
||||
(λ () (quote-syntax kernel:exn:fail:syntax)))))
|
||||
(begin
|
||||
(#%require
|
||||
|
|
@ -210,6 +235,7 @@
|
|||
(quote-syntax exn-message))
|
||||
'(#f #f #f)
|
||||
(quote-syntax exn:fail:syntax)))
|
||||
'()
|
||||
(λ () (quote-syntax kernel:exn:fail:syntax:unbound)))))
|
||||
(begin
|
||||
(#%require
|
||||
|
|
@ -232,6 +258,7 @@
|
|||
(quote-syntax exn-message))
|
||||
'(#f #f #f #f)
|
||||
(quote-syntax exn:fail:syntax)))
|
||||
'(path)
|
||||
(λ () (quote-syntax kernel:exn:fail:syntax:missing-module)))))
|
||||
(begin
|
||||
(#%require (rename '#%kernel kernel:exn:fail:read exn:fail:read))
|
||||
|
|
@ -249,6 +276,7 @@
|
|||
(quote-syntax exn-message))
|
||||
'(#f #f #f)
|
||||
(quote-syntax exn:fail)))
|
||||
'(srclocs)
|
||||
(λ () (quote-syntax kernel:exn:fail:read)))))
|
||||
(begin
|
||||
(#%require (rename '#%kernel kernel:exn:fail:read:eof exn:fail:read:eof))
|
||||
|
|
@ -266,6 +294,7 @@
|
|||
(quote-syntax exn-message))
|
||||
'(#f #f #f)
|
||||
(quote-syntax exn:fail:read)))
|
||||
'()
|
||||
(λ () (quote-syntax kernel:exn:fail:read:eof)))))
|
||||
(begin
|
||||
(#%require
|
||||
|
|
@ -284,6 +313,7 @@
|
|||
(quote-syntax exn-message))
|
||||
'(#f #f #f)
|
||||
(quote-syntax exn:fail:read)))
|
||||
'()
|
||||
(λ () (quote-syntax kernel:exn:fail:read:non-char)))))
|
||||
(begin
|
||||
(#%require
|
||||
|
|
@ -301,6 +331,7 @@
|
|||
(quote-syntax exn-message))
|
||||
'(#f #f)
|
||||
(quote-syntax exn:fail)))
|
||||
'()
|
||||
(λ () (quote-syntax kernel:exn:fail:filesystem)))))
|
||||
(begin
|
||||
(#%require
|
||||
|
|
@ -320,6 +351,7 @@
|
|||
(quote-syntax exn-message))
|
||||
'(#f #f)
|
||||
(quote-syntax exn:fail:filesystem)))
|
||||
'()
|
||||
(λ () (quote-syntax kernel:exn:fail:filesystem:exists)))))
|
||||
(begin
|
||||
(#%require
|
||||
|
|
@ -340,6 +372,7 @@
|
|||
(quote-syntax exn-message))
|
||||
'(#f #f)
|
||||
(quote-syntax exn:fail:filesystem)))
|
||||
'()
|
||||
(λ () (quote-syntax kernel:exn:fail:filesystem:version)))))
|
||||
(begin
|
||||
(#%require
|
||||
|
|
@ -360,6 +393,7 @@
|
|||
(quote-syntax exn-message))
|
||||
'(#f #f #f)
|
||||
(quote-syntax exn:fail:filesystem)))
|
||||
'(errno)
|
||||
(λ () (quote-syntax kernel:exn:fail:filesystem:errno)))))
|
||||
(begin
|
||||
(#%require
|
||||
|
|
@ -381,6 +415,7 @@
|
|||
(quote-syntax exn-message))
|
||||
'(#f #f #f)
|
||||
(quote-syntax exn:fail:filesystem)))
|
||||
'(path)
|
||||
(λ () (quote-syntax kernel:exn:fail:filesystem:missing-module)))))
|
||||
(begin
|
||||
(#%require (rename '#%kernel kernel:exn:fail:network exn:fail:network))
|
||||
|
|
@ -397,6 +432,7 @@
|
|||
(quote-syntax exn-message))
|
||||
'(#f #f)
|
||||
(quote-syntax exn:fail)))
|
||||
'()
|
||||
(λ () (quote-syntax kernel:exn:fail:network)))))
|
||||
(begin
|
||||
(#%require
|
||||
|
|
@ -415,6 +451,7 @@
|
|||
(quote-syntax exn-message))
|
||||
'(#f #f #f)
|
||||
(quote-syntax exn:fail:network)))
|
||||
'(errno)
|
||||
(λ () (quote-syntax kernel:exn:fail:network:errno)))))
|
||||
(begin
|
||||
(#%require
|
||||
|
|
@ -432,6 +469,7 @@
|
|||
(quote-syntax exn-message))
|
||||
'(#f #f)
|
||||
(quote-syntax exn:fail)))
|
||||
'()
|
||||
(λ () (quote-syntax kernel:exn:fail:out-of-memory)))))
|
||||
(begin
|
||||
(#%require
|
||||
|
|
@ -449,6 +487,7 @@
|
|||
(quote-syntax exn-message))
|
||||
'(#f #f)
|
||||
(quote-syntax exn:fail)))
|
||||
'()
|
||||
(λ () (quote-syntax kernel:exn:fail:unsupported)))))
|
||||
(begin
|
||||
(#%require (rename '#%kernel kernel:exn:fail:user exn:fail:user))
|
||||
|
|
@ -465,6 +504,7 @@
|
|||
(quote-syntax exn-message))
|
||||
'(#f #f)
|
||||
(quote-syntax exn:fail)))
|
||||
'()
|
||||
(λ () (quote-syntax kernel:exn:fail:user)))))
|
||||
(begin
|
||||
(#%require (rename '#%kernel kernel:exn:break exn:break))
|
||||
|
|
@ -482,6 +522,7 @@
|
|||
(quote-syntax exn-message))
|
||||
'(#f #f #f)
|
||||
(quote-syntax exn)))
|
||||
'(continuation)
|
||||
(λ () (quote-syntax kernel:exn:break)))))
|
||||
(begin
|
||||
(#%require (rename '#%kernel kernel:exn:break:hang-up exn:break:hang-up))
|
||||
|
|
@ -499,6 +540,7 @@
|
|||
(quote-syntax exn-message))
|
||||
'(#f #f #f)
|
||||
(quote-syntax exn:break)))
|
||||
'()
|
||||
(λ () (quote-syntax kernel:exn:break:hang-up)))))
|
||||
(begin
|
||||
(#%require
|
||||
|
|
@ -517,6 +559,7 @@
|
|||
(quote-syntax exn-message))
|
||||
'(#f #f #f)
|
||||
(quote-syntax exn:break)))
|
||||
'()
|
||||
(λ () (quote-syntax kernel:exn:break:terminate)))))
|
||||
(begin
|
||||
(#%require (rename '#%kernel kernel:arity-at-least arity-at-least))
|
||||
|
|
@ -531,6 +574,7 @@
|
|||
(list (quote-syntax arity-at-least-value))
|
||||
'(#f)
|
||||
#t))
|
||||
'(value)
|
||||
(λ () (quote-syntax kernel:arity-at-least)))))
|
||||
(begin
|
||||
(#%require (rename '#%kernel kernel:date date))
|
||||
|
|
@ -555,6 +599,16 @@
|
|||
(quote-syntax date-second))
|
||||
'(#f #f #f #f #f #f #f #f #f #f)
|
||||
#t))
|
||||
'(time-zone-offset
|
||||
dst?
|
||||
year-day
|
||||
week-day
|
||||
year
|
||||
month
|
||||
day
|
||||
hour
|
||||
minute
|
||||
second)
|
||||
(λ () (quote-syntax kernel:date)))))
|
||||
(begin
|
||||
(#%require (rename '#%kernel kernel:date* date*))
|
||||
|
|
@ -581,6 +635,7 @@
|
|||
(quote-syntax date-second))
|
||||
'(#f #f #f #f #f #f #f #f #f #f #f #f)
|
||||
(quote-syntax date)))
|
||||
'(time-zone-name nanosecond)
|
||||
(λ () (quote-syntax kernel:date*)))))
|
||||
(begin
|
||||
(#%require (rename '#%kernel kernel:srcloc srcloc))
|
||||
|
|
@ -600,4 +655,5 @@
|
|||
(quote-syntax srcloc-source))
|
||||
'(#f #f #f #f #f)
|
||||
#t))
|
||||
'(span position column line source)
|
||||
(λ () (quote-syntax kernel:srcloc))))))
|
||||
|
|
|
|||
|
|
@ -13,7 +13,11 @@
|
|||
|
||||
prop:struct-auto-info
|
||||
struct-auto-info?
|
||||
struct-auto-info-lists)
|
||||
struct-auto-info-lists
|
||||
|
||||
prop:struct-field-info
|
||||
struct-field-info?
|
||||
struct-field-info-list)
|
||||
|
||||
(define-values (prop:struct-info has-struct-info-prop? struct-info-prop-ref)
|
||||
(make-struct-type-property 'struct-info
|
||||
|
|
@ -131,4 +135,25 @@
|
|||
(error 'struct-auto-info-lists
|
||||
"struct-auto-info procedure result not properly formed: ~e"
|
||||
l))
|
||||
l)))
|
||||
|
||||
(define-values (prop:struct-field-info
|
||||
struct-field-info?
|
||||
struct-field-info-ref)
|
||||
(make-struct-type-property 'struct-field-info
|
||||
(lambda (val info)
|
||||
(unless (and (procedure? val)
|
||||
(procedure-arity-includes? val 1))
|
||||
(raise-argument-error 'guard-for-prop:struct-field-info "(procedure-arity-includes/c 1)" val))
|
||||
val)))
|
||||
|
||||
(define-values (struct-field-info-list)
|
||||
(lambda (v)
|
||||
(unless (struct-field-info? v)
|
||||
(raise-argument-error 'struct-field-info-list "struct-field-info?" v))
|
||||
(let ([l ((struct-field-info-ref v) v)])
|
||||
(unless (and (list? l) (andmap symbol? l))
|
||||
(error 'struct-field-info-list
|
||||
"struct-field-info procedure result not properly formed: ~e"
|
||||
l))
|
||||
l))))
|
||||
|
|
|
|||
|
|
@ -208,9 +208,22 @@ Not an exception in the above sense:
|
|||
|
||||
(#%provide (all-defined))
|
||||
|
||||
(define-values-for-syntax
|
||||
(struct:struct-field-info
|
||||
make-struct-field-info
|
||||
struct-field-info-rec?
|
||||
struct-field-info-ref
|
||||
struct-field-info-set!)
|
||||
(make-struct-type 'struct-field-info struct:struct-info
|
||||
1 0 #f
|
||||
(list (cons prop:struct-field-info
|
||||
(lambda (rec)
|
||||
(struct-field-info-ref rec 0))))))
|
||||
|
||||
|
||||
(define-values-for-syntax (make-self-ctr-struct-info)
|
||||
(letrec-values ([(struct: make- ? ref set!)
|
||||
(make-struct-type 'self-ctor-struct-info struct:struct-info
|
||||
(make-struct-type 'self-ctor-struct-info struct:struct-field-info
|
||||
1 0 #f
|
||||
(list (cons prop:procedure
|
||||
(lambda (v stx)
|
||||
|
|
@ -230,7 +243,7 @@ Not an exception in the above sense:
|
|||
(define (non-parent x)
|
||||
(or (equal? #f x) (equal? #t x)))
|
||||
|
||||
(define (gen-ds name-string fields parent)
|
||||
(define (gen-ds name-string fields num-selector parent)
|
||||
(let* ([name (sss name-string)]
|
||||
[kern-name (sss "kernel:" name)]
|
||||
[sn (sss "struct:" name)]
|
||||
|
|
@ -238,7 +251,11 @@ Not an exception in the above sense:
|
|||
[pn (sss name "?")]
|
||||
[fds `(list ,@(map (λ (x) `(quote-syntax ,x)) fields))]
|
||||
[fdsset! `'(,@(map (λ (x) #f) fields))]
|
||||
[prnt (if (non-parent parent) #t `(quote-syntax ,parent))])
|
||||
[prnt (if (non-parent parent) #t `(quote-syntax ,parent))]
|
||||
[name-length (string-length (symbol->string name))]
|
||||
[field-names (for/list ([fld (take fields num-selector)])
|
||||
;; add1 for hyphen
|
||||
(string->symbol (substring (symbol->string fld) (add1 name-length))))])
|
||||
`(begin
|
||||
(#%require (rename '#%kernel ,kern-name ,name))
|
||||
(define ,mn ,kern-name)
|
||||
|
|
@ -248,6 +265,7 @@ Not an exception in the above sense:
|
|||
(quote-syntax ,pn)
|
||||
,fds
|
||||
,fdsset! ,prnt))
|
||||
',field-names
|
||||
(λ () (quote-syntax ,kern-name)))))))
|
||||
|
||||
(define (parent-sym x)
|
||||
|
|
@ -262,17 +280,16 @@ Not an exception in the above sense:
|
|||
(if (non-parent exn)
|
||||
null
|
||||
(append (reverse (map (λ (field) (field-name exn field)) (ex-args exn))) (fields (ex-parent exn)))))
|
||||
|
||||
|
||||
(define exceptions (map (λ (x) (gen-ds (ex-string x) (fields x) (parent-sym x))) l))
|
||||
|
||||
(define exceptions (map (λ (x) (gen-ds (ex-string x) (fields x) (length (ex-args x)) (parent-sym x))) l))
|
||||
(define structs (map (λ (x) (apply gen-ds x))
|
||||
'((arity-at-least (arity-at-least-value) #t)
|
||||
'((arity-at-least (arity-at-least-value) 1 #t)
|
||||
(date (date-time-zone-offset date-dst? date-year-day date-week-day date-year
|
||||
date-month date-day date-hour date-minute date-second) #t)
|
||||
date-month date-day date-hour date-minute date-second) 10 #t)
|
||||
(date* (date*-time-zone-name date*-nanosecond
|
||||
date-time-zone-offset date-dst? date-year-day date-week-day date-year
|
||||
date-month date-day date-hour date-minute date-second) date)
|
||||
(srcloc (srcloc-span srcloc-position srcloc-column srcloc-line srcloc-source) #t))))
|
||||
date-month date-day date-hour date-minute date-second) 2 date)
|
||||
(srcloc (srcloc-span srcloc-position srcloc-column srcloc-line srcloc-source) 5 #t))))
|
||||
|
||||
(with-output-to-file filename #:exists 'replace
|
||||
(λ ()
|
||||
|
|
|
|||
Loading…
Reference in New Issue
Block a user