[Top][All Lists]
[Date Prev][Date Next][Thread Prev][Thread Next][Date Index][Thread Index]
[Guile-commits] GNU Guile branch, master, updated. v2.1.0-447-g54cbf8c
|
From: |
Mark H Weaver |
|
Subject: |
[Guile-commits] GNU Guile branch, master, updated. v2.1.0-447-g54cbf8c |
|
Date: |
Fri, 09 Nov 2012 00:37:39 +0000 |
This is an automated email from the git hooks/post-receive script. It was
generated because a ref change was pushed to the repository containing
the project "GNU Guile".
http://git.savannah.gnu.org/cgit/guile.git/commit/?id=54cbf8c6dcae9fe4925186c6f46718e7b45932fe
The branch, master has been updated
via 54cbf8c6dcae9fe4925186c6f46718e7b45932fe (commit)
via d9e368979bc2b8faa8859cde833b507e7eb83e7f (commit)
from fd57bbf5ac7c790f0731b1a44c7d20f469403009 (commit)
Those revisions listed above that are new to this repository have
not appeared on any other notification email; so we list those
revisions in full, below.
- Log -----------------------------------------------------------------
commit 54cbf8c6dcae9fe4925186c6f46718e7b45932fe
Merge: fd57bbf d9e3689
Author: Mark H Weaver <address@hidden>
Date: Thu Nov 8 19:29:56 2012 -0500
Merge remote-tracking branch 'origin/stable-2.0'
-----------------------------------------------------------------------
Summary of changes:
module/srfi/srfi-9.scm | 252 +++++++++++++-------
module/srfi/srfi-9/gnu.scm | 100 ++++++++-
test-suite/tests/srfi-9.test | 544 +++++++++++++++++++++++++++++++++++++++---
3 files changed, 785 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 @@
;; <predicate name>
;; <field spec> ...)
;;
-;; <field spec> -> (<field tag> <accessor name>)
-;; -> (<field tag> <accessor name> <modifier name>)
+;; <field spec> -> (<field tag> <getter name>)
+;; -> (<field tag> <getter name> <setter name>)
;;
;; <field tag> -> <identifier>
;; <... name> -> <identifier>
@@ -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
;; <http://lists.gnu.org/archive/html/guile-devel/2011-04/msg00111.html>.
+;;
+
+(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..a5179e2 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,169 @@
(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-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"
@@ -109,7 +247,352 @@
(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 "address@hidden"
+ (make-address "Foo" "Paris" "France"))))
+ (and (equal? (set-field (person-address address-street) p "Bar")
+ (make-person 30 "address@hidden"
+ (make-address "Bar" "Paris" "France")))
+ (equal? (set-field (person-email) p "address@hidden")
+ (make-person 30 "address@hidden"
+ (make-address "Foo" "Paris" "France")))
+ (equal? p (make-person 30 "address@hidden"
+ (make-address "Foo" "Paris" "France"))))))
+
+ (pass-if "set-fields"
+ (let ((p (make-person 30 "address@hidden"
+ (make-address "Foo" "Paris" "France"))))
+ (and (equal? (set-fields p
+ ((person-email) "address@hidden")
+ ((person-address address-country) "Catalonia")
+ ((person-address address-city) "Barcelona"))
+ (make-person 30 "address@hidden"
+ (make-address "Foo" "Barcelona" "Catalonia")))
+ (equal? (set-fields p
+ ((person-email) "address@hidden")
+ ((person-age) 20))
+ (make-person 20 "address@hidden"
+ (make-address "Foo" "Paris" "France")))
+ (equal? p (make-person 30 "address@hidden"
+ (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 "address@hidden"
+ (make-address "Foo" "Paris" "France"))))
+ (and (equal? (set-field (person-address address-street) p "Bar")
+ (make-person 30 "address@hidden"
+ (make-address "Bar" "Paris" "France")))
+ (equal? (set-field (person-email) p "address@hidden")
+ (make-person 30 "address@hidden"
+ (make-address "Foo" "Paris" "France")))
+ (equal? p (make-person 30 "address@hidden"
+ (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 "address@hidden"
+ (make-address "Foo" "Paris" "France"))))
+ (and (equal? (set-fields p
+ ((person-email) "address@hidden")
+ ((person-address address-country) "Catalonia")
+ ((person-address address-city) "Barcelona"))
+ (make-person 30 "address@hidden"
+ (make-address "Foo" "Barcelona"
"Catalonia")))
+ (equal? (set-fields p
+ ((person-email) "address@hidden")
+ ((person-age) 20))
+ (make-person 20 "address@hidden"
+ (make-address "Foo" "Paris" "France")))
+ (equal? p (make-person 30 "address@hidden"
+ (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"
@@ -119,3 +602,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:
hooks/post-receive
--
GNU Guile
| [Prev in Thread] |
Current Thread |
[Next in Thread] |
- [Guile-commits] GNU Guile branch, master, updated. v2.1.0-447-g54cbf8c,
Mark H Weaver <=