Commit | Line | Data |
---|---|---|
c7a813af TTN |
1 | ;;;; Copyright (C) 1996, 1998, 2001 Free Software Foundation, Inc. |
2 | ;;;; | |
1188fb05 MD |
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. | |
c7a813af | 7 | ;;;; |
1188fb05 MD |
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. | |
c7a813af | 12 | ;;;; |
1188fb05 MD |
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 | |
15328041 JB |
15 | ;;;; the Free Software Foundation, Inc., 59 Temple Place, Suite 330, |
16 | ;;;; Boston, MA 02111-1307 USA | |
1188fb05 | 17 | ;;;; |
a482f2cc MV |
18 | ;;;; As a special exception, the Free Software Foundation gives permission |
19 | ;;;; for additional uses of the text contained in its release of GUILE. | |
20 | ;;;; | |
21 | ;;;; The exception is that, if you link the GUILE library with other files | |
22 | ;;;; to produce an executable, this does not by itself cause the | |
23 | ;;;; resulting executable to be covered by the GNU General Public License. | |
24 | ;;;; Your use of that executable is in no way restricted on account of | |
25 | ;;;; linking the GUILE library code into it. | |
26 | ;;;; | |
27 | ;;;; This exception does not however invalidate any other reasons why | |
28 | ;;;; the executable file might be covered by the GNU General Public License. | |
29 | ;;;; | |
30 | ;;;; This exception applies only to the code released by the | |
31 | ;;;; Free Software Foundation under the name GUILE. If you copy | |
32 | ;;;; code from other Free Software Foundation releases into a copy of | |
33 | ;;;; GUILE, as the General Public License permits, the exception does | |
34 | ;;;; not apply to the code that you add in this way. To avoid misleading | |
35 | ;;;; anyone as to the status of such modified files, you must delete | |
36 | ;;;; this exception notice from them. | |
37 | ;;;; | |
38 | ;;;; If you write modifications of your own for GUILE, it is your choice | |
39 | ;;;; whether to permit this exception to apply to your modifications. | |
40 | ;;;; If you do not wish that, delete this exception notice. | |
41 | ;;;; | |
1188fb05 MD |
42 | ;;;; ---------------------------------------------------------------- |
43 | ;;;; threads.scm -- User-level interface to Guile's thread system | |
44 | ;;;; 4 March 1996, Anthony Green <green@cygnus.com> | |
45 | ;;;; Modified 5 October 1996, MDJ <djurfeldt@nada.kth.se> | |
c7a813af | 46 | ;;;; Modified 6 April 2001, ttn |
1188fb05 MD |
47 | ;;;; ---------------------------------------------------------------- |
48 | ;;;; | |
49 | \f | |
e7d82feb TTN |
50 | ;;; Commentary: |
51 | ||
52 | ;; This module is documented in the Guile Reference Manual. | |
53 | ;; Briefly, one procedure is exported: `%thread-handler'; | |
54 | ;; as well as four macros: `make-thread', `begin-thread', | |
55 | ;; `with-mutex' and `monitor'. | |
56 | ||
57 | ;;; Code: | |
1188fb05 | 58 | |
1a179b03 MD |
59 | (define-module (ice-9 threads) |
60 | :export-syntax (make-thread | |
61 | begin-thread | |
62 | with-mutex | |
63 | monitor) | |
64 | :export (%thread-handler)) | |
1188fb05 MD |
65 | |
66 | \f | |
67 | ||
c7a813af | 68 | (define (%thread-handler tag . args) |
13dc0cae MD |
69 | (fluid-set! the-last-stack #f) |
70 | (unmask-signals) | |
71 | (let ((n (length args)) | |
72 | (p (current-error-port))) | |
c7a813af TTN |
73 | (display "In thread:" p) |
74 | (newline p) | |
75 | (if (>= n 3) | |
76 | (display-error #f | |
77 | p | |
78 | (car args) | |
79 | (cadr args) | |
80 | (caddr args) | |
81 | (if (= n 4) | |
82 | (cadddr args) | |
83 | '())) | |
84 | (begin | |
85 | (display "uncaught throw to " p) | |
86 | (display tag p) | |
87 | (display ": " p) | |
88 | (display args p) | |
89 | (newline p))))) | |
13dc0cae | 90 | |
c7a813af TTN |
91 | ; --- MACROS ------------------------------------------------------- |
92 | ||
93 | (defmacro make-thread (proc . args) | |
1188fb05 MD |
94 | `(call-with-new-thread |
95 | (lambda () | |
c7a813af | 96 | (,proc ,@args)) |
13dc0cae | 97 | %thread-handler)) |
1188fb05 | 98 | |
c7a813af | 99 | (defmacro begin-thread (first . rest) |
1188fb05 MD |
100 | `(call-with-new-thread |
101 | (lambda () | |
102 | (begin | |
c7a813af | 103 | ,first ,@rest)) |
13dc0cae | 104 | %thread-handler)) |
1188fb05 | 105 | |
c7a813af | 106 | (defmacro with-mutex (m . body) |
1188fb05 | 107 | `(dynamic-wind |
c7a813af TTN |
108 | (lambda () (lock-mutex ,m)) |
109 | (lambda () (begin ,@body)) | |
110 | (lambda () (unlock-mutex ,m)))) | |
1188fb05 | 111 | |
c7a813af | 112 | (defmacro monitor (first . rest) |
1188fb05 | 113 | `(with-mutex ,(make-mutex) |
c7a813af TTN |
114 | (begin |
115 | ,first ,@rest))) | |
116 | ||
c7a813af | 117 | ;;; threads.scm ends here |