From cb09314846faf62461d63b17e108a95d7cff18c4 Mon Sep 17 00:00:00 2001 From: Mark H Weaver Date: Wed, 7 Nov 2012 12:21:44 -0500 Subject: [PATCH] Implement functional record setters. MIME-Version: 1.0 Content-Type: text/plain; charset=UTF-8 Content-Transfer-Encoding: 8bit Written in collaboration with Ludovic Courtès * module/srfi/srfi-9.scm: Internally, rename 'accessor' to 'getter' and 'modifier' to 'setter'. (define-tagged-inlinable, getter-type, getter-index, getter-copier, %%on-error, %%set-fields): New macros. (%define-record-type): New macro for creating both mutable and immutable records, and containing a substantially rewritten version of the code formerly in 'define-record-type'. (define-record-type): Now just a wrapper for '%define-record-type'. (throw-bad-struct, make-copier-id): New procedures. * module/srfi/srfi-9/gnu.scm (define-immutable-record-type, set-field, and set-fields): New exported macros. (collate-set-field-specs): New procedure. (%set-fields-unknown-getter, %set-fields): New macros. * test-suite/tests/srfi-9.test: Add tests. --- module/srfi/srfi-9.scm | 252 ++++++++++++++++++++---------- module/srfi/srfi-9/gnu.scm | 100 +++++++++++- test-suite/tests/srfi-9.test | 348 ++++++++++++++++++++++++++++++++++++++---- 3 files changed, 589 insertions(+), 111 deletions(-) diff --git a/module/srfi/srfi-9.scm b/module/srfi/srfi-9.scm index da71d1e..1dd132a 100644 --- a/module/srfi/srfi-9.scm +++ b/module/srfi/srfi-9.scm @@ -29,8 +29,8 @@ ;; ;; ...) ;; -;; -> ( ) -;; -> ( ) +;; -> ( ) +;; -> ( ) ;; ;; -> ;; <... name> -> @@ -68,8 +68,31 @@ ;; because the public one has a different `make-procedure-name', so ;; using it would require users to recompile code that uses SRFI-9. See ;; . +;; + +(define-syntax-rule (define-inlinable (name formals ...) body ...) + (define-tagged-inlinable () (name formals ...) body ...)) + +;; 'define-tagged-inlinable' has an additional feature: it stores a map +;; of keys to values that can be retrieved at expansion time. This is +;; currently used to retrieve the rtd id, field index, and record copier +;; macro for an arbitrary getter. + +(define-syntax-rule (%%on-error err) err) + +(define %%type #f) ; a private syntax literal +(define-syntax-rule (getter-type getter err) + (getter (%%on-error err) %%type)) -(define-syntax define-inlinable +(define %%index #f) ; a private syntax literal +(define-syntax-rule (getter-index getter err) + (getter (%%on-error err) %%index)) + +(define %%copier #f) ; a private syntax literal +(define-syntax-rule (getter-copier getter err) + (getter (%%on-error err) %%copier)) + +(define-syntax define-tagged-inlinable (lambda (x) (define (make-procedure-name name) (datum->syntax name @@ -77,7 +100,7 @@ '-procedure))) (syntax-case x () - ((_ (name formals ...) body ...) + ((_ ((key value) ...) (name formals ...) body ...) (identifier? #'name) (with-syntax ((proc-name (make-procedure-name #'name)) ((args ...) (generate-temporaries #'(formals ...)))) @@ -86,7 +109,8 @@ body ...) (define-syntax name (lambda (x) - (syntax-case x () + (syntax-case x (%%on-error key ...) + ((_ (%%on-error err) key) #'value) ... ((_ args ...) #'((lambda (formals ...) body ...) @@ -109,90 +133,149 @@ (loop (cdr fields) (+ 1 off))))) (display ">" p)) -(define-syntax define-record-type +(define (throw-bad-struct s who) + (throw 'wrong-type-arg who + "Wrong type argument: ~S" (list s) + (list s))) + +(define (make-copier-id type-name) + (datum->syntax type-name + (symbol-append '%% (syntax->datum type-name) + '-set-fields))) + +(define-syntax %%set-fields + (lambda (x) + (syntax-case x () + ((_ type-name (getter-id ...) check? s (getter expr) ...) + (every identifier? #'(getter ...)) + (let ((copier-name (syntax->datum (make-copier-id #'type-name))) + (getter+exprs #'((getter expr) ...))) + (define (lookup id default-expr) + (let ((results + (filter (lambda (g+e) + (free-identifier=? id (car g+e))) + getter+exprs))) + (case (length results) + ((0) default-expr) + ((1) (cadar results)) + (else (syntax-violation + copier-name "duplicate getter" x id))))) + (for-each (lambda (id) + (or (find (lambda (getter-id) + (free-identifier=? id getter-id)) + #'(getter-id ...)) + (syntax-violation + copier-name "unknown getter" x id))) + #'(getter ...)) + (with-syntax ((unsafe-expr + #`(make-struct + type-name 0 + #,@(map (lambda (getter index) + (lookup getter #`(struct-ref s #,index))) + #'(getter-id ...) + (iota (length #'(getter-id ...))))))) + (if (syntax->datum #'check?) + #`(if (eq? (struct-vtable s) type-name) + unsafe-expr + (throw-bad-struct + s '#,(datum->syntax #'here copier-name))) + #'unsafe-expr))))))) + +(define-syntax %define-record-type (lambda (x) (define (field-identifiers field-specs) - (syntax-case field-specs () - (() - '()) - ((field-spec) - (syntax-case #'field-spec () - ((name accessor) #'(name)) - ((name accessor modifier) #'(name)))) - ((field-spec rest ...) - (append (field-identifiers #'(field-spec)) - (field-identifiers #'(rest ...)))))) - - (define (field-indices fields) - (fold (lambda (field result) - (let ((i (if (null? result) - 0 - (+ 1 (cdar result))))) - (alist-cons field i result))) - '() - fields)) - - (define (constructor type-name constructor-spec indices) + (map (lambda (field-spec) + (syntax-case field-spec () + ((name getter) #'name) + ((name getter setter) #'name))) + field-specs)) + + (define (getter-identifiers field-specs) + (map (lambda (field-spec) + (syntax-case field-spec () + ((name getter) #'getter) + ((name getter setter) #'getter))) + field-specs)) + + (define (constructor form type-name constructor-spec field-names) (syntax-case constructor-spec () ((ctor field ...) - (let ((field-count (length indices)) - (ctor-args (map (lambda (field) - (cons (syntax->datum field) field)) - #'(field ...)))) + (every identifier? #'(field ...)) + (let ((ctor-args (map (lambda (field) + (let ((name (syntax->datum field))) + (or (memq name field-names) + (syntax-violation + 'define-record-type + "unknown field in constructor-spec" + form field)) + (cons name field))) + #'(field ...)))) #`(define-inlinable #,constructor-spec (make-struct #,type-name 0 - #,@(unfold - (lambda (field-num) - (>= field-num field-count)) - (lambda (field-num) - (let* ((name - (car (find (lambda (f+i) - (= (cdr f+i) field-num)) - indices))) - (arg (assq name ctor-args))) - (if (pair? arg) - (cdr arg) - #'#f))) - 1+ - 0))))))) - - (define (accessors type-name field-specs indices) - (syntax-case field-specs () - (() - #'()) - ((field-spec) - (syntax-case #'field-spec () - ((name accessor) - (with-syntax ((index (assoc-ref indices (syntax->datum #'name)))) - #`((define-inlinable (accessor s) - (if (eq? (struct-vtable s) #,type-name) - (struct-ref s index) - (throw 'wrong-type-arg 'accessor - "Wrong type argument: ~S" (list s) - (list s))))))) - ((name accessor modifier) - (with-syntax ((index (assoc-ref indices (syntax->datum #'name)))) - #`(#,@(accessors type-name #'((name accessor)) indices) - (define-inlinable (modifier s val) - (if (eq? (struct-vtable s) #,type-name) - (struct-set! s index val) - (throw 'wrong-type-arg 'modifier - "Wrong type argument: ~S" (list s) - (list s))))))))) - ((field-spec rest ...) - #`(#,@(accessors type-name #'(field-spec) indices) - #,@(accessors type-name #'(rest ...) indices))))) + #,@(map (lambda (name) + (assq-ref ctor-args name)) + field-names))))))) + + (define (getters type-name getter-ids copier-id) + (map (lambda (getter index) + #`(define-tagged-inlinable + ((%%type #,type-name) + (%%index #,index) + (%%copier #,copier-id)) + (#,getter s) + (if (eq? (struct-vtable s) #,type-name) + (struct-ref s #,index) + (throw-bad-struct s '#,getter)))) + getter-ids + (iota (length getter-ids)))) + + (define (copier type-name getter-ids copier-id) + #`(define-syntax-rule + (#,copier-id check? s (getter expr) (... ...)) + (%%set-fields #,type-name #,getter-ids + check? s (getter expr) (... ...)))) + + (define (setters type-name field-specs) + (filter-map (lambda (field-spec index) + (syntax-case field-spec () + ((name getter) #f) + ((name getter setter) + #`(define-inlinable (setter s val) + (if (eq? (struct-vtable s) #,type-name) + (struct-set! s #,index val) + (throw-bad-struct s 'setter)))))) + field-specs + (iota (length field-specs)))) + + (define (functional-setters copier-id field-specs) + (filter-map (lambda (field-spec index) + (syntax-case field-spec () + ((name getter) #f) + ((name getter setter) + #`(define-inlinable (setter s val) + (#,copier-id #t s (getter val)))))) + field-specs + (iota (length field-specs)))) + + (define (record-layout immutable? count) + (let ((desc (if immutable? "pr" "pw"))) + (string-concatenate (make-list count desc)))) (syntax-case x () - ((_ type-name constructor-spec predicate-name field-spec ...) - (let* ((fields (field-identifiers #'(field-spec ...))) - (field-count (length fields)) - (layout (string-concatenate (make-list field-count "pw"))) - (indices (field-indices (map syntax->datum fields))) + ((_ immutable? type-name constructor-spec predicate-name + field-spec ...) + (boolean? (syntax->datum #'immutable?)) + (let* ((field-ids (field-identifiers #'(field-spec ...))) + (getter-ids (getter-identifiers #'(field-spec ...))) + (field-count (length field-ids)) + (immutable? (syntax->datum #'immutable?)) + (layout (record-layout immutable? field-count)) + (field-names (map syntax->datum field-ids)) (ctor-name (syntax-case #'constructor-spec () - ((ctor args ...) #'ctor)))) + ((ctor args ...) #'ctor))) + (copier-id (make-copier-id #'type-name))) #`(begin - #,(constructor #'type-name #'constructor-spec indices) + #,(constructor x #'type-name #'constructor-spec field-names) (define type-name (let ((rtd (make-struct/no-tail @@ -200,7 +283,7 @@ '#,(datum->syntax #'here (make-struct-layout layout)) default-record-printer 'type-name - '#,fields))) + '#,field-ids))) (set-struct-vtable-name! rtd 'type-name) (struct-set! rtd (+ 2 vtable-offset-user) #,ctor-name) rtd)) @@ -209,6 +292,13 @@ (and (struct? obj) (eq? (struct-vtable obj) type-name))) - #,@(accessors #'type-name #'(field-spec ...) indices))))))) + #,@(getters #'type-name getter-ids copier-id) + #,(copier #'type-name getter-ids copier-id) + #,@(if immutable? + (functional-setters copier-id #'(field-spec ...)) + (setters #'type-name #'(field-spec ...))))))))) + +(define-syntax-rule (define-record-type name ctor pred fields ...) + (%define-record-type #f name ctor pred fields ...)) ;;; srfi-9.scm ends here diff --git a/module/srfi/srfi-9/gnu.scm b/module/srfi/srfi-9/gnu.scm index 30c101b..fa091fe 100644 --- a/module/srfi/srfi-9/gnu.scm +++ b/module/srfi/srfi-9/gnu.scm @@ -1,6 +1,6 @@ ;;; Extensions to SRFI-9 -;; Copyright (C) 2010 Free Software Foundation, Inc. +;; Copyright (C) 2010, 2012 Free Software Foundation, Inc. ;; ;; This library is free software; you can redistribute it and/or ;; modify it under the terms of the GNU Lesser General Public @@ -23,8 +23,104 @@ ;;; Code: (define-module (srfi srfi-9 gnu) - #:export (set-record-type-printer!)) + #:use-module (srfi srfi-1) + #:export (set-record-type-printer! + define-immutable-record-type + set-field + set-fields)) (define (set-record-type-printer! type thunk) "Set a custom printer THUNK for TYPE." (struct-set! type vtable-index-printer thunk)) + +(define-syntax-rule (define-immutable-record-type name ctor pred fields ...) + ((@@ (srfi srfi-9) %define-record-type) #t name ctor pred fields ...)) + +(define-syntax-rule (set-field (getter ...) s expr) + (%set-fields #t (set-field (getter ...) s expr) () + s ((getter ...) expr))) + +(define-syntax-rule (set-fields s . rest) + (%set-fields #t (set-fields s . rest) () + s . rest)) + +;; +;; collate-set-field-specs is a helper for %set-fields +;; thats combines all specs with the same head together. +;; +;; For example: +;; +;; SPECS: (((a b c) expr1) +;; ((a d) expr2) +;; ((b c) expr3) +;; ((c) expr4)) +;; +;; RESULT: ((a ((b c) expr1) +;; ((d) expr2)) +;; (b ((c) expr3)) +;; (c (() expr4))) +;; +(define (collate-set-field-specs specs) + (define (insert head tail expr result) + (cond ((find (lambda (tree) + (free-identifier=? head (car tree))) + result) + => (lambda (tree) + `((,head (,tail ,expr) + ,@(cdr tree)) + ,@(delq tree result)))) + (else `((,head (,tail ,expr)) + ,@result)))) + (with-syntax (((((head . tail) expr) ...) specs)) + (fold insert '() #'(head ...) #'(tail ...) #'(expr ...)))) + +(define-syntax %set-fields-unknown-getter + (lambda (x) + (syntax-case x () + ((_ orig-form getter) + (syntax-violation 'set-fields "unknown getter" #'orig-form #'getter))))) + +(define-syntax %set-fields + (lambda (x) + (with-syntax ((getter-type #'(@@ (srfi srfi-9) getter-type)) + (getter-index #'(@@ (srfi srfi-9) getter-index)) + (getter-copier #'(@@ (srfi srfi-9) getter-copier))) + (syntax-case x () + ((_ check? orig-form (path-so-far ...) + s) + #'s) + ((_ check? orig-form (path-so-far ...) + s (() e)) + #'e) + ((_ check? orig-form (path-so-far ...) + struct-expr ((head . tail) expr) ...) + (let ((collated-specs (collate-set-field-specs + #'(((head . tail) expr) ...)))) + (with-syntax ((getter (caar collated-specs))) + (with-syntax ((err #'(%set-fields-unknown-getter + orig-form getter))) + #`(let ((s struct-expr)) + ((getter-copier getter err) + check? + s + #,@(map (lambda (spec) + (with-syntax (((head (tail expr) ...) spec)) + (with-syntax ((err #'(%set-fields-unknown-getter + orig-form head))) + #'(head (%set-fields + check? + orig-form + (path-so-far ... head) + (struct-ref s (getter-index head err)) + (tail expr) ...))))) + collated-specs))))))) + ((_ check? orig-form (path-so-far ...) + s (() e) (() e*) ...) + (syntax-violation 'set-fields "duplicate field path" + #'orig-form #'(path-so-far ...))) + ((_ check? orig-form (path-so-far ...) + s ((getter ...) expr) ...) + (syntax-violation 'set-fields "one field path is a prefix of another" + #'orig-form #'(path-so-far ...))) + ((_ check? orig-form . rest) + (syntax-violation 'set-fields "invalid syntax" #'orig-form)))))) diff --git a/test-suite/tests/srfi-9.test b/test-suite/tests/srfi-9.test index 321fe16..54dbaef 100644 --- a/test-suite/tests/srfi-9.test +++ b/test-suite/tests/srfi-9.test @@ -20,19 +20,24 @@ (define-module (test-suite test-numbers) #:use-module (test-suite lib) #:use-module ((system base compile) #:select (compile)) - #:use-module (srfi srfi-9)) + #:use-module (srfi srfi-26) + #:use-module (srfi srfi-9) + #:use-module (srfi srfi-9 gnu)) (define-record-type :qux (make-qux) qux?) -(define-record-type :foo (make-foo x) foo? - (x get-x) (y get-y set-y!)) +(define-record-type :foo (make-foo x) foo? + (x foo-x) + (y foo-y set-foo-y!) + (z foo-z set-foo-z!)) -(define-record-type :bar (make-bar i j) bar? - (i get-i) (i get-j set-j!)) +(define-record-type :bar (make-bar i j) bar? + (i bar-i) + (j bar-j set-bar-j!)) (define f (make-foo 1)) -(set-y! f 2) +(set-foo-y! f 2) (define b (make-bar 123 456)) @@ -63,36 +68,78 @@ (pass-if "fail number" (eq? #f (foo? 123)))) -(with-test-prefix "accessor" +(with-test-prefix "getter" - (pass-if "get-x" - (= 1 (get-x f))) - (pass-if "get-y" - (= 2 (get-y f))) + (pass-if "foo-x" + (= 1 (foo-x f))) + (pass-if "foo-y" + (= 2 (foo-y f))) - (pass-if-exception "get-x on number" exception:wrong-type-arg - (get-x 999)) - (pass-if-exception "get-y on number" exception:wrong-type-arg - (get-y 999)) + (pass-if-exception "foo-x on number" exception:wrong-type-arg + (foo-x 999)) + (pass-if-exception "foo-y on number" exception:wrong-type-arg + (foo-y 999)) ;; prior to guile 1.6.9 and 1.8.1 this wan't enforced - (pass-if-exception "get-x on bar" exception:wrong-type-arg - (get-x b)) - (pass-if-exception "get-y on bar" exception:wrong-type-arg - (get-y b))) + (pass-if-exception "foo-x on bar" exception:wrong-type-arg + (foo-x b)) + (pass-if-exception "foo-y on bar" exception:wrong-type-arg + (foo-y b))) -(with-test-prefix "modifier" +(with-test-prefix "setter" - (pass-if "set-y!" - (set-y! f #t) - (eq? #t (get-y f))) + (pass-if "set-foo-y!" + (set-foo-y! f #t) + (eq? #t (foo-y f))) - (pass-if-exception "set-y! on number" exception:wrong-type-arg - (set-y! 999 #t)) + (pass-if-exception "set-foo-y! on number" exception:wrong-type-arg + (set-foo-y! 999 #t)) ;; prior to guile 1.6.9 and 1.8.1 this wan't enforced - (pass-if-exception "set-y! on bar" exception:wrong-type-arg - (set-y! b 99))) + (pass-if-exception "set-foo-y! on bar" exception:wrong-type-arg + (set-foo-y! b 99))) + +(with-test-prefix "functional setters" + + (pass-if "set-field" + (let ((s (make-foo (make-bar 1 2)))) + (and (equal? (set-field (foo-x bar-j) s 3) + (make-foo (make-bar 1 3))) + (equal? (set-field (foo-z) s 'bar) + (let ((s2 (make-foo (make-bar 1 2)))) + (set-foo-z! s2 'bar) + s2)) + (equal? s (make-foo (make-bar 1 2)))))) + + (pass-if-exception "set-field on wrong struct type" exception:wrong-type-arg + (let ((s (make-bar (make-foo 5) 2))) + (set-field (foo-x bar-j) s 3))) + + (pass-if-exception "set-field on number" exception:wrong-type-arg + (set-field (foo-x bar-j) 4 3)) + + (pass-if "set-fields" + (let ((s (make-foo (make-bar 1 2)))) + (and (equal? (set-field (foo-x bar-j) s 3) + (make-foo (make-bar 1 3))) + (equal? (set-fields s + ((foo-x bar-j) 3) + ((foo-z) 'bar)) + (let ((s2 (make-foo (make-bar 1 3)))) + (set-foo-z! s2 'bar) + s2)) + (equal? s (make-foo (make-bar 1 2)))))) + + (pass-if-exception "set-fields on wrong struct type" exception:wrong-type-arg + (let ((s (make-bar (make-foo 5) 2))) + (set-fields 4 + ((foo-x bar-j) 3) + ((foo-y) 'bar)))) + + (pass-if-exception "set-fields on number" exception:wrong-type-arg + (set-fields 4 + ((foo-x bar-j) 3) + ((foo-z) 'bar)))) (with-test-prefix "side-effecting arguments" @@ -109,7 +156,247 @@ (pass-if "construction" (let ((frotz (make-frotz 1 2))) (and (= (frotz-a frotz) 1) - (= (frotz-b frotz) 2))))) + (= (frotz-b frotz) 2)))) + + (with-test-prefix "functional setters" + (let () + (define-record-type foo (make-foo x) foo? + (x foo-x) + (y foo-y set-foo-y!) + (z foo-z set-foo-z!)) + + (define-record-type :bar (make-bar i j) bar? + (i bar-i) + (j bar-j set-bar-j!)) + + (pass-if "set-field" + (let ((s (make-foo (make-bar 1 2)))) + (and (equal? (set-field (foo-x bar-j) s 3) + (make-foo (make-bar 1 3))) + (equal? (set-field (foo-z) s 'bar) + (let ((s2 (make-foo (make-bar 1 2)))) + (set-foo-z! s2 'bar) + s2)) + (equal? s (make-foo (make-bar 1 2))))))) + + (pass-if "set-fields" + + (let ((s (make-foo (make-bar 1 2)))) + (and (equal? (set-field (foo-x bar-j) s 3) + (make-foo (make-bar 1 3))) + (equal? (set-fields s + ((foo-x bar-j) 3) + ((foo-z) 'bar)) + (let ((s2 (make-foo (make-bar 1 3)))) + (set-foo-z! s2 'bar) + s2)) + (equal? s (make-foo (make-bar 1 2)))))))) + + +(define-immutable-record-type :baz + (make-baz x y z) + baz? + (x baz-x set-baz-x) + (y baz-y set-baz-y) + (z baz-z set-baz-z)) + +(define-immutable-record-type :address + (make-address street city country) + address? + (street address-street) + (city address-city) + (country address-country)) + +(define-immutable-record-type :person + (make-person age email address) + person? + (age person-age) + (email person-email) + (address person-address)) + +(with-test-prefix "define-immutable-record-type" + + (pass-if "get" + (let ((b (make-baz 1 2 3))) + (and (= (baz-x b) 1) + (= (baz-y b) 2) + (= (baz-z b) 3)))) + + (pass-if "get non-inlined" + (let ((b (make-baz 1 2 3))) + (equal? (map (cute apply <> (list b)) + (list baz-x baz-y baz-z)) + '(1 2 3)))) + + (pass-if "set" + (let* ((b0 (make-baz 1 2 3)) + (b1 (set-baz-x b0 11)) + (b2 (set-baz-y b1 22)) + (b3 (set-baz-z b2 33))) + (and (= (baz-x b0) 1) + (= (baz-x b1) 11) (= (baz-x b2) 11) (= (baz-x b3) 11) + (= (baz-y b0) 2) (= (baz-y b1) 2) + (= (baz-y b2) 22) (= (baz-y b3) 22) + (= (baz-z b0) 3) (= (baz-z b1) 3) (= (baz-z b2) 3) + (= (baz-z b3) 33)))) + + (pass-if "set non-inlined" + (let ((set (compose (cut set-baz-x <> 1) + (cut set-baz-y <> 2) + (cut set-baz-z <> 3)))) + (equal? (set (make-baz 0 0 0)) (make-baz 1 2 3)))) + + (pass-if "set-field" + (let ((p (make-person 30 "foo@example.com" + (make-address "Foo" "Paris" "France")))) + (and (equal? (set-field (person-address address-street) p "Bar") + (make-person 30 "foo@example.com" + (make-address "Bar" "Paris" "France"))) + (equal? (set-field (person-email) p "bar@example.com") + (make-person 30 "bar@example.com" + (make-address "Foo" "Paris" "France"))) + (equal? p (make-person 30 "foo@example.com" + (make-address "Foo" "Paris" "France")))))) + + (pass-if "set-fields" + (let ((p (make-person 30 "foo@example.com" + (make-address "Foo" "Paris" "France")))) + (and (equal? (set-fields p + ((person-email) "bar@example.com") + ((person-address address-country) "Spain") + ((person-address address-city) "Barcelona")) + (make-person 30 "bar@example.com" + (make-address "Foo" "Barcelona" "Spain"))) + (equal? (set-fields p + ((person-email) "bar@example.com") + ((person-age) 20)) + (make-person 20 "bar@example.com" + (make-address "Foo" "Paris" "France"))) + (equal? p (make-person 30 "foo@example.com" + (make-address "Foo" "Paris" "France")))))) + + (with-test-prefix "non-toplevel" + + (pass-if "get" + (let () + (define-immutable-record-type bar + (make-bar x y z) + bar? + (x bar-x) + (y bar-y) + (z bar-z set-bar-z)) + + (let ((b (make-bar 1 2 3))) + (and (= (bar-x b) 1) + (= (bar-y b) 2) + (= (bar-z b) 3))))) + + (pass-if "get non-inlined" + (let () + (define-immutable-record-type bar + (make-bar x y z) + bar? + (x bar-x) + (y bar-y) + (z bar-z set-bar-z)) + + (let ((b (make-bar 1 2 3))) + (equal? (map (cute apply <> (list b)) + (list bar-x bar-y bar-z)) + '(1 2 3))))) + + (pass-if "set" + (let () + (define-immutable-record-type bar + (make-bar x y z) + bar? + (x bar-x set-bar-x) + (y bar-y set-bar-y) + (z bar-z set-bar-z)) + + (let* ((b0 (make-bar 1 2 3)) + (b1 (set-bar-x b0 11)) + (b2 (set-bar-y b1 22)) + (b3 (set-bar-z b2 33))) + (and (= (bar-x b0) 1) + (= (bar-x b1) 11) (= (bar-x b2) 11) (= (bar-x b3) 11) + (= (bar-y b0) 2) (= (bar-y b1) 2) + (= (bar-y b2) 22) (= (bar-y b3) 22) + (= (bar-z b0) 3) (= (bar-z b1) 3) (= (bar-z b2) 3) + (= (bar-z b3) 33))))) + + (pass-if "set non-inlined" + (let () + (define-immutable-record-type bar + (make-bar x y z) + bar? + (x bar-x set-bar-x) + (y bar-y set-bar-y) + (z bar-z set-bar-z)) + + (let ((set (compose (cut set-bar-x <> 1) + (cut set-bar-y <> 2) + (cut set-bar-z <> 3)))) + (equal? (set (make-bar 0 0 0)) (make-bar 1 2 3))))) + + (pass-if "set-field" + (let () + (define-immutable-record-type address + (make-address street city country) + address? + (street address-street) + (city address-city) + (country address-country)) + + (define-immutable-record-type :person + (make-person age email address) + person? + (age person-age) + (email person-email) + (address person-address)) + + (let ((p (make-person 30 "foo@example.com" + (make-address "Foo" "Paris" "France")))) + (and (equal? (set-field (person-address address-street) p "Bar") + (make-person 30 "foo@example.com" + (make-address "Bar" "Paris" "France"))) + (equal? (set-field (person-email) p "bar@example.com") + (make-person 30 "bar@example.com" + (make-address "Foo" "Paris" "France"))) + (equal? p (make-person 30 "foo@example.com" + (make-address "Foo" "Paris" "France"))))))) + + (pass-if "set-fields" + (let () + (define-immutable-record-type address + (make-address street city country) + address? + (street address-street) + (city address-city) + (country address-country)) + + (define-immutable-record-type :person + (make-person age email address) + person? + (age person-age) + (email person-email) + (address person-address)) + + (let ((p (make-person 30 "foo@example.com" + (make-address "Foo" "Paris" "France")))) + (and (equal? (set-fields p + ((person-email) "bar@example.com") + ((person-address address-country) "Spain") + ((person-address address-city) "Barcelona")) + (make-person 30 "bar@example.com" + (make-address "Foo" "Barcelona" "Spain"))) + (equal? (set-fields p + ((person-email) "bar@example.com") + ((person-age) 20)) + (make-person 20 "bar@example.com" + (make-address "Foo" "Paris" "France"))) + (equal? p (make-person 30 "foo@example.com" + (make-address "Foo" "Paris" "France"))))))))) (with-test-prefix "record compatibility" @@ -119,3 +406,8 @@ (pass-if "record-constructor" (equal? ((record-constructor :foo) 1) (make-foo 1)))) + +;;; Local Variables: +;;; mode: scheme +;;; eval: (put 'set-fields 'scheme-indent-function 1) +;;; End: -- 1.7.10.4