File: more-thread.scm

package info (click to toggle)
scsh 0.5.1-2
  • links: PTS
  • area: non-free
  • in suites: potato, slink
  • size: 6,540 kB
  • ctags: 8,656
  • sloc: lisp: 39,346; ansic: 13,466; sh: 1,669; makefile: 624
file content (112 lines) | stat: -rw-r--r-- 3,061 bytes parent folder | download
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
; Copyright (c) 1993, 1994 Richard Kelsey and Jonathan Rees.  See file COPYING.


; Glue to connect the threads package with command processor.

(define (threads)
  (with-threads breakpoint))

(define (with-threads thunk)
  (with-handler (simple-thread-condition-handler)
    (lambda ()
      (with-multitasking
       (lambda ()
	 (with-keyboard-interrupt-thread (current-thread)
	   thunk))))))

(define-command-syntax 'start-threads "" "initiate multitasking"
  '())

(define (start-threads)
  (let ((context (user-context))
	(env (environment-for-commands)))
    (exit-command-processor
     (lambda ()
       (with-threads
	(lambda ()
	  (start-command-processor
	   #f context
	   env
	   (lambda ()
	     (write-line "Multitasking started"
			 (command-output))))))))))



; For using threads in a system that has a command processor.
; Interrupts will be disabled, I think, when the designated thread gets
; its signal.

(define (with-keyboard-interrupt-thread thread thunk)
  (let ((save #f))
    (dynamic-wind
       (lambda ()
	 (set! save (vector-ref interrupt-handlers interrupt/keyboard))
	 (vector-set! interrupt-handlers
		      interrupt/keyboard
		      (lambda (ei)
			(interrupt-thread thread
			  (lambda ()
			    (signal 'interrupt interrupt/keyboard ei))))))
       thunk
       (lambda ()
	 (vector-set! interrupt-handlers interrupt/keyboard save)))))

(define interrupt/keyboard (enum interrupt keyboard))


; A simple handler for non-command-processor threads.

(define (simple-thread-condition-handler)
  (let ((port (current-output-port)))
    (lambda (c punt)
      (cond ((or (error? c) (interrupt? c))
	     (random-thread-error c port))
            (else (punt))))))

(define (random-thread-error c port)
  (display "*** " port)
  (write (current-thread) port)
  (display " got an error:" port) ;(newline port)
  (display-condition c port)
  (terminate-current-thread))

; Can we do better?...

;(define (cp-start-multitasking)
;  (let ((mbx (make-mailbox)))
;    (lambda ()
;      (with-multitasking
;          (errant-thread-condition-handler mbx (current-output-port))
;        (lambda ()
;          ;; (add-sentinel! (errant-thread-sentinel mbx))
;          (with-keyboard-interrupt-thread
;              (current-thread)
;            breakpoint))))))            ;???
;
;(define (errant-thread-condition-handler mbx port)
;  (lambda (c punt)
;    (cond ((error? c)
;           (random-thread-error c mbx))
;          ((warning? c)                 ;Proceed
;           (display-condition c port)
;           (newline port)
;           (unspecific))
;          (else                         ;Proceed
;           (punt)))))
;
;(define (random-thread-error c mbx)
;  (let ((cv (make-condvar)))
;    (mailbox-write mbx (list c cv (current-thread)))
;    ((condvar-ref cv))))


; To do: make the command processor check the errant-thread mailbox.

;(define (errant-thread-sentinel mbx)
;  (lambda ()
;    (if (not (mailbox-empty? mbx))
;        (begin (display .... ? ...) (newline)))))
;
;(add-sentinel! errant-thread-sentinel)