Commit | Line | Data |
---|---|---|
2d857fb1 KN |
1 | ;;; Guile object channel |
2 | ||
3 | ;; Copyright (C) 2001 Free Software Foundation, Inc. | |
4 | ||
5 | ;; This program is free software; you can redistribute it and/or modify | |
6 | ;; it under the terms of the GNU General Public License as published by | |
7 | ;; the Free Software Foundation; either version 2, or (at your option) | |
8 | ;; any later version. | |
cd96d7e6 | 9 | ;; |
2d857fb1 KN |
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. | |
cd96d7e6 | 14 | ;; |
2d857fb1 KN |
15 | ;; You should have received a copy of the GNU General Public License |
16 | ;; along with this program; see the file COPYING. If not, write to | |
17 | ;; the Free Software Foundation, Inc., 59 Temple Place - Suite 330, | |
18 | ;; Boston, MA 02111-1307, USA. | |
a482f2cc MV |
19 | ;; |
20 | ;; As a special exception, the Free Software Foundation gives permission | |
21 | ;; for additional uses of the text contained in its release of GUILE. | |
22 | ;; | |
23 | ;; The exception is that, if you link the GUILE library with other files | |
24 | ;; to produce an executable, this does not by itself cause the | |
25 | ;; resulting executable to be covered by the GNU General Public License. | |
26 | ;; Your use of that executable is in no way restricted on account of | |
27 | ;; linking the GUILE library code into it. | |
28 | ;; | |
29 | ;; This exception does not however invalidate any other reasons why | |
30 | ;; the executable file might be covered by the GNU General Public License. | |
31 | ;; | |
32 | ;; This exception applies only to the code released by the | |
33 | ;; Free Software Foundation under the name GUILE. If you copy | |
34 | ;; code from other Free Software Foundation releases into a copy of | |
35 | ;; GUILE, as the General Public License permits, the exception does | |
36 | ;; not apply to the code that you add in this way. To avoid misleading | |
37 | ;; anyone as to the status of such modified files, you must delete | |
38 | ;; this exception notice from them. | |
39 | ;; | |
40 | ;; If you write modifications of your own for GUILE, it is your choice | |
41 | ;; whether to permit this exception to apply to your modifications. | |
42 | ;; If you do not wish that, delete this exception notice. | |
2d857fb1 | 43 | |
cd96d7e6 TTN |
44 | ;;; Commentary: |
45 | ||
46 | ;; Now you can use Guile's modules in Emacs Lisp like this: | |
47 | ;; | |
48 | ;; (guile-import current-module) | |
49 | ;; (guile-import module-ref) | |
50 | ;; | |
51 | ;; (setq assq (module-ref (current-module) 'assq)) | |
52 | ;; => ("<guile>" %%1%% . "#<primitive-procedure assq>") | |
53 | ;; | |
54 | ;; (guile-use-modules (ice-9 documentation)) | |
55 | ;; | |
56 | ;; (object-documentation assq) | |
57 | ;; => | |
58 | ;; " - primitive: assq key alist | |
59 | ;; - primitive: assv key alist | |
60 | ;; - primitive: assoc key alist | |
61 | ;; Fetches the entry in ALIST that is associated with KEY. To decide | |
62 | ;; whether the argument KEY matches a particular entry in ALIST, | |
63 | ;; `assq' compares keys with `eq?', `assv' uses `eqv?' and `assoc' | |
64 | ;; uses `equal?'. If KEY cannot be found in ALIST (according to | |
65 | ;; whichever equality predicate is in use), then `#f' is returned. | |
66 | ;; These functions return the entire alist entry found (i.e. both the | |
67 | ;; key and the value)." | |
68 | ;; | |
69 | ;; Probably we can use GTK in Emacs Lisp. Can anybody try it? | |
70 | ;; | |
71 | ;; I have also implemented Guile Scheme mode and Scheme Interaction mode. | |
72 | ;; Just put the following lines in your ~/.emacs: | |
73 | ;; | |
74 | ;; (require 'guile-scheme) | |
75 | ;; (setq initial-major-mode 'scheme-interaction-mode) | |
76 | ;; | |
77 | ;; Currently, the following commands are available: | |
78 | ;; | |
79 | ;; M-TAB guile-scheme-complete-symbol | |
80 | ;; M-C-x guile-scheme-eval-define | |
81 | ;; C-x C-e guile-scheme-eval-last-sexp | |
82 | ;; C-c C-b guile-scheme-eval-buffer | |
83 | ;; C-c C-r guile-scheme-eval-region | |
84 | ;; C-c : guile-scheme-eval-expression | |
85 | ;; | |
86 | ;; I'll write more commands soon, or if you want to hack, please take | |
87 | ;; a look at the following files: | |
88 | ;; | |
89 | ;; guile-core/ice-9/channel.scm ;; object channel | |
90 | ;; guile-core/emacs/guile.el ;; object adapter | |
91 | ;; guile-core/emacs/guile-emacs.scm ;; Guile <-> Emacs channels | |
92 | ;; guile-core/emacs/guile-scheme.el ;; Guile Scheme mode | |
93 | ;; | |
94 | ;; As always, there are more than one bugs ;) | |
95 | ||
2d857fb1 KN |
96 | ;;; Code: |
97 | ||
1a179b03 MD |
98 | (define-module (ice-9 channel) |
99 | :export (make-object-channel | |
100 | channel-open | |
101 | channel-print-value | |
102 | channel-print-token)) | |
2d857fb1 KN |
103 | |
104 | ;;; | |
105 | ;;; Channel type | |
106 | ;;; | |
107 | ||
108 | (define channel-type | |
109 | (make-record-type 'channel '(stdin stdout printer token-module))) | |
110 | ||
111 | (define make-channel (record-constructor channel-type)) | |
112 | ||
1a179b03 | 113 | (define (make-object-channel printer) |
2d857fb1 KN |
114 | (make-channel (current-input-port) |
115 | (current-output-port) | |
116 | printer | |
117 | (make-module))) | |
118 | ||
119 | (define channel-stdin (record-accessor channel-type 'stdin)) | |
120 | (define channel-stdout (record-accessor channel-type 'stdout)) | |
121 | (define channel-printer (record-accessor channel-type 'printer)) | |
122 | (define channel-token-module (record-accessor channel-type 'token-module)) | |
123 | ||
124 | ;;; | |
125 | ;;; Channel | |
126 | ;;; | |
127 | ||
1a179b03 | 128 | (define (channel-open ch) |
2d857fb1 KN |
129 | (let ((stdin (channel-stdin ch)) |
130 | (stdout (channel-stdout ch)) | |
131 | (printer (channel-printer ch)) | |
132 | (token-module (channel-token-module ch))) | |
133 | (let loop () | |
134 | (catch #t | |
135 | (lambda () | |
136 | (channel:prompt stdout) | |
137 | (let ((cmd (read stdin))) | |
138 | (if (eof-object? cmd) | |
139 | (throw 'quit) | |
140 | (case cmd | |
141 | ((eval) | |
142 | (module-use! (current-module) token-module) | |
143 | (printer ch (eval (read stdin) (current-module)))) | |
144 | ((destroy) | |
145 | (let ((token (read stdin))) | |
146 | (if (module-defined? token-module token) | |
147 | (module-remove! token-module token) | |
148 | (channel:error stdout "Invalid token: ~S" token)))) | |
149 | ((quit) | |
150 | (throw 'quit)) | |
151 | (else | |
152 | (channel:error stdout "Unknown command: ~S" cmd))))) | |
153 | (loop)) | |
154 | (lambda (key . args) | |
155 | (case key | |
156 | ((quit) (throw 'quit)) | |
157 | (else | |
158 | (format stdout "exception = ~S\n" | |
159 | (list key (apply format #f (cadr args) (caddr args)))) | |
160 | (loop)))))))) | |
161 | ||
1a179b03 | 162 | (define (channel-print-value ch val) |
2d857fb1 KN |
163 | (format (channel-stdout ch) "value = ~S\n" val)) |
164 | ||
1a179b03 | 165 | (define (channel-print-token ch val) |
2d857fb1 KN |
166 | (let* ((token (symbol-append (gensym "%%") '%%)) |
167 | (pair (cons token (object->string val)))) | |
168 | (format (channel-stdout ch) "token = ~S\n" pair) | |
169 | (module-define! (channel-token-module ch) token val))) | |
170 | ||
171 | (define (channel:prompt port) | |
172 | (display "channel> " port) | |
173 | (force-output port)) | |
174 | ||
175 | (define (channel:error port msg . args) | |
176 | (display "ERROR: " port) | |
177 | (apply format port msg args) | |
178 | (newline port)) | |
1c446a7f KN |
179 | |
180 | ;;; | |
181 | ;;; Guile 1.4 compatibility | |
182 | ;;; | |
183 | ||
184 | (define guile:eval eval) | |
185 | (define eval | |
186 | (if (= (car (procedure-property guile:eval 'arity)) 1) | |
187 | (lambda (x e) (guile:eval x)) | |
188 | guile:eval)) | |
189 | ||
190 | (define object->string | |
191 | (if (defined? 'object->string) | |
192 | object->string | |
193 | (lambda (x) (format #f "~S" x)))) | |
cd96d7e6 TTN |
194 | |
195 | ;;; channel.scm ends here |