3 ;;; Mes --- Maxwell Equations of Software
4 ;;; Copyright © 2016,2017,2018 Jan (janneke) Nieuwenhuizen <janneke@gnu.org>
6 ;;; This file is part of Mes.
8 ;;; Mes is free software; you can redistribute it and/or modify it
9 ;;; under the terms of the GNU General Public License as published by
10 ;;; the Free Software Foundation; either version 3 of the License, or (at
11 ;;; your option) any later version.
13 ;;; Mes is distributed in the hope that it will be useful, but
14 ;;; WITHOUT ANY WARRANTY; without even the implied warranty of
15 ;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
16 ;;; GNU General Public License for more details.
18 ;;; You should have received a copy of the GNU General Public License
19 ;;; along with Mes. If not, see <http://www.gnu.org/licenses/>.
25 (mes-use-module (mes scm))
26 ;;(mes-use-module (mes srfi srfi-1))
28 (define (srfi-1:member x lst eq)
30 (if (eq x (car lst)) lst
31 (srfi-1:member x (cdr lst) eq))))
33 (define (next-xassq x a)
34 (and=> (srfi-1:member x a (lambda (x e) (eq? x (cdr e))))
35 (lambda (a) (xassq x (cdr a)))))
37 (define (next-xassq2 x a)
38 (and=> (srfi-1:member x a (lambda (x e) (eq? x (cdr e))))
40 (and=> (srfi-1:member x (cdr a) (lambda (x e) (eq? x (cdr e))))
41 (lambda (a) (xassq x (cdr a)))))))
43 (define-macro (display-cut f slot n1)
44 `(lambda (slot) (,f slot ,n1)))
46 (define-macro (display-cut2 f slot n1 n2)
47 `(lambda (slot) (,f slot ,n1 ,n2)))
49 (define (display x . rest)
50 (let* ((port (if (null? rest) (current-output-port) (car rest)))
51 (write? (and (pair? rest) (pair? (cdr rest)) (cadr rest))))
53 (define (display-char x port write?)
54 (cond ((and write? (or (eq? x #\") (eq? x #\\)))
57 ((and write? (eq? x #\newline))
59 (write-char #\n port))
60 (#t (write-char x port))))
62 (define (d x cont? sep)
63 (for-each (display-cut write-char <> port) (string->list sep))
66 (display "#<eof>" port))
68 (if (not write?) (write-char x port)
69 (let ((name (and=> (assq x '((#\nul . nul)
71 (#\backspace . backspace)
81 (if name (display name port)
82 (write-char x port)))))
84 (display "#<procedure " port)
85 (let ((name (and=> (next-xassq2 x (current-module)) car)))
88 (display (cadr (core:cdr x)) port)
91 (display "#<continuation " port)
92 (display (core:car x) port)
95 (display "#<macro " port)
96 (display (core:cdr x) port)
99 (display "#<variable " port)
100 (display (car (core:car x)) port)
103 (display (number->string x) port))
105 (if (not cont?) (write-char #\( port))
106 (cond ((eq? (car x) '*circular*)
107 (display "*circ* . #-1#)" port))
108 ((eq? (car x) '*closure*)
109 (display "*closure* . #-1#)" port))
111 (display (car x) port write?)
112 (if (pair? (cdr x)) (d (cdr x) #t " ")
113 (if (and (cdr x) (not (null? (cdr x))))
116 (display (cdr x) port write?))))))
117 (if (not cont?) (write-char #\) port)))
118 ((or (keyword? x) (special? x) (string? x) (symbol? x))
119 (if (and (string? x) write?) (write-char #\" port))
120 (if (keyword? x) (display "#:" port))
121 (for-each (display-cut2 display-char <> port write?) (string->list x))
122 (if (and (string? x) write?) (write-char #\" port)))
125 (for-each (lambda (i)
126 (let ((x (vector-ref x i)))
129 (display (if (= i 0) "" " ") port)
130 (display "#(...)" port))
131 (d x #f (if (= i 0) "" " ")))))
132 (iota (vector-length x)))
135 (display "#<procedure " port)
136 (display (core:car x) port)
150 (display "TODO type=") (display (cell:type-name x)) (newline)))
154 (define (write-char x . rest)
155 (apply write-byte (cons (char->integer x) rest)))
157 (define (write x . rest)
158 (let ((port (if (null? rest) (current-output-port) (car rest))))
159 (display x port #t)))
161 (define (newline . rest)
162 (apply display (cons "\n" rest)))
164 (define (with-output-to-string thunk)
165 (define save-write-byte write-byte)
169 (let ((out? (or (null? rest) (eq? (car rest) (current-output-port)))))
170 (if (not out?) (apply save-write-byte (cons x rest))
172 (set! stdout (append stdout (list (integer->char x))))
175 (let ((r (apply string stdout)))
176 (set! write-byte save-write-byte)
179 (define (simple-format destination format . rest)
180 (let ((port (if (boolean? destination) (current-output-port) destination))
181 (lst (string->list format)))
182 (define (simple-format lst args)
185 (if (not (eq? c #\~)) (begin (write-char (car lst) port)
186 (simple-format (cdr lst) args))
187 (let ((c (cadr lst)))
189 ((#\A) (display (car args) port))
190 ((#\a) (display (car args) port))
191 ((#\S) (write (car args) port))
192 ((#\s) (write (car args) port))
193 (else (display (car args) port)))
194 (simple-format (cddr lst) (cdr args)))))))
196 (if destination (simple-format lst rest)
197 (with-output-to-string
198 (lambda () (simple-format lst rest))))))
200 (define format simple-format)