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
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
|
#!/usr/bin/env newlisp
(println)
(println "testing message API")
; qa-message, check send and receive functions
; child processes
(when (find ostype '("Windows"))
(println "qa-message runs only run on Unix - exit")
(exit)
)
(sleep 1000)
; --------------------------------- status update
(set 'N 100)
(set 'k 10)
(println k " child processes transmit " 100 " random status numbers")
(define (child-process N)
(set 'ppid (sys-info -4)) ; get parent pid
(set 'cpid (sys-info -3)) ; get this pid
(dotimes (i N)
(until (send ppid (random) ))
)
)
; parent starts k child processes, listens and displays
(dotimes (i k) (spawn 'result (child-process N) true))
(set 'start (time-of-day));
(set 'cnt 0)
(while (< cnt (* k N))
(dolist (cpid (receive)) ; iterate thru child pids
(receive cpid msg) (inc cnt)
)
)
(abort) ; cancel child-processes
(set 'ms (div (- (time-of-day) start) (* k N )))
(println ">>>>> Time per simple message: " (mul ms 1000) " micro seconds")
; --------------------------------- roundtrip test
(set 'N 10)
(set 'k 10)
(println)
(println N " round trips to " k " child processes")
(println "send out and receive it back uppercased with child pid appended")
(define (child-process , pid pppid msg)
(setq ppid (sys-info -4)) ; parent pid
(setq pid (sys-info -3)) ; this child pid
(while true
(until (receive ppid msg) )
(until (send ppid (upper-case (string msg "-" pid)))) )
)
(dotimes (i k)
(spawn 'r (child-process) true))
(set 'start (time-of-day))
(dotimes (i N)
(dolist (ch (sync))
(until (send ch "pid") ) ; send out message
(until (receive ch msg)) ; get response
(unless (= msg (string "PID-" ch)) ; check
(setq error-msg (append " >>>> ERROR in round trip test: " msg )))
)
)
(set 'ms (div (- (time-of-day) start) (* k N )))
(println ">>>>> Time per round trip : " (mul ms 1000) " micros seconds")
(abort) (sleep 100)
; --------------------------------- proxy test
(set 'N 100)
(println)
; proxy messageing A -> parent -> B
; sender child process of the message
(set 'A (spawn 'result
(begin
(dotimes (i N)
(set 'ppid (sys-info -4))
/* the following statement in msg will be evaluated in the proxy */
(set 'msg '(until (send B (string "greetings from " A))))
(until (send ppid msg)))
(until (send ppid '(begin
(println "parent exiting ...\n")
(set 'finished true))))
) true))
; receiver child process of the message
(set 'B (spawn 'result
(begin
(set 'ppid (sys-info -4))
(while true
(until (receive ppid msg))
(unless (= msg (string "greetings from " A))
(println ">>> ERROR in proxy message: " msg))
)
(println)
) true))
; parent functioning as a proxy evaluating messages or any other code
(println "A:" A "-> parent-proxy:" (sys-info -3) " -> B:" B "\n")
(sleep 200)
(set 'start (time-of-day))
; listen to messages from A
(until finished (if (receive A msg) (eval msg)))
(set 'ms (div (- (time-of-day) start) N))
(println ">>>>> Time per proxy trip: " (mul ms 1000) " micro seconds")
(println)
(sleep 300)
(abort)
(sleep 300)
(if error-msg
(println ">>>>> PROBLEM " error-msg)
(println ">>>>> Message API tested SUCCESSFUL"))
(exit)
;; eof
|
