Merge remote-tracking branch 'origin/stable-2.0'

Conflicts:
	libguile/procprop.c

test-suite/standalone/Makefile.am

@@ -31,6 +31,7 @@ BUILT_SOURCES =
 EXTRA_DIST =
 
 TESTS_ENVIRONMENT =						\
+  srcdir="$(srcdir)"						\
   builddir="$(builddir)"					\
   GUILE_AUTO_COMPILE=0 "${top_builddir}/meta/uninstalled-env"
 
@@ -75,6 +76,11 @@ TESTS += test-require-extension
 check_SCRIPTS += test-guile-snarf
 TESTS += test-guile-snarf
 
+check_SCRIPTS += test-import-order
+TESTS += test-import-order
+EXTRA_DIST += test-import-order-a.scm test-import-order-b.scm \
+  test-import-order-c.scm test-import-order-d.scm
+
 # test-num2integral
 test_num2integral_SOURCES = test-num2integral.c
 test_num2integral_CFLAGS = ${test_cflags}

test-suite/standalone/test-import-order

@@ -0,0 +1,31 @@
+#!/bin/sh
+exec guile -q -L "$srcdir" -s "$0" "$@"
+!#
+
+(define-module (base)
+  #:export (push! order))
+
+(define order '())
+(define (push!)
+  (set! order `(,@order ,(module-name (current-module)))))
+
+(define-module (test-1)
+  #:use-module (base)
+  #:use-module (test-import-order-a)
+  #:use-module (test-import-order-b))
+
+(use-modules (test-import-order-c) (test-import-order-d))
+
+(if (not (equal? order
+                 '((test-import-order-a)
+                   (test-import-order-b)
+                   (test-import-order-c)
+                   (test-import-order-d))))
+    (begin
+      (format (current-error-port) "Unexpected import order: ~a" order)
+      (exit 1))
+    (exit 0))
+
+;; Local Variables:
+;; mode: scheme
+;; End:

test-suite/standalone/test-import-order-a.scm

@@ -0,0 +1,4 @@
+(define-module (test-import-order-a)
+  #:use-module (base))
+
+(push!)

test-suite/standalone/test-import-order-b.scm

@@ -0,0 +1,4 @@
+(define-module (test-import-order-b)
+  #:use-module (base))
+
+(push!)

test-suite/standalone/test-import-order-c.scm

@@ -0,0 +1,4 @@
+(define-module (test-import-order-c)
+  #:use-module (base))
+
+(push!)

test-suite/standalone/test-import-order-d.scm

@@ -0,0 +1,4 @@
+(define-module (test-import-order-d)
+  #:use-module (base))
+
+(push!)

test-suite/tests/r6rs-ports.test

@@ -19,9 +19,11 @@
 
 (define-module (test-io-ports)
   #:use-module (test-suite lib)
+  #:use-module (test-suite guile-test)
   #:use-module (srfi srfi-1)
   #:use-module (srfi srfi-11)
   #:use-module (rnrs io ports)
+  #:use-module (rnrs io simple)
   #:use-module (rnrs exceptions)
   #:use-module (rnrs bytevectors))
 
@@ -31,6 +33,45 @@
 ;; Set the default encoding of future ports to be Latin-1.
 (fluid-set! %default-port-encoding #f)
 
+(define-syntax pass-if-condition
+  (syntax-rules ()
+    ((_ name predicate body0 body ...)
+     (let ((cookie (list 'cookie)))
+       (pass-if name
+         (eq? cookie (guard (c ((predicate c) cookie))
+                       body0 body ...)))))))
+
+(define (test-file)
+  (data-file-name "ports-test.tmp"))
+
+;; A input/output port that swallows all output, and produces just
+;; spaces on input.  Reading and writing beyond `failure-position'
+;; produces `system-error' exceptions.  Used for testing exception
+;; behavior.
+(define* (make-failing-port #:optional (failure-position 0))
+  (define (maybe-fail index errno)
+    (if (> index failure-position)
+        (scm-error 'system-error
+                   'failing-port
+                   "I/O beyond failure position" '()
+                   (list errno))))
+  (let ((read-index  0)
+        (write-index 0))
+    (define (write-char chr)
+      (set! write-index (+ 1 write-index))
+      (maybe-fail write-index ENOSPC))
+    (make-soft-port
+     (vector write-char
+             (lambda (str)   ;; write-string
+               (for-each write-char (string->list str)))
+             (lambda () #t)  ;; flush-output
+             (lambda ()      ;; read-char
+               (set! read-index (+ read-index 1))
+               (maybe-fail read-index EIO)
+               #\space)
+             (lambda () #t)) ;; close-port
+     "rw")))
+
 
 (with-test-prefix "7.2.5 End-of-File Object"
 
@@ -421,6 +462,37 @@
 
 (with-test-prefix "8.2.10 Output ports"
 
+  (let ((filename (test-file)))
+    (pass-if "open-file-output-port [opens binary port]"
+      (call-with-port (open-file-output-port filename)
+        (lambda (port)
+          (put-bytevector port '#vu8(1 2 3))
+          (binary-port? port))))
+    
+    (pass-if-condition "open-file-output-port [exception: already-exists]"
+        i/o-file-already-exists-error?
+      (open-file-output-port filename))
+    
+    (pass-if "open-file-output-port [no-fail no-truncate]"
+      (and
+        (call-with-port (open-file-output-port filename
+                                               (file-options no-fail no-truncate))
+          (lambda (port)
+            (= 0 (port-position port))))
+        (= 3 (stat:size (stat filename)))))
+
+    (pass-if "open-file-output-port [no-fail]"
+      (and
+        (call-with-port (open-file-output-port filename (file-options no-fail))
+          binary-port?)
+        (= 0 (stat:size (stat filename)))))
+    
+    (delete-file filename)
+    
+    (pass-if-condition "open-file-output-port [exception: does-not-exist]"
+        i/o-file-does-not-exist-error?
+      (open-file-output-port filename (file-options no-create))))
+  
   (pass-if "open-bytevector-output-port"
     (let-values (((port get-content)
                   (open-bytevector-output-port #f)))
@@ -627,7 +699,69 @@
     (let ((port (open-input-string "GNU Guile"))
           (s (string-copy "Isn't XXX great?")))
       (and (= 3 (get-string-n! port s 6 3))
-           (string=? s "Isn't GNU great?")))))
+           (string=? s "Isn't GNU great?"))))
+
+  (with-test-prefix "read error"
+    (pass-if-condition "get-char" i/o-read-error?
+      (get-char (make-failing-port)))
+    (pass-if-condition "lookahead-char" i/o-read-error?
+      (lookahead-char (make-failing-port)))
+    ;; FIXME: these are not yet exception-correct
+    #|
+    (pass-if-condition "get-string-n" i/o-read-error?
+      (get-string-n (make-failing-port) 5))
+    (pass-if-condition "get-string-n!" i/o-read-error?
+      (get-string-n! (make-failing-port) (make-string 5) 0 5))
+    |#
+    (pass-if-condition "get-string-all" i/o-read-error?
+      (get-string-all (make-failing-port 100)))
+    (pass-if-condition "get-line" i/o-read-error?
+      (get-line (make-failing-port)))
+    (pass-if-condition "get-datum" i/o-read-error?
+      (get-datum (make-failing-port)))))
+
+(with-test-prefix "8.2.12 Textual Output"
+  
+  (with-test-prefix "write error"
+    (pass-if-condition "put-char" i/o-write-error?
+      (put-char (make-failing-port) #\G))
+    (pass-if-condition "put-string" i/o-write-error?
+      (put-string (make-failing-port) "Hello World!"))
+    (pass-if-condition "put-datum" i/o-write-error?
+      (put-datum (make-failing-port) '(hello world!)))))
+
+(with-test-prefix "8.3 Simple I/O"
+  (with-test-prefix "read error"
+    (pass-if-condition "read-char" i/o-read-error?
+      (read-char (make-failing-port)))
+    (pass-if-condition "peek-char" i/o-read-error?
+      (peek-char (make-failing-port)))
+    (pass-if-condition "read" i/o-read-error?
+      (read (make-failing-port))))
+  (with-test-prefix "write error"
+    (pass-if-condition "display" i/o-write-error?
+      (display "Hi there!" (make-failing-port)))
+    (pass-if-condition "write" i/o-write-error?
+      (write '(hi there!) (make-failing-port)))
+    (pass-if-condition "write-char" i/o-write-error?
+      (write-char #\G (make-failing-port)))
+    (pass-if-condition "newline" i/o-write-error?
+      (newline (make-failing-port))))
+  (let ((filename (test-file)))
+    ;; ensure the test file exists
+    (call-with-output-file filename
+      (lambda (port) (write "foo" port)))
+    (pass-if "call-with-input-file [port is textual]"
+      (call-with-input-file filename textual-port?))
+    (pass-if-condition "call-with-input-file [exception: not-found]"
+        i/o-file-does-not-exist-error?
+      (call-with-input-file ",this-is-highly-unlikely-to-exist!"
+        values))
+    (pass-if-condition "call-with-output-file [exception: already-exists]"
+        i/o-file-already-exists-error?
+      (call-with-output-file filename
+        values))
+    (delete-file filename)))
 
 ;;; Local Variables:
 ;;; mode: scheme