;;; -*-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)
projects / mes.git / blobdiff