From 02b888b438d1efaba7620fcc4b2e8e2d3feaf917 Mon Sep 17 00:00:00 2001
From: Alex Shinn <ashinn@users.noreply.github.com>
Date: Mon, 16 Aug 2010 15:14:30 +0000
Subject: [PATCH] chibi.repl uses edit-line, catches interrupts
---
lib/chibi/repl.module | 6 ++-
lib/chibi/repl.scm | 89 +++++++++++++++---------------------
lib/chibi/term/edit-line.scm | 16 +++++--
3 files changed, 52 insertions(+), 59 deletions(-)
diff --git a/lib/chibi/repl.module b/lib/chibi/repl.module
index 405d9a0e..742b9581 100644
--- a/lib/chibi/repl.module
+++ b/lib/chibi/repl.module
@@ -2,6 +2,8 @@
(define-module (chibi repl)
(export repl)
(import-immutable (scheme))
- (import (chibi process)
- (chibi term edit-line))
+ (import (chibi ast)
+ (chibi process)
+ (chibi term edit-line)
+ (srfi 18))
(include "repl.scm"))
diff --git a/lib/chibi/repl.scm b/lib/chibi/repl.scm
index 307b0253..b7ff79bc 100644
--- a/lib/chibi/repl.scm
+++ b/lib/chibi/repl.scm
@@ -1,58 +1,41 @@
+;;;; repl.scm - friendlier repl with line editing and signal handling
+;;
+;; Copyright (c) 2010 Alex Shinn. All rights reserved.
+;; BSD-style license: http://synthcode.com/license.txt
+
+(define-syntax handle-exceptions
+ (syntax-rules ()
+ ((handle-exceptions exn handler expr)
+ (call-with-current-continuation
+ (lambda (return)
+ (with-exception-handler (lambda (exn) (return handler))
+ (lambda () expr)))))))
+
+(define (with-signal-handler sig handler thunk)
+ (let ((old-handler #f))
+ (dynamic-wind
+ (lambda () (set! old-handler (set-signal-action! sig handler)))
+ thunk
+ (lambda () (set-signal-action! sig old-handler)))))
(define (run-repl module env)
- (if module (display module))
- (display "> ")
- (flush-output)
- (let lp ()
- (let ((ch (peek-char)))
- (cond ((eof-object? ch)
- (exit 0))
- ((and (char? ch) (char-whitespace? ch))
- (read-char)
- (lp)))))
- (cond
- ((eq? #\@ (peek-char))
- (read-char)
- (let ((sym (read)))
- (if (not (symbol? sym))
- (error "repl: invalid @ syntax: @" sym)
- (case sym
- ((config)
- (let ((res (eval (read) *config-env*)))
- (cond
- ((not (eq? res (if #f #f)))
- (write res)
- (newline)))
- (run-repl module env)))
- ((in)
- (let ((mod (read)))
- (if (or (not mod) (equal? mod '(scheme)))
- (run-repl #f (interaction-environment))
- (let ((env (eval `(module-env (load-module ',mod))
- *config-env*)))
- (run-repl mod env)))))
- (else
- (error "repl: unknown @ escape" sym))))))
- (else
- (let ((expr (read)))
- (cond
- ((eof-object? expr)
- (exit 0))
- (else
- (let ((res (eval expr env)))
- (cond
- ((not (eq? res (if #f #f)))
- (write res)
- (newline)))
- (run-repl module env))))))))
+ (let ((line (edit-line (if module (string-append (symbol->string module) "> ") "> "))))
+ (cond
+ ((or (not line) (eof-object? line)))
+ ((equal? line "") (run-repl module env))
+ (else
+ (handle-exceptions exn (print-exception exn (current-error-port))
+ (let* ((expr (call-with-input-string line read))
+ (thread (make-thread (lambda ()
+ (let ((res (eval expr env)))
+ (if (not (eq? res (if #f #f)))
+ (write res)))))))
+ (with-signal-handler
+ signal/interrupt
+ (lambda (n) (thread-terminate! thread))
+ (lambda () (thread-start! thread) (thread-join! thread)))))
+ (newline)
+ (run-repl module env)))))
(define (repl)
- (set-signal-action! signal/interrupt
- (lambda (n info)
- (newline)
- (run-repl #f (interaction-environment))))
- (current-exception-handler
- (lambda (exn)
- (print-exception exn (current-error-port))
- (run-repl #f (interaction-environment))))
(run-repl #f (interaction-environment)))
diff --git a/lib/chibi/term/edit-line.scm b/lib/chibi/term/edit-line.scm
index c3b022ea..1c985919 100644
--- a/lib/chibi/term/edit-line.scm
+++ b/lib/chibi/term/edit-line.scm
@@ -367,7 +367,12 @@
(buffer-goto! buf out (- (buffer-pos buf) 1)))
(define (command/forward-delete-char ch buf out return)
- (buffer-delete! buf out (buffer-pos buf) (+ (buffer-pos buf) 1)))
+ (cond
+ ((zero? (- (buffer-length buf) (buffer-min buf)))
+ (newline out)
+ (return 'eof))
+ (else
+ (buffer-delete! buf out (buffer-pos buf) (+ (buffer-pos buf) 1)))))
(define (command/backward-delete-char ch buf out return)
(buffer-delete! buf out (- (buffer-pos buf) 1) (buffer-pos buf)))
@@ -443,7 +448,7 @@
(let* ((width (or terminal-width (get-terminal-width out)))
(buf (make-buffer))
(done? #f)
- (return (lambda o (set! done? #t))))
+ (return (lambda o (set! done? (if (pair? o) (car o) #t)))))
(buffer-refresh?-set! buf #t)
(buffer-width-set! buf width)
(buffer-insert! buf out prompt)
@@ -457,7 +462,8 @@
(let lp ((kmap keymap))
(let ((ch (read-char in)))
(if (eof-object? ch)
- (buffer->string buf)
+ (let ((res (buffer->string buf)))
+ (if (equal? res "") ch res))
(let ((x (keymap-lookup kmap (char->integer ch))))
(cond
((keymap? x)
@@ -465,7 +471,9 @@
((procedure? x)
(x ch buf out return)
(buffer-refresh buf out)
- (if done? (buffer->string buf) (lp keymap)))
+ (if done?
+ (and (not (eq? done? 'eof)) (buffer->string buf))
+ (lp keymap)))
(else
;;(command/beep ch buf out return)
(lp keymap)))))))))))))