picrin/contrib/60.repl/repl.scm

106 lines
3.0 KiB
Scheme
Raw Normal View History

2014-07-27 22:37:46 -04:00
(define-library (picrin repl)
(import (scheme base)
(scheme read)
(scheme write)
(scheme eval)
(picrin base))
2014-09-19 04:14:08 -04:00
(cond-expand
((library (picrin readline))
(import (picrin readline)
(picrin readline history)))
(else
(begin
(define (readline str)
2015-05-29 07:43:05 -04:00
(when (tty?)
(display str)
(flush-output-port))
2014-09-19 04:14:08 -04:00
(read-line))
(define (add-history str)
#f))))
2014-07-27 22:37:46 -04:00
(define (init-env)
(eval
'(import (scheme base)
(scheme load)
(scheme process-context)
(scheme read)
(scheme write)
(scheme file)
(scheme inexact)
(scheme cxr)
(scheme lazy)
(scheme time)
2016-02-06 14:57:16 -05:00
(scheme eval)
(scheme r5rs)
(picrin macro))
"picrin.user"))
2016-02-22 14:03:59 -05:00
(define (repeat x)
(let ((p (list x)))
(set-cdr! p p)
p))
(define (join xs delim)
(cdr (apply append (map list (repeat delim) xs))))
(define (string-join strings delim)
(apply string-append (join strings delim)))
(define (->string x)
(call-with-port (open-output-string)
(lambda (port)
(write x port)
(get-output-string port))))
(define (print-error-object e)
(define type (error-object-type e))
(unless (eq? type '||)
(display type)
(display "-"))
2016-02-22 14:03:59 -05:00
(display "error: ")
(display (error-object-message e))
(display ".")
(define irritants (error-object-irritants e))
(unless (null? irritants)
(display " (irritants: ")
(display (string-join (map ->string irritants) ", "))
(display ")"))
(newline))
2014-08-30 11:36:20 -04:00
(define (repl)
(init-env)
2014-08-31 12:00:30 -04:00
(let loop ((buf ""))
(let ((line (readline (if (equal? buf "") "> " ""))))
2014-08-31 12:00:30 -04:00
(if (eof-object? line)
(newline) ; exit
(let ((str (string-append buf line "\n")))
(add-history line)
(call/cc
(lambda (exit)
(with-exception-handler
(lambda (condition)
2014-09-19 04:14:08 -04:00
(if (error-object? condition)
(unless (equal? (error-object-message condition) "unexpected EOF")
2016-02-22 14:03:59 -05:00
(print-error-object condition)
2014-09-19 04:14:08 -04:00
(set! str ""))
(begin
(display "raise: ")
2014-09-19 04:14:08 -04:00
(write condition)
(newline)
(set! str "")))
2014-08-31 12:00:30 -04:00
(exit))
(lambda ()
2014-09-19 04:14:08 -04:00
(call-with-port (open-input-string str)
(lambda (port)
(let next ((expr (read port)))
(unless (eof-object? expr)
(write (eval expr "picrin.user"))
2014-09-19 04:14:08 -04:00
(newline)
(set! str "")
(next (read port))))))))))
2014-08-31 12:00:30 -04:00
(loop str))))))
2014-07-27 22:37:46 -04:00
(export repl))
2014-08-30 10:30:04 -04:00