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