diff --git a/basis/bitstreams/bitstreams-tests.factor b/basis/bitstreams/bitstreams-tests.factor index d55910b131..769efcbb04 100644 --- a/basis/bitstreams/bitstreams-tests.factor +++ b/basis/bitstreams/bitstreams-tests.factor @@ -6,17 +6,17 @@ io.streams.byte-array ; IN: bitstreams.tests [ 1 t ] -[ B{ 254 } read-bit ] unit-test +[ B{ 254 } binary read-bit ] unit-test [ 254 8 t ] -[ B{ 254 } 8 swap read-bits ] unit-test +[ B{ 254 } binary 8 swap read-bits ] unit-test [ 4095 12 t ] -[ B{ 255 255 } 12 swap read-bits ] unit-test +[ B{ 255 255 } binary 12 swap read-bits ] unit-test [ B{ 254 } ] [ - 254 8 rot + binary 254 8 rot [ write-bits ] keep stream>> >byte-array ] unit-test diff --git a/basis/core-text/core-text-tests.factor b/basis/core-text/core-text-tests.factor index 93f92391c8..a5cf69fdee 100644 --- a/basis/core-text/core-text-tests.factor +++ b/basis/core-text/core-text-tests.factor @@ -1,10 +1,9 @@ ! Copyright (C) 2009 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. -USING: tools.test core-text core-foundation -core-foundation.dictionaries destructors -arrays kernel generalizations math accessors -core-foundation.utilities -combinators hashtables colors ; +USING: tools.test core-text core-text.fonts core-foundation +core-foundation.dictionaries destructors arrays kernel generalizations +math accessors core-foundation.utilities combinators hashtables colors +colors.constants ; IN: core-text.tests : test-font ( name -- font ) @@ -21,8 +20,8 @@ IN: core-text.tests : test-typographic-bounds ( string font -- ? ) [ - test-font &CFRelease white &CFRelease - line-typographic-bounds { + test-font &CFRelease tuck COLOR: white &CFRelease + compute-line-metrics { [ width>> float? ] [ ascent>> float? ] [ descent>> float? ] diff --git a/basis/io/encodings/big5/big5.factor b/basis/io/encodings/big5/big5.factor index 97943a52ad..749815a22d 100644 --- a/basis/io/encodings/big5/big5.factor +++ b/basis/io/encodings/big5/big5.factor @@ -3,7 +3,7 @@ USING: io.encodings.iana io.encodings.euc ; IN: io.encodings.big5 -EUC: big5 "vocab:io/encodings/big5/CP950.txt" +EUC: big5 "vocab:io/encodings/big5/CP950.TXT" big5 "Big5" register-encoding diff --git a/basis/simple-flat-file/simple-flat-file-tests.factor b/basis/simple-flat-file/simple-flat-file-tests.factor index 5b58f569cb..33b6d4ac2a 100644 --- a/basis/simple-flat-file/simple-flat-file-tests.factor +++ b/basis/simple-flat-file/simple-flat-file-tests.factor @@ -1,6 +1,6 @@ ! Copyright (C) 2009 Yun, Jonghyouk. ! See http://factorcode.org/license.txt for BSD license. -USING: simple-flat-file tools.test memoize ; +USING: simple-flat-file tools.test memoize assocs ; IN: simple-flat-file.tests diff --git a/basis/simple-flat-file/simple-flat-file.factor b/basis/simple-flat-file/simple-flat-file.factor index 53f5f16425..721f4986a0 100644 --- a/basis/simple-flat-file/simple-flat-file.factor +++ b/basis/simple-flat-file/simple-flat-file.factor @@ -7,7 +7,7 @@ IN: simple-flat-file [ "#" split1 drop ] map harvest ; : split-column ( line -- columns ) - "\t" split 2 head ; + " \t" split harvest 2 head ; : parse-hex ( s -- n ) 2 short tail hex> ; diff --git a/basis/simple-flat-file/test1.txt b/basis/simple-flat-file/test1.txt new file mode 100644 index 0000000000..3437a61c38 --- /dev/null +++ b/basis/simple-flat-file/test1.txt @@ -0,0 +1,15 @@ +# +# Name: cp949 to Unicode table (for testing, partial) +# +0x00 0x0000 #NULL +0x01 0x0001 #START OF HEADING +0x02 0x0002 #START OF TEXT +0x03 0x0003 #END OF TEXT +0x04 0x0004 #END OF TRANSMISSION +0x8253 0xAD2A #HANGUL SYLLABLE KIYEOK WAE PIEUPSIOS +0x8254 0xAD2B #HANGUL SYLLABLE KIYEOK WAE SIOS +0x8255 0xAD2E #HANGUL SYLLABLE KIYEOK WAE CIEUC +0x8256 0xAD2F #HANGUL SYLLABLE KIYEOK WAE CHIEUCH +0x8257 0xAD30 #HANGUL SYLLABLE KIYEOK WAE KHIEUKH +0x8258 0xAD31 #HANGUL SYLLABLE KIYEOK WAE THIEUTH +0x8259 0xAD32 #HANGUL SYLLABLE KIYEOK WAE PHIEUPH diff --git a/basis/stack-checker/stack-checker-tests.factor b/basis/stack-checker/stack-checker-tests.factor index 6e7774aba1..c881ccee11 100644 --- a/basis/stack-checker/stack-checker-tests.factor +++ b/basis/stack-checker/stack-checker-tests.factor @@ -288,7 +288,7 @@ DEFER: bar [ [ [ dup call ] dup call ] infer ] [ inference-error? ] must-fail-with -: m dup call ; inline +: m ( q -- ) dup call ; inline [ [ [ m ] m ] infer ] [ inference-error? ] must-fail-with @@ -296,13 +296,13 @@ DEFER: bar [ [ [ m' ] m' ] infer ] [ inference-error? ] must-fail-with -: m'' [ dup curry ] ; inline +: m'' ( -- q ) [ dup curry ] ; inline -: m''' m'' call call ; inline +: m''' ( -- ) m'' call call ; inline [ [ [ m''' ] m''' ] infer ] [ inference-error? ] must-fail-with -: m-if t over if ; inline +: m-if ( a b c -- ) t over if ; inline [ [ [ m-if ] m-if ] infer ] [ inference-error? ] must-fail-with @@ -488,7 +488,7 @@ ERROR: custom-error ; [ custom-error ] infer ] unit-test -: funny-throw throw ; inline +: funny-throw ( a -- * ) throw ; inline [ T{ effect f 0 0 t } ] [ [ 3 funny-throw ] infer @@ -502,12 +502,8 @@ ERROR: custom-error ; [ dup [ 3 throw ] dip ] infer ] unit-test -! This was a false trigger of the undecidable quotation -! recursion bug -{ 2 1 } [ find-last-sep ] must-infer-as - ! Regression -: missing->r-check 1 load-locals ; +: missing->r-check ( a -- ) 1 load-locals ; [ [ missing->r-check ] infer ] must-fail @@ -516,7 +512,7 @@ ERROR: custom-error ; [ [ [ f dup ] [ ] while ] infer ] must-fail -: erg's-inference-bug ( -- ) f dup [ erg's-inference-bug ] when ; inline +: erg's-inference-bug ( -- ) f dup [ erg's-inference-bug ] when ; inline recursive [ [ erg's-inference-bug ] infer ] must-fail @@ -544,10 +540,10 @@ M: object inference-invalidation-d inference-invalidation-c 2drop ; [ [ inference-invalidation-d ] infer ] must-fail -: bad-recursion-3 ( -- ) dup [ [ bad-recursion-3 ] dip ] when ; inline +: bad-recursion-3 ( -- ) dup [ [ bad-recursion-3 ] dip ] when ; inline recursive [ [ bad-recursion-3 ] infer ] must-fail -: bad-recursion-4 ( -- ) 4 [ dup call roll ] times ; inline +: bad-recursion-4 ( -- ) 4 [ dup call roll ] times ; inline recursive [ [ [ ] [ 1 2 3 ] over dup bad-recursion-4 ] infer ] must-fail : bad-recursion-5 ( obj quot: ( -- ) -- ) dup call swap bad-recursion-5 ; inline recursive diff --git a/basis/tools/annotations/annotations-tests.factor b/basis/tools/annotations/annotations-tests.factor index 9210c2cab1..7e377aedd9 100644 --- a/basis/tools/annotations/annotations-tests.factor +++ b/basis/tools/annotations/annotations-tests.factor @@ -45,4 +45,4 @@ M: string blah-generic ; { string blah-generic } watch -[ ] [ "hi" blah-generic ] unit-test +[ "hi" ] [ "hi" blah-generic ] unit-test diff --git a/basis/ui/tools/listener/listener-tests.factor b/basis/ui/tools/listener/listener-tests.factor index 337921a00c..cd56dd876e 100644 --- a/basis/ui/tools/listener/listener-tests.factor +++ b/basis/ui/tools/listener/listener-tests.factor @@ -25,7 +25,7 @@ IN: ui.tools.listener.tests ! This should not throw an exception [ ] [ "interactor" get evaluate-input ] unit-test - [ ] [ [ "interactor" get interactor-busy? ] [ yield ] [ ] while ] unit-test + [ ] [ [ "interactor" get interactor-busy? ] [ yield ] while ] unit-test [ ] [ "[ 1 2 3 ]" "interactor" get set-editor-string ] unit-test @@ -48,7 +48,7 @@ IN: ui.tools.listener.tests [ ] [ "hi" "interactor" get set-editor-string ] unit-test - [ ] [ [ "interactor" get interactor-busy? ] [ yield ] [ ] while ] unit-test + [ ] [ [ "interactor" get interactor-busy? ] [ yield ] while ] unit-test [ ] [ "interactor" get evaluate-input ] unit-test diff --git a/extra/4DNav/4DNav.factor b/extra/4DNav/4DNav.factor index d761eaf473..8ddbff96d9 100755 --- a/extra/4DNav/4DNav.factor +++ b/extra/4DNav/4DNav.factor @@ -3,6 +3,7 @@ USING: kernel namespaces accessors +assocs make math math.functions @@ -16,6 +17,7 @@ colors colors.constants prettyprint vars +call quotations io io.directories @@ -27,8 +29,6 @@ ui.gadgets.panes ui.gadgets ui.traverse ui.gadgets.borders - ui.gadgets.handler - ui.gadgets.slate ui.gadgets.frames ui.gadgets.tracks ui.gadgets.labels @@ -53,6 +53,7 @@ adsoda adsoda.tools ; QUALIFIED-WITH: ui.pens.solid s +QUALIFIED-WITH: ui.gadgets.wrappers w IN: 4DNav @@ -392,6 +393,13 @@ USE: ui.gadgets.labeled.private add-gadget menu-quick-views add-gadget ; +TUPLE: handler < w:wrapper table ; + +: ( child -- handler ) handler w:new-wrapper ; + +M: handler handle-gesture ( gesture gadget -- ? ) + tuck table>> at dup [ call( gadget -- ) f ] [ 2drop t ] if ; + : add-keyboard-delegate ( obj -- obj ) { diff --git a/extra/4DNav/file-chooser/file-chooser.factor b/extra/4DNav/file-chooser/file-chooser.factor index 5fe8284c78..9bd0e9c011 100755 --- a/extra/4DNav/file-chooser/file-chooser.factor +++ b/extra/4DNav/file-chooser/file-chooser.factor @@ -24,7 +24,6 @@ ui.gadgets.panes ui.gadgets.scrollers prettyprint combinators -rewrite-closures accessors values tools.walker @@ -67,7 +66,7 @@ file-chooser H{ [ directory? ] bi or ] filter ; -: update-filelist-model ( file-chooser -- file-chooser ) +: update-filelist-model ( file-chooser -- ) [ list-of-files ] [ model>> ] bi set-model ; : init-filelist-model ( file-chooser -- file-chooser ) @@ -86,7 +85,7 @@ file-chooser H{ : fc-go-home ( file-chooser -- ) [ home ] (fc-go) ; -: fc-change-directory ( file-chooser file -- file-chooser ) +: fc-change-directory ( file-chooser file -- ) dupd [ path>> value>> normalize-path ] [ name>> ] bi* append-path over path>> set-model update-filelist-model diff --git a/extra/4DNav/turtle/turtle.factor b/extra/4DNav/turtle/turtle.factor index aa705978c9..664645c466 100755 --- a/extra/4DNav/turtle/turtle.factor +++ b/extra/4DNav/turtle/turtle.factor @@ -10,9 +10,9 @@ IN: 4DNav.turtle VAR: self -: with-self ( quot obj -- ) [ >self call ] with-scope ; +: with-self ( quot obj -- ) [ >self call ] with-scope ; inline -: save-self ( quot -- ) self> [ self> clone >self call ] dip >self ; +: save-self ( quot -- ) self> [ self> clone >self call ] dip >self ; inline ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! diff --git a/extra/tetris/board/board-tests.factor b/extra/tetris/board/board-tests.factor index 518b5544e9..81ee65bcb8 100644 --- a/extra/tetris/board/board-tests.factor +++ b/extra/tetris/board/board-tests.factor @@ -1,23 +1,23 @@ -USING: accessors arrays colors kernel tetris.board tetris.piece tools.test ; +USING: accessors arrays colors colors.constants kernel tetris.board tetris.piece tools.test ; [ { { f f } { f f } { f f } } ] [ 2 3 make-rows ] unit-test [ { { f f } { f f } { f f } } ] [ 2 3 rows>> ] unit-test [ 1 { f f } ] [ 2 3 { 1 1 } board@block ] unit-test [ f ] [ 2 3 { 1 1 } block ] unit-test [ 2 3 { 2 3 } block ] must-fail -red 1array [ 2 3 dup { 1 1 } red set-block { 1 1 } block ] unit-test +COLOR: red 1array [ 2 3 dup { 1 1 } COLOR: red set-block { 1 1 } block ] unit-test [ t ] [ 2 3 { 1 1 } block-free? ] unit-test -[ f ] [ 2 3 dup { 1 1 } red set-block { 1 1 } block-free? ] unit-test -[ t ] [ 2 3 dup { 1 1 } red set-block { 1 2 } block-free? ] unit-test -[ t ] [ 2 3 dup { 1 1 } red set-block { 0 1 } block-free? ] unit-test +[ f ] [ 2 3 dup { 1 1 } COLOR: red set-block { 1 1 } block-free? ] unit-test +[ t ] [ 2 3 dup { 1 1 } COLOR: red set-block { 1 2 } block-free? ] unit-test +[ t ] [ 2 3 dup { 1 1 } COLOR: red set-block { 0 1 } block-free? ] unit-test [ t ] [ 2 3 { 0 0 } block-in-bounds? ] unit-test [ f ] [ 2 3 { -1 0 } block-in-bounds? ] unit-test [ t ] [ 2 3 { 1 2 } block-in-bounds? ] unit-test [ f ] [ 2 3 { 2 2 } block-in-bounds? ] unit-test [ t ] [ 2 3 { 1 1 } location-valid? ] unit-test -[ f ] [ 2 3 dup { 1 1 } red set-block { 1 1 } location-valid? ] unit-test +[ f ] [ 2 3 dup { 1 1 } COLOR: red set-block { 1 1 } location-valid? ] unit-test [ t ] [ 10 10 10 piece-valid? ] unit-test [ f ] [ 2 3 10 { 1 2 } >>location piece-valid? ] unit-test [ { { f } { f } } ] [ 1 1 add-row rows>> ] unit-test -[ { { f } } ] [ 1 2 dup { 0 1 } red set-block remove-full-rows rows>> ] unit-test -[ { { f } { f } } ] [ 1 2 dup { 0 1 } red set-block dup check-rows drop rows>> ] unit-test +[ { { f } } ] [ 1 2 dup { 0 1 } COLOR: red set-block remove-full-rows rows>> ] unit-test +[ { { f } { f } } ] [ 1 2 dup { 0 1 } COLOR: red set-block dup check-rows drop rows>> ] unit-test diff --git a/extra/ui/gadgets/handler/authors.txt b/extra/ui/gadgets/handler/authors.txt deleted file mode 100755 index 6cfd5da273..0000000000 --- a/extra/ui/gadgets/handler/authors.txt +++ /dev/null @@ -1 +0,0 @@ -Eduardo Cavazos diff --git a/extra/ui/gadgets/handler/handler.factor b/extra/ui/gadgets/handler/handler.factor deleted file mode 100644 index 1c12142593..0000000000 --- a/extra/ui/gadgets/handler/handler.factor +++ /dev/null @@ -1,11 +0,0 @@ - -USING: kernel assocs ui.gestures ui.gadgets.wrappers accessors ; - -IN: ui.gadgets.handler - -TUPLE: handler < wrapper table ; - -: ( child -- handler ) handler new-wrapper ; - -M: handler handle-gesture ( gesture gadget -- ? ) - tuck table>> at dup [ call f ] [ 2drop t ] if ; \ No newline at end of file diff --git a/extra/ui/gadgets/lists/lists.factor b/extra/ui/gadgets/lists/lists.factor index 4b5ceac086..982aabe2e8 100644 --- a/extra/ui/gadgets/lists/lists.factor +++ b/extra/ui/gadgets/lists/lists.factor @@ -1,10 +1,10 @@ ! Copyright (C) 2006, 2009 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. USING: accessors math.vectors classes.tuple math.rectangles colors -kernel sequences models opengl math math.order namespaces -ui.commands ui.gestures ui.render ui.gadgets -ui.gadgets.labels ui.gadgets.scrollers -ui.gadgets.presentations ui.gadgets.viewports ui.gadgets.packs ; +kernel sequences models opengl math math.order namespaces call +ui.commands ui.gestures ui.render ui.gadgets ui.gadgets.labels +ui.gadgets.scrollers ui.gadgets.presentations ui.gadgets.viewports +ui.gadgets.packs ; IN: ui.gadgets.lists TUPLE: list < pack index presenter color hook ; @@ -32,7 +32,7 @@ TUPLE: list < pack index presenter color hook ; hook>> [ [ list? ] find-parent ] prepend ; : ( hook elt presenter -- gadget ) - keep [ >label text-theme ] dip + [ call( elt -- obj ) ] [ drop ] 2bi [ >label text-theme ] dip swap >>hook ; inline diff --git a/extra/ui/gadgets/slate/authors.txt b/extra/ui/gadgets/slate/authors.txt deleted file mode 100755 index 6cfd5da273..0000000000 --- a/extra/ui/gadgets/slate/authors.txt +++ /dev/null @@ -1 +0,0 @@ -Eduardo Cavazos diff --git a/extra/ui/gadgets/slate/slate-docs.factor b/extra/ui/gadgets/slate/slate-docs.factor deleted file mode 100644 index 0225c20a1e..0000000000 --- a/extra/ui/gadgets/slate/slate-docs.factor +++ /dev/null @@ -1,13 +0,0 @@ -! Copyright (C) 2009 Eduardo Cavazos -! See http://factorcode.org/license.txt for BSD license. -USING: help.markup help.syntax multiline ; -IN: ui.gadgets.slate - -ARTICLE: "ui.gadgets.slate" "Slate gadget" -{ $description "A gadget with an 'action' slot which should be set to a callable."} -{ $heading "Example" } -{ $code <" USING: processing.shapes ui.gadgets.slate ui.gadgets.panes ; -[ { { 10 10 } { 50 30 } { 10 50 } } polygon fill-mode ] -gadget."> } ; - -ABOUT: "ui.gadgets.slate" diff --git a/extra/ui/gadgets/slate/slate.factor b/extra/ui/gadgets/slate/slate.factor deleted file mode 100644 index ac66da44b7..0000000000 --- a/extra/ui/gadgets/slate/slate.factor +++ /dev/null @@ -1,124 +0,0 @@ -! Copyright (C) 2009 Eduardo Cavazos -! See http://factorcode.org/license.txt for BSD license. -USING: kernel namespaces opengl ui.render ui.gadgets accessors ; - -IN: ui.gadgets.slate - -! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! - - -! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! - -TUPLE: slate < gadget action pdim graft ungraft ; - -! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! - -: init-slate ( slate -- slate ) - [ ] >>action - { 200 200 } >>pdim - [ ] >>graft - [ ] >>ungraft ; - -: ( action -- slate ) - slate new - init-slate - swap >>action ; - -M: slate pref-dim* ( slate -- dim ) pdim>> ; - -! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! - -USING: combinators arrays sequences math - opengl.gl ui.gadgets.worlds ; - -: width ( rect -- w ) dim>> first ; -: height ( rect -- h ) dim>> second ; - -: screen-y* ( gadget -- loc ) - { - [ find-world height ] - [ screen-loc second ] - [ height ] - } - cleave - + - ; - -: screen-loc* ( gadget -- loc ) - { - [ screen-loc first ] - [ screen-y* ] - } - cleave - 2array ; - -: setup-viewport ( gadget -- gadget ) - dup - { - [ screen-loc* ] - [ dim>> ] - } - cleave - gl-viewport ; - -! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! - -: default-coordinate-system ( gadget -- gadget ) - dup - { - [ drop 0 ] - [ width 1 - ] - [ height 1 - ] - [ drop 0 ] - } - cleave - -1 1 - glOrtho ; - -! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! - -M: slate graft* ( slate -- ) graft>> call ; -M: slate ungraft* ( slate -- ) ungraft>> call ; - -! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! - -GENERIC: establish-coordinate-system ( gadget -- gadget ) - -! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! - -M: slate establish-coordinate-system ( slate -- slate ) - default-coordinate-system ; - -! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! - -GENERIC: draw-slate ( slate -- slate ) - -! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! - -M: slate draw-slate ( slate -- slate ) dup action>> call ; - -! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! - -M: slate draw-gadget* ( slate -- ) - - GL_PROJECTION glMatrixMode glPushMatrix glLoadIdentity - - establish-coordinate-system - - GL_MODELVIEW glMatrixMode glPushMatrix glLoadIdentity - - setup-viewport - - draw-slate - - GL_PROJECTION glMatrixMode glPopMatrix glLoadIdentity - GL_MODELVIEW glMatrixMode glPopMatrix glLoadIdentity - - dup - find-world - ! The world coordinate system is a little wacky: - dup { [ drop 0 ] [ width ] [ height ] [ drop 0 ] } cleave -1 1 glOrtho - setup-viewport - drop - drop ; - -! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!