amaharaneko/guix-mirrors
1
1
Fork 0
mirror of https://codeberg.org/guix/guix.git synced 2025-10-02 02:15:12 +00:00
Code Issues Projects Releases Packages Wiki Activity Actions

define-record-type*: Add `letrec*' behavior.

Browse source 
* guix/utils.scm (define-record-type*)[make-syntactic-constructor]: Bind
  all the ((FIELD VALUE) ...) in a `letrec*'.  Adjust `field-value'
  accordingly.

* tests/utils.scm ("define-record-type* with letrec* behavior"): New
  test.
This commit is contained in:
Ludovic Courtès 2012-07-01 17:32:03 +02:00
parent e4c245f8a5
commit 8fd5bd2b69
2 changed files with 29 additions and 14 deletions
Download patch file Download diff file Expand all files Collapse all files

27
guix/utils.scm
View file

@ -479,20 +479,18 @@ tuples."
(lambda (s)
(syntax-case s expected
((_ (field value) (... ...))
(let ((fields (map syntax->datum #'(field (... ...))))
(inits (map (match-lambda
((f v)
(list (syntax->datum f) v)))
#'((field value) (... ...))))
(dflt (map (match-lambda
((f v)
(list (syntax->datum f) v)))
#'defaults)))
(let ((fields (map syntax->datum #'(field (... ...))))
(dflt (map (match-lambda
((f v)
(list (syntax->datum f) v)))
#'defaults)))
(define (field-value f)
(match (assoc f inits)
((_ v) v)
(#f (car (assoc-ref dflt f)))))
(define (field-value f)
(or (and=> (find (lambda (x)
(eq? f (car (syntax->datum x))))
#'((field value) (... ...)))
car)
(car (assoc-ref dflt (syntax->datum f)))))
(let-syntax ((error*
(syntax-rules ()
@ -503,7 +501,8 @@ tuples."
s)))))
(let ((fields (append fields (map car dflt))))
(cond ((lset= eq? fields 'expected)
#`(ctor #,@(map field-value 'expected)))
#`(letrec* ((field value) (... ...))
(ctor #,@(map field-value 'expected))))
((pair? (lset-difference eq? fields 'expected))
(error* "extraneous field initializers ~a"
(lset-difference eq? fields 'expected)))