summaryrefslogtreecommitdiff
diff options
context:
space:
mode:
-rw-r--r--THANKS1
-rw-r--r--doc/ref/api-compound.texi21
-rw-r--r--libguile/async.h16
-rw-r--r--libguile/threads.c16
-rw-r--r--libguile/threads.h1
-rw-r--r--module/Makefile.am1
-rw-r--r--module/ice-9/hash-table.scm45
-rw-r--r--module/rnrs/exceptions.scm160
-rw-r--r--module/web/http.scm2
-rw-r--r--test-suite/tests/exceptions.test26
-rw-r--r--test-suite/tests/hash.test38
-rw-r--r--test-suite/tests/r6rs-exceptions.test62
12 files changed, 359 insertions, 30 deletions
diff --git a/THANKS b/THANKS
index ea7c8c3cb..63f8feb42 100644
--- a/THANKS
+++ b/THANKS
@@ -29,6 +29,7 @@ Contributors since the last release:
Kevin Ryde
Stefan I Tampe
BT Templeton
+ David Thompson
Bake Timmons
Mark H Weaver
Göran Weinholt
diff --git a/doc/ref/api-compound.texi b/doc/ref/api-compound.texi
index 94e01450e..0b14c4889 100644
--- a/doc/ref/api-compound.texi
+++ b/doc/ref/api-compound.texi
@@ -3829,6 +3829,27 @@ then it can use @var{size} to avoid rehashing when initial entries are
added.
@end deffn
+@deffn {Scheme Procedure} alist->hash-table alist
+@deffnx {Scheme Procedure} alist->hashq-table alist
+@deffnx {Scheme Procedure} alist->hashv-table alist
+@deffnx {Scheme Procedure} alist->hashx-table hash assoc alist
+Convert @var{alist} into a hash table. When keys are repeated in
+@var{alist}, the leftmost association takes precedence.
+
+@example
+(use-modules (ice-9 hash-table))
+(alist->hash-table '((foo . 1) (bar . 2)))
+@end example
+
+When converting to an extended hash table, custom @var{hash} and
+@var{assoc} procedures must be provided.
+
+@example
+(alist->hashx-table hash assoc '((foo . 1) (bar . 2)))
+@end example
+
+@end deffn
+
@deffn {Scheme Procedure} hash-table? obj
@deffnx {C Function} scm_hash_table_p (obj)
Return @code{#t} if @var{obj} is a abstract hash table object.
diff --git a/libguile/async.h b/libguile/async.h
index 68952b055..e6fe5237c 100644
--- a/libguile/async.h
+++ b/libguile/async.h
@@ -78,6 +78,22 @@ SCM_API void scm_critical_section_end (void);
scm_async_tick (); \
} while (0)
+# define scm_i_pthread_mutex_lock_block_asyncs(m) \
+ do \
+ { \
+ SCM_I_CURRENT_THREAD->block_asyncs++; \
+ scm_i_pthread_mutex_lock (m); \
+ } \
+ while (0)
+
+# define scm_i_pthread_mutex_unlock_unblock_asyncs(m) \
+ do \
+ { \
+ scm_i_pthread_mutex_unlock (m); \
+ SCM_I_CURRENT_THREAD->block_asyncs--; \
+ } \
+ while (0)
+
#else /* !BUILDING_LIBGUILE */
# define SCM_CRITICAL_SECTION_START scm_critical_section_start ()
diff --git a/libguile/threads.c b/libguile/threads.c
index a67f30b30..f39bcc39e 100644
--- a/libguile/threads.c
+++ b/libguile/threads.c
@@ -1875,6 +1875,22 @@ scm_pthread_cond_timedwait (scm_i_pthread_cond_t *cond,
#endif
+static void
+do_unlock_with_asyncs (void *data)
+{
+ scm_i_pthread_mutex_unlock ((scm_i_pthread_mutex_t *)data);
+ SCM_I_CURRENT_THREAD->block_asyncs--;
+}
+
+void
+scm_i_dynwind_pthread_mutex_lock_block_asyncs (scm_i_pthread_mutex_t *mutex)
+{
+ SCM_I_CURRENT_THREAD->block_asyncs++;
+ scm_i_scm_pthread_mutex_lock (mutex);
+ scm_dynwind_unwind_handler (do_unlock_with_asyncs, mutex,
+ SCM_F_WIND_EXPLICITLY);
+}
+
unsigned long
scm_std_usleep (unsigned long usecs)
{
diff --git a/libguile/threads.h b/libguile/threads.h
index d34e1abf7..6db6c7594 100644
--- a/libguile/threads.h
+++ b/libguile/threads.h
@@ -140,6 +140,7 @@ SCM_INTERNAL void scm_init_threads (void);
SCM_INTERNAL void scm_init_thread_procs (void);
SCM_INTERNAL void scm_init_threads_default_dynamic_state (void);
+SCM_INTERNAL void scm_i_dynwind_pthread_mutex_lock_block_asyncs (scm_i_pthread_mutex_t *mutex);
SCM_API SCM scm_call_with_new_thread (SCM thunk, SCM handler);
SCM_API SCM scm_yield (void);
diff --git a/module/Makefile.am b/module/Makefile.am
index 64ded639c..beb1a99c4 100644
--- a/module/Makefile.am
+++ b/module/Makefile.am
@@ -213,6 +213,7 @@ ICE_9_SOURCES = \
ice-9/format.scm \
ice-9/futures.scm \
ice-9/getopt-long.scm \
+ ice-9/hash-table.scm \
ice-9/hcons.scm \
ice-9/i18n.scm \
ice-9/iconv.scm \
diff --git a/module/ice-9/hash-table.scm b/module/ice-9/hash-table.scm
new file mode 100644
index 000000000..ca9d2fd37
--- /dev/null
+++ b/module/ice-9/hash-table.scm
@@ -0,0 +1,45 @@
+;;;; hash-table.scm --- Additional hash table procedures
+;;;; Copyright (C) 2013 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
+;;;; 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
+;;;;
+
+(define-module (ice-9 hash-table)
+ #:export (alist->hash-table
+ alist->hashq-table
+ alist->hashv-table
+ alist->hashx-table))
+
+(define-syntax-rule (define-alist-converter name hash-set-proc)
+ (define (name alist)
+ "Convert ALIST into a hash table."
+ (let ((table (make-hash-table)))
+ (for-each (lambda (pair)
+ (hash-set-proc table (car pair) (cdr pair)))
+ (reverse alist))
+ table)))
+
+(define-alist-converter alist->hash-table hash-set!)
+(define-alist-converter alist->hashq-table hashq-set!)
+(define-alist-converter alist->hashv-table hashv-set!)
+
+(define (alist->hashx-table hash assoc alist)
+ "Convert ALIST into a hash table with custom HASH and ASSOC
+procedures."
+ (let ((table (make-hash-table)))
+ (for-each (lambda (pair)
+ (hashx-set! hash assoc table (car pair) (cdr pair)))
+ (reverse alist))
+ table))
diff --git a/module/rnrs/exceptions.scm b/module/rnrs/exceptions.scm
index 95d01dfdc..52f5c257f 100644
--- a/module/rnrs/exceptions.scm
+++ b/module/rnrs/exceptions.scm
@@ -1,6 +1,6 @@
;;; exceptions.scm --- The R6RS exceptions library
-;; Copyright (C) 2010, 2011 Free Software Foundation, Inc.
+;; Copyright (C) 2010, 2011, 2013 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
@@ -29,14 +29,61 @@
newline
display
filter
+ acons
+ assv-ref
+ throw
set-exception-printer!
with-throw-handler
*unspecified*
@@))
- (define raise (@@ (rnrs records procedural) r6rs-raise))
- (define raise-continuable
+ ;; When a native guile exception is caught by an R6RS exception
+ ;; handler, we convert it to an R6RS compound condition that includes
+ ;; not only the standard condition objects expected by R6RS code, but
+ ;; also a special &guile condition that preserves the original KEY and
+ ;; ARGS passed to the native Guile catch handler.
+
+ (define-condition-type &guile &condition
+ make-guile-condition guile-condition?
+ (key guile-condition-key)
+ (args guile-condition-args))
+
+ (define (default-guile-condition-converter key args)
+ (condition (make-serious-condition)
+ (guile-common-conditions key args)))
+
+ (define (guile-common-conditions key args)
+ (apply (case-lambda
+ ((subr msg margs . _)
+ (condition (make-who-condition subr)
+ (make-message-condition msg)
+ (make-irritants-condition margs)))
+ (_ (make-irritants-condition args)))
+ args))
+
+ (define (convert-guile-condition key args)
+ (let ((converter (assv-ref guile-condition-converters key)))
+ (condition (or (and converter (converter key args))
+ (default-guile-condition-converter key args))
+ ;; Preserve the original KEY and ARGS in the R6RS
+ ;; condition object.
+ (make-guile-condition key args))))
+
+ ;; If an R6RS exception handler chooses not to handle a given
+ ;; condition, it will re-raise the condition to pass it on to the next
+ ;; handler. If the condition was converted from a native Guile
+ ;; exception, we must re-raise using the native Guile facilities and
+ ;; the original exception KEY and ARGS. We arrange for this in
+ ;; 'raise' so that native Guile exception handlers will continue to
+ ;; work when mixed with R6RS code.
+
+ (define (raise obj)
+ (if (guile-condition? obj)
+ (apply throw (guile-condition-key obj) (guile-condition-args obj))
+ ((@@ (rnrs records procedural) r6rs-raise) obj)))
+ (define raise-continuable
(@@ (rnrs records procedural) r6rs-raise-continuable))
+
(define raise-object-wrapper?
(@@ (rnrs records procedural) raise-object-wrapper?))
(define raise-object-wrapper-obj
@@ -45,19 +92,22 @@
(@@ (rnrs records procedural) raise-object-wrapper-continuation))
(define (with-exception-handler handler thunk)
- (with-throw-handler 'r6rs:exception
+ (with-throw-handler #t
thunk
(lambda (key . args)
- (if (and (not (null? args))
- (raise-object-wrapper? (car args)))
- (let* ((cargs (car args))
- (obj (raise-object-wrapper-obj cargs))
- (continuation (raise-object-wrapper-continuation cargs))
- (handler-return (handler obj)))
- (if continuation
- (continuation handler-return)
- (raise (make-non-continuable-violation))))
- *unspecified*))))
+ (cond ((not (eq? key 'r6rs:exception))
+ (let ((obj (convert-guile-condition key args)))
+ (handler obj)
+ (raise (make-non-continuable-violation))))
+ ((and (not (null? args))
+ (raise-object-wrapper? (car args)))
+ (let* ((cargs (car args))
+ (obj (raise-object-wrapper-obj cargs))
+ (continuation (raise-object-wrapper-continuation cargs))
+ (handler-return (handler obj)))
+ (if continuation
+ (continuation handler-return)
+ (raise (make-non-continuable-violation)))))))))
(define-syntax guard0
(syntax-rules ()
@@ -143,4 +193,84 @@
(set-exception-printer! 'r6rs:exception exception-printer)
-)
+ ;; Guile condition converters
+ ;;
+ ;; Each converter is a procedure (converter KEY ARGS) that returns
+ ;; either an R6RS condition or #f. If #f is returned,
+ ;; 'default-guile-condition-converter' will be used.
+
+ (define (guile-syntax-violation-converter key args)
+ (apply (case-lambda
+ ((who what where form subform . extra)
+ (condition (make-syntax-violation form subform)
+ (make-who-condition who)
+ (make-message-condition what)))
+ (_ #f))
+ args))
+
+ (define (guile-lexical-violation-converter key args)
+ (condition (make-lexical-violation) (guile-common-conditions key args)))
+
+ (define (guile-assertion-violation-converter key args)
+ (condition (make-assertion-violation) (guile-common-conditions key args)))
+
+ (define (guile-undefined-violation-converter key args)
+ (condition (make-undefined-violation) (guile-common-conditions key args)))
+
+ (define (guile-implementation-restriction-converter key args)
+ (condition (make-implementation-restriction-violation)
+ (guile-common-conditions key args)))
+
+ (define (guile-error-converter key args)
+ (condition (make-error) (guile-common-conditions key args)))
+
+ (define (guile-system-error-converter key args)
+ (apply (case-lambda
+ ((subr msg msg-args errno . rest)
+ ;; XXX TODO we should return a more specific error
+ ;; (usually an I/O error) as expected by R6RS programs.
+ ;; Unfortunately this often requires the 'filename' (or
+ ;; other?) which is not currently provided by the native
+ ;; Guile exceptions.
+ (condition (make-error) (guile-common-conditions key args)))
+ (_ (guile-error-converter key args)))
+ args))
+
+ ;; TODO: Arrange to have the needed information included in native
+ ;; Guile I/O exceptions, and arrange here to convert them to the
+ ;; proper conditions. Remove the earlier exception conversion
+ ;; mechanism: search for 'with-throw-handler' in the 'rnrs'
+ ;; tree, e.g. 'with-i/o-filename-conditions' and
+ ;; 'with-i/o-port-error' in (rnrs io ports).
+
+ ;; XXX TODO: How should we handle the 'misc-error', 'vm-error', and
+ ;; 'signal' native Guile exceptions?
+
+ ;; XXX TODO: Should we handle the 'quit' exception specially?
+
+ ;; An alist mapping native Guile exception keys to converters.
+ (define guile-condition-converters
+ `((read-error . ,guile-lexical-violation-converter)
+ (syntax-error . ,guile-syntax-violation-converter)
+ (unbound-variable . ,guile-undefined-violation-converter)
+ (wrong-number-of-args . ,guile-assertion-violation-converter)
+ (wrong-type-arg . ,guile-assertion-violation-converter)
+ (keyword-argument-error . ,guile-assertion-violation-converter)
+ (out-of-range . ,guile-assertion-violation-converter)
+ (regular-expression-syntax . ,guile-assertion-violation-converter)
+ (program-error . ,guile-assertion-violation-converter)
+ (goops-error . ,guile-assertion-violation-converter)
+ (null-pointer-error . ,guile-assertion-violation-converter)
+ (system-error . ,guile-system-error-converter)
+ (host-not-found . ,guile-error-converter)
+ (getaddrinfo-error . ,guile-error-converter)
+ (no-data . ,guile-error-converter)
+ (no-recovery . ,guile-error-converter)
+ (try-again . ,guile-error-converter)
+ (stack-overflow . ,guile-implementation-restriction-converter)
+ (numerical-overflow . ,guile-implementation-restriction-converter)
+ (memory-allocation-error . ,guile-implementation-restriction-converter)))
+
+ (define (set-guile-condition-converter! key proc)
+ (set! guile-condition-converters
+ (acons key proc guile-condition-converters))))
diff --git a/module/web/http.scm b/module/web/http.scm
index af04259cc..6c9ab9523 100644
--- a/module/web/http.scm
+++ b/module/web/http.scm
@@ -716,6 +716,8 @@ as an ordered alist."
(cond
((string=? s "GMT")
0)
+ ((string=? s "UTC")
+ 0)
((string-match? s ".dddd")
(let ((sign (case (string-ref s 0)
((#\+) +1)
diff --git a/test-suite/tests/exceptions.test b/test-suite/tests/exceptions.test
index bcaa282e5..a839b68de 100644
--- a/test-suite/tests/exceptions.test
+++ b/test-suite/tests/exceptions.test
@@ -18,18 +18,20 @@
(use-modules (test-suite lib))
-(define-macro (throw-test title result . exprs)
- `(pass-if ,title
- (equal? ,result
- (letrec ((stack '())
- (push (lambda (val)
- (set! stack (cons val stack)))))
- (begin ,@exprs)
- ;;(display ,title)
- ;;(display ": ")
- ;;(write (reverse stack))
- ;;(newline)
- (reverse stack)))))
+(define-syntax-parameter push
+ (lambda (stx)
+ (syntax-violation 'push "push used outside of throw-test" stx)))
+
+(define-syntax-rule (throw-test title result expr ...)
+ (pass-if title
+ (equal? result
+ (let ((stack '()))
+ (syntax-parameterize ((push (syntax-rules ()
+ ((push val)
+ (set! stack (cons val stack))))))
+ expr ...
+ ;;(format #t "~a: ~s~%" title (reverse stack))
+ (reverse stack))))))
(with-test-prefix "throw/catch"
diff --git a/test-suite/tests/hash.test b/test-suite/tests/hash.test
index 3bd400425..ad247f50a 100644
--- a/test-suite/tests/hash.test
+++ b/test-suite/tests/hash.test
@@ -18,7 +18,8 @@
(define-module (test-suite test-numbers)
#:use-module (test-suite lib)
- #:use-module (ice-9 documentation))
+ #:use-module (ice-9 documentation)
+ #:use-module (ice-9 hash-table))
;;;
;;; hash
@@ -81,6 +82,41 @@
(write (make-hash-table 100)))))))
;;;
+;;; alist->hash-table
+;;;
+
+(with-test-prefix
+ "alist conversion"
+
+ (pass-if "alist->hash-table"
+ (let ((table (alist->hash-table '(("foo" . 1)
+ ("bar" . 2)
+ ("foo" . 3)))))
+ (and (= (hash-ref table "foo") 1)
+ (= (hash-ref table "bar") 2))))
+
+ (pass-if "alist->hashq-table"
+ (let ((table (alist->hashq-table '((foo . 1)
+ (bar . 2)
+ (foo . 3)))))
+ (and (= (hashq-ref table 'foo) 1)
+ (= (hashq-ref table 'bar) 2))))
+
+ (pass-if "alist->hashv-table"
+ (let ((table (alist->hashv-table '((1 . 1)
+ (2 . 2)
+ (1 . 3)))))
+ (and (= (hashv-ref table 1) 1)
+ (= (hashv-ref table 2) 2))))
+
+ (pass-if "alist->hashx-table"
+ (let ((table (alist->hashx-table hash assoc '((foo . 1)
+ (bar . 2)
+ (foo . 3)))))
+ (and (= (hashx-ref hash assoc table 'foo) 1)
+ (= (hashx-ref hash assoc table 'bar) 2)))))
+
+;;;
;;; usual set and reference
;;;
diff --git a/test-suite/tests/r6rs-exceptions.test b/test-suite/tests/r6rs-exceptions.test
index 54a4ddbd6..8ad6bdca8 100644
--- a/test-suite/tests/r6rs-exceptions.test
+++ b/test-suite/tests/r6rs-exceptions.test
@@ -1,6 +1,6 @@
-;;; r6rs-exceptions.test --- Test suite for R6RS (rnrs exceptions)
+;;; r6rs-exceptions.test --- Test suite for R6RS (rnrs exceptions) -*- scheme -*-
-;; Copyright (C) 2010 Free Software Foundation, Inc.
+;; Copyright (C) 2010, 2013 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
@@ -20,6 +20,7 @@
(define-module (test-suite test-rnrs-exceptions)
:use-module ((rnrs conditions) :version (6))
:use-module ((rnrs exceptions) :version (6))
+ :use-module (system foreign)
:use-module (test-suite lib))
(with-test-prefix "with-exception-handler"
@@ -96,3 +97,60 @@
(pass-if "guard with cond => syntax"
(guard (condition (condition => error?)) (raise (make-error)))))
+
+(with-test-prefix "guile condition conversions"
+
+ (define-syntax-rule (pass-if-condition name expected-condition? body ...)
+ (pass-if name
+ (guard (obj ((expected-condition? obj) #t)
+ (else #f))
+ body ... #f)))
+
+ (pass-if "rethrown native guile exceptions"
+ (catch #t
+ (lambda ()
+ (guard (obj ((syntax-violation? obj) #f))
+ (vector-ref '#(0 1) 2)
+ #f))
+ (lambda (key . args)
+ (eq? key 'out-of-range))))
+
+ (pass-if-condition "syntax-error"
+ syntax-violation?
+ (eval '(let) (current-module)))
+
+ (pass-if-condition "unbound-variable"
+ undefined-violation?
+ variable-that-does-not-exist)
+
+ (pass-if-condition "out-of-range"
+ assertion-violation?
+ (vector-ref '#(0 1) 2))
+
+ (pass-if-condition "wrong-number-of-args"
+ assertion-violation?
+ ((lambda () #f) 'unwanted-argument))
+
+ (pass-if-condition "wrong-type-arg"
+ assertion-violation?
+ (vector-ref '#(0 1) 'invalid-index))
+
+ (pass-if-condition "keyword-argument-error"
+ assertion-violation?
+ ((lambda* (#:key a) #f) #:unwanted-keyword 'val))
+
+ (pass-if-condition "regular-expression-syntax"
+ assertion-violation?
+ (make-regexp "[missing-close-square-bracket"))
+
+ (pass-if-condition "null-pointer-error"
+ assertion-violation?
+ (dereference-pointer (make-pointer 0)))
+
+ (pass-if-condition "read-error"
+ lexical-violation?
+ (read (open-input-string "(missing-close-paren"))))
+
+;;; Local Variables:
+;;; eval: (put 'pass-if-condition 'scheme-indent-function 1)
+;;; End: