r6rs io/simple tests; syntax-case bug fix (PR 9328)

svn: r9535

collects/r6rs/private/readtable.ss

@@ -6,6 +6,7 @@
          (for-syntax scheme/base))
 
 (provide with-r6rs-reader-parameters
+         rx:id
          rx:number)
 
 ;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

collects/rnrs/io/ports-6.ss

@@ -930,6 +930,19 @@
                  [pretty-print-size-hook
                   (lambda (v write? p)
                     (cond
+                     [(symbol? v)
+                      (let ([s (symbol->string v)])
+                        (and (not (regexp-match rx:id s))
+                             (for/fold ([len 0])
+                                 ([c (in-string s)]
+                                  [pos (in-naturals)])
+                               (+ len 
+                                  (if (or (char-alphabetic? c)
+                                          (and (char-numeric? c)
+                                               (positive? pos)))
+                                      1
+                                      (+ 3 (string-length 
+                                            (number->string (char->integer c) 16))))))))]
                      [(string? v) 
                       (and (for/or ([c (in-string v)])
                                    (not (or (char-graphic? c)
@@ -966,6 +979,17 @@
                  [pretty-print-print-hook
                   (lambda (v write? p)
                     (cond
+                     [(symbol? v)
+                      (for ([c (in-string (symbol->string v))]
+                            [pos (in-naturals)])
+                        (if (or (char-alphabetic? c)
+                                (and (char-numeric? c)
+                                     (positive? pos)))
+                            (display c p)
+                            (begin
+                              (display "\\x" p)
+                              (display (number->string (char->integer c) 16) p)
+                              (display ";" p))))]
                      [(string? v) 
                       (write-char #\" p)
                       (for ([c (in-string v)])

collects/rnrs/syntax-case-6.ss

@@ -205,7 +205,8 @@
       (mcons (unwrap (car p) (car mapping))
              (unwrap (cdr p) (cdr mapping))))]
    [(vector? mapping)
-    (list->vector (unwrap (vector->list (syntax-e stx)) (vector->list mapping)))]
+    (list->vector (mlist->list (unwrap (vector->list (syntax-e stx)) (vector->list mapping))))]
+   [(null? mapping) null]
    [(box? mapping)
     ;; ellipses
     (let* ([mapping (unbox mapping)]
@@ -254,7 +255,7 @@
             repeats
             (mappend repeats
                      (unwrap rest-stx rest-mapping)))))]
-   [else (error 'unwrap "srtange unwrap mapping: ~e" mapping)]))
+   [else (error 'unwrap "strange unwrap mapping: ~e" mapping)]))
 
 (define-syntax (r6rs:syntax stx)
   (syntax-case stx ()

collects/tests/r6rs/io/ports.ss

@@ -722,9 +722,19 @@
     (test-rw 1+2.0i)
     (test-rw #t)
     (test-rw #f)
+    (test-rw 'apple)
+    (test-rw (string->number "app\x3BB;e"))
+    (test-rw (string->symbol " "))
+    (test-rw (string->symbol "+"))
+    (test-rw (string->symbol "0"))
+    (test-rw (string->symbol "app\x1678;e"))
+    (test-rw 'a1)
+    (test-rw '->)
+    (test-rw '...)
     (test-rw "apple")
     (test-rw "app\x3BB;e")
     (test-rw "app\x1678;e")
+    (test-rw "\r\n")
     (test-rw #\a)
     (test-rw #\x3BB)
     (test-rw #\nul)

collects/tests/r6rs/io/simple.ss

@@ -0,0 +1,94 @@
+#!r6rs
+
+(library (tests r6rs io simple)
+  (export run-io-simple-tests)
+  (import (rnrs)
+          (tests r6rs test))
+
+  (define (run-io-simple-tests)
+
+    (test/unspec
+     (when (file-exists? "io-tmp2")
+       (delete-file "io-tmp2")))
+
+    (test/values (call-with-output-file "io-tmp2"
+                   (lambda (p)
+                     (test (output-port? p) #t)
+                     (test (binary-port? p) #f)
+                     (test (textual-port? p) #t)
+                     (test/unspec (write-char #\q p))
+                     (test/unspec (newline p))
+                     (test/unspec (display "more" p))
+                     (test/unspec (write "last" p))
+                     (values 3 4)))
+                 3 4)
+
+    (test/values (call-with-input-file "io-tmp2"
+                   (lambda (p)
+                     (test (input-port? p) #t)
+                     (test (binary-port? p) #f)
+                     (test (textual-port? p) #t)
+                     (test (peek-char p) #\q)
+                     (test (read-char p) #\q)
+                     (test (read-char p) #\newline)
+                     (test (read-char p) #\m)
+                     (test (read-char p) #\o)
+                     (test (peek-char p) #\r)
+                     (test (read-char p) #\r)
+                     (test (read-char p) #\e)
+                     (test (read p) "last")
+                     (test (read p) (eof-object))
+                     (values 7 8 9)))
+                 7 8 9)
+
+    (test/unspec (delete-file "io-tmp2"))
+
+    (let ([p (open-output-file "io-tmp2")])
+      (test (output-port? p) #t)
+      (test (binary-port? p) #f)
+      (test (textual-port? p) #t)
+      (test/unspec (write-char #\! p))
+      (test/unspec (close-output-port p)))
+
+    (let ([p (open-input-file "io-tmp2")])
+      (test (input-port? p) #t)
+      (test (binary-port? p) #f)
+      (test (textual-port? p) #t)
+      (test (read-char p) #\!)
+      (test/unspec (close-input-port p)))
+
+    (test/unspec (delete-file "io-tmp2"))
+
+    (test/values (with-output-to-file "io-tmp2"
+                   (lambda ()
+                     (test/unspec (write-char #\z))
+                     (test/unspec (newline))
+                     (test/unspec (display "a"))
+                     (test/unspec (write "a"))
+                     (values 30 40)))
+                 30 40)
+
+    (test/values (with-input-from-file "io-tmp2"
+                   (lambda ()
+                     (test (peek-char) #\z)
+                     (test (read-char) #\z)
+                     (test (read) 'a)
+                     (test (read) "a")
+                     (test (read) (eof-object))
+                     (values 70 80 90)))
+                 70 80 90)
+    
+    (test (input-port? (current-input-port)) #t)
+    (test (binary-port? (current-input-port)) #f)
+    (test (textual-port? (current-input-port)) #t)
+
+    (test (output-port? (current-output-port)) #t)
+    (test (binary-port? (current-output-port)) #f)
+    (test (textual-port? (current-output-port)) #t)
+
+    (test (output-port? (current-error-port)) #t)
+    (test (binary-port? (current-error-port)) #f)
+    (test (textual-port? (current-error-port)) #t)
+
+    ;;
+    ))

collects/tests/r6rs/run.ss

@@ -14,6 +14,7 @@
         (tests r6rs exceptions)
         (tests r6rs conditions)
         (tests r6rs io ports)
+        (tests r6rs io simple)
         (tests r6rs programs)
         (tests r6rs arithmetic fixnums)
         (tests r6rs arithmetic flonums)
@@ -39,6 +40,7 @@
 (run-exceptions-tests)
 (run-conditions-tests)
 (run-io-ports-tests)
+(run-io-simple-tests)
 (run-programs-tests)
 (run-arithmetic-fixnums-tests)
 (run-arithmetic-flonums-tests)