artemist/mes
1
0
Fork 0
Code Issues Pull requests Packages Projects Releases Wiki Activity

Add write, add display test, some fixes.

Browse source 
* 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.
This commit is contained in:
Jan Nieuwenhuizen 2016-12-24 11:10:11 +01:00
parent 16e3caafcd
commit d81ce91ff7
5 changed files with 158 additions and 34 deletions
Show stats Download patch file Download diff file Expand all files Collapse all files

1
GNUmakefile
View file

@ -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\

2
mes.c
View file

@ -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);

93
module/mes/display.mes
View file

@ -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 "#<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)")
((2) "(x y)")
((3) "(x y z)"))
((1) "(_)")
((2) "(_ _)")
((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)))

91
tests/display.test Executable file
View file

@ -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)

5
tests/read.test
View file

@ -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)