1;; guile-gnome 2;; Copyright (C) 1997 Marius Vollmer <mvo@zagadka.ping.de> 3;; Copyright (C) 2003,2004 Andy Wingo <wingo at pobox dot com> 4 5;; This program is free software; you can redistribute it and/or 6;; modify it under the terms of the GNU General Public License as 7;; published by the Free Software Foundation; either version 2 of 8;; the License, or (at your option) any later version. 9;; 10;; This program is distributed in the hope that it will be useful, 11;; but WITHOUT ANY WARRANTY; without even the implied warranty of 12;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the 13;; GNU General Public License for more details. 14;; 15;; You should have received a copy of the GNU General Public License 16;; along with this program; if not, contact: 17;; 18;; Free Software Foundation Voice: +1-617-542-5942 19;; 59 Temple Place - Suite 330 Fax: +1-617-542-2652 20;; Boston, MA 02111-1307, USA gnu@gnu.org 21 22;;; Commentary: 23;; 24;;An event-driven REPL, taken from guile-gtk 1.2. 25;; 26;;; Code: 27 28(define-module (gnome gobject event-repl)) 29 30(define eof-object (with-input-from-string "" read)) 31 32(define-public repl-error-stack car) 33(define-public repl-error-args cadr) 34 35(define-public (make-event-repl read eval print error-reporter) 36 (let ((the-last-stack #f) 37 (stack-saved? #f) 38 39 (buffer "") 40 (bufpos 0) 41 (readeof #f)) 42 43 (define (save-stack) 44 (cond (stack-saved?) 45 ((not (memq 'debug (debug-options-interface))) 46 (set! the-last-stack #f) 47 (set! stack-saved? #t)) 48 (else 49 (set! the-last-stack (make-stack #t lazy-dispatch 4)) 50 (set! stack-saved? #t)))) 51 52 (define (lazy-dispatch . args) 53 (save-stack) 54 (apply throw args)) 55 56 (define (catch-stacked thunk handler) 57 (set! stack-saved? #f) 58 (start-stack #t 59 (catch #t 60 (lambda () 61 (lazy-catch #t 62 thunk 63 lazy-dispatch)) 64 (lambda args 65 (if (= (length args) 5) 66 (handler 67 (list (if stack-saved? 68 the-last-stack #f) 69 args)) 70 (apply throw args)))))) 71 72 (define (bufeof?) 73 (>= bufpos (string-length buffer))) 74 75 (define (discardbuf) 76 (set! buffer (substring buffer bufpos)) 77 (set! bufpos 0)) 78 79 (define bufport (make-soft-port 80 (vector #f #f #f 81 (lambda () 82 (cond ((bufeof?) 83 (set! readeof #t) 84 #f) 85 (else 86 (let ((ch (string-ref buffer bufpos))) 87 (set! bufpos (1+ bufpos)) 88 ch)))) 89 #f) 90 "r")) 91 92 (define (tryread) 93 (set! readeof #f) 94 (set! bufpos 0) 95 (let ((val 96 (catch-stacked 97 (lambda () (read bufport)) 98 (lambda (data) 99 ;; when READ gets an error but has consumed the whole 100 ;; buffer, we assume it is some kind of `premature end 101 ;; of input` condition. 102 (cond ((not readeof) 103 (error-reporter data) 104 (discardbuf))) 105 eof-object)))) 106 (if (not (eof-object? val)) 107 (discardbuf)) 108 val)) 109 110 (define (evalbuf) 111 (let loop ((form (tryread))) 112 (if (not (eof-object? form)) 113 (let* ((throw-args #f) 114 (ans (catch-stacked 115 (lambda () (eval form)) 116 (lambda args (set! throw-args args))))) 117 (if throw-args 118 (apply error-reporter throw-args) 119 (print ans)) 120 (loop (tryread)))))) 121 122 (lambda (op . args) 123 (case op 124 ((input) 125 (set! buffer (string-append buffer (car args))) 126 (evalbuf)) 127 ((pending?) 128 (not (bufeof?))))))) 129 130(define-public (repl-input repl str) 131 (repl 'input str)) 132 133(define-public (repl-pending? repl) 134 (repl 'pending?)) 135 136(define-public (repl-display-error data . opt-port) 137 (let ((port (if (null? opt-port) (current-error-port) (car opt-port)))) 138 (apply display-error (repl-error-stack data) port 139 (cdr (repl-error-args data))))) 140 141(define-public (repl-display-backtrace data . opt-port) 142 (let ((port (if (null? opt-port) (current-error-port) (car opt-port)))) 143 (if (repl-error-stack data) 144 (display-backtrace (repl-error-stack data) port)))) 145