From bbb7a00e9a224d812a56c67956efb3e8a840cf0a Mon Sep 17 00:00:00 2001
From: Ludovic Courtès <ludo@gnu.org>
Date: Wed, 23 Jan 2013 22:24:47 +0100
Subject: define-record-type*: Add the `thunked' field definition keyword.

* guix/utils.scm (define-record-type*)[make-syntactic-constructor]: Add
  a `thunked' parameter.
  (thunked-field?, field-bindings): New procedures.  Use the latter when
  generating `letrec*' bindings.
  [thunked-field?, thunked-field-accessor-name, field-spec->srfi-9,
  thunked-field-accessor-name]: New procedures.
  Use them when generating the `define-record-type' form, and to
  generated thunk field accessors, along call to
  `make-syntactic-constructor' with the new argument.
* tests/utils.scm ("define-record-type* & thunked",
  "define-record-type* & thunked & default",
  "define-record-type* & thunked & inherited"): New tests.
---
 tests/utils.scm | 51 ++++++++++++++++++++++++++++++++++++++++++++++++++-
 1 file changed, 50 insertions(+), 1 deletion(-)

(limited to 'tests')

diff --git a/tests/utils.scm b/tests/utils.scm
index 59fde5ac06..96496c5f84 100644
--- a/tests/utils.scm
+++ b/tests/utils.scm
@@ -1,5 +1,5 @@
 ;;; GNU Guix --- Functional package management for GNU
-;;; Copyright © 2012 Ludovic Courtès <ludo@gnu.org>
+;;; Copyright © 2012, 2013 Ludovic Courtès <ludo@gnu.org>
 ;;;
 ;;; This file is part of GNU Guix.
 ;;;
@@ -123,6 +123,55 @@
           (match b (($ <foo> 1 2) #t))
           (equal? b c)))))
 
+(test-assert "define-record-type* & thunked"
+  (begin
+    (define-record-type* <foo> foo make-foo
+      foo?
+      (bar foo-bar)
+      (baz foo-baz (thunked)))
+
+    (let* ((calls 0)
+           (x     (foo (bar 2)
+                       (baz (begin (set! calls (1+ calls)) 3)))))
+      (and (zero? calls)
+           (equal? (foo-bar x) 2)
+           (equal? (foo-baz x) 3) (= 1 calls)
+           (equal? (foo-baz x) 3) (= 2 calls)))))
+
+(test-assert "define-record-type* & thunked & default"
+  (begin
+    (define-record-type* <foo> foo make-foo
+      foo?
+      (bar foo-bar)
+      (baz foo-baz (thunked) (default 42)))
+
+    (let ((mark (make-parameter #f)))
+      (let ((x (foo (bar 2) (baz (mark))))
+            (y (foo (bar 2))))
+        (and (equal? (foo-bar x) 2)
+             (parameterize ((mark (cons 'a 'b)))
+               (eq? (foo-baz x) (mark)))
+             (equal? (foo-bar y) 2)
+             (equal? (foo-baz y) 42))))))
+
+(test-assert "define-record-type* & thunked & inherited"
+  (begin
+    (define-record-type* <foo> foo make-foo
+      foo?
+      (bar foo-bar (thunked))
+      (baz foo-baz (thunked) (default 42)))
+
+    (let ((mark (make-parameter #f)))
+      (let* ((x (foo (bar 2) (baz (mark))))
+             (y (foo (inherit x) (bar (mark)))))
+        (and (equal? (foo-bar x) 2)
+             (parameterize ((mark (cons 'a 'b)))
+               (eq? (foo-baz x) (mark)))
+             (parameterize ((mark (cons 'a 'b)))
+               (eq? (foo-bar y) (mark)))
+             (parameterize ((mark (cons 'a 'b)))
+               (eq? (foo-baz y) (mark))))))))
+
 ;; This is actually in (guix store).
 (test-equal "store-path-package-name"
   "bash-4.2-p24"
-- 
cgit v1.2.3