nixo
/
guix-devel
1
0
Fork 0
Code Issues Pull Requests Releases Wiki Activity

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 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 @@
(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* (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
(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,
@ -71,7 +65,7 @@ the list of identifiers of delayed fields."
;; Make sure there are no unknown field names.
(let* ((fields (map (compose car syntax->datum) field+value))
(unexpected (lset-difference eq? fields 'expected)))
(unexpected (lset-difference eq? fields '(expected ...))))
(when (pair? unexpected)
(record-error 'name s "extraneous field initializers ~a"
unexpected)))
@ -81,14 +75,14 @@ the list of identifiers of delayed fields."
(or (field-inherited-value field)
#`(struct-ref #,orig-record
#,index)))
'expected
(iota (length 'expected)))))
'(expected ...)
(iota (length '(expected ...))))))
(define (thunked-field? f)
(memq (syntax->datum f) '#,thunked))
(memq (syntax->datum f) 'thunked))
(define (delayed-field? f)
(memq (syntax->datum f) '#,delayed))
(memq (syntax->datum f) 'delayed))
(define (wrap-field-value f value)
(cond ((thunked-field? f)
@ -106,7 +100,7 @@ the list of identifiers of delayed fields."
#,(wrap-field-value #'field #'value)))))
field+value))
(syntax-case s (inherit #,@fields)
(syntax-case s (inherit expected ...)
((_ (inherit orig-record) (field value) (... ...))
#`(let* #,(field-bindings #'((field value) (... ...)))
#,(record-inheritance #'orig-record
@ -128,19 +122,21 @@ the list of identifiers of delayed fields."
(wrap-field-value f value))))
(let ((fields (append fields (map car dflt))))
(cond ((lset= eq? fields 'expected)
(cond ((lset= eq? fields '(expected ...))
#`(let* #,(field-bindings
#'((field value) (... ...)))
(ctor #,@(map field-value 'expected))))
((pair? (lset-difference eq? fields 'expected))
(ctor #,@(map field-value '(expected ...)))))
((pair? (lset-difference eq? fields
'(expected ...)))
(record-error 'name s
"extraneous field initializers ~a"
(lset-difference eq? fields
'expected)))
'(expected ...))))
(else
(record-error 'name s
"missing field initializers ~a"
(lset-difference eq? 'expected
(lset-difference eq?
'(expected ...)
fields)))))))))))))
(define-syntax define-record-type*
@ -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 '()))