From a3cb24d195d5ca67e83310e63559e3f9063d1c62 Mon Sep 17 00:00:00 2001 From: Matthias Felleisen Date: Sat, 1 Aug 2009 16:18:27 +0000 Subject: [PATCH] fixed small universe bug svn: r15657 --- collects/2htdp/private/check-aux.ss | 18 ++++++++++++++++++ collects/2htdp/private/universe.ss | 15 +++++++++------ collects/2htdp/private/world.ss | 5 +---- collects/2htdp/uchat/chatter.ss | 5 ++++- collects/2htdp/uchat/server.ss | 6 ++++-- collects/2htdp/uchat/xrun | 4 ++++ collects/2htdp/universe.ss | 6 +++--- 7 files changed, 43 insertions(+), 16 deletions(-) create mode 100755 collects/2htdp/uchat/xrun diff --git a/collects/2htdp/private/check-aux.ss b/collects/2htdp/private/check-aux.ss index 6af0eec623..2c7eef2163 100644 --- a/collects/2htdp/private/check-aux.ss +++ b/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))) + ; ; ; diff --git a/collects/2htdp/private/universe.ss b/collects/2htdp/private/universe.ss index befe3ad146..4f56894c36 100644 --- a/collects/2htdp/private/universe.ss +++ b/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) diff --git a/collects/2htdp/private/world.ss b/collects/2htdp/private/world.ss index 062ccd34d4..36fe66980b 100644 --- a/collects/2htdp/private/world.ss +++ b/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)))))) diff --git a/collects/2htdp/uchat/chatter.ss b/collects/2htdp/uchat/chatter.ss index 3b52497ea0..e7f4ee4391 100644 --- a/collects/2htdp/uchat/chatter.ss +++ b/collects/2htdp/uchat/chatter.ss @@ -484,4 +484,7 @@ (name n) (register LOCALHOST))) -; (launch-many-worlds (main "carl") (main "sam")) \ No newline at end of file +(define (run* _) + (launch-many-worlds (main "carl") (main "sam"))) + +(run* 0) diff --git a/collects/2htdp/uchat/server.ss b/collects/2htdp/uchat/server.ss index ce34ba1a6f..3e5ce6d1f6 100644 --- a/collects/2htdp/uchat/server.ss +++ b/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))) \ No newline at end of file + (on-msg forward))) + +(run 0) diff --git a/collects/2htdp/uchat/xrun b/collects/2htdp/uchat/xrun new file mode 100755 index 0000000000..27361d78a4 --- /dev/null +++ b/collects/2htdp/uchat/xrun @@ -0,0 +1,4 @@ +#!/bin/tcsh + +mred server.ss & +mred chatter.ss -e"(run* 'go)" & diff --git a/collects/2htdp/universe.ss b/collects/2htdp/universe.ss index f14298c603..ba0f7e2e82 100644 --- a/collects/2htdp/universe.ss +++ b/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,