| 1 | ;;; Guile object channel |
| 2 | |
| 3 | ;; Copyright (C) 2001, 2006 Free Software Foundation, Inc. |
| 4 | |
| 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 2.1 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 |
| 18 | |
| 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 | |
| 71 | ;;; Code: |
| 72 | |
| 73 | (define-module (ice-9 channel) |
| 74 | :export (make-object-channel |
| 75 | channel-open |
| 76 | channel-print-value |
| 77 | channel-print-token)) |
| 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 | |
| 88 | (define (make-object-channel printer) |
| 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 | |
| 103 | (define (channel-open ch) |
| 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 | |
| 137 | (define (channel-print-value ch val) |
| 138 | (format (channel-stdout ch) "value = ~S\n" val)) |
| 139 | |
| 140 | (define (channel-print-token ch val) |
| 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)) |
| 154 | |
| 155 | ;;; |
| 156 | ;;; Guile 1.4 compatibility |
| 157 | ;;; |
| 158 | |
| 159 | (define guile:eval eval) |
| 160 | (define eval |
| 161 | (if (= (car (procedure-property guile:eval 'arity)) 1) |
| 162 | (lambda (x e) (guile:eval x)) |
| 163 | guile:eval)) |
| 164 | |
| 165 | (define object->string |
| 166 | (if (defined? 'object->string) |
| 167 | object->string |
| 168 | (lambda (x) (format #f "~S" x)))) |
| 169 | |
| 170 | ;;; channel.scm ends here |