lassik
/
upscheme
1
0
Fork 0
Code Issues Pull Requests Projects Releases Wiki Activity

Make Lisp core use xwrite/xdisplay/xnewline

This commit is contained in:
Lassi Kortela 2019-08-25 22:07:38 +03:00
parent 6e87c8ad26
commit 55cb24023b
5 changed files with 94 additions and 70 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

13
scheme-core/aliases.scm
View File

@ -179,18 +179,17 @@
(define (delete-file name) (void)) ; TODO (define (delete-file name) (void)) ; TODO
(define (display x (port *output-stream*)) (define (display x (port *output-stream*))
(with-output-to port (princ x)) (xdisplay x port))
#t)
(define assertion-violation (define assertion-violation
(lambda args (lambda args
(display 'assertion-violation) (xdisplay 'assertion-violation)
(newline) (xnewline)
(display args) (xdisplay args)
(newline) (xnewline)
(car #f))) (car #f)))
(define pretty-print write) (define pretty-print xwrite)
(define (memp proc ls) (define (memp proc ls)
(cond ((null? ls) #f) (cond ((null? ls) #f)

50
scheme-core/compiler.scm
View File

@ -656,18 +656,20 @@
(define (disassemble f . lev?) (define (disassemble f . lev?)
(if (null? lev?) (if (null? lev?)
(begin (disassemble f 0) (begin (disassemble f 0)
(newline) (xnewline)
(return #t))) (return #t)))
(let ((lev (car lev?)) (let ((lev (car lev?))
(code (function:code f)) (code (function:code f))
(vals (function:vals f))) (vals (function:vals f)))
(define (print-val v) (define (print-val v)
(if (and (function? v) (not (builtin? v))) (if (and (function? v) (not (builtin? v)))
(begin (princ "\n") (begin (xdisplay "\n")
(disassemble v (+ lev 1))) (disassemble v (+ lev 1)))
(print v))) (xwrite v)))
(dotimes (xx lev) (princ " ")) (dotimes (xx lev) (xdisplay " "))
(princ "maxstack " (ref-int32-LE code 0) "\n") (xdisplay "maxstack ")
(xdisplay (ref-int32-LE code 0))
(xnewline)
(let ((i 4) (let ((i 4)
(N (length code))) (N (length code)))
(while (< i N) (while (< i N)
@ -676,10 +678,12 @@
(or z (and (eq? v (aref code i)) (or z (and (eq? v (aref code i))
k))) k)))
#f Instructions))) #f Instructions)))
(if (> i 4) (newline)) (if (> i 4) (xnewline))
(dotimes (xx lev) (princ " ")) (dotimes (xx lev) (xdisplay " "))
(princ (hex5 (- i 4)) ": " (xdisplay (hex5 (- i 4)))
(string inst) " ") (xdisplay ": ")
(xdisplay (string inst))
(xdisplay " ")
(set! i (+ i 1)) (set! i (+ i 1))
(case inst (case inst
((loadv.l loadg.l setg.l) ((loadv.l loadg.l setg.l)
@ -692,40 +696,46 @@
((loada seta call tcall list + - * / vector ((loada seta call tcall list + - * / vector
argc vargc loadi8 apply tapply) argc vargc loadi8 apply tapply)
(princ (number->string (aref code i))) (xdisplay (number->string (aref code i)))
(set! i (+ i 1))) (set! i (+ i 1)))
((loada.l seta.l largc lvargc call.l tcall.l) ((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))) (set! i (+ i 4)))
((loadc setc) ((loadc setc)
(princ (number->string (aref code i)) " ") (xdisplay (number->string (aref code i)))
(xdisplay " ")
(set! i (+ i 1)) (set! i (+ i 1))
(princ (number->string (aref code i))) (xdisplay (number->string (aref code i)))
(set! i (+ i 1))) (set! i (+ i 1)))
((loadc.l setc.l optargs keyargs) ((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)) (set! i (+ i 4))
(princ (number->string (ref-int32-LE code i))) (xdisplay (number->string (ref-int32-LE code i)))
(set! i (+ i 4)) (set! i (+ i 4))
(if (eq? inst 'keyargs) (if (eq? inst 'keyargs)
(begin (begin
(princ " ") (xdisplay " ")
(princ (number->string (ref-int32-LE code i)) " ") (xdisplay (number->string (ref-int32-LE code i)))
(xdisplay " ")
(set! i (+ i 4))))) (set! i (+ i 4)))))
((brbound) ((brbound)
(princ (number->string (ref-int32-LE code i)) " ") (xdisplay (number->string (ref-int32-LE code i)))
(xdisplay " ")
(set! i (+ i 4))) (set! i (+ i 4)))
((jmp brf brt brne brnn brn) ((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))) (set! i (+ i 2)))
((jmp.l brf.l brt.l brne.l brnn.l brn.l) ((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))) (set! i (+ i 4)))
(else #f))))))) (else #f)))))))

12
scheme-core/dump.scm
View File

@ -1,5 +1,5 @@
(define (dump-buffers-as-c-literal . bufs) (define (dump-buffers-as-c-literal . bufs)
(princ "char boot_image[] = \"") (xdisplay "char boot_image[] = \"")
(let loop-bufs ((bufs bufs)) (let loop-bufs ((bufs bufs))
(if (not (null? bufs)) (if (not (null? bufs))
(begin (let ((buf (car bufs))) (begin (let ((buf (car bufs)))
@ -7,10 +7,10 @@
(let ((char (read-u8 buf))) (let ((char (read-u8 buf)))
(if (not (io.eof? buf)) (if (not (io.eof? buf))
(let ((code (+ char 0))) (let ((code (+ char 0)))
(if (= 0 (mod i 16)) (princ "\"\n\"")) (if (= 0 (mod i 16)) (xdisplay "\"\n\""))
(princ "\\x") (xdisplay "\\x")
(if (< code #x10) (princ "0")) (if (< code #x10) (xdisplay "0"))
(princ (number->string code 16)) (xdisplay (number->string code 16))
(loop-buf-bytes (+ i 1))))))) (loop-buf-bytes (+ i 1)))))))
(loop-bufs (cdr bufs))))) (loop-bufs (cdr bufs)))))
(princ "\";\n")) (xdisplay "\";\n"))

2
scheme-core/mkboot0.scm
View File

@ -13,7 +13,7 @@
(let next ((E (read in))) (let next ((E (read in)))
(if (not (io.eof? in)) (if (not (io.eof? in))
(begin (write (compile-thunk (expand E)) out) (begin (write (compile-thunk (expand E)) out)
(newline out) (xnewline out)
(next (read in))))) (next (read in)))))
(io.close in) (io.close in)
(io.seek out 0) (io.seek out 0)

87
scheme-core/system.scm
View File

@ -584,8 +584,8 @@
(define-macro (assert expr) `(if ,expr #t (raise '(assert-failed ,expr)))) (define-macro (assert expr) `(if ,expr #t (raise '(assert-failed ,expr))))
(define traced? (define traced?
(letrec ((sample-traced-lambda (lambda args (begin (write (cons 'x args)) (letrec ((sample-traced-lambda (lambda args (begin (xwrite (cons 'x args))
(newline) (xnewline)
(apply #.apply args))))) (apply #.apply args)))))
(lambda (f) (lambda (f)
(and (closure? f) (and (closure? f)
@ -599,8 +599,8 @@
(set-top-level-value! sym (set-top-level-value! sym
(eval (eval
`(lambda ,args `(lambda ,args
(begin (write (cons ',sym ,args)) (begin (xwrite (cons ',sym ,args))
(newline) (xnewline)
(apply ',func ,args))))))) (apply ',func ,args)))))))
'ok) 'ok)
@ -615,18 +615,21 @@
`(let ((,t0 (time.now))) `(let ((,t0 (time.now)))
(prog1 (prog1
,expr ,expr
(princ "Elapsed time: " (- (time.now) ,t0) " seconds\n"))))) (xdisplay "Elapsed time: ")
(xdisplay (- (time.now) ,t0))
(xdisplay " seconds")
(xnewline)))))
; text I/O ------------------------------------------------------------------- ; text I/O -------------------------------------------------------------------
(define (print . args) (for-each write args)) (define (print . args)
(for-each xwrite args))
(define (princ . args) (define (princ . args)
(with-bindings ((*print-readably* #f)) (for-each xdisplay args))
(for-each write args)))
(define (newline (port *output-stream*)) (define (newline (port *output-stream*))
(io.write port *linefeed*) (xnewline port))
#t)
(define (io.readline s) (io.readuntil s #\linefeed)) (define (io.readline s) (io.readuntil s #\linefeed))
@ -747,7 +750,7 @@
(define (print-to-string v) (define (print-to-string v)
(let ((b (buffer))) (let ((b (buffer)))
(write v b) (xwrite v b)
(io.tostring! b))) (io.tostring! b)))
(define (string.join strlist sep) (define (string.join strlist sep)
@ -924,24 +927,25 @@ Up Scheme
(define (repl) (define (repl)
(define (prompt) (define (prompt)
(princ "up> ") (io.flush *output-stream*) (xdisplay "up> ")
(io.flush *output-stream*)
(let ((v (trycatch (read) (let ((v (trycatch (read)
(lambda (e) (begin (io.discardbuffer *input-stream*) (lambda (e) (begin (io.discardbuffer *input-stream*)
(raise e)))))) (raise e))))))
(and (not (io.eof? *input-stream*)) (and (not (io.eof? *input-stream*))
(let ((V (load-process v))) (let ((V (load-process v)))
(print V) (xwrite V)
(set! that V) (set! that V)
#t)))) #t))))
(define (reploop) (define (reploop)
(when (trycatch (and (prompt) (newline)) (when (trycatch (and (prompt) (xnewline))
(lambda (e) (lambda (e)
(top-level-exception-handler e) (top-level-exception-handler e)
#t)) #t))
(begin (newline) (begin (xnewline)
(reploop)))) (reploop))))
(reploop) (reploop)
(newline)) (xnewline))
(define (top-level-exception-handler e) (define (top-level-exception-handler e)
(with-output-to *stderr* (with-output-to *stderr*
@ -974,10 +978,12 @@ Up Scheme
(n 0)) (n 0))
(for-each (for-each
(lambda (f) (lambda (f)
(princ "#" n " ") (xdisplay "#")
(print (cons (fn-name (aref f 0) e) (xdisplay n)
(cdr (vector->list f)))) (xdisplay " ")
(newline) (xwrite (cons (fn-name (aref f 0) e)
(cdr (vector->list f))))
(xnewline)
(set! n (+ n 1))) (set! n (+ n 1)))
st))) st)))
@ -985,43 +991,52 @@ Up Scheme
(cond ((and (pair? e) (cond ((and (pair? e)
(eq? (car e) 'type-error) (eq? (car e) 'type-error)
(length= e 4)) (length= e 4))
(princ "type error: " (cadr e) ": expected " (caddr e) ", got ") (xdisplay "type error: ")
(print (cadddr e))) (xdisplay (cadr e))
(xdisplay ": expected ")
(xdisplay (caddr e))
(xdisplay ", got ")
(xwrite (cadddr e)))
((and (pair? e) ((and (pair? e)
(eq? (car e) 'bounds-error) (eq? (car e) 'bounds-error)
(length= e 4)) (length= e 4))
(princ (cadr e) ": index " (cadddr e) " out of bounds for ") (xdisplay (cadr e))
(print (caddr e))) (xdisplay ": index ")
(xdisplay (cadddr e))
(xdisplay " out of bounds for ")
(xwrite (caddr e)))
((and (pair? e) ((and (pair? e)
(eq? (car e) 'unbound-error) (eq? (car e) 'unbound-error)
(pair? (cdr e))) (pair? (cdr e)))
(princ "eval: variable " (cadr e) " has no value")) (xdisplay "eval: variable ")
(xdisplay (cadr e))
(xdisplay " has no value"))
((and (pair? e) ((and (pair? e)
(eq? (car e) 'error)) (eq? (car e) 'error))
(princ "error: ") (xdisplay "error: ")
(apply princ (cdr e))) (for-each xdisplay (cdr e)))
((and (pair? e) ((and (pair? e)
(eq? (car e) 'load-error)) (eq? (car e) 'load-error))
(print-exception (caddr e)) (print-exception (caddr e))
(princ "in file " (cadr e))) (xdisplay "in file " (cadr e)))
((and (list? e) ((and (list? e)
(length= e 2)) (length= e 2))
(print (car e)) (xwrite (car e))
(princ ": ") (xdisplay ": ")
(let ((msg (cadr e))) (let ((msg (cadr e)))
((if (or (string? msg) (symbol? msg)) ((if (or (string? msg) (symbol? msg))
princ print) xdisplay xwrite)
msg))) msg)))
(else (princ "*** Unhandled exception: ") (else (xdisplay "*** Unhandled exception: ")
(print e))) (xwrite e)))
(princ *linefeed*)) (xdisplay *linefeed*))
(define (simple-sort l) (define (simple-sort l)
(if (or (null? l) (null? (cdr l))) l (if (or (null? l) (null? (cdr l))) l
@ -1078,6 +1093,6 @@ Up Scheme
(__script (cadr argv))) (__script (cadr argv)))
(begin (set! *argv* argv) (begin (set! *argv* argv)
(set! *interactive* #t) (set! *interactive* #t)
(princ *banner*) (xdisplay *banner*)
(repl))) (repl)))
(exit 0)) (exit 0))