steve
/
factor
1
0
Fork 0
Code Issues Pull Requests Releases Wiki Activity

Merge branch 'master' of git://factorcode.org/git/factor

db4
Slava Pestov 2008-11-22 20:00:13 -06:00
parent 359fac1266 ca200b72d0
commit ec0d4717ca
4 changed files with 82 additions and 62 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

18
basis/regexp/regexp-tests.factor
View File

@ -326,26 +326,26 @@ IN: regexp-tests
! "a(?#bcdefg)bcd" <regexp> "abcdefg" over first-match ! "a(?#bcdefg)bcd" <regexp> "abcdefg" over first-match
! "a(?:bcdefg)" <regexp> "abcdefg" over first-match ! "a(?:bcdefg)" <regexp> "abcdefg" over first-match
[ { 0 1 } ] [ "ac" "a(?!b)" <regexp> first-match ] unit-test [ "a" ] [ "ac" "a(?!b)" <regexp> first-match >string ] unit-test
[ f ] [ "ab" "a(?!b)" <regexp> first-match ] unit-test [ f ] [ "ab" "a(?!b)" <regexp> first-match ] unit-test
! "a(?<=b)" <regexp> "caba" over first-match ! "a(?<=b)" <regexp> "caba" over first-match
[ { 0 1 } ] [ "ab" "a(?=b)(?=b)" <regexp> first-match ] unit-test [ "a" ] [ "ab" "a(?=b)(?=b)" <regexp> first-match >string ] unit-test
[ { 1 2 } ] [ "ba" "a(?<=b)(?<=b)" <regexp> first-match ] unit-test [ "a" ] [ "ba" "a(?<=b)(?<=b)" <regexp> first-match >string ] unit-test
[ { 1 2 } ] [ "cab" "a(?=b)(?<=c)" <regexp> first-match ] unit-test [ "a" ] [ "cab" "a(?=b)(?<=c)" <regexp> first-match >string ] unit-test
! capture group 1: "aaaa" 2: "" ! capture group 1: "aaaa" 2: ""
! "aaaa" "(a*)(a*)" <regexp> match* ! "aaaa" "(a*)(a*)" <regexp> match*
! "aaaa" "(a*)(a+)" <regexp> match* ! "aaaa" "(a*)(a+)" <regexp> match*
[ { 0 2 } ] [ "ab" "(a|ab)(bc)?" <regexp> first-match ] unit-test [ "ab" ] [ "ab" "(a|ab)(bc)?" <regexp> first-match >string ] unit-test
[ { 0 3 } ] [ "abc" "(a|ab)(bc)?" <regexp> first-match ] unit-test [ "abc" ] [ "abc" "(a|ab)(bc)?" <regexp> first-match >string ] unit-test
[ { 0 2 } ] [ "ab" "(ab|a)(bc)?" <regexp> first-match ] unit-test [ "ab" ] [ "ab" "(ab|a)(bc)?" <regexp> first-match >string ] unit-test
[ { 0 3 } ] [ "abc" "(ab|a)(bc)?" <regexp> first-match ] unit-test [ "abc" ] [ "abc" "(ab|a)(bc)?" <regexp> first-match >string ] unit-test
[ { 23 24 } ] [ "aaaaaaaaaaaaaaaaaaaaaaab" "((a*)*b)*b" <regexp> first-match ] unit-test [ "b" ] [ "aaaaaaaaaaaaaaaaaaaaaaab" "((a*)*b)*b" <regexp> first-match >string ] unit-test
[ t ] [ "a:b" ".+:?" <regexp> matches? ] unit-test [ t ] [ "a:b" ".+:?" <regexp> matches? ] unit-test

23
basis/regexp/regexp.factor
View File

@ -1,6 +1,6 @@
! Copyright (C) 2008 Doug Coleman. ! Copyright (C) 2008 Doug Coleman.
! See http://factorcode.org/license.txt for BSD license. ! See http://factorcode.org/license.txt for BSD license.
USING: accessors combinators kernel math math.ranges sequences USING: accessors combinators kernel math sequences
sets assocs prettyprint.backend make lexer namespaces parser sets assocs prettyprint.backend make lexer namespaces parser
arrays fry regexp.backend regexp.utils regexp.parser regexp.nfa arrays fry regexp.backend regexp.utils regexp.parser regexp.nfa
regexp.dfa regexp.traversal regexp.transition-tables ; regexp.dfa regexp.traversal regexp.transition-tables ;
@ -25,17 +25,20 @@ IN: regexp
[ ] [ ]
} cleave ; } cleave ;
: match ( string regexp -- pair ) : (match) ( string regexp -- dfa-traverser )
<dfa-traverser> do-match return-match ; <dfa-traverser> do-match ; inline
: match* ( string regexp -- pair captured-groups ) : match ( string regexp -- slice/f )
<dfa-traverser> do-match [ return-match ] [ captured-groups>> ] bi ; (match) return-match ;
: match* ( string regexp -- slice/f captured-groups )
(match) [ return-match ] [ captured-groups>> ] bi ;
: matches? ( string regexp -- ? ) : matches? ( string regexp -- ? )
dupd match dupd match
[ [ length ] [ length>> 1- ] bi* = ] [ drop f ] if* ; [ [ length ] bi@ = ] [ drop f ] if* ;
: match-head ( string regexp -- end/f ) match [ length>> 1- ] [ f ] if* ; : match-head ( string regexp -- end/f ) match [ length ] [ f ] if* ;
: match-at ( string m regexp -- n/f finished? ) : match-at ( string m regexp -- n/f finished? )
[ [
@ -50,7 +53,7 @@ IN: regexp
] if ; ] if ;
: first-match ( string regexp -- pair/f ) : first-match ( string regexp -- pair/f )
0 swap match-range dup [ 2array ] [ 2drop f ] if ; dupd 0 swap match-range rot over [ <slice> ] [ 3drop f ] if ;
: re-cut ( string regexp -- end/f start ) : re-cut ( string regexp -- end/f start )
dupd first-match dupd first-match
@ -66,9 +69,7 @@ IN: regexp
: next-match ( string regexp -- end/f match/f ) : next-match ( string regexp -- end/f match/f )
dupd first-match dup dupd first-match dup
[ [ second tail-slice ] keep ] [ [ length 1+ tail-slice ] keep ] [ 2drop f f ] if ;
[ 2drop f f ]
if ;
: all-matches ( string regexp -- seq ) : all-matches ( string regexp -- seq )
[ dup ] swap '[ _ next-match ] [ ] produce nip ; [ dup ] swap '[ _ next-match ] [ ] produce nip ;

9
basis/regexp/traversal/traversal.factor
View File

@ -1,6 +1,6 @@
! Copyright (C) 2008 Doug Coleman. ! Copyright (C) 2008 Doug Coleman.
! See http://factorcode.org/license.txt for BSD license. ! See http://factorcode.org/license.txt for BSD license.
USING: accessors assocs combinators kernel math math.ranges USING: accessors assocs combinators kernel math
quotations sequences regexp.parser regexp.classes fry arrays quotations sequences regexp.parser regexp.classes fry arrays
combinators.short-circuit regexp.utils prettyprint regexp.nfa combinators.short-circuit regexp.utils prettyprint regexp.nfa
shuffle ; shuffle ;
@ -144,7 +144,10 @@ M: capture-group-off flag-action ( dfa-traverser flag -- )
[ increment-state do-match ] when* [ increment-state do-match ] when*
] unless ; ] unless ;
: return-match ( dfa-traverser -- interval/f ) : return-match ( dfa-traverser -- slice/f )
dup matches>> dup matches>>
[ drop f ] [ drop f ]
[ [ start-index>> ] [ peek ] bi* 1 <range> ] if-empty ; [
[ [ text>> ] [ start-index>> ] bi ]
[ peek ] bi* rot <slice>
] if-empty ;

94
basis/ui/windows/windows.factor Normal file → Executable file
View File

@ -6,9 +6,10 @@ ui.gadgets ui.backend ui.clipboards ui.gadgets.worlds
ui.gestures io kernel math math.vectors namespaces make ui.gestures io kernel math math.vectors namespaces make
sequences strings vectors words windows.kernel32 windows.gdi32 sequences strings vectors words windows.kernel32 windows.gdi32
windows.user32 windows.opengl32 windows.messages windows.types windows.user32 windows.opengl32 windows.messages windows.types
windows.nt windows threads libc combinators continuations windows.nt windows threads libc combinators
command-line shuffle opengl ui.render unicode.case ascii combinators.short-circuit continuations command-line shuffle
math.bitwise locals symbols accessors math.geometry.rect ; opengl ui.render ascii math.bitwise locals symbols accessors
math.geometry.rect math.order ascii ;
IN: ui.windows IN: ui.windows
SINGLETON: windows-ui-backend SINGLETON: windows-ui-backend
@ -144,11 +145,6 @@ SYMBOLS: msg-obj class-name-ptr mouse-captured ;
: alt? ( -- ? ) left-alt? right-alt? or ; : alt? ( -- ? ) left-alt? right-alt? or ;
: caps-lock? ( -- ? ) VK_CAPITAL GetKeyState zero? not ; : caps-lock? ( -- ? ) VK_CAPITAL GetKeyState zero? not ;
: switch-case ( seq -- seq )
dup first CHAR: a >= [ >upper ] [ >lower ] if ;
: switch-case? ( -- ? ) shift? caps-lock? xor not ;
: key-modifiers ( -- seq ) : key-modifiers ( -- seq )
[ [
shift? [ S+ , ] when shift? [ S+ , ] when
@ -179,33 +175,53 @@ SYMBOLS: msg-obj class-name-ptr mouse-captured ;
: exclude-key-wm-char? ( n -- bool ) : exclude-key-wm-char? ( n -- bool )
exclude-keys-wm-char key? ; exclude-keys-wm-char key? ;
: keystroke>gesture ( n -- mods sym ? ) : keystroke>gesture ( n -- mods sym )
dup wm-keydown-codes at* [ wm-keydown-codes at* [ key-modifiers swap ] [ drop f f ] if ;
nip >r key-modifiers r> t
] [ : send-key-gesture ( sym action? quot hWnd -- )
drop 1string >r key-modifiers r> [ [ key-modifiers ] 3dip call ] dip
C+ pick member? >r A+ pick member? r> or [ window-focus propagate-gesture ; inline
shift? [ >lower ] unless f
] [ : send-key-down ( sym action? hWnd -- )
switch-case? [ switch-case ] when t [ [ <key-down> ] ] dip send-key-gesture ;
] if
] if ; : send-key-up ( sym action? hWnd -- )
[ [ <key-up> ] ] dip send-key-gesture ;
: key-sym ( wParam -- string/f action? )
{
{
[ dup LETTER? ]
[ shift? caps-lock? xor [ CHAR: a + CHAR: A - ] unless 1string f ]
}
{ [ dup digit? ] [ 1string f ] }
[ wm-keydown-codes at t ]
} cond ;
:: handle-wm-keydown ( hWnd uMsg wParam lParam -- ) :: handle-wm-keydown ( hWnd uMsg wParam lParam -- )
wParam exclude-key-wm-keydown? [ wParam exclude-key-wm-keydown? [
wParam keystroke>gesture <key-down> wParam key-sym over [
hWnd window-focus propagate-gesture dup ctrl? alt? xor or [
hWnd send-key-down
] [ 2drop ] if
] [ 2drop ] if
] unless ; ] unless ;
:: handle-wm-char ( hWnd uMsg wParam lParam -- ) :: handle-wm-char ( hWnd uMsg wParam lParam -- )
wParam exclude-key-wm-char? ctrl? alt? xor or [ wParam exclude-key-wm-char? [
wParam 1string ctrl? alt? xor [
hWnd window-focus user-input wParam 1string
[ f hWnd send-key-down ]
[ hWnd window-focus user-input ] bi
] unless
] unless ; ] unless ;
:: handle-wm-keyup ( hWnd uMsg wParam lParam -- ) :: handle-wm-keyup ( hWnd uMsg wParam lParam -- )
wParam keystroke>gesture <key-up> wParam exclude-key-wm-keydown? [
hWnd window-focus propagate-gesture ; wParam key-sym over [
hWnd send-key-up
] [ 2drop ] if
] unless ;
:: set-window-active ( hwnd uMsg wParam lParam ? -- n ) :: set-window-active ( hwnd uMsg wParam lParam ? -- n )
? hwnd window (>>active?) ? hwnd window (>>active?)
@ -241,20 +257,20 @@ M: windows-ui-backend (close-window)
: message>button ( uMsg -- button down? ) : message>button ( uMsg -- button down? )
{ {
{ [ dup WM_LBUTTONDOWN = ] [ drop 1 t ] } { WM_LBUTTONDOWN [ 1 t ] }
{ [ dup WM_LBUTTONUP = ] [ drop 1 f ] } { WM_LBUTTONUP [ 1 f ] }
{ [ dup WM_MBUTTONDOWN = ] [ drop 2 t ] } { WM_MBUTTONDOWN [ 2 t ] }
{ [ dup WM_MBUTTONUP = ] [ drop 2 f ] } { WM_MBUTTONUP [ 2 f ] }
{ [ dup WM_RBUTTONDOWN = ] [ drop 3 t ] } { WM_RBUTTONDOWN [ 3 t ] }
{ [ dup WM_RBUTTONUP = ] [ drop 3 f ] } { WM_RBUTTONUP [ 3 f ] }
{ [ dup WM_NCLBUTTONDOWN = ] [ drop 1 t ] } { WM_NCLBUTTONDOWN [ 1 t ] }
{ [ dup WM_NCLBUTTONUP = ] [ drop 1 f ] } { WM_NCLBUTTONUP [ 1 f ] }
{ [ dup WM_NCMBUTTONDOWN = ] [ drop 2 t ] } { WM_NCMBUTTONDOWN [ 2 t ] }
{ [ dup WM_NCMBUTTONUP = ] [ drop 2 f ] } { WM_NCMBUTTONUP [ 2 f ] }
{ [ dup WM_NCRBUTTONDOWN = ] [ drop 3 t ] } { WM_NCRBUTTONDOWN [ 3 t ] }
{ [ dup WM_NCRBUTTONUP = ] [ drop 3 f ] } { WM_NCRBUTTONUP [ 3 f ] }
} cond ; } case ;
! If the user clicks in the window border ("non-client area") ! If the user clicks in the window border ("non-client area")
! Windows sends us an NC[LMR]BUTTONDOWN message; but if the ! Windows sends us an NC[LMR]BUTTONDOWN message; but if the