[Guile-commits] GNU Guile branch, stable-2.0, updated. v2.0.9-102-g02500d4

[Mark H Weaver]

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=02500d44775a77e46febfd47a0dab8233b0c99d0

The branch, stable-2.0 has been updated
       via  02500d44775a77e46febfd47a0dab8233b0c99d0 (commit)
       via  750ac8c592e792e627444f476877f282525b132e (commit)
      from  363df6cf108763e24eb5cb149131a3fa3f400734 (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 02500d44775a77e46febfd47a0dab8233b0c99d0
Author: Mark H Weaver <address@hidden>
Date:   Fri Aug 9 18:27:20 2013 -0400

    Convert guile exceptions to R6RS conditions in R6RS exception handlers.
    
    * module/rnrs/exceptions.scm (&guile): New condition type.
    
      (guile-condition-converters): New variable.
    
      (convert-guile-condition, default-guile-condition-converter,
      set-guile-condition-converter!, guile-common-conditions,
      guile-lexical-violation-converter, guile-syntax-violation-converter,
      guile-assertion-violation-converter, guile-system-error-converter,
      guile-undefined-violation-converter, guile-error-converter,
      guile-implementation-restriction-converter): New procedures.
    
      (with-exception-handler): Catch all exceptions, not just R6RS
      exceptions.  Convert native Guile exceptions to R6RS conditions,
      preserving the original Guile exception information in the &guile
      condition object.
    
      (raise): If the condition includes a &guile condition, use 'throw' to
      throw the original native guile exception instead of raising an R6RS
      exception.
    
    * test-suite/tests/r6rs-exceptions.test ("guile condition conversions"):
      Add tests.

commit 750ac8c592e792e627444f476877f282525b132e
Author: Mark H Weaver <address@hidden>
Date:   Sat Nov 16 23:24:42 2013 -0500

    Improve error when 'include' form with relative path is not in a file.
    
    Reported by Nala Ginrut <address@hidden>.
    
    * module/ice-9/psyntax.scm (include): Give a proper error message when
      given a relative file name, and when the form is not in a file.
    
    * module/ice-9/psyntax-pp.scm: Regenerate.

-----------------------------------------------------------------------

Summary of changes:
 module/ice-9/psyntax-pp.scm           |    9 ++-
 module/ice-9/psyntax.scm              |   12 ++-
 module/rnrs/exceptions.scm            |  160 +++++++++++++++++++++++++++++---
 test-suite/tests/r6rs-exceptions.test |   62 ++++++++++++-
 4 files changed, 222 insertions(+), 21 deletions(-)

diff --git a/module/ice-9/psyntax-pp.scm b/module/ice-9/psyntax-pp.scm
index 254f701..7b801ad 100644
--- a/module/ice-9/psyntax-pp.scm
+++ b/module/ice-9/psyntax-pp.scm
@@ -2974,7 +2974,14 @@
         ((read-file
            (lambda (fn dir k)
              (let ((p (open-input-file
-                        (if (absolute-file-name? fn) fn (in-vicinity dir 
fn)))))
+                        (if (absolute-file-name? fn)
+                          fn
+                          (if dir
+                            (in-vicinity dir fn)
+                            (syntax-violation
+                              'include
+                              "relative file name only allowed when the 
include form is in a file"
+                              x))))))
                (let ((enc (file-encoding p)))
                  (set-port-encoding! p (let ((t enc)) (if t t "UTF-8")))
                  (let f ((x (read p)) (result '()))
diff --git a/module/ice-9/psyntax.scm b/module/ice-9/psyntax.scm
index 576fc3f..5f1bd8a 100644
--- a/module/ice-9/psyntax.scm
+++ b/module/ice-9/psyntax.scm
@@ -2952,9 +2952,15 @@
     (define read-file
       (lambda (fn dir k)
         (let* ((p (open-input-file
-                   (if (absolute-file-name? fn)
-                       fn
-                       (in-vicinity dir fn))))
+                   (cond ((absolute-file-name? fn)
+                          fn)
+                         (dir
+                          (in-vicinity dir fn))
+                         (else
+                          (syntax-violation
+                           'include
+                           "relative file name only allowed when the include 
form is in a file"
+                           x)))))
                (enc (file-encoding p)))
 
           ;; Choose the input encoding deterministically.
diff --git a/module/rnrs/exceptions.scm b/module/rnrs/exceptions.scm
index 95d01df..52f5c25 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/test-suite/tests/r6rs-exceptions.test 
b/test-suite/tests/r6rs-exceptions.test
index 54a4ddb..8ad6bdc 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:


hooks/post-receive
-- 
GNU Guile