! 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 ;
[ spread>> 1234 = ]
[ timestamp>> timestamp? ]
} 1&&
-] unit-test
\ No newline at end of file
+] 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
-! 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 )
- <reversed> [ setter-word '[ swap _ execute ] ] map [ ] join ;
+: initializer-name ( class -- word )
+ name>> "initialize-" prepend ;
-: construct ( ... class slots -- instance )
- [ new ] dip set-slots ; inline
+: lookup-initializer ( class -- word/f )
+ initializer-name "initializers" lookup ;
-: define-constructor ( name class effect body -- )
- [ [ in>> '[ _ _ construct ] ] dip compose ] [ drop ] 2bi
- define-declared ;
+: initializer-word ( class -- word )
+ initializer-name
+ "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 ;
\ No newline at end of file
+ define-constructor ;
] "" 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
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 ( -- )
local-address get >>local-address
remote-address get >>remote-address ;
-: check-logged-in ( username -- username )
- dup clients key? [ handle-already-logged-in ] when ;
+: maybe-login-client ( -- )
+ username clients key? [
+ handle-already-logged-in
+ ] [
+ t client (>>logged-in?)
+ client username clients set-at
+ ] if ;
-: add-managed-client ( -- )
- client username check-logged-in clients set-at ;
+: when-logged-in ( quot -- )
+ 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
- [ handle-managed-client* client quit?>> not ] loop ;
+ maybe-login-client [
+ 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 )