records: Replace 'eval-when' with a proper 'define-syntax'.
* guix/records.scm (make-syntactic-constructor): Remove enclosing 'eval-when'. Turn into a 'syntax-rules' macro.master
Ludovic Courtès
parent
b45ce07a8a
commit
39fc041a7d
188
guix/records.scm
188
guix/records.scm
|
|
@ -42,106 +42,102 @@
|
|||
(format #f fmt args ...)
|
||||
form))))
|
||||
|
||||
(eval-when (expand load eval)
|
||||
;; This procedure is a syntactic helper used by 'define-record-type*', hence
|
||||
;; 'eval-when'.
|
||||
(define-syntax make-syntactic-constructor
|
||||
(syntax-rules ()
|
||||
"Make the syntactic constructor NAME for TYPE, that calls CTOR, and
|
||||
expects all of EXPECTED fields to be initialized. DEFAULTS is the list of
|
||||
FIELD/DEFAULT-VALUE tuples, THUNKED is the list of identifiers of thunked
|
||||
fields, and DELAYED is the list of identifiers of delayed fields."
|
||||
((_ type name ctor (expected ...)
|
||||
#:thunked thunked
|
||||
#:delayed delayed
|
||||
#:defaults defaults)
|
||||
(define-syntax name
|
||||
(lambda (s)
|
||||
(define (record-inheritance orig-record field+value)
|
||||
;; Produce code that returns a record identical to ORIG-RECORD,
|
||||
;; except that values for the FIELD+VALUE alist prevail.
|
||||
(define (field-inherited-value f)
|
||||
(and=> (find (lambda (x)
|
||||
(eq? f (car (syntax->datum x))))
|
||||
field+value)
|
||||
car))
|
||||
|
||||
(define* (make-syntactic-constructor type name ctor fields
|
||||
#:key (thunked '()) (defaults '())
|
||||
(delayed '()))
|
||||
"Make the syntactic constructor NAME for TYPE, that calls CTOR, and expects
|
||||
all of FIELDS to be initialized. DEFAULTS is the list of FIELD/DEFAULT-VALUE
|
||||
tuples, THUNKED is the list of identifiers of thunked fields, and DELAYED is
|
||||
the list of identifiers of delayed fields."
|
||||
(with-syntax ((type type)
|
||||
(name name)
|
||||
(ctor ctor)
|
||||
(expected fields)
|
||||
(defaults defaults))
|
||||
#`(define-syntax name
|
||||
(lambda (s)
|
||||
(define (record-inheritance orig-record field+value)
|
||||
;; Produce code that returns a record identical to ORIG-RECORD,
|
||||
;; except that values for the FIELD+VALUE alist prevail.
|
||||
(define (field-inherited-value f)
|
||||
(and=> (find (lambda (x)
|
||||
(eq? f (car (syntax->datum x))))
|
||||
field+value)
|
||||
car))
|
||||
;; Make sure there are no unknown field names.
|
||||
(let* ((fields (map (compose car syntax->datum) field+value))
|
||||
(unexpected (lset-difference eq? fields '(expected ...))))
|
||||
(when (pair? unexpected)
|
||||
(record-error 'name s "extraneous field initializers ~a"
|
||||
unexpected)))
|
||||
|
||||
;; Make sure there are no unknown field names.
|
||||
(let* ((fields (map (compose car syntax->datum) field+value))
|
||||
(unexpected (lset-difference eq? fields 'expected)))
|
||||
(when (pair? unexpected)
|
||||
(record-error 'name s "extraneous field initializers ~a"
|
||||
unexpected)))
|
||||
#`(make-struct type 0
|
||||
#,@(map (lambda (field index)
|
||||
(or (field-inherited-value field)
|
||||
#`(struct-ref #,orig-record
|
||||
#,index)))
|
||||
'(expected ...)
|
||||
(iota (length '(expected ...))))))
|
||||
|
||||
#`(make-struct type 0
|
||||
#,@(map (lambda (field index)
|
||||
(or (field-inherited-value field)
|
||||
#`(struct-ref #,orig-record
|
||||
#,index)))
|
||||
'expected
|
||||
(iota (length 'expected)))))
|
||||
(define (thunked-field? f)
|
||||
(memq (syntax->datum f) 'thunked))
|
||||
|
||||
(define (thunked-field? f)
|
||||
(memq (syntax->datum f) '#,thunked))
|
||||
(define (delayed-field? f)
|
||||
(memq (syntax->datum f) 'delayed))
|
||||
|
||||
(define (delayed-field? f)
|
||||
(memq (syntax->datum f) '#,delayed))
|
||||
(define (wrap-field-value f value)
|
||||
(cond ((thunked-field? f)
|
||||
#`(lambda () #,value))
|
||||
((delayed-field? f)
|
||||
#`(delay #,value))
|
||||
(else value)))
|
||||
|
||||
(define (wrap-field-value f value)
|
||||
(cond ((thunked-field? f)
|
||||
#`(lambda () #,value))
|
||||
((delayed-field? f)
|
||||
#`(delay #,value))
|
||||
(else value)))
|
||||
(define (field-bindings field+value)
|
||||
;; Return field to value bindings, for use in 'let*' below.
|
||||
(map (lambda (field+value)
|
||||
(syntax-case field+value ()
|
||||
((field value)
|
||||
#`(field
|
||||
#,(wrap-field-value #'field #'value)))))
|
||||
field+value))
|
||||
|
||||
(define (field-bindings field+value)
|
||||
;; Return field to value bindings, for use in 'let*' below.
|
||||
(map (lambda (field+value)
|
||||
(syntax-case field+value ()
|
||||
((field value)
|
||||
#`(field
|
||||
#,(wrap-field-value #'field #'value)))))
|
||||
field+value))
|
||||
(syntax-case s (inherit expected ...)
|
||||
((_ (inherit orig-record) (field value) (... ...))
|
||||
#`(let* #,(field-bindings #'((field value) (... ...)))
|
||||
#,(record-inheritance #'orig-record
|
||||
#'((field value) (... ...)))))
|
||||
((_ (field value) (... ...))
|
||||
(let ((fields (map syntax->datum #'(field (... ...))))
|
||||
(dflt (map (match-lambda
|
||||
((f v)
|
||||
(list (syntax->datum f) v)))
|
||||
#'defaults)))
|
||||
|
||||
(syntax-case s (inherit #,@fields)
|
||||
((_ (inherit orig-record) (field value) (... ...))
|
||||
#`(let* #,(field-bindings #'((field value) (... ...)))
|
||||
#,(record-inheritance #'orig-record
|
||||
#'((field value) (... ...)))))
|
||||
((_ (field value) (... ...))
|
||||
(let ((fields (map syntax->datum #'(field (... ...))))
|
||||
(dflt (map (match-lambda
|
||||
((f v)
|
||||
(list (syntax->datum f) v)))
|
||||
#'defaults)))
|
||||
(define (field-value f)
|
||||
(or (and=> (find (lambda (x)
|
||||
(eq? f (car (syntax->datum x))))
|
||||
#'((field value) (... ...)))
|
||||
car)
|
||||
(let ((value
|
||||
(car (assoc-ref dflt (syntax->datum f)))))
|
||||
(wrap-field-value f value))))
|
||||
|
||||
(define (field-value f)
|
||||
(or (and=> (find (lambda (x)
|
||||
(eq? f (car (syntax->datum x))))
|
||||
#'((field value) (... ...)))
|
||||
car)
|
||||
(let ((value
|
||||
(car (assoc-ref dflt (syntax->datum f)))))
|
||||
(wrap-field-value f value))))
|
||||
|
||||
(let ((fields (append fields (map car dflt))))
|
||||
(cond ((lset= eq? fields 'expected)
|
||||
#`(let* #,(field-bindings
|
||||
#'((field value) (... ...)))
|
||||
(ctor #,@(map field-value 'expected))))
|
||||
((pair? (lset-difference eq? fields 'expected))
|
||||
(record-error 'name s
|
||||
"extraneous field initializers ~a"
|
||||
(lset-difference eq? fields
|
||||
'expected)))
|
||||
(else
|
||||
(record-error 'name s
|
||||
"missing field initializers ~a"
|
||||
(lset-difference eq? 'expected
|
||||
fields)))))))))))))
|
||||
(let ((fields (append fields (map car dflt))))
|
||||
(cond ((lset= eq? fields '(expected ...))
|
||||
#`(let* #,(field-bindings
|
||||
#'((field value) (... ...)))
|
||||
(ctor #,@(map field-value '(expected ...)))))
|
||||
((pair? (lset-difference eq? fields
|
||||
'(expected ...)))
|
||||
(record-error 'name s
|
||||
"extraneous field initializers ~a"
|
||||
(lset-difference eq? fields
|
||||
'(expected ...))))
|
||||
(else
|
||||
(record-error 'name s
|
||||
"missing field initializers ~a"
|
||||
(lset-difference eq?
|
||||
'(expected ...)
|
||||
fields)))))))))))))
|
||||
|
||||
(define-syntax define-record-type*
|
||||
(lambda (s)
|
||||
|
|
@ -279,11 +275,11 @@ field."
|
|||
field-spec* ...)
|
||||
(begin thunked-field-accessor ...
|
||||
delayed-field-accessor ...)
|
||||
#,(make-syntactic-constructor #'type #'syntactic-ctor #'ctor
|
||||
#'(field ...)
|
||||
#:thunked thunked
|
||||
#:delayed delayed
|
||||
#:defaults defaults))))))))
|
||||
(make-syntactic-constructor type syntactic-ctor ctor
|
||||
(field ...)
|
||||
#:thunked #,thunked
|
||||
#:delayed #,delayed
|
||||
#:defaults #,defaults))))))))
|
||||
|
||||
(define* (alist->record alist make keys
|
||||
#:optional (multiple-value-keys '()))
|
||||
|
|
|
|||
Reference in New Issue