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

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

hand down optional arguments as list, as optional parameters get initialised by chicken

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      (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.