diff --git a/GNUmakefile b/GNUmakefile index df4bd28d..12a5dca6 100644 --- a/GNUmakefile +++ b/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\ diff --git a/mes.c b/mes.c index dd73f2d4..74a79a5e 100644 --- a/mes.c +++ b/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); diff --git a/module/mes/display.mes b/module/mes/display.mes index 0daf1feb..ee5e65b4 100644 --- a/module/mes/display.mes +++ b/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) - `(lambda (slot) (,f slot ,port))) + + (define-macro (cut f slot n1) + `(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) - (write-char #\\ port) - (let ((name (and=> (assq x '((#\*eof* . *eof*) - (#\nul . nul) - (#\alarm . alarm) - (#\backspace . backspace) - (#\tab . tab) - (#\newline . newline) - (#\vtab . vtab) - (#\page . page) - (#\return . return) - (#\space . space))) - cdr))) - (if name (display name) - (write-char x port)))) + (if (not write?) (write-char x port) + (let ((name (and=> (assq x '((#\*eof* . *eof*) + (#\nul . nul) + (#\alarm . alarm) + (#\backspace . backspace) + (#\tab . tab) + (#\newline . newline) + (#\vtab . vtab) + (#\page . page) + (#\return . return) + (#\space . space))) + cdr))) + (write-char #\# port) + (write-char #\\ port) + (if name (display name) + (write-char x port))))) ((closure? x) - (display "<#procedure #f " port) + (display "#" port)) ((macro? x) - (display "<#macro " 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 "#" 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))) diff --git a/tests/display.test b/tests/display.test new file mode 100755 index 00000000..2a1a352d --- /dev/null +++ b/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 +;;; +;;; 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 . + +(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" + "#" + (with-output-to-string (lambda () (display (lambda (a b c) #t)))))) + +(if (or mes? guile-2?) + (pass-if-equal "display builtin thunk" + "#" + (with-output-to-string (lambda () (display gc))))) + +(if (or mes? guile-2?) + (pass-if-equal "display builtin procedure" + "#" + (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) diff --git a/tests/read.test b/tests/read.test index 38c6e16d..8d60925e 100755 --- a/tests/read.test +++ b/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)