Add write, add display test, some fixes.

* mes.c (write_byte): Rename from write_char.
* module/mes/display.mes (display): Fixes for write: char, closure, procedure.
  (write-char, write, with-output-to-string): New functions.
* tests/read.test: Include base-0 to see some output.
* tests/display.test: New file.
* GNUmakefile (TESTS): Add it.

GNUmakefile

@@ -53,6 +53,7 @@ TESTS:=\
  tests/let.test\
  tests/vector.test\
  tests/scm.test\
+ tests/display.test\
  tests/cwv.test\
  tests/srfi-1.test\
  tests/srfi-13.test\

mes.c

@@ -838,7 +838,7 @@ unread_byte (SCM i)
 }
 
 SCM
-write_char (SCM x) ///((arity . n))
+write_byte (SCM x) ///((arity . n))
 {
   SCM c = car (x);
   SCM p = cdr (x);

module/mes/display.mes

@@ -24,41 +24,51 @@
 
 (mes-use-module (mes scm))
 
-(define (newline . rest)
-  (apply display (cons "\n" rest)))
-
 (define (display x . rest)
   (let* ((port (if (null? rest) (current-output-port) (car rest)))
          (write? (and (pair? rest) (pair? (cdr rest)))))
-    
+
-    (define-macro (cut f slot port)
+    (define-macro (cut f slot n1)
-      `(lambda (slot) (,f slot ,port)))
+      `(lambda (slot) (,f slot ,n1)))
+
+    (define-macro (cut2 f slot n1 n2)
+      `(lambda (slot) (,f slot ,n1 ,n2)))
+
+    (define (display-char x write? port)
+      (cond ((and write? (or (eq? x #\") (eq? x #\\)))
+             (write-char #\\ port)
+             (write-char x port))
+            ((and write? (eq? x #\newline))
+             (write-char #\\ port)
+             (write-char #\n port))
+            (#t (write-char x port))))
 
     (define (d x cont? sep)
       (for-each (cut write-char <> port) (string->list sep))
       (cond
        ((char? x)
-        (write-char #\# port)
+        (if (not write?) (write-char x port)
-        (write-char #\\ port)
+            (let ((name (and=> (assq x '((#\*eof* . *eof*)
-        (let ((name (and=> (assq x '((#\*eof* . *eof*)
+                                         (#\nul . nul)
-                                     (#\nul . nul)
+                                         (#\alarm . alarm)
-                                     (#\alarm . alarm)
+                                         (#\backspace . backspace)
-                                     (#\backspace . backspace)
+                                         (#\tab . tab)
-                                     (#\tab . tab)
+                                         (#\newline . newline)
-                                     (#\newline . newline)
+                                         (#\vtab . vtab)
-                                     (#\vtab . vtab)
+                                         (#\page . page)
-                                     (#\page . page)
+                                         (#\return . return)
-                                     (#\return . return)
+                                         (#\space . space)))
-                                     (#\space . space)))
+                               cdr)))
-                           cdr)))
+              (write-char #\# port)
-          (if name (display name)
+              (write-char #\\ port)
-              (write-char x port))))
+              (if name (display name)
+                  (write-char x port)))))
        ((closure? x)
-        (display "<#procedure #f " port)
+        (display "#<procedure #f " port)
         (display (cadr (core:cdr x)) port)
         (display ">" port))
        ((macro? x)
-        (display "<#macro " port)
+        (display "#<macro " port)
         (display (core:cdr x) port)
         (display ">" port))
        ((number? x) (display (number->string x) port))
@@ -79,7 +89,7 @@
        ((or (keyword? x) (special? x) (string? x) (symbol? x))
         (if (and (string? x) write?) (write-char #\" port))
         (if (keyword? x) (display "#:" port))
-        (for-each (cut write-char <> port) (string->list x))
+        (for-each (cut2 display-char <> write? port) (string->list x))
         (if (and (string? x) write?) (write-char #\" port)))
        ((vector? x)
         (display "#(" port)
@@ -93,16 +103,16 @@
                   (iota (vector-length x)))
         (display ")" port))
        ((function? x)
-        (display "<#procedure " port)
+        (display "#<procedure " port)
         (display (core:car x) port)
         (display " " port)
         (display
          (case (core:arity x)
-           ((-1) "(. x)")
+           ((-1) "_")
            ((0) "()")
-           ((1) "(x)")
+           ((1) "(_)")
-           ((2) "(x y)")
+           ((2) "(_ _)")
-           ((3) "(x y z)"))
+           ((3) "(_ _ _)"))
          port)
         (display ">" port))
        ((broken-heart? x)
@@ -111,3 +121,28 @@
         (display "TODO type=") (display (cell:type-name x)) (newline)))
       *unspecified*)
     (d x #f "")))
+
+(define (write-char x . rest)
+  (apply write-byte (cons (char->integer x) rest)))
+
+(define (write x . rest)
+  (let ((port (if (null? rest) (current-output-port) (car rest))))
+    (display x port #t)))
+
+(define (newline . rest)
+  (apply display (cons "\n" rest)))
+
+(define (with-output-to-string thunk)
+  (define save-write-byte write-byte)
+  (let ((stdout '()))
+    (set! write-byte
+          (lambda (x . rest)
+            (let ((out? (or (null? rest) (eq? (car rest) (current-output-port)))))
+              (if (not out?) (apply save-write-byte (cons x rest))
+                  (begin
+                    (set! stdout (append stdout (list (integer->char x))))
+                    x)))))
+    (thunk)
+    (let ((r (apply string stdout)))
+      (set! write-byte save-write-byte)
+      r)))

tests/display.test

@@ -0,0 +1,91 @@
+#! /bin/sh
+# -*-scheme-*-
+echo ' ()' | cat $(dirname $0)/../module/mes/base-0.mes $0 /dev/stdin | $(dirname $0)/../scripts/mes $MES_FLAGS "$@"
+#paredit:||
+exit $?
+!#
+
+;;; -*-scheme-*-
+
+;;; Mes --- Maxwell Equations of Software
+;;; Copyright © 2016 Jan Nieuwenhuizen <janneke@gnu.org>
+;;;
+;;; This file is part of Mes.
+;;;
+;;; Mes is free software; you can redistribute it and/or modify it
+;;; under the terms of the GNU General Public License as published by
+;;; the Free Software Foundation; either version 3 of the License, or (at
+;;; your option) any later version.
+;;;
+;;; Mes 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 General Public License for more details.
+;;;
+;;; You should have received a copy of the GNU General Public License
+;;; along with Mes.  If not, see <http://www.gnu.org/licenses/>.
+
+(mes-use-module (mes display))
+(mes-use-module (mes test))
+
+(pass-if "first dummy" #t)
+(pass-if-not "second dummy" #f)
+
+(pass-if-equal "display"
+    "0"
+  (with-output-to-string (lambda () (display 0))))
+
+(pass-if-equal "display"
+    "A"
+  (with-output-to-string (lambda () (display #\A))))
+
+(pass-if-equal "write"
+    "#\\A"
+  (with-output-to-string (lambda () (write #\A))))
+
+(if (or mes? guile-2?)
+    (pass-if-equal "write alarm"
+        "#\\alarm"
+      (with-output-to-string (lambda () (write #\alarm)))))
+
+(pass-if-equal "write string"
+    "\"BOO\\n\""
+  (with-output-to-string (lambda () (write "BOO\n"))))
+
+(pass-if-equal "display string"
+    "BOO\n"
+  (with-output-to-string (lambda () (display "BOO\n"))))
+
+(pass-if-equal "display symbol"
+    "Bah"
+  (with-output-to-string (lambda () (display 'Bah))))
+
+(pass-if-equal "display number"
+    "486"
+  (with-output-to-string (lambda () (display 486))))
+
+(if (or mes? guile-1.8?)
+    (pass-if-equal "display closure"
+        "#<procedure #f (a b c)>"
+      (with-output-to-string (lambda () (display (lambda (a b c) #t))))))
+
+(if (or mes? guile-2?)
+    (pass-if-equal "display builtin thunk"
+        "#<procedure gc ()>"
+      (with-output-to-string (lambda () (display gc)))))
+
+(if (or mes? guile-2?)
+    (pass-if-equal "display builtin procedure"
+        "#<procedure acons (_ _ _)>"
+      (with-output-to-string (lambda () (display acons)))))
+
+(pass-if-equal "s-exp"
+    "(lambda (a b . c) #t)"
+  (with-output-to-string (lambda () (display '(lambda (a b . c) #t)))))
+
+(if mes?
+    (pass-if-equal "vector nest"
+        "#(0 #(...) 2 3)"
+      (with-output-to-string (lambda () (display #(0 #(1) 2 3))))))
+
+(result 'report)

tests/read.test

@@ -1,14 +1,11 @@
 #! /bin/sh
 # -*-scheme-*-
 # ***REMOVE THIS BLOCK COMMENT INITIALLY***
-echo ' ()' | cat $0 /dev/stdin | $(dirname $0)/../scripts/mes $MES_FLAGS "$@"
+echo ' ()' | cat $(dirname $0)/../module/mes/base-0.mes $0 /dev/stdin | $(dirname $0)/../scripts/mes $MES_FLAGS "$@"
 #paredit:||
 exit $?
 !#
 
-;; FIXME
-(gc)
-
 0
 cons
 (cons 0 1)