<html><body style="word-wrap: break-word; -webkit-nbsp-mode: space; -webkit-line-break: after-white-space; ">Regarding this previous problem I submitted, I worked on isolating it to simpler terms. I found another IO problem on Gambit 4.2.5 on WindowsXP (MinGW). I don't know if they are related in any way.<div><br></div><div>The problem occurs when I do an open-process on a dummy bat script that: outputs two lines and loop indefinitely. I read the the lines in the process port and after that, all IO is blocked in Gambit. To show this, I run a dummy tcp server and a loop of clients calls to this server concurrently and this loop gets stuck when all IO is blocked.</div><div><br></div><div>Strangely, if I send a (read-line) in the process port; It unblocks the IO even if there is actually nothing to read in the port.</div><div><br></div><div><br></div><div>Here is the code to reproduce it on Windows (MingW):</div><div><br></div><div><br></div><div>----- Simple BAT script ---------------------------</div><div><div><br></div><div>@ECHO OFF</div><div><br></div><div>ECHO A</div><div>ECHO B</div><div><br></div><div>:loop</div><div>IF 1==1 GOTO loop</div><div><br></div><div>--------------------------------------------------------</div><div><br></div><div><br></div><div>----- Gambit 4.2.5 Code ---------------------------</div><div><br></div><div><div><font class="Apple-style-span" face="'Courier New'">(define n 0)</font></div><div><font class="Apple-style-span" face="'Courier New'"><br></font></div><div><font class="Apple-style-span" face="'Courier New'"><br></font></div><div><font class="Apple-style-span" face="'Courier New'">;;;</font></div><div><font class="Apple-style-span" face="'Courier New'">;;;; main</font></div><div><font class="Apple-style-span" face="'Courier New'">;;;</font></div><div><font class="Apple-style-span" face="'Courier New'"><br></font></div><div><font class="Apple-style-span" face="'Courier New'"><br></font></div><div><font class="Apple-style-span" face="'Courier New'">(define (main)</font></div><div><font class="Apple-style-span" face="'Courier New'">  (start-server)</font></div><div><font class="Apple-style-span" face="'Courier New'">  (start-open-process)</font></div><div><font class="Apple-style-span" face="'Courier New'">  (start-clients))</font></div><div><font class="Apple-style-span" face="'Courier New'"><br></font></div><div><font class="Apple-style-span" face="'Courier New'"><br></font></div><div><font class="Apple-style-span" face="'Courier New'"><br></font></div><div><font class="Apple-style-span" face="'Courier New'">;;;</font></div><div><font class="Apple-style-span" face="'Courier New'">;;;; Minimal Server</font></div><div><font class="Apple-style-span" face="'Courier New'">;;;</font></div><div><font class="Apple-style-span" face="'Courier New'"><br></font></div><div><font class="Apple-style-span" face="'Courier New'"><br></font></div><div><font class="Apple-style-span" face="'Courier New'">(define (start-server)</font></div><div><font class="Apple-style-span" face="'Courier New'">  (let ((rpc-command-queue (open-tcp-server</font></div><div><font class="Apple-style-span" face="'Courier New'">                            (list port-number: 8001))))</font></div><div><font class="Apple-style-span" face="'Courier New'">    (thread-start!</font></div><div><font class="Apple-style-span" face="'Courier New'">     (make-thread</font></div><div><font class="Apple-style-span" face="'Courier New'">      (lambda ()</font></div><div><font class="Apple-style-span" face="'Courier New'">        (let loop ()</font></div><div><font class="Apple-style-span" face="'Courier New'">          (let ((incoming-connection (read rpc-command-queue)))</font></div><div><font class="Apple-style-span" face="'Courier New'">            (serve-connection incoming-connection))</font></div><div><font class="Apple-style-span" face="'Courier New'">          (loop)))))))</font></div><div><font class="Apple-style-span" face="'Courier New'"><br></font></div><div><font class="Apple-style-span" face="'Courier New'"><br></font></div><div><font class="Apple-style-span" face="'Courier New'">(define (serve-connection incoming-connection)</font></div><div><font class="Apple-style-span" face="'Courier New'">  (thread-start!</font></div><div><font class="Apple-style-span" face="'Courier New'">   (make-thread</font></div><div><font class="Apple-style-span" face="'Courier New'">    (lambda ()</font></div><div><font class="Apple-style-span" face="'Courier New'">      (let* ((line (read-line incoming-connection)))</font></div><div><font class="Apple-style-span" face="'Courier New'">        (pp (list "read in server" line))</font></div><div><font class="Apple-style-span" face="'Courier New'">        (force-output)</font></div><div><font class="Apple-style-span" face="'Courier New'">        (set! n (+ 1 n))</font></div><div><font class="Apple-style-span" face="'Courier New'">        (display (string-append "connection " (number->string n) "\n") incoming-connection)</font></div><div><font class="Apple-style-span" face="'Courier New'">        (close-port incoming-connection))))))</font></div><div><font class="Apple-style-span" face="'Courier New'"><br></font></div><div><font class="Apple-style-span" face="'Courier New'"><br></font></div><div><font class="Apple-style-span" face="'Courier New'">;;;</font></div><div><font class="Apple-style-span" face="'Courier New'">;;;; Client</font></div><div><font class="Apple-style-span" face="'Courier New'">;;;</font></div><div><font class="Apple-style-span" face="'Courier New'"><br></font></div><div><font class="Apple-style-span" face="'Courier New'">(define (start-clients)</font></div><div><font class="Apple-style-span" face="'Courier New'">  (let loop ()</font></div><div><font class="Apple-style-span" face="'Courier New'">    (let ((p (open-tcp-client (list server-address: "127.0.0.1"</font></div><div><font class="Apple-style-span" face="'Courier New'">                                    port-number: 8001))))</font></div><div><font class="Apple-style-span" face="'Courier New'">      (display "anything\n" p)</font></div><div><font class="Apple-style-span" face="'Courier New'">      (force-output p)</font></div><div><font class="Apple-style-span" face="'Courier New'">      (pp (list "read from server" (read-line p)))</font></div><div><font class="Apple-style-span" face="'Courier New'">      (force-output)</font></div><div><font class="Apple-style-span" face="'Courier New'">      (close-port p))</font></div><div><font class="Apple-style-span" face="'Courier New'">    (thread-sleep! 0.1)</font></div><div><font class="Apple-style-span" face="'Courier New'">    (if (< n 50)</font></div><div><font class="Apple-style-span" face="'Courier New'">        (loop))))</font></div><div><font class="Apple-style-span" face="'Courier New'"><br></font></div><div><font class="Apple-style-span" face="'Courier New'"><br></font></div><div><font class="Apple-style-span" face="'Courier New'"><br></font></div><div><font class="Apple-style-span" face="'Courier New'">;;;</font></div><div><font class="Apple-style-span" face="'Courier New'">;;;; start-open-process</font></div><div><font class="Apple-style-span" face="'Courier New'">;;;</font></div><div><font class="Apple-style-span" face="'Courier New'"><br></font></div><div><font class="Apple-style-span" face="'Courier New'"><br></font></div><div><font class="Apple-style-span" face="'Courier New'">(define (start-open-process)</font></div><div><font class="Apple-style-span" face="'Courier New'">  (thread-start!</font></div><div><font class="Apple-style-span" face="'Courier New'">   (make-thread</font></div><div><font class="Apple-style-span" face="'Courier New'">    (lambda ()</font></div><div><font class="Apple-style-span" face="'Courier New'">      (let ((p (open-process (list</font></div><div><font class="Apple-style-span" face="'Courier New'">                              path: "processDos.bat"</font></div><div><font class="Apple-style-span" face="'Courier New'">                              pseudo-terminal: #t</font></div><div><font class="Apple-style-span" face="'Courier New'">                              stderr-redirection: #f</font></div><div><font class="Apple-style-span" face="'Courier New'">                              eol-encoding: 'cr-lf</font></div><div><font class="Apple-style-span" face="'Courier New'">                              ))))</font></div><div><font class="Apple-style-span" face="'Courier New'"><br></font></div><div><font class="Apple-style-span" face="'Courier New'">        (pp (list (read-line p) "1"))</font></div><div><font class="Apple-style-span" face="'Courier New'">        (pp (list (read-line p) "2"))</font></div><div><font class="Apple-style-span" face="'Courier New'">        ; Uncomment the following line to unblock IO</font></div><div><font class="Apple-style-span" face="'Courier New'">        ;(pp (list (read-line p) "3"))</font></div><div><font class="Apple-style-span" face="'Courier New'">        )))))</font></div><div><font class="Apple-style-span" face="'Courier New'"><br></font></div><div><font class="Apple-style-span" face="'Courier New'">;;;</font></div><div><font class="Apple-style-span" face="'Courier New'">;;;; start main</font></div><div><font class="Apple-style-span" face="'Courier New'">;;;</font></div><div><font class="Apple-style-span" face="'Courier New'"><br></font></div><div><font class="Apple-style-span" face="'Courier New'"><br></font></div><div><font class="Apple-style-span" face="'Courier New'">(main)</font></div></div><div><br></div><div><br></div></div><div>--------------------------------------------------------<br><div><html><br></html><html>This phenomenon is not present on MacOSX version.</html><html><br></html><html>Thank you,</html><html>Francois Magnan</html><html><br></html><html><br></html><html><br></html><html>On 8-Feb-08, at 4:51 PM, François Magnan wrote:</html><br class="Apple-interchange-newline"><blockquote type="cite"><div style="word-wrap: break-word; -webkit-nbsp-mode: space; -webkit-line-break: after-white-space; ">Hi,<div><br class="webkit-block-placeholder"></div><div>I worked hard to isolate one of my bugs and I found a rather disturbing minimal example that reproduces the bug. It can be observed in all the latests  versions of Gambit (including 4.2.1).</div><div><br class="webkit-block-placeholder"></div><div>Basically, I start a minimal multithread web server and in another thread I start a loop that calls a serie of open-tcp-client to different ips in the local network. The default web browser is launched to get the page served by the web server. </div><div><br class="webkit-block-placeholder"></div><div>On MacOSX Leopard everything is fine. On WindowsXP (MingW compiled version of Gambit) the page takes an unnaceptable loooong time to load. The website index.html must require multiple HTTP GET to render (a page with multiple pictures for example).</div><div><br class="webkit-block-placeholder"></div><div>What is the most disturbing is that if I replace the calls to "read-u8-line" by simple "read-line", the bug disapears. The bug is therefore somehow related to "read-u8".</div><div><br class="webkit-block-placeholder"></div><div>Here is the sample code. You have to define  "Server-ROOT" at the top so it points to a website on your local hard-drive.</div><div>I didn't try on Linux but to try it the code will have to be adapted a little bit (how to launch the default browser on Linux?).</div><div><br class="webkit-block-placeholder"></div><div>What could lead to this huge difference between a sequence of read-u8 and read-line on WinXP???</div><div><br></div><div>Thank you,</div><div>Francois Magnan</div><div> </div><div><br class="webkit-block-placeholder"></div><div><div><font class="Apple-style-span" face="Courier">;;; Gambit Networking Test Example</font></div><div><font class="Apple-style-span" face="Courier">;;; </font></div><div><font class="Apple-style-span" face="Courier">;;; Minimal web server that gets incredibly slow on WinXP (MinGW) if it is run in parallel with another thread that does a network scan.</font></div><div><font class="Apple-style-span" face="Courier">;;;</font></div><div><font class="Apple-style-span" face="Courier">;;; If the "read-u8-line" calls are replaced by "read-line" the bug disapears.</font></div><div><font class="Apple-style-span" face="Courier">;;;</font></div><div><font class="Apple-style-span" face="Courier">;;; On MacOSX Leopard the bug is not present.</font></div><div><font class="Apple-style-span" face="Courier">;;; </font></div><div><font class="Apple-style-span" face="Courier">;;; Was tested with versions: Gambit-C 4.0.1, 4.1.2, 4.2.1</font></div><div><font class="Apple-style-span" face="Courier">;;;</font></div><div><font class="Apple-style-span" face="Courier"><br class="webkit-block-placeholder"></font></div><div><font class="Apple-style-span" face="Courier"><br class="webkit-block-placeholder"></font></div><div><font class="Apple-style-span" face="Courier">;;;</font></div><div><font class="Apple-style-span" face="Courier">;;;; Server-ROOT</font></div><div><font class="Apple-style-span" face="Courier">;;;</font></div><div><font class="Apple-style-span" face="Courier"><br class="webkit-block-placeholder"></font></div><div><font class="Apple-style-span" face="Courier"><br class="webkit-block-placeholder"></font></div><div><font class="Apple-style-span" face="Courier">;;; *******************</font></div><div><font class="Apple-style-span" face="Courier">;;; Put here the path to a static website with many files to load to render index.html</font></div><div><font class="Apple-style-span" face="Courier">;;; *******************</font></div><div><font class="Apple-style-span" face="Courier"><br class="webkit-block-placeholder"></font></div><div><font class="Apple-style-span" face="Courier">;(define Server-ROOT "/Users/magnan/TELOS/interface/TELOS-Desktop")</font></div><div><font class="Apple-style-span" face="Courier">(define Server-ROOT "C:/TELOS/interface/TELOS-Desktop")</font></div><div><font class="Apple-style-span" face="Courier"><br class="webkit-block-placeholder"></font></div><div><font class="Apple-style-span" face="Courier"><br class="webkit-block-placeholder"></font></div><div><font class="Apple-style-span" face="Courier">;;;</font></div><div><font class="Apple-style-span" face="Courier">;;;; main</font></div><div><font class="Apple-style-span" face="Courier">;;;</font></div><div><font class="Apple-style-span" face="Courier"><br class="webkit-block-placeholder"></font></div><div><font class="Apple-style-span" face="Courier"><br class="webkit-block-placeholder"></font></div><div><font class="Apple-style-span" face="Courier">(define (main)</font></div><div><font class="Apple-style-span" face="Courier">  (start-server)</font></div><div><font class="Apple-style-span" face="Courier">  (start-broadcast)</font></div><div><font class="Apple-style-span" face="Courier">  (start-client)</font></div><div><font class="Apple-style-span" face="Courier">)</font></div><div><font class="Apple-style-span" face="Courier"><br class="webkit-block-placeholder"></font></div><div><font class="Apple-style-span" face="Courier"><br class="webkit-block-placeholder"></font></div><div><font class="Apple-style-span" face="Courier"><br class="webkit-block-placeholder"></font></div><div><font class="Apple-style-span" face="Courier">;;;</font></div><div><font class="Apple-style-span" face="Courier">;;;; Minimal Web Server</font></div><div><font class="Apple-style-span" face="Courier">;;;</font></div><div><font class="Apple-style-span" face="Courier"><br class="webkit-block-placeholder"></font></div><div><font class="Apple-style-span" face="Courier"><br class="webkit-block-placeholder"></font></div><div><font class="Apple-style-span" face="Courier">(define (start-server)</font></div><div><font class="Apple-style-span" face="Courier">  (let ((rpc-command-queue (open-tcp-server</font></div><div><font class="Apple-style-span" face="Courier">                            (list port-number: 8000))))</font></div><div><font class="Apple-style-span" face="Courier">    (thread-start!</font></div><div><font class="Apple-style-span" face="Courier">     (make-thread</font></div><div><font class="Apple-style-span" face="Courier">      (lambda ()</font></div><div><span class="Apple-tab-span" style="white-space:pre"><font class="Apple-style-span" face="Courier">      </font></span><font class="Apple-style-span" face="Courier">(let loop ()</font></div><div><span class="Apple-tab-span" style="white-space:pre"><font class="Apple-style-span" face="Courier">       </font></span><font class="Apple-style-span" face="Courier">  (let ((incoming-connection (read rpc-command-queue)))</font></div><div><span class="Apple-tab-span" style="white-space:pre"><font class="Apple-style-span" face="Courier">       </font></span><font class="Apple-style-span" face="Courier">    (force-output)</font></div><div><span class="Apple-tab-span" style="white-space:pre"><font class="Apple-style-span" face="Courier">       </font></span><font class="Apple-style-span" face="Courier">    (serve-connection incoming-connection))</font></div><div><span class="Apple-tab-span" style="white-space:pre"><font class="Apple-style-span" face="Courier">      </font></span><font class="Apple-style-span" face="Courier">  (loop)))))))</font></div><div><font class="Apple-style-span" face="Courier"><br class="webkit-block-placeholder"></font></div><div><font class="Apple-style-span" face="Courier"><br class="webkit-block-placeholder"></font></div><div><font class="Apple-style-span" face="Courier">(define (serve-connection incoming-connection)</font></div><div><font class="Apple-style-span" face="Courier">  (thread-start!</font></div><div><font class="Apple-style-span" face="Courier">   (make-thread</font></div><div><font class="Apple-style-span" face="Courier">    (lambda ()</font></div><div><font class="Apple-style-span" face="Courier">      (let* ((line (read-u8-line incoming-connection))</font></div><div><span class="Apple-tab-span" style="white-space:pre"><font class="Apple-style-span" face="Courier">  </font></span><font class="Apple-style-span" face="Courier">     (splitted (split-string line #\space))</font></div><div><span class="Apple-tab-span" style="white-space:pre"><font class="Apple-style-span" face="Courier">      </font></span><font class="Apple-style-span" face="Courier">     (path     (cadr splitted)))</font></div><div><span class="Apple-tab-span" style="white-space:pre"><font class="Apple-style-span" face="Courier">       </font></span><font class="Apple-style-span" face="Courier">(read-all-headers incoming-connection)</font></div><div><span class="Apple-tab-span" style="white-space:pre"><font class="Apple-style-span" face="Courier">     </font></span><font class="Apple-style-span" face="Courier">(force-output)</font></div><div><span class="Apple-tab-span" style="white-space:pre"><font class="Apple-style-span" face="Courier">     </font></span><font class="Apple-style-span" face="Courier">(with-exception-catcher </font></div><div><span class="Apple-tab-span" style="white-space:pre"><font class="Apple-style-span" face="Courier">      </font></span><font class="Apple-style-span" face="Courier"> (lambda (e)</font></div><div><span class="Apple-tab-span" style="white-space:pre"><font class="Apple-style-span" face="Courier">       </font></span><font class="Apple-style-span" face="Courier">   (##display-exception e (current-output-port)))</font></div><div><span class="Apple-tab-span" style="white-space:pre"><font class="Apple-style-span" face="Courier">     </font></span><font class="Apple-style-span" face="Courier"> (lambda ()</font></div><div><span class="Apple-tab-span" style="white-space:pre"><font class="Apple-style-span" face="Courier">        </font></span><font class="Apple-style-span" face="Courier">   (serve-file path incoming-connection))))))))</font></div><div><font class="Apple-style-span" face="Courier"><br class="webkit-block-placeholder"></font></div><div><font class="Apple-style-span" face="Courier"><br class="webkit-block-placeholder"></font></div><div><font class="Apple-style-span" face="Courier">(define (read-all-headers incoming-connection)</font></div><div><font class="Apple-style-span" face="Courier">  (let ((line (read-u8-line incoming-connection)))</font></div><div><font class="Apple-style-span" face="Courier">    (pp (list "read header line" line))</font></div><div><font class="Apple-style-span" face="Courier">    (force-output)</font></div><div><font class="Apple-style-span" face="Courier">    (if (not (equal? line ""))</font></div><div><span class="Apple-tab-span" style="white-space:pre"><font class="Apple-style-span" face="Courier">       </font></span><font class="Apple-style-span" face="Courier">(read-all-headers incoming-connection))))</font></div><div><span class="Apple-tab-span" style="white-space:pre"><font class="Apple-style-span" face="Courier">  </font></span><font class="Apple-style-span" face="Courier">      </font></div><div><font class="Apple-style-span" face="Courier"><br class="webkit-block-placeholder"></font></div><div><font class="Apple-style-span" face="Courier"><br class="webkit-block-placeholder"></font></div><div><font class="Apple-style-span" face="Courier">(define (split-string str sep-char)</font></div><div><font class="Apple-style-span" face="Courier">  (call-with-input-string</font></div><div><font class="Apple-style-span" face="Courier">   str</font></div><div><font class="Apple-style-span" face="Courier">   (lambda (p) (read-fields p sep-char #f))))</font></div><div><font class="Apple-style-span" face="Courier"><br class="webkit-block-placeholder"></font></div><div><font class="Apple-style-span" face="Courier"><br class="webkit-block-placeholder"></font></div><div><font class="Apple-style-span" face="Courier">(define (read-fields port sep inc-sep?)</font></div><div><font class="Apple-style-span" face="Courier">  (read-all port</font></div><div><font class="Apple-style-span" face="Courier">            (lambda (p)</font></div><div><font class="Apple-style-span" face="Courier">              (read-line p sep inc-sep?))))</font></div><div><font class="Apple-style-span" face="Courier"><br class="webkit-block-placeholder"></font></div><div><font class="Apple-style-span" face="Courier"><br class="webkit-block-placeholder"></font></div><div><font class="Apple-style-span" face="Courier">(define (serve-file path incoming-connection)</font></div><div><font class="Apple-style-span" face="Courier">  (let* ((complete-path (string-append Server-ROOT path))</font></div><div><span class="Apple-tab-span" style="white-space:pre"><font class="Apple-style-span" face="Courier">     </font></span><font class="Apple-style-span" face="Courier"> (fileInfo (file-info complete-path))</font></div><div><span class="Apple-tab-span" style="white-space:pre"><font class="Apple-style-span" face="Courier">      </font></span><font class="Apple-style-span" face="Courier"> (size     (file-info-size fileInfo))</font></div><div><span class="Apple-tab-span" style="white-space:pre"><font class="Apple-style-span" face="Courier">    </font></span><font class="Apple-style-span" face="Courier"> (mimetype (compute-mimetype complete-path))</font></div><div><span class="Apple-tab-span" style="white-space:pre"><font class="Apple-style-span" face="Courier">       </font></span><font class="Apple-style-span" face="Courier"> (header   (compute-get-result-header size mimetype)))</font></div><div><font class="Apple-style-span" face="Courier">    (display header incoming-connection)</font></div><div><font class="Apple-style-span" face="Courier">    (output-file-data complete-path incoming-connection)</font></div><div><font class="Apple-style-span" face="Courier">    (close-port incoming-connection)))</font></div><div><font class="Apple-style-span" face="Courier">    </font></div><div><font class="Apple-style-span" face="Courier"><br class="webkit-block-placeholder"></font></div><div><font class="Apple-style-span" face="Courier">(define (compute-get-result-header size mimetype)</font></div><div><font class="Apple-style-span" face="Courier">  (string-append "HTTP/1.0 200 OK\r\n"</font></div><div><font class="Apple-style-span" face="Courier">                 "Content-type: " mimetype "\r\n"</font></div><div><font class="Apple-style-span" face="Courier">                 "Content-length: " (number->string size) "\r\n"</font></div><div><font class="Apple-style-span" face="Courier">                 "\r\n"))</font></div><div><font class="Apple-style-span" face="Courier"><br class="webkit-block-placeholder"></font></div><div><font class="Apple-style-span" face="Courier"><br class="webkit-block-placeholder"></font></div><div><font class="Apple-style-span" face="Courier">(define (output-file-data filePath connection)</font></div><div><font class="Apple-style-span" face="Courier">  (with-input-from-file filePath</font></div><div><font class="Apple-style-span" face="Courier">    (lambda ()</font></div><div><font class="Apple-style-span" face="Courier">      (letrec ((output-file-data-rec (lambda ()</font></div><div><span class="Apple-tab-span" style="white-space:pre"><font class="Apple-style-span" face="Courier">                          </font></span><font class="Apple-style-span" face="Courier">       (let ((rc (read-char)))</font></div><div><span class="Apple-tab-span" style="white-space:pre"><font class="Apple-style-span" face="Courier">                                      </font></span><font class="Apple-style-span" face="Courier"> (if (not (equal? rc #!eof))</font></div><div><span class="Apple-tab-span" style="white-space:pre"><font class="Apple-style-span" face="Courier">                                       </font></span><font class="Apple-style-span" face="Courier">     (begin</font></div><div><span class="Apple-tab-span" style="white-space:pre"><font class="Apple-style-span" face="Courier">                                      </font></span><font class="Apple-style-span" face="Courier">       (write-char rc connection)</font></div><div><span class="Apple-tab-span" style="white-space:pre"><font class="Apple-style-span" face="Courier">                                   </font></span><font class="Apple-style-span" face="Courier">       (output-file-data-rec)))))))</font></div><div><span class="Apple-tab-span" style="white-space:pre"><font class="Apple-style-span" face="Courier"> </font></span><font class="Apple-style-span" face="Courier">(output-file-data-rec)))))</font></div><div><font class="Apple-style-span" face="Courier"><br class="webkit-block-placeholder"></font></div><div><font class="Apple-style-span" face="Courier"><br class="webkit-block-placeholder"></font></div><div><font class="Apple-style-span" face="Courier">(define (compute-mimetype filePath)</font></div><div><font class="Apple-style-span" face="Courier">  (let* ((ext  (path-extension filePath))</font></div><div><font class="Apple-style-span" face="Courier">        (rext (and (string? ext) (substring ext 1 (string-length ext)))))</font></div><div><font class="Apple-style-span" face="Courier">    (case (string->symbol rext)</font></div><div><font class="Apple-style-span" face="Courier">      ((jpg jpeg JPG JPEG)</font></div><div><font class="Apple-style-span" face="Courier">       "image/jpeg")</font></div><div><font class="Apple-style-span" face="Courier">      ((gif GIF)</font></div><div><font class="Apple-style-span" face="Courier">       "image/gif")</font></div><div><font class="Apple-style-span" face="Courier">      ((png PNG)</font></div><div><font class="Apple-style-span" face="Courier">       "image/png")</font></div><div><font class="Apple-style-span" face="Courier">      ((html HTML htm HTM)</font></div><div><font class="Apple-style-span" face="Courier">       "text/html")</font></div><div><font class="Apple-style-span" face="Courier">      ((js JS)</font></div><div><font class="Apple-style-span" face="Courier">       "text/javascript")</font></div><div><font class="Apple-style-span" face="Courier">      ((css CSS)</font></div><div><font class="Apple-style-span" face="Courier">       "text/css")</font></div><div><font class="Apple-style-span" face="Courier">      (else</font></div><div><font class="Apple-style-span" face="Courier">       "application/octet-stream"</font></div><div><font class="Apple-style-span" face="Courier">       ))))</font></div><div><font class="Apple-style-span" face="Courier"><br class="webkit-block-placeholder"></font></div><div><font class="Apple-style-span" face="Courier"><br class="webkit-block-placeholder"></font></div><div><font class="Apple-style-span" face="Courier">;;;</font></div><div><font class="Apple-style-span" face="Courier">;;;; start-broadcast</font></div><div><font class="Apple-style-span" face="Courier">;;;</font></div><div><font class="Apple-style-span" face="Courier"><br class="webkit-block-placeholder"></font></div><div><font class="Apple-style-span" face="Courier"><br class="webkit-block-placeholder"></font></div><div><font class="Apple-style-span" face="Courier">(define (start-broadcast)</font></div><div><font class="Apple-style-span" face="Courier">  (thread-start!</font></div><div><font class="Apple-style-span" face="Courier">   (make-thread</font></div><div><font class="Apple-style-span" face="Courier">    (lambda ()</font></div><div><font class="Apple-style-span" face="Courier">      (let* ((hostname     (host-name))</font></div><div><span class="Apple-tab-span" style="white-space:pre"><font class="Apple-style-span" face="Courier">      </font></span><font class="Apple-style-span" face="Courier">     (hi           (host-info hostname))</font></div><div><span class="Apple-tab-span" style="white-space:pre"><font class="Apple-style-span" face="Courier">        </font></span><font class="Apple-style-span" face="Courier">     (host-ips  (host-info-addresses hi))</font></div><div><span class="Apple-tab-span" style="white-space:pre"><font class="Apple-style-span" face="Courier">   </font></span><font class="Apple-style-span" face="Courier">     (host-ip      (car host-ips)))</font></div><div><span class="Apple-tab-span" style="white-space:pre"><font class="Apple-style-span" face="Courier">       </font></span><font class="Apple-style-span" face="Courier">(letrec ((network-broadcast (lambda (i)</font></div><div><span class="Apple-tab-span" style="white-space:pre"><font class="Apple-style-span" face="Courier">                            </font></span><font class="Apple-style-span" face="Courier">      (if (= i 255)</font></div><div><span class="Apple-tab-span" style="white-space:pre"><font class="Apple-style-span" face="Courier">                                 </font></span><font class="Apple-style-span" face="Courier">  #t</font></div><div><span class="Apple-tab-span" style="white-space:pre"><font class="Apple-style-span" face="Courier">                                  </font></span><font class="Apple-style-span" face="Courier">  (begin</font></div><div><span class="Apple-tab-span" style="white-space:pre"><font class="Apple-style-span" face="Courier">                                      </font></span><font class="Apple-style-span" face="Courier">    (u8vector-set! host-ip 3 i)</font></div><div><span class="Apple-tab-span" style="white-space:pre"><font class="Apple-style-span" face="Courier">                                  </font></span><font class="Apple-style-span" face="Courier">    (call-addr host-ip)</font></div><div><span class="Apple-tab-span" style="white-space:pre"><font class="Apple-style-span" face="Courier">                                  </font></span><font class="Apple-style-span" face="Courier">    (thread-sleep! 0.2)</font></div><div><span class="Apple-tab-span" style="white-space:pre"><font class="Apple-style-span" face="Courier">                                  </font></span><font class="Apple-style-span" face="Courier">    (network-broadcast (+ i 1)))))))</font></div><div><span class="Apple-tab-span" style="white-space:pre"><font class="Apple-style-span" face="Courier">     </font></span><font class="Apple-style-span" face="Courier">  (network-broadcast 1)))))))</font></div><div><span class="Apple-tab-span" style="white-space:pre"><font class="Apple-style-span" face="Courier"> </font></span></div><div><font class="Apple-style-span" face="Courier"><br class="webkit-block-placeholder"></font></div><div><font class="Apple-style-span" face="Courier">(define (call-addr target-addr)</font></div><div><font class="Apple-style-span" face="Courier">  (pp (list "trying to reach" target-addr))</font></div><div><font class="Apple-style-span" face="Courier">  (with-exception-catcher</font></div><div><span class="Apple-tab-span" style="white-space:pre"><font class="Apple-style-span" face="Courier">  </font></span><font class="Apple-style-span" face="Courier"> (lambda (e)</font></div><div><span class="Apple-tab-span" style="white-space:pre"><font class="Apple-style-span" face="Courier">       </font></span><font class="Apple-style-span" face="Courier">   #f)</font></div><div><span class="Apple-tab-span" style="white-space:pre"><font class="Apple-style-span" face="Courier">        </font></span><font class="Apple-style-span" face="Courier"> (lambda ()</font></div><div><span class="Apple-tab-span" style="white-space:pre"><font class="Apple-style-span" face="Courier">        </font></span><font class="Apple-style-span" face="Courier">   (let ((port (open-tcp-client (list server-address: target-addr </font></div><div><span class="Apple-tab-span" style="white-space:pre"><font class="Apple-style-span" face="Courier">                                       </font></span><font class="Apple-style-span" face="Courier">      port-number: 5000))))</font></div><div><span class="Apple-tab-span" style="white-space:pre"><font class="Apple-style-span" face="Courier"> </font></span><font class="Apple-style-span" face="Courier">     (with-exception-catcher</font></div><div><span class="Apple-tab-span" style="white-space:pre"><font class="Apple-style-span" face="Courier">     </font></span><font class="Apple-style-span" face="Courier">      (lambda (e)</font></div><div><span class="Apple-tab-span" style="white-space:pre"><font class="Apple-style-span" face="Courier">           </font></span><font class="Apple-style-span" face="Courier">#f)</font></div><div><span class="Apple-tab-span" style="white-space:pre"><font class="Apple-style-span" face="Courier">        </font></span><font class="Apple-style-span" face="Courier">      (lambda ()</font></div><div><span class="Apple-tab-span" style="white-space:pre"><font class="Apple-style-span" face="Courier">            </font></span><font class="Apple-style-span" face="Courier">(input-port-timeout-set! port 0.1) </font></div><div><span class="Apple-tab-span" style="white-space:pre"><font class="Apple-style-span" face="Courier">           </font></span><font class="Apple-style-span" face="Courier">(output-port-timeout-set! port 0.1)</font><span class="Apple-tab-span" style="white-space:pre"><font class="Apple-style-span" face="Courier">               </font></span></div><div><span class="Apple-tab-span" style="white-space:pre"><font class="Apple-style-span" face="Courier">                </font></span><font class="Apple-style-span" face="Courier">(write (list 1 2 3) port)))</font></div><div><span class="Apple-tab-span" style="white-space:pre"><font class="Apple-style-span" face="Courier">        </font></span><font class="Apple-style-span" face="Courier">     (close-port port)))))</font></div><div><font class="Apple-style-span" face="Courier"><br class="webkit-block-placeholder"></font></div><div><font class="Apple-style-span" face="Courier"><br class="webkit-block-placeholder"></font></div><div><font class="Apple-style-span" face="Courier">;;;</font></div><div><font class="Apple-style-span" face="Courier">;;;; Client</font></div><div><font class="Apple-style-span" face="Courier">;;;</font></div><div><font class="Apple-style-span" face="Courier"><br class="webkit-block-placeholder"></font></div><div><font class="Apple-style-span" face="Courier"><br class="webkit-block-placeholder"></font></div><div><font class="Apple-style-span" face="Courier">(define (start-client)</font></div><div><font class="Apple-style-span" face="Courier">  (if (equal? (get-host-os) "WinXP")</font></div><div><font class="Apple-style-span" face="Courier">      (shell-command "start <a href="http://localhost:8000/index.html">http://localhost:8000/index.html</a>")</font></div><div><font class="Apple-style-span" face="Courier">      (shell-command "open \"<a href="http://localhost:8000/index.html">http://localhost:8000/index.html</a>\"")))</font></div><div><font class="Apple-style-span" face="Courier"><br class="webkit-block-placeholder"></font></div><div><font class="Apple-style-span" face="Courier"><br class="webkit-block-placeholder"></font></div><div><font class="Apple-style-span" face="Courier">(define (get-host-os)</font></div><div><font class="Apple-style-span" face="Courier">  (with-exception-handler</font></div><div><font class="Apple-style-span" face="Courier">   (lambda (e)</font></div><div><font class="Apple-style-span" face="Courier">     "WinXP")</font></div><div><font class="Apple-style-span" face="Courier">   (lambda ()</font></div><div><font class="Apple-style-span" face="Courier">     (let* ((p (open-process '(path: "/usr/bin/uname"</font></div><div><font class="Apple-style-span" face="Courier">                                     arguments: ("-s"))))</font></div><div><font class="Apple-style-span" face="Courier">            (r (read-line p)))</font></div><div><font class="Apple-style-span" face="Courier">       (close-port p)</font></div><div><font class="Apple-style-span" face="Courier">       r))))</font></div><div><font class="Apple-style-span" face="Courier"><br class="webkit-block-placeholder"></font></div><div><font class="Apple-style-span" face="Courier"><br class="webkit-block-placeholder"></font></div><div><font class="Apple-style-span" face="Courier">;;;</font></div><div><font class="Apple-style-span" face="Courier">;;;; read-u8-line</font></div><div><font class="Apple-style-span" face="Courier">;;;</font></div><div><font class="Apple-style-span" face="Courier"><br class="webkit-block-placeholder"></font></div><div><font class="Apple-style-span" face="Courier"><br class="webkit-block-placeholder"></font></div><div><font class="Apple-style-span" face="Courier">(define (read-u8-line port)</font></div><div><font class="Apple-style-span" face="Courier">  (letrec ((read-loop (lambda (acc)</font></div><div><font class="Apple-style-span" face="Courier">                        (let ((b (read-u8 port)))</font></div><div><font class="Apple-style-span" face="Courier">                          (if (or (equal? b 13) (equal? b 10) (equal? b #!eof))</font></div><div><font class="Apple-style-span" face="Courier">                              (begin</font></div><div><span class="Apple-tab-span" style="white-space:pre"><font class="Apple-style-span" face="Courier">                                </font></span><font class="Apple-style-span" face="Courier">(read-u8 port)</font></div><div><font class="Apple-style-span" face="Courier">                                acc)</font></div><div><font class="Apple-style-span" face="Courier">                              (read-loop (string-append acc (list->string (list (integer->char b))))))))))</font></div><div><font class="Apple-style-span" face="Courier">    (read-loop "")))</font></div><div><font class="Apple-style-span" face="Courier"><br class="webkit-block-placeholder"></font></div><div><font class="Apple-style-span" face="Courier"><br class="webkit-block-placeholder"></font></div><div><font class="Apple-style-span" face="Courier"><br class="webkit-block-placeholder"></font></div><div><font class="Apple-style-span" face="Courier"><br class="webkit-block-placeholder"></font></div><div><font class="Apple-style-span" face="Courier"><br class="webkit-block-placeholder"></font></div><div><font class="Apple-style-span" face="Courier"><br class="webkit-block-placeholder"></font></div><div><font class="Apple-style-span" face="Courier">;;;</font></div><div><font class="Apple-style-span" face="Courier">;;;; start main</font></div><div><font class="Apple-style-span" face="Courier">;;;</font></div><div><font class="Apple-style-span" face="Courier"><br class="webkit-block-placeholder"></font></div><div><font class="Apple-style-span" face="Courier"><br class="webkit-block-placeholder"></font></div><div><font class="Apple-style-span" face="Courier">(main)</font></div></div><div><font class="Apple-style-span" face="Courier"><br class="webkit-block-placeholder"></font></div><div><br class="webkit-block-placeholder"></div></div>_______________________________________________<br>Gambit-list mailing list<br><a href="mailto:Gambit-list@iro.umontreal.ca">Gambit-list@iro.umontreal.ca</a><br>https://webmail.iro.umontreal.ca/mailman/listinfo/gambit-list<br></blockquote></div><br></div></body></html>