summaryrefslogtreecommitdiff
diff options
context:
space:
mode:
authorLudovic Courtès <ludo@gnu.org>2014-07-17 16:42:19 +0200
committerLudovic Courtès <ludo@gnu.org>2014-07-17 16:42:19 +0200
commitb1353e7a6baf15e6e1db79063c01f4b07b6d4e06 (patch)
treee787359212bf753ecf089914a27b04dd88c8eaef
parent23e9a68088364d2ad44608cf118bfd81faac1559 (diff)
downloadpatches-b1353e7a6baf15e6e1db79063c01f4b07b6d4e06.tar
patches-b1353e7a6baf15e6e1db79063c01f4b07b6d4e06.tar.gz
records: Factorize error-reporting macro.
* guix/records.scm (record-error): New macro. (define-record-type*)[error*]: Remove. Use 'record-error' instead.
-rw-r--r--guix/records.scm44
1 files changed, 24 insertions, 20 deletions
diff --git a/guix/records.scm b/guix/records.scm
index 37d34b4c81..e60732dd43 100644
--- a/guix/records.scm
+++ b/guix/records.scm
@@ -1,5 +1,5 @@
;;; GNU Guix --- Functional package management for GNU
-;;; Copyright © 2012, 2013 Ludovic Courtès <ludo@gnu.org>
+;;; Copyright © 2012, 2013, 2014 Ludovic Courtès <ludo@gnu.org>
;;;
;;; This file is part of GNU Guix.
;;;
@@ -34,6 +34,14 @@
;;;
;;; Code:
+(define-syntax record-error
+ (syntax-rules ()
+ "Report a syntactic error in use of CONSTRUCTOR."
+ ((_ constructor form fmt args ...)
+ (syntax-violation constructor
+ (format #f fmt args ...)
+ form))))
+
(define-syntax define-record-type*
(lambda (s)
"Define the given record type such that an additional \"syntactic
@@ -107,25 +115,21 @@ thunked fields."
#`(lambda () #,value)
value))))
- (let-syntax ((error*
- (syntax-rules ()
- ((_ fmt args (... ...))
- (syntax-violation 'name
- (format #f fmt args
- (... ...))
- s)))))
- (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))
- (error* "extraneous field initializers ~a"
- (lset-difference eq? fields 'expected)))
- (else
- (error* "missing field initializers ~a"
- (lset-difference eq? 'expected
- fields)))))))))))))
+ (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 (field-default-value s)
(syntax-case s (default)