fixed small universe bug

svn: r15657

collects/2htdp/private/check-aux.ss

@@ -124,6 +124,24 @@
           (read-line in) ;; read the newline 
           x))))
 
+(define REGISTER '***register***)
+(define OKAY '***okay***)
+
+;; InPort OutPort (X -> Y) -> (U Y Void)
+;; process a registration from a potential client, invoke k if it is okay
+(define (tcp-process-registration in out k)
+  (define next (tcp-receive in))
+  (when (and (pair? next) (eq? REGISTER (car next))) 
+    (tcp-send out OKAY)
+    (k (cdr next))))
+  
+
+;; InPort OutPort (U #f String) -> Void 
+;; register with the server 
+(define (tcp-register in out name)
+  (tcp-send out `(,REGISTER ,(if name name (symbol->string (gensym 'world)))))
+  (unless (eq? (tcp-receive in) OKAY) (raise tcp-eof)))
+
 ;                                                   
 ;                                                   
 ;                                                   

collects/2htdp/private/universe.ss

@@ -88,7 +88,6 @@
       
       (def/cback private (pnew iworld) on-new
         (set! iworlds (cons iworld iworlds))
-        (iworld-send iworld 'okay)  ;; <--- this can fail!                  
         (send gui add (format "~a signed up" (iworld-name iworld))))
       
       (def/cback private (pmsg iworld r) on-msg
@@ -133,12 +132,16 @@
               (tcp-listen SQPORT 4 #t)))
           ;; (list IPort OPort) -> Void 
           (define (add-iworld in-out)
+            (define in (first in-out))
+            (define out (second in-out))
             ;; is it possible to kill the server with lots of bad connections?
-            (with-handlers ((tcp-eof? (lambda _ (loop))))
-              (define in (first in-out))        
-              (define next (tcp-receive in))
-              (when (and (pair? next) (eq? 'REGISTER (car next)))
-                (pnew (create-iworld in (second in-out) (cdr next))))
+            (with-handlers ((tcp-eof? (lambda _ (loop)))
+                            (exn? (lambda (e)
+                                    (printf "process registration failed!\n~a" 
+                                            (exn-message e))
+                                    (loop))))
+              (tcp-process-registration
+               in out (lambda (info) (pnew (create-iworld in out info))))
               (loop)))
           ;; IWorld -> [IPort -> Void]
           (define (process-message p)

collects/2htdp/private/world.ss

@@ -114,10 +114,7 @@
                                      (printf FMTtry register TRIES)
                                      (begin (sleep PAUSE) (try (- n 1)))))))
                 (define-values (in out) (tcp-connect register SQPORT))
-                (tcp-send
-                 out
-                 `(REGISTER ,(if name name (symbol->string (gensym 'world)))))
-                (unless (eq? (tcp-receive in) 'okay) (raise tcp-eof))
+                (tcp-register in out name)
                 (printf "... successful registered and ready to receive\n")
                 (set! *out* out)
                 (thread (RECEIVE in))))))

collects/2htdp/uchat/chatter.ss

@@ -484,4 +484,7 @@
             (name n)
             (register LOCALHOST)))
 
-; (launch-many-worlds (main "carl") (main "sam"))
+(define (run* _)
+  (launch-many-worlds (main "carl") (main "sam")))
+
+(run* 0)

collects/2htdp/uchat/server.ss

@@ -1,6 +1,6 @@
 ;; The first three lines of this file were inserted by DrScheme. They record metadata
 ;; about the language level of this file in a form that our tools can easily process.
-#reader(lib "htdp-intermediate-lambda-reader.ss" "lang")((modname server) (read-case-sensitive #t) (teachpacks ()) (htdp-settings #(#t constructor repeating-decimal #f #t none #f ())))
+#reader(lib "htdp-intermediate-lambda-reader.ss" "lang")((modname server) (read-case-sensitive #f) (teachpacks ()) (htdp-settings #(#f constructor repeating-decimal #f #t none #f ())))
 (require 2htdp/universe)
 
 ;; UniState = [Listof IWorld]
@@ -94,4 +94,6 @@
 (define (run _)
   (universe '() 
             (on-new new-chatter)
-            (on-msg forward)))
+            (on-msg forward)))
+
+(run 0)

collects/2htdp/uchat/xrun

@@ -0,0 +1,4 @@
+#!/bin/tcsh
+
+mred server.ss &
+mred chatter.ss -e"(run* 'go)" &

collects/2htdp/universe.ss

@@ -145,7 +145,7 @@
   (syntax-case stx ()
     [(big-bang) 
      (raise-syntax-error #f "big-bang needs at least an initial world;" stx)]
-    [(big-bang w s ...)
+    [(big-bang w (k s ...) ...)
      (let* (;; [Listof (list Keyword Contract)]
             [Spec (append AllSpec WldSpec)]
             [kwds (map (lambda (x) (datum->syntax #'here x)) (map car Spec))]
@@ -161,10 +161,10 @@
                                 (syntax-case #'E ()
                                   [(V) (set! rec? #'V)]
                                   [_ (err 'record? stx)]))
-                              (cons #'kw #'E #;(syntax E)))]
+                              (cons #'kw #'E))]
                            [_ (raise-syntax-error
                                'big-bang "not a legal big-bang clause" stx)]))
-                       (syntax->list (syntax (s ...))))]
+                       (syntax->list (syntax ((k s ...) ...))))]
             ;; assert: all items of wrld have shape (kw . E) 
             ;;         and all kw are guaranted in the domain of Spec
             ;; now bring together the coercion-contracts and the values,