summaryrefslogtreecommitdiff
diff options
context:
space:
mode:
-rw-r--r--guix/records.scm44
1 files changed, 24 insertions, 20 deletions
diff --git a/guix/records.scm b/guix/records.scm
index 37d34b4c810..e60732dd430 100644
--- a/guix/records.scm
+++ b/guix/records.scm
@@ -1,5 +1,5 @@
1;;; GNU Guix --- Functional package management for GNU 1;;; GNU Guix --- Functional package management for GNU
2;;; Copyright © 2012, 2013 Ludovic Courtès <ludo@gnu.org> 2;;; Copyright © 2012, 2013, 2014 Ludovic Courtès <ludo@gnu.org>
3;;; 3;;;
4;;; This file is part of GNU Guix. 4;;; This file is part of GNU Guix.
5;;; 5;;;
@@ -34,6 +34,14 @@
34;;; 34;;;
35;;; Code: 35;;; Code:
36 36
37(define-syntax record-error
38 (syntax-rules ()
39 "Report a syntactic error in use of CONSTRUCTOR."
40 ((_ constructor form fmt args ...)
41 (syntax-violation constructor
42 (format #f fmt args ...)
43 form))))
44
37(define-syntax define-record-type* 45(define-syntax define-record-type*
38 (lambda (s) 46 (lambda (s)
39 "Define the given record type such that an additional \"syntactic 47 "Define the given record type such that an additional \"syntactic
@@ -107,25 +115,21 @@ thunked fields."
107 #`(lambda () #,value) 115 #`(lambda () #,value)
108 value)))) 116 value))))
109 117
110 (let-syntax ((error* 118 (let ((fields (append fields (map car dflt))))
111 (syntax-rules () 119 (cond ((lset= eq? fields 'expected)
112 ((_ fmt args (... ...)) 120 #`(let* #,(field-bindings
113 (syntax-violation 'name 121 #'((field value) (... ...)))
114 (format #f fmt args 122 (ctor #,@(map field-value 'expected))))
115 (... ...)) 123 ((pair? (lset-difference eq? fields 'expected))
116 s))))) 124 (record-error 'name s
117 (let ((fields (append fields (map car dflt)))) 125 "extraneous field initializers ~a"
118 (cond ((lset= eq? fields 'expected) 126 (lset-difference eq? fields
119 #`(let* #,(field-bindings 127 'expected)))
120 #'((field value) (... ...))) 128 (else
121 (ctor #,@(map field-value 'expected)))) 129 (record-error 'name s
122 ((pair? (lset-difference eq? fields 'expected)) 130 "missing field initializers ~a"
123 (error* "extraneous field initializers ~a" 131 (lset-difference eq? 'expected
124 (lset-difference eq? fields 'expected))) 132 fields))))))))))))
125 (else
126 (error* "missing field initializers ~a"
127 (lset-difference eq? 'expected
128 fields)))))))))))))
129 133
130 (define (field-default-value s) 134 (define (field-default-value s)
131 (syntax-case s (default) 135 (syntax-case s (default)