Merge commit '8571dbde63'

Conflicts:
	libguile/procprop.c

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"
 

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
@@ -80,6 +81,41 @@
                             (lambda ()
                               (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
 ;;;

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: