diff --git a/doc/ref/api-compound.texi b/doc/ref/api-compound.texi index d02077409..6aaed06d4 100644 --- a/doc/ref/api-compound.texi +++ b/doc/ref/api-compound.texi @@ -25,8 +25,10 @@ values can be looked up within them. * Generalized Vectors:: Treating all vector-like things uniformly. * Arrays:: Matrices, etc. * VLists:: Vector-like lists. -* Records:: -* Structures:: +* Record Overview:: Walking through the maze of record APIs. +* SRFI-9 Records:: The standard, recommended record API. +* Records:: Guile's historical record API. +* Structures:: Low-level record representation. * Dictionary Types:: About dictionary types in general. * Association Lists:: List-based dictionaries. * VHashes:: VList-based dictionaries. @@ -2249,7 +2251,254 @@ Return a new vlist whose contents correspond to @var{lst}. Return a new list whose contents match those of @var{vlist}. @end deffn +@node Record Overview +@subsection Record Overview +@cindex record +@cindex structure + +@dfn{Records}, also called @dfn{structures}, are Scheme's primary +mechanism to define new disjoint types. A @dfn{record type} defines a +list of @dfn{fields} that instances of the type consist of. This is like +C's @code{struct}. + +Historically, Guile has offered several different ways to define record +types and to create records, offering different features, and making +different trade-offs. Over the years, each ``standard'' has also come +with its own new record interface, leading to a maze of record APIs. + +At the highest level is SRFI-9, a high-level record interface +implemented by most Scheme implementations (@pxref{SRFI-9}). It defines +a simple and efficient syntactic abstraction of record types and their +associated type predicate, fields, and field accessors. SRFI-9 is +suitable for most uses, and this is the recommended way to create record +types in Guile. Similar high-level record APIs include SRFI-35 +(@pxref{SRFI-35}) and R6RS records (@pxref{rnrs records syntactic}). + +Then comes Guile's historical ``records'' API (@pxref{Records}). Record +types defined this way are first-class objects. Introspection +facilities are available, allowing users to query the list of fields or +the value of a specific field at run-time, without prior knowledge of +the type. + +Finally, the common denominator of these interfaces is Guile's +@dfn{structure} API (@pxref{Structures}). Guile's structures are the +low-level building block for all other record APIs. Application writers +will normally not need to use it. + +Records created with these APIs may all be pattern-matched using Guile's +standard pattern matcher (@pxref{Pattern Matching}). + + +@node SRFI-9 Records +@subsection SRFI-9 Records + +@cindex SRFI-9 +@cindex record + +SRFI-9 standardizes a syntax for defining new record types and creating +predicate, constructor, and field getter and setter functions. In Guile +this is the recommended option to create new record types (@pxref{Record +Overview}). It can be used with: + +@example +(use-modules (srfi srfi-9)) +@end example + +@deffn {library syntax} define-record-type type @* (constructor fieldname @dots{}) @* predicate @* (fieldname accessor [modifier]) @dots{} +@sp 1 +Create a new record type, and make various @code{define}s for using +it. This syntax can only occur at the top-level, not nested within +some other form. + +@var{type} is bound to the record type, which is as per the return +from the core @code{make-record-type}. @var{type} also provides the +name for the record, as per @code{record-type-name}. + +@var{constructor} is bound to a function to be called as +@code{(@var{constructor} fieldval @dots{})} to create a new record of +this type. The arguments are initial values for the fields, one +argument for each field, in the order they appear in the +@code{define-record-type} form. + +The @var{fieldname}s provide the names for the record fields, as per +the core @code{record-type-fields} etc, and are referred to in the +subsequent accessor/modifier forms. + +@var{predicate} is bound to a function to be called as +@code{(@var{predicate} obj)}. It returns @code{#t} or @code{#f} +according to whether @var{obj} is a record of this type. + +Each @var{accessor} is bound to a function to be called +@code{(@var{accessor} record)} to retrieve the respective field from a +@var{record}. Similarly each @var{modifier} is bound to a function to +be called @code{(@var{modifier} record val)} to set the respective +field in a @var{record}. +@end deffn + +@noindent +An example will illustrate typical usage, + +@example +(define-record-type employee-type + (make-employee name age salary) + employee? + (name get-employee-name) + (age get-employee-age set-employee-age) + (salary get-employee-salary set-employee-salary)) +@end example + +This creates a new employee data type, with name, age and salary +fields. Accessor functions are created for each field, but no +modifier function for the name (the intention in this example being +that it's established only when an employee object is created). These +can all then be used as for example, + +@example +employee-type @result{} # + +(define fred (make-employee "Fred" 45 20000.00)) + +(employee? fred) @result{} #t +(get-employee-age fred) @result{} 45 +(set-employee-salary fred 25000.00) ;; pay rise +@end example + +The functions created by @code{define-record-type} are ordinary +top-level @code{define}s. They can be redefined or @code{set!} as +desired, exported from a module, etc. + +@unnumberedsubsubsec Non-toplevel Record Definitions + +The SRFI-9 specification explicitly disallows record definitions in a +non-toplevel context, such as inside @code{lambda} body or inside a +@var{let} block. However, Guile's implementation does not enforce that +restriction. + +@unnumberedsubsubsec Custom Printers + +You may use @code{set-record-type-printer!} to customize the default printing +behavior of records. This is a Guile extension and is not part of SRFI-9. It +is located in the @nicode{(srfi srfi-9 gnu)} module. + +@deffn {Scheme Syntax} set-record-type-printer! name thunk +Where @var{type} corresponds to the first argument of @code{define-record-type}, +and @var{thunk} is a procedure accepting two arguments, the record to print, and +an output port. +@end deffn + +@noindent +This example prints the employee's name in brackets, for instance @code{[Fred]}. + +@example +(set-record-type-printer! employee-type + (lambda (record port) + (write-char #\[ port) + (display (get-employee-name record) port) + (write-char #\] port))) +@end example + +@unnumberedsubsubsec Functional ``Setters'' + +@cindex functional setters + +When writing code in a functional style, it is desirable to never alter +the contents of records. For such code, a simple way to return new +record instances based on existing ones is highly desirable. + +The @code{(srfi srfi-9 gnu)} module extends SRFI-9 with facilities to +return new record instances based on existing ones, only with one or +more field values changed---@dfn{functional setters}. First, the +@code{define-immutable-record-type} works like +@code{define-record-type}, except that fields are immutable and setters +are defined as functional setters. + +@deffn {Scheme Syntax} define-immutable-record-type type @* (constructor fieldname @dots{}) @* predicate @* (fieldname accessor [modifier]) @dots{} +Define @var{type} as a new record type, like @code{define-record-type}. +However, the record type is made @emph{immutable} (records may not be +mutated, even with @code{struct-set!}), and any @var{modifier} is +defined to be a functional setter---a procedure that returns a new +record instance with the specified field changed, and leaves the +original unchanged (see example below.) +@end deffn + +@noindent +In addition, the generic @code{set-field} and @code{set-fields} macros +may be applied to any SRFI-9 record. + +@deffn {Scheme Syntax} set-field (field sub-fields ...) record value +Return a new record of @var{record}'s type whose fields are equal to +the corresponding fields of @var{record} except for the one specified by +@var{field}. + +@var{field} must be the name of the getter corresponding to the field of +@var{record} being ``set''. Subsequent @var{sub-fields} must be record +getters designating sub-fields within that field value to be set (see +example below.) +@end deffn + +@deffn {Scheme Syntax} set-fields record ((field sub-fields ...) value) ... +Like @code{set-field}, but can be used to set more than one field at a +time. This expands to code that is more efficient than a series of +single @code{set-field} calls. +@end deffn + +To illustrate the use of functional setters, let's assume these two +record type definitions: + +@example +(define-record-type
+ (address street city country) + address? + (street address-street) + (city address-city) + (country address-country)) + +(define-immutable-record-type + (person age email address) + person? + (age person-age set-person-age) + (email person-email set-person-email) + (address person-address set-person-address)) +@end example + +@noindent +First, note that the @code{} record type definition introduces +named functional setters. These may be used like this: + +@example +(define fsf-address + (address "Franklin Street" "Boston" "USA")) + +(define rms + (person 30 "rms@@gnu.org" fsf-address)) + +(and (equal? (set-person-age rms 60) + (person 60 "rms@@gnu.org" fsf-address)) + (= (person-age rms) 30)) +@result{} #t +@end example + +@noindent +Here, the original @code{} record, to which @var{rms} is bound, +is left unchanged. + +Now, suppose we want to change both the street and age of @var{rms}. +This can be achieved using @code{set-fields}: + +@example +(set-fields rms + ((person-age) 60) + ((person-address address-street) "Temple Place")) +@result{} #< age: 60 email: "rms@@gnu.org" + address: #<
street: "Temple Place" city: "Boston" country: "USA">> +@end example + +@noindent +Notice how the above changed two fields of @var{rms}, including the +@code{street} field of its @code{address} field, in a concise way. Also +note that @code{set-fields} works equally well for types defined with +just @code{define-record-type}. @node Records @subsection Records diff --git a/doc/ref/srfi-modules.texi b/doc/ref/srfi-modules.texi index da1b86fe0..f92ddafc2 100644 --- a/doc/ref/srfi-modules.texi +++ b/doc/ref/srfi-modules.texi @@ -1862,110 +1862,12 @@ procedures easier. It is documented in @xref{Multiple Values}. @node SRFI-9 @subsection SRFI-9 - define-record-type -@cindex SRFI-9 -@cindex record This SRFI is a syntax for defining new record types and creating -predicate, constructor, and field getter and setter functions. In -Guile this is simply an alternate interface to the core record -functionality (@pxref{Records}). It can be used with, +predicate, constructor, and field getter and setter functions. It is +documented in the ``Compound Data Types'' section of the manual +(@pxref{SRFI-9 Records}). -@example -(use-modules (srfi srfi-9)) -@end example - -@deffn {library syntax} define-record-type type @* (constructor fieldname @dots{}) @* predicate @* (fieldname accessor [modifier]) @dots{} -@sp 1 -Create a new record type, and make various @code{define}s for using -it. This syntax can only occur at the top-level, not nested within -some other form. - -@var{type} is bound to the record type, which is as per the return -from the core @code{make-record-type}. @var{type} also provides the -name for the record, as per @code{record-type-name}. - -@var{constructor} is bound to a function to be called as -@code{(@var{constructor} fieldval @dots{})} to create a new record of -this type. The arguments are initial values for the fields, one -argument for each field, in the order they appear in the -@code{define-record-type} form. - -The @var{fieldname}s provide the names for the record fields, as per -the core @code{record-type-fields} etc, and are referred to in the -subsequent accessor/modifier forms. - -@var{predicate} is bound to a function to be called as -@code{(@var{predicate} obj)}. It returns @code{#t} or @code{#f} -according to whether @var{obj} is a record of this type. - -Each @var{accessor} is bound to a function to be called -@code{(@var{accessor} record)} to retrieve the respective field from a -@var{record}. Similarly each @var{modifier} is bound to a function to -be called @code{(@var{modifier} record val)} to set the respective -field in a @var{record}. -@end deffn - -@noindent -An example will illustrate typical usage, - -@example -(define-record-type employee-type - (make-employee name age salary) - employee? - (name get-employee-name) - (age get-employee-age set-employee-age) - (salary get-employee-salary set-employee-salary)) -@end example - -This creates a new employee data type, with name, age and salary -fields. Accessor functions are created for each field, but no -modifier function for the name (the intention in this example being -that it's established only when an employee object is created). These -can all then be used as for example, - -@example -employee-type @result{} # - -(define fred (make-employee "Fred" 45 20000.00)) - -(employee? fred) @result{} #t -(get-employee-age fred) @result{} 45 -(set-employee-salary fred 25000.00) ;; pay rise -@end example - -The functions created by @code{define-record-type} are ordinary -top-level @code{define}s. They can be redefined or @code{set!} as -desired, exported from a module, etc. - -@unnumberedsubsubsec Non-toplevel Record Definitions - -The SRFI-9 specification explicitly disallows record definitions in a -non-toplevel context, such as inside @code{lambda} body or inside a -@var{let} block. However, Guile's implementation does not enforce that -restriction. - -@unnumberedsubsubsec Custom Printers - -You may use @code{set-record-type-printer!} to customize the default printing -behavior of records. This is a Guile extension and is not part of SRFI-9. It -is located in the @nicode{(srfi srfi-9 gnu)} module. - -@deffn {Scheme Syntax} set-record-type-printer! name thunk -Where @var{type} corresponds to the first argument of @code{define-record-type}, -and @var{thunk} is a procedure accepting two arguments, the record to print, and -an output port. -@end deffn - -@noindent -This example prints the employee's name in brackets, for instance @code{[Fred]}. - -@example -(set-record-type-printer! employee-type - (lambda (record port) - (write-char #\[ port) - (display (get-employee-name record) port) - (write-char #\] port))) -@end example @node SRFI-10 @subsection SRFI-10 - Hash-Comma Reader Extension diff --git a/module/Makefile.am b/module/Makefile.am index 49b8a3152..2226d5b0f 100644 --- a/module/Makefile.am +++ b/module/Makefile.am @@ -187,7 +187,8 @@ SYSTEM_BASE_SOURCES = \ system/base/language.scm \ system/base/lalr.scm \ system/base/message.scm \ - system/base/target.scm + system/base/target.scm \ + system/base/ck.scm ICE_9_SOURCES = \ ice-9/r5rs.scm \ diff --git a/module/ice-9/futures.scm b/module/ice-9/futures.scm index 0f64b5c1f..7fbccf63f 100644 --- a/module/ice-9/futures.scm +++ b/module/ice-9/futures.scm @@ -19,6 +19,7 @@ (define-module (ice-9 futures) #:use-module (srfi srfi-1) #:use-module (srfi srfi-9) + #:use-module (ice-9 threads) #:use-module (ice-9 q) #:export (future make-future future? touch)) @@ -157,15 +158,20 @@ touched." (define %workers '()) (define (%create-workers!) - (lock-mutex %futures-mutex) - (set! %workers - (unfold (lambda (i) (>= i %worker-count)) - (lambda (i) - (call-with-new-thread process-futures)) - 1+ - 0)) - (set! create-workers! (lambda () #t)) - (unlock-mutex %futures-mutex)) + (with-mutex + %futures-mutex + ;; Setting 'create-workers!' to a no-op is an optimization, but it is + ;; still possible for '%create-workers!' to be called more than once + ;; from different threads. Therefore, to avoid creating %workers more + ;; than once (and thus creating too many threads), we check to make + ;; sure %workers is empty within the critical section. + (when (null? %workers) + (set! %workers + (unfold (lambda (i) (>= i %worker-count)) + (lambda (i) (call-with-new-thread process-futures)) + 1+ + 0)) + (set! create-workers! (lambda () #t))))) (define create-workers! (lambda () (%create-workers!))) diff --git a/module/srfi/srfi-9.scm b/module/srfi/srfi-9.scm index de4945952..d213a8656 100644 --- a/module/srfi/srfi-9.scm +++ b/module/srfi/srfi-9.scm @@ -60,6 +60,7 @@ (define-module (srfi srfi-9) #:use-module (srfi srfi-1) + #:use-module (system base ck) #:export (define-record-type)) (cond-expand-provide (current-module) '(srfi-9)) @@ -81,16 +82,22 @@ (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 getter-type + (syntax-rules (quote) + ((_ s 'getter 'err) + (getter (%%on-error err) %%type s)))) (define %%index #f) ; a private syntax literal -(define-syntax-rule (getter-index getter err) - (getter (%%on-error err) %%index)) +(define-syntax getter-index + (syntax-rules (quote) + ((_ s 'getter 'err) + (getter (%%on-error err) %%index s)))) (define %%copier #f) ; a private syntax literal -(define-syntax-rule (getter-copier getter err) - (getter (%%on-error err) %%copier)) +(define-syntax getter-copier + (syntax-rules (quote) + ((_ s 'getter 'err) + (getter (%%on-error err) %%copier s)))) (define-syntax define-tagged-inlinable (lambda (x) @@ -110,7 +117,7 @@ (define-syntax name (lambda (x) (syntax-case x (%%on-error key ...) - ((_ (%%on-error err) key) #'value) ... + ((_ (%%on-error err) key s) #'(ck s 'value)) ... ((_ args ...) #'((lambda (formals ...) body ...) diff --git a/module/srfi/srfi-9/gnu.scm b/module/srfi/srfi-9/gnu.scm index 4f3a6634c..eb3506487 100644 --- a/module/srfi/srfi-9/gnu.scm +++ b/module/srfi/srfi-9/gnu.scm @@ -24,6 +24,7 @@ (define-module (srfi srfi-9 gnu) #:use-module (srfi srfi-1) + #:use-module (system base ck) #:export (set-record-type-printer! define-immutable-record-type set-field @@ -38,8 +39,8 @@ #t (define-immutable-record-type name ctor pred fields ...) name ctor pred fields ...)) -(define-syntax-rule (set-field (getter ...) s expr) - (%set-fields #t (set-field (getter ...) s expr) () +(define-syntax-rule (set-field s (getter ...) expr) + (%set-fields #t (set-field s (getter ...) expr) () s ((getter ...) expr))) (define-syntax-rule (set-fields s . rest) @@ -76,12 +77,41 @@ (with-syntax (((((head . tail) expr) ...) specs)) (fold insert '() #'(head ...) #'(tail ...) #'(expr ...)))) -(define-syntax %set-fields-unknown-getter +(define-syntax unknown-getter (lambda (x) (syntax-case x () ((_ orig-form getter) (syntax-violation 'set-fields "unknown getter" #'orig-form #'getter))))) +(define-syntax c-list + (lambda (x) + (syntax-case x (quote) + ((_ s 'v ...) + #'(ck s '(v ...)))))) + +(define-syntax c-same-type-check + (lambda (x) + (syntax-case x (quote) + ((_ s 'orig-form '(path ...) + '(getter0 getter ...) + '(type0 type ...) + 'on-success) + (every (lambda (t g) + (or (free-identifier=? t #'type0) + (syntax-violation + 'set-fields + (format #f + "\ +field paths ~a and ~a require one object to belong to two different record types (~a and ~a)" + (syntax->datum #`(path ... #,g)) + (syntax->datum #'(path ... getter0)) + (syntax->datum t) + (syntax->datum #'type0)) + #'orig-form))) + #'(type ...) + #'(getter ...)) + #'(ck s 'on-success))))) + (define-syntax %set-fields (lambda (x) (with-syntax ((getter-type #'(@@ (srfi srfi-9) getter-type)) @@ -98,24 +128,34 @@ 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))))))) + (with-syntax (((getter0 getter ...) + (map car collated-specs))) + (with-syntax ((err #'(unknown-getter + orig-form getter0))) + #`(ck + () + (c-same-type-check + 'orig-form + '(path-so-far ...) + '(getter0 getter ...) + (c-list (getter-type 'getter0 'err) + (getter-type 'getter 'err) ...) + '(let ((s struct-expr)) + ((ck () (getter-copier 'getter0 'err)) + check? + s + #,@(map (lambda (spec) + (with-syntax (((head (tail expr) ...) spec)) + (with-syntax ((err #'(unknown-getter + orig-form head))) + #'(head (%set-fields + check? + orig-form + (path-so-far ... head) + (struct-ref s (ck () (getter-index + 'head 'err))) + (tail expr) ...))))) + collated-specs))))))))) ((_ check? orig-form (path-so-far ...) s (() e) (() e*) ...) (syntax-violation 'set-fields "duplicate field path" diff --git a/module/system/base/ck.scm b/module/system/base/ck.scm new file mode 100644 index 000000000..cd9cc18c6 --- /dev/null +++ b/module/system/base/ck.scm @@ -0,0 +1,55 @@ +;;; ck, to facilitate applicative-order macro programming + +;;; Copyright (C) 2012 Free Software Foundation, Inc +;;; Copyright (C) 2009, 2011 Oleg Kiselyov +;;; +;;; This library is free software; you can redistribute it and/or +;;; modify it under the terms of the GNU Lesser General Public +;;; License as published by the Free Software Foundation; either +;;; version 3 of the License, or (at your option) any later version. +;;; +;;; This library 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 +;;; Lesser General Public License for more details. +;;; +;;; You should have received a copy of the GNU Lesser General Public +;;; License along with this library; if not, write to the Free Software +;;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA +;;; +;;; +;;; Originally written by Oleg Kiselyov and later contributed to Guile. +;;; +;;; Based on the CK machine introduced in: +;;; +;;; Matthias Felleisen and Daniel P. Friedman: Control operators, the +;;; SECD machine, and the lambda-calculus. In Martin Wirsing, editor, +;;; Formal Description of Programming Concepts III, pages +;;; 193-217. Elsevier, Amsterdam, 1986. +;;; +;;; See http://okmij.org/ftp/Scheme/macros.html#ck-macros for details. +;;; + +(define-module (system base ck) + #:export (ck)) + +(define-syntax ck + (syntax-rules (quote) + ((ck () 'v) v) ; yield the value on empty stack + + ((ck (((op ...) ea ...) . s) 'v) ; re-focus on the other argument, ea + (ck-arg s (op ... 'v) ea ...)) + + ((ck s (op ea ...)) ; Focus: handling an application; + (ck-arg s (op) ea ...)))) ; check if args are values + +(define-syntax ck-arg + (syntax-rules (quote) + ((ck-arg s (op va ...)) ; all arguments are evaluated, + (op s va ...)) ; do the redex + + ((ck-arg s (op ...) 'v ea1 ...) ; optimization when the first ea + (ck-arg s (op ... 'v) ea1 ...)) ; was already a value + + ((ck-arg s (op ...) ea ea1 ...) ; focus on ea, to evaluate it + (ck (((op ...) ea1 ...) . s) ea)))) diff --git a/test-suite/tests/srfi-9.test b/test-suite/tests/srfi-9.test index 4935148b3..e951fc67f 100644 --- a/test-suite/tests/srfi-9.test +++ b/test-suite/tests/srfi-9.test @@ -103,9 +103,9 @@ (pass-if "set-field" (let ((s (make-foo (make-bar 1 2)))) - (and (equal? (set-field (foo-x bar-j) s 3) + (and (equal? (set-field s (foo-x bar-j) 3) (make-foo (make-bar 1 3))) - (equal? (set-field (foo-z) s 'bar) + (equal? (set-field s (foo-z) 'bar) (let ((s2 (make-foo (make-bar 1 2)))) (set-foo-z! s2 'bar) s2)) @@ -113,19 +113,19 @@ (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))) + (set-field s (foo-x bar-j) 3))) (pass-if-exception "set-field on number" exception:wrong-type-arg - (set-field (foo-x bar-j) 4 3)) + (set-field 4 (foo-x bar-j) 3)) (pass-if-equal "set-field with unknown first getter" '(syntax-error set-fields "unknown getter" - (set-field (blah) s 3) + (set-field s (blah) 3) blah) (catch 'syntax-error (lambda () (compile '(let ((s (make-bar (make-foo 5) 2))) - (set-field (blah) s 3)) + (set-field s (blah) 3)) #:env (current-module)) #f) (lambda (key whom what src form subform) @@ -133,12 +133,12 @@ (pass-if-equal "set-field with unknown second getter" '(syntax-error set-fields "unknown getter" - (set-field (bar-j blah) s 3) + (set-field s (bar-j blah) 3) blah) (catch 'syntax-error (lambda () (compile '(let ((s (make-bar (make-foo 5) 2))) - (set-field (bar-j blah) s 3)) + (set-field s (bar-j blah) 3)) #:env (current-module)) #f) (lambda (key whom what src form subform) @@ -146,7 +146,7 @@ (pass-if "set-fields" (let ((s (make-foo (make-bar 1 2)))) - (and (equal? (set-field (foo-x bar-j) s 3) + (and (equal? (set-field s (foo-x bar-j) 3) (make-foo (make-bar 1 3))) (equal? (set-fields s ((foo-x bar-j) 3) @@ -262,18 +262,18 @@ (pass-if "set-field" (let ((s (make-foo (make-bar 1 2)))) - (and (equal? (set-field (foo-x bar-j) s 3) + (and (equal? (set-field s (foo-x bar-j) 3) (make-foo (make-bar 1 3))) - (equal? (set-field (foo-z) s 'bar) + (equal? (set-field s (foo-z) '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" + (pass-if "set-fieldss " (let ((s (make-foo (make-bar 1 2)))) - (and (equal? (set-field (foo-x bar-j) s 3) + (and (equal? (set-field s (foo-x bar-j) 3) (make-foo (make-bar 1 3))) (equal? (set-fields s ((foo-x bar-j) 3) @@ -340,10 +340,10 @@ (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") + (and (equal? (set-field p (person-address address-street) "Bar") (make-person 30 "foo@example.com" (make-address "Bar" "Paris" "France"))) - (equal? (set-field (person-email) p "bar@example.com") + (equal? (set-field p (person-email) "bar@example.com") (make-person 30 "bar@example.com" (make-address "Foo" "Paris" "France"))) (equal? p (make-person 30 "foo@example.com" @@ -448,10 +448,10 @@ (let ((p (make-person 30 "foo@example.com" (make-address "Foo" "Paris" "France")))) - (and (equal? (set-field (person-address address-street) p "Bar") + (and (equal? (set-field p (person-address address-street) "Bar") (make-person 30 "foo@example.com" (make-address "Bar" "Paris" "France"))) - (equal? (set-field (person-email) p "bar@example.com") + (equal? (set-field p (person-email) "bar@example.com") (make-person 30 "bar@example.com" (make-address "Foo" "Paris" "France"))) (equal? p (make-person 30 "foo@example.com" @@ -607,6 +607,42 @@ ((bar-i) 3)))) #:env (current-module)) #f) + (lambda (key whom what src form subform) + (list key whom what form subform)))) + + (pass-if-equal "incompatible field paths" + '(syntax-error set-fields + "\ +field paths (bar-i bar-j) and (bar-i foo-x) require one object \ +to belong to two different record types (bar and foo)" + (set-fields s + ((bar-i foo-x) 1) + ((bar-i bar-j) 2) + ((bar-j) 3)) + #f) + (catch 'syntax-error + (lambda () + (compile '(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)) + + (let ((s (make-bar (make-foo 5) 2))) + (set-fields s + ((bar-i foo-x) 1) + ((bar-i bar-j) 2) + ((bar-j) 3)))) + #:env (current-module)) + #f) (lambda (key whom what src form subform) (list key whom what form subform))))))