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