diff options
| author | Ludovic Courtès <ludo@gnu.org> | 2014-07-17 16:42:19 +0200 |
|---|---|---|
| committer | Ludovic Courtès <ludo@gnu.org> | 2014-07-17 16:42:19 +0200 |
| commit | b1353e7a6baf15e6e1db79063c01f4b07b6d4e06 (patch) | |
| tree | e787359212bf753ecf089914a27b04dd88c8eaef /guix | |
| parent | 23e9a68088364d2ad44608cf118bfd81faac1559 (diff) | |
| download | gnu-guix-b1353e7a6baf15e6e1db79063c01f4b07b6d4e06.tar gnu-guix-b1353e7a6baf15e6e1db79063c01f4b07b6d4e06.tar.gz | |
records: Factorize error-reporting macro.
* guix/records.scm (record-error): New macro.
(define-record-type*)[error*]: Remove.
Use 'record-error' instead.
Diffstat (limited to 'guix')
| -rw-r--r-- | guix/records.scm | 44 |
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) |