ice-9/threads.scm

   1 ;;;;    Copyright (C) 1996, 1998 Free Software Foundation, Inc.
   2 ;;;;
   3 ;;;; This program is free software; you can redistribute it and/or modify
   4 ;;;; it under the terms of the GNU General Public License as published by
   5 ;;;; the Free Software Foundation; either version 2, or (at your option)
   6 ;;;; any later version.
   7 ;;;;
   8 ;;;; This program is distributed in the hope that it will be useful,
   9 ;;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
  10 ;;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
  11 ;;;; GNU General Public License for more details.
  12 ;;;;
  13 ;;;; You should have received a copy of the GNU General Public License
  14 ;;;; along with this software; see the file COPYING.  If not, write to
  15 ;;;; the Free Software Foundation, Inc., 59 Temple Place, Suite 330,
  16 ;;;; Boston, MA 02111-1307 USA
  17 ;;;;
  18 ;;;; ----------------------------------------------------------------
  19 ;;;; threads.scm -- User-level interface to Guile's thread system
  20 ;;;; 4 March 1996, Anthony Green <green@cygnus.com>
  21 ;;;; Modified 5 October 1996, MDJ <djurfeldt@nada.kth.se>
  22 ;;;; ----------------------------------------------------------------
  23 ;;;;
  24 \f
  25
  26 (define-module (ice-9 threads))
  27
  28 \f
  29
  30 ; --- MACROS -------------------------------------------------------
  31
  32 (define-public (%thread-handler tag . args)
  33   (fluid-set! the-last-stack #f)
  34   (unmask-signals)
  35   (let ((n (length args))
  36         (p (current-error-port)))
  37   (display "In thread:" p)
  38   (newline p)
  39   (if (>= n 3)
  40       (display-error #f
  41                      p
  42                      (car args)
  43                      (cadr args)
  44                      (caddr args)
  45                      (if (= n 4)
  46                          (cadddr args)
  47                          '()))
  48       (begin
  49         (display "uncaught throw to " p)
  50         (display tag p)
  51         (display ": " p)
  52         (display args p)
  53         (newline p)))))
  54
  55 (defmacro-public make-thread (fn . args)
  56   `(call-with-new-thread
  57     (lambda ()
  58       (,fn ,@args))
  59     %thread-handler))
  60
  61 (defmacro-public begin-thread (first . thunk)
  62   `(call-with-new-thread
  63     (lambda ()
  64       (begin
  65         ,first ,@thunk))
  66     %thread-handler))
  67
  68 (defmacro-public with-mutex (m . thunk)
  69   `(dynamic-wind
  70     (lambda () (lock-mutex ,m))
  71     (lambda () (begin ,@thunk))
  72     (lambda () (unlock-mutex ,m))))
  73
  74 (defmacro-public monitor (first . thunk)
  75   `(with-mutex ,(make-mutex)
  76     (begin
  77       ,first ,@thunk)))