diff --git a/basis/game-input/dinput/dinput.factor b/basis/game-input/dinput/dinput.factor index 8540907db9..0ecf543baa 100755 --- a/basis/game-input/dinput/dinput.factor +++ b/basis/game-input/dinput/dinput.factor @@ -1,14 +1,13 @@ -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 ; +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 ; IN: game-input.dinput - CONSTANT: MOUSE-BUFFER-SIZE 16 SINGLETON: dinput-game-input-backend diff --git a/basis/io/servers/connection/connection.factor b/basis/io/servers/connection/connection.factor index df6c21e7cc..de75165c7a 100644 --- a/basis/io/servers/connection/connection.factor +++ b/basis/io/servers/connection/connection.factor @@ -11,17 +11,17 @@ combinators.short-circuit ; IN: io.servers.connection TUPLE: threaded-server -name -log-level +{ name initial: "server" } +{ log-level initial: DEBUG } secure insecure -secure-config -sockets +{ secure-config initial-quot: [ ] } +{ sockets initial-quot: [ V{ } clone ] } max-connections semaphore -timeout +{ timeout initial-quot: [ 1 minutes ] } encoding -handler -ready ; +{ handler initial: [ "No handler quotation" throw ] } +{ ready initial-quot: [ ] } ; : local-server ( port -- addrspec ) "localhost" swap ; @@ -29,14 +29,7 @@ ready ; : new-threaded-server ( encoding class -- threaded-server ) new - swap >>encoding - "server" >>name - DEBUG >>log-level - 1 minutes >>timeout - V{ } clone >>sockets - >>secure-config - [ "No handler quotation" throw ] >>handler - >>ready ; inline + swap >>encoding ; : ( encoding -- threaded-server ) threaded-server new-threaded-server ; diff --git a/core/bootstrap/syntax.factor b/core/bootstrap/syntax.factor index f5182a0210..24538229c6 100644 --- a/core/bootstrap/syntax.factor +++ b/core/bootstrap/syntax.factor @@ -80,6 +80,7 @@ IN: bootstrap.syntax ">>" "call-next-method" "initial:" + "initial-quot:" "read-only" "call(" "execute(" diff --git a/core/classes/tuple/parser/parser-tests.factor b/core/classes/tuple/parser/parser-tests.factor index b95507c78b..350b594274 100644 --- a/core/classes/tuple/parser/parser-tests.factor +++ b/core/classes/tuple/parser/parser-tests.factor @@ -1,7 +1,7 @@ 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 ; +arrays classes.tuple eval multiline ; TUPLE: test-1 ; @@ -142,3 +142,11 @@ TUPLE: parsing-corner-case x ; " 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 diff --git a/core/classes/tuple/tuple.factor b/core/classes/tuple/tuple.factor index 225176f4e5..55fbdf725f 100755 --- a/core/classes/tuple/tuple.factor +++ b/core/classes/tuple/tuple.factor @@ -50,8 +50,19 @@ M: tuple class layout-of 2 slot { word } declare ; 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>> ] map ; + all-slots [ initial-value ] map ; : pad-slots ( slots class -- slots' class ) [ initial-values over length tail append ] keep ; inline @@ -64,9 +75,7 @@ PRIVATE> : tuple-slots ( tuple -- seq ) prepare-tuple>array drop copy-tuple-slots ; -GENERIC: slots>tuple ( seq class -- tuple ) - -M: tuple-class slots>tuple +: slots>tuple ( seq class -- tuple ) check-slots pad-slots tuple-layout [ [ tuple-size ] @@ -176,7 +185,7 @@ ERROR: bad-superclass class ; : compute-slot-permutation ( new-slots old-slots -- triples ) [ [ [ name>> ] map ] bi@ [ index ] curry map ] [ drop [ class>> ] map ] - [ drop [ initial>> ] map ] + [ drop [ initial-value ] map ] 2tri 3array flip ; : update-slot ( old-values n class initial -- value ) diff --git a/core/slots/slots.factor b/core/slots/slots.factor index 304ded0adb..9db26846d0 100755 --- a/core/slots/slots.factor +++ b/core/slots/slots.factor @@ -3,10 +3,10 @@ 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 ; +words sequences.private assocs alien quotations hashtables summary ; IN: slots -TUPLE: slot-spec name offset class initial read-only ; +TUPLE: slot-spec name offset class initial initial-quot read-only ; PREDICATE: reader < word "reader" word-prop ; @@ -190,6 +190,7 @@ ERROR: bad-slot-attribute key ; 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 @@ -197,7 +198,17 @@ ERROR: bad-slot-attribute key ; 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? diff --git a/core/syntax/syntax.factor b/core/syntax/syntax.factor index 56ac9fa36e..8093b6345b 100644 --- a/core/syntax/syntax.factor +++ b/core/syntax/syntax.factor @@ -245,7 +245,9 @@ IN: bootstrap.syntax ] 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