Merge branch 'master' of git://factorcode.org/git/factor

basis/constructors/constructors-tests.factor

@@ -1,7 +1,7 @@
 ! Copyright (C) 2009 Slava Pestov.
 ! See http://factorcode.org/license.txt for BSD license.
 USING: tools.test constructors calendar kernel accessors
-combinators.short-circuit ;
+combinators.short-circuit initializers math ;
 IN: constructors.tests
 
 TUPLE: stock-spread stock spread timestamp ;
@@ -18,4 +18,30 @@ SYMBOL: AAPL
         [ spread>> 1234 = ]
         [ timestamp>> timestamp? ]
     } 1&&
-] unit-test
+] unit-test
+
+
+TUPLE: ct1 a ;
+TUPLE: ct2 < ct1 b ;
+TUPLE: ct3 < ct2 c ;
+TUPLE: ct4 < ct3 d ;
+
+CONSTRUCTOR: ct1 ( a -- obj )
+    [ 1 + ] change-a ;
+
+CONSTRUCTOR: ct2 ( a b -- obj )
+    initialize-ct1
+    [ 1 + ] change-a ;
+
+CONSTRUCTOR: ct3 ( a b c -- obj )
+    initialize-ct1
+    [ 1 + ] change-a ;
+
+CONSTRUCTOR: ct4 ( a b c d -- obj )
+    initialize-ct3
+    [ 1 + ] change-a ;
+
+[ 1 ] [ 0 <ct1> a>> ] unit-test
+[ 2 ] [ 0 0 <ct2> a>> ] unit-test
+[ 2 ] [ 0 0 0 <ct3> a>> ] unit-test
+[ 3 ] [ 0 0 0 0 <ct4> a>> ] unit-test

basis/constructors/constructors.factor

@@ -1,23 +1,53 @@
-! Copyright (C) 2009 Slava Pestov.
+! Copyright (C) 2009 Slava Pestov, Doug Coleman.
 ! See http://factorcode.org/license.txt for BSD license.
 USING: slots kernel sequences fry accessors parser lexer words
-effects.parser macros ;
+effects.parser macros generalizations locals classes.tuple
+vocabs generic.standard ;
 IN: constructors
 
 ! An experiment
 
-MACRO: set-slots ( slots -- quot )
+: initializer-name ( class -- word )
-    <reversed> [ setter-word '[ swap _ execute ] ] map [ ] join ;
+    name>> "initialize-" prepend ;
 
-: construct ( ... class slots -- instance )
+: lookup-initializer ( class -- word/f )
-    [ new ] dip set-slots ; inline
+    initializer-name "initializers" lookup ;
 
-: define-constructor ( name class effect body -- )
+: initializer-word ( class -- word )
-    [ [ in>> '[ _ _ construct ] ] dip compose ] [ drop ] 2bi
+    initializer-name
-    define-declared ;
+    "initializers" create-vocab create
+    [ t "initializer" set-word-prop ] [ ] bi ;
+
+: define-initializer-generic ( name -- )
+    initializer-word (( object -- object )) define-simple-generic ;
+
+: define-initializer ( class def -- )
+    [ drop define-initializer-generic ]
+    [ [ dup lookup-initializer ] dip H{ } clone define-typecheck ] 2bi ;
+
+MACRO:: slots>constructor ( class slots -- quot )
+    slots class
+    all-slots [ name>> ] map
+    [ '[ _ = ] find drop ] with map
+    [ [ ] count ] [ ] [ length ] tri
+    '[
+        _ narray _
+        [ swap over [ nth ] [ drop ] if ] with map
+        _ firstn class boa
+    ] ;
+
+:: define-constructor ( constructor-word class effect def -- )
+    constructor-word
+    class def define-initializer
+    class effect in>> '[ _ _ slots>constructor ]
+    class lookup-initializer
+    '[ @ _ execute( obj -- obj ) ] effect define-declared ;
+
+: scan-constructor ( -- class word )
+    scan-word [ name>> "<" ">" surround create-in ] keep ;
 
 SYNTAX: CONSTRUCTOR:
-    scan-word [ name>> "<" ">" surround create-in ] keep
+    scan-constructor
     complete-effect
     parse-definition
-    define-constructor ;
+    define-constructor ;

extra/managed-server/chat/chat.factor

@@ -126,7 +126,8 @@ M: chat-server handle-client-disconnect
     ] "" append-outputs-as send-everyone ;
 
 M: chat-server handle-already-logged-in
-    username username-taken-string send-line ;
+    username username-taken-string send-line
+    t client (>>quit?) ;
 
 M: chat-server handle-managed-client*
     readln dup f = [ t client (>>quit?) ] when

extra/managed-server/managed-server.factor

@@ -11,7 +11,7 @@ TUPLE: managed-server < threaded-server clients ;
 
 TUPLE: managed-client
 input-stream output-stream local-address remote-address
-username object quit? ;
+username object quit? logged-in? ;
 
 HOOK: handle-login threaded-server ( -- username )
 HOOK: handle-managed-client* managed-server ( -- )
@@ -62,26 +62,39 @@ PRIVATE>
         local-address get >>local-address
         remote-address get >>remote-address ;
 
-: check-logged-in ( username -- username )
+: maybe-login-client ( -- )
-    dup clients key? [ handle-already-logged-in ] when ;
+    username clients key? [
+        handle-already-logged-in
+    ] [
+        t client (>>logged-in?)
+        client username clients set-at
+    ] if ;
 
-: add-managed-client ( -- )
+: when-logged-in ( quot -- )
-    client username check-logged-in clients set-at ;
+    client logged-in?>> [ call ] [ drop ] if ; inline
 
 : delete-managed-client ( -- )
-    username server clients>> delete-at ;
+    [ username server clients>> delete-at ] when-logged-in ;
 
 : handle-managed-client ( -- )
     handle-login <managed-client> managed-client set
-    add-managed-client handle-client-join
+    maybe-login-client [
-    [ handle-managed-client* client quit?>> not ] loop ;
+        handle-client-join
+        [ handle-managed-client* client quit?>> not ] loop
+    ] when-logged-in ;
+
+: cleanup-client ( -- )
+    [
+        delete-managed-client
+        handle-client-disconnect
+    ] when-logged-in ;
 
 PRIVATE>
 
 M: managed-server handle-client*
     managed-server set
     [ handle-managed-client ]
-    [ delete-managed-client handle-client-disconnect ]
+    [ cleanup-client ]
     [ ] cleanup ;
 
 : new-managed-server ( port name encoding class -- server )