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

basis/bitstreams/bitstreams-tests.factor

@@ -6,17 +6,17 @@ io.streams.byte-array ;
 IN: bitstreams.tests
 
 [ 1 t ]
-[ B{ 254 } <string-reader> <bitstream-reader> read-bit ] unit-test
+[ B{ 254 } binary <byte-reader> <bitstream-reader> read-bit ] unit-test
 
 [ 254 8 t ]
-[ B{ 254 } <string-reader> <bitstream-reader> 8 swap read-bits ] unit-test
+[ B{ 254 } binary <byte-reader> <bitstream-reader> 8 swap read-bits ] unit-test
 
 [ 4095 12 t ]
-[ B{ 255 255 } <string-reader> <bitstream-reader> 12 swap read-bits ] unit-test
+[ B{ 255 255 } binary <byte-reader> <bitstream-reader> 12 swap read-bits ] unit-test
 
 [ B{ 254 } ]
 [
-    <string-writer> <bitstream-writer> 254 8 rot
+    binary <byte-writer> <bitstream-writer> 254 8 rot
     [ write-bits ] keep stream>> >byte-array
 ] unit-test
 

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
+USING: tools.test core-text core-text.fonts core-foundation
-core-foundation.dictionaries destructors
+core-foundation.dictionaries destructors arrays kernel generalizations
-arrays kernel generalizations math accessors
+math accessors core-foundation.utilities combinators hashtables colors
-core-foundation.utilities
+colors.constants ;
-combinators hashtables colors ;
 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 <CTLine> &CFRelease
+        test-font &CFRelease tuck COLOR: white <CTLine> &CFRelease
-        line-typographic-bounds {
+        compute-line-metrics {
             [ width>> float? ]
             [ ascent>> float? ]
             [ descent>> float? ]

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
 

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
 
 

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> ;

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

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

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

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
 

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 ;
+
+: <handler> ( 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 )
  <handler>
 {

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

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
 
 ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
 

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 <board> rows>> ] unit-test
 [ 1 { f f } ] [ 2 3 <board> { 1 1 } board@block ] unit-test
 [ f ] [ 2 3 <board> { 1 1 } block ] unit-test
 [ 2 3 <board> { 2 3 } block ] must-fail
-red 1array [ 2 3 <board> dup { 1 1 } red set-block { 1 1 } block ] unit-test
+COLOR: red 1array [ 2 3 <board> dup { 1 1 } COLOR: red set-block { 1 1 } block ] unit-test
 [ t ] [ 2 3 <board> { 1 1 } block-free? ] unit-test
-[ f ] [ 2 3 <board> dup { 1 1 } red set-block { 1 1 } block-free? ] unit-test
+[ f ] [ 2 3 <board> dup { 1 1 } COLOR: red set-block { 1 1 } block-free? ] unit-test
-[ t ] [ 2 3 <board> dup { 1 1 } red set-block { 1 2 } block-free? ] unit-test
+[ t ] [ 2 3 <board> dup { 1 1 } COLOR: red set-block { 1 2 } block-free? ] unit-test
-[ t ] [ 2 3 <board> dup { 1 1 } red set-block { 0 1 } block-free? ] unit-test
+[ t ] [ 2 3 <board> dup { 1 1 } COLOR: red set-block { 0 1 } block-free? ] unit-test
 [ t ] [ 2 3 <board> { 0 0 } block-in-bounds? ] unit-test
 [ f ] [ 2 3 <board> { -1 0 } block-in-bounds? ] unit-test
 [ t ] [ 2 3 <board> { 1 2 } block-in-bounds? ] unit-test
 [ f ] [ 2 3 <board> { 2 2 } block-in-bounds? ] unit-test
 [ t ] [ 2 3 <board> { 1 1 } location-valid? ] unit-test
-[ f ] [ 2 3 <board> dup { 1 1 } red set-block { 1 1 } location-valid? ] unit-test
+[ f ] [ 2 3 <board> dup { 1 1 } COLOR: red set-block { 1 1 } location-valid? ] unit-test
 [ t ] [ 10 10 <board> 10 <random-piece> piece-valid? ] unit-test
 [ f ] [ 2 3 <board> 10 <random-piece> { 1 2 } >>location piece-valid? ] unit-test
 [ { { f } { f } } ] [ 1 1 <board> add-row rows>> ] unit-test
-[ { { f } } ] [ 1 2 <board> dup { 0 1 } red set-block remove-full-rows rows>> ] unit-test
+[ { { f } } ] [ 1 2 <board> dup { 0 1 } COLOR: red set-block remove-full-rows rows>> ] unit-test
-[ { { f } { f } } ] [ 1 2 <board> dup { 0 1 } red set-block dup check-rows drop rows>> ] unit-test
+[ { { f } { f } } ] [ 1 2 <board> dup { 0 1 } COLOR: red set-block dup check-rows drop rows>> ] unit-test

extra/ui/gadgets/handler/authors.txt

@@ -1 +0,0 @@
-Eduardo Cavazos

extra/ui/gadgets/handler/handler.factor

@@ -1,11 +0,0 @@
-
-USING: kernel assocs ui.gestures ui.gadgets.wrappers accessors ;
-
-IN: ui.gadgets.handler
-
-TUPLE: handler < wrapper table ;
-
-: <handler> ( child -- handler ) handler new-wrapper ;
-
-M: handler handle-gesture ( gesture gadget -- ? )
-   tuck table>> at dup [ call f ] [ 2drop t ] if ;

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
+kernel sequences models opengl math math.order namespaces call
-ui.commands ui.gestures ui.render ui.gadgets
+ui.commands ui.gestures ui.render ui.gadgets ui.gadgets.labels
-ui.gadgets.labels ui.gadgets.scrollers
+ui.gadgets.scrollers ui.gadgets.presentations ui.gadgets.viewports
-ui.gadgets.presentations ui.gadgets.viewports ui.gadgets.packs ;
+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 ;
 
 : <list-presentation> ( hook elt presenter -- gadget )
-    keep [ >label text-theme ] dip
+    [ call( elt -- obj ) ] [ drop ] 2bi [ >label text-theme ] dip
     <presentation>
     swap >>hook ; inline
 

extra/ui/gadgets/slate/authors.txt

@@ -1 +0,0 @@
-Eduardo Cavazos

extra/ui/gadgets/slate/slate-docs.factor

@@ -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 ] <slate>
-gadget."> } ;
-
-ABOUT: "ui.gadgets.slate"

extra/ui/gadgets/slate/slate.factor

@@ -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 ;
-
-: <slate> ( 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 ;
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!