From 55cb24023bfe3211e463e9d26bfdfe7f3211d14d Mon Sep 17 00:00:00 2001 From: Lassi Kortela Date: Sun, 25 Aug 2019 22:07:38 +0300 Subject: [PATCH] Make Lisp core use xwrite/xdisplay/xnewline --- scheme-core/aliases.scm | 13 +++--- scheme-core/compiler.scm | 50 ++++++++++++++--------- scheme-core/dump.scm | 12 +++--- scheme-core/mkboot0.scm | 2 +- scheme-core/system.scm | 87 +++++++++++++++++++++++----------------- 5 files changed, 94 insertions(+), 70 deletions(-) diff --git a/scheme-core/aliases.scm b/scheme-core/aliases.scm index 0f175d1..8a80817 100644 --- a/scheme-core/aliases.scm +++ b/scheme-core/aliases.scm @@ -179,18 +179,17 @@ (define (delete-file name) (void)) ; TODO (define (display x (port *output-stream*)) - (with-output-to port (princ x)) - #t) + (xdisplay x port)) (define assertion-violation (lambda args - (display 'assertion-violation) - (newline) - (display args) - (newline) + (xdisplay 'assertion-violation) + (xnewline) + (xdisplay args) + (xnewline) (car #f))) -(define pretty-print write) +(define pretty-print xwrite) (define (memp proc ls) (cond ((null? ls) #f) diff --git a/scheme-core/compiler.scm b/scheme-core/compiler.scm index de2d45d..ea9d5e1 100644 --- a/scheme-core/compiler.scm +++ b/scheme-core/compiler.scm @@ -656,18 +656,20 @@ (define (disassemble f . lev?) (if (null? lev?) (begin (disassemble f 0) - (newline) + (xnewline) (return #t))) (let ((lev (car lev?)) (code (function:code f)) (vals (function:vals f))) (define (print-val v) (if (and (function? v) (not (builtin? v))) - (begin (princ "\n") + (begin (xdisplay "\n") (disassemble v (+ lev 1))) - (print v))) - (dotimes (xx lev) (princ " ")) - (princ "maxstack " (ref-int32-LE code 0) "\n") + (xwrite v))) + (dotimes (xx lev) (xdisplay " ")) + (xdisplay "maxstack ") + (xdisplay (ref-int32-LE code 0)) + (xnewline) (let ((i 4) (N (length code))) (while (< i N) @@ -676,10 +678,12 @@ (or z (and (eq? v (aref code i)) k))) #f Instructions))) - (if (> i 4) (newline)) - (dotimes (xx lev) (princ " ")) - (princ (hex5 (- i 4)) ": " - (string inst) " ") + (if (> i 4) (xnewline)) + (dotimes (xx lev) (xdisplay " ")) + (xdisplay (hex5 (- i 4))) + (xdisplay ": ") + (xdisplay (string inst)) + (xdisplay " ") (set! i (+ i 1)) (case inst ((loadv.l loadg.l setg.l) @@ -692,40 +696,46 @@ ((loada seta call tcall list + - * / vector argc vargc loadi8 apply tapply) - (princ (number->string (aref code i))) + (xdisplay (number->string (aref code i))) (set! i (+ i 1))) ((loada.l seta.l largc lvargc call.l tcall.l) - (princ (number->string (ref-int32-LE code i))) + (xdisplay (number->string (ref-int32-LE code i))) (set! i (+ i 4))) ((loadc setc) - (princ (number->string (aref code i)) " ") + (xdisplay (number->string (aref code i))) + (xdisplay " ") (set! i (+ i 1)) - (princ (number->string (aref code i))) + (xdisplay (number->string (aref code i))) (set! i (+ i 1))) ((loadc.l setc.l optargs keyargs) - (princ (number->string (ref-int32-LE code i)) " ") + (xdisplay (number->string (ref-int32-LE code i))) + (xdisplay " ") (set! i (+ i 4)) - (princ (number->string (ref-int32-LE code i))) + (xdisplay (number->string (ref-int32-LE code i))) (set! i (+ i 4)) (if (eq? inst 'keyargs) (begin - (princ " ") - (princ (number->string (ref-int32-LE code i)) " ") + (xdisplay " ") + (xdisplay (number->string (ref-int32-LE code i))) + (xdisplay " ") (set! i (+ i 4))))) ((brbound) - (princ (number->string (ref-int32-LE code i)) " ") + (xdisplay (number->string (ref-int32-LE code i))) + (xdisplay " ") (set! i (+ i 4))) ((jmp brf brt brne brnn brn) - (princ "@" (hex5 (+ i -4 (ref-int16-LE code i)))) + (xdisplay "@") + (xdisplay (hex5 (+ i -4 (ref-int16-LE code i)))) (set! i (+ i 2))) ((jmp.l brf.l brt.l brne.l brnn.l brn.l) - (princ "@" (hex5 (+ i -4 (ref-int32-LE code i)))) + (xdisplay "@") + (xdisplay (hex5 (+ i -4 (ref-int32-LE code i)))) (set! i (+ i 4))) (else #f))))))) diff --git a/scheme-core/dump.scm b/scheme-core/dump.scm index 11fd4d1..58ba740 100644 --- a/scheme-core/dump.scm +++ b/scheme-core/dump.scm @@ -1,5 +1,5 @@ (define (dump-buffers-as-c-literal . bufs) - (princ "char boot_image[] = \"") + (xdisplay "char boot_image[] = \"") (let loop-bufs ((bufs bufs)) (if (not (null? bufs)) (begin (let ((buf (car bufs))) @@ -7,10 +7,10 @@ (let ((char (read-u8 buf))) (if (not (io.eof? buf)) (let ((code (+ char 0))) - (if (= 0 (mod i 16)) (princ "\"\n\"")) - (princ "\\x") - (if (< code #x10) (princ "0")) - (princ (number->string code 16)) + (if (= 0 (mod i 16)) (xdisplay "\"\n\"")) + (xdisplay "\\x") + (if (< code #x10) (xdisplay "0")) + (xdisplay (number->string code 16)) (loop-buf-bytes (+ i 1))))))) (loop-bufs (cdr bufs))))) - (princ "\";\n")) + (xdisplay "\";\n")) diff --git a/scheme-core/mkboot0.scm b/scheme-core/mkboot0.scm index 5759f22..c1ad554 100644 --- a/scheme-core/mkboot0.scm +++ b/scheme-core/mkboot0.scm @@ -13,7 +13,7 @@ (let next ((E (read in))) (if (not (io.eof? in)) (begin (write (compile-thunk (expand E)) out) - (newline out) + (xnewline out) (next (read in))))) (io.close in) (io.seek out 0) diff --git a/scheme-core/system.scm b/scheme-core/system.scm index 809f24e..f171184 100644 --- a/scheme-core/system.scm +++ b/scheme-core/system.scm @@ -584,8 +584,8 @@ (define-macro (assert expr) `(if ,expr #t (raise '(assert-failed ,expr)))) (define traced? - (letrec ((sample-traced-lambda (lambda args (begin (write (cons 'x args)) - (newline) + (letrec ((sample-traced-lambda (lambda args (begin (xwrite (cons 'x args)) + (xnewline) (apply #.apply args))))) (lambda (f) (and (closure? f) @@ -599,8 +599,8 @@ (set-top-level-value! sym (eval `(lambda ,args - (begin (write (cons ',sym ,args)) - (newline) + (begin (xwrite (cons ',sym ,args)) + (xnewline) (apply ',func ,args))))))) 'ok) @@ -615,18 +615,21 @@ `(let ((,t0 (time.now))) (prog1 ,expr - (princ "Elapsed time: " (- (time.now) ,t0) " seconds\n"))))) + (xdisplay "Elapsed time: ") + (xdisplay (- (time.now) ,t0)) + (xdisplay " seconds") + (xnewline))))) ; text I/O ------------------------------------------------------------------- -(define (print . args) (for-each write args)) +(define (print . args) + (for-each xwrite args)) + (define (princ . args) - (with-bindings ((*print-readably* #f)) - (for-each write args))) + (for-each xdisplay args)) (define (newline (port *output-stream*)) - (io.write port *linefeed*) - #t) + (xnewline port)) (define (io.readline s) (io.readuntil s #\linefeed)) @@ -747,7 +750,7 @@ (define (print-to-string v) (let ((b (buffer))) - (write v b) + (xwrite v b) (io.tostring! b))) (define (string.join strlist sep) @@ -924,24 +927,25 @@ Up Scheme (define (repl) (define (prompt) - (princ "up> ") (io.flush *output-stream*) + (xdisplay "up> ") + (io.flush *output-stream*) (let ((v (trycatch (read) (lambda (e) (begin (io.discardbuffer *input-stream*) (raise e)))))) (and (not (io.eof? *input-stream*)) (let ((V (load-process v))) - (print V) + (xwrite V) (set! that V) #t)))) (define (reploop) - (when (trycatch (and (prompt) (newline)) + (when (trycatch (and (prompt) (xnewline)) (lambda (e) (top-level-exception-handler e) #t)) - (begin (newline) + (begin (xnewline) (reploop)))) (reploop) - (newline)) + (xnewline)) (define (top-level-exception-handler e) (with-output-to *stderr* @@ -974,10 +978,12 @@ Up Scheme (n 0)) (for-each (lambda (f) - (princ "#" n " ") - (print (cons (fn-name (aref f 0) e) - (cdr (vector->list f)))) - (newline) + (xdisplay "#") + (xdisplay n) + (xdisplay " ") + (xwrite (cons (fn-name (aref f 0) e) + (cdr (vector->list f)))) + (xnewline) (set! n (+ n 1))) st))) @@ -985,43 +991,52 @@ Up Scheme (cond ((and (pair? e) (eq? (car e) 'type-error) (length= e 4)) - (princ "type error: " (cadr e) ": expected " (caddr e) ", got ") - (print (cadddr e))) - + (xdisplay "type error: ") + (xdisplay (cadr e)) + (xdisplay ": expected ") + (xdisplay (caddr e)) + (xdisplay ", got ") + (xwrite (cadddr e))) + ((and (pair? e) (eq? (car e) 'bounds-error) (length= e 4)) - (princ (cadr e) ": index " (cadddr e) " out of bounds for ") - (print (caddr e))) + (xdisplay (cadr e)) + (xdisplay ": index ") + (xdisplay (cadddr e)) + (xdisplay " out of bounds for ") + (xwrite (caddr e))) ((and (pair? e) (eq? (car e) 'unbound-error) (pair? (cdr e))) - (princ "eval: variable " (cadr e) " has no value")) + (xdisplay "eval: variable ") + (xdisplay (cadr e)) + (xdisplay " has no value")) ((and (pair? e) (eq? (car e) 'error)) - (princ "error: ") - (apply princ (cdr e))) + (xdisplay "error: ") + (for-each xdisplay (cdr e))) ((and (pair? e) (eq? (car e) 'load-error)) (print-exception (caddr e)) - (princ "in file " (cadr e))) + (xdisplay "in file " (cadr e))) ((and (list? e) (length= e 2)) - (print (car e)) - (princ ": ") + (xwrite (car e)) + (xdisplay ": ") (let ((msg (cadr e))) ((if (or (string? msg) (symbol? msg)) - princ print) + xdisplay xwrite) msg))) - (else (princ "*** Unhandled exception: ") - (print e))) + (else (xdisplay "*** Unhandled exception: ") + (xwrite e))) - (princ *linefeed*)) + (xdisplay *linefeed*)) (define (simple-sort l) (if (or (null? l) (null? (cdr l))) l @@ -1078,6 +1093,6 @@ Up Scheme (__script (cadr argv))) (begin (set! *argv* argv) (set! *interactive* #t) - (princ *banner*) + (xdisplay *banner*) (repl))) (exit 0))