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

[Ludovic Courtès]

civodul pushed a commit to branch master
in repository guix.

commit 39fc041a7de18e4b41c4e9007cfdadbff581334a
Author: Ludovic Courtès <address@hidden>
Date:   Thu Jun 11 21:37:49 2015 +0200

    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.
---
 guix/records.scm |  206 ++++++++++++++++++++++++++---------------------------
 1 files changed, 101 insertions(+), 105 deletions(-)

diff --git a/guix/records.scm b/guix/records.scm
index db59a99..2378969 100644
--- a/guix/records.scm
+++ b/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* (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)))))))))))))
+(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))
+
+           ;; 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 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)))
+
+              (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)
@@ -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 '()))