Commit | Line | Data |
---|---|---|
2d857fb1 KN |
1 | ;;; Guile object channel |
2 | ||
3fc7e2c1 | 3 | ;; Copyright (C) 2001, 2006, 2009, 2010 Free Software Foundation, Inc. |
2d857fb1 | 4 | |
53befeb7 NJ |
5 | ;;;; This library is free software; you can redistribute it and/or |
6 | ;;;; modify it under the terms of the GNU Lesser General Public | |
7 | ;;;; License as published by the Free Software Foundation; either | |
8 | ;;;; version 3 of the License, or (at your option) any later version. | |
9 | ;;;; | |
10 | ;;;; This library 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 GNU | |
13 | ;;;; Lesser General Public License for more details. | |
14 | ;;;; | |
15 | ;;;; You should have received a copy of the GNU Lesser General Public | |
16 | ;;;; License along with this library; if not, write to the Free Software | |
17 | ;;;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA | |
2d857fb1 | 18 | |
cd96d7e6 TTN |
19 | ;;; Commentary: |
20 | ||
21 | ;; Now you can use Guile's modules in Emacs Lisp like this: | |
22 | ;; | |
23 | ;; (guile-import current-module) | |
24 | ;; (guile-import module-ref) | |
25 | ;; | |
26 | ;; (setq assq (module-ref (current-module) 'assq)) | |
27 | ;; => ("<guile>" %%1%% . "#<primitive-procedure assq>") | |
28 | ;; | |
29 | ;; (guile-use-modules (ice-9 documentation)) | |
30 | ;; | |
31 | ;; (object-documentation assq) | |
32 | ;; => | |
33 | ;; " - primitive: assq key alist | |
34 | ;; - primitive: assv key alist | |
35 | ;; - primitive: assoc key alist | |
36 | ;; Fetches the entry in ALIST that is associated with KEY. To decide | |
37 | ;; whether the argument KEY matches a particular entry in ALIST, | |
38 | ;; `assq' compares keys with `eq?', `assv' uses `eqv?' and `assoc' | |
39 | ;; uses `equal?'. If KEY cannot be found in ALIST (according to | |
40 | ;; whichever equality predicate is in use), then `#f' is returned. | |
41 | ;; These functions return the entire alist entry found (i.e. both the | |
42 | ;; key and the value)." | |
43 | ;; | |
44 | ;; Probably we can use GTK in Emacs Lisp. Can anybody try it? | |
45 | ;; | |
46 | ;; I have also implemented Guile Scheme mode and Scheme Interaction mode. | |
47 | ;; Just put the following lines in your ~/.emacs: | |
48 | ;; | |
49 | ;; (require 'guile-scheme) | |
50 | ;; (setq initial-major-mode 'scheme-interaction-mode) | |
51 | ;; | |
52 | ;; Currently, the following commands are available: | |
53 | ;; | |
54 | ;; M-TAB guile-scheme-complete-symbol | |
55 | ;; M-C-x guile-scheme-eval-define | |
56 | ;; C-x C-e guile-scheme-eval-last-sexp | |
57 | ;; C-c C-b guile-scheme-eval-buffer | |
58 | ;; C-c C-r guile-scheme-eval-region | |
59 | ;; C-c : guile-scheme-eval-expression | |
60 | ;; | |
61 | ;; I'll write more commands soon, or if you want to hack, please take | |
62 | ;; a look at the following files: | |
63 | ;; | |
64 | ;; guile-core/ice-9/channel.scm ;; object channel | |
65 | ;; guile-core/emacs/guile.el ;; object adapter | |
66 | ;; guile-core/emacs/guile-emacs.scm ;; Guile <-> Emacs channels | |
67 | ;; guile-core/emacs/guile-scheme.el ;; Guile Scheme mode | |
68 | ;; | |
69 | ;; As always, there are more than one bugs ;) | |
70 | ||
2d857fb1 KN |
71 | ;;; Code: |
72 | ||
1a179b03 MD |
73 | (define-module (ice-9 channel) |
74 | :export (make-object-channel | |
75 | channel-open | |
76 | channel-print-value | |
77 | channel-print-token)) | |
2d857fb1 KN |
78 | |
79 | ;;; | |
80 | ;;; Channel type | |
81 | ;;; | |
82 | ||
83 | (define channel-type | |
84 | (make-record-type 'channel '(stdin stdout printer token-module))) | |
85 | ||
86 | (define make-channel (record-constructor channel-type)) | |
87 | ||
1a179b03 | 88 | (define (make-object-channel printer) |
2d857fb1 KN |
89 | (make-channel (current-input-port) |
90 | (current-output-port) | |
91 | printer | |
92 | (make-module))) | |
93 | ||
94 | (define channel-stdin (record-accessor channel-type 'stdin)) | |
95 | (define channel-stdout (record-accessor channel-type 'stdout)) | |
96 | (define channel-printer (record-accessor channel-type 'printer)) | |
97 | (define channel-token-module (record-accessor channel-type 'token-module)) | |
98 | ||
99 | ;;; | |
100 | ;;; Channel | |
101 | ;;; | |
102 | ||
1a179b03 | 103 | (define (channel-open ch) |
2d857fb1 KN |
104 | (let ((stdin (channel-stdin ch)) |
105 | (stdout (channel-stdout ch)) | |
106 | (printer (channel-printer ch)) | |
107 | (token-module (channel-token-module ch))) | |
108 | (let loop () | |
109 | (catch #t | |
110 | (lambda () | |
111 | (channel:prompt stdout) | |
112 | (let ((cmd (read stdin))) | |
113 | (if (eof-object? cmd) | |
114 | (throw 'quit) | |
115 | (case cmd | |
116 | ((eval) | |
117 | (module-use! (current-module) token-module) | |
118 | (printer ch (eval (read stdin) (current-module)))) | |
119 | ((destroy) | |
120 | (let ((token (read stdin))) | |
121 | (if (module-defined? token-module token) | |
122 | (module-remove! token-module token) | |
123 | (channel:error stdout "Invalid token: ~S" token)))) | |
124 | ((quit) | |
125 | (throw 'quit)) | |
126 | (else | |
127 | (channel:error stdout "Unknown command: ~S" cmd))))) | |
128 | (loop)) | |
129 | (lambda (key . args) | |
130 | (case key | |
131 | ((quit) (throw 'quit)) | |
132 | (else | |
133 | (format stdout "exception = ~S\n" | |
134 | (list key (apply format #f (cadr args) (caddr args)))) | |
135 | (loop)))))))) | |
136 | ||
1a179b03 | 137 | (define (channel-print-value ch val) |
2d857fb1 KN |
138 | (format (channel-stdout ch) "value = ~S\n" val)) |
139 | ||
1a179b03 | 140 | (define (channel-print-token ch val) |
2d857fb1 KN |
141 | (let* ((token (symbol-append (gensym "%%") '%%)) |
142 | (pair (cons token (object->string val)))) | |
143 | (format (channel-stdout ch) "token = ~S\n" pair) | |
144 | (module-define! (channel-token-module ch) token val))) | |
145 | ||
146 | (define (channel:prompt port) | |
147 | (display "channel> " port) | |
148 | (force-output port)) | |
149 | ||
150 | (define (channel:error port msg . args) | |
151 | (display "ERROR: " port) | |
152 | (apply format port msg args) | |
153 | (newline port)) | |
1c446a7f KN |
154 | |
155 | ;;; | |
156 | ;;; Guile 1.4 compatibility | |
157 | ;;; | |
158 | ||
159 | (define guile:eval eval) | |
160 | (define eval | |
3fc7e2c1 | 161 | (if (= (car (procedure-minimum-arity guile:eval)) 1) |
5658035c | 162 | (lambda (x e) (guile:eval x e)) |
1c446a7f KN |
163 | guile:eval)) |
164 | ||
165 | (define object->string | |
166 | (if (defined? 'object->string) | |
167 | object->string | |
168 | (lambda (x) (format #f "~S" x)))) | |
cd96d7e6 TTN |
169 | |
170 | ;;; channel.scm ends here |