[Top][All Lists]
[Date Prev][Date Next][Thread Prev][Thread Next][Date Index][Thread Index]
[Guile-commits] GNU Guile branch, stable-2.0, updated. v2.0.6-76-gbe05b3
From: |
Mark H Weaver |
Subject: |
[Guile-commits] GNU Guile branch, stable-2.0, updated. v2.0.6-76-gbe05b33 |
Date: |
Sat, 10 Nov 2012 15:08:27 +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=be05b336090598ee306d5799926b66c7556a8a5d
The branch, stable-2.0 has been updated
via be05b336090598ee306d5799926b66c7556a8a5d (commit)
via 92fac8c056f8c2e61852625d48b5f7a8e66b72b9 (commit)
from f31a0762328b9cffa328ce1540ceaa6f1497e083 (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 be05b336090598ee306d5799926b66c7556a8a5d
Author: Mark H Weaver <address@hidden>
Date: Wed Nov 7 08:39:42 2012 -0500
Futures: Avoid creating the worker pool more than once.
* module/ice-9/futures.scm (%create-workers!): Use 'with-mutex' in case
an exception is thrown. Within the critical section, check to make
sure the worker pool hasn't already been created by another thread.
commit 92fac8c056f8c2e61852625d48b5f7a8e66b72b9
Author: Mark H Weaver <address@hidden>
Date: Fri Nov 9 05:04:13 2012 -0500
Improve error for set-fields paths leading to different types.
* module/system/base/ck.scm: New module.
* module/srfi/srfi-9.scm: Import (system base ck).
(getter-type, getter-index, getter-copier): Convert incoming argument
convention to CK form.
(define-tagged-inlinable): Convert return value convention for key
lookup to CK form.
* module/srfi/srfi-9/gnu.scm: Import (system base ck).
Rename '%set-fields-unknown-getter' to 'unknown-getter'.
(c-list, c-same-type-check): New macros.
(%set-fields): Using the CK abstract machine, arrange to check (at
macro expansion time) that all of the getters in head position
correspond to the same record type.
* test-suite/tests/srfi-9.test: Add test.
-----------------------------------------------------------------------
Summary of changes:
module/ice-9/futures.scm | 24 ++++++++-----
module/srfi/srfi-9.scm | 21 +++++++----
module/srfi/srfi-9/gnu.scm | 78 +++++++++++++++++++++++++++++++----------
module/system/base/ck.scm | 55 +++++++++++++++++++++++++++++
test-suite/tests/srfi-9.test | 36 +++++++++++++++++++
5 files changed, 179 insertions(+), 35 deletions(-)
create mode 100644 module/system/base/ck.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..6322756 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
@@ -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..cd313ac 100644
--- a/test-suite/tests/srfi-9.test
+++ b/test-suite/tests/srfi-9.test
@@ -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, stable-2.0, updated. v2.0.6-76-gbe05b33,
Mark H Weaver <=