source: project/release/4/mailbox-threads/trunk/mailbox-threads.scm @ 15943

Last change on this file since 15943 was 15943, checked in by Christian Kellermann, 11 years ago

of course we need here apply too

File size: 2.8 KB
Line 
1(module mailbox-threads
2   (make-thread
3    thread-specific-set!
4    thread-specific
5    thread-send
6    thread-start!
7    thread?
8    thread-receive
9    thread-mailbox-next
10    thread-mailbox-rewind
11    thread-mailbox-extract-and-rewind)
12
13(import chicken scheme)
14
15(require-library srfi-18)
16(import
17  (except srfi-18
18   thread?
19   make-thread
20   thread-specific-set!
21   thread-specific
22   thread-start!
23   current-thread) 
24  (prefix (only srfi-18 
25   current-thread
26   thread?
27   make-thread
28   thread-specific-set!
29   thread-specific
30   thread-start!) thread:))
31(use mailbox)
32
33(define *tag* 'mboxthread)
34
35(define (thread? t)
36   (let ((specific (thread:thread-specific t)))
37      (cond ((list? specific)
38                (eq? (car (thread:thread-specific t)) *tag*))
39            (else #f))))
40
41(define (current-thread)
42   (let ((t (thread:current-thread)))
43      (if (thread? t) t
44         (begin
45            (add-specifics! t)
46            t ))))
47
48(define (add-specifics! t)
49   (let* ((mbox (make-mailbox 'mbox-thread))
50         (mbox-cursor (make-mailbox-cursor mbox)))
51   (thread:thread-specific-set! t (list *tag* '() mbox mbox-cursor))))
52
53(define (make-thread thunk #!optional (name 'anonymous))
54   (let ((t (thread:make-thread thunk name)))
55      (add-specifics! t)
56   t))
57
58(define (thread-specific-set! thread newspec)
59   (if (not (thread? thread))
60       (add-specifics! thread)
61       (let* ((specific (thread:thread-specific thread))
62             (mbox (caddr specific))
63             (cursor (cadddr specific)))
64          (thread:thread-specific-set! thread (list *tag* newspec mbox cursor)))))
65
66(define (thread-specific thread)
67   (if (not (thread? thread))
68       (add-specifics! thread)
69       (cadr (thread:thread-specific thread))))
70
71(define (thread-start! thread)
72      (if (procedure? thread)
73          (thread:thread-start! (make-thread thread))
74          (thread:thread-start! thread)))
75
76(define (thread-mbox-cursor thread)
77   (if (not (thread? thread))
78       (add-specifics! thread)
79       (cadddr (thread:thread-specific thread))))
80
81(define (thread-mbox thread)
82   (if (not (thread? thread))
83       (add-specifics! thread)
84       (caddr (thread:thread-specific thread))))
85
86(define (thread-send thread msg)
87      (mailbox-send! (thread-mbox thread) msg))
88
89(define (thread-receive . args)
90      (apply mailbox-receive! (thread-mbox (current-thread)) args))
91
92(define (thread-mailbox-next . args)
93   (let* ((mbox-cursor (thread-mbox-cursor (current-thread))))
94      (apply mailbox-cursor-next mbox-cursor args)))
95
96(define (thread-mailbox-rewind)
97   (let* ((mbox-cursor (thread-mbox-cursor (current-thread))))
98      (mailbox-cursor-rewind mbox-cursor)))
99
100(define (thread-mailbox-extract-and-rewind)
101  (let* ((mbox-cursor (thread-mbox-cursor (current-thread))))
102      (mailbox-cursor-extract-and-rewind! mbox-cursor))) )
Note: See TracBrowser for help on using the repository browser.