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

Replace xwrite/xdisplay/xnewline with non-x names

This commit is contained in:
Lassi Kortela 2019-08-25 22:57:31 +03:00
parent 924a45b7bd
commit 33488d73cf
15 changed files with 2793 additions and 2818 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

5356
scheme-boot/boot_image.h
View File

File diff suppressed because it is too large Load Diff

11
scheme-core/aliases.scm
View File

@ -178,18 +178,13 @@
(define (file-exists? f) (path.exists? f)) (define (file-exists? f) (path.exists? f))
(define (delete-file name) (void)) ; TODO (define (delete-file name) (void)) ; TODO
(define (display x (port *output-stream*))
(xdisplay x port))
(define assertion-violation (define assertion-violation
(lambda args (lambda args
(xdisplay 'assertion-violation) (displayln 'assertion-violation)
(xnewline) (displayln args)
(xdisplay args)
(xnewline)
(car #f))) (car #f)))
(define pretty-print xwrite) (define pretty-print write)
(define (memp proc ls) (define (memp proc ls)
(cond ((null? ls) #f) (cond ((null? ls) #f)

68
scheme-core/compiler.scm
View File

@ -433,7 +433,7 @@
(if (symbol? (cadr x)) (if (symbol? (cadr x))
`(,(void)) `(,(void))
(error "compile error: invalid syntax " (error "compile error: invalid syntax "
(print-to-string x)))))) (write-to-string x))))))
(if (symbol? form) (if (symbol? form)
`(set! ,form ,(car body)) `(set! ,form ,(car body))
`(set! ,(car form) `(set! ,(car form)
@ -656,20 +656,20 @@
(define (disassemble f . lev?) (define (disassemble f . lev?)
(if (null? lev?) (if (null? lev?)
(begin (disassemble f 0) (begin (disassemble f 0)
(xnewline) (newline)
(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 (write-val v)
(if (and (function? v) (not (builtin? v))) (if (and (function? v) (not (builtin? v)))
(begin (xdisplay "\n") (begin (display "\n")
(disassemble v (+ lev 1))) (disassemble v (+ lev 1)))
(xwrite v))) (write v)))
(dotimes (xx lev) (xdisplay " ")) (dotimes (xx lev) (display " "))
(xdisplay "maxstack ") (display "maxstack ")
(xdisplay (ref-int32-LE code 0)) (display (ref-int32-LE code 0))
(xnewline) (newline)
(let ((i 4) (let ((i 4)
(N (length code))) (N (length code)))
(while (< i N) (while (< i N)
@ -678,64 +678,64 @@
(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) (xnewline)) (if (> i 4) (newline))
(dotimes (xx lev) (xdisplay " ")) (dotimes (xx lev) (display " "))
(xdisplay (hex5 (- i 4))) (display (hex5 (- i 4)))
(xdisplay ": ") (display ": ")
(xdisplay (string inst)) (display (string inst))
(xdisplay " ") (display " ")
(set! i (+ i 1)) (set! i (+ i 1))
(case inst (case inst
((loadv.l loadg.l setg.l) ((loadv.l loadg.l setg.l)
(print-val (aref vals (ref-int32-LE code i))) (write-val (aref vals (ref-int32-LE code i)))
(set! i (+ i 4))) (set! i (+ i 4)))
((loadv loadg setg) ((loadv loadg setg)
(print-val (aref vals (aref code i))) (write-val (aref vals (aref code i)))
(set! i (+ i 1))) (set! i (+ i 1)))
((loada seta call tcall list + - * / vector ((loada seta call tcall list + - * / vector
argc vargc loadi8 apply tapply) argc vargc loadi8 apply tapply)
(xdisplay (number->string (aref code i))) (display (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)
(xdisplay (number->string (ref-int32-LE code i))) (display (number->string (ref-int32-LE code i)))
(set! i (+ i 4))) (set! i (+ i 4)))
((loadc setc) ((loadc setc)
(xdisplay (number->string (aref code i))) (display (number->string (aref code i)))
(xdisplay " ") (display " ")
(set! i (+ i 1)) (set! i (+ i 1))
(xdisplay (number->string (aref code i))) (display (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)
(xdisplay (number->string (ref-int32-LE code i))) (display (number->string (ref-int32-LE code i)))
(xdisplay " ") (display " ")
(set! i (+ i 4)) (set! i (+ i 4))
(xdisplay (number->string (ref-int32-LE code i))) (display (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
(xdisplay " ") (display " ")
(xdisplay (number->string (ref-int32-LE code i))) (display (number->string (ref-int32-LE code i)))
(xdisplay " ") (display " ")
(set! i (+ i 4))))) (set! i (+ i 4)))))
((brbound) ((brbound)
(xdisplay (number->string (ref-int32-LE code i))) (display (number->string (ref-int32-LE code i)))
(xdisplay " ") (display " ")
(set! i (+ i 4))) (set! i (+ i 4)))
((jmp brf brt brne brnn brn) ((jmp brf brt brne brnn brn)
(xdisplay "@") (display "@")
(xdisplay (hex5 (+ i -4 (ref-int16-LE code i)))) (display (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)
(xdisplay "@") (display "@")
(xdisplay (hex5 (+ i -4 (ref-int32-LE code i)))) (display (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)
(xdisplay "char boot_image[] = \"") (display "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)) (xdisplay "\"\n\"")) (if (= 0 (mod i 16)) (display "\"\n\""))
(xdisplay "\\x") (display "\\x")
(if (< code #x10) (xdisplay "0")) (if (< code #x10) (display "0"))
(xdisplay (number->string code 16)) (display (number->string code 16))
(loop-buf-bytes (+ i 1))))))) (loop-buf-bytes (+ i 1)))))))
(loop-bufs (cdr bufs))))) (loop-bufs (cdr bufs)))))
(xdisplay "\";\n")) (display "\";\n"))

3
scheme-core/mkboot0.scm
View File

@ -12,8 +12,7 @@
(out (buffer))) (out (buffer)))
(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 (writeln (compile-thunk (expand E)) out)
(xnewline out)
(next (read in))))) (next (read in)))))
(io.close in) (io.close in)
(io.seek out 0) (io.seek out 0)

97
scheme-core/system.scm
View File

@ -584,8 +584,7 @@
(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 (xwrite (cons 'x args)) (letrec ((sample-traced-lambda (lambda args (begin (writeln (cons 'x args))
(xnewline)
(apply #.apply args))))) (apply #.apply args)))))
(lambda (f) (lambda (f)
(and (closure? f) (and (closure? f)
@ -599,8 +598,7 @@
(set-top-level-value! sym (set-top-level-value! sym
(eval (eval
`(lambda ,args `(lambda ,args
(begin (xwrite (cons ',sym ,args)) (begin (writeln (cons ',sym ,args))
(xnewline)
(apply ',func ,args))))))) (apply ',func ,args)))))))
'ok) 'ok)
@ -615,22 +613,13 @@
`(let ((,t0 (time.now))) `(let ((,t0 (time.now)))
(prog1 (prog1
,expr ,expr
(xdisplay "Elapsed time: ") (display "Elapsed time: ")
(xdisplay (- (time.now) ,t0)) (display (- (time.now) ,t0))
(xdisplay " seconds") (display " seconds")
(xnewline))))) (newline)))))
; text I/O ------------------------------------------------------------------- ; text I/O -------------------------------------------------------------------
(define (print . args)
(for-each xwrite args))
(define (princ . args)
(for-each xdisplay args))
(define (newline (port *output-stream*))
(xnewline port))
(define (io.readline s) (io.readuntil s #\linefeed)) (define (io.readline s) (io.readuntil s #\linefeed))
; call f on a stream until the stream runs out of data ; call f on a stream until the stream runs out of data
@ -748,11 +737,13 @@
(define (string.lpad s n c) (string (string.rep c (- n (string.count s))) s)) (define (string.lpad s n c) (string (string.rep c (- n (string.count s))) s))
(define (string.rpad s n c) (string s (string.rep c (- n (string.count s))))) (define (string.rpad s n c) (string s (string.rep c (- n (string.count s)))))
(define (print-to-string v) (define (write-to-string v)
(let ((b (buffer))) (let ((b (buffer)))
(xwrite v b) (write v b)
(io.tostring! b))) (io.tostring! b)))
(define print-to-string write-to-string) ;; TODO: remove
(define (string.join strlist sep) (define (string.join strlist sep)
(if (null? strlist) "" (if (null? strlist) ""
(let ((b (buffer))) (let ((b (buffer)))
@ -927,25 +918,25 @@ Up Scheme
(define (repl) (define (repl)
(define (prompt) (define (prompt)
(xdisplay "up> ") (display "up> ")
(io.flush *output-stream*) (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)))
(xwrite V) (write V)
(set! that V) (set! that V)
#t)))) #t))))
(define (reploop) (define (reploop)
(when (trycatch (and (prompt) (xnewline)) (when (trycatch (and (prompt) (newline))
(lambda (e) (lambda (e)
(top-level-exception-handler e) (top-level-exception-handler e)
#t)) #t))
(begin (xnewline) (begin (newline)
(reploop)))) (reploop))))
(reploop) (reploop)
(xnewline)) (newline))
(define (top-level-exception-handler e) (define (top-level-exception-handler e)
(with-output-to *stderr* (with-output-to *stderr*
@ -978,12 +969,11 @@ Up Scheme
(n 0)) (n 0))
(for-each (for-each
(lambda (f) (lambda (f)
(xdisplay "#") (display "#")
(xdisplay n) (display n)
(xdisplay " ") (display " ")
(xwrite (cons (fn-name (aref f 0) e) (writeln (cons (fn-name (aref f 0) e)
(cdr (vector->list f)))) (cdr (vector->list f))))
(xnewline)
(set! n (+ n 1))) (set! n (+ n 1)))
st))) st)))
@ -991,52 +981,53 @@ 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))
(xdisplay "type error: ") (display "type error: ")
(xdisplay (cadr e)) (display (cadr e))
(xdisplay ": expected ") (display ": expected ")
(xdisplay (caddr e)) (display (caddr e))
(xdisplay ", got ") (display ", got ")
(xwrite (cadddr e))) (write (cadddr e)))
((and (pair? e) ((and (pair? e)
(eq? (car e) 'bounds-error) (eq? (car e) 'bounds-error)
(length= e 4)) (length= e 4))
(xdisplay (cadr e)) (display (cadr e))
(xdisplay ": index ") (display ": index ")
(xdisplay (cadddr e)) (display (cadddr e))
(xdisplay " out of bounds for ") (display " out of bounds for ")
(xwrite (caddr e))) (write (caddr e)))
((and (pair? e) ((and (pair? e)
(eq? (car e) 'unbound-error) (eq? (car e) 'unbound-error)
(pair? (cdr e))) (pair? (cdr e)))
(xdisplay "eval: variable ") (display "eval: variable ")
(xdisplay (cadr e)) (display (cadr e))
(xdisplay " has no value")) (display " has no value"))
((and (pair? e) ((and (pair? e)
(eq? (car e) 'error)) (eq? (car e) 'error))
(xdisplay "error: ") (display "error: ")
(for-each xdisplay (cdr e))) (for-each display (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))
(xdisplay "in file " (cadr e))) (display "in file ")
(display (cadr e)))
((and (list? e) ((and (list? e)
(length= e 2)) (length= e 2))
(xwrite (car e)) (write (car e))
(xdisplay ": ") (display ": ")
(let ((msg (cadr e))) (let ((msg (cadr e)))
((if (or (string? msg) (symbol? msg)) ((if (or (string? msg) (symbol? msg))
xdisplay xwrite) display write)
msg))) msg)))
(else (xdisplay "*** Unhandled exception: ") (else (display "*** Unhandled exception: ")
(xwrite e))) (write e)))
(xdisplay *linefeed*)) (newline))
(define (simple-sort l) (define (simple-sort l)
(if (or (null? l) (null? (cdr l))) l (if (or (null? l) (null? (cdr l))) l
@ -1093,6 +1084,6 @@ Up Scheme
(__script (cadr argv))) (__script (cadr argv)))
(begin (set! *argv* argv) (begin (set! *argv* argv)
(set! *interactive* #t) (set! *interactive* #t)
(xdisplay *banner*) (display *banner*)
(repl))) (repl)))
(exit 0)) (exit 0))

4
scheme-examples/cps.scm
View File

@ -295,14 +295,14 @@ todo:
(let ((x 0)) (let ((x 0))
(while (< x 10) (while (< x 10)
(begin (print x) (set! x (+ 1 x))))) (begin (write x) (set! x (+ 1 x)))))
=> =>
(let ((x 0)) (let ((x 0))
(reset (reset
(let ((l #f)) (let ((l #f))
(let ((k (shift k (k k)))) (let ((k (shift k (k k))))
(if (< x 10) (if (< x 10)
(begin (set! l (begin (print x) (begin (set! l (begin (write x)
(set! x (+ 1 x)))) (set! x (+ 1 x))))
(k k)) (k k))
l))))) l)))))

4
scheme-examples/rule30.scm
View File

@ -19,7 +19,5 @@
s)) s))
(for-each (lambda (n) (for-each (lambda (n)
(begin (displayln (bin-draw (string.lpad (number->string n 2) 63 #\0))))
(princ (bin-draw (string.lpad (number->string n 2) 63 #\0)))
(newline)))
(nestlist rule30-step (uint64 #x0000000080000000) 32)) (nestlist rule30-step (uint64 #x0000000080000000) 32))

2
scheme-tests/argv.scm
View File

@ -1 +1 @@
(print *argv*) (princ "\n") (writeln *argv*)

2
scheme-tests/err.scm
View File

@ -1,4 +1,4 @@
(define (f x) (begin (list-tail '(1) 3) 3)) (define (f x) (begin (list-tail '(1) 3) 3))
(f 2) (f 2)
a a
(trycatch a (lambda (e) (print (stacktrace)))) (trycatch a (lambda (e) (write (stacktrace))))

14
scheme-tests/perf.scm
View File

@ -1,18 +1,18 @@
(load "test.scm") (load "test.scm")
(princ "colorgraph: ") (display "colorgraph: ")
(load "tcolor.scm") (load "tcolor.scm")
(princ "fib(34): ") (display "fib(34): ")
(assert (equal? (time (fib 34)) 5702887)) (assert (equal? (time (fib 34)) 5702887))
(princ "yfib(32): ") (display "yfib(32): ")
(assert (equal? (time (yfib 32)) 2178309)) (assert (equal? (time (yfib 32)) 2178309))
(princ "sort: ") (display "sort: ")
(set! r (map-int (lambda (x) (mod (+ (* x 9421) 12345) 1024)) 1000)) (set! r (map-int (lambda (x) (mod (+ (* x 9421) 12345) 1024)) 1000))
(time (simple-sort r)) (time (simple-sort r))
(princ "expand: ") (display "expand: ")
(time (dotimes (n 5000) (expand '(dotimes (i 100) body1 body2)))) (time (dotimes (n 5000) (expand '(dotimes (i 100) body1 body2))))
(define (my-append . lsts) (define (my-append . lsts)
@ -24,12 +24,12 @@
(append2 (cdr l) d)))))) (append2 (cdr l) d))))))
(append2 (car lsts) (apply my-append (cdr lsts))))))) (append2 (car lsts) (apply my-append (cdr lsts)))))))
(princ "append: ") (display "append: ")
(set! L (map-int (lambda (x) (map-int identity 20)) 20)) (set! L (map-int (lambda (x) (map-int identity 20)) 20))
(time (dotimes (n 1000) (apply my-append L))) (time (dotimes (n 1000) (apply my-append L)))
(path.cwd "ast") (path.cwd "ast")
(princ "p-lambda: ") (display "p-lambda: ")
(load "rpasses.scm") (load "rpasses.scm")
(define *input* (load "datetimeR.scm")) (define *input* (load "datetimeR.scm"))
(time (set! *output* (compile-ish *input*))) (time (set! *output* (compile-ish *input*)))

18
scheme-tests/test.scm
View File

@ -25,10 +25,10 @@
(car lsts) (append-h (cdr lsts))))))) (car lsts) (append-h (cdr lsts)))))))
lsts)) lsts))
;(princ 'Hello '| | 'world! "\n") ;(for-each display '(Hello | | world! "\n"))
;(filter (lambda (x) (not (< x 0))) '(1 -1 -2 5 10 -8 0)) ;(filter (lambda (x) (not (< x 0))) '(1 -1 -2 5 10 -8 0))
(define (fib n) (if (< n 2) n (+ (fib (- n 1)) (fib (- n 2))))) (define (fib n) (if (< n 2) n (+ (fib (- n 1)) (fib (- n 2)))))
;(princ (time (fib 34)) "\n") ;(displayln (time (fib 34)))
;(dotimes (i 20000) (map-int (lambda (x) (list 'quote x)) 8)) ;(dotimes (i 20000) (map-int (lambda (x) (list 'quote x)) 8))
;(dotimes (i 40000) (append '(a b) '(1 2 3 4) () '(c) () '(5 6))) ;(dotimes (i 40000) (append '(a b) '(1 2 3 4) () '(c) () '(5 6)))
;(dotimes (i 80000) (list 1 2 3 4 5)) ;(dotimes (i 80000) (list 1 2 3 4 5))
@ -240,17 +240,17 @@
(length (string x))) (length (string x)))
(cons 'Function (cons 'Function
(map car pr)))))) (map car pr))))))
(princ (string.rpad "Function" width #\ ) (display (string.rpad "Function" width #\ ))
"#Calls Time (seconds)") (display "#Calls Time (seconds)")
(newline) (newline)
(princ (string.rpad "--------" width #\ ) (display (string.rpad "--------" width #\ ))
"------ --------------") (display "------ --------------")
(newline) (newline)
(for-each (for-each
(lambda (p) (lambda (p)
(princ (string.rpad (string (caddr p)) width #\ ) (display (string.rpad (string (caddr p)) width #\ ))
(string.rpad (string (cadr p)) 11 #\ ) (display (string.rpad (string (cadr p)) 11 #\ ))
(car p)) (display (car p))
(newline)) (newline))
(simple-sort (map (lambda (l) (reverse (to-proper l))) (simple-sort (map (lambda (l) (reverse (to-proper l)))
pr))))) pr)))))

12
scheme-tests/torture.scm
View File

@ -1,7 +1,6 @@
(define ones (map (lambda (x) 1) (iota 1000000))) (define ones (map (lambda (x) 1) (iota 1000000)))
(write (apply + ones)) (writeln (apply + ones))
(newline)
(define (big n) (define (big n)
(if (<= n 0) (if (<= n 0)
@ -10,15 +9,12 @@
(define nst (big 100000)) (define nst (big 100000))
(write (eval nst)) (writeln (eval nst))
(newline)
(define longg (cons '+ ones)) (define longg (cons '+ ones))
(write (eval longg)) (writeln (eval longg))
(newline)
(define (f x) (define (f x)
(begin (write x) (begin (writeln x)
(newline)
(f (+ x 1)) (f (+ x 1))
0)) 0))

2
scheme-tests/torus.scm
View File

@ -37,7 +37,7 @@
(set! b (cdr b)))) (set! b (cdr b))))
l)) l))
(time (begin (print (torus 100 100)) ())) (time (begin (write (torus 100 100)) ()))
;(time (dotimes (i 1) (load "100x100.scm"))) ;(time (dotimes (i 1) (load "100x100.scm")))
; with ltable ; with ltable
; printing time: 0.415sec ; printing time: 0.415sec

4
scheme-tests/unittest.scm
View File

@ -297,10 +297,10 @@
(io.tostring! b))) (io.tostring! b)))
(let ((c #\a)) (let ((c #\a))
(assert (equal? (with-output-to-string #f (lambda () (xwrite (list c c)))) (assert (equal? (with-output-to-string #f (lambda () (write (list c c))))
"(#\\a #\\a)"))) "(#\\a #\\a)")))
(assert-fail (eval '(set! (car (cons 1 2)) 3))) (assert-fail (eval '(set! (car (cons 1 2)) 3)))
(xdisplay "all tests pass\n") (display "all tests pass\n")
#t #t