ryan77627/guix
1
0
Fork 0
mirror of https://git.in.rschanz.org/ryan77627/guix.git synced 2025-01-13 14:40:21 -05: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

188
guix/records.scm
View file

@ -42,106 +42,102 @@ (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
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 ;; Make sure there are no unknown field names.
#:key (thunked '()) (defaults '()) (let* ((fields (map (compose car syntax->datum) field+value))
(delayed '())) (unexpected (lset-difference eq? fields '(expected ...))))
"Make the syntactic constructor NAME for TYPE, that calls CTOR, and expects (when (pair? unexpected)
all of FIELDS to be initialized. DEFAULTS is the list of FIELD/DEFAULT-VALUE (record-error 'name s "extraneous field initializers ~a"
tuples, THUNKED is the list of identifiers of thunked fields, and DELAYED is unexpected)))
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. #`(make-struct type 0
(let* ((fields (map (compose car syntax->datum) field+value)) #,@(map (lambda (field index)
(unexpected (lset-difference eq? fields 'expected))) (or (field-inherited-value field)
(when (pair? unexpected) #`(struct-ref #,orig-record
(record-error 'name s "extraneous field initializers ~a" #,index)))
unexpected))) '(expected ...)
(iota (length '(expected ...))))))
#`(make-struct type 0 (define (thunked-field? f)
#,@(map (lambda (field index) (memq (syntax->datum f) 'thunked))
(or (field-inherited-value field)
#`(struct-ref #,orig-record
#,index)))
'expected
(iota (length 'expected)))))
(define (thunked-field? f) (define (delayed-field? f)
(memq (syntax->datum f) '#,thunked)) (memq (syntax->datum f) 'delayed))
(define (delayed-field? f) (define (wrap-field-value f value)
(memq (syntax->datum f) '#,delayed)) (cond ((thunked-field? f)
#`(lambda () #,value))
((delayed-field? f)
#`(delay #,value))
(else value)))
(define (wrap-field-value f value) (define (field-bindings field+value)
(cond ((thunked-field? f) ;; Return field to value bindings, for use in 'let*' below.
#`(lambda () #,value)) (map (lambda (field+value)
((delayed-field? f) (syntax-case field+value ()
#`(delay #,value)) ((field value)
(else value))) #`(field
#,(wrap-field-value #'field #'value)))))
field+value))
(define (field-bindings field+value) (syntax-case s (inherit expected ...)
;; Return field to value bindings, for use in 'let*' below. ((_ (inherit orig-record) (field value) (... ...))
(map (lambda (field+value) #`(let* #,(field-bindings #'((field value) (... ...)))
(syntax-case field+value () #,(record-inheritance #'orig-record
((field value) #'((field value) (... ...)))))
#`(field ((_ (field value) (... ...))
#,(wrap-field-value #'field #'value))))) (let ((fields (map syntax->datum #'(field (... ...))))
field+value)) (dflt (map (match-lambda
((f v)
(list (syntax->datum f) v)))
#'defaults)))
(syntax-case s (inherit #,@fields) (define (field-value f)
((_ (inherit orig-record) (field value) (... ...)) (or (and=> (find (lambda (x)
#`(let* #,(field-bindings #'((field value) (... ...))) (eq? f (car (syntax->datum x))))
#,(record-inheritance #'orig-record #'((field value) (... ...)))
#'((field value) (... ...))))) car)
((_ (field value) (... ...)) (let ((value
(let ((fields (map syntax->datum #'(field (... ...)))) (car (assoc-ref dflt (syntax->datum f)))))
(dflt (map (match-lambda (wrap-field-value f value))))
((f v)
(list (syntax->datum f) v)))
#'defaults)))
(define (field-value f) (let ((fields (append fields (map car dflt))))
(or (and=> (find (lambda (x) (cond ((lset= eq? fields '(expected ...))
(eq? f (car (syntax->datum x)))) #`(let* #,(field-bindings
#'((field value) (... ...))) #'((field value) (... ...)))
car) (ctor #,@(map field-value '(expected ...)))))
(let ((value ((pair? (lset-difference eq? fields
(car (assoc-ref dflt (syntax->datum f))))) '(expected ...)))
(wrap-field-value f value)))) (record-error 'name s
"extraneous field initializers ~a"
(let ((fields (append fields (map car dflt)))) (lset-difference eq? fields
(cond ((lset= eq? fields 'expected) '(expected ...))))
#`(let* #,(field-bindings (else
#'((field value) (... ...))) (record-error 'name s
(ctor #,@(map field-value 'expected)))) "missing field initializers ~a"
((pair? (lset-difference eq? fields 'expected)) (lset-difference eq?
(record-error 'name s '(expected ...)
"extraneous field initializers ~a" fields)))))))))))))
(lset-difference eq? fields
'expected)))
(else
(record-error 'name s
"missing field initializers ~a"
(lset-difference eq? 'expected
fields)))))))))))))
(define-syntax define-record-type* (define-syntax define-record-type*
(lambda (s) (lambda (s)
@ -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 '()))