mirror/guile
mirror/guile
1
Fork 0
mirror of https://git.savannah.gnu.org/git/guile.git synced 2025-05-20 19:50:24 +02:00
Code Activity

Implement functional record setters.

Browse source 
Written in collaboration with Ludovic Courtès <ludo@gnu.org>

* 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.  Rename getters and setters
  in existing tests to make the functional setters look better.
This commit is contained in:
Mark H Weaver 2012-11-07 12:21:44 -05:00
parent 02a362a665
commit d9e368979b
3 changed files with 782 additions and 108 deletions
Download patch file Download diff file Expand all files Collapse all files

240
module/srfi/srfi-9.scm
View file

@ -29,8 +29,8 @@
;; <predicate name> ;; <predicate name>
;; <field spec> ...) ;; <field spec> ...)
;; ;;
;; <field spec> -> (<field tag> <accessor name>) ;; <field spec> -> (<field tag> <getter name>)
;; -> (<field tag> <accessor name> <modifier name>) ;; -> (<field tag> <getter name> <setter name>)
;; ;;
;; <field tag> -> <identifier> ;; <field tag> -> <identifier>
;; <... name> -> <identifier> ;; <... name> -> <identifier>
@ -68,8 +68,31 @@
;; because the public one has a different `make-procedure-name', so ;; because the public one has a different `make-procedure-name', so
;; using it would require users to recompile code that uses SRFI-9. See ;; using it would require users to recompile code that uses SRFI-9. See
;; <http://lists.gnu.org/archive/html/guile-devel/2011-04/msg00111.html>. ;; <http://lists.gnu.org/archive/html/guile-devel/2011-04/msg00111.html>.
;;
(define-syntax define-inlinable (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 %%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) (lambda (x)
(define (make-procedure-name name) (define (make-procedure-name name)
(datum->syntax name (datum->syntax name
@ -77,7 +100,7 @@
'-procedure))) '-procedure)))
(syntax-case x () (syntax-case x ()
((_ (name formals ...) body ...) ((_ ((key value) ...) (name formals ...) body ...)
(identifier? #'name) (identifier? #'name)
(with-syntax ((proc-name (make-procedure-name #'name)) (with-syntax ((proc-name (make-procedure-name #'name))
((args ...) (generate-temporaries #'(formals ...)))) ((args ...) (generate-temporaries #'(formals ...))))
@ -86,7 +109,8 @@
body ...) body ...)
(define-syntax name (define-syntax name
(lambda (x) (lambda (x)
(syntax-case x () (syntax-case x (%%on-error key ...)
((_ (%%on-error err) key) #'value) ...
((_ args ...) ((_ args ...)
#'((lambda (formals ...) #'((lambda (formals ...)
body ...) body ...)
@ -109,90 +133,149 @@
(loop (cdr fields) (+ 1 off))))) (loop (cdr fields) (+ 1 off)))))
(display ">" p)) (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) (lambda (x)
(define (field-identifiers field-specs) (define (field-identifiers field-specs)
(syntax-case field-specs () (map (lambda (field-spec)
(() (syntax-case field-spec ()
'()) ((name getter) #'name)
((field-spec) ((name getter setter) #'name)))
(syntax-case #'field-spec () field-specs))
((name accessor) #'(name))
((name accessor modifier) #'(name))))
((field-spec rest ...)
(append (field-identifiers #'(field-spec))
(field-identifiers #'(rest ...))))))
(define (field-indices fields) (define (getter-identifiers field-specs)
(fold (lambda (field result) (map (lambda (field-spec)
(let ((i (if (null? result) (syntax-case field-spec ()
0 ((name getter) #'getter)
(+ 1 (cdar result))))) ((name getter setter) #'getter)))
(alist-cons field i result))) field-specs))
'()
fields))
(define (constructor type-name constructor-spec indices) (define (constructor form type-name constructor-spec field-names)
(syntax-case constructor-spec () (syntax-case constructor-spec ()
((ctor field ...) ((ctor field ...)
(let ((field-count (length indices)) (every identifier? #'(field ...))
(ctor-args (map (lambda (field) (let ((ctor-args (map (lambda (field)
(cons (syntax->datum field) 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 ...)))) #'(field ...))))
#`(define-inlinable #,constructor-spec #`(define-inlinable #,constructor-spec
(make-struct #,type-name 0 (make-struct #,type-name 0
#,@(unfold #,@(map (lambda (name)
(lambda (field-num) (assq-ref ctor-args name))
(>= field-num field-count)) field-names)))))))
(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) (define (getters type-name getter-ids copier-id)
(syntax-case field-specs () (map (lambda (getter index)
(() #`(define-tagged-inlinable
#'()) ((%%type #,type-name)
((field-spec) (%%index #,index)
(syntax-case #'field-spec () (%%copier #,copier-id))
((name accessor) (#,getter s)
(with-syntax ((index (assoc-ref indices (syntax->datum #'name))))
#`((define-inlinable (accessor s)
(if (eq? (struct-vtable s) #,type-name) (if (eq? (struct-vtable s) #,type-name)
(struct-ref s index) (struct-ref s #,index)
(throw 'wrong-type-arg 'accessor (throw-bad-struct s '#,getter))))
"Wrong type argument: ~S" (list s) getter-ids
(list s))))))) (iota (length getter-ids))))
((name accessor modifier)
(with-syntax ((index (assoc-ref indices (syntax->datum #'name)))) (define (copier type-name getter-ids copier-id)
#`(#,@(accessors type-name #'((name accessor)) indices) #`(define-syntax-rule
(define-inlinable (modifier s val) (#,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) (if (eq? (struct-vtable s) #,type-name)
(struct-set! s index val) (struct-set! s #,index val)
(throw 'wrong-type-arg 'modifier (throw-bad-struct s 'setter))))))
"Wrong type argument: ~S" (list s) field-specs
(list s))))))))) (iota (length field-specs))))
((field-spec rest ...)
#`(#,@(accessors type-name #'(field-spec) indices) (define (functional-setters copier-id field-specs)
#,@(accessors type-name #'(rest ...) indices))))) (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 () (syntax-case x ()
((_ type-name constructor-spec predicate-name field-spec ...) ((_ immutable? type-name constructor-spec predicate-name
(let* ((fields (field-identifiers #'(field-spec ...))) field-spec ...)
(field-count (length fields)) (boolean? (syntax->datum #'immutable?))
(layout (string-concatenate (make-list field-count "pw"))) (let* ((field-ids (field-identifiers #'(field-spec ...)))
(indices (field-indices (map syntax->datum fields))) (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-name (syntax-case #'constructor-spec ()
((ctor args ...) #'ctor)))) ((ctor args ...) #'ctor)))
(copier-id (make-copier-id #'type-name)))
#`(begin #`(begin
#,(constructor #'type-name #'constructor-spec indices) #,(constructor x #'type-name #'constructor-spec field-names)
(define type-name (define type-name
(let ((rtd (make-struct/no-tail (let ((rtd (make-struct/no-tail
@ -200,7 +283,7 @@
'#,(datum->syntax #'here (make-struct-layout layout)) '#,(datum->syntax #'here (make-struct-layout layout))
default-record-printer default-record-printer
'type-name 'type-name
'#,fields))) '#,field-ids)))
(set-struct-vtable-name! rtd 'type-name) (set-struct-vtable-name! rtd 'type-name)
(struct-set! rtd (+ 2 vtable-offset-user) #,ctor-name) (struct-set! rtd (+ 2 vtable-offset-user) #,ctor-name)
rtd)) rtd))
@ -209,6 +292,13 @@
(and (struct? obj) (and (struct? obj)
(eq? (struct-vtable obj) type-name))) (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 ;;; srfi-9.scm ends here

100
module/srfi/srfi-9/gnu.scm
View file

@ -1,6 +1,6 @@
;;; Extensions to SRFI-9 ;;; 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 ;; This library is free software; you can redistribute it and/or
;; modify it under the terms of the GNU Lesser General Public ;; modify it under the terms of the GNU Lesser General Public
@ -23,8 +23,104 @@
;;; Code: ;;; Code:
(define-module (srfi srfi-9 gnu) (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) (define (set-record-type-printer! type thunk)
"Set a custom printer THUNK for TYPE." "Set a custom printer THUNK for TYPE."
(struct-set! type vtable-index-printer thunk)) (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))))))

540
test-suite/tests/srfi-9.test
View file

@ -20,19 +20,24 @@
(define-module (test-suite test-numbers) (define-module (test-suite test-numbers)
#:use-module (test-suite lib) #:use-module (test-suite lib)
#:use-module ((system base compile) #:select (compile)) #: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 :qux (make-qux) qux?)
(define-record-type :foo (make-foo x) foo? (define-record-type :foo (make-foo x) foo?
(x get-x) (y get-y set-y!)) (x foo-x)
(y foo-y set-foo-y!)
(z foo-z set-foo-z!))
(define-record-type :bar (make-bar i j) bar? (define-record-type :bar (make-bar i j) bar?
(i get-i) (i get-j set-j!)) (i bar-i)
(j bar-j set-bar-j!))
(define f (make-foo 1)) (define f (make-foo 1))
(set-y! f 2) (set-foo-y! f 2)
(define b (make-bar 123 456)) (define b (make-bar 123 456))
@ -63,36 +68,169 @@
(pass-if "fail number" (pass-if "fail number"
(eq? #f (foo? 123)))) (eq? #f (foo? 123))))
(with-test-prefix "accessor" (with-test-prefix "getter"
(pass-if "get-x" (pass-if "foo-x"
(= 1 (get-x f))) (= 1 (foo-x f)))
(pass-if "get-y" (pass-if "foo-y"
(= 2 (get-y f))) (= 2 (foo-y f)))
(pass-if-exception "get-x on number" exception:wrong-type-arg (pass-if-exception "foo-x on number" exception:wrong-type-arg
(get-x 999)) (foo-x 999))
(pass-if-exception "get-y on number" exception:wrong-type-arg (pass-if-exception "foo-y on number" exception:wrong-type-arg
(get-y 999)) (foo-y 999))
;; prior to guile 1.6.9 and 1.8.1 this wan't enforced ;; 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 (pass-if-exception "foo-x on bar" exception:wrong-type-arg
(get-x b)) (foo-x b))
(pass-if-exception "get-y on bar" exception:wrong-type-arg (pass-if-exception "foo-y on bar" exception:wrong-type-arg
(get-y b))) (foo-y b)))
(with-test-prefix "modifier" (with-test-prefix "setter"
(pass-if "set-y!" (pass-if "set-foo-y!"
(set-y! f #t) (set-foo-y! f #t)
(eq? #t (get-y f))) (eq? #t (foo-y f)))
(pass-if-exception "set-y! on number" exception:wrong-type-arg (pass-if-exception "set-foo-y! on number" exception:wrong-type-arg
(set-y! 999 #t)) (set-foo-y! 999 #t))
;; prior to guile 1.6.9 and 1.8.1 this wan't enforced ;; 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 (pass-if-exception "set-foo-y! on bar" exception:wrong-type-arg
(set-y! b 99))) (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-field with unknown first getter"
(catch 'syntax-error
(lambda ()
(compile '(let ((s (make-bar (make-foo 5) 2)))
(set-field (blah) s 3))
#:env (current-module))
#f)
(lambda (key whom what src form subform)
(equal? (list key whom what form subform)
'(syntax-error set-fields "unknown getter"
(set-field (blah) s 3)
blah)))))
(pass-if "set-field with unknown second getter"
(catch 'syntax-error
(lambda ()
(compile '(let ((s (make-bar (make-foo 5) 2)))
(set-field (bar-j blah) s 3))
#:env (current-module))
#f)
(lambda (key whom what src form subform)
(equal? (list key whom what form subform)
'(syntax-error set-fields "unknown getter"
(set-field (bar-j blah) s 3)
blah)))))
(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)))
(pass-if "set-fields with unknown first getter"
(catch 'syntax-error
(lambda ()
(compile '(let ((s (make-bar (make-foo 5) 2)))
(set-fields s ((bar-i foo-x) 1) ((blah) 3)))
#:env (current-module))
#f)
(lambda (key whom what src form subform)
(equal? (list key whom what form subform)
'(syntax-error set-fields "unknown getter"
(set-fields s ((bar-i foo-x) 1) ((blah) 3))
blah)))))
(pass-if "set-fields with unknown second getter"
(catch 'syntax-error
(lambda ()
(compile '(let ((s (make-bar (make-foo 5) 2)))
(set-fields s ((bar-i foo-x) 1) ((blah) 3)))
#:env (current-module))
#f)
(lambda (key whom what src form subform)
(equal? (list key whom what form subform)
'(syntax-error set-fields "unknown getter"
(set-fields s ((bar-i foo-x) 1) ((blah) 3))
blah)))))
(pass-if "set-fields with duplicate field path"
(catch 'syntax-error
(lambda ()
(compile '(let ((s (make-bar (make-foo 5) 2)))
(set-fields s
((bar-i foo-x) 1)
((bar-i foo-z) 2)
((bar-i foo-x) 3)))
#:env (current-module))
#f)
(lambda (key whom what src form subform)
(equal? (list key whom what form subform)
'(syntax-error set-fields "duplicate field path"
(set-fields s
((bar-i foo-x) 1)
((bar-i foo-z) 2)
((bar-i foo-x) 3))
(bar-i foo-x))))))
(pass-if "set-fields with one path as a prefix of another"
(catch 'syntax-error
(lambda ()
(compile '(let ((s (make-bar (make-foo 5) 2)))
(set-fields s
((bar-i foo-x) 1)
((bar-i foo-z) 2)
((bar-i) 3)))
#:env (current-module))
#f)
(lambda (key whom what src form subform)
(equal? (list key whom what form subform)
'(syntax-error set-fields
"one field path is a prefix of another"
(set-fields s
((bar-i foo-x) 1)
((bar-i foo-z) 2)
((bar-i) 3))
(bar-i)))))))
(with-test-prefix "side-effecting arguments" (with-test-prefix "side-effecting arguments"
@ -109,7 +247,352 @@
(pass-if "construction" (pass-if "construction"
(let ((frotz (make-frotz 1 2))) (let ((frotz (make-frotz 1 2)))
(and (= (frotz-a frotz) 1) (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) "Catalonia")
((person-address address-city) "Barcelona"))
(make-person 30 "bar@example.com"
(make-address "Foo" "Barcelona" "Catalonia")))
(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) "Catalonia")
((person-address address-city) "Barcelona"))
(make-person 30 "bar@example.com"
(make-address "Foo" "Barcelona" "Catalonia")))
(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")))))))
(pass-if "set-fields with unknown first getter"
(let ()
(define-immutable-record-type foo (make-foo x) foo?
(x foo-x)
(y foo-y set-foo-y)
(z foo-z set-foo-z))
(define-immutable-record-type :bar (make-bar i j) bar?
(i bar-i)
(j bar-j set-bar-j))
(catch 'syntax-error
(lambda ()
(compile '(let ((s (make-bar (make-foo 5) 2)))
(set-fields s ((bar-i foo-x) 1) ((blah) 3)))
#:env (current-module))
#f)
(lambda (key whom what src form subform)
(equal? (list key whom what form subform)
'(syntax-error set-fields "unknown getter"
(set-fields s ((bar-i foo-x) 1) ((blah) 3))
blah))))))
(pass-if "set-fields with unknown second getter"
(let ()
(define-immutable-record-type foo (make-foo x) foo?
(x foo-x)
(y foo-y set-foo-y)
(z foo-z set-foo-z))
(define-immutable-record-type :bar (make-bar i j) bar?
(i bar-i)
(j bar-j set-bar-j))
(catch 'syntax-error
(lambda ()
(compile '(let ((s (make-bar (make-foo 5) 2)))
(set-fields s ((bar-i foo-x) 1) ((blah) 3)))
#:env (current-module))
#f)
(lambda (key whom what src form subform)
(equal? (list key whom what form subform)
'(syntax-error set-fields "unknown getter"
(set-fields s ((bar-i foo-x) 1) ((blah) 3))
blah))))))
(pass-if "set-fields with duplicate field path"
(let ()
(define-immutable-record-type foo (make-foo x) foo?
(x foo-x)
(y foo-y set-foo-y)
(z foo-z set-foo-z))
(define-immutable-record-type :bar (make-bar i j) bar?
(i bar-i)
(j bar-j set-bar-j))
(catch 'syntax-error
(lambda ()
(compile '(let ((s (make-bar (make-foo 5) 2)))
(set-fields s
((bar-i foo-x) 1)
((bar-i foo-z) 2)
((bar-i foo-x) 3)))
#:env (current-module))
#f)
(lambda (key whom what src form subform)
(equal? (list key whom what form subform)
'(syntax-error set-fields "duplicate field path"
(set-fields s
((bar-i foo-x) 1)
((bar-i foo-z) 2)
((bar-i foo-x) 3))
(bar-i foo-x)))))))
(pass-if "set-fields with one path as a prefix of another"
(let ()
(define-immutable-record-type foo (make-foo x) foo?
(x foo-x)
(y foo-y set-foo-y)
(z foo-z set-foo-z))
(define-immutable-record-type :bar (make-bar i j) bar?
(i bar-i)
(j bar-j set-bar-j))
(catch 'syntax-error
(lambda ()
(compile '(let ((s (make-bar (make-foo 5) 2)))
(set-fields s
((bar-i foo-x) 1)
((bar-i foo-z) 2)
((bar-i) 3)))
#:env (current-module))
#f)
(lambda (key whom what src form subform)
(equal? (list key whom what form subform)
'(syntax-error set-fields
"one field path is a prefix of another"
(set-fields s
((bar-i foo-x) 1)
((bar-i foo-z) 2)
((bar-i) 3))
(bar-i)))))))))
(with-test-prefix "record compatibility" (with-test-prefix "record compatibility"
@ -119,3 +602,8 @@
(pass-if "record-constructor" (pass-if "record-constructor"
(equal? ((record-constructor :foo) 1) (equal? ((record-constructor :foo) 1)
(make-foo 1)))) (make-foo 1))))
;;; Local Variables:
;;; mode: scheme
;;; eval: (put 'set-fields 'scheme-indent-function 1)
;;; End: