-USING: accessors alien alien.c-types alien.strings arrays
-assocs byte-arrays combinators continuations game-input
-game-input.dinput.keys-array io.encodings.utf16
-io.encodings.utf16n kernel locals math math.bitwise
-math.rectangles namespaces parser sequences shuffle
-struct-arrays ui.backend.windows vectors windows.com
-windows.dinput windows.dinput.constants windows.errors
-windows.kernel32 windows.messages windows.ole32
-windows.user32 ;
+USING: windows.dinput windows.dinput.constants parser
+alien.c-types windows.ole32 namespaces assocs kernel arrays
+vectors windows.kernel32 windows.com windows.dinput shuffle
+windows.user32 windows.messages sequences combinators locals
+math.rectangles accessors math alien alien.strings
+io.encodings.utf16 io.encodings.utf16n continuations
+byte-arrays game-input.dinput.keys-array game-input
+ui.backend.windows windows.errors struct-arrays
+math.bitwise ;
IN: game-input.dinput
+
CONSTANT: MOUSE-BUFFER-SIZE 16
SINGLETON: dinput-game-input-backend
IN: io.servers.connection
TUPLE: threaded-server
-{ name initial: "server" }
-{ log-level initial: DEBUG }
+name
+log-level
secure insecure
-{ secure-config initial-quot: [ <secure-config> ] }
-{ sockets initial-quot: [ V{ } clone ] }
+secure-config
+sockets
max-connections
semaphore
-{ timeout initial-quot: [ 1 minutes ] }
+timeout
encoding
-{ handler initial: [ "No handler quotation" throw ] }
-{ ready initial-quot: [ <flag> ] } ;
+handler
+ready ;
: local-server ( port -- addrspec ) "localhost" swap <inet> ;
: new-threaded-server ( encoding class -- threaded-server )
new
- swap >>encoding ;
+ swap >>encoding
+ "server" >>name
+ DEBUG >>log-level
+ 1 minutes >>timeout
+ V{ } clone >>sockets
+ <secure-config> >>secure-config
+ [ "No handler quotation" throw ] >>handler
+ <flag> >>ready ; inline
: <threaded-server> ( encoding -- threaded-server )
threaded-server new-threaded-server ;
">>"
"call-next-method"
"initial:"
- "initial-quot:"
"read-only"
"call("
"execute("
IN: classes.tuple.parser.tests
USING: accessors classes.tuple.parser lexer words classes
sequences math kernel slots tools.test parser compiler.units
-arrays classes.tuple eval multiline ;
+arrays classes.tuple eval ;
TUPLE: test-1 ;
" x 3 }"
} "\n" join eval( -- tuple )
] [ error>> unexpected-eof? ] must-fail-with
-
-
-[ ] [
- <" USE: sequences
- IN: classes.tuple.tests
- TUPLE: book { name initial-quot: [ "Lord of the " "Rings" append ] } ;">
- eval( -- )
-] unit-test
PRIVATE>
-: initial-value ( slot -- obj )
- dup initial>> [
- nip
- ] [
- dup initial-quot>> [
- nip call( -- obj )
- ] [
- drop f
- ] if*
- ] if* ;
-
: initial-values ( class -- slots )
- all-slots [ initial-value ] map ;
+ all-slots [ initial>> ] map ;
: pad-slots ( slots class -- slots' class )
[ initial-values over length tail append ] keep ; inline
: tuple-slots ( tuple -- seq )
prepare-tuple>array drop copy-tuple-slots ;
-: slots>tuple ( seq class -- tuple )
+GENERIC: slots>tuple ( seq class -- tuple )
+
+M: tuple-class slots>tuple
check-slots pad-slots
tuple-layout <tuple> [
[ tuple-size ]
: compute-slot-permutation ( new-slots old-slots -- triples )
[ [ [ name>> ] map ] bi@ [ index ] curry map ]
[ drop [ class>> ] map ]
- [ drop [ initial-value ] map ]
+ [ drop [ initial>> ] map ]
2tri 3array flip ;
: update-slot ( old-values n class initial -- value )
USING: arrays byte-arrays kernel kernel.private math namespaces
make sequences strings effects generic generic.standard
classes classes.algebra slots.private combinators accessors
-words sequences.private assocs alien quotations hashtables summary ;
+words sequences.private assocs alien quotations hashtables ;
IN: slots
-TUPLE: slot-spec name offset class initial initial-quot read-only ;
+TUPLE: slot-spec name offset class initial read-only ;
PREDICATE: reader < word "reader" word-prop ;
dup empty? [
unclip {
{ initial: [ [ first >>initial ] [ rest ] bi ] }
- { initial-quot: [ [ first >>initial-quot ] [ rest ] bi ] }
{ read-only [ [ t >>read-only ] dip ] }
[ bad-slot-attribute ]
} case
ERROR: bad-initial-value name ;
-ERROR: duplicate-initial-values slot ;
-
-M: duplicate-initial-values summary
- drop "Slots can either define initial: or initial-quot:, but not both" ;
-
-: check-duplicate-initial-values ( slot-spec -- slot-spec )
- dup [ initial>> ] [ initial-quot>> ] bi and
- [ duplicate-initial-values ] when ;
-
: check-initial-value ( slot-spec -- slot-spec )
- check-duplicate-initial-values
dup initial>> [
[ ] [
dup [ initial>> ] [ class>> ] bi instance?
] define-core-syntax
"initial:" "syntax" lookup define-symbol
-
- "initial-quot:" "syntax" lookup define-symbol
-
+
"read-only" "syntax" lookup define-symbol
"call(" [ \ call-effect parse-call( ] define-core-syntax