andrius
/
mes
1
0
Fork 0
Code Issues Pull Requests Packages Projects Releases Wiki Activity

mes: Remove broken copy of simple-format. 

* mes/module/mes/simple-format.mes: New file.
* mes/module/mes/guile.mes: Use it.
(with-output-to-string, simple-format): Remove broken copies.
* mes/module/mes/display.mes (with-output-to-string, simple-format,
format): Remove.
This commit is contained in:
Jan Nieuwenhuizen 2019-07-19 15:36:36 +02:00
parent 4b5d5017c4
commit 81849edb86
No known key found for this signature in database
GPG Key ID: F3C1A0D9C1D65273
4 changed files with 67 additions and 77 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

40
mes/module/mes/display.mes
View File

@ -1,7 +1,7 @@
;;; -*-scheme-*-
;;; GNU Mes --- Maxwell Equations of Software
;;; Copyright © 2016,2017,2018 Jan (janneke) Nieuwenhuizen <janneke@gnu.org>
;;; Copyright © 2016,2017,2018,2019 Jan (janneke) Nieuwenhuizen <janneke@gnu.org>
;;;
;;; This file is part of GNU Mes.
;;;
@ -199,41 +199,3 @@
(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)))
(define (simple-format destination format . rest)
(let ((port (if (boolean? destination) (current-output-port) destination))
(lst (string->list format)))
(define (simple-format lst args)
(if (pair? lst)
(let ((c (car lst)))
(if (not (eq? c #\~)) (begin (write-char (car lst) port)
(simple-format (cdr lst) args))
(let ((c (cadr lst)))
(case c
((#\A) (display (car args) port))
((#\a) (display (car args) port))
((#\S) (write (car args) port))
((#\s) (write (car args) port))
(else (display (car args) port)))
(simple-format (cddr lst) (cdr args)))))))
(if destination (simple-format lst rest)
(with-output-to-string
(lambda () (simple-format lst rest))))))
(define format simple-format)

40
mes/module/mes/guile.mes
View File

@ -1,7 +1,7 @@
;;; -*-scheme-*-
;;; GNU Mes --- Maxwell Equations of Software
;;; Copyright © 2016,2017,2018 Jan (janneke) Nieuwenhuizen <janneke@gnu.org>
;;; Copyright © 2016,2017,2018,2019 Jan (janneke) Nieuwenhuizen <janneke@gnu.org>
;;;
;;; This file is part of GNU Mes.
;;;
@ -30,6 +30,7 @@
(mes-use-module (mes posix))
(mes-use-module (srfi srfi-16))
(mes-use-module (mes display))
(mes-use-module (mes simple-format))
(define (drain-input port) (read-string))
@ -117,42 +118,5 @@
(if (string-null? dir) "."
dir))))))
;; FIXME: c&p from display
(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)))
;; FIXME: c&p from display
(define (simple-format destination format . rest)
(let ((port (if (boolean? destination) (current-output-port) destination))
(lst (string->list format)))
(define (simple-format lst args)
(if (pair? lst)
(let ((c (car lst)))
(if (not (eq? c #\~)) (begin (write-char (car lst) port)
(simple-format (cdr lst) args))
(let ((c (cadr lst)))
(case c
((#\a) (display (car args) port))
((#\s) (write (car args) port)))
(simple-format (cddr lst) (cdr args)))))))
(if destination (simple-format lst rest)
(with-output-to-string
(lambda () (simple-format lst rest))))))
(define format simple-format)
(define (file-exists? o)
(access? o R_OK))

63
mes/module/mes/simple-format.mes Normal file
View File

@ -0,0 +1,63 @@
;;; -*-scheme-*-
;;; GNU Mes --- Maxwell Equations of Software
;;; Copyright © 2016,2017,2018,2019 Jan (janneke) Nieuwenhuizen <janneke@gnu.org>
;;;
;;; This file is part of GNU Mes.
;;;
;;; GNU 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.
;;;
;;; GNU 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 GNU Mes. If not, see <http://www.gnu.org/licenses/>.
;;; Commentary:
;;; Code:
(mes-use-module (mes display))
(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)))
(define (simple-format destination format . rest)
(let ((port (if (boolean? destination) (current-output-port) destination))
(lst (string->list format)))
(define (simple-format lst args)
(if (pair? lst)
(let ((c (car lst)))
(if (not (eq? c #\~)) (begin (write-char (car lst) port)
(simple-format (cdr lst) args))
(let ((c (cadr lst)))
(case c
((#\A) (display (car args) port))
((#\a) (display (car args) port))
((#\S) (write (car args) port))
((#\s) (write (car args) port))
(else (display (car args) port)))
(simple-format (cddr lst) (cdr args)))))))
(if destination (simple-format lst rest)
(with-output-to-string
(lambda () (simple-format lst rest))))))
(define format simple-format)

1
tests/display.test
View File

@ -27,6 +27,7 @@ exec ${MES-src/mes} --no-auto-compile -L ${0%/*} -L module -C module -e '(tests
#:use-module (mes test))
(mes-use-module (mes display))
(mes-use-module (mes guile))
(mes-use-module (mes test))
(pass-if "first dummy" #t)