mirror/guix
1
0
Fork 0
mirror of https://git.savannah.gnu.org/git/guix.git synced 2025-01-19 22:16:32 +01:00
Code Issues Projects Releases Packages Wiki Activity Actions

records: Replace 'eval-when' with a proper 'define-syntax'.

Browse source 
* guix/records.scm (make-syntactic-constructor): Remove enclosing
  'eval-when'.  Turn into a 'syntax-rules' macro.
This commit is contained in:
Ludovic Courtès 2015-06-11 21:37:49 +02:00
parent b45ce07a8a
commit 39fc041a7d
1 changed files with 92 additions and 96 deletions
Show stats Download patch file Download diff file Expand all files Collapse all files

62
guix/records.scm
View file

@ -42,23 +42,17 @@ (define-syntax record-error
(format #f fmt args ...) (format #f fmt args ...)
form)))) form))))
(eval-when (expand load eval) (define-syntax make-syntactic-constructor
;; This procedure is a syntactic helper used by 'define-record-type*', hence (syntax-rules ()
;; 'eval-when'. "Make the syntactic constructor NAME for TYPE, that calls CTOR, and
expects all of EXPECTED fields to be initialized. DEFAULTS is the list of
(define* (make-syntactic-constructor type name ctor fields FIELD/DEFAULT-VALUE tuples, THUNKED is the list of identifiers of thunked
#:key (thunked '()) (defaults '()) fields, and DELAYED is the list of identifiers of delayed fields."
(delayed '())) ((_ type name ctor (expected ...)
"Make the syntactic constructor NAME for TYPE, that calls CTOR, and expects #:thunked thunked
all of FIELDS to be initialized. DEFAULTS is the list of FIELD/DEFAULT-VALUE #:delayed delayed
tuples, THUNKED is the list of identifiers of thunked fields, and DELAYED is #:defaults defaults)
the list of identifiers of delayed fields." (define-syntax name
(with-syntax ((type type)
(name name)
(ctor ctor)
(expected fields)
(defaults defaults))
#`(define-syntax name
(lambda (s) (lambda (s)
(define (record-inheritance orig-record field+value) (define (record-inheritance orig-record field+value)
;; Produce code that returns a record identical to ORIG-RECORD, ;; Produce code that returns a record identical to ORIG-RECORD,
@ -71,7 +65,7 @@ (define (field-inherited-value f)
;; Make sure there are no unknown field names. ;; Make sure there are no unknown field names.
(let* ((fields (map (compose car syntax->datum) field+value)) (let* ((fields (map (compose car syntax->datum) field+value))
(unexpected (lset-difference eq? fields 'expected))) (unexpected (lset-difference eq? fields '(expected ...))))
(when (pair? unexpected) (when (pair? unexpected)
(record-error 'name s "extraneous field initializers ~a" (record-error 'name s "extraneous field initializers ~a"
unexpected))) unexpected)))
@ -81,14 +75,14 @@ (define (field-inherited-value f)
(or (field-inherited-value field) (or (field-inherited-value field)
#`(struct-ref #,orig-record #`(struct-ref #,orig-record
#,index))) #,index)))
'expected '(expected ...)
(iota (length 'expected))))) (iota (length '(expected ...))))))
(define (thunked-field? f) (define (thunked-field? f)
(memq (syntax->datum f) '#,thunked)) (memq (syntax->datum f) 'thunked))
(define (delayed-field? f) (define (delayed-field? f)
(memq (syntax->datum f) '#,delayed)) (memq (syntax->datum f) 'delayed))
(define (wrap-field-value f value) (define (wrap-field-value f value)
(cond ((thunked-field? f) (cond ((thunked-field? f)
@ -106,7 +100,7 @@ (define (field-bindings field+value)
#,(wrap-field-value #'field #'value))))) #,(wrap-field-value #'field #'value)))))
field+value)) field+value))
(syntax-case s (inherit #,@fields) (syntax-case s (inherit expected ...)
((_ (inherit orig-record) (field value) (... ...)) ((_ (inherit orig-record) (field value) (... ...))
#`(let* #,(field-bindings #'((field value) (... ...))) #`(let* #,(field-bindings #'((field value) (... ...)))
#,(record-inheritance #'orig-record #,(record-inheritance #'orig-record
@ -128,19 +122,21 @@ (define (field-value f)
(wrap-field-value f value)))) (wrap-field-value f value))))
(let ((fields (append fields (map car dflt)))) (let ((fields (append fields (map car dflt))))
(cond ((lset= eq? fields 'expected) (cond ((lset= eq? fields '(expected ...))
#`(let* #,(field-bindings #`(let* #,(field-bindings
#'((field value) (... ...))) #'((field value) (... ...)))
(ctor #,@(map field-value 'expected)))) (ctor #,@(map field-value '(expected ...)))))
((pair? (lset-difference eq? fields 'expected)) ((pair? (lset-difference eq? fields
'(expected ...)))
(record-error 'name s (record-error 'name s
"extraneous field initializers ~a" "extraneous field initializers ~a"
(lset-difference eq? fields (lset-difference eq? fields
'expected))) '(expected ...))))
(else (else
(record-error 'name s (record-error 'name s
"missing field initializers ~a" "missing field initializers ~a"
(lset-difference eq? 'expected (lset-difference eq?
'(expected ...)
fields))))))))))))) fields)))))))))))))
(define-syntax define-record-type* (define-syntax define-record-type*
@ -279,11 +275,11 @@ (define-record-type type
field-spec* ...) field-spec* ...)
(begin thunked-field-accessor ... (begin thunked-field-accessor ...
delayed-field-accessor ...) delayed-field-accessor ...)
#,(make-syntactic-constructor #'type #'syntactic-ctor #'ctor (make-syntactic-constructor type syntactic-ctor ctor
#'(field ...) (field ...)
#:thunked thunked #:thunked #,thunked
#:delayed delayed #:delayed #,delayed
#:defaults defaults)))))))) #:defaults #,defaults))))))))
(define* (alist->record alist make keys (define* (alist->record alist make keys
#:optional (multiple-value-keys '())) #:optional (multiple-value-keys '()))