[Date Prev][Date Next][Thread Prev][Thread Next][Date Index][Thread Index]
50/66: records: Make 'make-syntactic-constructor' available at load/eval
|
From: |
Manolis Fragkiskos Ragkousis |
|
Subject: |
50/66: records: Make 'make-syntactic-constructor' available at load/eval/expand. |
|
Date: |
Thu, 21 May 2015 12:52:07 +0000 |
phant0mas pushed a commit to branch wip-hurd
in repository guix.
commit 4fd6d1b718b288b46aceb839df6ae50b1e90ee75
Author: Ludovic Courtès <address@hidden>
Date: Mon May 4 23:18:14 2015 +0200
records: Make 'make-syntactic-constructor' available at load/eval/expand.
* guix/records.scm (make-syntactic-constructor): Wrap in 'eval-when'.
---
guix/records.scm | 190 +++++++++++++++++++++++++++--------------------------
1 files changed, 97 insertions(+), 93 deletions(-)
diff --git a/guix/records.scm b/guix/records.scm
index fd17e13..db59a99 100644
--- a/guix/records.scm
+++ b/guix/records.scm
@@ -42,102 +42,106 @@
(format #f fmt args ...)
form))))
-(define* (make-syntactic-constructor type name ctor fields
- #:key (thunked '()) (defaults '())
- (delayed '()))
- "Make the syntactic constructor NAME for TYPE, that calls CTOR, and expects
+(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
- (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-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 (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 (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 #,@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))))
-
- (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))))))))))))
+ (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-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 (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 (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 #,@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))))
+
+ (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)
- 40/66: gnu: curl: Update to 7.42.1., (continued)
- 40/66: gnu: curl: Update to 7.42.1., Manolis Fragkiskos Ragkousis, 2015/05/21
- 44/66: gnu: Add markdown., Manolis Fragkiskos Ragkousis, 2015/05/21
- 47/66: search-paths: Add 'environment-variable-definition'., Manolis Fragkiskos Ragkousis, 2015/05/21
- 49/66: profiles: Use a &message error condition instead of 'error'., Manolis Fragkiskos Ragkousis, 2015/05/21
- 48/66: search-paths: 'evaluate-search-paths' now returns spec/value pairs., Manolis Fragkiskos Ragkousis, 2015/05/21
- 42/66: gnu: Add libwpg., Manolis Fragkiskos Ragkousis, 2015/05/21
- 41/66: guix: build: Fix indentation for --sources in help output., Manolis Fragkiskos Ragkousis, 2015/05/21
- 46/66: search-paths: Add 'evaluate-search-paths', from (guix scripts package)., Manolis Fragkiskos Ragkousis, 2015/05/21
- 45/66: Move search path specifications to (guix search-paths)., Manolis Fragkiskos Ragkousis, 2015/05/21
- 51/66: gnu: Add soil., Manolis Fragkiskos Ragkousis, 2015/05/21
- 50/66: records: Make 'make-syntactic-constructor' available at load/eval/expand.,
Manolis Fragkiskos Ragkousis <=
- 56/66: gnu: vcftools: Remove "-m64" from CFLAGS., Manolis Fragkiskos Ragkousis, 2015/05/21
- 53/66: gnu: Add bluez., Manolis Fragkiskos Ragkousis, 2015/05/21
- 55/66: gnu: fltk: Fix undefined symbol errors for shared libraries., Manolis Fragkiskos Ragkousis, 2015/05/21
- 60/66: gnu: bootstrap: Add the location of where ld.so is located on Hurd systems., Manolis Fragkiskos Ragkousis, 2015/05/21
- 61/66: gnu: cross-base: Make it aware of non-Linux (ie. Hurd) systems., Manolis Fragkiskos Ragkousis, 2015/05/21
- 54/66: gnu: ardour: Add library dirs to RUNPATH., Manolis Fragkiskos Ragkousis, 2015/05/21
- 57/66: environment: Use (guix search-paths)., Manolis Fragkiskos Ragkousis, 2015/05/21
- 64/66: gnu: hurd: Pass --build to gnumach-headers when not cross building., Manolis Fragkiskos Ragkousis, 2015/05/21
- 63/66: gnu: acl: Fix i686-gnu build., Manolis Fragkiskos Ragkousis, 2015/05/21
- 65/66: gnu: hurd: Pass --build to hurd-headers when not cross building., Manolis Fragkiskos Ragkousis, 2015/05/21