Make Lisp core use xwrite/xdisplay/xnewline
This commit is contained in:
parent
6e87c8ad26
commit
55cb24023b
|
@ -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)
|
||||
|
|
|
@ -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)))))))
|
||||
|
|
|
@ -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"))
|
||||
|
|
|
@ -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)
|
||||
|
|
|
@ -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)
|
||||
(xdisplay "#")
|
||||
(xdisplay n)
|
||||
(xdisplay " ")
|
||||
(xwrite (cons (fn-name (aref f 0) e)
|
||||
(cdr (vector->list f))))
|
||||
(newline)
|
||||
(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))
|
||||
|
|
Loading…
Reference in New Issue