diff options
| -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 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) |
