File: repl.scm

package info (click to toggle)
guile-gtk-1.2 0.31-3
  • links: PTS
  • area: main
  • in suites: sarge
  • size: 2,544 kB
  • ctags: 2,413
  • sloc: sh: 11,073; ansic: 3,380; lisp: 1,058; makefile: 106
file content (181 lines) | stat: -rw-r--r-- 4,641 bytes parent folder | download | duplicates (2)
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
(define-module (gtk-1.2 repl)
  :use-module (gtk-1.2 gtk)
  :use-module (gtk-1.2 gdk)
  :use-module (gtk-1.2 threads))

;; A event driven repl

(define eof-object (with-input-from-string "" read))

(define-public repl-error-stack car)
(define-public repl-error-args cadr)

(define-public (make-event-repl read eval print error-reporter)
  (let ((the-last-stack #f)
	(stack-saved?   #f)

	(buffer  "")
	(bufpos  0)
	(readeof #f))

    (define (save-stack)
      (cond (stack-saved?)
	    ((not (memq 'debug (debug-options-interface)))
	     (set! the-last-stack #f)
	     (set! stack-saved? #t))
	    (else
	     (set! the-last-stack (make-stack #t lazy-dispatch 4))
	     (set! stack-saved? #t))))

    (define (lazy-dispatch . args)
      (save-stack)
      (apply throw args))
    
    (define (catch-stacked thunk handler)
      (set! stack-saved? #f)
      (start-stack #t
		   (catch #t
			  (lambda ()
			    (lazy-catch #t
					thunk
					lazy-dispatch))
			  (lambda args
			    (if (= (length args) 5)
				(handler 
				 (list (if stack-saved?
					   the-last-stack #f)
				       args))
				(apply throw args))))))

    (define (bufeof?)
      (>= bufpos (string-length buffer)))

    (define (discardbuf)
      (set! buffer (substring buffer bufpos))
      (set! bufpos 0))

    (define bufport (make-soft-port
		     (vector #f #f #f
			     (lambda ()
			       (cond ((bufeof?)
				      (set! readeof #t)
				      #f)
				     (else
				      (let ((ch (string-ref buffer bufpos)))
					(set! bufpos (1+ bufpos))
					ch))))
			     #f)
		     "r"))

    (define (tryread)
      (set! readeof #f)
      (set! bufpos 0)
      (let ((val
	     (catch-stacked
	      (lambda () (read bufport))
	      (lambda (data)
		;; when READ gets an error but has consumed the whole
		;; buffer, we assume it is some kind of `premature end
		;; of input` condition.
		(cond ((not readeof)
		       (error-reporter data)
		       (discardbuf)))
		eof-object))))
	(if (not (eof-object? val))
	    (discardbuf))
	val))

    (define (evalbuf)
      (let loop ((form (tryread)))
	(if (not (eof-object? form))
	    (let* ((throw-args #f)
		   (ans (catch-stacked
			 (lambda () (eval form (current-module)))
			 (lambda args (set! throw-args args)))))
	      (if throw-args
		  (apply error-reporter throw-args)
		  (print ans))
	      (loop (tryread))))))
      
    (lambda (op . args)
      (case op
	((input)
	 (set! buffer (string-append buffer (car args)))
	 (evalbuf))
	((pending?)
	 (not (bufeof?)))))))

(define-public (repl-input repl str)
  (repl 'input str))

(define-public (repl-pending? repl)
  (repl 'pending?))

(define-public (repl-display-error data . opt-port)
  (let ((port (if (null? opt-port) (current-error-port) (car opt-port))))
    (apply display-error (repl-error-stack data) port 
	   (cdr (repl-error-args data)))))

(define-public (repl-display-backtrace data . opt-port)
  (let ((port (if (null? opt-port) (current-error-port) (car opt-port))))
    (if (repl-error-stack data)
	(display-backtrace (repl-error-stack data) port))))

;; The Gtk repl that doesn't use threads.

(define-public (gtk-event-repl)
  (define inport (current-input-port))
  (define outport (current-output-port))

  (define unspecified (if #f #f))
  (define (prompt)
    (display "gtk> " outport)
    (force-output outport))
  (define (print val)
    (cond ((not (eq? unspecified val))
	   (write val outport)
	   (newline outport)))
    (prompt))
  (define (report data)
    (repl-display-backtrace data outport)
    (repl-display-error data outport)
    (prompt))
  (define (nonblocking-read port)
    (let loop ((res '()))
      (if (char-ready? port)
	  (let ((ch (read-char port)))
	    (if (eof-object? ch)
		(if (null? res)
		    ch 
		    (apply string (reverse res)))
		(loop (cons ch res))))
	  (apply string (reverse res)))))

  (let ((repl (make-event-repl read eval print report)))
    (gtk-input-add inport
		   '(read)
		   (lambda (source condition)
		     (catch 'quit
			    (lambda ()
			      (let ((str (nonblocking-read inport)))
				(if (eof-object? str)
				    (gtk-exit)
				    (repl-input repl str))))
			    (lambda (key . args)
			      (gtk-exit (if (null? args) 0 (car args)))))))
    (prompt)
    (gtk-main)))

;; The default Gtk repl.

(define-public (gtk-repl)
  (cond
   ((feature? 'threads)
    (let ((guile-user (resolve-module '(guile-user))))
      (module-use! guile-user (resolve-interface '(gtk gtk)))
      (module-use! guile-user (resolve-interface '(gtk gdk)))
      (gtk-threads-ensure-handler)
      (add-hook! before-read-hook gdk-flush)
      (top-repl)))
   (else
    (gtk-event-repl))))