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 (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)

50
scheme-core/compiler.scm
View File

@ -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)))))))

12
scheme-core/dump.scm
View File

@ -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"))

2
scheme-core/mkboot0.scm
View File

@ -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)

87
scheme-core/system.scm
View File

@ -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))