ice-9/occam-channel.scm

   1 ;;;; Occam-like channels
   2
   3 ;;; Copyright (C) 2003 Free Software Foundation, Inc.
   4 ;;;
   5 ;;; This program is free software; you can redistribute it and/or
   6 ;;; modify it under the terms of the GNU General Public License as
   7 ;;; published by the Free Software Foundation; either version 2, or
   8 ;;; (at your option) 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 GNU
  13 ;;; General Public License for more details.
  14 ;;;
  15 ;;; You should have received a copy of the GNU General Public License
  16 ;;; along with this software; 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 ;;; As a special exception, the Free Software Foundation gives permission
  21 ;;; for additional uses of the text contained in its release of GUILE.
  22 ;;;
  23 ;;; The exception is that, if you link the GUILE library with other files
  24 ;;; to produce an executable, this does not by itself cause the
  25 ;;; resulting executable to be covered by the GNU General Public License.
  26 ;;; Your use of that executable is in no way restricted on account of
  27 ;;; linking the GUILE library code into it.
  28 ;;;
  29 ;;; This exception does not however invalidate any other reasons why
  30 ;;; the executable file might be covered by the GNU General Public License.
  31 ;;;
  32 ;;; This exception applies only to the code released by the
  33 ;;; Free Software Foundation under the name GUILE.  If you copy
  34 ;;; code from other Free Software Foundation releases into a copy of
  35 ;;; GUILE, as the General Public License permits, the exception does
  36 ;;; not apply to the code that you add in this way.  To avoid misleading
  37 ;;; anyone as to the status of such modified files, you must delete
  38 ;;; this exception notice from them.
  39 ;;;
  40 ;;; If you write modifications of your own for GUILE, it is your choice
  41 ;;; whether to permit this exception to apply to your modifications.
  42 ;;; If you do not wish that, delete this exception notice.
  43
  44 (define-module (ice-9 occam-channel)
  45   #:use-module (oop goops)
  46   #:use-module (ice-9 threads)
  47   ;;#:export-syntax (alt)
  48   #:export (make-channel
  49             ?
  50             !
  51             make-timer
  52             )
  53   )
  54
  55 (define no-data '(no-data))
  56 (define receiver-waiting '(receiver-waiting))
  57
  58 (define-class <channel> ())
  59
  60 (define-class <data-channel> (<channel>)
  61   (data #:accessor data #:init-value no-data)
  62   (cv #:accessor cv #:init-form (make-condition-variable))
  63   (mutex #:accessor mutex #:init-form (make-mutex)))
  64
  65 (define-method (make-channel)
  66   (make <data-channel>))
  67
  68 (define-method (? (ch <data-channel>))
  69   (lock-mutex (mutex ch))
  70   (cond ((eq? (data ch) no-data)
  71          (set! (data ch) receiver-waiting)
  72          (wait-condition-variable (cv ch) (mutex ch)))
  73         ((eq? (data ch) receiver-waiting)
  74          (unlock-mutex (mutex ch))
  75          (scm-error 'misc-error '? "another process is already receiving on ~A"
  76                     (list ch) #f))
  77         (else
  78          ;; sender is waiting
  79          (signal-condition-variable (cv ch))))
  80   (let ((res (data ch)))
  81     (set! (data ch) no-data)
  82     (unlock-mutex (mutex ch))
  83     res))
  84
  85 (define-method (! (ch <data-channel>))
  86   (! ch *unspecified*))
  87
  88 (define-method (! (ch <data-channel>) (x <top>))
  89   (lock-mutex (mutex ch))
  90   (cond ((eq? (data ch) no-data)
  91          (set! (data ch) x)
  92          (wait-condition-variable (cv ch) (mutex ch)))
  93         ((eq? (data ch) receiver-waiting)
  94          (set! (data ch) x)
  95          (signal-condition-variable (cv ch)))
  96         (else
  97          (unlock-mutex (mutex ch))
  98          (scm-error 'misc-error '! "another process is already sending on ~A"
  99                     (list ch) #f)))
 100   (unlock-mutex (mutex ch)))
 101
 102 ;;; Add protocols?
 103
 104 (define-class <port-channel> (<channel>)
 105   (port #:accessor port #:init-keyword #:port))
 106
 107 (define-method (make-channel (port <port>))
 108   (make <port-channel> #:port port))
 109
 110 (define-method (? (ch <port-channel>))
 111   (read (port ch)))
 112
 113 (define-method (! (ch <port-channel>))
 114   (write (port ch)))
 115
 116 (define-class <timer-channel> (<channel>))
 117
 118 (define the-timer (make <timer-channel>))
 119
 120 (define timer-cv (make-condition-variable))
 121 (define timer-mutex (make-mutex))
 122
 123 (define (make-timer)
 124   the-timer)
 125
 126 (define (timeofday->us t)
 127   (+ (* 1000000 (car t)) (cdr t)))
 128
 129 (define (us->timeofday n)
 130   (cons (quotient n 1000000)
 131         (remainder n 1000000)))
 132
 133 (define-method (? (ch <timer-channel>))
 134   (timeofday->us (gettimeofday)))
 135
 136 (define-method (? (ch <timer-channel>) (t <integer>))
 137   (lock-mutex timer-mutex)
 138   (wait-condition-variable timer-cv timer-mutex (us->timeofday t))
 139   (unlock-mutex timer-mutex))
 140