;;; -*-scheme-*-

;;; GNU Mes --- Maxwell Equations of Software
;;; Copyright © 2016,2017,2018,2019,2020 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:

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