core: Add continuations, call/cc.
[mes.git] / module / mes / display.mes
1 ;;; -*-scheme-*-
2
3 ;;; Mes --- Maxwell Equations of Software
4 ;;; Copyright © 2016 Jan Nieuwenhuizen <janneke@gnu.org>
5 ;;;
6 ;;; This file is part of Mes.
7 ;;;
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.
12 ;;;
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.
17 ;;;
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/>.
20
21 ;;; Commentary:
22
23 ;;; Code:
24
25 (mes-use-module (mes scm))
26 ;;(mes-use-module (mes srfi srfi-1))
27
28 (define (srfi-1:member x lst eq)
29   (if (null? lst) #f
30       (if (eq x (car lst)) lst
31           (srfi-1:member x (cdr lst) eq))))
32
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)))))
36
37 (define (next-xassq2 x a)
38   (and=> (srfi-1:member x a (lambda (x e) (eq? x (cdr e))))
39          (lambda (a)
40            (and=> (srfi-1:member x (cdr a) (lambda (x e) (eq? x (cdr e))))
41                   (lambda (a) (xassq x (cdr a)))))))
42
43 (define (display x . rest)
44   (let* ((port (if (null? rest) (current-output-port) (car rest)))
45          (write? (and (pair? rest) (pair? (cdr rest)))))
46
47     (define-macro (cut f slot n1)
48       `(lambda (slot) (,f slot ,n1)))
49
50     (define-macro (cut2 f slot n1 n2)
51       `(lambda (slot) (,f slot ,n1 ,n2)))
52
53     (define (display-char x write? port)
54       (cond ((and write? (or (eq? x #\") (eq? x #\\)))
55              (write-char #\\ port)
56              (write-char x port))
57             ((and write? (eq? x #\newline))
58              (write-char #\\ port)
59              (write-char #\n port))
60             (#t (write-char x port))))
61
62     (define (d x cont? sep)
63       (for-each (cut write-char <> port) (string->list sep))
64       (cond
65        ((char? x)
66         (if (not write?) (write-char x port)
67             (let ((name (and=> (assq x '((#\*eof* . *eof*)
68                                          (#\nul . nul)
69                                          (#\alarm . alarm)
70                                          (#\backspace . backspace)
71                                          (#\tab . tab)
72                                          (#\newline . newline)
73                                          (#\vtab . vtab)
74                                          (#\page . page)
75                                          (#\return . return)
76                                          (#\space . space)))
77                                cdr)))
78               (write-char #\# port)
79               (write-char #\\ port)
80               (if name (display name)
81                   (write-char x port)))))
82        ((closure? x)
83         (display "#<procedure " port)
84         (let ((name (and=> (next-xassq2 x (current-module)) car)))
85           (display name port))
86         (display " " port)
87         (display (cadr (core:cdr x)) port)
88         (display ">" port))
89        ((continuation? x)
90         (display "#<continuation " port)
91         (display (core:car x) port)
92         (display ">" port))
93        ((macro? x)
94         (display "#<macro " port)
95         (display (core:cdr x) port)
96         (display ">" port))
97        ((number? x) (display (number->string x) port))
98        ((pair? x)
99         (if (not cont?) (write-char #\( port))
100         (cond ((eq? (car x) '*circular*)
101                (display "(*circ* . #-1#)" port))
102               ((eq? (car x) '*closure*)
103                (display "(*closure* . #-1#)" port))
104               (#t
105                (display (car x) port write?)
106                (if (pair? (cdr x)) (d (cdr x) #t " ")
107                    (if (and (cdr x) (not (null? (cdr x))))
108                        (begin
109                          (display " . " port)
110                          (display (cdr x) port write?))))
111                (if (not cont?) (write-char #\) port)))))
112        ((or (keyword? x) (special? x) (string? x) (symbol? x))
113         (if (and (string? x) write?) (write-char #\" port))
114         (if (keyword? x) (display "#:" port))
115         (for-each (cut2 display-char <> write? port) (string->list x))
116         (if (and (string? x) write?) (write-char #\" port)))
117        ((vector? x)
118         (display "#(" port)
119         (for-each (lambda (i)
120                     (let ((x (vector-ref x i)))
121                       (if (vector? x)
122                           (begin
123                             (display (if (= i 0) "" " ") port)
124                             (display "#(...)" port))
125                           (d x #f (if (= i 0) "" " ")))))
126                   (iota (vector-length x)))
127         (display ")" port))
128        ((function? x)
129         (display "#<procedure " port)
130         (display (core:car x) port)
131         (display " " port)
132         (display
133          (case (core:arity x)
134            ((-1) "_")
135            ((0) "()")
136            ((1) "(_)")
137            ((2) "(_ _)")
138            ((3) "(_ _ _)"))
139          port)
140         (display ">" port))
141        ((broken-heart? x)
142         (display "<3" port))
143        (#t
144         (display "TODO type=") (display (cell:type-name x)) (newline)))
145       *unspecified*)
146     (d x #f "")))
147
148 (define (write-char x . rest)
149   (apply write-byte (cons (char->integer x) rest)))
150
151 (define (write x . rest)
152   (let ((port (if (null? rest) (current-output-port) (car rest))))
153     (display x port #t)))
154
155 (define (newline . rest)
156   (apply display (cons "\n" rest)))
157
158 (define (with-output-to-string thunk)
159   (define save-write-byte write-byte)
160   (let ((stdout '()))
161     (set! write-byte
162           (lambda (x . rest)
163             (let ((out? (or (null? rest) (eq? (car rest) (current-output-port)))))
164               (if (not out?) (apply save-write-byte (cons x rest))
165                   (begin
166                     (set! stdout (append stdout (list (integer->char x))))
167                     x)))))
168     (thunk)
169     (let ((r (apply string stdout)))
170       (set! write-byte save-write-byte)
171       r)))
172
173 (define (simple-format destination format . rest)
174   (let ((port (if (boolean? destination) (current-output-port) destination))
175         (lst (string->list format)))
176     (define (simple-format lst args)
177       (if (pair? lst)
178           (let ((c (car lst)))
179             (if (not (eq? c #\~)) (begin (write-char (car lst) port)
180                                          (simple-format (cdr lst) args))
181                 (let ((c (cadr lst)))
182                   (case c
183                     ((#\a) (display (car args) port))
184                     ((#\s) (write (car args) port)))
185                   (simple-format (cddr lst) (cdr args)))))))
186     
187     (if destination (simple-format lst rest)
188         (with-output-to-string
189           (lambda () (simple-format lst rest))))))
190 (define format simple-format)