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. | |
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; 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. | |
19 | ||
20 | ;;; Code: | |
21 | ||
1c446a7f | 22 | (define-module (ice-9 channel)) |
2d857fb1 KN |
23 | |
24 | ;;; | |
25 | ;;; Channel type | |
26 | ;;; | |
27 | ||
28 | (define channel-type | |
29 | (make-record-type 'channel '(stdin stdout printer token-module))) | |
30 | ||
31 | (define make-channel (record-constructor channel-type)) | |
32 | ||
1c446a7f | 33 | (define-public (make-object-channel printer) |
2d857fb1 KN |
34 | (make-channel (current-input-port) |
35 | (current-output-port) | |
36 | printer | |
37 | (make-module))) | |
38 | ||
39 | (define channel-stdin (record-accessor channel-type 'stdin)) | |
40 | (define channel-stdout (record-accessor channel-type 'stdout)) | |
41 | (define channel-printer (record-accessor channel-type 'printer)) | |
42 | (define channel-token-module (record-accessor channel-type 'token-module)) | |
43 | ||
44 | ;;; | |
45 | ;;; Channel | |
46 | ;;; | |
47 | ||
1c446a7f | 48 | (define-public (channel-open ch) |
2d857fb1 KN |
49 | (let ((stdin (channel-stdin ch)) |
50 | (stdout (channel-stdout ch)) | |
51 | (printer (channel-printer ch)) | |
52 | (token-module (channel-token-module ch))) | |
53 | (let loop () | |
54 | (catch #t | |
55 | (lambda () | |
56 | (channel:prompt stdout) | |
57 | (let ((cmd (read stdin))) | |
58 | (if (eof-object? cmd) | |
59 | (throw 'quit) | |
60 | (case cmd | |
61 | ((eval) | |
62 | (module-use! (current-module) token-module) | |
63 | (printer ch (eval (read stdin) (current-module)))) | |
64 | ((destroy) | |
65 | (let ((token (read stdin))) | |
66 | (if (module-defined? token-module token) | |
67 | (module-remove! token-module token) | |
68 | (channel:error stdout "Invalid token: ~S" token)))) | |
69 | ((quit) | |
70 | (throw 'quit)) | |
71 | (else | |
72 | (channel:error stdout "Unknown command: ~S" cmd))))) | |
73 | (loop)) | |
74 | (lambda (key . args) | |
75 | (case key | |
76 | ((quit) (throw 'quit)) | |
77 | (else | |
78 | (format stdout "exception = ~S\n" | |
79 | (list key (apply format #f (cadr args) (caddr args)))) | |
80 | (loop)))))))) | |
81 | ||
1c446a7f | 82 | (define-public (channel-print-value ch val) |
2d857fb1 KN |
83 | (format (channel-stdout ch) "value = ~S\n" val)) |
84 | ||
1c446a7f | 85 | (define-public (channel-print-token ch val) |
2d857fb1 KN |
86 | (let* ((token (symbol-append (gensym "%%") '%%)) |
87 | (pair (cons token (object->string val)))) | |
88 | (format (channel-stdout ch) "token = ~S\n" pair) | |
89 | (module-define! (channel-token-module ch) token val))) | |
90 | ||
91 | (define (channel:prompt port) | |
92 | (display "channel> " port) | |
93 | (force-output port)) | |
94 | ||
95 | (define (channel:error port msg . args) | |
96 | (display "ERROR: " port) | |
97 | (apply format port msg args) | |
98 | (newline port)) | |
1c446a7f KN |
99 | |
100 | ;;; | |
101 | ;;; Guile 1.4 compatibility | |
102 | ;;; | |
103 | ||
104 | (define guile:eval eval) | |
105 | (define eval | |
106 | (if (= (car (procedure-property guile:eval 'arity)) 1) | |
107 | (lambda (x e) (guile:eval x)) | |
108 | guile:eval)) | |
109 | ||
110 | (define object->string | |
111 | (if (defined? 'object->string) | |
112 | object->string | |
113 | (lambda (x) (format #f "~S" x)))) |