diff options
-rw-r--r-- | THANKS | 1 | ||||
-rw-r--r-- | doc/ref/api-compound.texi | 21 | ||||
-rw-r--r-- | libguile/async.h | 16 | ||||
-rw-r--r-- | libguile/threads.c | 16 | ||||
-rw-r--r-- | libguile/threads.h | 1 | ||||
-rw-r--r-- | module/Makefile.am | 1 | ||||
-rw-r--r-- | module/ice-9/hash-table.scm | 45 | ||||
-rw-r--r-- | module/rnrs/exceptions.scm | 160 | ||||
-rw-r--r-- | module/web/http.scm | 2 | ||||
-rw-r--r-- | test-suite/tests/exceptions.test | 26 | ||||
-rw-r--r-- | test-suite/tests/hash.test | 38 | ||||
-rw-r--r-- | test-suite/tests/r6rs-exceptions.test | 62 |
12 files changed, 359 insertions, 30 deletions
@@ -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: |