mes: #<eof> is not a character.
[mes.git] / module / mes / display.mes
index 0daf1febe53f4b0bad5da7354ce72a0770dd890b..e6831658396590bb5a4d11fd32172a090078b41b 100644 (file)
@@ -1,7 +1,7 @@
 ;;; -*-scheme-*-
 
 ;;; Mes --- Maxwell Equations of Software
-;;; Copyright © 2016 Jan Nieuwenhuizen <janneke@gnu.org>
+;;; Copyright © 2016,2017,2018 Jan Nieuwenhuizen <janneke@gnu.org>
 ;;;
 ;;; This file is part of Mes.
 ;;;
 ;;; Code:
 
 (mes-use-module (mes scm))
+;;(mes-use-module (mes srfi srfi-1))
 
-(define (newline . rest)
-  (apply display (cons "\n" rest)))
+(define (srfi-1:member x lst eq)
+  (if (null? lst) #f
+      (if (eq x (car lst)) lst
+          (srfi-1:member x (cdr lst) eq))))
+
+(define (next-xassq x a)
+  (and=> (srfi-1:member x a (lambda (x e) (eq? x (cdr e))))
+         (lambda (a) (xassq x (cdr a)))))
+
+(define (next-xassq2 x a)
+  (and=> (srfi-1:member x a (lambda (x e) (eq? x (cdr e))))
+         (lambda (a)
+           (and=> (srfi-1:member x (cdr a) (lambda (x e) (eq? x (cdr e))))
+                  (lambda (a) (xassq x (cdr a)))))))
 
 (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)))
+         (write? (and (pair? rest) (pair? (cdr rest)) (cadr rest))))
+
+    (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 port write?)
+      (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
+       ((eof-object? x)
+        (display "#<eof>" port))
        ((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 '((#\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 port)
+                  (write-char x port)))))
        ((closure? x)
-        (display "<#procedure #f " port)
+        (display "#<procedure " port)
+        (let ((name (and=> (next-xassq2 x (current-module)) car)))
+          (display name port))
+        (display " " port)
         (display (cadr (core:cdr x)) port)
         (display ">" port))
+       ((continuation? x)
+        (display "#<continuation " port)
+        (display (core:car 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))
+       ((number? x)
+        (display (number->string x) port))
        ((pair? x)
         (if (not cont?) (write-char #\( port))
         (cond ((eq? (car x) '*circular*)
-               (display "(*circ* . #-1#)" port))
+               (display "*circ* . #-1#)" port))
               ((eq? (car x) '*closure*)
-               (display "(*closure* . #-1#)" port))
+               (display "*closure* . #-1#)" port))
               (#t
                (display (car x) port write?)
                (if (pair? (cdr x)) (d (cdr x) #t " ")
                    (if (and (cdr x) (not (null? (cdr x))))
                        (begin
                          (display " . " port)
-                         (display (cdr x) port write?))))
-               (if (not cont?) (write-char #\) port)))))
+                         (display (cdr x) port write?))))))
+        (if (not cont?) (write-char #\) port)))
        ((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 <> port write?) (string->list x))
         (if (and (string? x) write?) (write-char #\" port)))
        ((vector? x)
         (display "#(" port)
                   (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)
         (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)))
+
+(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)