Commit | Line | Data |
---|---|---|
c0cd1b3e | 1 | ;;; GNU Guix --- Functional package management for GNU |
47212fc7 | 2 | ;;; Copyright © 2012, 2013, 2014, 2015, 2016, 2017, 2018, 2019, 2020 Ludovic Courtès <ludo@gnu.org> |
c2dcff41 | 3 | ;;; Copyright © 2018 Mark H Weaver <mhw@netris.org> |
c0cd1b3e LC |
4 | ;;; |
5 | ;;; This file is part of GNU Guix. | |
6 | ;;; | |
7 | ;;; GNU Guix is free software; you can redistribute it and/or modify it | |
8 | ;;; under the terms of the GNU General Public License as published by | |
9 | ;;; the Free Software Foundation; either version 3 of the License, or (at | |
10 | ;;; your option) any later version. | |
11 | ;;; | |
12 | ;;; GNU Guix is distributed in the hope that it will be useful, but | |
13 | ;;; WITHOUT ANY WARRANTY; without even the implied warranty of | |
14 | ;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the | |
15 | ;;; GNU General Public License for more details. | |
16 | ;;; | |
17 | ;;; You should have received a copy of the GNU General Public License | |
18 | ;;; along with GNU Guix. If not, see <http://www.gnu.org/licenses/>. | |
19 | ||
20 | (define-module (guix records) | |
21 | #:use-module (srfi srfi-1) | |
22 | #:use-module (srfi srfi-9) | |
23 | #:use-module (srfi srfi-26) | |
24 | #:use-module (ice-9 match) | |
fdc1bf65 LC |
25 | #:use-module (ice-9 regex) |
26 | #:use-module (ice-9 rdelim) | |
a05ad011 | 27 | #:autoload (system base target) (target-most-positive-fixnum) |
c0cd1b3e | 28 | #:export (define-record-type* |
abd4d6b3 LC |
29 | this-record |
30 | ||
c0cd1b3e | 31 | alist->record |
fdc1bf65 | 32 | object->fields |
6692d845 | 33 | recutils->alist |
34 | match-record)) | |
c0cd1b3e LC |
35 | |
36 | ;;; Commentary: | |
37 | ;;; | |
38 | ;;; Utilities for dealing with Scheme records. | |
39 | ;;; | |
40 | ;;; Code: | |
41 | ||
b1353e7a LC |
42 | (define-syntax record-error |
43 | (syntax-rules () | |
44 | "Report a syntactic error in use of CONSTRUCTOR." | |
45 | ((_ constructor form fmt args ...) | |
46 | (syntax-violation constructor | |
47 | (format #f fmt args ...) | |
48 | form)))) | |
49 | ||
9768848a LC |
50 | (eval-when (expand load eval) |
51 | ;; The procedures below are needed both at run time and at expansion time. | |
52 | ||
53 | (define (current-abi-identifier type) | |
54 | "Return an identifier unhygienically derived from TYPE for use as its | |
7874bbbb | 55 | \"current ABI\" variable." |
9768848a LC |
56 | (let ((type-name (syntax->datum type))) |
57 | (datum->syntax | |
58 | type | |
59 | (string->symbol | |
60 | (string-append "% " (symbol->string type-name) | |
61 | " abi-cookie"))))) | |
7874bbbb | 62 | |
9768848a LC |
63 | (define (abi-check type cookie) |
64 | "Return syntax that checks that the current \"application binary | |
7874bbbb | 65 | interface\" (ABI) for TYPE is equal to COOKIE." |
9768848a LC |
66 | (with-syntax ((current-abi (current-abi-identifier type))) |
67 | #`(unless (eq? current-abi #,cookie) | |
de5cbd4a LC |
68 | ;; The source file where this exception is thrown must be |
69 | ;; recompiled. | |
70 | (throw 'record-abi-mismatch-error 'abi-check | |
71 | "~a: record ABI mismatch; recompilation needed" | |
bbb2bd50 LC |
72 | (list #,type) '())))) |
73 | ||
47212fc7 LC |
74 | (define* (report-invalid-field-specifier name bindings |
75 | #:optional parent-form) | |
76 | "Report the first invalid binding among BINDINGS. PARENT-FORM is used for | |
77 | error-reporting purposes." | |
bbb2bd50 LC |
78 | (let loop ((bindings bindings)) |
79 | (syntax-case bindings () | |
80 | (((field value) rest ...) ;good | |
81 | (loop #'(rest ...))) | |
82 | ((weird _ ...) ;weird! | |
47212fc7 LC |
83 | ;; WEIRD may be an identifier, thus lacking source location info, and |
84 | ;; BINDINGS is a list, also lacking source location info. Hopefully | |
85 | ;; PARENT-FORM provides source location info. | |
86 | (apply syntax-violation name "invalid field specifier" | |
87 | (if parent-form | |
88 | (list parent-form #'weird) | |
89 | (list #'weird))))))) | |
bbb2bd50 LC |
90 | |
91 | (define (report-duplicate-field-specifier name ctor) | |
92 | "Report the first duplicate identifier among the bindings in CTOR." | |
93 | (syntax-case ctor () | |
94 | ((_ bindings ...) | |
95 | (let loop ((bindings #'(bindings ...)) | |
96 | (seen '())) | |
97 | (syntax-case bindings () | |
98 | (((field value) rest ...) | |
99 | (not (memq (syntax->datum #'field) seen)) | |
100 | (loop #'(rest ...) (cons (syntax->datum #'field) seen))) | |
101 | ((duplicate rest ...) | |
102 | (syntax-violation name "duplicate field initializer" | |
103 | #'duplicate)) | |
104 | (() | |
105 | #t))))))) | |
7874bbbb | 106 | |
abd4d6b3 LC |
107 | (define-syntax-parameter this-record |
108 | (lambda (s) | |
109 | "Return the record being defined. This macro may only be used in the | |
110 | context of the definition of a thunked field." | |
111 | (syntax-case s () | |
112 | (id | |
113 | (identifier? #'id) | |
114 | (syntax-violation 'this-record | |
115 | "cannot be used outside of a record instantiation" | |
116 | #'id))))) | |
117 | ||
39fc041a LC |
118 | (define-syntax make-syntactic-constructor |
119 | (syntax-rules () | |
120 | "Make the syntactic constructor NAME for TYPE, that calls CTOR, and | |
121 | expects all of EXPECTED fields to be initialized. DEFAULTS is the list of | |
122 | FIELD/DEFAULT-VALUE tuples, THUNKED is the list of identifiers of thunked | |
7874bbbb LC |
123 | fields, and DELAYED is the list of identifiers of delayed fields. |
124 | ||
125 | ABI-COOKIE is the cookie (an integer) against which to check the run-time ABI | |
126 | of TYPE matches the expansion-time ABI." | |
39fc041a | 127 | ((_ type name ctor (expected ...) |
7874bbbb | 128 | #:abi-cookie abi-cookie |
39fc041a | 129 | #:thunked thunked |
d2be7e3c | 130 | #:this-identifier this-identifier |
39fc041a | 131 | #:delayed delayed |
8a16d064 | 132 | #:innate innate |
39fc041a LC |
133 | #:defaults defaults) |
134 | (define-syntax name | |
135 | (lambda (s) | |
136 | (define (record-inheritance orig-record field+value) | |
137 | ;; Produce code that returns a record identical to ORIG-RECORD, | |
138 | ;; except that values for the FIELD+VALUE alist prevail. | |
139 | (define (field-inherited-value f) | |
140 | (and=> (find (lambda (x) | |
141 | (eq? f (car (syntax->datum x)))) | |
142 | field+value) | |
143 | car)) | |
144 | ||
145 | ;; Make sure there are no unknown field names. | |
146 | (let* ((fields (map (compose car syntax->datum) field+value)) | |
147 | (unexpected (lset-difference eq? fields '(expected ...)))) | |
148 | (when (pair? unexpected) | |
149 | (record-error 'name s "extraneous field initializers ~a" | |
150 | unexpected))) | |
151 | ||
cea25b08 | 152 | #`(make-struct/no-tail type |
39fc041a LC |
153 | #,@(map (lambda (field index) |
154 | (or (field-inherited-value field) | |
8a16d064 LC |
155 | (if (innate-field? field) |
156 | (wrap-field-value | |
157 | field (field-default-value field)) | |
158 | #`(struct-ref #,orig-record | |
159 | #,index)))) | |
39fc041a LC |
160 | '(expected ...) |
161 | (iota (length '(expected ...)))))) | |
162 | ||
163 | (define (thunked-field? f) | |
164 | (memq (syntax->datum f) 'thunked)) | |
165 | ||
166 | (define (delayed-field? f) | |
167 | (memq (syntax->datum f) 'delayed)) | |
168 | ||
8a16d064 LC |
169 | (define (innate-field? f) |
170 | (memq (syntax->datum f) 'innate)) | |
171 | ||
39fc041a LC |
172 | (define (wrap-field-value f value) |
173 | (cond ((thunked-field? f) | |
abd4d6b3 | 174 | #`(lambda (x) |
d2be7e3c | 175 | (syntax-parameterize ((#,this-identifier |
abd4d6b3 LC |
176 | (lambda (s) |
177 | (syntax-case s () | |
178 | (id | |
179 | (identifier? #'id) | |
180 | #'x))))) | |
181 | #,value))) | |
39fc041a LC |
182 | ((delayed-field? f) |
183 | #`(delay #,value)) | |
184 | (else value))) | |
185 | ||
b9c86473 LC |
186 | (define default-values |
187 | ;; List of symbol/value tuples. | |
188 | (map (match-lambda | |
189 | ((f v) | |
190 | (list (syntax->datum f) v))) | |
191 | #'defaults)) | |
192 | ||
193 | (define (field-default-value f) | |
194 | (car (assoc-ref default-values (syntax->datum f)))) | |
195 | ||
39fc041a LC |
196 | (define (field-bindings field+value) |
197 | ;; Return field to value bindings, for use in 'let*' below. | |
198 | (map (lambda (field+value) | |
199 | (syntax-case field+value () | |
200 | ((field value) | |
201 | #`(field | |
202 | #,(wrap-field-value #'field #'value))))) | |
203 | field+value)) | |
204 | ||
205 | (syntax-case s (inherit expected ...) | |
206 | ((_ (inherit orig-record) (field value) (... ...)) | |
207 | #`(let* #,(field-bindings #'((field value) (... ...))) | |
7874bbbb | 208 | #,(abi-check #'type abi-cookie) |
39fc041a LC |
209 | #,(record-inheritance #'orig-record |
210 | #'((field value) (... ...))))) | |
211 | ((_ (field value) (... ...)) | |
b9c86473 | 212 | (let ((fields (map syntax->datum #'(field (... ...))))) |
39fc041a | 213 | (define (field-value f) |
94df39cc LC |
214 | (or (find (lambda (x) |
215 | (eq? f (syntax->datum x))) | |
216 | #'(field (... ...))) | |
b9c86473 | 217 | (wrap-field-value f (field-default-value f)))) |
39fc041a | 218 | |
c2dcff41 LC |
219 | ;; Pass S to make sure source location info is preserved. |
220 | (report-duplicate-field-specifier 'name s) | |
221 | ||
b9c86473 | 222 | (let ((fields (append fields (map car default-values)))) |
39fc041a LC |
223 | (cond ((lset= eq? fields '(expected ...)) |
224 | #`(let* #,(field-bindings | |
225 | #'((field value) (... ...))) | |
7874bbbb | 226 | #,(abi-check #'type abi-cookie) |
39fc041a LC |
227 | (ctor #,@(map field-value '(expected ...))))) |
228 | ((pair? (lset-difference eq? fields | |
229 | '(expected ...))) | |
230 | (record-error 'name s | |
231 | "extraneous field initializers ~a" | |
232 | (lset-difference eq? fields | |
233 | '(expected ...)))) | |
234 | (else | |
235 | (record-error 'name s | |
236 | "missing field initializers ~a" | |
237 | (lset-difference eq? | |
238 | '(expected ...) | |
babc2c80 LC |
239 | fields))))))) |
240 | ((_ bindings (... ...)) | |
241 | ;; One of BINDINGS doesn't match the (field value) pattern. | |
242 | ;; Report precisely which one is faulty, instead of letting the | |
243 | ;; "source expression failed to match any pattern" error. | |
244 | (report-invalid-field-specifier 'name | |
47212fc7 LC |
245 | #'(bindings (... ...)) |
246 | s)))))))) | |
cf4efb39 | 247 | |
faef3b6a LC |
248 | (define-syntax-rule (define-field-property-predicate predicate property) |
249 | "Define PREDICATE as a procedure that takes a syntax object and, when passed | |
250 | a field specification, returns the field name if it has the given PROPERTY." | |
251 | (define (predicate s) | |
252 | (syntax-case s (property) | |
253 | ((field (property values (... ...)) _ (... ...)) | |
254 | #'field) | |
255 | ((field _ properties (... ...)) | |
256 | (predicate #'(field properties (... ...)))) | |
257 | (_ #f)))) | |
258 | ||
c0cd1b3e LC |
259 | (define-syntax define-record-type* |
260 | (lambda (s) | |
261 | "Define the given record type such that an additional \"syntactic | |
262 | constructor\" is defined, which allows instances to be constructed with named | |
e2540884 LC |
263 | field initializers, à la SRFI-35, as well as default values. An example use |
264 | may look like this: | |
265 | ||
266 | (define-record-type* <thing> thing make-thing | |
267 | thing? | |
d2be7e3c | 268 | this-thing |
e2540884 LC |
269 | (name thing-name (default \"chbouib\")) |
270 | (port thing-port | |
8a16d064 LC |
271 | (default (current-output-port)) (thunked)) |
272 | (loc thing-location (innate) (default (current-source-location)))) | |
e2540884 LC |
273 | |
274 | This example defines a macro 'thing' that can be used to instantiate records | |
275 | of this type: | |
276 | ||
277 | (thing | |
278 | (name \"foo\") | |
279 | (port (current-error-port))) | |
280 | ||
281 | The value of 'name' or 'port' could as well be omitted, in which case the | |
282 | default value specified in the 'define-record-type*' form is used: | |
283 | ||
284 | (thing) | |
285 | ||
286 | The 'port' field is \"thunked\", meaning that calls like '(thing-port x)' will | |
287 | actually compute the field's value in the current dynamic extent, which is | |
d2be7e3c LC |
288 | useful when referring to fluids in a field's value. Furthermore, that thunk |
289 | can access the record it belongs to via the 'this-thing' identifier. | |
e2540884 | 290 | |
310b32a2 LC |
291 | A field can also be marked as \"delayed\" instead of \"thunked\", in which |
292 | case its value is effectively wrapped in a (delay …) form. | |
293 | ||
e2540884 LC |
294 | It is possible to copy an object 'x' created with 'thing' like this: |
295 | ||
296 | (thing (inherit x) (name \"bar\")) | |
297 | ||
298 | This expression returns a new object equal to 'x' except for its 'name' | |
8a16d064 LC |
299 | field and its 'loc' field---the latter is marked as \"innate\", so it is not |
300 | inherited." | |
e2540884 | 301 | |
c0cd1b3e LC |
302 | (define (field-default-value s) |
303 | (syntax-case s (default) | |
304 | ((field (default val) _ ...) | |
305 | (list #'field #'val)) | |
792798f4 LC |
306 | ((field _ properties ...) |
307 | (field-default-value #'(field properties ...))) | |
c0cd1b3e LC |
308 | (_ #f))) |
309 | ||
faef3b6a LC |
310 | (define-field-property-predicate delayed-field? delayed) |
311 | (define-field-property-predicate thunked-field? thunked) | |
8a16d064 | 312 | (define-field-property-predicate innate-field? innate) |
c0cd1b3e | 313 | |
310b32a2 LC |
314 | (define (wrapped-field? s) |
315 | (or (thunked-field? s) (delayed-field? s))) | |
316 | ||
317 | (define (wrapped-field-accessor-name field) | |
c0cd1b3e | 318 | ;; Return the name (an unhygienic syntax object) of the "real" |
310b32a2 | 319 | ;; getter for field, which is assumed to be a wrapped field. |
c0cd1b3e | 320 | (syntax-case field () |
792798f4 | 321 | ((field get properties ...) |
c0cd1b3e LC |
322 | (let* ((getter (syntax->datum #'get)) |
323 | (real-getter (symbol-append '% getter '-real))) | |
324 | (datum->syntax #'get real-getter))))) | |
325 | ||
326 | (define (field-spec->srfi-9 field) | |
327 | ;; Convert a field spec of our style to a SRFI-9 field spec of the | |
328 | ;; form (field get). | |
329 | (syntax-case field () | |
792798f4 | 330 | ((name get properties ...) |
c0cd1b3e | 331 | #`(name |
310b32a2 LC |
332 | #,(if (wrapped-field? field) |
333 | (wrapped-field-accessor-name field) | |
c0cd1b3e LC |
334 | #'get))))) |
335 | ||
336 | (define (thunked-field-accessor-definition field) | |
337 | ;; Return the real accessor for FIELD, which is assumed to be a | |
338 | ;; thunked field. | |
339 | (syntax-case field () | |
340 | ((name get _ ...) | |
310b32a2 | 341 | (with-syntax ((real-get (wrapped-field-accessor-name field))) |
c0cd1b3e LC |
342 | #'(define-inlinable (get x) |
343 | ;; The real value of that field is a thunk, so call it. | |
abd4d6b3 | 344 | ((real-get x) x)))))) |
c0cd1b3e | 345 | |
310b32a2 LC |
346 | (define (delayed-field-accessor-definition field) |
347 | ;; Return the real accessor for FIELD, which is assumed to be a | |
348 | ;; delayed field. | |
349 | (syntax-case field () | |
350 | ((name get _ ...) | |
351 | (with-syntax ((real-get (wrapped-field-accessor-name field))) | |
352 | #'(define-inlinable (get x) | |
353 | ;; The real value of that field is a promise, so force it. | |
354 | (force (real-get x))))))) | |
355 | ||
7874bbbb LC |
356 | (define (compute-abi-cookie field-specs) |
357 | ;; Compute an "ABI cookie" for the given FIELD-SPECS. We use | |
358 | ;; 'string-hash' because that's a better hash function that 'hash' on a | |
359 | ;; list of symbols. | |
360 | (syntax-case field-specs () | |
361 | (((field get properties ...) ...) | |
362 | (string-hash (object->string | |
363 | (syntax->datum #'((field properties ...) ...))) | |
a05ad011 LC |
364 | (cond-expand |
365 | (guile-3 (target-most-positive-fixnum)) | |
366 | (else most-positive-fixnum)))))) | |
7874bbbb | 367 | |
c0cd1b3e LC |
368 | (syntax-case s () |
369 | ((_ type syntactic-ctor ctor pred | |
d2be7e3c | 370 | this-identifier |
792798f4 | 371 | (field get properties ...) ...) |
d2be7e3c | 372 | (identifier? #'this-identifier) |
792798f4 | 373 | (let* ((field-spec #'((field get properties ...) ...)) |
9b543456 | 374 | (thunked (filter-map thunked-field? field-spec)) |
310b32a2 | 375 | (delayed (filter-map delayed-field? field-spec)) |
8a16d064 | 376 | (innate (filter-map innate-field? field-spec)) |
9b543456 | 377 | (defaults (filter-map field-default-value |
7874bbbb LC |
378 | #'((field properties ...) ...))) |
379 | (cookie (compute-abi-cookie field-spec))) | |
c0cd1b3e LC |
380 | (with-syntax (((field-spec* ...) |
381 | (map field-spec->srfi-9 field-spec)) | |
382 | ((thunked-field-accessor ...) | |
383 | (filter-map (lambda (field) | |
384 | (and (thunked-field? field) | |
385 | (thunked-field-accessor-definition | |
386 | field))) | |
310b32a2 LC |
387 | field-spec)) |
388 | ((delayed-field-accessor ...) | |
389 | (filter-map (lambda (field) | |
390 | (and (delayed-field? field) | |
391 | (delayed-field-accessor-definition | |
392 | field))) | |
c0cd1b3e LC |
393 | field-spec))) |
394 | #`(begin | |
395 | (define-record-type type | |
396 | (ctor field ...) | |
397 | pred | |
398 | field-spec* ...) | |
7874bbbb LC |
399 | (define #,(current-abi-identifier #'type) |
400 | #,cookie) | |
d2be7e3c LC |
401 | |
402 | #,@(if (free-identifier=? #'this-identifier #'this-record) | |
403 | #'() | |
404 | #'((define-syntax-parameter this-identifier | |
405 | (lambda (s) | |
406 | "Return the record being defined. This macro may | |
407 | only be used in the context of the definition of a thunked field." | |
408 | (syntax-case s () | |
409 | (id | |
410 | (identifier? #'id) | |
411 | (syntax-violation 'this-identifier | |
412 | "cannot be used outside \ | |
413 | of a record instantiation" | |
414 | #'id))))))) | |
ad7c1a2c LC |
415 | thunked-field-accessor ... |
416 | delayed-field-accessor ... | |
39fc041a LC |
417 | (make-syntactic-constructor type syntactic-ctor ctor |
418 | (field ...) | |
7874bbbb | 419 | #:abi-cookie #,cookie |
39fc041a | 420 | #:thunked #,thunked |
d2be7e3c | 421 | #:this-identifier #'this-identifier |
39fc041a | 422 | #:delayed #,delayed |
8a16d064 | 423 | #:innate #,innate |
d2be7e3c LC |
424 | #:defaults #,defaults))))) |
425 | ((_ type syntactic-ctor ctor pred | |
426 | (field get properties ...) ...) | |
427 | ;; When no 'this' identifier was specified, use 'this-record'. | |
428 | #'(define-record-type* type syntactic-ctor ctor pred | |
429 | this-record | |
430 | (field get properties ...) ...))))) | |
c0cd1b3e | 431 | |
c8772a7a LC |
432 | (define* (alist->record alist make keys |
433 | #:optional (multiple-value-keys '())) | |
434 | "Apply MAKE to the values associated with KEYS in ALIST. Items in KEYS that | |
435 | are also in MULTIPLE-VALUE-KEYS are considered to occur possibly multiple | |
436 | times in ALIST, and thus their value is a list." | |
437 | (let ((args (map (lambda (key) | |
438 | (if (member key multiple-value-keys) | |
439 | (filter-map (match-lambda | |
440 | ((k . v) | |
441 | (and (equal? k key) v))) | |
442 | alist) | |
443 | (assoc-ref alist key))) | |
444 | keys))) | |
c0cd1b3e LC |
445 | (apply make args))) |
446 | ||
447 | (define (object->fields object fields port) | |
448 | "Write OBJECT (typically a record) as a series of recutils-style fields to | |
449 | PORT, according to FIELDS. FIELDS must be a list of field name/getter pairs." | |
450 | (let loop ((fields fields)) | |
451 | (match fields | |
452 | (() | |
453 | object) | |
454 | (((field . get) rest ...) | |
455 | (format port "~a: ~a~%" field (get object)) | |
456 | (loop rest))))) | |
457 | ||
fb519bd8 LC |
458 | (define %recutils-field-charset |
459 | ;; Valid characters starting a recutils field. | |
460 | ;; info "(recutils) Fields" | |
461 | (char-set-union char-set:upper-case | |
462 | char-set:lower-case | |
463 | (char-set #\%))) | |
836d10f1 | 464 | |
fdc1bf65 LC |
465 | (define (recutils->alist port) |
466 | "Read a recutils-style record from PORT and return it as a list of key/value | |
467 | pairs. Stop upon an empty line (after consuming it) or EOF." | |
468 | (let loop ((line (read-line port)) | |
469 | (result '())) | |
b7b88288 | 470 | (cond ((eof-object? line) |
fdc1bf65 | 471 | (reverse result)) |
b7b88288 LC |
472 | ((string-null? line) |
473 | (if (null? result) | |
474 | (loop (read-line port) result) ; leading space: ignore it | |
475 | (reverse result))) ; end-of-record marker | |
fdc1bf65 | 476 | (else |
fb519bd8 LC |
477 | ;; Now check the first character of LINE, since that's what the |
478 | ;; recutils manual says is enough. | |
479 | (let ((first (string-ref line 0))) | |
480 | (cond | |
481 | ((char-set-contains? %recutils-field-charset first) | |
482 | (let* ((colon (string-index line #\:)) | |
483 | (field (string-take line colon)) | |
484 | (value (string-trim (string-drop line (+ 1 colon))))) | |
485 | (loop (read-line port) | |
486 | (alist-cons field value result)))) | |
487 | ((eqv? first #\#) ;info "(recutils) Comments" | |
488 | (loop (read-line port) result)) | |
489 | ((eqv? first #\+) ;info "(recutils) Fields" | |
490 | (let ((new-line (if (string-prefix? "+ " line) | |
491 | (string-drop line 2) | |
492 | (string-drop line 1)))) | |
493 | (match result | |
494 | (((field . value) rest ...) | |
495 | (loop (read-line port) | |
496 | `((,field . ,(string-append value "\n" new-line)) | |
497 | ,@rest)))))) | |
498 | (else | |
499 | (error "unmatched line" line)))))))) | |
fdc1bf65 | 500 | |
6692d845 | 501 | (define-syntax match-record |
502 | (syntax-rules () | |
503 | "Bind each FIELD of a RECORD of the given TYPE to it's FIELD name. | |
504 | The current implementation does not support thunked and delayed fields." | |
505 | ((_ record type (field fields ...) body ...) | |
506 | (if (eq? (struct-vtable record) type) | |
507 | ;; TODO compute indices and report wrong-field-name errors at | |
508 | ;; expansion time | |
509 | ;; TODO support thunked and delayed fields | |
510 | (let ((field ((record-accessor type 'field) record))) | |
511 | (match-record record type (fields ...) body ...)) | |
512 | (throw 'wrong-type-arg record))) | |
513 | ((_ record type () body ...) | |
514 | (begin body ...)))) | |
515 | ||
c0cd1b3e | 516 | ;;; records.scm ends here |