From ea4d261a45ba7c24bf2ca19d21c73a5fda13b22b Mon Sep 17 00:00:00 2001 From: William Schlieper Date: Sat, 20 Feb 2010 08:09:49 -0500 Subject: [PATCH 01/37] Added rudimentary x11 support in game.input --- basis/game/input/input.factor | 1 + basis/game/input/x11/x11.factor | 67 +++++++++++++++++++++++++++++++++ 2 files changed, 68 insertions(+) create mode 100644 basis/game/input/x11/x11.factor diff --git a/basis/game/input/input.factor b/basis/game/input/input.factor index a2afbe92a3..923d5d6107 100644 --- a/basis/game/input/input.factor +++ b/basis/game/input/input.factor @@ -93,5 +93,6 @@ M: mouse-state clone { { [ os windows? ] [ "game.input.xinput" require ] } { [ os macosx? ] [ "game.input.iokit" require ] } + { [ os linux? ] [ "game.input.x11" require ] } { [ t ] [ ] } } cond diff --git a/basis/game/input/x11/x11.factor b/basis/game/input/x11/x11.factor new file mode 100644 index 0000000000..c54fc4be5d --- /dev/null +++ b/basis/game/input/x11/x11.factor @@ -0,0 +1,67 @@ +USING: alien.c-types alien.syntax arrays bit-arrays game.input +kernel namespaces sequences x11 x11.xlib ; +IN: game.input.x11 + +SINGLETON: x11-game-input-backend + +x11-game-input-backend game-input-backend set-global + +LIBRARY: xlib +FUNCTION: int XQueryKeymap ( Display* display, char[32] keys_return ) ; + +CONSTANT: x>hid-bit-order { + 0 0 0 0 0 0 0 0 + 0 41 30 31 32 33 34 35 + 36 37 38 39 45 46 42 43 + 20 26 8 21 23 28 24 12 + 18 19 47 48 40 224 4 22 + 7 9 10 11 13 14 15 51 + 52 53 225 49 29 27 6 25 + 5 17 16 54 55 56 229 85 + 226 44 57 58 59 60 61 62 + 63 64 65 66 67 83 71 95 + 96 97 86 92 93 94 87 91 + 90 89 99 0 0 0 68 69 + 0 0 0 0 0 0 0 88 + 228 84 70 0 0 74 82 75 + 80 79 77 81 78 73 76 127 + 129 128 102 103 0 72 0 0 + 0 0 227 231 0 0 0 0 + 0 0 0 0 0 0 0 0 + 0 0 0 0 0 0 0 0 + 0 0 0 0 0 0 0 0 + 0 0 0 0 0 0 0 0 + 0 0 0 0 0 0 0 0 + 0 0 0 0 0 0 0 0 + 0 0 0 0 0 0 0 0 + 0 0 0 0 0 0 0 0 + 0 0 0 0 0 0 0 0 + 0 0 0 0 0 0 0 0 + 0 0 0 0 0 0 0 0 + 0 0 0 0 0 0 0 0 + 0 0 0 0 0 0 0 0 + 0 0 0 0 0 0 0 0 + 0 0 0 0 0 0 0 0 +} + +M: x11-game-input-backend (open-game-input) ; ! assume X was already started for now +M: x11-game-input-backend (close-game-input) ; ! let someone else stop X +M: x11-game-input-backend (reset-game-input) ; ! nothing to reset at this point + +! No controller support yet--if this works, I shouldn't even need to define the other methods +M: x11-game-input-backend get-controllers f ; + + +: x-bits>hid-bits ( bit-array -- bit-array ) + 256 iota [ 2array ] 2map [ first ] filter [ second ] map + x>hid-bit-order [ nth ] with map + ?{ } swap [ t swap pick set-nth ] each ; + +M: x11-game-input-backend read-keyboard + dpy get 256 [ XQueryKeymap drop ] keep + x-bits>hid-bits keyboard-state boa ; + +M: x11-game-input-backend read-mouse + 0 0 0 0 ?{ f f f } mouse-state boa ; + +M: x11-game-input-backend reset-mouse ; \ No newline at end of file From 47666f0049f045177956c43693ec0659b363b706 Mon Sep 17 00:00:00 2001 From: William Schlieper Date: Sat, 20 Feb 2010 08:35:02 -0500 Subject: [PATCH 02/37] Fixed a bug in the linux version of game.input --- basis/game/input/linux/linux.factor | 9 ++++++--- 1 file changed, 6 insertions(+), 3 deletions(-) diff --git a/basis/game/input/linux/linux.factor b/basis/game/input/linux/linux.factor index b307835d70..b6f3d43956 100644 --- a/basis/game/input/linux/linux.factor +++ b/basis/game/input/linux/linux.factor @@ -4,6 +4,9 @@ USING: alien.c-types alien.syntax arrays kernel game.input namespaces classes bit-arrays sequences vectors x11 x11.xlib ; IN: game.input.linux +LIBRARY: xlib +FUNCTION: int XQueryKeymap ( Display* display, char[32] keys_return ) ; + SINGLETON: linux-game-input-backend linux-game-input-backend game-input-backend set-global @@ -74,9 +77,9 @@ CONSTANT: x>hid-bit-order { } : x-bits>hid-bits ( bit-array -- bit-array ) - 256 iota [ 2array ] 2map [ first ] filter [ second ] map - x>hid-bit-order [ nth ] with map - ?{ } swap [ t swap pick set-nth ] each ; + 256 iota [ 2array ] { } 2map-as [ first ] filter [ second ] map + x>hid-bit-order [ nth ] curry map + 256 swap [ t swap pick set-nth ] each ; M: linux-game-input-backend read-keyboard dpy get 256 [ XQueryKeymap drop ] keep From f71e22eda57f6fccba98957b482a9a17d956fffd Mon Sep 17 00:00:00 2001 From: William Schlieper Date: Sat, 20 Feb 2010 09:36:58 -0500 Subject: [PATCH 03/37] Fixed ridiculously stupid error in Linux game.input library --- basis/game/input/linux/linux.factor | 65 +++++++++++++++-------------- 1 file changed, 33 insertions(+), 32 deletions(-) diff --git a/basis/game/input/linux/linux.factor b/basis/game/input/linux/linux.factor index b6f3d43956..07889c8298 100644 --- a/basis/game/input/linux/linux.factor +++ b/basis/game/input/linux/linux.factor @@ -42,38 +42,39 @@ M: linux-game-input-backend vibrate-controller 3drop ; CONSTANT: x>hid-bit-order { - 0 0 0 0 0 0 0 0 - 0 41 30 31 32 33 34 35 - 36 37 38 39 45 46 42 43 - 20 26 8 21 23 28 24 12 - 18 19 47 48 40 224 4 22 - 7 9 10 11 13 14 15 51 - 52 53 225 49 29 27 6 25 - 5 17 16 54 55 56 229 85 - 226 44 57 58 59 60 61 62 - 63 64 65 66 67 83 71 95 - 96 97 86 92 93 94 87 91 - 90 89 99 0 0 0 68 69 - 0 0 0 0 0 0 0 88 - 228 84 70 0 0 74 82 75 - 80 79 77 81 78 73 76 127 - 129 128 102 103 0 72 0 0 - 0 0 227 231 0 0 0 0 - 0 0 0 0 0 0 0 0 - 0 0 0 0 0 0 0 0 - 0 0 0 0 0 0 0 0 - 0 0 0 0 0 0 0 0 - 0 0 0 0 0 0 0 0 - 0 0 0 0 0 0 0 0 - 0 0 0 0 0 0 0 0 - 0 0 0 0 0 0 0 0 - 0 0 0 0 0 0 0 0 - 0 0 0 0 0 0 0 0 - 0 0 0 0 0 0 0 0 - 0 0 0 0 0 0 0 0 - 0 0 0 0 0 0 0 0 - 0 0 0 0 0 0 0 0 - 0 0 0 0 0 0 0 0 + +0 0 0 0 0 0 0 0 +0 41 30 31 32 33 34 35 +36 37 38 39 45 46 42 43 +20 26 8 21 23 28 24 12 +18 19 47 48 40 224 4 22 +7 9 10 11 13 14 15 51 +52 53 225 49 29 27 6 25 +5 17 16 54 55 56 229 85 +226 44 57 58 59 60 61 62 +63 64 65 66 67 83 71 95 +96 97 86 92 93 94 87 91 +90 89 98 99 0 0 0 68 +69 0 0 0 0 0 0 0 +88 228 84 70 0 0 74 82 +75 80 79 77 81 78 73 76 +127 129 128 102 103 0 72 0 +0 0 0 227 231 0 0 0 +0 0 0 0 0 0 0 0 +0 0 0 0 0 0 0 0 +0 0 0 0 0 0 0 0 +0 0 0 0 0 0 0 0 +0 0 0 0 0 0 0 0 +0 0 0 0 0 0 0 0 +0 0 0 0 0 0 0 0 +0 0 0 0 0 0 0 0 +0 0 0 0 0 0 0 0 +0 0 0 0 0 0 0 0 +0 0 0 0 0 0 0 0 +0 0 0 0 0 0 0 0 +0 0 0 0 0 0 0 0 +0 0 0 0 0 0 0 0 +0 0 0 0 0 0 0 0 } : x-bits>hid-bits ( bit-array -- bit-array ) From dfd99199a376caa70ad519b96ff4e7e5b78ee074 Mon Sep 17 00:00:00 2001 From: Joe Groff Date: Fri, 26 Feb 2010 13:20:47 -0800 Subject: [PATCH 04/37] grouping: circular-slice shouldn't be a subclass of slice since that thwarts method inlining --- basis/grouping/grouping.factor | 13 +++++++++++-- 1 file changed, 11 insertions(+), 2 deletions(-) diff --git a/basis/grouping/grouping.factor b/basis/grouping/grouping.factor index 0dced6ad9d..304fd50fcc 100644 --- a/basis/grouping/grouping.factor +++ b/basis/grouping/grouping.factor @@ -1,7 +1,8 @@ ! Copyright (C) 2005, 2010 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. USING: kernel math math.order strings arrays vectors sequences -sequences.private accessors fry combinators.short-circuit ; +sequences.private accessors fry combinators.short-circuit +combinators ; IN: grouping > ] [ from>> ] bi - ; inline +M: circular-slice virtual-exemplar seq>> ; inline M: circular-slice virtual@ [ from>> + ] [ seq>> ] bi [ length slice-mod ] keep ; inline From 013760a90687c41f40d8aae84bddbcba519c50ac Mon Sep 17 00:00:00 2001 From: Joe Groff Date: Fri, 26 Feb 2010 18:16:16 -0800 Subject: [PATCH 05/37] co-credit William Schlieper for game.input.linux --- basis/game/input/linux/authors.txt | 3 ++- basis/game/input/linux/linux.factor | 2 +- 2 files changed, 3 insertions(+), 2 deletions(-) diff --git a/basis/game/input/linux/authors.txt b/basis/game/input/linux/authors.txt index 67cf648cf5..d73be90188 100644 --- a/basis/game/input/linux/authors.txt +++ b/basis/game/input/linux/authors.txt @@ -1 +1,2 @@ -Erik Charlebois \ No newline at end of file +Erik Charlebois +William Schlieper diff --git a/basis/game/input/linux/linux.factor b/basis/game/input/linux/linux.factor index 07889c8298..a1b9c57def 100644 --- a/basis/game/input/linux/linux.factor +++ b/basis/game/input/linux/linux.factor @@ -1,4 +1,4 @@ -! Copyright (C) 2010 Erik Charlebois. +! Copyright (C) 2010 Erik Charlebois, William Schlieper. ! See http://factorcode.org/license.txt for BSD license. USING: alien.c-types alien.syntax arrays kernel game.input namespaces classes bit-arrays sequences vectors x11 x11.xlib ; From 3d479927d79c4a06b06f946309bbe3d68fd37d68 Mon Sep 17 00:00:00 2001 From: Joe Groff Date: Fri, 26 Feb 2010 18:21:37 -0800 Subject: [PATCH 06/37] move XQueryKeymap binding to x11.xlib --- basis/game/input/linux/linux.factor | 75 ++++++++++++++--------------- basis/x11/xlib/xlib.factor | 5 ++ 2 files changed, 42 insertions(+), 38 deletions(-) diff --git a/basis/game/input/linux/linux.factor b/basis/game/input/linux/linux.factor index a1b9c57def..cd482ae604 100644 --- a/basis/game/input/linux/linux.factor +++ b/basis/game/input/linux/linux.factor @@ -42,49 +42,48 @@ M: linux-game-input-backend vibrate-controller 3drop ; CONSTANT: x>hid-bit-order { - -0 0 0 0 0 0 0 0 -0 41 30 31 32 33 34 35 -36 37 38 39 45 46 42 43 -20 26 8 21 23 28 24 12 -18 19 47 48 40 224 4 22 -7 9 10 11 13 14 15 51 -52 53 225 49 29 27 6 25 -5 17 16 54 55 56 229 85 -226 44 57 58 59 60 61 62 -63 64 65 66 67 83 71 95 -96 97 86 92 93 94 87 91 -90 89 98 99 0 0 0 68 -69 0 0 0 0 0 0 0 -88 228 84 70 0 0 74 82 -75 80 79 77 81 78 73 76 -127 129 128 102 103 0 72 0 -0 0 0 227 231 0 0 0 -0 0 0 0 0 0 0 0 -0 0 0 0 0 0 0 0 -0 0 0 0 0 0 0 0 -0 0 0 0 0 0 0 0 -0 0 0 0 0 0 0 0 -0 0 0 0 0 0 0 0 -0 0 0 0 0 0 0 0 -0 0 0 0 0 0 0 0 -0 0 0 0 0 0 0 0 -0 0 0 0 0 0 0 0 -0 0 0 0 0 0 0 0 -0 0 0 0 0 0 0 0 -0 0 0 0 0 0 0 0 -0 0 0 0 0 0 0 0 -0 0 0 0 0 0 0 0 + 0 0 0 0 0 0 0 0 + 0 41 30 31 32 33 34 35 + 36 37 38 39 45 46 42 43 + 20 26 8 21 23 28 24 12 + 18 19 47 48 40 224 4 22 + 7 9 10 11 13 14 15 51 + 52 53 225 49 29 27 6 25 + 5 17 16 54 55 56 229 85 + 226 44 57 58 59 60 61 62 + 63 64 65 66 67 83 71 95 + 96 97 86 92 93 94 87 91 + 90 89 98 99 0 0 0 68 + 69 0 0 0 0 0 0 0 + 88 228 84 70 0 0 74 82 + 75 80 79 77 81 78 73 76 + 127 129 128 102 103 0 72 0 + 0 0 0 227 231 0 0 0 + 0 0 0 0 0 0 0 0 + 0 0 0 0 0 0 0 0 + 0 0 0 0 0 0 0 0 + 0 0 0 0 0 0 0 0 + 0 0 0 0 0 0 0 0 + 0 0 0 0 0 0 0 0 + 0 0 0 0 0 0 0 0 + 0 0 0 0 0 0 0 0 + 0 0 0 0 0 0 0 0 + 0 0 0 0 0 0 0 0 + 0 0 0 0 0 0 0 0 + 0 0 0 0 0 0 0 0 + 0 0 0 0 0 0 0 0 + 0 0 0 0 0 0 0 0 + 0 0 0 0 0 0 0 0 } : x-bits>hid-bits ( bit-array -- bit-array ) - 256 iota [ 2array ] { } 2map-as [ first ] filter [ second ] map - x>hid-bit-order [ nth ] curry map - 256 swap [ t swap pick set-nth ] each ; + 256 iota [ 2array ] { } 2map-as [ first ] filter [ second ] map + x>hid-bit-order [ nth ] curry map + 256 swap [ t swap pick set-nth ] each ; M: linux-game-input-backend read-keyboard - dpy get 256 [ XQueryKeymap drop ] keep - x-bits>hid-bits keyboard-state boa ; + dpy get 256 [ XQueryKeymap drop ] keep + x-bits>hid-bits keyboard-state boa ; M: linux-game-input-backend read-mouse 0 0 0 0 2 mouse-state boa ; diff --git a/basis/x11/xlib/xlib.factor b/basis/x11/xlib/xlib.factor index e86bb5e8c3..1c5ff2e3ef 100644 --- a/basis/x11/xlib/xlib.factor +++ b/basis/x11/xlib/xlib.factor @@ -1406,3 +1406,8 @@ X-FUNCTION: c-string setlocale ( int category, c-string name ) ; X-FUNCTION: Bool XSupportsLocale ( ) ; X-FUNCTION: c-string XSetLocaleModifiers ( c-string modifier_list ) ; + +! uncategorized xlib bindings + +X-FUNCTION: int XQueryKeymap ( Display* display, char[32] keys_return ) ; + From 09517a87e3eba441b9bc301a4672be6401b3b7a5 Mon Sep 17 00:00:00 2001 From: Joe Groff Date: Fri, 26 Feb 2010 18:30:51 -0800 Subject: [PATCH 07/37] rename game.input.linux to game.input.x11, make x>hid-bit-order a hook on system --- basis/game/input/input.factor | 2 +- basis/game/input/linux/linux.factor | 92 ------------------- basis/game/input/{linux => x11}/authors.txt | 0 basis/game/input/{linux => x11}/platforms.txt | 0 basis/game/input/{linux => x11}/summary.txt | 0 basis/game/input/{linux => x11}/tags.txt | 0 basis/game/input/x11/x11.factor | 92 +++++++++++++++++++ 7 files changed, 93 insertions(+), 93 deletions(-) delete mode 100644 basis/game/input/linux/linux.factor rename basis/game/input/{linux => x11}/authors.txt (100%) rename basis/game/input/{linux => x11}/platforms.txt (100%) rename basis/game/input/{linux => x11}/summary.txt (100%) rename basis/game/input/{linux => x11}/tags.txt (100%) create mode 100644 basis/game/input/x11/x11.factor diff --git a/basis/game/input/input.factor b/basis/game/input/input.factor index f27e1f36d1..9b514e77e0 100644 --- a/basis/game/input/input.factor +++ b/basis/game/input/input.factor @@ -108,6 +108,6 @@ SYMBOLS: pressed released ; { { [ os windows? ] [ "game.input.xinput" require ] } { [ os macosx? ] [ "game.input.iokit" require ] } - { [ os linux? ] [ "game.input.linux" require ] } + { [ os linux? ] [ "game.input.x11" require ] } [ ] } cond diff --git a/basis/game/input/linux/linux.factor b/basis/game/input/linux/linux.factor deleted file mode 100644 index cd482ae604..0000000000 --- a/basis/game/input/linux/linux.factor +++ /dev/null @@ -1,92 +0,0 @@ -! Copyright (C) 2010 Erik Charlebois, William Schlieper. -! See http://factorcode.org/license.txt for BSD license. -USING: alien.c-types alien.syntax arrays kernel game.input namespaces -classes bit-arrays sequences vectors x11 x11.xlib ; -IN: game.input.linux - -LIBRARY: xlib -FUNCTION: int XQueryKeymap ( Display* display, char[32] keys_return ) ; - -SINGLETON: linux-game-input-backend - -linux-game-input-backend game-input-backend set-global - -M: linux-game-input-backend (open-game-input) - ; - -M: linux-game-input-backend (close-game-input) - ; - -M: linux-game-input-backend (reset-game-input) - ; - -M: linux-game-input-backend get-controllers - { } ; - -M: linux-game-input-backend product-string - drop "" ; - -M: linux-game-input-backend product-id - drop f ; - -M: linux-game-input-backend instance-id - drop f ; - -M: linux-game-input-backend read-controller - drop controller-state new ; - -M: linux-game-input-backend calibrate-controller - drop ; - -M: linux-game-input-backend vibrate-controller - 3drop ; - -CONSTANT: x>hid-bit-order { - 0 0 0 0 0 0 0 0 - 0 41 30 31 32 33 34 35 - 36 37 38 39 45 46 42 43 - 20 26 8 21 23 28 24 12 - 18 19 47 48 40 224 4 22 - 7 9 10 11 13 14 15 51 - 52 53 225 49 29 27 6 25 - 5 17 16 54 55 56 229 85 - 226 44 57 58 59 60 61 62 - 63 64 65 66 67 83 71 95 - 96 97 86 92 93 94 87 91 - 90 89 98 99 0 0 0 68 - 69 0 0 0 0 0 0 0 - 88 228 84 70 0 0 74 82 - 75 80 79 77 81 78 73 76 - 127 129 128 102 103 0 72 0 - 0 0 0 227 231 0 0 0 - 0 0 0 0 0 0 0 0 - 0 0 0 0 0 0 0 0 - 0 0 0 0 0 0 0 0 - 0 0 0 0 0 0 0 0 - 0 0 0 0 0 0 0 0 - 0 0 0 0 0 0 0 0 - 0 0 0 0 0 0 0 0 - 0 0 0 0 0 0 0 0 - 0 0 0 0 0 0 0 0 - 0 0 0 0 0 0 0 0 - 0 0 0 0 0 0 0 0 - 0 0 0 0 0 0 0 0 - 0 0 0 0 0 0 0 0 - 0 0 0 0 0 0 0 0 - 0 0 0 0 0 0 0 0 -} - -: x-bits>hid-bits ( bit-array -- bit-array ) - 256 iota [ 2array ] { } 2map-as [ first ] filter [ second ] map - x>hid-bit-order [ nth ] curry map - 256 swap [ t swap pick set-nth ] each ; - -M: linux-game-input-backend read-keyboard - dpy get 256 [ XQueryKeymap drop ] keep - x-bits>hid-bits keyboard-state boa ; - -M: linux-game-input-backend read-mouse - 0 0 0 0 2 mouse-state boa ; - -M: linux-game-input-backend reset-mouse - ; diff --git a/basis/game/input/linux/authors.txt b/basis/game/input/x11/authors.txt similarity index 100% rename from basis/game/input/linux/authors.txt rename to basis/game/input/x11/authors.txt diff --git a/basis/game/input/linux/platforms.txt b/basis/game/input/x11/platforms.txt similarity index 100% rename from basis/game/input/linux/platforms.txt rename to basis/game/input/x11/platforms.txt diff --git a/basis/game/input/linux/summary.txt b/basis/game/input/x11/summary.txt similarity index 100% rename from basis/game/input/linux/summary.txt rename to basis/game/input/x11/summary.txt diff --git a/basis/game/input/linux/tags.txt b/basis/game/input/x11/tags.txt similarity index 100% rename from basis/game/input/linux/tags.txt rename to basis/game/input/x11/tags.txt diff --git a/basis/game/input/x11/x11.factor b/basis/game/input/x11/x11.factor new file mode 100644 index 0000000000..4e6f610531 --- /dev/null +++ b/basis/game/input/x11/x11.factor @@ -0,0 +1,92 @@ +! Copyright (C) 2010 Erik Charlebois, William Schlieper. +! See http://factorcode.org/license.txt for BSD license. +USING: arrays kernel game.input namespaces +classes bit-arrays system sequences vectors x11 x11.xlib ; +IN: game.input.x11 + +SINGLETON: x11-game-input-backend + +x11-game-input-backend game-input-backend set-global + +M: x11-game-input-backend (open-game-input) + ; + +M: x11-game-input-backend (close-game-input) + ; + +M: x11-game-input-backend (reset-game-input) + ; + +M: x11-game-input-backend get-controllers + { } ; + +M: x11-game-input-backend product-string + drop "" ; + +M: x11-game-input-backend product-id + drop f ; + +M: x11-game-input-backend instance-id + drop f ; + +M: x11-game-input-backend read-controller + drop controller-state new ; + +M: x11-game-input-backend calibrate-controller + drop ; + +M: x11-game-input-backend vibrate-controller + 3drop ; + +HOOK: x>hid-bit-order os ( -- x ) + +M: linux x>hid-bit-order + { + 0 0 0 0 0 0 0 0 + 0 41 30 31 32 33 34 35 + 36 37 38 39 45 46 42 43 + 20 26 8 21 23 28 24 12 + 18 19 47 48 40 224 4 22 + 7 9 10 11 13 14 15 51 + 52 53 225 49 29 27 6 25 + 5 17 16 54 55 56 229 85 + 226 44 57 58 59 60 61 62 + 63 64 65 66 67 83 71 95 + 96 97 86 92 93 94 87 91 + 90 89 98 99 0 0 0 68 + 69 0 0 0 0 0 0 0 + 88 228 84 70 0 0 74 82 + 75 80 79 77 81 78 73 76 + 127 129 128 102 103 0 72 0 + 0 0 0 227 231 0 0 0 + 0 0 0 0 0 0 0 0 + 0 0 0 0 0 0 0 0 + 0 0 0 0 0 0 0 0 + 0 0 0 0 0 0 0 0 + 0 0 0 0 0 0 0 0 + 0 0 0 0 0 0 0 0 + 0 0 0 0 0 0 0 0 + 0 0 0 0 0 0 0 0 + 0 0 0 0 0 0 0 0 + 0 0 0 0 0 0 0 0 + 0 0 0 0 0 0 0 0 + 0 0 0 0 0 0 0 0 + 0 0 0 0 0 0 0 0 + 0 0 0 0 0 0 0 0 + 0 0 0 0 0 0 0 0 + } ; inline + +: x-bits>hid-bits ( bit-array -- bit-array ) + 256 iota [ 2array ] { } 2map-as [ first ] filter [ second ] map + x>hid-bit-order [ nth ] curry map + 256 swap [ t swap pick set-nth ] each ; + +M: x11-game-input-backend read-keyboard + dpy get 256 [ XQueryKeymap drop ] keep + x-bits>hid-bits keyboard-state boa ; + +M: x11-game-input-backend read-mouse + 0 0 0 0 2 mouse-state boa ; + +M: x11-game-input-backend reset-mouse + ; From 9bf7f56283ce7adfe731367efbe94a0577b7d79c Mon Sep 17 00:00:00 2001 From: Doug Coleman Date: Thu, 25 Feb 2010 18:05:10 -0600 Subject: [PATCH 08/37] Add a new word http-data that is just http-get nip --- .../bootstrap/image/download/download.factor | 2 +- basis/http/client/client.factor | 3 +++ basis/http/http-tests.factor | 22 +++++++++---------- basis/syndication/syndication.factor | 2 +- extra/images/http/http.factor | 2 +- extra/webapps/fjsc/fjsc.factor | 2 +- extra/yahoo/yahoo.factor | 2 +- 7 files changed, 19 insertions(+), 16 deletions(-) diff --git a/basis/bootstrap/image/download/download.factor b/basis/bootstrap/image/download/download.factor index e2de621984..9ab7689eca 100644 --- a/basis/bootstrap/image/download/download.factor +++ b/basis/bootstrap/image/download/download.factor @@ -7,7 +7,7 @@ IN: bootstrap.image.download CONSTANT: url URL" http://factorcode.org/images/latest/" : download-checksums ( -- alist ) - url "checksums.txt" >url derive-url http-get nip + url "checksums.txt" >url derive-url http-data string-lines [ " " split1 ] { } map>assoc ; : need-new-image? ( image -- ? ) diff --git a/basis/http/client/client.factor b/basis/http/client/client.factor index 482a23aeaa..9e540f111f 100644 --- a/basis/http/client/client.factor +++ b/basis/http/client/client.factor @@ -157,6 +157,9 @@ ERROR: download-failed response ; : http-get ( url -- response data ) http-request ; +: http-data ( url -- data ) + http-get nip ; + : with-http-get ( url quot -- response ) [ ] dip with-http-request ; inline diff --git a/basis/http/http-tests.factor b/basis/http/http-tests.factor index 35d01c1014..62936af7ff 100644 --- a/basis/http/http-tests.factor +++ b/basis/http/http-tests.factor @@ -226,14 +226,14 @@ test-db [ [ t ] [ "vocab:http/test/foo.html" ascii file-contents - "http://localhost/nested/foo.html" add-port http-get nip = + "http://localhost/nested/foo.html" add-port http-data = ] unit-test -[ "http://localhost/redirect-loop" add-port http-get nip ] +[ "http://localhost/redirect-loop" add-port http-data ] [ too-many-redirects? ] must-fail-with [ "Goodbye" ] [ - "http://localhost/quit" add-port http-get nip + "http://localhost/quit" add-port http-data ] unit-test ! HTTP client redirect bug @@ -247,7 +247,7 @@ test-db [ ] unit-test [ "Goodbye" ] [ - "http://localhost/redirect" add-port http-get nip + "http://localhost/redirect" add-port http-data ] unit-test @@ -274,12 +274,12 @@ test-db [ : 404? ( response -- ? ) [ download-failed? ] [ response>> code>> 404 = ] bi and ; ! This should give a 404 not an infinite redirect loop -[ "http://localhost/d/blah" add-port http-get nip ] [ 404? ] must-fail-with +[ "http://localhost/d/blah" add-port http-data ] [ 404? ] must-fail-with ! This should give a 404 not an infinite redirect loop -[ "http://localhost/blah/" add-port http-get nip ] [ 404? ] must-fail-with +[ "http://localhost/blah/" add-port http-data ] [ 404? ] must-fail-with -[ "Goodbye" ] [ "http://localhost/quit" add-port http-get nip ] unit-test +[ "Goodbye" ] [ "http://localhost/quit" add-port http-data ] unit-test [ ] [ @@ -293,9 +293,9 @@ test-db [ test-httpd ] unit-test -[ "Hi" ] [ "http://localhost/" add-port http-get nip ] unit-test +[ "Hi" ] [ "http://localhost/" add-port http-data ] unit-test -[ "Goodbye" ] [ "http://localhost/quit" add-port http-get nip ] unit-test +[ "Goodbye" ] [ "http://localhost/quit" add-port http-data ] unit-test USING: html.components html.forms xml xml.traversal validators @@ -353,7 +353,7 @@ SYMBOL: a [ 4 ] [ a get-global ] unit-test -[ "Goodbye" ] [ "http://localhost/quit" add-port http-get nip ] unit-test +[ "Goodbye" ] [ "http://localhost/quit" add-port http-data ] unit-test ! Test cloning [ f ] [ <404> dup clone "b" "a" set-header drop "a" header ] unit-test @@ -371,7 +371,7 @@ SYMBOL: a ] unit-test [ t ] [ - "http://localhost/" add-port http-get nip + "http://localhost/" add-port http-data "vocab:http/test/foo.html" ascii file-contents = ] unit-test diff --git a/basis/syndication/syndication.factor b/basis/syndication/syndication.factor index fe31a49265..edfbebeeab 100644 --- a/basis/syndication/syndication.factor +++ b/basis/syndication/syndication.factor @@ -115,7 +115,7 @@ M: byte-array parse-feed [ bytes>xml xml>feed ] with-html-entities ; : download-feed ( url -- feed ) #! Retrieve an news syndication file, return as a feed tuple. - http-get nip parse-feed ; + http-data parse-feed ; ! Atom generation diff --git a/extra/images/http/http.factor b/extra/images/http/http.factor index 620ab6f73b..d3cff18afb 100644 --- a/extra/images/http/http.factor +++ b/extra/images/http/http.factor @@ -5,7 +5,7 @@ images.viewer ; IN: images.http : load-http-image ( path -- image ) - [ http-get nip ] [ image-class ] bi load-image* ; + [ http-data ] [ image-class ] bi load-image* ; : http-image. ( path -- ) load-http-image image. ; diff --git a/extra/webapps/fjsc/fjsc.factor b/extra/webapps/fjsc/fjsc.factor index 01d6935bee..4dec258083 100644 --- a/extra/webapps/fjsc/fjsc.factor +++ b/extra/webapps/fjsc/fjsc.factor @@ -35,7 +35,7 @@ TUPLE: fjsc < dispatcher ; : do-compile-url ( url -- response ) [ - absolute-url http-get nip 'expression' parse fjsc-compile write "();" write + absolute-url http-data 'expression' parse fjsc-compile write "();" write ] with-string-writer "application/javascript" ; diff --git a/extra/yahoo/yahoo.factor b/extra/yahoo/yahoo.factor index 5e0c08b430..2a8469c328 100644 --- a/extra/yahoo/yahoo.factor +++ b/extra/yahoo/yahoo.factor @@ -57,4 +57,4 @@ CONSTANT: factor-id "fRrVAKzV34GDyeRw6bUHDhEWHRedwfOC7e61wwXZLgGF80E67spxdQXuugB swap >>query ; : search-yahoo ( search -- seq ) - query http-get nip string>xml parse-yahoo ; + query http-data string>xml parse-yahoo ; From 18c0935b64c5745c47cb4fa17c40365a32313be8 Mon Sep 17 00:00:00 2001 From: Doug Coleman Date: Thu, 25 Feb 2010 18:07:14 -0600 Subject: [PATCH 09/37] Docs for http-data --- basis/http/client/client-docs.factor | 7 ++++++- 1 file changed, 6 insertions(+), 1 deletion(-) diff --git a/basis/http/client/client-docs.factor b/basis/http/client/client-docs.factor index 04077fc2f7..0d0887d10d 100644 --- a/basis/http/client/client-docs.factor +++ b/basis/http/client/client-docs.factor @@ -35,6 +35,11 @@ HELP: http-get { $description "Downloads the contents of a URL." } { $errors "Throws an error if the HTTP request fails." } ; +HELP: http-data +{ $values { "url" "a " { $link url } " or " { $link string } } { "data" sequence } } +{ $description "Downloads the contents of a URL. To view the HTTP response, use " { $link http-get } "." } +{ $errors "Throws an error if the HTTP request fails." } ; + HELP: http-post { $values { "post-data" object } { "url" "a " { $link url } " or " { $link string } } { "response" response } { "data" sequence } } { $description "Submits an HTTP POST request." } @@ -61,7 +66,7 @@ HELP: with-http-request ARTICLE: "http.client.get" "GET requests with the HTTP client" "Basic usage involves passing a " { $link url } " and getting a " { $link response } " and data back:" -{ $subsections http-get } +{ $subsections http-get http-data } "Utilities to retrieve a " { $link url } " and save the contents to a file:" { $subsections download From 5eff2e0e9aad9951eb479d27fb20abb29df76afc Mon Sep 17 00:00:00 2001 From: Doug Coleman Date: Thu, 25 Feb 2010 18:30:40 -0600 Subject: [PATCH 10/37] Add csv>string and string>csv --- basis/csv/csv-docs.factor | 18 ++++++++++++++++++ basis/csv/csv.factor | 22 ++++++++++++++++++---- 2 files changed, 36 insertions(+), 4 deletions(-) diff --git a/basis/csv/csv-docs.factor b/basis/csv/csv-docs.factor index 1f05ab639b..1796a029de 100644 --- a/basis/csv/csv-docs.factor +++ b/basis/csv/csv-docs.factor @@ -21,6 +21,20 @@ HELP: csv>file } { $description "Writes a comma-separated-value structure to a file." } ; +HELP: string>csv +{ $values + { "string" string } + { "csv" "csv" } +} +{ $description "Parses a string into a sequence of comma-separated-value fields." } ; + +HELP: csv>string +{ $values + { "rows" "a sequence of sequences of strings" } + { "string" string } +} +{ $description "Writes a comma-separated-value structure to a string." } ; + HELP: csv-row { $values { "stream" "an input stream" } { "row" "an array of fields" } } @@ -42,6 +56,10 @@ ARTICLE: "csv" "Comma-separated-values parsing and writing" { $subsections file>csv } "Writing a csv file:" { $subsections csv>file } +"Reading a string to csv:" +{ $subsections string>csv } +"Writing csv to a string:" +{ $subsections csv>string } "Changing the delimiter from a comma:" { $subsections with-delimiter } "Reading from a stream:" diff --git a/basis/csv/csv.factor b/basis/csv/csv.factor index 23416d6912..1aeb2e1d19 100644 --- a/basis/csv/csv.factor +++ b/basis/csv/csv.factor @@ -1,7 +1,8 @@ ! Copyright (C) 2007, 2008 Phil Dawes ! See http://factorcode.org/license.txt for BSD license. USING: kernel sequences io namespaces make combinators -unicode.categories io.files combinators.short-circuit ; +unicode.categories io.files combinators.short-circuit +io.streams.string ; IN: csv SYMBOL: delimiter @@ -65,6 +66,9 @@ PRIVATE> [ [ (csv) ] { } make ] with-input-stream dup last { "" } = [ but-last ] when ; +: string>csv ( string -- csv ) + csv ; + : file>csv ( path encoding -- csv ) csv ; @@ -96,8 +100,18 @@ PRIVATE> : write-row ( row -- ) [ delimiter get write1 ] [ escape-if-required write ] interleave nl ; inline - -: write-csv ( rows stream -- ) - [ [ write-row ] each ] with-output-stream ; + + +: write-csv ( rows stream -- ) + [ (write-csv) ] with-output-stream ; + +: csv>string ( csv -- string ) + [ (write-csv) ] with-string-writer ; + : csv>file ( rows path encoding -- ) write-csv ; From 90597236e1341a56c44438804ecfb21045dbb87a Mon Sep 17 00:00:00 2001 From: Doug Coleman Date: Sat, 27 Feb 2010 05:01:14 -0600 Subject: [PATCH 11/37] Add a slots{ word for accessing multiple slots --- extra/slots/syntax/authors.txt | 1 + extra/slots/syntax/syntax-docs.factor | 20 ++++++++++++++++++++ extra/slots/syntax/syntax-tests.factor | 10 ++++++++++ extra/slots/syntax/syntax.factor | 10 ++++++++++ 4 files changed, 41 insertions(+) create mode 100755 extra/slots/syntax/authors.txt create mode 100755 extra/slots/syntax/syntax-docs.factor create mode 100755 extra/slots/syntax/syntax-tests.factor create mode 100755 extra/slots/syntax/syntax.factor diff --git a/extra/slots/syntax/authors.txt b/extra/slots/syntax/authors.txt new file mode 100755 index 0000000000..7c1b2f2279 --- /dev/null +++ b/extra/slots/syntax/authors.txt @@ -0,0 +1 @@ +Doug Coleman diff --git a/extra/slots/syntax/syntax-docs.factor b/extra/slots/syntax/syntax-docs.factor new file mode 100755 index 0000000000..b79916f91b --- /dev/null +++ b/extra/slots/syntax/syntax-docs.factor @@ -0,0 +1,20 @@ +! Copyright (C) 2010 Doug Coleman. +! See http://factorcode.org/license.txt for BSD license. +USING: help.markup help.syntax ; +IN: slots.syntax + +HELP: slots{ +{ $description "Outputs an array of slot values from a tuple." } +{ $example "USING: prettyprint slots.syntax ;" + "IN: slots.syntax.example" + "TUPLE: rectangle width height ;" + "T{ rectangle { width 3 } { height 5 } } slots{ width height } ." + "{ 3 5 }" +} ; + +ARTICLE: "slots.syntax" "Slots syntax sugar" +"The " { $vocab-link "slots.syntax" } " vocabulary provides an alternative syntax for taking a sequence of slots from a tuple." $nl +"Syntax sugar for cleaving slots to an array:" +{ $subsections POSTPONE: slots{ } ; + +ABOUT: "slots.syntax" diff --git a/extra/slots/syntax/syntax-tests.factor b/extra/slots/syntax/syntax-tests.factor new file mode 100755 index 0000000000..689ccb48eb --- /dev/null +++ b/extra/slots/syntax/syntax-tests.factor @@ -0,0 +1,10 @@ +! Copyright (C) 2010 Doug Coleman. +! See http://factorcode.org/license.txt for BSD license. +USING: tools.test slots.syntax ; +IN: slots.syntax.tests + +TUPLE: slot-test a b c ; + +[ { 1 2 3 } ] [ T{ slot-test f 1 2 3 } slots{ a b c } ] unit-test +[ { 3 } ] [ T{ slot-test f 1 2 3 } slots{ c } ] unit-test +[ { } ] [ T{ slot-test f 1 2 3 } slots{ } ] unit-test \ No newline at end of file diff --git a/extra/slots/syntax/syntax.factor b/extra/slots/syntax/syntax.factor new file mode 100755 index 0000000000..2cce91c569 --- /dev/null +++ b/extra/slots/syntax/syntax.factor @@ -0,0 +1,10 @@ +! Copyright (C) 2010 Doug Coleman. +! See http://factorcode.org/license.txt for BSD license. +USING: combinators combinators.smart fry lexer quotations +sequences slots ; +IN: slots.syntax + +SYNTAX: slots{ + "}" parse-tokens + [ reader-word 1quotation ] map + '[ [ _ cleave ] output>array ] append! ; \ No newline at end of file From 93efc83938091c363074d6a6eb34a8c71f84ec5c Mon Sep 17 00:00:00 2001 From: Doug Coleman Date: Sat, 27 Feb 2010 07:53:21 -0600 Subject: [PATCH 12/37] more user32 bindings --- basis/windows/user32/user32.factor | 14 ++++++++------ 1 file changed, 8 insertions(+), 6 deletions(-) diff --git a/basis/windows/user32/user32.factor b/basis/windows/user32/user32.factor index b9d5cc95c4..1c23c36071 100644 --- a/basis/windows/user32/user32.factor +++ b/basis/windows/user32/user32.factor @@ -580,8 +580,8 @@ CONSTANT: SWP_HIDEWINDOW 128 CONSTANT: SWP_NOCOPYBITS 256 CONSTANT: SWP_NOOWNERZORDER 512 CONSTANT: SWP_NOSENDCHANGING 1024 -CONSTANT: SWP_DRAWFRAME SWP_FRAMECHANGED -CONSTANT: SWP_NOREPOSITION SWP_NOOWNERZORDER +ALIAS: SWP_DRAWFRAME SWP_FRAMECHANGED +ALIAS: SWP_NOREPOSITION SWP_NOOWNERZORDER CONSTANT: SWP_DEFERERASE 8192 CONSTANT: SWP_ASYNCWINDOWPOS 16384 @@ -1250,7 +1250,7 @@ FUNCTION: UINT EnumClipboardFormats ( UINT format ) ; ! FUNCTION: EnumDesktopWindows ! FUNCTION: EnumDisplayDevicesA ! FUNCTION: EnumDisplayDevicesW -! FUNCTION: EnumDisplayMonitors +! FUNCTION: BOOL EnumDisplayMonitors ( HDC hdc, LPCRECT lprcClip, MONITORENUMPROC lpfnEnum, LPARAM dwData ) ; ! FUNCTION: EnumDisplaySettingsA ! FUNCTION: EnumDisplaySettingsExA ! FUNCTION: EnumDisplaySettingsExW @@ -1327,7 +1327,7 @@ FUNCTION: HWND GetDesktopWindow ( ) ; ! FUNCTION: GetDlgItemTextW FUNCTION: uint GetDoubleClickTime ( ) ; FUNCTION: HWND GetFocus ( ) ; -! FUNCTION: GetForegroundWindow +FUNCTION: HWND GetForegroundWindow ( ) ; ! FUNCTION: GetGuiResources ! FUNCTION: GetGUIThreadInfo ! FUNCTION: GetIconInfo @@ -1428,7 +1428,8 @@ FUNCTION: HWND GetWindow ( HWND hWnd, UINT uCmd ) ; FUNCTION: LONG_PTR GetWindowLongW ( HANDLE hWnd, int index ) ; ALIAS: GetWindowLong GetWindowLongW -FUNCTION: LONG_PTR GetWindowLongPtr ( HWND hWnd, int nIndex ) ; +FUNCTION: LONG_PTR GetWindowLongPtrW ( HWND hWnd, int nIndex ) ; +ALIAS: GetWindowLongPtr GetWindowLongPtrW ! FUNCTION: GetWindowModuleFileName ! FUNCTION: GetWindowModuleFileNameA ! FUNCTION: GetWindowModuleFileNameW @@ -1776,7 +1777,8 @@ ALIAS: SetWindowLong SetWindowLongW ! FUNCTION: SetWindowPlacement FUNCTION: BOOL SetWindowPos ( HWND hWnd, HWND hWndInsertAfter, int X, int Y, int cx, int cy, UINT uFlags ) ; -FUNCTION: LONG_PTR SetWindowLongPtr ( HWND hWnd, int nIndex, LONG_PTR dwNewLong ) ; +FUNCTION: LONG_PTR SetWindowLongPtrW ( HWND hWnd, int nIndex, LONG_PTR dwNewLong ) ; +ALIAS: SetWindowLongPtr SetWindowLongPtrW : HWND_BOTTOM ( -- alien ) 1 ; : HWND_NOTOPMOST ( -- alien ) -2 ; From bad7e4b68e3c84419c00d786fc021662b4c64257 Mon Sep 17 00:00:00 2001 From: Doug Coleman Date: Sat, 27 Feb 2010 07:54:54 -0600 Subject: [PATCH 13/37] Add a slot for worlds to know if they are fullscreened, and another for restoring the window position after returning from fullscreen mode --- basis/ui/gadgets/worlds/worlds.factor | 3 ++- 1 file changed, 2 insertions(+), 1 deletion(-) diff --git a/basis/ui/gadgets/worlds/worlds.factor b/basis/ui/gadgets/worlds/worlds.factor index 05466f4673..bcdccb23cd 100644 --- a/basis/ui/gadgets/worlds/worlds.factor +++ b/basis/ui/gadgets/worlds/worlds.factor @@ -33,7 +33,8 @@ CONSTANT: default-world-window-controls } TUPLE: world < track - active? focused? grab-input? + active? focused? grab-input? fullscreen? + saved-position layers title status status-owner text-handle handle images From cc892700c8dea87510011713d476c377f08573db Mon Sep 17 00:00:00 2001 From: Doug Coleman Date: Sat, 27 Feb 2010 08:25:25 -0600 Subject: [PATCH 14/37] add missing using --- basis/csv/csv-docs.factor | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/basis/csv/csv-docs.factor b/basis/csv/csv-docs.factor index 1796a029de..075b00eea2 100644 --- a/basis/csv/csv-docs.factor +++ b/basis/csv/csv-docs.factor @@ -1,5 +1,5 @@ USING: help.syntax help.markup kernel prettyprint sequences -io.pathnames ; +io.pathnames strings ; IN: csv HELP: csv From 07dfcf2298df860755c443f3a494814a9ca143b0 Mon Sep 17 00:00:00 2001 From: Doug Coleman Date: Sat, 27 Feb 2010 13:03:28 -0600 Subject: [PATCH 15/37] Beginning of a real fullscreen library --- extra/fullscreen/authors.txt | 1 + extra/fullscreen/fullscreen.factor | 142 +++++++++++++++++++++++++++++ extra/fullscreen/platforms.txt | 1 + 3 files changed, 144 insertions(+) create mode 100755 extra/fullscreen/authors.txt create mode 100755 extra/fullscreen/fullscreen.factor create mode 100644 extra/fullscreen/platforms.txt diff --git a/extra/fullscreen/authors.txt b/extra/fullscreen/authors.txt new file mode 100755 index 0000000000..7c1b2f2279 --- /dev/null +++ b/extra/fullscreen/authors.txt @@ -0,0 +1 @@ +Doug Coleman diff --git a/extra/fullscreen/fullscreen.factor b/extra/fullscreen/fullscreen.factor new file mode 100755 index 0000000000..a233d6f4f5 --- /dev/null +++ b/extra/fullscreen/fullscreen.factor @@ -0,0 +1,142 @@ +! Copyright (C) 2010 Doug Coleman. +! See http://factorcode.org/license.txt for BSD license. +USING: accessors alien.c-types arrays classes.struct fry kernel +literals locals make math math.bitwise multiline sequences +slots.syntax ui.backend.windows vocabs.loader windows.errors +windows.gdi32 windows.kernel32 windows.types windows.user32 +ui.gadgets.worlds ; +IN: fullscreen + +: hwnd>hmonitor ( HWND -- HMONITOR ) + MONITOR_DEFAULTTOPRIMARY MonitorFromWindow ; + +: desktop-hmonitor ( -- HMONITOR ) + GetDesktopWindow hwnd>hmonitor ; + +:: (monitor-info>devmodes) ( monitor-info n -- ) + DEVMODE + DEVMODE heap-size >>dmSize + { DM_BITSPERPEL DM_PELSWIDTH DM_PELSHEIGHT } flags >>dmFields + :> devmode + + monitor-info szDevice>> + n + devmode + EnumDisplaySettings 0 = [ + devmode , + monitor-info n 1 + (monitor-info>devmodes) + ] unless ; + +: monitor-info>devmodes ( monito-info -- devmodes ) + [ 0 (monitor-info>devmodes) ] { } make ; + +: hmonitor>monitor-info ( HMONITOR -- monitor-info ) + MONITORINFOEX + MONITORINFOEX heap-size >>cbSize + [ GetMonitorInfo win32-error=0/f ] keep ; + +: hwnd>monitor-info ( HWND -- monitor-info ) + hwnd>hmonitor hmonitor>monitor-info ; + +: hmonitor>devmodes ( HMONITOR -- devmodes ) + hmonitor>monitor-info monitor-info>devmodes ; + +: desktop-devmodes ( -- DEVMODEs ) + desktop-hmonitor hmonitor>devmodes ; + +: desktop-monitor-info ( -- monitor-info ) + desktop-hmonitor hmonitor>monitor-info ; + +: desktop-RECT ( -- RECT ) + GetDesktopWindow RECT [ GetWindowRect win32-error=0/f ] keep ; + +ERROR: display-change-error n ; + +: fullscreen-mode ( monitor-info devmode -- ) + [ szDevice>> ] dip f CDS_FULLSCREEN f + ChangeDisplaySettingsEx dup DISP_CHANGE_SUCCESSFUL = + [ drop ] [ display-change-error ] if ; + +: non-fullscreen-mode ( monitor-info devmode -- ) + [ szDevice>> ] dip f 0 f + ChangeDisplaySettingsEx dup DISP_CHANGE_SUCCESSFUL = + [ drop ] [ display-change-error ] if ; + +: get-style ( hwnd n -- style ) + GetWindowLongPtr [ win32-error=0/f ] keep ; + +: set-style ( hwnd n style -- ) + SetWindowLongPtr win32-error=0/f ; + +: change-style ( hwnd n quot -- ) + [ 2dup get-style ] dip call set-style ; inline + +: set-fullscreen-styles ( hwnd -- ) + [ GWL_STYLE [ WS_OVERLAPPEDWINDOW unmask ] change-style ] + [ GWL_EXSTYLE [ { WS_EX_APPWINDOW WS_EX_TOPMOST } flags bitor ] change-style ] bi ; + +: set-non-fullscreen-styles ( hwnd -- ) + [ GWL_STYLE [ WS_OVERLAPPEDWINDOW bitor ] change-style ] + [ GWL_EXSTYLE [ { WS_EX_APPWINDOW WS_EX_TOPMOST } flags unmask ] change-style ] bi ; + +ERROR: unsupported-resolution triple ; + +:: find-devmode ( triple hwnd -- devmode ) + hwnd hwnd>hmonitor hmonitor>devmodes + [ + slots{ dmPelsWidth dmPelsHeight dmBitsPerPel } + triple = + ] find nip [ triple unsupported-resolution ] unless* ; + +:: set-fullscreen-window-position ( hwnd triple -- ) + hwnd f + desktop-monitor-info rcMonitor>> slots{ left top } first2 + triple first2 + { + SWP_NOACTIVATE SWP_NOCOPYBITS SWP_NOOWNERZORDER + SWP_NOREPOSITION SWP_NOZORDER + } flags + SetWindowPos win32-error=0/f ; + +:: enable-fullscreen ( triple hwnd -- rect ) + hwnd hwnd>RECT :> rect + + desktop-monitor-info + triple GetDesktopWindow find-devmode + hwnd set-fullscreen-styles + fullscreen-mode + + hwnd triple set-fullscreen-window-position + rect ; + +:: set-window-position ( hwnd rect -- ) + hwnd f rect get-RECT-dimensions SWP_FRAMECHANGED + SetWindowPos win32-error=0/f ; + +:: disable-fullscreen ( rect triple hwnd -- ) + desktop-monitor-info + triple + GetDesktopWindow find-devmode non-fullscreen-mode + hwnd set-non-fullscreen-styles + hwnd rect set-window-position ; + +: enable-factor-fullscreen ( triple -- rect ) + GetForegroundWindow enable-fullscreen ; + +: disable-factor-fullscreen ( rect triple -- ) + GetForegroundWindow disable-fullscreen ; + +:: (set-fullscreen) ( world triple fullscreen? -- ) + world fullscreen?>> fullscreen? xor [ + triple + world handle>> hWnd>> + fullscreen? [ + enable-fullscreen world (>>saved-position) + ] [ + [ world saved-position>> ] 2dip disable-fullscreen + ] if + fullscreen? world (>>fullscreen?) + ] when ; + +: set-fullscreen ( gadget triple fullscreen? -- ) + [ find-world ] 2dip (set-fullscreen) ; diff --git a/extra/fullscreen/platforms.txt b/extra/fullscreen/platforms.txt new file mode 100644 index 0000000000..8e1a55995e --- /dev/null +++ b/extra/fullscreen/platforms.txt @@ -0,0 +1 @@ +windows From 004608e1f48171bc9697713663fc39a25751f2d8 Mon Sep 17 00:00:00 2001 From: Doug Coleman Date: Sat, 27 Feb 2010 13:04:42 -0600 Subject: [PATCH 16/37] fix docs for csv --- basis/csv/csv-docs.factor | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/basis/csv/csv-docs.factor b/basis/csv/csv-docs.factor index 075b00eea2..32c4cd53fb 100644 --- a/basis/csv/csv-docs.factor +++ b/basis/csv/csv-docs.factor @@ -30,7 +30,7 @@ HELP: string>csv HELP: csv>string { $values - { "rows" "a sequence of sequences of strings" } + { "csv" "csv" } { "string" string } } { $description "Writes a comma-separated-value structure to a string." } ; From e7d2e732153306f5702a8edb6aeaf2590634984e Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Sun, 28 Feb 2010 19:44:18 +1300 Subject: [PATCH 17/37] webapps.help: fix typo --- extra/webapps/help/search.xml | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/extra/webapps/help/search.xml b/extra/webapps/help/search.xml index bcaed59ea4..f6b364f089 100644 --- a/extra/webapps/help/search.xml +++ b/extra/webapps/help/search.xml @@ -23,7 +23,7 @@

This is the Factor documentation, generated offline from a - load-everything image. If you want, you can also browse the + load-all image. If you want, you can also browse the documentation from within the Factor UI.

You may search article titles below; for example, try searching for "HTTP".

From 163c26ad7242b440a9737f8d0087c1ec19ba4790 Mon Sep 17 00:00:00 2001 From: Joe Groff Date: Sun, 28 Feb 2010 13:01:03 -0800 Subject: [PATCH 18/37] lexer, parser: show initial parsing word line as part of lexer-errors --- core/lexer/lexer.factor | 50 ++++++++++++++++++++++++++++++++------- core/parser/parser.factor | 7 +++++- 2 files changed, 48 insertions(+), 9 deletions(-) diff --git a/core/lexer/lexer.factor b/core/lexer/lexer.factor index b3bd3cacdb..3b0348aa10 100644 --- a/core/lexer/lexer.factor +++ b/core/lexer/lexer.factor @@ -5,7 +5,9 @@ io vectors arrays math.parser combinators continuations source-files.errors ; IN: lexer -TUPLE: lexer text line line-text line-length column ; +TUPLE: lexer text line line-text line-length column parsing-words ; + +TUPLE: lexer-parsing-word word line line-text column ; : next-line ( lexer -- ) dup [ line>> ] [ text>> ] bi ?nth >>line-text @@ -14,10 +16,23 @@ TUPLE: lexer text line line-text line-length column ; 0 >>column drop ; +: push-parsing-word ( word -- ) + lexer-parsing-word new + swap >>word + lexer get [ + [ line>> >>line ] + [ line-text>> >>line-text ] + [ column>> >>column ] tri + ] [ parsing-words>> push ] bi ; + +: pop-parsing-word ( -- ) + lexer get parsing-words>> pop drop ; + : new-lexer ( text class -- lexer ) new 0 >>line swap >>text + V{ } clone >>parsing-words dup next-line ; inline : ( text -- lexer ) @@ -92,27 +107,46 @@ PREDICATE: unexpected-eof < unexpected : parse-tokens ( end -- seq ) 100 swap (parse-tokens) >array ; -TUPLE: lexer-error line column line-text error ; +TUPLE: lexer-error line column line-text parsing-words error ; M: lexer-error error-file error>> error-file ; M: lexer-error error-line [ error>> error-line ] [ line>> ] bi or ; : ( msg -- error ) \ lexer-error new - lexer get - [ line>> >>line ] - [ column>> >>column ] - [ line-text>> >>line-text ] - tri + lexer get [ + [ line>> >>line ] + [ column>> >>column ] bi + ] [ + [ line-text>> >>line-text ] + [ parsing-words>> clone >>parsing-words ] bi + ] bi swap >>error ; -: lexer-dump ( error -- ) +: simple-lexer-dump ( error -- ) [ line>> number>string ": " append ] [ line-text>> dup string? [ drop "" ] unless ] [ column>> 0 or ] tri pick length + CHAR: \s [ write ] [ print ] [ write "^" print ] tri* ; +: (parsing-word-lexer-dump) ( error parsing-word -- ) + [ + line>> number>string + over line>> number>string length + CHAR: \s pad-head + ": " append write + ] [ line-text>> dup string? [ drop "" ] unless print ] bi + simple-lexer-dump ; + +: parsing-word-lexer-dump ( error parsing-word -- ) + 2dup [ line>> ] bi@ = + [ drop simple-lexer-dump ] + [ (parsing-word-lexer-dump) ] if ; + +: lexer-dump ( error -- ) + dup parsing-words>> [ simple-lexer-dump ] [ last parsing-word-lexer-dump ] if-empty ; + : with-lexer ( lexer quot -- newquot ) [ lexer set ] dip [ rethrow ] recover ; inline diff --git a/core/parser/parser.factor b/core/parser/parser.factor index e3e7d79c40..3257bd69a4 100644 --- a/core/parser/parser.factor +++ b/core/parser/parser.factor @@ -58,9 +58,14 @@ SYMBOL: auto-use? ERROR: staging-violation word ; +: (execute-parsing) ( accum word -- accum ) + dup push-parsing-word + execute( accum -- accum ) + pop-parsing-word ; inline + : execute-parsing ( accum word -- accum ) dup changed-definitions get key? [ staging-violation ] when - execute( accum -- accum ) ; + (execute-parsing) ; : scan-object ( -- object ) scan-word { From e3ddafbdecdd778e036bb7f0d99f80d2337e081c Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Mon, 1 Mar 2010 12:22:18 +1300 Subject: [PATCH 19/37] core-foundation.run-loop: clean up and speed up some code to fix starvation issue exposed by game.loop (reported by Joe Groff) --- .../core-foundation/run-loop/run-loop.factor | 22 ++++++++----------- basis/core-foundation/time/time.factor | 12 +++++----- basis/core-foundation/timers/timers.factor | 4 ++-- extra/game/loop/loop.factor | 2 +- 4 files changed, 19 insertions(+), 21 deletions(-) diff --git a/basis/core-foundation/run-loop/run-loop.factor b/basis/core-foundation/run-loop/run-loop.factor index 56b5a9c798..c1316eaa16 100644 --- a/basis/core-foundation/run-loop/run-loop.factor +++ b/basis/core-foundation/run-loop/run-loop.factor @@ -99,22 +99,18 @@ TUPLE: run-loop fds sources timers ; CFAbsoluteTime CFRunLoopTimerSetNextFireDate ; +: (reset-timer) ( timer timestamp -- ) + >CFAbsoluteTime CFRunLoopTimerSetNextFireDate ; -: nano-count>timestamp ( x -- timestamp ) - nano-count - nanoseconds now time+ ; - -: (reset-timer) ( timer counter -- ) - yield { - { [ dup 0 = ] [ now ((reset-timer)) ] } - { [ run-queue deque-empty? not ] [ 1 - (reset-timer) ] } - { [ sleep-queue heap-empty? ] [ 5 minutes hence ((reset-timer)) ] } - [ sleep-queue heap-peek nip nano-count>timestamp ((reset-timer)) ] - } cond ; +: nano-count>micros ( x -- n ) + nano-count - 1,000 /f system-micros + ; : reset-timer ( timer -- ) - 10 (reset-timer) ; + yield { + { [ run-queue deque-empty? not ] [ yield system-micros (reset-timer) ] } + { [ sleep-queue heap-empty? ] [ system-micros 1,000,000 + (reset-timer) ] } + [ sleep-queue heap-peek nip nano-count>micros (reset-timer) ] + } cond ; PRIVATE> diff --git a/basis/core-foundation/time/time.factor b/basis/core-foundation/time/time.factor index 8f09652462..59dd8098b4 100644 --- a/basis/core-foundation/time/time.factor +++ b/basis/core-foundation/time/time.factor @@ -1,6 +1,6 @@ -! Copyright (C) 2008 Slava Pestov. +! Copyright (C) 2008, 2010 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. -USING: calendar alien.c-types alien.syntax ; +USING: calendar math alien.c-types alien.syntax memoize system ; IN: core-foundation.time TYPEDEF: double CFTimeInterval @@ -9,6 +9,8 @@ TYPEDEF: double CFAbsoluteTime : >CFTimeInterval ( duration -- interval ) duration>seconds ; inline -: >CFAbsoluteTime ( timestamp -- time ) - T{ timestamp { year 2001 } { month 1 } { day 1 } } time- - duration>seconds ; inline +MEMO: epoch ( -- micros ) + T{ timestamp { year 2001 } { month 1 } { day 1 } } timestamp>micros ; + +: >CFAbsoluteTime ( micros -- time ) + epoch - 1,000,000 /f ; inline diff --git a/basis/core-foundation/timers/timers.factor b/basis/core-foundation/timers/timers.factor index cf17cb41d9..343753385a 100644 --- a/basis/core-foundation/timers/timers.factor +++ b/basis/core-foundation/timers/timers.factor @@ -1,4 +1,4 @@ -! Copyright (C) 2008 Slava Pestov. +! Copyright (C) 2008, 2010 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. USING: alien.c-types alien.syntax system math kernel calendar core-foundation core-foundation.time ; @@ -19,7 +19,7 @@ FUNCTION: CFRunLoopTimerRef CFRunLoopTimerCreate ( ) ; : ( callback -- timer ) - [ f now >CFAbsoluteTime 60 0 0 ] dip f CFRunLoopTimerCreate ; + [ f system-micros >CFAbsoluteTime 60 0 0 ] dip f CFRunLoopTimerCreate ; FUNCTION: void CFRunLoopTimerInvalidate ( CFRunLoopTimerRef timer diff --git a/extra/game/loop/loop.factor b/extra/game/loop/loop.factor index 9e46535b4e..00fe14c3cd 100644 --- a/extra/game/loop/loop.factor +++ b/extra/game/loop/loop.factor @@ -66,7 +66,7 @@ TUPLE: game-loop-error game-loop error ; : (run-loop) ( loop -- ) dup running?>> - [ [ MAX-FRAMES-TO-SKIP ?tick ] [ redraw ] [ 1 milliseconds sleep (run-loop) ] tri ] + [ [ MAX-FRAMES-TO-SKIP ?tick ] [ redraw ] [ yield (run-loop) ] tri ] [ drop ] if ; : run-loop ( loop -- ) From 078ca0fa5876275272e46a24e96770879388cb07 Mon Sep 17 00:00:00 2001 From: Joe Groff Date: Sun, 28 Feb 2010 16:15:58 -0800 Subject: [PATCH 20/37] alien.parser: refactor FUNCTION: parsing to read from the source incrementally. parse errors in FUNCTION: should now correspond to their location within the definition --- basis/alien/parser/parser.factor | 63 ++++++++++++++------------- basis/alien/syntax/syntax-docs.factor | 5 --- 2 files changed, 32 insertions(+), 36 deletions(-) diff --git a/basis/alien/parser/parser.factor b/basis/alien/parser/parser.factor index cf8c878589..f4331b3624 100644 --- a/basis/alien/parser/parser.factor +++ b/basis/alien/parser/parser.factor @@ -59,64 +59,65 @@ ERROR: *-in-c-type-name name ; [ ] } cleave ; -: normalize-c-arg ( type name -- type' name' ) - [ length ] - [ - [ CHAR: * = ] trim-head - [ length - CHAR: * append ] keep - ] bi - [ parse-c-type ] dip ; - > ; M: pointer return-type-name to>> return-type-name CHAR: * suffix ; + +: parse-pointers ( type name -- type' name' ) + "*" ?head + [ [ ] dip parse-pointers ] when ; + PRIVATE> -: parse-arglist ( parameters return -- types effect ) - [ - 2 group [ first2 normalize-c-arg 2array ] map - unzip [ "," ?tail drop ] map - ] - [ [ { } ] [ return-type-name 1array ] if-void ] - bi* ; +: scan-function-name ( -- return function ) + scan-c-type scan parse-pointers ; + +:: (scan-c-args) ( end-marker types names -- ) + scan :> type-str + type-str end-marker = [ + type-str { "(" ")" } member? [ + type-str parse-c-type :> type + scan :> name + type name parse-pointers :> ( type' name' ) + type' types push name' names push + ] unless + end-marker types names (scan-c-args) + ] unless ; + +: scan-c-args ( end-marker -- types names ) + V{ } clone V{ } clone [ (scan-c-args) ] 2keep [ >array ] bi@ ; : function-quot ( return library function types -- quot ) '[ _ _ _ _ alien-invoke ] ; -:: make-function ( return library function parameters -- word quot effect ) - return function normalize-c-arg :> ( return function ) - function create-in dup reset-generic - return library function - parameters return parse-arglist [ function-quot ] dip ; +: function-effect ( names return -- effect ) + [ { } ] [ return-type-name 1array ] if-void ; -: parse-arg-tokens ( -- tokens ) - ";" parse-tokens [ "()" subseq? not ] filter ; +:: make-function ( return function library types names -- word quot effect ) + function create-in dup reset-generic + return library function types function-quot + names return function-effect ; : (FUNCTION:) ( -- word quot effect ) - scan "c-library" get scan parse-arg-tokens make-function ; - -: define-function ( return library function parameters -- ) - make-function define-declared ; + scan-function-name "c-library" get ";" scan-c-args make-function ; : callback-quot ( return types abi -- quot ) '[ [ _ _ _ ] dip alien-callback ] ; -:: make-callback-type ( lib return type-name parameters -- word quot effect ) - return type-name normalize-c-arg :> ( return type-name ) +:: make-callback-type ( lib return type-name types names -- word quot effect ) type-name current-vocab create :> type-word type-word [ reset-generic ] [ reset-c-type ] bi void* type-word typedef - parameters return parse-arglist :> ( types callback-effect ) - type-word callback-effect "callback-effect" set-word-prop + type-word names return function-effect "callback-effect" set-word-prop type-word lib "callback-library" set-word-prop type-word return types lib library-abi callback-quot (( quot -- alien )) ; : (CALLBACK:) ( -- word quot effect ) "c-library" get - scan scan parse-arg-tokens make-callback-type ; + scan-function-name ";" scan-c-args make-callback-type ; PREDICATE: alien-function-word < word def>> { diff --git a/basis/alien/syntax/syntax-docs.factor b/basis/alien/syntax/syntax-docs.factor index 3d1c757035..58b43cec31 100644 --- a/basis/alien/syntax/syntax-docs.factor +++ b/basis/alien/syntax/syntax-docs.factor @@ -112,11 +112,6 @@ HELP: c-struct? { $values { "c-type" "a C type" } { "?" "a boolean" } } { $description "Tests if a C type is a structure defined by " { $link POSTPONE: STRUCT: } "." } ; -HELP: define-function -{ $values { "return" "a C return type" } { "library" "a logical library name" } { "function" "a C function name" } { "parameters" "a sequence of C parameter types" } } -{ $description "Defines a word named " { $snippet "function" } " in the current vocabulary (see " { $link "vocabularies" } "). The word calls " { $link alien-invoke } " with the specified parameters." } -{ $notes "This word is used to implement the " { $link POSTPONE: FUNCTION: } " parsing word." } ; - HELP: C-GLOBAL: { $syntax "C-GLOBAL: type name" } { $values { "type" "a C type" } { "name" "a C global variable name" } } From 9412fe82973d4fbf6f31fa9535cd0d8da306917d Mon Sep 17 00:00:00 2001 From: Joe Groff Date: Sun, 28 Feb 2010 16:40:34 -0800 Subject: [PATCH 21/37] update GL-FUNCTION: to use new FUNCTION: factors --- basis/opengl/gl/extensions/extensions.factor | 27 +++++++++----------- 1 file changed, 12 insertions(+), 15 deletions(-) diff --git a/basis/opengl/gl/extensions/extensions.factor b/basis/opengl/gl/extensions/extensions.factor index 17813b8c82..530f3ada6c 100644 --- a/basis/opengl/gl/extensions/extensions.factor +++ b/basis/opengl/gl/extensions/extensions.factor @@ -11,11 +11,11 @@ ERROR: unknown-gl-platform ; [ unknown-gl-platform ] } cond use-vocab >> -SYMBOL: +gl-function-number-counter+ +SYMBOL: +gl-function-counter+ SYMBOL: +gl-function-pointers+ : reset-gl-function-number-counter ( -- ) - 0 +gl-function-number-counter+ set-global ; + 0 +gl-function-counter+ set-global ; : reset-gl-function-pointers ( -- ) 100 +gl-function-pointers+ set-global ; @@ -23,9 +23,9 @@ SYMBOL: +gl-function-pointers+ reset-gl-function-pointers reset-gl-function-number-counter -: gl-function-number ( -- n ) - +gl-function-number-counter+ get-global - dup 1 + +gl-function-number-counter+ set-global ; +: gl-function-counter ( -- n ) + +gl-function-counter+ get-global + dup 1 + +gl-function-counter+ set-global ; : gl-function-pointer ( names n -- funptr ) gl-function-context 2array dup +gl-function-pointers+ get-global at @@ -41,18 +41,15 @@ reset-gl-function-number-counter : indirect-quot ( function-ptr-quot return types abi -- quot ) '[ @ _ _ _ alien-indirect ] ; -:: define-indirect ( abi return function-ptr-quot function-name parameters -- ) +:: define-indirect ( abi return function-name function-ptr-quot types names -- ) function-name create-in dup reset-generic - function-ptr-quot return - parameters return parse-arglist [ abi indirect-quot ] dip + function-ptr-quot return types abi indirect-quot + names return function-effect define-declared ; SYNTAX: GL-FUNCTION: gl-function-calling-convention - scan-c-type - scan dup - scan drop "}" parse-tokens swap prefix - gl-function-number - [ gl-function-pointer ] 2curry swap - ";" parse-tokens [ "()" subseq? not ] filter - define-indirect ; + scan-function-name + "{" expect "}" parse-tokens over prefix + gl-function-counter '[ _ _ gl-function-pointer ] + ";" scan-c-args define-indirect ; From cd17a934ac1f33b45a218e0f4e036343462e9551 Mon Sep 17 00:00:00 2001 From: Joe Groff Date: Sun, 28 Feb 2010 19:29:53 -0800 Subject: [PATCH 22/37] cut commas off of FUNCTION: parameter names in stack effects again --- basis/alien/parser/parser.factor | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/basis/alien/parser/parser.factor b/basis/alien/parser/parser.factor index f4331b3624..c9ec2c3889 100644 --- a/basis/alien/parser/parser.factor +++ b/basis/alien/parser/parser.factor @@ -80,7 +80,7 @@ PRIVATE> type-str end-marker = [ type-str { "(" ")" } member? [ type-str parse-c-type :> type - scan :> name + scan "," ?tail drop :> name type name parse-pointers :> ( type' name' ) type' types push name' names push ] unless From bde65fe2d076ac57535b3f1961bf8e7dfd27c72e Mon Sep 17 00:00:00 2001 From: Joe Groff Date: Sun, 28 Feb 2010 19:30:15 -0800 Subject: [PATCH 23/37] windows.com: update COM-INTERFACE: to parse incrementally --- basis/windows/com/syntax/syntax.factor | 45 ++++++++++-------------- basis/windows/com/wrapper/wrapper.factor | 6 +--- 2 files changed, 19 insertions(+), 32 deletions(-) diff --git a/basis/windows/com/syntax/syntax.factor b/basis/windows/com/syntax/syntax.factor index 5230d9497e..49c9272d9b 100644 --- a/basis/windows/com/syntax/syntax.factor +++ b/basis/windows/com/syntax/syntax.factor @@ -2,8 +2,8 @@ USING: alien alien.c-types alien.accessors alien.parser effects kernel windows.ole32 parser lexer splitting grouping sequences namespaces assocs quotations generalizations accessors words macros alien.syntax fry arrays layouts math -classes.struct windows.kernel32 ; -FROM: alien.parser.private => return-type-name ; +classes.struct windows.kernel32 locals ; +FROM: alien.parser.private => parse-pointers return-type-name ; IN: windows.com.syntax com-interface-definition -TUPLE: com-function-definition name return parameters ; +TUPLE: com-function-definition return name parameter-types parameter-names ; C: com-function-definition SYMBOL: +com-interface-definitions+ @@ -37,19 +37,20 @@ ERROR: no-com-interface interface ; : save-com-interface-definition ( definition -- ) dup word>> +com-interface-definitions+ get-global set-at ; -: (parse-com-function) ( tokens -- definition ) - [ second ] - [ first parse-c-type ] - [ - 3 tail [ CHAR: , swap remove ] map - 2 group [ first2 normalize-c-arg 2array ] map - { void* "this" } prefix - ] tri +: (parse-com-function) ( return name -- definition ) + ")" scan-c-args + [ pointer: void prefix ] [ "this" prefix ] bi* ; +:: (parse-com-functions) ( functions -- ) + scan dup ";" = [ drop ] [ + parse-c-type scan parse-pointers + (parse-com-function) functions push + functions (parse-com-functions) + ] if ; + : parse-com-functions ( -- functions ) - ";" parse-tokens { ")" } split harvest - [ (parse-com-function) ] map ; + V{ } clone [ (parse-com-functions) ] keep >array ; : (iid-word) ( definition -- word ) word>> name>> "-iid" append create-in ; @@ -66,20 +67,10 @@ ERROR: no-com-interface interface ; dup parent>> [ family-tree-functions ] [ { } ] if* swap functions>> append ; -: (invocation-quot) ( function return parameters -- quot ) - [ first ] map [ com-invoke ] 3curry ; - -: (stack-effect-from-return-and-parameters) ( return parameters -- stack-effect ) - swap - [ [ second ] map ] - [ dup void? [ drop { } ] [ return-type-name 1array ] if ] bi* - ; - -: (define-word-for-function) ( function interface n -- ) - -rot [ (function-word) swap ] 2keep drop - [ return>> ] [ parameters>> ] bi - [ (invocation-quot) ] 2keep - (stack-effect-from-return-and-parameters) +:: (define-word-for-function) ( function interface n -- ) + function interface (function-word) + n function [ return>> ] [ parameter-types>> ] bi '[ _ _ _ com-invoke ] + function [ parameter-names>> ] [ return>> ] bi function-effect define-declared ; : define-words-for-com-interface ( definition -- ) diff --git a/basis/windows/com/wrapper/wrapper.factor b/basis/windows/com/wrapper/wrapper.factor index 623a9c8db3..25861659dc 100644 --- a/basis/windows/com/wrapper/wrapper.factor +++ b/basis/windows/com/wrapper/wrapper.factor @@ -110,11 +110,7 @@ unless keep (next-vtbl-counter) '[ swap [ [ name>> _ _ (callback-word) ] - [ return>> ] [ - parameters>> - [ [ first ] map ] - [ length ] bi - ] tri + [ return>> ] [ parameter-types>> dup length ] tri ] [ first2 (finish-thunk) ] bi* From bb58cf4d161518d496f2c711e9572cb7140d1158 Mon Sep 17 00:00:00 2001 From: Joe Groff Date: Sun, 28 Feb 2010 20:14:16 -0800 Subject: [PATCH 24/37] classes.tuple.parser: throw bad-slot-name immediately when an invalid slot name in a tuple/struct literal is scanned --- core/classes/tuple/parser/parser.factor | 25 ++++++++++++++----------- 1 file changed, 14 insertions(+), 11 deletions(-) diff --git a/core/classes/tuple/parser/parser.factor b/core/classes/tuple/parser/parser.factor index 7482cce048..5016bb38f6 100644 --- a/core/classes/tuple/parser/parser.factor +++ b/core/classes/tuple/parser/parser.factor @@ -68,23 +68,28 @@ ERROR: invalid-slot-name name ; ERROR: bad-literal-tuple ; -: parse-slot-value ( -- ) - scan scan-object 2array , scan { +ERROR: bad-slot-name class slot ; + +: check-slot-name ( class slots name -- name ) + 2dup swap slot-named* nip [ 2nip ] [ nip bad-slot-name ] if ; + +: parse-slot-value ( class slots -- ) + scan check-slot-name scan-object 2array , scan { { f [ \ } unexpected-eof ] } { "}" [ ] } [ bad-literal-tuple ] } case ; -: (parse-slot-values) ( -- ) - parse-slot-value +: (parse-slot-values) ( class slots -- ) + 2dup parse-slot-value scan { - { f [ \ } unexpected-eof ] } + { f [ 2drop \ } unexpected-eof ] } { "{" [ (parse-slot-values) ] } - { "}" [ ] } - [ bad-literal-tuple ] + { "}" [ 2drop ] } + [ 2nip bad-literal-tuple ] } case ; -: parse-slot-values ( -- values ) +: parse-slot-values ( class slots -- values ) [ (parse-slot-values) ] { } make ; GENERIC# boa>object 1 ( class slots -- tuple ) @@ -92,8 +97,6 @@ GENERIC# boa>object 1 ( class slots -- tuple ) M: tuple-class boa>object swap prefix >tuple ; -ERROR: bad-slot-name class slot ; - : check-slot-exists ( class initials slot-spec/f index/f name -- class initials slot-spec index ) over [ drop ] [ nip nip nip bad-slot-name ] if ; @@ -109,7 +112,7 @@ ERROR: bad-slot-name class slot ; scan { { f [ unexpected-eof ] } { "f" [ drop \ } parse-until boa>object ] } - { "{" [ parse-slot-values assoc>object ] } + { "{" [ 2dup parse-slot-values assoc>object ] } { "}" [ drop new ] } [ bad-literal-tuple ] } case ; From 9bf5c76771f82af8c301fe1cf6c70cd981a899d5 Mon Sep 17 00:00:00 2001 From: Joe Groff Date: Sun, 28 Feb 2010 22:06:47 -0800 Subject: [PATCH 25/37] lexer: add "each-token" and "map-tokens", which are equivalent to "parse-token _ each/map" but incremental. update a smattering of parsing words (such as USING:, SYMBOLS:, etc.) to use each-token/map-tokens --- basis/delegate/delegate.factor | 6 +++--- basis/locals/parser/parser.factor | 7 +++++-- basis/match/match.factor | 2 +- .../specialized-arrays/specialized-arrays.factor | 2 +- .../specialized-vectors.factor | 4 ++-- core/lexer/lexer.factor | 16 +++++++++------- core/syntax/syntax.factor | 8 +++----- extra/poker/poker.factor | 2 +- extra/slots/syntax/syntax.factor | 5 ++--- extra/vars/vars.factor | 2 +- 10 files changed, 28 insertions(+), 26 deletions(-) diff --git a/basis/delegate/delegate.factor b/basis/delegate/delegate.factor index 662a2840a1..dc3024b55f 100644 --- a/basis/delegate/delegate.factor +++ b/basis/delegate/delegate.factor @@ -157,6 +157,6 @@ M: protocol definer drop \ PROTOCOL: \ ; ; M: protocol group-words protocol-words ; SYNTAX: SLOT-PROTOCOL: - CREATE-WORD ";" parse-tokens - [ [ reader-word ] [ writer-word ] bi 2array ] map concat - define-protocol ; \ No newline at end of file + CREATE-WORD ";" + [ [ reader-word ] [ writer-word ] bi 2array ] + map-tokens concat define-protocol ; diff --git a/basis/locals/parser/parser.factor b/basis/locals/parser/parser.factor index c0184ee0ef..e742b4768a 100644 --- a/basis/locals/parser/parser.factor +++ b/basis/locals/parser/parser.factor @@ -21,6 +21,9 @@ SYMBOL: in-lambda? : make-locals ( seq -- words assoc ) [ [ make-local ] map ] H{ } make-assoc ; +: parse-local-defs ( -- words assoc ) + [ "|" [ make-local ] map-tokens ] H{ } make-assoc ; + : make-local-word ( name def -- word ) [ [ dup name>> set ] [ ] [ ] tri ] dip "local-word-def" set-word-prop ; @@ -42,12 +45,12 @@ SYMBOL: locals [ \ ] parse-until >quotation ] ((parse-lambda)) ; : parse-lambda ( -- lambda ) - "|" parse-tokens make-locals + parse-local-defs (parse-lambda) ?rewrite-closures ; : parse-multi-def ( locals -- multi-def ) - ")" parse-tokens swap [ [ make-local ] map ] bind ; + [ ")" [ make-local ] map-tokens ] bind ; : parse-def ( name/paren locals -- def ) over "(" = [ nip parse-multi-def ] [ [ make-local ] bind ] if ; diff --git a/basis/match/match.factor b/basis/match/match.factor index b6369249b3..9baadfe1f2 100644 --- a/basis/match/match.factor +++ b/basis/match/match.factor @@ -17,7 +17,7 @@ SYMBOL: _ [ define-match-var ] each ; SYNTAX: MATCH-VARS: ! vars ... - ";" parse-tokens define-match-vars ; + ";" [ define-match-var ] each-token ; : match-var? ( symbol -- bool ) dup word? [ "match-var" word-prop ] [ drop f ] if ; diff --git a/basis/specialized-arrays/specialized-arrays.factor b/basis/specialized-arrays/specialized-arrays.factor index b052becfed..11b050d5fc 100644 --- a/basis/specialized-arrays/specialized-arrays.factor +++ b/basis/specialized-arrays/specialized-arrays.factor @@ -168,7 +168,7 @@ M: c-type-word c-direct-array-constructor M: pointer c-direct-array-constructor drop void* c-direct-array-constructor ; SYNTAX: SPECIALIZED-ARRAYS: - ";" parse-tokens [ parse-c-type define-array-vocab use-vocab ] each ; + ";" [ parse-c-type define-array-vocab use-vocab ] each-token ; SYNTAX: SPECIALIZED-ARRAY: scan-c-type define-array-vocab use-vocab ; diff --git a/basis/specialized-vectors/specialized-vectors.factor b/basis/specialized-vectors/specialized-vectors.factor index 0c0569ea9d..3352c226d8 100644 --- a/basis/specialized-vectors/specialized-vectors.factor +++ b/basis/specialized-vectors/specialized-vectors.factor @@ -56,11 +56,11 @@ PRIVATE> generate-vocab ; SYNTAX: SPECIALIZED-VECTORS: - ";" parse-tokens [ + ";" [ parse-c-type [ define-array-vocab use-vocab ] [ define-vector-vocab use-vocab ] bi - ] each ; + ] each-token ; SYNTAX: SPECIALIZED-VECTOR: scan-c-type diff --git a/core/lexer/lexer.factor b/core/lexer/lexer.factor index b3bd3cacdb..7ad454c67c 100644 --- a/core/lexer/lexer.factor +++ b/core/lexer/lexer.factor @@ -82,15 +82,17 @@ PREDICATE: unexpected-eof < unexpected [ unexpected-eof ] if* ; -: (parse-tokens) ( accum end -- accum ) - scan 2dup = [ - 2drop - ] [ - [ pick push (parse-tokens) ] [ unexpected-eof ] if* - ] if ; +: (each-token) ( end quot -- pred quot ) + [ [ [ scan dup ] ] dip [ = not ] curry [ [ f ] if* ] curry compose ] dip ; inline + +: each-token ( end quot -- ) + (each-token) while drop ; inline + +: map-tokens ( end quot -- seq ) + (each-token) produce nip ; inline : parse-tokens ( end -- seq ) - 100 swap (parse-tokens) >array ; + [ ] map-tokens ; TUPLE: lexer-error line column line-text error ; diff --git a/core/syntax/syntax.factor b/core/syntax/syntax.factor index 0b5b32e289..6c35a3c5c6 100644 --- a/core/syntax/syntax.factor +++ b/core/syntax/syntax.factor @@ -51,7 +51,7 @@ IN: bootstrap.syntax "UNUSE:" [ scan unuse-vocab ] define-core-syntax - "USING:" [ ";" parse-tokens [ use-vocab ] each ] define-core-syntax + "USING:" [ ";" [ use-vocab ] each-token ] define-core-syntax "QUALIFIED:" [ scan dup add-qualified ] define-core-syntax @@ -124,13 +124,11 @@ IN: bootstrap.syntax ] define-core-syntax "SYMBOLS:" [ - ";" parse-tokens - [ create-in dup reset-generic define-symbol ] each + ";" [ create-in dup reset-generic define-symbol ] each-token ] define-core-syntax "SINGLETONS:" [ - ";" parse-tokens - [ create-class-in define-singleton-class ] each + ";" [ create-class-in define-singleton-class ] each-token ] define-core-syntax "DEFER:" [ diff --git a/extra/poker/poker.factor b/extra/poker/poker.factor index b33b8e5710..75af1b604a 100644 --- a/extra/poker/poker.factor +++ b/extra/poker/poker.factor @@ -263,4 +263,4 @@ ERROR: bad-suit-symbol ch ; string>value value>hand-name ; SYNTAX: HAND{ - "}" parse-tokens [ card> ] { } map-as suffix! ; + "}" [ card> ] map-tokens suffix! ; diff --git a/extra/slots/syntax/syntax.factor b/extra/slots/syntax/syntax.factor index 2cce91c569..95207a0de9 100755 --- a/extra/slots/syntax/syntax.factor +++ b/extra/slots/syntax/syntax.factor @@ -5,6 +5,5 @@ sequences slots ; IN: slots.syntax SYNTAX: slots{ - "}" parse-tokens - [ reader-word 1quotation ] map - '[ [ _ cleave ] output>array ] append! ; \ No newline at end of file + "}" [ reader-word 1quotation ] map-tokens + '[ [ _ cleave ] output>array ] append! ; diff --git a/extra/vars/vars.factor b/extra/vars/vars.factor index 21c9b303f3..990b0307d0 100644 --- a/extra/vars/vars.factor +++ b/extra/vars/vars.factor @@ -28,4 +28,4 @@ SYNTAX: VAR: ! var [ define-var ] each ; SYNTAX: VARS: ! vars ... - ";" parse-tokens define-vars ; + ";" [ define-var ] each-token ; From 6d81d1eaaa1ed1f6129a973a5565c4a9d96a8ff9 Mon Sep 17 00:00:00 2001 From: Joe Groff Date: Sun, 28 Feb 2010 23:11:43 -0800 Subject: [PATCH 26/37] windows.directx.d3d9: a method was missing argument names --- basis/windows/directx/d3d9/d3d9.factor | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/basis/windows/directx/d3d9/d3d9.factor b/basis/windows/directx/d3d9/d3d9.factor index d4e06ae8c9..a612f72ccd 100644 --- a/basis/windows/directx/d3d9/d3d9.factor +++ b/basis/windows/directx/d3d9/d3d9.factor @@ -109,7 +109,7 @@ COM-INTERFACE: IDirect3DDevice9 IUnknown {D0223B96-BF7A-43fd-92BD-A43B0D82B9EB} HRESULT Clear ( DWORD Count, D3DRECT* pRects, DWORD Flags, D3DCOLOR Color, float Z, DWORD Stencil ) HRESULT SetTransform ( D3DTRANSFORMSTATETYPE State, D3DMATRIX* pMatrix ) HRESULT GetTransform ( D3DTRANSFORMSTATETYPE State, D3DMATRIX* pMatrix ) - HRESULT MultiplyTransform ( D3DTRANSFORMSTATETYPE, D3DMATRIX* ) + HRESULT MultiplyTransform ( D3DTRANSFORMSTATETYPE State, D3DMATRIX* pMatrix ) HRESULT SetViewport ( D3DVIEWPORT9* pViewport ) HRESULT GetViewport ( D3DVIEWPORT9* pViewport ) HRESULT SetMaterial ( D3DMATERIAL9* pMaterial ) From 51541bb35b42b33e5a6104762727b289d66122d7 Mon Sep 17 00:00:00 2001 From: Joe Groff Date: Mon, 1 Mar 2010 11:47:57 -0800 Subject: [PATCH 27/37] lexer, parser: update docs on "parse-tokens" and add docs for "each-token", "map-tokens" --- core/lexer/lexer-docs.factor | 13 ++++++++++++- core/parser/parser-docs.factor | 10 +++++++--- 2 files changed, 19 insertions(+), 4 deletions(-) diff --git a/core/lexer/lexer-docs.factor b/core/lexer/lexer-docs.factor index 30888b76d8..b9af0dc65c 100644 --- a/core/lexer/lexer-docs.factor +++ b/core/lexer/lexer-docs.factor @@ -66,10 +66,21 @@ HELP: still-parsing? { $values { "lexer" lexer } { "?" "a boolean" } } { $description "Outputs " { $link f } " if end of input has been reached, " { $link t } " otherwise." } ; +HELP: each-token +{ $values { "end" string } { "quot" { $quotation "( token -- )" } } } +{ $description "Reads a sequence of tokens until the first occurrence of " { $snippet "end" } ". " { $snippet "quot" } " is called on each token as it is read." } +{ $examples "This word is used to implement " { $link POSTPONE: USING: } "." } +$parsing-note ; + +HELP: map-tokens +{ $values { "end" string } { "quot" { $quotation "( token -- object )" } } { "seq" "a new sequence of " { $snippet "object" } "s" } } +{ $description "Reads a sequence of tokens until the first occurrence of " { $snippet "end" } ". " { $snippet "quot" } " is called on each token as it is read, and the results are collected into a new output sequence." } +$parsing-note ; + HELP: parse-tokens { $values { "end" string } { "seq" "a new sequence of strings" } } { $description "Reads a sequence of tokens until the first occurrence of " { $snippet "end" } ". The tokens remain as strings and are not processed in any way." } -{ $examples "This word is used to implement " { $link POSTPONE: USING: } "." } +{ $notes "This word is equivalent to " { $link map-tokens } " with an empty quotation." } $parsing-note ; HELP: unexpected diff --git a/core/parser/parser-docs.factor b/core/parser/parser-docs.factor index b024d1d968..c04a0f568e 100644 --- a/core/parser/parser-docs.factor +++ b/core/parser/parser-docs.factor @@ -52,8 +52,12 @@ ARTICLE: "parsing-tokens" "Parsing raw tokens" $nl "One example is the " { $link POSTPONE: USING: } " parsing word." { $see POSTPONE: USING: } -"It reads a list of vocabularies terminated by " { $link POSTPONE: ; } ". However, the vocabulary names do not name words, except by coincidence; so " { $link parse-until } " cannot be used here. Instead, a lower-level word is called:" -{ $subsections parse-tokens } ; +"It reads a list of vocabularies terminated by " { $link POSTPONE: ; } ". However, the vocabulary names do not name words, except by coincidence; so " { $link parse-until } " cannot be used here. Instead, a set of lower-level combinators can be used:" +{ $subsections + each-token + map-tokens + parse-tokens +} ; ARTICLE: "parsing-words" "Parsing words" "The Factor parser follows a simple recursive-descent design. The parser reads successive tokens from the input; if the token identifies a number or an ordinary word, it is added to an accumulator vector. Otherwise if the token identifies a parsing word, the parsing word is executed immediately." @@ -164,7 +168,7 @@ HELP: parse-until { $examples "This word is used to implement " { $link POSTPONE: ARTICLE: } "." } $parsing-note ; -{ parse-tokens (parse-until) parse-until } related-words +{ parse-tokens each-token map-tokens (parse-until) parse-until } related-words HELP: (parse-lines) { $values { "lexer" lexer } { "quot" "a new " { $link quotation } } } From 2c5deba1d1f61c36cf373cbda4103453ebb79175 Mon Sep 17 00:00:00 2001 From: Joe Groff Date: Mon, 1 Mar 2010 11:50:16 -0800 Subject: [PATCH 28/37] parse-tokens had two $notes sections. oops! --- core/lexer/lexer-docs.factor | 3 +-- 1 file changed, 1 insertion(+), 2 deletions(-) diff --git a/core/lexer/lexer-docs.factor b/core/lexer/lexer-docs.factor index b9af0dc65c..04985a4340 100644 --- a/core/lexer/lexer-docs.factor +++ b/core/lexer/lexer-docs.factor @@ -79,8 +79,7 @@ $parsing-note ; HELP: parse-tokens { $values { "end" string } { "seq" "a new sequence of strings" } } -{ $description "Reads a sequence of tokens until the first occurrence of " { $snippet "end" } ". The tokens remain as strings and are not processed in any way." } -{ $notes "This word is equivalent to " { $link map-tokens } " with an empty quotation." } +{ $description "Reads a sequence of tokens until the first occurrence of " { $snippet "end" } ". The tokens remain as strings and are not processed in any way. This word is equivalent to " { $link map-tokens } " with an empty quotation." } $parsing-note ; HELP: unexpected From ac979619e614e02f9063768ea6af6994069c488c Mon Sep 17 00:00:00 2001 From: Joe Groff Date: Mon, 1 Mar 2010 13:32:07 -0800 Subject: [PATCH 29/37] record the C++ compiler version in the VM, and expose it with a vm-compiler word --- core/alien/strings/strings.factor | 5 +++-- core/system/system.factor | 2 ++ vm/factor.cpp | 1 + vm/master.hpp | 13 +++++++++++++ vm/objects.hpp | 2 ++ 5 files changed, 21 insertions(+), 2 deletions(-) diff --git a/core/alien/strings/strings.factor b/core/alien/strings/strings.factor index 0ad4f6c85a..435ceb2a96 100644 --- a/core/alien/strings/strings.factor +++ b/core/alien/strings/strings.factor @@ -66,6 +66,7 @@ M: string string>symbol string>symbol* ; M: sequence string>symbol [ string>symbol* ] map ; [ - 8 special-object utf8 alien>string string>cpu \ cpu set-global - 9 special-object utf8 alien>string string>os \ os set-global + 8 special-object utf8 alien>string string>cpu \ cpu set-global + 9 special-object utf8 alien>string string>os \ os set-global + 67 special-object utf8 alien>string \ vm-compiler set-global ] "alien.strings" add-startup-hook diff --git a/core/system/system.factor b/core/system/system.factor index 715564c64d..765861c62f 100644 --- a/core/system/system.factor +++ b/core/system/system.factor @@ -24,6 +24,8 @@ UNION: unix bsd solaris linux haiku ; : os ( -- class ) \ os get-global ; foldable +: vm-compiler ( -- string ) \ vm-compiler get-global ; foldable + cpu ( str -- class ) diff --git a/vm/factor.cpp b/vm/factor.cpp index fb14336ae4..4433095173 100755 --- a/vm/factor.cpp +++ b/vm/factor.cpp @@ -136,6 +136,7 @@ void factor_vm::init_factor(vm_parameters *p) special_objects[OBJ_EXECUTABLE] = allot_alien(false_object,(cell)p->executable_path); special_objects[OBJ_ARGS] = false_object; special_objects[OBJ_EMBEDDED] = false_object; + special_objects[OBJ_VM_COMPILER] = allot_alien(false_object,(cell)FACTOR_COMPILER_VERSION); /* We can GC now */ gc_off = false; diff --git a/vm/master.hpp b/vm/master.hpp index 70736c1bd9..9ba4ebd64b 100755 --- a/vm/master.hpp +++ b/vm/master.hpp @@ -29,6 +29,19 @@ #include #include +/* Record compiler version */ +#if defined(__clang__) + #define FACTOR_COMPILER_VERSION "Clang (GCC " __VERSION__ ")" +#elif defined(__INTEL_COMPILER) + #define FACTOR_COMPILER_VERSION "Intel C Compiler " #__INTEL_COMPILER +#elif defined(__GNUC__) + #define FACTOR_COMPILER_VERSION "GCC " __VERSION__ +#elif defined(_MSC_FULL_VER) + #define FACTOR_COMPILER_VERSION "Microsoft Visual C++ " #_MSC_FULL_VER +#else + #define FACTOR_COMPILER_VERSION "unknown" +#endif + /* Detect target CPU type */ #if defined(__arm__) #define FACTOR_ARM diff --git a/vm/objects.hpp b/vm/objects.hpp index fdc5758a8d..2d777ac516 100644 --- a/vm/objects.hpp +++ b/vm/objects.hpp @@ -95,6 +95,8 @@ enum special_object { OBJ_THREADS = 64, OBJ_RUN_QUEUE = 65, OBJ_SLEEP_QUEUE = 66, + + OBJ_VM_COMPILER = 67, /* version string of the compiler we were built with */ }; /* save-image-and-exit discards special objects that are filled in on startup From 1c08fde381ed7767f087e22aeaec2577332da588 Mon Sep 17 00:00:00 2001 From: Joe Groff Date: Mon, 1 Mar 2010 17:56:17 -0800 Subject: [PATCH 30/37] yay C89 --- vm/master.hpp | 6 ++++-- 1 file changed, 4 insertions(+), 2 deletions(-) diff --git a/vm/master.hpp b/vm/master.hpp index 9ba4ebd64b..dca3d7473c 100755 --- a/vm/master.hpp +++ b/vm/master.hpp @@ -29,15 +29,17 @@ #include #include +#define FACTOR_STRINGIZE(x) #x + /* Record compiler version */ #if defined(__clang__) #define FACTOR_COMPILER_VERSION "Clang (GCC " __VERSION__ ")" #elif defined(__INTEL_COMPILER) - #define FACTOR_COMPILER_VERSION "Intel C Compiler " #__INTEL_COMPILER + #define FACTOR_COMPILER_VERSION "Intel C Compiler " FACTOR_STRINGIZE(__INTEL_COMPILER) #elif defined(__GNUC__) #define FACTOR_COMPILER_VERSION "GCC " __VERSION__ #elif defined(_MSC_FULL_VER) - #define FACTOR_COMPILER_VERSION "Microsoft Visual C++ " #_MSC_FULL_VER + #define FACTOR_COMPILER_VERSION "Microsoft Visual C++ " FACTOR_STRINGIZE(_MSC_FULL_VER) #else #define FACTOR_COMPILER_VERSION "unknown" #endif From 55e772c528b4123210c680d53e6366e21734c900 Mon Sep 17 00:00:00 2001 From: Doug Coleman Date: Mon, 1 Mar 2010 22:31:36 -0600 Subject: [PATCH 31/37] Remove the http-data word --- .../bootstrap/image/download/download.factor | 2 +- basis/http/client/client-docs.factor | 7 +----- basis/http/client/client.factor | 3 --- basis/http/http-tests.factor | 22 +++++++++---------- basis/syndication/syndication.factor | 2 +- extra/images/http/http.factor | 2 +- extra/webapps/fjsc/fjsc.factor | 2 +- extra/yahoo/yahoo.factor | 2 +- 8 files changed, 17 insertions(+), 25 deletions(-) diff --git a/basis/bootstrap/image/download/download.factor b/basis/bootstrap/image/download/download.factor index 9ab7689eca..e2de621984 100644 --- a/basis/bootstrap/image/download/download.factor +++ b/basis/bootstrap/image/download/download.factor @@ -7,7 +7,7 @@ IN: bootstrap.image.download CONSTANT: url URL" http://factorcode.org/images/latest/" : download-checksums ( -- alist ) - url "checksums.txt" >url derive-url http-data + url "checksums.txt" >url derive-url http-get nip string-lines [ " " split1 ] { } map>assoc ; : need-new-image? ( image -- ? ) diff --git a/basis/http/client/client-docs.factor b/basis/http/client/client-docs.factor index 0d0887d10d..04077fc2f7 100644 --- a/basis/http/client/client-docs.factor +++ b/basis/http/client/client-docs.factor @@ -35,11 +35,6 @@ HELP: http-get { $description "Downloads the contents of a URL." } { $errors "Throws an error if the HTTP request fails." } ; -HELP: http-data -{ $values { "url" "a " { $link url } " or " { $link string } } { "data" sequence } } -{ $description "Downloads the contents of a URL. To view the HTTP response, use " { $link http-get } "." } -{ $errors "Throws an error if the HTTP request fails." } ; - HELP: http-post { $values { "post-data" object } { "url" "a " { $link url } " or " { $link string } } { "response" response } { "data" sequence } } { $description "Submits an HTTP POST request." } @@ -66,7 +61,7 @@ HELP: with-http-request ARTICLE: "http.client.get" "GET requests with the HTTP client" "Basic usage involves passing a " { $link url } " and getting a " { $link response } " and data back:" -{ $subsections http-get http-data } +{ $subsections http-get } "Utilities to retrieve a " { $link url } " and save the contents to a file:" { $subsections download diff --git a/basis/http/client/client.factor b/basis/http/client/client.factor index 9e540f111f..482a23aeaa 100644 --- a/basis/http/client/client.factor +++ b/basis/http/client/client.factor @@ -157,9 +157,6 @@ ERROR: download-failed response ; : http-get ( url -- response data ) http-request ; -: http-data ( url -- data ) - http-get nip ; - : with-http-get ( url quot -- response ) [ ] dip with-http-request ; inline diff --git a/basis/http/http-tests.factor b/basis/http/http-tests.factor index 62936af7ff..35d01c1014 100644 --- a/basis/http/http-tests.factor +++ b/basis/http/http-tests.factor @@ -226,14 +226,14 @@ test-db [ [ t ] [ "vocab:http/test/foo.html" ascii file-contents - "http://localhost/nested/foo.html" add-port http-data = + "http://localhost/nested/foo.html" add-port http-get nip = ] unit-test -[ "http://localhost/redirect-loop" add-port http-data ] +[ "http://localhost/redirect-loop" add-port http-get nip ] [ too-many-redirects? ] must-fail-with [ "Goodbye" ] [ - "http://localhost/quit" add-port http-data + "http://localhost/quit" add-port http-get nip ] unit-test ! HTTP client redirect bug @@ -247,7 +247,7 @@ test-db [ ] unit-test [ "Goodbye" ] [ - "http://localhost/redirect" add-port http-data + "http://localhost/redirect" add-port http-get nip ] unit-test @@ -274,12 +274,12 @@ test-db [ : 404? ( response -- ? ) [ download-failed? ] [ response>> code>> 404 = ] bi and ; ! This should give a 404 not an infinite redirect loop -[ "http://localhost/d/blah" add-port http-data ] [ 404? ] must-fail-with +[ "http://localhost/d/blah" add-port http-get nip ] [ 404? ] must-fail-with ! This should give a 404 not an infinite redirect loop -[ "http://localhost/blah/" add-port http-data ] [ 404? ] must-fail-with +[ "http://localhost/blah/" add-port http-get nip ] [ 404? ] must-fail-with -[ "Goodbye" ] [ "http://localhost/quit" add-port http-data ] unit-test +[ "Goodbye" ] [ "http://localhost/quit" add-port http-get nip ] unit-test [ ] [ @@ -293,9 +293,9 @@ test-db [ test-httpd ] unit-test -[ "Hi" ] [ "http://localhost/" add-port http-data ] unit-test +[ "Hi" ] [ "http://localhost/" add-port http-get nip ] unit-test -[ "Goodbye" ] [ "http://localhost/quit" add-port http-data ] unit-test +[ "Goodbye" ] [ "http://localhost/quit" add-port http-get nip ] unit-test USING: html.components html.forms xml xml.traversal validators @@ -353,7 +353,7 @@ SYMBOL: a [ 4 ] [ a get-global ] unit-test -[ "Goodbye" ] [ "http://localhost/quit" add-port http-data ] unit-test +[ "Goodbye" ] [ "http://localhost/quit" add-port http-get nip ] unit-test ! Test cloning [ f ] [ <404> dup clone "b" "a" set-header drop "a" header ] unit-test @@ -371,7 +371,7 @@ SYMBOL: a ] unit-test [ t ] [ - "http://localhost/" add-port http-data + "http://localhost/" add-port http-get nip "vocab:http/test/foo.html" ascii file-contents = ] unit-test diff --git a/basis/syndication/syndication.factor b/basis/syndication/syndication.factor index edfbebeeab..fe31a49265 100644 --- a/basis/syndication/syndication.factor +++ b/basis/syndication/syndication.factor @@ -115,7 +115,7 @@ M: byte-array parse-feed [ bytes>xml xml>feed ] with-html-entities ; : download-feed ( url -- feed ) #! Retrieve an news syndication file, return as a feed tuple. - http-data parse-feed ; + http-get nip parse-feed ; ! Atom generation diff --git a/extra/images/http/http.factor b/extra/images/http/http.factor index d3cff18afb..620ab6f73b 100644 --- a/extra/images/http/http.factor +++ b/extra/images/http/http.factor @@ -5,7 +5,7 @@ images.viewer ; IN: images.http : load-http-image ( path -- image ) - [ http-data ] [ image-class ] bi load-image* ; + [ http-get nip ] [ image-class ] bi load-image* ; : http-image. ( path -- ) load-http-image image. ; diff --git a/extra/webapps/fjsc/fjsc.factor b/extra/webapps/fjsc/fjsc.factor index 4dec258083..01d6935bee 100644 --- a/extra/webapps/fjsc/fjsc.factor +++ b/extra/webapps/fjsc/fjsc.factor @@ -35,7 +35,7 @@ TUPLE: fjsc < dispatcher ; : do-compile-url ( url -- response ) [ - absolute-url http-data 'expression' parse fjsc-compile write "();" write + absolute-url http-get nip 'expression' parse fjsc-compile write "();" write ] with-string-writer "application/javascript" ; diff --git a/extra/yahoo/yahoo.factor b/extra/yahoo/yahoo.factor index 2a8469c328..5e0c08b430 100644 --- a/extra/yahoo/yahoo.factor +++ b/extra/yahoo/yahoo.factor @@ -57,4 +57,4 @@ CONSTANT: factor-id "fRrVAKzV34GDyeRw6bUHDhEWHRedwfOC7e61wwXZLgGF80E67spxdQXuugB swap >>query ; : search-yahoo ( search -- seq ) - query http-data string>xml parse-yahoo ; + query http-get nip string>xml parse-yahoo ; From 4159cfcc7bce7c9fe073c5dbf22d9482f0f1a9df Mon Sep 17 00:00:00 2001 From: Joe Groff Date: Mon, 1 Mar 2010 23:29:26 -0800 Subject: [PATCH 32/37] game.input.*: factor out callback implementations to separate words so they optimize --- basis/game/input/dinput/dinput.factor | 38 ++++++++++++---------- basis/game/input/iokit/iokit.factor | 47 ++++++++++++++------------- 2 files changed, 45 insertions(+), 40 deletions(-) diff --git a/basis/game/input/dinput/dinput.factor b/basis/game/input/dinput/dinput.factor index a95dbd06c3..7eae826aa5 100755 --- a/basis/game/input/dinput/dinput.factor +++ b/basis/game/input/dinput/dinput.factor @@ -92,21 +92,22 @@ SYMBOLS: +dinput+ +keyboard-device+ +keyboard-state+ +dinput+ get swap device-guid IDirectInput8W::GetDeviceStatus S_OK = ; +: (find-device-axes-callback) ( lpddoi pvRef -- BOOL ) + +controller-devices+ get at + swap guidType>> { + { [ dup GUID_XAxis = ] [ drop 0.0 >>x ] } + { [ dup GUID_YAxis = ] [ drop 0.0 >>y ] } + { [ dup GUID_ZAxis = ] [ drop 0.0 >>z ] } + { [ dup GUID_RxAxis = ] [ drop 0.0 >>rx ] } + { [ dup GUID_RyAxis = ] [ drop 0.0 >>ry ] } + { [ dup GUID_RzAxis = ] [ drop 0.0 >>rz ] } + { [ dup GUID_Slider = ] [ drop 0.0 >>slider ] } + [ drop ] + } cond drop + DIENUM_CONTINUE ; + : find-device-axes-callback ( -- alien ) - [ ! ( lpddoi pvRef -- BOOL ) - +controller-devices+ get at - swap guidType>> { - { [ dup GUID_XAxis = ] [ drop 0.0 >>x ] } - { [ dup GUID_YAxis = ] [ drop 0.0 >>y ] } - { [ dup GUID_ZAxis = ] [ drop 0.0 >>z ] } - { [ dup GUID_RxAxis = ] [ drop 0.0 >>rx ] } - { [ dup GUID_RyAxis = ] [ drop 0.0 >>ry ] } - { [ dup GUID_RzAxis = ] [ drop 0.0 >>rz ] } - { [ dup GUID_Slider = ] [ drop 0.0 >>slider ] } - [ drop ] - } cond drop - DIENUM_CONTINUE - ] LPDIENUMDEVICEOBJECTSCALLBACKW ; + [ (find-device-axes-callback) ] LPDIENUMDEVICEOBJECTSCALLBACKW ; : find-device-axes ( device controller-state -- controller-state ) swap [ +controller-devices+ get set-at ] 2keep @@ -139,11 +140,12 @@ SYMBOLS: +dinput+ +keyboard-device+ +keyboard-state+ [ device-guid +controller-guids+ get delete-at ] [ com-release ] tri ; +: (find-controller-callback) ( lpddi pvRef -- BOOL ) + drop guidInstance>> add-controller + DIENUM_CONTINUE ; + : find-controller-callback ( -- alien ) - [ ! ( lpddi pvRef -- BOOL ) - drop guidInstance>> add-controller - DIENUM_CONTINUE - ] LPDIENUMDEVICESCALLBACKW ; inline + [ (find-controller-callback) ] LPDIENUMDEVICESCALLBACKW ; : find-controllers ( -- ) +dinput+ get DI8DEVCLASS_GAMECTRL find-controller-callback diff --git a/basis/game/input/iokit/iokit.factor b/basis/game/input/iokit/iokit.factor index efc586e1ef..45ed67dc22 100644 --- a/basis/game/input/iokit/iokit.factor +++ b/basis/game/input/iokit/iokit.factor @@ -251,33 +251,36 @@ M: iokit-game-input-backend reset-mouse 2dup length > [ set-length ] [ 2drop ] if ; +:: (device-matched-callback) ( context result sender device -- ) + { + { [ device mouse-device? ] [ device ?add-mouse-buttons ] } + { [ device controller-device? ] [ + device + device +controller-states+ get set-at + ] } + [ ] + } cond ; + : device-matched-callback ( -- alien ) - [| context result sender device | - { - { [ device controller-device? ] [ - device - device +controller-states+ get set-at - ] } - { [ device mouse-device? ] [ device ?add-mouse-buttons ] } - [ ] - } cond - ] IOHIDDeviceCallback ; + [ (device-matched-callback) ] IOHIDDeviceCallback ; + +:: (device-removed-callback) ( context result sender device -- ) + device +controller-states+ get delete-at ; : device-removed-callback ( -- alien ) - [| context result sender device | - device +controller-states+ get delete-at - ] IOHIDDeviceCallback ; + [ (device-removed-callback) ] IOHIDDeviceCallback ; + +:: (device-input-callback) ( context result sender value -- ) + { + { [ sender mouse-device? ] [ +mouse-state+ get value record-mouse ] } + { [ sender controller-device? ] [ + sender +controller-states+ get at value record-controller + ] } + [ +keyboard-state+ get value record-keyboard ] + } cond ; : device-input-callback ( -- alien ) - [| context result sender value | - { - { [ sender controller-device? ] [ - sender +controller-states+ get at value record-controller - ] } - { [ sender mouse-device? ] [ +mouse-state+ get value record-mouse ] } - [ +keyboard-state+ get value record-keyboard ] - } cond - ] IOHIDValueCallback ; + [ (device-input-callback) ] IOHIDValueCallback ; : initialize-variables ( manager -- ) +hid-manager+ set-global From 55c606f274ebeed93884f2eeff65ee889c6152b0 Mon Sep 17 00:00:00 2001 From: Doug Coleman Date: Tue, 2 Mar 2010 04:20:40 -0600 Subject: [PATCH 33/37] Remove year/month/day words because they're dumb and confusing --- basis/calendar/calendar.factor | 12 ------------ 1 file changed, 12 deletions(-) diff --git a/basis/calendar/calendar.factor b/basis/calendar/calendar.factor index 1a64ceb646..cd87701aa9 100644 --- a/basis/calendar/calendar.factor +++ b/basis/calendar/calendar.factor @@ -170,18 +170,6 @@ M: timestamp easter ( timestamp -- timestamp ) : microseconds ( x -- duration ) 1000000 / seconds ; : nanoseconds ( x -- duration ) 1000000000 / seconds ; -GENERIC: year ( obj -- n ) -M: integer year ; -M: timestamp year year>> ; - -GENERIC: month ( obj -- n ) -M: integer month ; -M: timestamp month month>> ; - -GENERIC: day ( obj -- n ) -M: integer day ; -M: timestamp day day>> ; - GENERIC: leap-year? ( obj -- ? ) M: integer leap-year? ( year -- ? ) From b059ade5edad9b2a13c46475c988660336bfac7a Mon Sep 17 00:00:00 2001 From: Doug Coleman Date: Tue, 2 Mar 2010 04:31:17 -0600 Subject: [PATCH 34/37] Use TYPED: in a few places in calendar.format to avoid passing durations instead of timestamps --- basis/calendar/format/format.factor | 12 ++++++------ 1 file changed, 6 insertions(+), 6 deletions(-) diff --git a/basis/calendar/format/format.factor b/basis/calendar/format/format.factor index 96d76d0ce8..35e364e6aa 100644 --- a/basis/calendar/format/format.factor +++ b/basis/calendar/format/format.factor @@ -1,8 +1,8 @@ ! Copyright (C) 2008, 2010 Slava Pestov, Doug Coleman. ! See http://factorcode.org/license.txt for BSD license. -USING: math math.order math.parser math.functions kernel -sequences io accessors arrays io.streams.string splitting -combinators calendar calendar.format.macros present ; +USING: accessors arrays calendar calendar.format.macros +combinators io io.streams.string kernel math math.functions +math.order math.parser present sequences typed ; IN: calendar.format : pad-00 ( n -- str ) number>string 2 CHAR: 0 pad-head ; @@ -272,16 +272,16 @@ ERROR: invalid-timestamp-format ; : (timestamp>ymd) ( timestamp -- ) { YYYY "-" MM "-" DD } formatted ; -: timestamp>ymd ( timestamp -- str ) +TYPED: timestamp>ymd ( timestamp: timestamp -- str ) [ (timestamp>ymd) ] with-string-writer ; : (timestamp>hms) ( timestamp -- ) { hh ":" mm ":" ss } formatted ; -: timestamp>hms ( timestamp -- str ) +TYPED: timestamp>hms ( timestamp: timestamp -- str ) [ (timestamp>hms) ] with-string-writer ; -: timestamp>ymdhms ( timestamp -- str ) +TYPED: timestamp>ymdhms ( timestamp: timestamp -- str ) [ >gmt { (timestamp>ymd) " " (timestamp>hms) } formatted From 3faa1a57d30e49429448f0bae99fb6acfe1e401c Mon Sep 17 00:00:00 2001 From: Doug Coleman Date: Tue, 2 Mar 2010 04:51:52 -0600 Subject: [PATCH 35/37] Add a parsing word to output slots to the stack instead of to an array --- extra/slots/syntax/syntax-docs.factor | 12 ++++++++++++ extra/slots/syntax/syntax-tests.factor | 6 +++++- extra/slots/syntax/syntax.factor | 4 ++++ 3 files changed, 21 insertions(+), 1 deletion(-) diff --git a/extra/slots/syntax/syntax-docs.factor b/extra/slots/syntax/syntax-docs.factor index b79916f91b..84e6e89dac 100755 --- a/extra/slots/syntax/syntax-docs.factor +++ b/extra/slots/syntax/syntax-docs.factor @@ -3,6 +3,16 @@ USING: help.markup help.syntax ; IN: slots.syntax +HELP: slots[ +{ $description "Outputs several slot values to the stack." } +{ $example "USING: kernel prettyprint slots.syntax ;" + "IN: slots.syntax.example" + "TUPLE: rectangle width height ;" + "T{ rectangle { width 3 } { height 5 } } slots[ width height ] [ . ] bi@" + """3 +5""" +} ; + HELP: slots{ { $description "Outputs an array of slot values from a tuple." } { $example "USING: prettyprint slots.syntax ;" @@ -14,6 +24,8 @@ HELP: slots{ ARTICLE: "slots.syntax" "Slots syntax sugar" "The " { $vocab-link "slots.syntax" } " vocabulary provides an alternative syntax for taking a sequence of slots from a tuple." $nl +"Syntax sugar for cleaving slots to the stack:" +{ $subsections POSTPONE: slots[ } "Syntax sugar for cleaving slots to an array:" { $subsections POSTPONE: slots{ } ; diff --git a/extra/slots/syntax/syntax-tests.factor b/extra/slots/syntax/syntax-tests.factor index 689ccb48eb..e4dac6e4a4 100755 --- a/extra/slots/syntax/syntax-tests.factor +++ b/extra/slots/syntax/syntax-tests.factor @@ -5,6 +5,10 @@ IN: slots.syntax.tests TUPLE: slot-test a b c ; +[ 1 2 3 ] [ T{ slot-test f 1 2 3 } slots[ a b c ] ] unit-test +[ 3 ] [ T{ slot-test f 1 2 3 } slots[ c ] ] unit-test +[ ] [ T{ slot-test f 1 2 3 } slots[ ] ] unit-test + [ { 1 2 3 } ] [ T{ slot-test f 1 2 3 } slots{ a b c } ] unit-test [ { 3 } ] [ T{ slot-test f 1 2 3 } slots{ c } ] unit-test -[ { } ] [ T{ slot-test f 1 2 3 } slots{ } ] unit-test \ No newline at end of file +[ { } ] [ T{ slot-test f 1 2 3 } slots{ } ] unit-test diff --git a/extra/slots/syntax/syntax.factor b/extra/slots/syntax/syntax.factor index 95207a0de9..7bfe238fa8 100755 --- a/extra/slots/syntax/syntax.factor +++ b/extra/slots/syntax/syntax.factor @@ -4,6 +4,10 @@ USING: combinators combinators.smart fry lexer quotations sequences slots ; IN: slots.syntax +SYNTAX: slots[ + "]" [ reader-word 1quotation ] map-tokens + '[ _ cleave ] append! ; + SYNTAX: slots{ "}" [ reader-word 1quotation ] map-tokens '[ [ _ cleave ] output>array ] append! ; From 8ef279e020abb9ee38f87a90c141f16a17176c11 Mon Sep 17 00:00:00 2001 From: Doug Coleman Date: Tue, 2 Mar 2010 11:38:35 -0600 Subject: [PATCH 36/37] Fix load error in calendar --- extra/calendar/holidays/us/us.factor | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/extra/calendar/holidays/us/us.factor b/extra/calendar/holidays/us/us.factor index a4fb19c597..538836952f 100644 --- a/extra/calendar/holidays/us/us.factor +++ b/extra/calendar/holidays/us/us.factor @@ -33,7 +33,7 @@ HOLIDAY-NAME: new-years-day us-federal "New Year's Day" HOLIDAY: martin-luther-king-day january 3 monday-of-month ; HOLIDAY-NAME: martin-luther-king-day us-federal "Martin Luther King Day" -HOLIDAY: inauguration-day year dup 4 neg rem + january 20 >>day ; +HOLIDAY: inauguration-day january 20 >>day [ dup 4 neg rem + ] change-year ; HOLIDAY-NAME: inauguration-day us "Inauguration Day" HOLIDAY: washingtons-birthday february 3 monday-of-month ; From 2e4ebc01829c754b5a31a4de65d261bb8a56a03a Mon Sep 17 00:00:00 2001 From: Joe Groff Date: Tue, 2 Mar 2010 15:24:47 -0800 Subject: [PATCH 37/37] needlessly rice game.input backends further by using set/get-global everywhere --- basis/game/input/dinput/dinput.factor | 42 +++++++++++++-------------- basis/game/input/iokit/iokit.factor | 22 +++++++------- 2 files changed, 32 insertions(+), 32 deletions(-) diff --git a/basis/game/input/dinput/dinput.factor b/basis/game/input/dinput/dinput.factor index 7eae826aa5..f5b3520b12 100755 --- a/basis/game/input/dinput/dinput.factor +++ b/basis/game/input/dinput/dinput.factor @@ -30,15 +30,15 @@ SYMBOLS: +dinput+ +keyboard-device+ +keyboard-state+ +dinput+ [ com-release f ] change-global ; : device-for-guid ( guid -- device ) - +dinput+ get swap f + +dinput+ get-global swap f [ f IDirectInput8W::CreateDevice ole32-error ] keep *void* ; : set-coop-level ( device -- ) - +device-change-window+ get DISCL_BACKGROUND DISCL_NONEXCLUSIVE bitor - IDirectInputDevice8W::SetCooperativeLevel ole32-error ; + +device-change-window+ get-global DISCL_BACKGROUND DISCL_NONEXCLUSIVE bitor + IDirectInputDevice8W::SetCooperativeLevel ole32-error ; inline : set-data-format ( device format-symbol -- ) - get IDirectInputDevice8W::SetDataFormat ole32-error ; + get-global IDirectInputDevice8W::SetDataFormat ole32-error ; inline : ( size -- DIPROPDWORD ) DIPROPDWORD [ @@ -93,7 +93,7 @@ SYMBOLS: +dinput+ +keyboard-device+ +keyboard-state+ IDirectInput8W::GetDeviceStatus S_OK = ; : (find-device-axes-callback) ( lpddoi pvRef -- BOOL ) - +controller-devices+ get at + +controller-devices+ get-global at swap guidType>> { { [ dup GUID_XAxis = ] [ drop 0.0 >>x ] } { [ dup GUID_YAxis = ] [ drop 0.0 >>y ] } @@ -110,7 +110,7 @@ SYMBOLS: +dinput+ +keyboard-device+ +keyboard-state+ [ (find-device-axes-callback) ] LPDIENUMDEVICEOBJECTSCALLBACKW ; : find-device-axes ( device controller-state -- controller-state ) - swap [ +controller-devices+ get set-at ] 2keep + swap [ +controller-devices+ get-global set-at ] 2keep find-device-axes-callback over DIDFT_AXIS IDirectInputDevice8W::EnumObjects ole32-error ; @@ -122,22 +122,22 @@ SYMBOLS: +dinput+ +keyboard-device+ +keyboard-state+ find-device-axes ; : device-known? ( guid -- ? ) - +controller-guids+ get key? ; inline + +controller-guids+ get-global key? ; inline : (add-controller) ( guid -- ) device-for-guid { [ configure-controller ] [ controller-state-template ] - [ dup device-guid clone +controller-guids+ get set-at ] - [ +controller-devices+ get set-at ] + [ dup device-guid clone +controller-guids+ get-global set-at ] + [ +controller-devices+ get-global set-at ] } cleave ; : add-controller ( guid -- ) dup device-known? [ drop ] [ (add-controller) ] if ; : remove-controller ( device -- ) - [ +controller-devices+ get delete-at ] - [ device-guid +controller-guids+ get delete-at ] + [ +controller-devices+ get-global delete-at ] + [ device-guid +controller-guids+ get-global delete-at ] [ com-release ] tri ; : (find-controller-callback) ( lpddi pvRef -- BOOL ) @@ -148,7 +148,7 @@ SYMBOLS: +dinput+ +keyboard-device+ +keyboard-state+ [ (find-controller-callback) ] LPDIENUMDEVICESCALLBACKW ; : find-controllers ( -- ) - +dinput+ get DI8DEVCLASS_GAMECTRL find-controller-callback + +dinput+ get-global DI8DEVCLASS_GAMECTRL find-controller-callback f DIEDFL_ATTACHEDONLY IDirectInput8W::EnumDevices ole32-error ; : set-up-controllers ( -- ) @@ -157,7 +157,7 @@ SYMBOLS: +dinput+ +keyboard-device+ +keyboard-state+ find-controllers ; : find-and-remove-detached-devices ( -- ) - +controller-devices+ get keys + +controller-devices+ get-global keys [ device-attached? not ] filter [ remove-controller ] each ; @@ -253,7 +253,7 @@ M: dinput-game-input-backend (reset-game-input) ] bind ; M: dinput-game-input-backend get-controllers - +controller-devices+ get + +controller-devices+ get-global [ drop controller boa ] { } assoc>map ; M: dinput-game-input-backend product-string @@ -315,7 +315,7 @@ CONSTANT: pov-values } case ; : fill-mouse-state ( buffer count -- state ) - iota [ +mouse-state+ get ] 2dip swap [ nth (fill-mouse-state) ] curry each ; + iota [ +mouse-state+ get-global ] 2dip swap [ nth (fill-mouse-state) ] curry each ; : get-device-state ( device DIJOYSTATE2 -- ) [ dup IDirectInputDevice8W::Poll ole32-error ] dip @@ -327,25 +327,25 @@ CONSTANT: pov-values [ fill-controller-state ] [ drop f ] with-acquisition ; M: dinput-game-input-backend read-controller - handle>> dup +controller-devices+ get at + handle>> dup +controller-devices+ get-global at [ (read-controller) ] [ drop f ] if* ; M: dinput-game-input-backend calibrate-controller handle>> f 0 IDirectInputDevice8W::RunControlPanel ole32-error ; M: dinput-game-input-backend read-keyboard - +keyboard-device+ get - [ +keyboard-state+ get [ keys>> underlying>> get-device-state ] keep ] + +keyboard-device+ get-global + [ +keyboard-state+ get-global [ keys>> underlying>> get-device-state ] keep ] [ ] [ f ] with-acquisition ; M: dinput-game-input-backend read-mouse - +mouse-device+ get [ +mouse-buffer+ get MOUSE-BUFFER-SIZE read-device-buffer ] + +mouse-device+ get-global [ +mouse-buffer+ get-global MOUSE-BUFFER-SIZE read-device-buffer ] [ fill-mouse-state ] [ f ] with-acquisition ; M: dinput-game-input-backend reset-mouse - +mouse-device+ get [ f MOUSE-BUFFER-SIZE read-device-buffer ] + +mouse-device+ get-global [ f MOUSE-BUFFER-SIZE read-device-buffer ] [ 2drop ] [ ] with-acquisition - +mouse-state+ get + +mouse-state+ get-global 0 >>dx 0 >>dy 0 >>scroll-dx diff --git a/basis/game/input/iokit/iokit.factor b/basis/game/input/iokit/iokit.factor index 45ed67dc22..083be8e74f 100644 --- a/basis/game/input/iokit/iokit.factor +++ b/basis/game/input/iokit/iokit.factor @@ -203,10 +203,10 @@ HINTS: record-keyboard { bit-array alien } ; HINTS: record-mouse { mouse-state alien } ; M: iokit-game-input-backend read-mouse - +mouse-state+ get ; + +mouse-state+ get-global ; M: iokit-game-input-backend reset-mouse - +mouse-state+ get + +mouse-state+ get-global 0 >>dx 0 >>dy 0 >>scroll-dx @@ -247,7 +247,7 @@ M: iokit-game-input-backend reset-mouse } cleave controller-state boa ; : ?add-mouse-buttons ( device -- ) - button-count +mouse-state+ get buttons>> + button-count +mouse-state+ get-global buttons>> 2dup length > [ set-length ] [ 2drop ] if ; @@ -256,7 +256,7 @@ M: iokit-game-input-backend reset-mouse { [ device mouse-device? ] [ device ?add-mouse-buttons ] } { [ device controller-device? ] [ device - device +controller-states+ get set-at + device +controller-states+ get-global set-at ] } [ ] } cond ; @@ -265,18 +265,18 @@ M: iokit-game-input-backend reset-mouse [ (device-matched-callback) ] IOHIDDeviceCallback ; :: (device-removed-callback) ( context result sender device -- ) - device +controller-states+ get delete-at ; + device +controller-states+ get-global delete-at ; : device-removed-callback ( -- alien ) [ (device-removed-callback) ] IOHIDDeviceCallback ; :: (device-input-callback) ( context result sender value -- ) { - { [ sender mouse-device? ] [ +mouse-state+ get value record-mouse ] } + { [ sender mouse-device? ] [ +mouse-state+ get-global value record-mouse ] } { [ sender controller-device? ] [ - sender +controller-states+ get at value record-controller + sender +controller-states+ get-global at value record-controller ] } - [ +keyboard-state+ get value record-keyboard ] + [ +keyboard-state+ get-global value record-keyboard ] } cond ; : device-input-callback ( -- alien ) @@ -324,7 +324,7 @@ M: iokit-game-input-backend (close-game-input) ] when ; M: iokit-game-input-backend get-controllers ( -- sequence ) - +controller-states+ get keys [ controller boa ] map ; + +controller-states+ get-global keys [ controller boa ] map ; : ?join ( pre post sep -- string ) 2over start [ swap 2nip ] [ [ 2array ] dip join ] if ; @@ -341,10 +341,10 @@ M: iokit-game-input-backend instance-id ( controller -- integer ) handle>> kIOHIDLocationIDKey device-property ; M: iokit-game-input-backend read-controller ( controller -- controller-state ) - handle>> +controller-states+ get at clone ; + handle>> +controller-states+ get-global at clone ; M: iokit-game-input-backend read-keyboard ( -- keyboard-state ) - +keyboard-state+ get clone keyboard-state boa ; + +keyboard-state+ get-global clone keyboard-state boa ; M: iokit-game-input-backend calibrate-controller ( controller -- ) drop ;