mirror/guile
mirror/guile
1
Fork 0
mirror of https://git.savannah.gnu.org/git/guile.git synced 2025-06-18 01:30:27 +02:00
Code Activity

Merge commit '8571dbde63'

Browse source 
Conflicts:
	libguile/procprop.c
This commit is contained in:
Andy Wingo 2013-11-28 15:00:17 +01:00
commit f76cf73a49
12 changed files with 359 additions and 30 deletions
Download patch file Download diff file Expand all files Collapse all files

1
module/Makefile.am
View file

@ -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 \

45
module/ice-9/hash-table.scm Normal file
View file

@ -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))

160
module/rnrs/exceptions.scm
View file

@ -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))))

2
module/web/http.scm
View file

@ -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)