From f9fb81a96226dd96bdc9507af36ae39be4a8ff34 Mon Sep 17 00:00:00 2001 From: Doug Coleman Date: Thu, 11 Jun 2009 21:22:24 -0400 Subject: [PATCH 1/2] merge --- basis/game-input/dinput/dinput.factor | 19 +++++++-------- basis/io/servers/connection/connection.factor | 23 ++++++++++++------- core/bootstrap/syntax.factor | 1 - core/classes/tuple/parser/parser-tests.factor | 10 +------- core/classes/tuple/tuple.factor | 19 ++++----------- core/slots/slots.factor | 15 ++---------- core/syntax/syntax.factor | 4 +--- 7 files changed, 34 insertions(+), 57 deletions(-) diff --git a/basis/game-input/dinput/dinput.factor b/basis/game-input/dinput/dinput.factor index 0ecf543baa..8540907db9 100755 --- a/basis/game-input/dinput/dinput.factor +++ b/basis/game-input/dinput/dinput.factor @@ -1,13 +1,14 @@ -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 diff --git a/basis/io/servers/connection/connection.factor b/basis/io/servers/connection/connection.factor index de75165c7a..df6c21e7cc 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 initial: "server" } -{ log-level initial: DEBUG } +name +log-level secure insecure -{ secure-config initial-quot: [ ] } -{ 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: [ ] } ; +handler +ready ; : local-server ( port -- addrspec ) "localhost" swap ; @@ -29,7 +29,14 @@ encoding : 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 + [ "No handler quotation" throw ] >>handler + >>ready ; inline : ( encoding -- threaded-server ) threaded-server new-threaded-server ; diff --git a/core/bootstrap/syntax.factor b/core/bootstrap/syntax.factor index 24538229c6..f5182a0210 100644 --- a/core/bootstrap/syntax.factor +++ b/core/bootstrap/syntax.factor @@ -80,7 +80,6 @@ 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 350b594274..b95507c78b 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 multiline ; +arrays classes.tuple eval ; TUPLE: test-1 ; @@ -142,11 +142,3 @@ 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 55fbdf725f..225176f4e5 100755 --- a/core/classes/tuple/tuple.factor +++ b/core/classes/tuple/tuple.factor @@ -50,19 +50,8 @@ 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-value ] map ; + all-slots [ initial>> ] map ; : pad-slots ( slots class -- slots' class ) [ initial-values over length tail append ] keep ; inline @@ -75,7 +64,9 @@ PRIVATE> : 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-size ] @@ -185,7 +176,7 @@ ERROR: bad-superclass class ; : 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 ) diff --git a/core/slots/slots.factor b/core/slots/slots.factor index 9db26846d0..304ded0adb 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 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 ; @@ -190,7 +190,6 @@ 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 @@ -198,17 +197,7 @@ 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 8093b6345b..56ac9fa36e 100644 --- a/core/syntax/syntax.factor +++ b/core/syntax/syntax.factor @@ -245,9 +245,7 @@ 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 From a390fe9644f2555c5b47445136113569fb68a8cc Mon Sep 17 00:00:00 2001 From: Doug Coleman Date: Thu, 11 Jun 2009 21:23:47 -0400 Subject: [PATCH 2/2] Revert "merge" This reverts commit c2a03d259a7b853b586afd68a0b842140188e0db. --- basis/game-input/dinput/dinput.factor | 19 ++++++++------- basis/io/servers/connection/connection.factor | 23 +++++++------------ core/bootstrap/syntax.factor | 1 + core/classes/tuple/parser/parser-tests.factor | 10 +++++++- core/classes/tuple/tuple.factor | 19 +++++++++++---- core/slots/slots.factor | 15 ++++++++++-- core/syntax/syntax.factor | 4 +++- 7 files changed, 57 insertions(+), 34 deletions(-) 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