summaryrefslogtreecommitdiff
diff options
context:
space:
mode:
-rw-r--r--Makefile.am22
-rw-r--r--guix/build-system.scm4
-rw-r--r--guix/gnu-maintenance.scm7
-rw-r--r--guix/packages.scm1
-rw-r--r--guix/records.scm214
-rwxr-xr-xguix/scripts/substitute-binary.scm17
-rw-r--r--guix/utils.scm165
-rw-r--r--tests/records.scm137
-rw-r--r--tests/utils.scm108
9 files changed, 368 insertions, 307 deletions
diff --git a/Makefile.am b/Makefile.am
index 3998e9123f..69b4af013a 100644
--- a/Makefile.am
+++ b/Makefile.am
@@ -35,6 +35,7 @@ MODULES = \
guix/scripts/substitute-binary.scm \
guix/scripts/refresh.scm \
guix/base32.scm \
+ guix/records.scm \
guix/utils.scm \
guix/serialization.scm \
guix/nar.scm \
@@ -85,7 +86,7 @@ MODULES = \
gnu/packages/cpio.scm \
gnu/packages/cppi.scm \
gnu/packages/cross-base.scm \
- gnu/packages/cryptsetup.scm \
+ gnu/packages/cryptsetup.scm \
gnu/packages/curl.scm \
gnu/packages/cyrus-sasl.scm \
gnu/packages/dejagnu.scm \
@@ -121,11 +122,11 @@ MODULES = \
gnu/packages/icu4c.scm \
gnu/packages/idutils.scm \
gnu/packages/indent.scm \
- gnu/packages/irssi.scm \
+ gnu/packages/irssi.scm \
gnu/packages/ld-wrapper.scm \
gnu/packages/less.scm \
gnu/packages/lesstif.scm \
- gnu/packages/libapr.scm \
+ gnu/packages/libapr.scm \
gnu/packages/libdaemon.scm \
gnu/packages/libevent.scm \
gnu/packages/libffi.scm \
@@ -156,7 +157,7 @@ MODULES = \
gnu/packages/ncurses.scm \
gnu/packages/netpbm.scm \
gnu/packages/nettle.scm \
- gnu/packages/ocaml.scm \
+ gnu/packages/ocaml.scm \
gnu/packages/oggvorbis.scm \
gnu/packages/openldap.scm \
gnu/packages/openssl.scm \
@@ -176,22 +177,22 @@ MODULES = \
gnu/packages/rsync.scm \
gnu/packages/samba.scm \
gnu/packages/scheme.scm \
- gnu/packages/screen.scm \
+ gnu/packages/screen.scm \
gnu/packages/shishi.scm \
gnu/packages/smalltalk.scm \
- gnu/packages/sqlite.scm \
+ gnu/packages/sqlite.scm \
gnu/packages/ssh.scm \
- gnu/packages/subversion.scm \
+ gnu/packages/subversion.scm \
gnu/packages/system.scm \
gnu/packages/tcl.scm \
- gnu/packages/tcsh.scm \
+ gnu/packages/tcsh.scm \
gnu/packages/texinfo.scm \
gnu/packages/texlive.scm \
gnu/packages/time.scm \
- gnu/packages/tmux.scm \
+ gnu/packages/tmux.scm \
gnu/packages/tor.scm \
gnu/packages/version-control.scm \
- gnu/packages/vim.scm \
+ gnu/packages/vim.scm \
gnu/packages/vpn.scm \
gnu/packages/w3m.scm \
gnu/packages/wdiff.scm \
@@ -313,6 +314,7 @@ SCM_TESTS = \
tests/builders.scm \
tests/derivations.scm \
tests/ui.scm \
+ tests/records.scm \
tests/utils.scm \
tests/build-utils.scm \
tests/packages.scm \
diff --git a/guix/build-system.scm b/guix/build-system.scm
index 0df5e4362b..c618a5e243 100644
--- a/guix/build-system.scm
+++ b/guix/build-system.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.
;;;
@@ -17,7 +17,7 @@
;;; along with GNU Guix. If not, see <http://www.gnu.org/licenses/>.
(define-module (guix build-system)
- #:use-module (guix utils)
+ #:use-module (guix records)
#:export (build-system
build-system?
build-system-name
diff --git a/guix/gnu-maintenance.scm b/guix/gnu-maintenance.scm
index e39094db72..b54cd84ecf 100644
--- a/guix/gnu-maintenance.scm
+++ b/guix/gnu-maintenance.scm
@@ -32,6 +32,7 @@
#:use-module (guix ftp-client)
#:use-module (guix ui)
#:use-module (guix utils)
+ #:use-module (guix records)
#:use-module (guix packages)
#:use-module ((guix download) #:select (download-to-store))
#:use-module (guix gnupg)
@@ -150,12 +151,6 @@
(remove null-list? state)
(match-field line))))
- (define (alist->record alist make keys)
- ;; Apply MAKE, which should be a syntactic constructor, to the
- ;; values associated with KEYS in ALIST.
- (let ((args (map (cut assoc-ref alist <>) keys)))
- (apply make args)))
-
(reverse
(map (lambda (alist)
(alist->record alist
diff --git a/guix/packages.scm b/guix/packages.scm
index 1cbbd2ec47..0549771cea 100644
--- a/guix/packages.scm
+++ b/guix/packages.scm
@@ -18,6 +18,7 @@
(define-module (guix packages)
#:use-module (guix utils)
+ #:use-module (guix records)
#:use-module (guix store)
#:use-module (guix base32)
#:use-module (guix derivations)
diff --git a/guix/records.scm b/guix/records.scm
new file mode 100644
index 0000000000..54e1c17752
--- /dev/null
+++ b/guix/records.scm
@@ -0,0 +1,214 @@
+;;; GNU Guix --- Functional package management for GNU
+;;; Copyright © 2012, 2013 Ludovic Courtès <ludo@gnu.org>
+;;;
+;;; This file is part of GNU Guix.
+;;;
+;;; GNU Guix is free software; you can redistribute it and/or modify it
+;;; under the terms of the GNU General Public License as published by
+;;; the Free Software Foundation; either version 3 of the License, or (at
+;;; your option) any later version.
+;;;
+;;; GNU Guix is distributed in the hope that it will be useful, but
+;;; WITHOUT ANY WARRANTY; without even the implied warranty of
+;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+;;; GNU General Public License for more details.
+;;;
+;;; You should have received a copy of the GNU General Public License
+;;; along with GNU Guix. If not, see <http://www.gnu.org/licenses/>.
+
+(define-module (guix records)
+ #:use-module (srfi srfi-1)
+ #:use-module (srfi srfi-9)
+ #:use-module (srfi srfi-26)
+ #:use-module (ice-9 match)
+ #:export (define-record-type*
+ alist->record
+ object->fields))
+
+;;; Commentary:
+;;;
+;;; Utilities for dealing with Scheme records.
+;;;
+;;; Code:
+
+(define-syntax define-record-type*
+ (lambda (s)
+ "Define the given record type such that an additional \"syntactic
+constructor\" is defined, which allows instances to be constructed with named
+field initializers, à la SRFI-35, as well as default values."
+ (define (make-syntactic-constructor type name ctor fields thunked defaults)
+ "Make the syntactic constructor NAME for TYPE, that calls CTOR, and
+expects all of FIELDS to be initialized. DEFAULTS is the list of
+FIELD/DEFAULT-VALUE tuples, and THUNKED is the list of identifiers of
+thunked fields."
+ (with-syntax ((type type)
+ (name name)
+ (ctor ctor)
+ (expected fields)
+ (defaults defaults))
+ #`(define-syntax name
+ (lambda (s)
+ (define (record-inheritance orig-record field+value)
+ ;; Produce code that returns a record identical to
+ ;; ORIG-RECORD, except that values for the FIELD+VALUE alist
+ ;; prevail.
+ (define (field-inherited-value f)
+ (and=> (find (lambda (x)
+ (eq? f (car (syntax->datum x))))
+ field+value)
+ car))
+
+ #`(make-struct type 0
+ #,@(map (lambda (field index)
+ (or (field-inherited-value field)
+ #`(struct-ref #,orig-record
+ #,index)))
+ 'expected
+ (iota (length 'expected)))))
+
+ (define (thunked-field? f)
+ (memq (syntax->datum f) '#,thunked))
+
+ (define (field-bindings field+value)
+ ;; Return field to value bindings, for use in `letrec*' below.
+ (map (lambda (field+value)
+ (syntax-case field+value ()
+ ((field value)
+ #`(field
+ #,(if (thunked-field? #'field)
+ #'(lambda () value)
+ #'value)))))
+ field+value))
+
+ (syntax-case s (inherit #,@fields)
+ ((_ (inherit orig-record) (field value) (... ...))
+ #`(letrec* #,(field-bindings #'((field value) (... ...)))
+ #,(record-inheritance #'orig-record
+ #'((field value) (... ...)))))
+ ((_ (field value) (... ...))
+ (let ((fields (map syntax->datum #'(field (... ...))))
+ (dflt (map (match-lambda
+ ((f v)
+ (list (syntax->datum f) v)))
+ #'defaults)))
+
+ (define (field-value f)
+ (or (and=> (find (lambda (x)
+ (eq? f (car (syntax->datum x))))
+ #'((field value) (... ...)))
+ car)
+ (let ((value
+ (car (assoc-ref dflt
+ (syntax->datum f)))))
+ (if (thunked-field? f)
+ #`(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)
+ #`(letrec* #,(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)))))))))))))
+
+ (define (field-default-value s)
+ (syntax-case s (default)
+ ((field (default val) _ ...)
+ (list #'field #'val))
+ ((field _ options ...)
+ (field-default-value #'(field options ...)))
+ (_ #f)))
+
+ (define (thunked-field? s)
+ ;; Return the field name if the field defined by S is thunked.
+ (syntax-case s (thunked)
+ ((field (thunked) _ ...)
+ #'field)
+ ((field _ options ...)
+ (thunked-field? #'(field options ...)))
+ (_ #f)))
+
+ (define (thunked-field-accessor-name field)
+ ;; Return the name (an unhygienic syntax object) of the "real"
+ ;; getter for field, which is assumed to be a thunked field.
+ (syntax-case field ()
+ ((field get options ...)
+ (let* ((getter (syntax->datum #'get))
+ (real-getter (symbol-append '% getter '-real)))
+ (datum->syntax #'get real-getter)))))
+
+ (define (field-spec->srfi-9 field)
+ ;; Convert a field spec of our style to a SRFI-9 field spec of the
+ ;; form (field get).
+ (syntax-case field ()
+ ((name get options ...)
+ #`(name
+ #,(if (thunked-field? field)
+ (thunked-field-accessor-name field)
+ #'get)))))
+
+ (define (thunked-field-accessor-definition field)
+ ;; Return the real accessor for FIELD, which is assumed to be a
+ ;; thunked field.
+ (syntax-case field ()
+ ((name get _ ...)
+ (with-syntax ((real-get (thunked-field-accessor-name field)))
+ #'(define-inlinable (get x)
+ ;; The real value of that field is a thunk, so call it.
+ ((real-get x)))))))
+
+ (syntax-case s ()
+ ((_ type syntactic-ctor ctor pred
+ (field get options ...) ...)
+ (let* ((field-spec #'((field get options ...) ...)))
+ (with-syntax (((field-spec* ...)
+ (map field-spec->srfi-9 field-spec))
+ ((thunked-field-accessor ...)
+ (filter-map (lambda (field)
+ (and (thunked-field? field)
+ (thunked-field-accessor-definition
+ field)))
+ field-spec)))
+ #`(begin
+ (define-record-type type
+ (ctor field ...)
+ pred
+ field-spec* ...)
+ (begin thunked-field-accessor ...)
+ #,(make-syntactic-constructor #'type #'syntactic-ctor #'ctor
+ #'(field ...)
+ (filter-map thunked-field? field-spec)
+ (filter-map field-default-value
+ #'((field options ...)
+ ...))))))))))
+
+(define (alist->record alist make keys)
+ "Apply MAKE to the values associated with KEYS in ALIST."
+ (let ((args (map (cut assoc-ref alist <>) keys)))
+ (apply make args)))
+
+(define (object->fields object fields port)
+ "Write OBJECT (typically a record) as a series of recutils-style fields to
+PORT, according to FIELDS. FIELDS must be a list of field name/getter pairs."
+ (let loop ((fields fields))
+ (match fields
+ (()
+ object)
+ (((field . get) rest ...)
+ (format port "~a: ~a~%" field (get object))
+ (loop rest)))))
+
+;;; records.scm ends here
diff --git a/guix/scripts/substitute-binary.scm b/guix/scripts/substitute-binary.scm
index 995078e630..5965e936f9 100755
--- a/guix/scripts/substitute-binary.scm
+++ b/guix/scripts/substitute-binary.scm
@@ -21,6 +21,7 @@
#:use-module (guix store)
#:use-module (guix utils)
#:use-module (guix config)
+ #:use-module (guix records)
#:use-module (guix nar)
#:use-module ((guix build utils) #:select (mkdir-p))
#:use-module (ice-9 rdelim)
@@ -103,22 +104,6 @@ pairs."
(else
(error "unmatched line" line)))))
-(define (alist->record alist make keys)
- "Apply MAKE to the values associated with KEYS in ALIST."
- (let ((args (map (cut assoc-ref alist <>) keys)))
- (apply make args)))
-
-(define (object->fields object fields port)
- "Write OBJECT (typically a record) as a series of recutils-style fields to
-PORT, according to FIELDS. FIELDS must be a list of field name/getter pairs."
- (let loop ((fields fields))
- (match fields
- (()
- object)
- (((field . get) rest ...)
- (format port "~a: ~a~%" field (get object))
- (loop rest)))))
-
(define (fetch uri)
"Return a binary input port to URI and the number of bytes it's expected to
provide."
diff --git a/guix/utils.scm b/guix/utils.scm
index 7c8e914c01..c2d2808f76 100644
--- a/guix/utils.scm
+++ b/guix/utils.scm
@@ -42,7 +42,6 @@
nixpkgs-derivation
nixpkgs-derivation*
- define-record-type*
compile-time-value
memoize
default-keyword-arguments
@@ -239,170 +238,6 @@ wait."
;;; Miscellaneous.
;;;
-(define-syntax define-record-type*
- (lambda (s)
- "Define the given record type such that an additional \"syntactic
-constructor\" is defined, which allows instances to be constructed with named
-field initializers, à la SRFI-35, as well as default values."
- (define (make-syntactic-constructor type name ctor fields thunked defaults)
- "Make the syntactic constructor NAME for TYPE, that calls CTOR, and
-expects all of FIELDS to be initialized. DEFAULTS is the list of
-FIELD/DEFAULT-VALUE tuples, and THUNKED is the list of identifiers of
-thunked fields."
- (with-syntax ((type type)
- (name name)
- (ctor ctor)
- (expected fields)
- (defaults defaults))
- #`(define-syntax name
- (lambda (s)
- (define (record-inheritance orig-record field+value)
- ;; Produce code that returns a record identical to
- ;; ORIG-RECORD, except that values for the FIELD+VALUE alist
- ;; prevail.
- (define (field-inherited-value f)
- (and=> (find (lambda (x)
- (eq? f (car (syntax->datum x))))
- field+value)
- car))
-
- #`(make-struct type 0
- #,@(map (lambda (field index)
- (or (field-inherited-value field)
- #`(struct-ref #,orig-record
- #,index)))
- 'expected
- (iota (length 'expected)))))
-
- (define (thunked-field? f)
- (memq (syntax->datum f) '#,thunked))
-
- (define (field-bindings field+value)
- ;; Return field to value bindings, for use in `letrec*' below.
- (map (lambda (field+value)
- (syntax-case field+value ()
- ((field value)
- #`(field
- #,(if (thunked-field? #'field)
- #'(lambda () value)
- #'value)))))
- field+value))
-
- (syntax-case s (inherit #,@fields)
- ((_ (inherit orig-record) (field value) (... ...))
- #`(letrec* #,(field-bindings #'((field value) (... ...)))
- #,(record-inheritance #'orig-record
- #'((field value) (... ...)))))
- ((_ (field value) (... ...))
- (let ((fields (map syntax->datum #'(field (... ...))))
- (dflt (map (match-lambda
- ((f v)
- (list (syntax->datum f) v)))
- #'defaults)))
-
- (define (field-value f)
- (or (and=> (find (lambda (x)
- (eq? f (car (syntax->datum x))))
- #'((field value) (... ...)))
- car)
- (let ((value
- (car (assoc-ref dflt
- (syntax->datum f)))))
- (if (thunked-field? f)
- #`(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)
- #`(letrec* #,(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)))))))))))))
-
- (define (field-default-value s)
- (syntax-case s (default)
- ((field (default val) _ ...)
- (list #'field #'val))
- ((field _ options ...)
- (field-default-value #'(field options ...)))
- (_ #f)))
-
- (define (thunked-field? s)
- ;; Return the field name if the field defined by S is thunked.
- (syntax-case s (thunked)
- ((field (thunked) _ ...)
- #'field)
- ((field _ options ...)
- (thunked-field? #'(field options ...)))
- (_ #f)))
-
- (define (thunked-field-accessor-name field)
- ;; Return the name (an unhygienic syntax object) of the "real"
- ;; getter for field, which is assumed to be a thunked field.
- (syntax-case field ()
- ((field get options ...)
- (let* ((getter (syntax->datum #'get))
- (real-getter (symbol-append '% getter '-real)))
- (datum->syntax #'get real-getter)))))
-
- (define (field-spec->srfi-9 field)
- ;; Convert a field spec of our style to a SRFI-9 field spec of the
- ;; form (field get).
- (syntax-case field ()
- ((name get options ...)
- #`(name
- #,(if (thunked-field? field)
- (thunked-field-accessor-name field)
- #'get)))))
-
- (define (thunked-field-accessor-definition field)
- ;; Return the real accessor for FIELD, which is assumed to be a
- ;; thunked field.
- (syntax-case field ()
- ((name get _ ...)
- (with-syntax ((real-get (thunked-field-accessor-name field)))
- #'(define-inlinable (get x)
- ;; The real value of that field is a thunk, so call it.
- ((real-get x)))))))
-
- (syntax-case s ()
- ((_ type syntactic-ctor ctor pred
- (field get options ...) ...)
- (let* ((field-spec #'((field get options ...) ...)))
- (with-syntax (((field-spec* ...)
- (map field-spec->srfi-9 field-spec))
- ((thunked-field-accessor ...)
- (filter-map (lambda (field)
- (and (thunked-field? field)
- (thunked-field-accessor-definition
- field)))
- field-spec)))
- #`(begin
- (define-record-type type
- (ctor field ...)
- pred
- field-spec* ...)
- (begin thunked-field-accessor ...)
- #,(make-syntactic-constructor #'type #'syntactic-ctor #'ctor
- #'(field ...)
- (filter-map thunked-field? field-spec)
- (filter-map field-default-value
- #'((field options ...)
- ...))))))))))
-
(define (memoize proc)
"Return a memoizing version of PROC."
(let ((cache (make-hash-table)))
diff --git a/tests/records.scm b/tests/records.scm
new file mode 100644
index 0000000000..9e524b670c
--- /dev/null
+++ b/tests/records.scm
@@ -0,0 +1,137 @@
+;;; GNU Guix --- Functional package management for GNU
+;;; Copyright © 2012, 2013 Ludovic Courtès <ludo@gnu.org>
+;;;
+;;; This file is part of GNU Guix.
+;;;
+;;; GNU Guix is free software; you can redistribute it and/or modify it
+;;; under the terms of the GNU General Public License as published by
+;;; the Free Software Foundation; either version 3 of the License, or (at
+;;; your option) any later version.
+;;;
+;;; GNU Guix is distributed in the hope that it will be useful, but
+;;; WITHOUT ANY WARRANTY; without even the implied warranty of
+;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+;;; GNU General Public License for more details.
+;;;
+;;; You should have received a copy of the GNU General Public License
+;;; along with GNU Guix. If not, see <http://www.gnu.org/licenses/>.
+
+(define-module (test-records)
+ #:use-module (srfi srfi-64)
+ #:use-module (ice-9 match)
+ #:use-module (guix records))
+
+(test-begin "records")
+
+(test-assert "define-record-type*"
+ (begin
+ (define-record-type* <foo> foo make-foo
+ foo?
+ (bar foo-bar)
+ (baz foo-baz (default (+ 40 2))))
+ (and (match (foo (bar 1) (baz 2))
+ (($ <foo> 1 2) #t))
+ (match (foo (baz 2) (bar 1))
+ (($ <foo> 1 2) #t))
+ (match (foo (bar 1))
+ (($ <foo> 1 42) #t)))))
+
+(test-assert "define-record-type* with letrec* behavior"
+ ;; Make sure field initializers can refer to each other as if they were in
+ ;; a `letrec*'.
+ (begin
+ (define-record-type* <bar> bar make-bar
+ foo?
+ (x bar-x)
+ (y bar-y (default (+ 40 2)))
+ (z bar-z))
+ (and (match (bar (x 1) (y (+ x 1)) (z (* y 2)))
+ (($ <bar> 1 2 4) #t))
+ (match (bar (x 7) (z (* x 3)))
+ (($ <bar> 7 42 21)))
+ (match (bar (z 21) (x (/ z 3)))
+ (($ <bar> 7 42 21))))))
+
+(test-assert "define-record-type* & inherit"
+ (begin
+ (define-record-type* <foo> foo make-foo
+ foo?
+ (bar foo-bar)
+ (baz foo-baz (default (+ 40 2))))
+ (let* ((a (foo (bar 1)))
+ (b (foo (inherit a) (baz 2)))
+ (c (foo (inherit b) (bar -2)))
+ (d (foo (inherit c)))
+ (e (foo (inherit (foo (bar 42))) (baz 77))))
+ (and (match a (($ <foo> 1 42) #t))
+ (match b (($ <foo> 1 2) #t))
+ (match c (($ <foo> -2 2) #t))
+ (equal? c d)
+ (match e (($ <foo> 42 77) #t))))))
+
+(test-assert "define-record-type* & inherit & letrec* behavior"
+ (begin
+ (define-record-type* <foo> foo make-foo
+ foo?
+ (bar foo-bar)
+ (baz foo-baz (default (+ 40 2))))
+ (let* ((a (foo (bar 77)))
+ (b (foo (inherit a) (bar 1) (baz (+ bar 1))))
+ (c (foo (inherit b) (baz 2) (bar (- baz 1)))))
+ (and (match a (($ <foo> 77 42) #t))
+ (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))))))))
+
+(test-end)
+
+
+(exit (= (test-runner-fail-count (test-runner-current)) 0))
diff --git a/tests/utils.scm b/tests/utils.scm
index f14412e61e..c2fb274193 100644
--- a/tests/utils.scm
+++ b/tests/utils.scm
@@ -126,114 +126,6 @@
(append pids1 pids2)))
(equal? (get-bytevector-all decompressed) data)))))
-(test-assert "define-record-type*"
- (begin
- (define-record-type* <foo> foo make-foo
- foo?
- (bar foo-bar)
- (baz foo-baz (default (+ 40 2))))
- (and (match (foo (bar 1) (baz 2))
- (($ <foo> 1 2) #t))
- (match (foo (baz 2) (bar 1))
- (($ <foo> 1 2) #t))
- (match (foo (bar 1))
- (($ <foo> 1 42) #t)))))
-
-(test-assert "define-record-type* with letrec* behavior"
- ;; Make sure field initializers can refer to each other as if they were in
- ;; a `letrec*'.
- (begin
- (define-record-type* <bar> bar make-bar
- foo?
- (x bar-x)
- (y bar-y (default (+ 40 2)))
- (z bar-z))
- (and (match (bar (x 1) (y (+ x 1)) (z (* y 2)))
- (($ <bar> 1 2 4) #t))
- (match (bar (x 7) (z (* x 3)))
- (($ <bar> 7 42 21)))
- (match (bar (z 21) (x (/ z 3)))
- (($ <bar> 7 42 21))))))
-
-(test-assert "define-record-type* & inherit"
- (begin
- (define-record-type* <foo> foo make-foo
- foo?
- (bar foo-bar)
- (baz foo-baz (default (+ 40 2))))
- (let* ((a (foo (bar 1)))
- (b (foo (inherit a) (baz 2)))
- (c (foo (inherit b) (bar -2)))
- (d (foo (inherit c)))
- (e (foo (inherit (foo (bar 42))) (baz 77))))
- (and (match a (($ <foo> 1 42) #t))
- (match b (($ <foo> 1 2) #t))
- (match c (($ <foo> -2 2) #t))
- (equal? c d)
- (match e (($ <foo> 42 77) #t))))))
-
-(test-assert "define-record-type* & inherit & letrec* behavior"
- (begin
- (define-record-type* <foo> foo make-foo
- foo?
- (bar foo-bar)
- (baz foo-baz (default (+ 40 2))))
- (let* ((a (foo (bar 77)))
- (b (foo (inherit a) (bar 1) (baz (+ bar 1))))
- (c (foo (inherit b) (baz 2) (bar (- baz 1)))))
- (and (match a (($ <foo> 77 42) #t))
- (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"