[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-461-gdb18a25
|
From: |
Mark H Weaver |
|
Subject: |
[Guile-commits] GNU Guile branch, master, updated. v2.1.0-461-gdb18a25 |
|
Date: |
Sun, 11 Nov 2012 00:19:53 +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=db18a252fb4910017808878b3b8e2dfeda1ccdd0
The branch, master has been updated
via db18a252fb4910017808878b3b8e2dfeda1ccdd0 (commit)
via b594998356007e25dedb483373bf8bda4ba30006 (commit)
via a144a7a8467734c349399e3173df8e1c6c41a2a5 (commit)
via ec7e4f77ecbdc5ba28da8078e3a457d411f675bd (commit)
via 3d01c19a78929b89df2c3d1368cb435268259856 (commit)
via 46954839017812d1c05995a9050f37705a5d724e (commit)
via be05b336090598ee306d5799926b66c7556a8a5d (commit)
via 92fac8c056f8c2e61852625d48b5f7a8e66b72b9 (commit)
from ad84cc8b84c8ee0b4920e7a97b1e6ecbbbafab29 (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 db18a252fb4910017808878b3b8e2dfeda1ccdd0
Merge: ad84cc8 b594998
Author: Mark H Weaver <address@hidden>
Date: Sat Nov 10 19:17:30 2012 -0500
Merge remote-tracking branch 'origin/stable-2.0'
-----------------------------------------------------------------------
Summary of changes:
doc/ref/api-compound.texi | 253 +++++++++++++++++++++++++++++++++++++++++-
doc/ref/srfi-modules.texi | 104 +-----------------
module/Makefile.am | 3 +-
module/ice-9/futures.scm | 24 +++--
module/srfi/srfi-9.scm | 21 +++-
module/srfi/srfi-9/gnu.scm | 82 ++++++++++----
module/system/base/ck.scm | 55 +++++++++
test-suite/tests/srfi-9.test | 70 +++++++++---
8 files changed, 454 insertions(+), 158 deletions(-)
create mode 100644 module/system/base/ck.scm
diff --git a/doc/ref/api-compound.texi b/doc/ref/api-compound.texi
index d020774..6aaed06 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
address@hidden Record Overview
address@hidden Record Overview
address@hidden record
address@hidden structure
+
address@hidden, 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
address@hidden 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}).
+
+
address@hidden SRFI-9 Records
address@hidden SRFI-9 Records
+
address@hidden SRFI-9
address@hidden 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:
+
address@hidden
+(use-modules (srfi srfi-9))
address@hidden example
+
address@hidden {library syntax} define-record-type type @* (constructor
fieldname @dots{}) @* predicate @* (fieldname accessor [modifier]) @dots{}
address@hidden 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.
+
address@hidden 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}.
+
address@hidden is bound to a function to be called as
address@hidden(@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
address@hidden 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.
+
address@hidden is bound to a function to be called as
address@hidden(@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
address@hidden(@var{accessor} record)} to retrieve the respective field from a
address@hidden 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}.
address@hidden deffn
+
address@hidden
+An example will illustrate typical usage,
+
address@hidden
+(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))
address@hidden 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,
+
address@hidden
+employee-type @result{} #<record-type employee-type>
+
+(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
address@hidden 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.
+
address@hidden 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
address@hidden block. However, Guile's implementation does not enforce that
+restriction.
+
address@hidden 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.
+
address@hidden {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.
address@hidden deffn
+
address@hidden
+This example prints the employee's name in brackets, for instance
@code{[Fred]}.
+
address@hidden
+(set-record-type-printer! employee-type
+ (lambda (record port)
+ (write-char #\[ port)
+ (display (get-employee-name record) port)
+ (write-char #\] port)))
address@hidden example
+
address@hidden Functional ``Setters''
+
address@hidden 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 address@hidden setters}. First, the
address@hidden works like
address@hidden, except that fields are immutable and setters
+are defined as functional setters.
+
address@hidden {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.)
address@hidden deffn
+
address@hidden
+In addition, the generic @code{set-field} and @code{set-fields} macros
+may be applied to any SRFI-9 record.
+
address@hidden {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
address@hidden
+
address@hidden must be the name of the getter corresponding to the field of
address@hidden being ``set''. Subsequent @var{sub-fields} must be record
+getters designating sub-fields within that field value to be set (see
+example below.)
address@hidden deffn
+
address@hidden {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.
address@hidden deffn
+
+To illustrate the use of functional setters, let's assume these two
+record type definitions:
+
address@hidden
+(define-record-type <address>
+ (address street city country)
+ address?
+ (street address-street)
+ (city address-city)
+ (country address-country))
+
+(define-immutable-record-type <person>
+ (person age email address)
+ person?
+ (age person-age set-person-age)
+ (email person-email set-person-email)
+ (address person-address set-person-address))
address@hidden example
+
address@hidden
+First, note that the @code{<person>} record type definition introduces
+named functional setters. These may be used like this:
+
address@hidden
+(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))
address@hidden #t
address@hidden example
+
address@hidden
+Here, the original @code{<person>} 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}:
+
address@hidden
+(set-fields rms
+ ((person-age) 60)
+ ((person-address address-street) "Temple Place"))
address@hidden #<<person> age: 60 email: "rms@@gnu.org"
+ address: #<<address> street: "Temple Place" city: "Boston" country: "USA">>
address@hidden example
+
address@hidden
+Notice how the above changed two fields of @var{rms}, including the
address@hidden 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 da1b86f..f92ddaf 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
address@hidden SRFI-9
address@hidden 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}).
address@hidden
-(use-modules (srfi srfi-9))
address@hidden example
-
address@hidden {library syntax} define-record-type type @* (constructor
fieldname @dots{}) @* predicate @* (fieldname accessor [modifier]) @dots{}
address@hidden 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.
-
address@hidden 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}.
-
address@hidden is bound to a function to be called as
address@hidden(@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
address@hidden 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.
-
address@hidden is bound to a function to be called as
address@hidden(@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
address@hidden(@var{accessor} record)} to retrieve the respective field from a
address@hidden 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}.
address@hidden deffn
-
address@hidden
-An example will illustrate typical usage,
-
address@hidden
-(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))
address@hidden 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,
-
address@hidden
-employee-type @result{} #<record-type employee-type>
-
-(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
address@hidden 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.
-
address@hidden 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
address@hidden block. However, Guile's implementation does not enforce that
-restriction.
-
address@hidden 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.
-
address@hidden {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.
address@hidden deffn
-
address@hidden
-This example prints the employee's name in brackets, for instance
@code{[Fred]}.
-
address@hidden
-(set-record-type-printer! employee-type
- (lambda (record port)
- (write-char #\[ port)
- (display (get-employee-name record) port)
- (write-char #\] port)))
address@hidden example
@node SRFI-10
@subsection SRFI-10 - Hash-Comma Reader Extension
diff --git a/module/Makefile.am b/module/Makefile.am
index 49b8a31..2226d5b 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 0f64b5c..7fbccf6 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 de49459..d213a86 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 4f3a663..eb35064 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 0000000..cd9cc18
--- /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 4935148..e951fc6 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 "address@hidden"
(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 "address@hidden"
(make-address "Bar" "Paris" "France")))
- (equal? (set-field (person-email) p "address@hidden")
+ (equal? (set-field p (person-email) "address@hidden")
(make-person 30 "address@hidden"
(make-address "Foo" "Paris" "France")))
(equal? p (make-person 30 "address@hidden"
@@ -448,10 +448,10 @@
(let ((p (make-person 30 "address@hidden"
(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 "address@hidden"
(make-address "Bar" "Paris" "France")))
- (equal? (set-field (person-email) p "address@hidden")
+ (equal? (set-field p (person-email) "address@hidden")
(make-person 30 "address@hidden"
(make-address "Foo" "Paris" "France")))
(equal? p (make-person 30 "address@hidden"
@@ -608,6 +608,42 @@
#: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))))))
hooks/post-receive
--
GNU Guile
| [Prev in Thread] |
Current Thread |
[Next in Thread] |
- [Guile-commits] GNU Guile branch, master, updated. v2.1.0-461-gdb18a25,
Mark H Weaver <=