module/guile/channel.scm

   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
  22 (define-module (guile channel)
  23   :use-syntax (system base syntax)
  24   :export (open-object-channel))
  25
  26 (define-record (<channel> (stdin (current-input-port))
  27                           (stdout (current-output-port))
  28                           (token-module (make-module))))
  29
  30 (define (make-channel) (<channel>))
  31
  32 (define (native-type? x)
  33   (or (boolean? x) (integer? x) (null? x) (symbol? x) (string? x)
  34       (pair? x) (vector? x)))
  35
  36 (define (open-object-channel)
  37   (let ((ch (make-channel)))
  38     (let loop ()
  39       (catch #t
  40         (lambda ()
  41           (channel:prompt ch)
  42           (let ((cmd (read ch.stdin)))
  43             (if (eof-object? cmd)
  44               (throw 'quit)
  45               (case cmd
  46                 ((eval)
  47                  (module-use! (current-module) ch.token-module)
  48                  (let ((val (eval (read ch.stdin) (current-module))))
  49                    (if (native-type? val)
  50                      (format ch.stdout "value = ~S\n" val)
  51                      (let* ((token (gensym "%object-token%"))
  52                             (pair (cons token (object->string val))))
  53                        (format ch.stdout "token = ~S\n" pair)
  54                        (module-define! ch.token-module token val)))))
  55                 ((destroy)
  56                  (let ((token (read ch.stdin)))
  57                    (if (module-defined? ch.token-module token)
  58                      (module-remove! ch.token-module token)
  59                      (channel:error ch "Invalid token: ~S" token))))
  60                 ((quit)
  61                  (throw 'quit))
  62                 (else
  63                  (channel:error ch "Unknown command: ~S" cmd)))))
  64           (loop))
  65         (lambda args
  66           (case (car args)
  67             ((quit) (throw 'quit))
  68             (else
  69              (format ch.stdout "exception = ~S\n" args)
  70              (loop))))))))
  71
  72 (define (channel:prompt ch)
  73   (display "channel> " ch.stdout)
  74   (force-output ch.stdout))
  75
  76 (define (channel:error ch msg . args)
  77   (display "ERROR: " ch.stdout)
  78   (apply format ch.stdout msg args)
  79   (newline ch.stdout))