Merge branch 'master' into smarter_error_list

Makefile

@@ -141,9 +141,10 @@ wince-arm:
 
 macosx.app: factor
 	mkdir -p $(BUNDLE)/Contents/MacOS
+	mkdir -p $(BUNDLE)/Contents/Frameworks
 	mv $(EXECUTABLE) $(BUNDLE)/Contents/MacOS/factor
 	ln -s Factor.app/Contents/MacOS/factor ./factor
-	cp $(ENGINE) $(BUNDLE)/Contents/Frameworks
+	cp $(ENGINE) $(BUNDLE)/Contents/Frameworks/$(ENGINE)
 
 	install_name_tool \
 		-change libfactor.dylib \
@@ -161,11 +162,11 @@ factor-console: $(DLL_OBJS) $(EXE_OBJS)
 		$(CFLAGS) $(CFLAGS_CONSOLE) -o factor$(EXE_SUFFIX)$(CONSOLE_EXTENSION) $(EXE_OBJS)
 
 factor-ffi-test: vm/ffi_test.o
-	$(CC) $(LIBPATH) $(CFLAGS) $(FFI_TEST_CFLAGS) $(SHARED_FLAG) -o libfactor-ffi-test$(DLL_EXTENSION) $(TEST_OBJS)
+	$(CC) $(LIBPATH) $(CFLAGS) $(FFI_TEST_CFLAGS) $(SHARED_FLAG) -o libfactor-ffi-test$(SHARED_DLL_EXTENSION) $(TEST_OBJS)
 
 clean:
 	rm -f vm/*.o
-	rm -f factor*.dll libfactor.{a,so,dylib}
+	rm -f factor*.dll libfactor.{a,so,dylib} libfactor-ffi-test.{a,so,dylib}
 
 vm/resources.o:
 	$(WINDRES) vm/factor.rs vm/resources.o

README.txt

@@ -113,12 +113,6 @@ the command prompt using the console application:
 
   factor.com -i=boot.<cpu>.image
 
-Before bootstrapping, you will need to download the DLLs for the Pango
-text rendering library. The required DLLs are listed in
-build-support/dlls.txt and are available from the following location:
-
-  <http://factorcode.org/dlls>
-
 Once bootstrapped, double-clicking factor.exe or factor.com starts
 the Factor UI.
 

basis/alien/destructors/destructors.factor

@@ -1,6 +1,7 @@
 ! Copyright (C) 2009 Slava Pestov.
 ! See http://factorcode.org/license.txt for BSD license.
-USING: functors destructors accessors kernel parser words ;
+USING: functors destructors accessors kernel parser words
+effects generalizations sequences ;
 IN: alien.destructors
 
 SLOT: alien
@@ -11,6 +12,7 @@ F-destructor DEFINES-CLASS ${F}-destructor
 <F-destructor> DEFINES <${F}-destructor>
 &F DEFINES &${F}
 |F DEFINES |${F}
+N [ F stack-effect out>> length ]
 
 WHERE
 
@@ -18,7 +20,7 @@ TUPLE: F-destructor alien disposed ;
 
 : <F-destructor> ( alien -- destructor ) f F-destructor boa ; inline
 
-M: F-destructor dispose* alien>> F ;
+M: F-destructor dispose* alien>> F N ndrop ;
 
 : &F ( alien -- alien ) dup <F-destructor> &dispose drop ; inline
 

basis/alien/fortran/fortran-docs.factor

@@ -7,10 +7,10 @@ IN: alien.fortran
 ARTICLE: "alien.fortran-abis" "Fortran ABIs"
 "Fortran does not have a standard ABI like C does. Factor supports the following Fortran ABIs:"
 { $list
-    { { $subsection gfortran-abi } " is used by gfortran, the Fortran compiler included with GCC 4." }
+    { { $link gfortran-abi } " is used by gfortran, the Fortran compiler included with GCC 4." }
-    { { $subsection f2c-abi } " is used by the F2C Fortran-to-C translator and G77, the Fortran compiler included with GCC 3.x and earlier. It is also used by gfortran when compiling with the -ff2c flag." }
+    { { $link f2c-abi } " is used by the F2C Fortran-to-C translator and G77, the Fortran compiler included with GCC 3.x and earlier. It is also used by gfortran when compiling with the -ff2c flag." }
-    { { $subsection intel-unix-abi } " is used by the Intel Fortran Compiler on Linux and Mac OS X." }
+    { { $link intel-unix-abi } " is used by the Intel Fortran Compiler on Linux and Mac OS X." }
-    { { $subsection intel-windows-abi } " is used by the Intel Fortran Compiler on Windows." }
+    { { $link intel-windows-abi } " is used by the Intel Fortran Compiler on Windows." }
 }
 "A library's ABI is specified when that library is opened by the " { $link add-fortran-library } " word." ;
 

basis/binary-search/binary-search-docs.factor

@@ -14,7 +14,7 @@ $nl
 
 HELP: sorted-index
 { $values { "obj" object } { "seq" "a sorted sequence" } { "i" "an index, or " { $link f } } }
-{ $description "Outputs the index and value of the element closest to " { $snippet "elt" } " in the sequence. See " { $link search } " for details." }
+{ $description "Outputs the index of the element closest to " { $snippet "elt" } " in the sequence. See " { $link search } " for details." }
 { $notes "If the sequence has at least one element, this word always outputs a valid index, because it finds the closest match, not necessarily an exact one. In this respect its behavior differs from " { $link index } "." } ;
 
 { index index-from last-index last-index-from sorted-index } related-words

basis/bootstrap/ui/ui.factor

@@ -10,12 +10,4 @@ IN: bootstrap.ui
             { [ os unix? ] [ "x11" ] }
         } cond
     ] unless* "ui.backend." prepend require
-
-    "ui-text-backend" get [
-        {
-            { [ os macosx? ] [ "core-text" ] }
-            { [ os windows? ] [ "pango" ] }
-            { [ os unix? ] [ "pango" ] }
-        } cond
-    ] unless* "ui.text." prepend require
 ] when

basis/calendar/calendar.factor

@@ -1,8 +1,8 @@
 ! Copyright (C) 2007 Doug Coleman.
 ! See http://factorcode.org/license.txt for BSD license.
-USING: arrays kernel math math.functions namespaces sequences
+USING: accessors arrays classes.tuple combinators combinators.short-circuit
-strings system vocabs.loader threads accessors combinators
+    kernel locals math math.functions math.order namespaces sequences strings
-locals classes.tuple math.order summary combinators.short-circuit ;
+    summary system threads vocabs.loader ;
 IN: calendar
 
 HOOK: gmt-offset os ( -- hours minutes seconds )
@@ -136,7 +136,7 @@ CONSTANT: day-abbreviations3
 GENERIC: leap-year? ( obj -- ? )
 
 M: integer leap-year? ( year -- ? )
-    dup 100 mod zero? 400 4 ? mod zero? ;
+    dup 100 divisor? 400 4 ? divisor? ;
 
 M: timestamp leap-year? ( timestamp -- ? )
     year>> leap-year? ;
@@ -348,7 +348,7 @@ M: duration time-
     #! good for any date since October 15, 1582
     [
         dup 2 <= [ [ 1- ] [ 12 + ] bi* ] when
-        [ dup [ 4 /i + ] keep [ 100 /i - ] keep 400 /i + ] dip
+        [ dup [ 4 /i + ] [ 100 /i - ] [ 400 /i + ] tri ] dip
         [ 1+ 3 * 5 /i + ] keep 2 * +
     ] dip 1+ + 7 mod ;
 

basis/cocoa/application/application.factor

@@ -2,7 +2,7 @@
 ! See http://factorcode.org/license.txt for BSD license.
 USING: alien alien.syntax io kernel namespaces core-foundation
 core-foundation.strings cocoa.messages cocoa cocoa.classes
-cocoa.runtime sequences threads init summary kernel.private
+cocoa.runtime sequences init summary kernel.private
 assocs ;
 IN: cocoa.application
 

basis/combinators/smart/smart.factor

@@ -4,6 +4,9 @@ USING: accessors fry generalizations kernel macros math.order
 stack-checker math ;
 IN: combinators.smart
 
+MACRO: drop-outputs ( quot -- quot' )
+    dup infer out>> '[ @ _ ndrop ] ;
+
 MACRO: output>sequence ( quot exemplar -- newquot )
     [ dup infer out>> ] dip
     '[ @ _ _ nsequence ] ;

basis/compiler/codegen/codegen.factor

@@ -53,7 +53,7 @@ SYMBOL: labels
     V{ } clone literal-table set
     V{ } clone calls set
     compiling-word set
-    compiled-stack-traces? compiling-word get f ? add-literal ;
+    compiled-stack-traces? [ compiling-word get add-literal ] when ;
 
 : generate ( mr -- asm )
     [

basis/compiler/tests/alien.factor

@@ -9,11 +9,11 @@ IN: compiler.tests
 
 <<
 : libfactor-ffi-tests-path ( -- string )
-    "resource:" normalize-path
+    "resource:" (normalize-path)
     {
         { [ os winnt? ]  [ "libfactor-ffi-test.dll" ] }
         { [ os macosx? ] [ "libfactor-ffi-test.dylib" ] }
-        { [ os unix?  ]  [ "libfactor-ffi-test.a" ] }
+        { [ os unix?  ]  [ "libfactor-ffi-test.so" ] }
     } cond append-path ;
 
 "f-cdecl" libfactor-ffi-tests-path "cdecl" add-library

basis/compiler/tree/propagation/known-words/known-words.factor

@@ -312,7 +312,7 @@ generic-comparison-ops [
 \ clone [
     in-d>> first value-info literal>> {
         { V{ } [ [ drop { } 0 vector boa ] ] }
-        { H{ } [ [ drop hashtable new ] ] }
+        { H{ } [ [ drop 0 <hashtable> ] ] }
         [ drop f ]
     } case
 ] "custom-inlining" set-word-prop

basis/concurrency/conditions/conditions.factor

@@ -20,10 +20,12 @@ IN: concurrency.conditions
         ]
     ] dip later ;
 
+ERROR: wait-timeout ;
+
 : wait ( queue timeout status -- )
     over [
         [ queue-timeout [ drop ] ] dip suspend
-        [ "Timeout" throw ] [ cancel-alarm ] if
+        [ wait-timeout ] [ cancel-alarm ] if
     ] [
         [ drop '[ _ push-front ] ] dip suspend drop
     ] if ;

basis/concurrency/mailboxes/mailboxes-tests.factor

@@ -1,6 +1,6 @@
 IN: concurrency.mailboxes.tests
-USING: concurrency.mailboxes concurrency.count-downs vectors
+USING: concurrency.mailboxes concurrency.count-downs concurrency.conditions
-sequences threads tools.test math kernel strings namespaces
+vectors sequences threads tools.test math kernel strings namespaces
 continuations calendar destructors ;
 
 { 1 1 } [ [ integer? ] mailbox-get? ] must-infer-as
@@ -75,3 +75,15 @@ continuations calendar destructors ;
 [ ] [ "d" get 5 seconds await-timeout ] unit-test
 
 [ ] [ "m" get dispose ] unit-test
+
+[ { "foo" "bar" } ] [
+    <mailbox>
+    "foo" over mailbox-put
+    "bar" over mailbox-put
+    mailbox-get-all
+] unit-test
+
+[
+    <mailbox> 1 seconds mailbox-get-timeout
+] [ wait-timeout? ] must-fail-with
+    

basis/concurrency/mailboxes/mailboxes.factor

@@ -49,7 +49,7 @@ M: mailbox dispose* threads>> notify-all ;
 
 : mailbox-get-all-timeout ( mailbox timeout -- array )
     block-if-empty
-    [ dup mailbox-empty? ]
+    [ dup mailbox-empty? not ]
     [ dup data>> pop-back ]
     produce nip ;
 

basis/core-foundation/strings/strings.factor

@@ -2,7 +2,7 @@
 ! See http://factorcode.org/license.txt for BSD license.
 USING: alien.syntax alien.strings io.encodings.string kernel
 sequences byte-arrays io.encodings.utf8 math core-foundation
-core-foundation.arrays destructors unicode.data ;
+core-foundation.arrays destructors ;
 IN: core-foundation.strings
 
 TYPEDEF: void* CFStringRef
@@ -62,7 +62,7 @@ FUNCTION: CFStringRef CFStringCreateWithCString (
 : prepare-CFString ( string -- byte-array )
     [
         dup HEX: 10ffff >
-        [ drop CHAR: replacement-character ] when
+        [ drop HEX: fffd ] when
     ] map utf8 encode ;
 
 : <CFString> ( string -- alien )

basis/cpu/ppc/ppc.factor

@@ -659,13 +659,40 @@ M: ppc %callback-value ( ctype -- )
 
 M: ppc small-enough? ( n -- ? ) -32768 32767 between? ;
 
-M: ppc return-struct-in-registers? ( c-type -- ? ) drop f ;
+M: ppc return-struct-in-registers? ( c-type -- ? )
+    c-type return-in-registers?>> ;
 
-M: ppc %box-small-struct
+M: ppc %box-small-struct ( c-type -- )
-    drop "No small structs" throw ;
+    #! Box a <= 16-byte struct returned in r3:r4:r5:r6
+    heap-size 7 LI
+    "box_medium_struct" f %alien-invoke ;
 
-M: ppc %unbox-small-struct
+: %unbox-struct-1 ( -- )
-    drop "No small structs" throw ;
+    ! Alien must be in r3.
+    "alien_offset" f %alien-invoke
+    3 3 0 LWZ ;
+
+: %unbox-struct-2 ( -- )
+    ! Alien must be in r3.
+    "alien_offset" f %alien-invoke
+    4 3 4 LWZ
+    3 3 0 LWZ ;
+
+: %unbox-struct-4 ( -- )
+    ! Alien must be in r3.
+    "alien_offset" f %alien-invoke
+    6 3 12 LWZ
+    5 3 8 LWZ
+    4 3 4 LWZ
+    3 3 0 LWZ ;
+
+M: ppc %unbox-small-struct ( size -- )
+    #! Alien must be in EAX.
+    heap-size cell align cell /i {
+        { 1 [ %unbox-struct-1 ] }
+        { 2 [ %unbox-struct-2 ] }
+        { 4 [ %unbox-struct-4 ] }
+    } case ;
 
 USE: vocabs.loader
 
@@ -673,3 +700,5 @@ USE: vocabs.loader
     { [ os macosx? ] [ "cpu.ppc.macosx" require ] }
     { [ os linux? ] [ "cpu.ppc.linux" require ] }
 } cond
+
+"complex-double" c-type t >>return-in-registers? drop

basis/documents/elements/elements-tests.factor

@@ -3,68 +3,72 @@
 USING: tools.test namespaces documents documents.elements multiline ;
 IN: document.elements.tests
 
-<document> "doc" set
+SYMBOL: doc
-"123\nabc" "doc" get set-doc-string
+<document> doc set
+"123\nabcé" doc get set-doc-string
 
 ! char-elt
-[ { 0 0 } ] [ { 0 0 } "doc" get char-elt prev-elt ] unit-test
+[ { 0 0 } ] [ { 0 0 } doc get char-elt prev-elt ] unit-test
-[ { 0 0 } ] [ { 0 1 } "doc" get char-elt prev-elt ] unit-test
+[ { 0 0 } ] [ { 0 1 } doc get char-elt prev-elt ] unit-test
-[ { 0 3 } ] [ { 1 0 } "doc" get char-elt prev-elt ] unit-test
+[ { 0 3 } ] [ { 1 0 } doc get char-elt prev-elt ] unit-test
+[ { 1 3 } ] [ { 1 5 } doc get char-elt prev-elt ] unit-test
 
-[ { 1 3 } ] [ { 1 3 } "doc" get char-elt next-elt ] unit-test
+[ { 1 5 } ] [ { 1 5 } doc get char-elt next-elt ] unit-test
-[ { 0 2 } ] [ { 0 1 } "doc" get char-elt next-elt ] unit-test
+[ { 0 2 } ] [ { 0 1 } doc get char-elt next-elt ] unit-test
-[ { 1 0 } ] [ { 0 3 } "doc" get char-elt next-elt ] unit-test
+[ { 1 0 } ] [ { 0 3 } doc get char-elt next-elt ] unit-test
+[ { 1 5 } ] [ { 1 3 } doc get char-elt next-elt ] unit-test
 
 ! word-elt
-<document> "doc" set
+<document> doc set
-"Hello world\nanother line" "doc" get set-doc-string
+"Hello world\nanother line" doc get set-doc-string
 
-[ { 0 0 } ] [ { 0 0 } "doc" get word-elt prev-elt ] unit-test
+[ { 0 0 } ] [ { 0 0 } doc get word-elt prev-elt ] unit-test
-[ { 0 0 } ] [ { 0 2 } "doc" get word-elt prev-elt ] unit-test
+[ { 0 0 } ] [ { 0 2 } doc get word-elt prev-elt ] unit-test
-[ { 0 0 } ] [ { 0 5 } "doc" get word-elt prev-elt ] unit-test
+[ { 0 0 } ] [ { 0 5 } doc get word-elt prev-elt ] unit-test
-[ { 0 5 } ] [ { 0 6 } "doc" get word-elt prev-elt ] unit-test
+[ { 0 5 } ] [ { 0 6 } doc get word-elt prev-elt ] unit-test
-[ { 0 6 } ] [ { 0 8 } "doc" get word-elt prev-elt ] unit-test
+[ { 0 6 } ] [ { 0 8 } doc get word-elt prev-elt ] unit-test
-[ { 0 11 } ] [ { 1 0 } "doc" get word-elt prev-elt ] unit-test
+[ { 0 11 } ] [ { 1 0 } doc get word-elt prev-elt ] unit-test
+
+[ { 0 5 } ] [ { 0 0 } doc get word-elt next-elt ] unit-test
+[ { 0 6 } ] [ { 0 5 } doc get word-elt next-elt ] unit-test
+[ { 0 11 } ] [ { 0 6 } doc get word-elt next-elt ] unit-test
+[ { 1 0 } ] [ { 0 11 } doc get word-elt next-elt ] unit-test
 
-[ { 0 5 } ] [ { 0 0 } "doc" get word-elt next-elt ] unit-test
-[ { 0 6 } ] [ { 0 5 } "doc" get word-elt next-elt ] unit-test
-[ { 0 11 } ] [ { 0 6 } "doc" get word-elt next-elt ] unit-test
-[ { 1 0 } ] [ { 0 11 } "doc" get word-elt next-elt ] unit-test
 
 ! one-word-elt
-[ { 0 0 } ] [ { 0 0 } "doc" get one-word-elt prev-elt ] unit-test
+[ { 0 0 } ] [ { 0 0 } doc get one-word-elt prev-elt ] unit-test
-[ { 0 0 } ] [ { 0 2 } "doc" get one-word-elt prev-elt ] unit-test
+[ { 0 0 } ] [ { 0 2 } doc get one-word-elt prev-elt ] unit-test
-[ { 0 0 } ] [ { 0 5 } "doc" get one-word-elt prev-elt ] unit-test
+[ { 0 0 } ] [ { 0 5 } doc get one-word-elt prev-elt ] unit-test
-[ { 0 5 } ] [ { 0 2 } "doc" get one-word-elt next-elt ] unit-test
+[ { 0 5 } ] [ { 0 2 } doc get one-word-elt next-elt ] unit-test
-[ { 0 5 } ] [ { 0 5 } "doc" get one-word-elt next-elt ] unit-test
+[ { 0 5 } ] [ { 0 5 } doc get one-word-elt next-elt ] unit-test
 
 ! line-elt
-<document> "doc" set
+<document> doc set
-"Hello\nworld, how are\nyou?" "doc" get set-doc-string
+"Hello\nworld, how are\nyou?" doc get set-doc-string
 
-[ { 0 0 } ] [ { 0 3 } "doc" get line-elt prev-elt ] unit-test
+[ { 0 0 } ] [ { 0 3 } doc get line-elt prev-elt ] unit-test
-[ { 0 3 } ] [ { 1 3 } "doc" get line-elt prev-elt ] unit-test
+[ { 0 3 } ] [ { 1 3 } doc get line-elt prev-elt ] unit-test
-[ { 2 4 } ] [ { 2 1 } "doc" get line-elt next-elt ] unit-test
+[ { 2 4 } ] [ { 2 1 } doc get line-elt next-elt ] unit-test
 
 ! one-line-elt
-[ { 1 0 } ] [ { 1 3 } "doc" get one-line-elt prev-elt ] unit-test
+[ { 1 0 } ] [ { 1 3 } doc get one-line-elt prev-elt ] unit-test
-[ { 1 14 } ] [ { 1 3 } "doc" get one-line-elt next-elt ] unit-test
+[ { 1 14 } ] [ { 1 3 } doc get one-line-elt next-elt ] unit-test
 
 ! page-elt
-<document> "doc" set
+<document> doc set
 <" First line
 Second line
 Third line
 Fourth line
 Fifth line
-Sixth line"> "doc" get set-doc-string
+Sixth line"> doc get set-doc-string
 
-[ { 0 0 } ] [ { 3 3 } "doc" get 4 <page-elt> prev-elt ] unit-test
+[ { 0 0 } ] [ { 3 3 } doc get 4 <page-elt> prev-elt ] unit-test
-[ { 1 2 } ] [ { 5 2 } "doc" get 4 <page-elt> prev-elt ] unit-test
+[ { 1 2 } ] [ { 5 2 } doc get 4 <page-elt> prev-elt ] unit-test
 
-[ { 4 3 } ] [ { 0 3 } "doc" get 4 <page-elt> next-elt ] unit-test
+[ { 4 3 } ] [ { 0 3 } doc get 4 <page-elt> next-elt ] unit-test
-[ { 5 10 } ] [ { 4 2 } "doc" get 4 <page-elt> next-elt ] unit-test
+[ { 5 10 } ] [ { 4 2 } doc get 4 <page-elt> next-elt ] unit-test
 
 ! doc-elt
-[ { 0 0 } ] [ { 3 4 } "doc" get doc-elt prev-elt ] unit-test
+[ { 0 0 } ] [ { 3 4 } doc get doc-elt prev-elt ] unit-test
-[ { 5 10 } ] [ { 3 4 } "doc" get doc-elt next-elt ] unit-test
+[ { 5 10 } ] [ { 3 4 } doc get doc-elt next-elt ] unit-test

basis/documents/elements/elements.factor

@@ -1,7 +1,7 @@
 ! Copyright (C) 2006, 2009 Slava Pestov.
 ! See http://factorcode.org/license.txt for BSD license.
 USING: arrays combinators documents fry kernel math sequences
-unicode.categories accessors ;
+accessors unicode.categories unicode.breaks combinators.short-circuit ;
 IN: documents.elements
 
 GENERIC: prev-elt ( loc document elt -- newloc )
@@ -20,27 +20,32 @@ SINGLETON: char-elt
 
 <PRIVATE
 
-: (prev-char) ( loc document quot -- loc )
+: prev ( loc document quot: ( loc document -- loc ) -- loc )
     {
         { [ pick { 0 0 } = ] [ 2drop ] }
         { [ pick second zero? ] [ drop [ first 1- ] dip line-end ] }
         [ call ]
     } cond ; inline
 
-: (next-char) ( loc document quot -- loc )
+: next ( loc document quot: ( loc document -- loc ) -- loc )
     {
         { [ 2over doc-end = ] [ 2drop ] }
         { [ 2over line-end? ] [ 2drop first 1+ 0 2array ] }
         [ call ]
     } cond ; inline
 
+: modify-col ( loc document quot: ( col str -- col' ) -- loc )
+    pick [
+        [ [ first2 swap ] dip doc-line ] dip call
+    ] dip =col ; inline
+
 PRIVATE>
 
 M: char-elt prev-elt
-    drop [ drop -1 +col ] (prev-char) ;
+    drop [ [ last-grapheme-from ] modify-col ] prev ;
 
 M: char-elt next-elt
-    drop [ drop 1 +col ] (next-char) ;
+    drop [ [ first-grapheme-from ] modify-col ] next ;
 
 SINGLETON: one-char-elt
 
@@ -50,21 +55,16 @@ M: one-char-elt next-elt 2drop ;
 
 <PRIVATE
 
-: (word-elt) ( loc document quot -- loc )
+: blank-at? ( n seq -- n seq ? )
-    pick [
-        [ [ first2 swap ] dip doc-line ] dip call
-    ] dip =col ; inline
-
-: ((word-elt)) ( n seq -- n seq ? )
     2dup ?nth blank? ;
 
 : break-detector ( ? -- quot )
     '[ blank? _ xor ] ; inline
 
-: (prev-word) ( col str ? -- col )
+: prev-word ( col str ? -- col )
     break-detector find-last-from drop ?1+ ;
 
-: (next-word) ( col str ? -- col )
+: next-word ( col str ? -- col )
     [ break-detector find-from drop ] [ drop length ] 2bi or ;
 
 PRIVATE>
@@ -73,23 +73,23 @@ SINGLETON: one-word-elt
 
 M: one-word-elt prev-elt
     drop
-    [ [ 1- ] dip f (prev-word) ] (word-elt) ;
+    [ [ 1- ] dip f prev-word ] modify-col ;
 
 M: one-word-elt next-elt
     drop
-    [ f (next-word) ] (word-elt) ;
+    [ f next-word ] modify-col ;
 
 SINGLETON: word-elt
 
 M: word-elt prev-elt
     drop
-    [ [ [ 1- ] dip ((word-elt)) (prev-word) ] (word-elt) ]
+    [ [ [ 1- ] dip blank-at? prev-word ] modify-col ]
-    (prev-char) ;
+    prev ;
 
 M: word-elt next-elt
     drop
-    [ [ ((word-elt)) (next-word) ] (word-elt) ]
+    [ [ blank-at? next-word ] modify-col ]
-    (next-char) ;
+    next ;
 
 SINGLETON: one-line-elt
 
@@ -118,4 +118,4 @@ SINGLETON: doc-elt
 
 M: doc-elt prev-elt 3drop { 0 0 } ;
 
-M: doc-elt next-elt drop nip doc-end ;
+M: doc-elt next-elt drop nip doc-end ;

basis/farkup/farkup-tests.factor

@@ -1,7 +1,8 @@
 ! Copyright (C) 2008 Doug Coleman.
 ! See http://factorcode.org/license.txt for BSD license.
 USING: farkup kernel peg peg.ebnf tools.test namespaces xml
-urls.encoding assocs xml.traversal xml.data ;
+urls.encoding assocs xml.traversal xml.data sequences random
+io continuations math ;
 IN: farkup.tests
 
 relative-link-prefix off
@@ -180,3 +181,29 @@ link-no-follow? off
 [ "<p><em>italics<strong>both</strong></em>after<strong></strong></p>" ] [ "_italics*both_after*" convert-farkup ] unit-test
 [ "<table><tr><td>foo|bar</td></tr></table>" ] [ "|foo\\|bar|" convert-farkup ] unit-test
 [ "<p></p>" ] [ "\\" convert-farkup ] unit-test
+
+[ "<p>[abc]</p>" ] [ "[abc]" convert-farkup ] unit-test
+
+: random-markup ( -- string )
+    10 [
+        2 random 1 = [
+            {
+                "[["
+                "*"
+                "_"
+                "|"
+                "-"
+                "[{"
+                "\n"
+            } random
+        ] [
+            "abc"
+        ] if
+    ] replicate concat ;
+
+[ t ] [
+    100 [
+        drop random-markup
+        [ convert-farkup drop t ] [ drop print f ] recover
+    ] all?
+] unit-test

basis/farkup/farkup.factor

@@ -75,7 +75,7 @@ DEFER: (parse-paragraph)
         "|" split1
         [ "" like dup simple-link-title ] unless*
         [ "image:" ?head ] dip swap [ image boa ] [ parse-paragraph link boa ] if
-    ] dip [ (parse-paragraph) cons ] when* ;
+    ] dip [ (parse-paragraph) cons ] [ 1list ] if* ;
 
 : ?first ( seq -- elt ) 0 swap ?nth ;
 
@@ -121,7 +121,7 @@ DEFER: (parse-paragraph)
         ] if
     ] if ;
 
-: take-until ( state delimiter -- string/f state' )
+: take-until ( state delimiter -- string state'/f )
     V{ } clone (take-until) ;
 
 : count= ( string -- n )
@@ -186,10 +186,12 @@ DEFER: (parse-paragraph)
 
 : parse-code ( state -- state' item )
     dup 1 look CHAR: [ =
-    [ unclip-slice make-paragraph ] [
+    [ take-line make-paragraph ] [
-        "{" take-until [ rest ] dip
+        dup "{" take-until [
-        "}]" take-until
+            [ nip rest ] dip
-        [ code boa ] dip swap
+            "}]" take-until
+            [ code boa ] dip swap
+        ] [ drop take-line make-paragraph ] if*
     ] if ;
 
 : parse-item ( state -- state' item )

basis/help/html/html.factor

@@ -60,7 +60,7 @@ M: topic url-of topic>filename ;
 : help>html ( topic -- xml )
     [ article-title ]
     [ drop help-stylesheet ]
-    [ [ help ] with-html-writer ]
+    [ [ print-topic ] with-html-writer ]
     tri simple-page ;
           
 : generate-help-file ( topic -- )

basis/help/tips/tips-docs.factor

@@ -1,6 +1,6 @@
 IN: help.tips
 USING: help.markup help.syntax debugger prettyprint see help help.vocabs
-help.apropos tools.time stack-checker editors ;
+help.apropos tools.time stack-checker editors memory ;
 
 TIP: "To look at the most recent error, run " { $link :error } ". To look at the most recent error's callstack, run " { $link :c } "." ;
 
@@ -20,6 +20,10 @@ TIP: "Power tools: " { $links see edit help about apropos time infer. } ;
 
 TIP: "Tips of the day implement the " { $link "definition-protocol" } " and new tips of the day can be defined using the " { $link POSTPONE: TIP: } " parsing word." ;
 
+TIP: "Try some simple demo applications, then look at the source code in " { $snippet "extra/" } ": " { $snippet "\"demos\" run" } ;
+
+TIP: "To save time on reloading big libraries such as the " { $vocab-link "furnace" } " web framework, save the image after loading them using the " { $link save } " word." ;
+
 HELP: TIP:
 { $syntax "TIP: content ;" }
 { $values { "content" "a markup element" } }

basis/hints/hints.factor

@@ -119,6 +119,6 @@ SYNTAX: HINTS:
 
 \ >be { { bignum fixnum } { fixnum fixnum } } "specializer" set-word-prop
 
-\ hashtable \ at* method { { fixnum hashtable } { word hashtable } } "specializer" set-word-prop
+\ hashtable \ at* method { { fixnum object } { word object } } "specializer" set-word-prop
 
 \ hashtable \ set-at method { { object fixnum object } { object word object } } "specializer" set-word-prop

basis/images/images.factor

@@ -1,11 +1,13 @@
 ! Copyright (C) 2009 Doug Coleman.
 ! See http://factorcode.org/license.txt for BSD license.
-USING: combinators kernel ;
+USING: combinators kernel accessors ;
 IN: images
 
 SINGLETONS: L BGR RGB BGRA RGBA ABGR ARGB RGBX XRGB BGRX XBGR
 R16G16B16 R32G32B32 R16G16B16A16 R32G32B32A32 ;
 
+UNION: alpha-channel BGRA RGBA ABGR ARGB R16G16B16A16 R32G32B32A32 ;
+
 : bytes-per-pixel ( component-order -- n )
     {
         { L [ 1 ] }
@@ -29,4 +31,6 @@ TUPLE: image dim component-order upside-down? bitmap ;
 
 : <image> ( -- image ) image new ; inline
 
+: has-alpha? ( image -- ? ) component-order>> alpha-channel? ;
+
 GENERIC: load-image* ( path tuple -- image )

basis/images/normalization/normalization.factor

@@ -61,6 +61,18 @@ M: ARGB normalize-component-order*
 M: ABGR normalize-component-order*
     drop ARGB>RGBA BGRA>RGBA ;
 
+: fix-XBGR ( bitmap -- bitmap' )
+    dup 4 <sliced-groups> [ [ 255 0 ] dip set-nth ] each ;
+
+M: XBGR normalize-component-order*
+    drop fix-XBGR ABGR normalize-component-order* ;
+
+: fix-BGRX ( bitmap -- bitmap' )
+    dup 4 <sliced-groups> [ [ 255 3 ] dip set-nth ] each ;
+
+M: BGRX normalize-component-order*
+    drop fix-BGRX BGRA normalize-component-order* ;
+
 : normalize-scan-line-order ( image -- image )
     dup upside-down?>> [
         dup dim>> first 4 * '[

basis/io/directories/search/search.factor

@@ -65,9 +65,9 @@ ERROR: file-not-found ;
         _ [ _ _ find-file [ file-not-found ] unless* ] attempt-all
     ] [
         drop f
-    ] recover ;
+    ] recover ; inline
 
 : find-all-in-directories ( directories bfs? quot: ( obj -- ? ) -- paths/f )
-    '[ _ _ find-all-files ] map concat ;
+    '[ _ _ find-all-files ] map concat ; inline
 
 os windows? [ "io.directories.search.windows" require ] when

basis/io/encodings/ascii/ascii.factor

@@ -1,6 +1,6 @@
 ! Copyright (C) 2008 Daniel Ehrenberg.
 ! See http://factorcode.org/license.txt for BSD license.
-USING: io io.encodings kernel math io.encodings.private io.encodings.iana ;
+USING: io io.encodings kernel math io.encodings.private ;
 IN: io.encodings.ascii
 
 <PRIVATE
@@ -19,6 +19,4 @@ M: ascii encode-char
     128 encode-if< ;
 
 M: ascii decode-char
-    128 decode-if< ;
+    128 decode-if< ;
-
-ascii "ANSI_X3.4-1968" register-encoding

basis/io/encodings/iana/iana.factor

@@ -1,7 +1,8 @@
 ! Copyright (C) 2008 Daniel Ehrenberg
 ! See http://factorcode.org/license.txt for BSD license.
 USING: kernel strings values io.files assocs
-splitting sequences io namespaces sets io.encodings.utf8 ;
+splitting sequences io namespaces sets
+io.encodings.ascii io.encodings.utf8 ;
 IN: io.encodings.iana
 
 <PRIVATE
@@ -52,3 +53,5 @@ e>n-table [ initial-e>n ] initialize
             [ n>e-table get-global set-at ] with each
         ] [ "Bad encoding registration" throw ] if*
     ] [ swap e>n-table get-global set-at ] 2bi ;
+
+ascii "ANSI_X3.4-1968" register-encoding

basis/math/blas/config/config-docs.factor

@@ -0,0 +1,23 @@
+USING: alien.fortran help.markup help.syntax math.blas.config multiline ;
+IN: math.blas.config
+
+ARTICLE: "math.blas.config" "Configuring the BLAS interface"
+"The " { $link "math.blas-summary" } " chooses the underlying BLAS interface to use based on the values of the following global variables:"
+{ $subsection blas-library }
+{ $subsection blas-fortran-abi }
+"The interface attempts to set default values based on the ones encountered on the Factor project's build machines. If these settings don't work with your system's BLAS, or you wish to use a commercial BLAS, you may change the global values of those variables in your " { $link "factor-rc" } ". For example, to use AMD's ACML library on Windows with " { $snippet "math.blas" } ", your " { $snippet "factor-rc" } " would look like this:"
+{ $code <"
+USING: math.blas.config namespaces ;
+"X:\\path\\to\\acml.dll" blas-library set-global
+intel-windows-abi blas-fortran-abi set-global
+"> }
+"To take effect, the " { $snippet "blas-library" } " and " { $snippet "blas-fortran-abi" } " variables must be set before any other " { $snippet "math.blas" } " vocabularies are loaded."
+;
+
+HELP: blas-library
+{ $description "The name of the shared library containing the BLAS interface to load. The value of this variable must be a valid shared library name that can be passed to " { $link add-fortran-library } ". To take effect, this variable must be set before any other " { $snippet "math.blas" } " vocabularies are loaded. See " { $link "math.blas.config" } " for details and examples." } ;
+
+HELP: blas-fortran-abi
+{ $description "The Fortran ABI used by the BLAS interface specified in the " { $link blas-library } " variable. The value of " { $snippet "blas-fortran-abi" } " must be one of the " { $link "alien.fortran-abis" } " that can be passed to " { $link add-fortran-library } ". To take effect, this variable must be set before any other " { $snippet "math.blas" } " vocabularies are loaded. See " { $link "math.blas.config" } " for details and examples." } ;
+
+ABOUT: "math.blas.config"

basis/math/blas/config/config.factor

@@ -0,0 +1,23 @@
+USING: alien.fortran combinators kernel namespaces system ;
+IN: math.blas.config
+
+SYMBOLS: blas-library blas-fortran-abi ;
+
+blas-library [
+    {
+        { [ os macosx?  ] [ "libblas.dylib" ] }
+        { [ os windows? ] [ "blas.dll"      ] }
+        [ "libblas.so" ]
+    } cond
+] initialize
+
+blas-fortran-abi [
+    {
+        { [ os macosx?                  ] [ intel-unix-abi ] }
+        { [ os windows? cpu x86.32? and ] [ f2c-abi        ] }
+        { [ os windows? cpu x86.64? and ] [ gfortran-abi   ] }
+        { [ os freebsd?                 ] [ gfortran-abi   ] }
+        { [ os linux?   cpu x86.32? and ] [ gfortran-abi   ] }
+        [ f2c-abi ]
+    } cond
+] initialize

basis/math/blas/ffi/ffi.factor

@@ -1,15 +1,9 @@
-USING: alien alien.fortran kernel system combinators
+USING: alien.fortran kernel math.blas.config namespaces ;
-alien.libraries ;
 IN: math.blas.ffi
 
 <<
-"blas" {
+"blas" blas-library blas-fortran-abi [ get ] bi@
-    { [ os macosx? ] [ "libblas.dylib" intel-unix-abi add-fortran-library ] }
+add-fortran-library
-    { [ os windows? cpu x86.32? and ] [ "blas.dll" f2c-abi add-fortran-library ] }
-    { [ os windows? cpu x86.64? and ] [ "blas.dll" gfortran-abi add-fortran-library ] }
-    { [ os freebsd? ] [ "libblas.so" gfortran-abi add-fortran-library ] }
-    [ "libblas.so" f2c-abi add-fortran-library ]
-} cond
 >>
 
 LIBRARY: blas

basis/math/blas/matrices/matrices-docs.factor

@@ -2,13 +2,14 @@ USING: alien byte-arrays help.markup help.syntax math math.blas.vectors sequence
 IN: math.blas.matrices
 
 ARTICLE: "math.blas-summary" "Basic Linear Algebra Subroutines (BLAS) interface"
-"Factor provides an interface to high-performance vector and matrix math routines available in the system's BLAS library. A set of specialized types are provided for handling packed, unboxed vector data:"
+"Factor provides an interface to high-performance vector and matrix math routines available in implementations of the BLAS math library. A set of specialized types are provided for handling packed, unboxed vector data:"
 { $subsection "math.blas-types" }
 "Scalar-vector and vector-vector operations are available in the " { $vocab-link "math.blas.vectors" } " vocabulary:"
 { $subsection "math.blas.vectors" }
 "Vector-matrix and matrix-matrix operations are available in the " { $vocab-link "math.blas.matrices" } " vocabulary:"
 { $subsection "math.blas.matrices" }
-"The low-level BLAS Fortran interface can be accessed directly through the " { $vocab-link "math.blas.ffi" } " vocabulary." ;
+"The low-level BLAS Fortran interface can be accessed directly through the " { $vocab-link "math.blas.ffi" } " vocabulary. The BLAS interface can be configured to use different underlying BLAS implementations:"
+{ $subsection "math.blas.config" } ;
 
 ARTICLE: "math.blas-types" "BLAS interface types"
 "BLAS vectors come in single- and double-precision, real and complex flavors:"

basis/math/functions/functions-docs.factor

@@ -13,7 +13,8 @@ ARTICLE: "integer-functions" "Integer functions"
 "Tests:"
 { $subsection power-of-2? }
 { $subsection even? }
-{ $subsection odd? } ;
+{ $subsection odd? }
+{ $subsection divisor? } ;
 
 ARTICLE: "arithmetic-functions" "Arithmetic functions"
 "Computing additive and multiplicative inverses:"
@@ -269,6 +270,11 @@ HELP: gcd
 { $description "Computes the positive greatest common divisor " { $snippet "d" } " of " { $snippet "x" } " and " { $snippet "y" } ", and another value " { $snippet "a" } " satisfying:" { $code "a*y = d mod x" } }
 { $notes "If " { $snippet "d" } " is 1, then " { $snippet "a" } " is the inverse of " { $snippet "y" } " modulo " { $snippet "x" } "." } ;
 
+HELP: divisor?
+{ $values { "m" integer } { "n" integer } { "?" "a boolean" } }
+{ $description "Tests if " { $snippet "n" } " is a divisor of " { $snippet "m" } ". This is the same thing as asking if " { $snippet "m" } " is divisible by " { $snippet "n" } "." }
+{ $notes "Returns t for both negative and positive divisors, as well as for trivial and non-trivial divisors." } ;
+
 HELP: mod-inv
 { $values { "x" integer } { "n" integer } { "y" integer } }
 { $description "Outputs an integer " { $snippet "y" } " such that " { $snippet "xy = 1 (mod n)" } "." }

basis/math/functions/functions-tests.factor

@@ -32,13 +32,13 @@ IN: math.functions.tests
 
 [ 1.0 ] [ 0 cosh ] unit-test
 [ 0.0 ] [ 1 acosh ] unit-test
-            
+
 [ 1.0 ] [ 0 cos ] unit-test
 [ 0.0 ] [ 1 acos ] unit-test
-            
+
 [ 0.0 ] [ 0 sinh ] unit-test
 [ 0.0 ] [ 0 asinh ] unit-test
-            
+
 [ 0.0 ] [ 0 sin ] unit-test
 [ 0.0 ] [ 0 asin ] unit-test
 
@@ -97,11 +97,17 @@ IN: math.functions.tests
 
 : verify-gcd ( a b -- ? )
     2dup gcd
-    [ rot * swap rem ] dip = ; 
+    [ rot * swap rem ] dip = ;
 
 [ t ] [ 123 124 verify-gcd ] unit-test
 [ t ] [ 50 120 verify-gcd ] unit-test
 
+[ t ] [ 0 42 divisor? ] unit-test
+[ t ] [ 42 7 divisor? ] unit-test
+[ t ] [ 42 -7 divisor? ] unit-test
+[ t ] [ 42 42 divisor? ] unit-test
+[ f ] [ 42 16 divisor? ] unit-test
+
 [ 3 ] [ 5 7 mod-inv ] unit-test
 [ 78572682077 ] [ 234829342 342389423843 mod-inv ] unit-test
 
@@ -150,4 +156,4 @@ IN: math.functions.tests
     1067811677921310779
     2135623355842621559
     [ >bignum ] tri@ ^mod
-] unit-test
+] unit-test

basis/math/functions/functions.factor

@@ -111,6 +111,9 @@ PRIVATE>
 : lcm ( a b -- c )
     [ * ] 2keep gcd nip /i ; foldable
 
+: divisor? ( m n -- ? )
+    mod 0 = ;
+
 : mod-inv ( x n -- y )
     [ nip ] [ gcd 1 = ] 2bi
     [ dup 0 < [ + ] [ nip ] if ]
@@ -198,7 +201,7 @@ M: real sin fsin ;
 
 GENERIC: sinh ( x -- y ) foldable
 
-M: complex sinh 
+M: complex sinh
     >float-rect
     [ [ fsinh ] [ fcos ] bi* * ]
     [ [ fcosh ] [ fsin ] bi* * ] 2bi rect> ;

basis/math/primes/factors/factors.factor

@@ -1,6 +1,6 @@
 ! Copyright (C) 2007-2009 Samuel Tardieu.
 ! See http://factorcode.org/license.txt for BSD license.
-USING: arrays combinators kernel make math math.primes sequences ;
+USING: arrays combinators kernel make math math.functions math.primes sequences ;
 IN: math.primes.factors
 
 <PRIVATE
@@ -11,7 +11,7 @@ IN: math.primes.factors
     swap ;
 
 : write-factor ( n d -- n' d' )
-    2dup mod zero? [
+    2dup divisor? [
         [ [ count-factor ] keep swap 2array , ] keep
         ! If the remainder is a prime number, increase d so that
         ! the caller stops looking for factors.

basis/models/models-docs.factor

@@ -5,12 +5,13 @@ IN: models
 HELP: model
 { $class-description "A mutable cell holding a single value. When the value is changed, a sequence of connected objects are notified. Models have the following slots:"
     { $list
-        { { $snippet "value" } " - the value of the model. Use " { $link set-model } " to change the value." }
+        { { $slot "value" } " - the value of the model. Use " { $link set-model } " to change the value." }
-        { { $snippet "connections" } " - a sequence of objects implementing the " { $link model-changed } " generic word, to be notified when the model's value changes." }
+        { { $slot "connections" } " - a sequence of objects implementing the " { $link model-changed } " generic word, to be notified when the model's value changes." }
-        { { $snippet "dependencies" } " - a sequence of models which should have this model added to their sequence of connections when activated." }
+        { { $slot "dependencies" } " - a sequence of models which should have this model added to their sequence of connections when activated." }
-        { { $snippet "ref" } " - a reference count tracking the number of models which depend on this one." }
+        { { $slot "ref" } " - a reference count tracking the number of models which depend on this one." }
+        { { $slot "locked?" } " - a slot set by " { $link with-locked-model } " to ensure that the model doesn't get changed recursively" }
     }
-"Other classes may delegate to " { $link model } "."
+"Other classes may inherit from " { $link model } "."
 } ;
 
 HELP: <model>
@@ -132,7 +133,6 @@ $nl
 { $subsection "models-impl" }
 { $subsection "models.arrow" }
 { $subsection "models.product" }
-{ $subsection "models-history" }
 { $subsection "models-range" }
 { $subsection "models-delay" } ;
 

basis/opengl/opengl-docs.factor

@@ -15,8 +15,8 @@ HELP: do-enabled
 { $description "Wraps a quotation in " { $link glEnable } "/" { $link glDisable } " calls." } ;
 
 HELP: do-matrix
-{ $values { "mode" { $link GL_MODELVIEW } " or " { $link GL_PROJECTION } } { "quot" quotation } }
+{ $values { "quot" quotation } }
-{ $description "Saves and restores the matrix specified by " { $snippet "mode" } " before and after calling the quotation." } ;
+{ $description "Saves and restores the current matrix before and after calling the quotation." } ;
 
 HELP: gl-line
 { $values { "a" "a pair of integers" } { "b" "a pair of integers" } }

basis/opengl/opengl.factor

@@ -44,9 +44,8 @@ MACRO: all-enabled ( seq quot -- )
 MACRO: all-enabled-client-state ( seq quot -- )
     [ words>values ] dip '[ _ _ (all-enabled-client-state) ] ;
 
-: do-matrix ( mode quot -- )
+: do-matrix ( quot -- )
-    swap [ glMatrixMode glPushMatrix call ] keep
+    glPushMatrix call glPopMatrix ; inline
-    glMatrixMode glPopMatrix ; inline
 
 : gl-material ( face pname params -- )
     float-array{ } like glMaterialfv ;
@@ -165,7 +164,7 @@ MACRO: set-draw-buffers ( buffers -- )
 : delete-dlist ( id -- ) 1 glDeleteLists ;
 
 : with-translation ( loc quot -- )
-    GL_MODELVIEW [ [ gl-translate ] dip call ] do-matrix ; inline
+    [ [ gl-translate ] dip call ] do-matrix ; inline
 
 : fix-coordinates ( point1 point2 -- x1 y2 x2 y2 )
     [ first2 [ >fixnum ] bi@ ] bi@ ;
@@ -177,6 +176,7 @@ MACRO: set-draw-buffers ( buffers -- )
     fix-coordinates glViewport ;
 
 : init-matrices ( -- )
+    #! Leaves with matrix mode GL_MODELVIEW
     GL_PROJECTION glMatrixMode
     glLoadIdentity
     GL_MODELVIEW glMatrixMode

basis/opengl/textures/textures-tests.factor

@@ -5,56 +5,6 @@ opengl.textures.private images kernel namespaces accessors
 sequences ;
 IN: opengl.textures.tests
 
-[ ] [
-    T{ image
-       { dim { 3 5 } }
-       { component-order RGB }
-       { bitmap
-         B{
-             1 2 3 4 5 6 7 8 9
-             10 11 12 13 14 15 16 17 18
-             19 20 21 22 23 24 25 26 27
-             28 29 30 31 32 33 34 35 36
-             37 38 39 40 41 42 43 44 45
-         }
-       }
-    } "image" set
-] unit-test
-
-[
-    T{ image
-        { dim { 4 8 } }
-        { component-order RGB }
-        { bitmap
-          B{
-              1 2 3 4 5 6 7 8 9 7 8 9
-              10 11 12 13 14 15 16 17 18 16 17 18
-              19 20 21 22 23 24 25 26 27 25 26 27
-              28 29 30 31 32 33 34 35 36 34 35 36
-              37 38 39 40 41 42 43 44 45 43 44 45
-              37 38 39 40 41 42 43 44 45 43 44 45
-              37 38 39 40 41 42 43 44 45 43 44 45
-              37 38 39 40 41 42 43 44 45 43 44 45
-          }
-        }
-    }
-] [
-    "image" get power-of-2-image
-] unit-test
-
-[
-    T{ image
-       { dim { 0 0 } }
-       { component-order R32G32B32 }
-       { bitmap B{ } } }
-] [
-    T{ image
-       { dim { 0 0 } }
-       { component-order R32G32B32 }
-       { bitmap B{ } }
-    } power-of-2-image
-] unit-test
-
 [
     {
         { { 0 0 } { 10 0 } }

basis/opengl/textures/textures.factor

@@ -2,8 +2,8 @@
 ! See http://factorcode.org/license.txt for BSD license.
 USING: accessors assocs cache colors.constants destructors fry kernel
 opengl opengl.gl combinators images images.tesselation grouping
-specialized-arrays.float locals sequences math math.vectors
+specialized-arrays.float sequences math math.vectors
-math.matrices generalizations fry columns ;
+math.matrices generalizations fry arrays ;
 IN: opengl.textures
 
 : gen-texture ( -- id ) [ glGenTextures ] (gen-gl-object) ;
@@ -17,60 +17,42 @@ M: BGR component-order>format drop GL_BGR GL_UNSIGNED_BYTE ;
 M: RGBA component-order>format drop GL_RGBA GL_UNSIGNED_BYTE ;
 M: ARGB component-order>format drop GL_BGRA_EXT GL_UNSIGNED_INT_8_8_8_8_REV ;
 M: BGRA component-order>format drop GL_BGRA_EXT GL_UNSIGNED_BYTE ;
+M: BGRX component-order>format drop GL_BGRA_EXT GL_UNSIGNED_BYTE ;
 
-GENERIC: draw-texture ( texture -- )
+SLOT: display-list
+
+: draw-texture ( texture -- ) display-list>> [ glCallList ] when* ;
 
 GENERIC: draw-scaled-texture ( dim texture -- )
 
 <PRIVATE
 
-TUPLE: single-texture loc dim texture-coords texture display-list disposed ;
+TUPLE: single-texture image dim loc texture-coords texture display-list disposed ;
 
-: repeat-last ( seq n -- seq' )
+: (tex-image) ( image -- )
-    over peek pad-tail concat ;
+    [ GL_TEXTURE_2D 0 GL_RGBA ] dip
+    [ dim>> first2 [ next-power-of-2 ] bi@ 0 ]
+    [ component-order>> component-order>format f ] bi
+    glTexImage2D ;
 
-: power-of-2-bitmap ( rows dim size -- bitmap dim )
+: (tex-sub-image) ( image -- )
-    '[
+    [ GL_TEXTURE_2D 0 0 0 ] dip
-        first2
+    [ dim>> first2 ] [ component-order>> component-order>format ] [ bitmap>> ] tri
-        [ [ _ ] dip '[ _ group _ repeat-last ] map ]
+    glTexSubImage2D ;
-        [ repeat-last ]
-        bi*
-    ] keep ;
 
-: image-rows ( image -- rows )
+: make-texture ( image -- id )
-    [ bitmap>> ]
+    #! We use glTexSubImage2D to work around the power of 2 texture size
-    [ dim>> first ]
+    #! limitation
-    [ component-order>> bytes-per-pixel ]
-    tri * group ; inline
-
-: power-of-2-image ( image -- image )
-    dup dim>> [ 0 = ] all? [
-        clone dup
-        [ image-rows ]
-        [ dim>> [ next-power-of-2 ] map ]
-        [ component-order>> bytes-per-pixel ] tri
-        power-of-2-bitmap
-        [ >>bitmap ] [ >>dim ] bi*
-    ] unless ;
-
-:: make-texture ( image -- id )
     gen-texture [
         GL_TEXTURE_BIT [
             GL_TEXTURE_2D swap glBindTexture
-            GL_TEXTURE_2D
+            [ (tex-image) ] [ (tex-sub-image) ] bi
-            0
-            GL_RGBA
-            image dim>> first2
-            0
-            image component-order>> component-order>format
-            image bitmap>>
-            glTexImage2D
         ] do-attribs
     ] keep ;
 
 : init-texture ( -- )
-    GL_TEXTURE_2D GL_TEXTURE_MAG_FILTER GL_LINEAR glTexParameteri
+    GL_TEXTURE_2D GL_TEXTURE_MAG_FILTER GL_NEAREST glTexParameteri
-    GL_TEXTURE_2D GL_TEXTURE_MIN_FILTER GL_LINEAR glTexParameteri
+    GL_TEXTURE_2D GL_TEXTURE_MIN_FILTER GL_NEAREST glTexParameteri
     GL_TEXTURE_2D GL_TEXTURE_WRAP_S GL_REPEAT glTexParameteri
     GL_TEXTURE_2D GL_TEXTURE_WRAP_T GL_REPEAT glTexParameteri ;
 
@@ -92,26 +74,29 @@ TUPLE: single-texture loc dim texture-coords texture display-list disposed ;
 
 : draw-textured-rect ( dim texture -- )
     [
-        (draw-textured-rect)
+        [ image>> has-alpha? [ GL_BLEND glDisable ] unless ]
-        GL_TEXTURE_2D 0 glBindTexture
+        [ (draw-textured-rect) GL_TEXTURE_2D 0 glBindTexture ]
+        [ image>> has-alpha? [ GL_BLEND glEnable ] unless ]
+        tri
     ] with-texturing ;
 
-: texture-coords ( dim -- coords )
+: texture-coords ( texture -- coords )
-    [ dup next-power-of-2 /f ] map
+    [ [ dim>> ] [ image>> dim>> [ next-power-of-2 ] map ] bi v/ ]
-    { { 0 0 } { 1 0 } { 1 1 } { 0 1 } } [ v* ] with map
+    [
-    float-array{ } join ;
+        image>> upside-down?>>
+        { { 0 1 } { 1 1 } { 1 0 } { 0 0 } }
+        { { 0 0 } { 1 0 } { 1 1 } { 0 1 } } ?
+    ] bi
+    [ v* ] with map float-array{ } join ;
 
 : make-texture-display-list ( texture -- dlist )
     GL_COMPILE [ [ dim>> ] keep draw-textured-rect ] make-dlist ;
 
 : <single-texture> ( image loc -- texture )
-   single-texture new swap >>loc
+    single-texture new swap >>loc swap [ >>image ] [ dim>> >>dim ] bi
-    swap
+    dup image>> dim>> product 0 = [
-    [ dim>> >>dim ] keep
+        dup texture-coords >>texture-coords
-    [ dim>> product 0 = ] keep '[
+        dup image>> make-texture >>texture
-        _
-        [ dim>> texture-coords >>texture-coords ]
-        [ power-of-2-image make-texture >>texture ] bi
         dup make-texture-display-list >>display-list
     ] unless ;
 
@@ -119,15 +104,13 @@ M: single-texture dispose*
     [ texture>> [ delete-texture ] when* ]
     [ display-list>> [ delete-dlist ] when* ] bi ;
 
-M: single-texture draw-texture display-list>> [ glCallList ] when* ;
-
 M: single-texture draw-scaled-texture
     dup texture>> [ draw-textured-rect ] [ 2drop ] if ;
 
 TUPLE: multi-texture grid display-list loc disposed ;
 
 : image-locs ( image-grid -- loc-grid )
-    [ first [ dim>> first ] map ] [ 0 <column> [ dim>> second ] map ] bi
+    [ first [ dim>> first ] map ] [ [ first dim>> second ] map ] bi
     [ 0 [ + ] accumulate nip ] bi@
     cross-zip flip ;
 
@@ -138,14 +121,15 @@ TUPLE: multi-texture grid display-list loc disposed ;
 : draw-textured-grid ( grid -- )
     [ [ [ dim>> ] keep (draw-textured-rect) ] each ] each ;
 
+: grid-has-alpha? ( grid -- ? )
+    first first image>> has-alpha? ;
+
 : make-textured-grid-display-list ( grid -- dlist )
     GL_COMPILE [
         [
-            [
+            [ grid-has-alpha? [ GL_BLEND glDisable ] unless ]
-                [
+            [ [ [ [ dim>> ] keep (draw-textured-rect) ] each ] each ]
-                    [ dim>> ] keep (draw-textured-rect)
+            [ grid-has-alpha? [ GL_BLEND glEnable ] unless ] tri
-                ] each
-            ] each
             GL_TEXTURE_2D 0 glBindTexture
         ] with-texturing
     ] make-dlist ;
@@ -159,11 +143,9 @@ TUPLE: multi-texture grid display-list loc disposed ;
         f multi-texture boa
     ] with-destructors ;
 
-M: multi-texture draw-texture display-list>> [ glCallList ] when* ;
-
 M: multi-texture dispose* grid>> [ [ dispose ] each ] each ;
 
-CONSTANT: max-texture-size { 256 256 }
+CONSTANT: max-texture-size { 512 512 }
 
 PRIVATE>
 

basis/pack/pack.factor

@@ -2,7 +2,7 @@
 ! See http://factorcode.org/license.txt for BSD license.
 USING: alien alien.c-types arrays assocs byte-arrays io
 io.binary io.streams.string kernel math math.parser namespaces
-make parser prettyprint quotations sequences strings vectors
+make parser quotations sequences strings vectors
 words macros math.functions math.bitwise fry generalizations
 combinators.smart io.streams.byte-array io.encodings.binary
 math.vectors combinators multiline endian ;

basis/peg/ebnf/ebnf-tests.factor

@@ -3,7 +3,7 @@
 !
 USING: kernel tools.test peg peg.ebnf words math math.parser 
        sequences accessors peg.parsers parser namespaces arrays 
-       strings eval ;
+       strings eval unicode.data multiline ;
 IN: peg.ebnf.tests
 
 { T{ ebnf-non-terminal f "abc" } } [
@@ -520,3 +520,13 @@ Tok                = Spaces (Number | Special )
 { "\\" } [
   "\\" [EBNF foo="\\" EBNF]
 ] unit-test
+
+[ "USE: peg.ebnf [EBNF EBNF]" eval ] must-fail
+
+[ <" USE: peg.ebnf [EBNF
+    lol = a
+    lol = b
+  EBNF] "> eval
+] [
+    error>> [ redefined-rule? ] [ name>> "lol" = ] bi and
+] must-fail-with

basis/peg/ebnf/ebnf.factor

@@ -5,13 +5,18 @@ sequences quotations vectors namespaces make math assocs
 continuations peg peg.parsers unicode.categories multiline
 splitting accessors effects sequences.deep peg.search
 combinators.short-circuit lexer io.streams.string stack-checker
-io combinators parser ;
+io combinators parser summary ;
 IN: peg.ebnf
 
 : rule ( name word -- parser )
   #! Given an EBNF word produced from EBNF: return the EBNF rule
   "ebnf-parser" word-prop at ;
 
+ERROR: no-rule rule parser ;
+
+: lookup-rule ( rule parser -- rule' )
+    2dup rule [ 2nip ] [ no-rule ] if* ; 
+
 TUPLE: tokenizer any one many ;
 
 : default-tokenizer ( -- tokenizer )
@@ -34,8 +39,13 @@ TUPLE: tokenizer any one many ;
 : reset-tokenizer ( -- )
   default-tokenizer \ tokenizer set-global ;
 
+ERROR: no-tokenizer name ;
+
+M: no-tokenizer summary
+    drop "Tokenizer not found" ;
+
 SYNTAX: TOKENIZER: 
-  scan search [ "Tokenizer not found" throw ] unless*
+  scan dup search [ nip ] [ no-tokenizer ] if*
   execute( -- tokenizer ) \ tokenizer set-global ;
 
 TUPLE: ebnf-non-terminal symbol ;
@@ -258,7 +268,7 @@ DEFER: 'choice'
     "]]" token ensure-not ,
     "]?" token ensure-not ,
     [ drop t ] satisfy ,
-  ] seq* [ first ] action repeat0 [ >string ] action ;
+  ] seq* repeat0 [ concat >string ] action ;
 
 : 'ensure-not' ( -- parser )
   #! Parses the '!' syntax to ensure that 
@@ -367,15 +377,16 @@ M: ebnf-tokenizer (transform) ( ast -- parser )
   (transform) 
   dup parser-tokenizer \ tokenizer set-global
   ] if ;
+
+ERROR: redefined-rule name ;
+
+M: redefined-rule summary
+  name>> "Rule '" "' defined more than once" surround ;
   
 M: ebnf-rule (transform) ( ast -- parser )
   dup elements>> 
   (transform) [
-    swap symbol>> dup get parser? [ 
+    swap symbol>> dup get parser? [ redefined-rule ] [ set ] if
-      "Rule '" over append "' defined more than once" append throw 
-    ] [ 
-      set 
-    ] if
   ] keep ;
 
 M: ebnf-sequence (transform) ( ast -- parser )
@@ -466,14 +477,18 @@ ERROR: bad-effect quot effect ;
     { [ dup (( -- b )) effect<= ] [ drop [ drop ] prepose ] }
     [ bad-effect ]
   } cond ;
+
+: ebnf-transform ( ast -- parser quot )
+  [ parser>> (transform) ]
+  [ code>> insert-escapes ]
+  [ parser>> ] tri build-locals  
+  [ string-lines parse-lines ] call( string -- quot ) ;
  
 M: ebnf-action (transform) ( ast -- parser )
-  [ parser>> (transform) ] [ code>> insert-escapes ] [ parser>> ] tri build-locals  
+  ebnf-transform check-action-effect action ;
-  [ string-lines parse-lines ] call( string -- quot ) check-action-effect action ;
 
 M: ebnf-semantic (transform) ( ast -- parser )
-  [ parser>> (transform) ] [ code>> insert-escapes ] [ parser>> ] tri build-locals 
+  ebnf-transform semantic ;
-  [ string-lines parse-lines ] call( string -- quot ) semantic ;
 
 M: ebnf-var (transform) ( ast -- parser )
   parser>> (transform) ;
@@ -481,19 +496,20 @@ M: ebnf-var (transform) ( ast -- parser )
 M: ebnf-terminal (transform) ( ast -- parser )
   symbol>> tokenizer one>> call( symbol -- parser ) ;
 
+ERROR: ebnf-foreign-not-found name ;
+
+M: ebnf-foreign-not-found summary
+  name>> "Foreign word '" "' not found" surround ;
+
 M: ebnf-foreign (transform) ( ast -- parser )
-  dup word>> search
+  dup word>> search [ word>> ebnf-foreign-not-found ] unless*
-  [ "Foreign word '" swap word>> append "' not found" append throw ] unless*
   swap rule>> [ main ] unless* over rule [
     nip
   ] [
     execute( -- parser )
   ] if* ;
 
-: parser-not-found ( name -- * )
+ERROR: parser-not-found name ;
-  [
-    "Parser '" % % "' not found." %
-  ] "" make throw ;
 
 M: ebnf-non-terminal (transform) ( ast -- parser )
   symbol>>  [
@@ -504,16 +520,16 @@ M: ebnf-non-terminal (transform) ( ast -- parser )
   'ebnf' parse transform ;
 
 : check-parse-result ( result -- result )
-  dup [
+  [
-    dup remaining>> [ blank? ] trim empty? [
+    dup remaining>> [ blank? ] trim [
       [ 
         "Unable to fully parse EBNF. Left to parse was: " %
         remaining>> % 
       ] "" make throw
-    ] unless
+    ] unless-empty
   ] [
     "Could not parse EBNF" throw
-  ] if ;
+  ] if* ;
 
 : parse-ebnf ( string -- hashtable )
   'ebnf' (parse) check-parse-result ast>> transform ;
@@ -522,14 +538,18 @@ M: ebnf-non-terminal (transform) ( ast -- parser )
   parse-ebnf dup dup parser [ main swap at compile ] with-variable
   [ compiled-parse ] curry [ with-scope ast>> ] curry ;
 
-SYNTAX: <EBNF "EBNF>" reset-tokenizer parse-multiline-string parse-ebnf main swap at  
+SYNTAX: <EBNF
+  "EBNF>"
+  reset-tokenizer parse-multiline-string parse-ebnf main swap at  
   parsed reset-tokenizer ;
 
-SYNTAX: [EBNF "EBNF]" reset-tokenizer parse-multiline-string ebnf>quot nip 
+SYNTAX: [EBNF
+  "EBNF]"
+  reset-tokenizer parse-multiline-string ebnf>quot nip 
   parsed \ call parsed reset-tokenizer ;
 
 SYNTAX: EBNF: 
   reset-tokenizer CREATE-WORD dup ";EBNF" parse-multiline-string  
-  ebnf>quot swapd (( input -- ast )) define-declared "ebnf-parser" set-word-prop 
+  ebnf>quot swapd
+  (( input -- ast )) define-declared "ebnf-parser" set-word-prop 
   reset-tokenizer ;
-

basis/peg/peg.factor

@@ -155,18 +155,21 @@ TUPLE: peg-head rule-id involved-set eval-set ;
   dup pos>> pos set ans>>
   ; inline
 
-:: (setup-lr) ( r l s -- )
+:: (setup-lr) ( l s -- )
-  s head>> l head>> eq? [
+  s [ 
-    l head>> s (>>head)
+    s left-recursion? [ s throw ] unless
-    l head>> [ s rule-id>> suffix ] change-involved-set drop
+    s head>> l head>> eq? [
-    r l s next>> (setup-lr)
+      l head>> s (>>head)
-  ] unless ;
+      l head>> [ s rule-id>> suffix ] change-involved-set drop
+      l s next>> (setup-lr)
+    ] unless 
+  ] when ;
 
 :: setup-lr ( r l -- )
   l head>> [
     r rule-id V{ } clone V{ } clone peg-head boa l (>>head)
   ] unless
-  r l lrstack get (setup-lr) ;
+  l lrstack get (setup-lr) ;
 
 :: lr-answer ( r p m -- ast )
   [let* |
@@ -216,8 +219,10 @@ TUPLE: peg-head rule-id involved-set eval-set ;
     lrstack get next>> lrstack set
     pos get m (>>pos)
     lr head>> [
-      ans lr (>>seed)
+      m ans>> left-recursion? [
-      r p m lr-answer
+        ans lr (>>seed)
+        r p m lr-answer
+     ] [ ans ] if 
     ] [
       ans m (>>ans)
       ans

basis/quoting/quoting-tests.factor

@@ -0,0 +1,11 @@
+! Copyright (C) 2009 Doug Coleman.
+! See http://factorcode.org/license.txt for BSD license.
+USING: tools.test quoting ;
+IN: quoting.tests
+
+[ f ] [ "" quoted? ] unit-test
+[ t ] [ "''" quoted? ] unit-test
+[ t ] [ "\"\"" quoted? ] unit-test
+[ t ] [ "\"Circus Maximus\"" quoted? ] unit-test
+[ t ] [ "'Circus Maximus'" quoted? ] unit-test
+[ f ] [ "Circus Maximus" quoted? ] unit-test

basis/regexp/compiler/compiler.factor

@@ -84,21 +84,24 @@ C: <box> box
     { } assoc-like [ first integer? ] partition
     [ [ literals>cases ] keep ] dip non-literals>dispatch ;
 
-:: step ( last-match index str quot final? direction -- last-index/f )
+: advance ( index backwards? -- index+/-1 )
+    -1 1 ? + >fixnum ; inline
+
+: check ( index string backwards? -- in-bounds? )
+    [ drop -1 eq? not ] [ length < ] if ; inline
+
+:: step ( last-match index str quot final? backwards? -- last-index/f )
     final? index last-match ?
-    index str bounds-check? [
+    index str backwards? check [
-        index direction + str
+        index backwards? advance str
         index str nth-unsafe
         quot call
     ] when ; inline
 
-: direction ( -- n )
-    backwards? get -1 1 ? ;
-
 : transitions>quot ( transitions final-state? -- quot )
     dup shortest? get and [ 2drop [ drop nip ] ] [
-        [ split-literals swap case>quot ] dip direction
+        [ split-literals swap case>quot ] dip backwards? get
-        '[ { array-capacity string } declare _ _ _ step ]
+        '[ { fixnum string } declare _ _ _ step ]
     ] if ;
 
 : word>quot ( word dfa -- quot )
@@ -122,10 +125,13 @@ C: <box> box
 : dfa>main-word ( dfa -- word )
     states>words [ states>code ] keep start-state>> ;
 
+: word-template ( quot -- quot' )
+    '[ drop [ f ] 2dip over array-capacity? _ [ 2drop ] if ] ;
+
 PRIVATE>
 
 : dfa>word ( dfa -- quot )
-    dfa>main-word execution-quot '[ drop [ f ] 2dip @ ]
+    dfa>main-word execution-quot word-template
     (( start-index string regexp -- i/f )) define-temp ;
 
 : dfa>shortest-word ( dfa -- word )

basis/roman/roman.factor

@@ -51,7 +51,7 @@ PRIVATE>
 <PRIVATE
 
 MACRO: binary-roman-op ( quot -- quot' )
-    dup infer [ in>> swap ] [ out>> ] bi
+    [ infer in>> ] [ ] [ infer out>> ] tri
     '[ [ roman> ] _ napply @ [ >roman ] _ napply ] ;
 
 PRIVATE>

basis/see/see-tests.factor

@@ -0,0 +1,11 @@
+IN: see.tests
+USING: see tools.test io.streams.string math ;
+
+CONSTANT: test-const 10
+[ "IN: see.tests\nCONSTANT: test-const 10 inline\n" ]
+[ [ \ test-const see ] with-string-writer ] unit-test
+
+ALIAS: test-alias +
+
+[ "USING: math ;\nIN: see.tests\nALIAS: test-alias + inline\n" ]
+[ [ \ test-alias see ] with-string-writer ] unit-test

basis/see/see.factor

@@ -7,7 +7,7 @@ definitions effects generic generic.standard io io.pathnames
 io.streams.string io.styles kernel make namespaces prettyprint
 prettyprint.backend prettyprint.config prettyprint.custom
 prettyprint.sections sequences sets sorting strings summary
-words words.symbol ;
+words words.symbol words.constant words.alias ;
 IN: see
 
 GENERIC: synopsis* ( defspec -- )
@@ -29,8 +29,16 @@ GENERIC: see* ( defspec -- )
 : comment. ( text -- )
     H{ { font-style italic } } styled-text ;
 
+GENERIC: print-stack-effect? ( word -- ? )
+
+M: parsing-word print-stack-effect? drop f ;
+M: symbol print-stack-effect? drop f ;
+M: constant print-stack-effect? drop f ;
+M: alias print-stack-effect? drop f ;
+M: word print-stack-effect? drop t ;
+
 : stack-effect. ( word -- )
-    [ [ parsing-word? ] [ symbol? ] bi or not ] [ stack-effect ] bi and
+    [ print-stack-effect? ] [ stack-effect ] bi and
     [ effect>string comment. ] when* ;
 
 <PRIVATE

basis/sorting/functor/functor.factor

@@ -0,0 +1,16 @@
+! Copyright (C) 2009 Doug Coleman.
+! See http://factorcode.org/license.txt for BSD license.
+USING: functors kernel math.order sequences sorting ;
+IN: sorting.functor
+
+FUNCTOR: define-sorting ( NAME QUOT -- )
+
+NAME<=> DEFINES ${NAME}<=>
+NAME>=< DEFINES ${NAME}>=<
+
+WHERE
+
+: NAME<=> ( obj1 obj2 -- <=> ) QUOT bi@ <=> ;
+: NAME>=< ( obj1 obj2 -- >=< ) NAME<=> invert-comparison ;
+
+;FUNCTOR

basis/sorting/human/human-docs.factor

@@ -25,46 +25,11 @@ HELP: human>=<
 }
 { $description "Compares two objects using the " { $link human<=> } " word and inverts the result." } ;
 
-HELP: human-compare
-{ $values
-     { "obj1" object } { "obj2" object } { "quot" quotation }
-     { "<=>" "an ordering specifier" }
-}
-{ $description "Compares the results of applying the quotation to both objects via <=>." } ;
-
-HELP: human-sort
-{ $values
-     { "seq" sequence }
-     { "seq'" sequence }
-}
-{ $description "Sorts a sequence of objects by comparing the magnitude of any integers in the input string using the <=> word." } ;
-
-HELP: human-sort-keys
-{ $values
-     { "seq" "an alist" }
-     { "sortedseq" "a new sorted sequence" }
-}
-{ $description "Sorts the elements comparing first elements of pairs using the " { $link human<=> } " word." } ;
-
-HELP: human-sort-values
-{ $values
-     { "seq" "an alist" }
-     { "sortedseq" "a new sorted sequence" }
-}
-{ $description "Sorts the elements comparing second elements of pairs using the " { $link human<=> } " word." } ;
-
-{ <=> >=< human-compare human-sort human-sort-keys human-sort-values } related-words
-
 ARTICLE: "sorting.human" "Human-friendly sorting"
 "The " { $vocab-link "sorting.human" } " vocabulary sorts by numbers as a human would -- by comparing their magnitudes -- rather than in a lexicographic way. For example, sorting a1, a10, a03, a2 with human sort returns a1, a2, a03, a10, while sorting with natural sort returns a03, a1, a10, a2." $nl
 "Comparing two objects:"
 { $subsection human<=> }
 { $subsection human>=< }
-{ $subsection human-compare }
-"Sort a sequence:"
-{ $subsection human-sort }
-{ $subsection human-sort-keys }
-{ $subsection human-sort-values }
 "Splitting a string into substrings and integers:"
 { $subsection find-numbers } ;
 

basis/sorting/human/human-tests.factor

@@ -1,6 +1,4 @@
-USING: sorting.human tools.test ;
+USING: sorting.human tools.test sorting.slots ;
 IN: sorting.human.tests
 
-\ human-sort must-infer
+[ { "x1y" "x2" "x10y" } ] [ { "x1y" "x10y" "x2" } { human<=> } sort-by ] unit-test
-
-[ { "x1y" "x2" "x10y" } ] [ { "x1y" "x10y" "x2" } human-sort ] unit-test

basis/sorting/human/human.factor

@@ -1,22 +1,9 @@
 ! Copyright (C) 2008 Doug Coleman, Slava Pestov.
 ! See http://factorcode.org/license.txt for BSD license.
-USING: peg.ebnf math.parser kernel assocs sorting fry
+USING: math.parser peg.ebnf sorting.functor ;
-math.order sequences ascii splitting.monotonic ;
 IN: sorting.human
 
 : find-numbers ( string -- seq )
     [EBNF Result = ([0-9]+ => [[ string>number ]] | (!([0-9]) .)+)* EBNF] ;
 
-: human<=> ( obj1 obj2 -- <=> ) [ find-numbers ] bi@ <=> ;
+<< "human" [ find-numbers ] define-sorting >>
-
-: human>=< ( obj1 obj2 -- >=< ) human<=> invert-comparison ; inline
-
-: human-compare ( obj1 obj2 quot -- <=> ) bi@ human<=> ;
-
-: human-sort ( seq -- seq' ) [ human<=> ] sort ;
-
-: human-sort-keys ( seq -- sortedseq )
-    [ [ first ] human-compare ] sort ;
-
-: human-sort-values ( seq -- sortedseq )
-    [ [ second ] human-compare ] sort ;

basis/sorting/slots/slots-docs.factor

@@ -14,7 +14,7 @@ HELP: compare-slots
 HELP: sort-by-slots
 { $values
      { "seq" sequence } { "sort-specs" "a sequence of accessors ending with a comparator" }
-     { "seq'" sequence }
+     { "sortedseq" sequence }
 }
 { $description "Sorts a sequence of tuples by the sort-specs in " { $snippet "sort-spec" } ". A sort-spec is a sequence of slot accessors ending in a comparator." }
 { $examples
@@ -39,11 +39,20 @@ HELP: split-by-slots
 }
 { $description "Splits a sequence of tuples into a sequence of slices of tuples that have the same values in all slots in the accessor sequence. This word is only useful for splitting a sorted sequence, but is more efficient than partitioning in such a case." } ;
 
+HELP: sort-by
+{ $values
+    { "seq" sequence } { "sort-seq" "a sequence of comparators" }
+    { "sortedseq" sequence }
+}
+{ $description "Sorts a sequence by comparing elements by comparators, using subsequent comparators when there is a tie." } ;
+
 ARTICLE: "sorting.slots" "Sorting by slots"
 "The " { $vocab-link "sorting.slots" } " vocabulary can sort tuples by slot in ascending or descending order, using subsequent slots as tie-breakers." $nl
 "Comparing two objects by a sequence of slots:"
 { $subsection compare-slots }
-"Sorting a sequence by a sequence of slots:"
+"Sorting a sequence of tuples by a slot/comparator pairs:"
-{ $subsection sort-by-slots } ;
+{ $subsection sort-by-slots }
+"Sorting a sequence by a sequence of comparators:"
+{ $subsection sort-by } ;
 
 ABOUT: "sorting.slots"

basis/sorting/slots/slots-tests.factor

@@ -1,7 +1,8 @@
 ! Copyright (C) 2009 Doug Coleman.
 ! See http://factorcode.org/license.txt for BSD license.
 USING: accessors math.order sorting.slots tools.test
-sorting.human arrays sequences kernel assocs multiline ;
+sorting.human arrays sequences kernel assocs multiline
+sorting.functor ;
 IN: sorting.literals.tests
 
 TUPLE: sort-test a b c tuple2 ;
@@ -76,6 +77,9 @@ TUPLE: tuple2 d ;
 [ { } ]
 [ { } { { a>> <=> } { b>> >=< } { c>> <=> } } sort-by-slots ] unit-test
 
+[ { } ]
+[ { } { } sort-by-slots ] unit-test
+
 [
     {
         T{ sort-test { a 6 } { tuple2 T{ tuple2 { d 1 } } } }
@@ -143,3 +147,15 @@ TUPLE: tuple2 d ;
         T{ sort-test { a 5 } { tuple2 T{ tuple2 { d 4 } } } }
     } { { tuple2>> d>> } { a>> } } split-by-slots [ >array ] map
 ] unit-test
+
+
+[ { "a" "b" "c" } ] [ { "b" "c" "a" } { <=> <=> } sort-by ] unit-test
+[ { "b" "c" "a" } ] [ { "b" "c" "a" } { } sort-by ] unit-test
+
+<< "length-test" [ length ] define-sorting >>
+
+[ { { 1 } { 1 2 3 } { 1 3 2 } { 3 2 1 } } ]
+[
+    { { 3 2 1 } { 1 2 3 } { 1 3 2 } { 1 } }
+    { length-test<=> <=> } sort-by
+] unit-test

basis/sorting/slots/slots.factor

@@ -7,13 +7,16 @@ IN: sorting.slots
 
 <PRIVATE
 
+: short-circuit-comparator ( obj1 obj2 word --  comparator/? )
+    execute dup +eq+ eq? [ drop f ] when ; inline
+
 : slot-comparator ( seq -- quot )
     [
         but-last-slice
         [ '[ [ _ execute ] bi@ ] ] map concat
     ] [
         peek
-        '[ @ _ execute dup +eq+ eq? [ drop f ] when ]
+        '[ @ _ short-circuit-comparator ]
     ] bi ;
 
 PRIVATE>
@@ -22,8 +25,20 @@ MACRO: compare-slots ( sort-specs -- <=> )
     #! sort-spec: { accessors comparator }
     [ slot-comparator ] map '[ _ 2|| +eq+ or ] ;
 
-: sort-by-slots ( seq sort-specs -- seq' )
+MACRO: sort-by-slots ( sort-specs -- quot )
-    '[ _ compare-slots ] sort ;
+    '[ [ _ compare-slots ] sort ] ;
+
+MACRO: compare-seq ( seq -- quot )
+    [ '[ _ short-circuit-comparator ] ] map '[ _ 2|| +eq+ or ] ;
+
+MACRO: sort-by ( sort-seq -- quot )
+    '[ [ _ compare-seq ] sort ] ;
+
+MACRO: sort-keys-by ( sort-seq -- quot )
+    '[ [ first ] bi@ _ compare-seq ] sort ;
+
+MACRO: sort-values-by ( sort-seq -- quot )
+    '[ [ second ] bi@ _ compare-seq ] sort ;
 
 MACRO: split-by-slots ( accessor-seqs -- quot )
     [ [ '[ [ _ execute ] bi@ ] ] map concat [ = ] compose ] map

basis/sorting/title/authors.txt

@@ -0,0 +1 @@
+Doug Coleman

basis/sorting/title/title-tests.factor

@@ -0,0 +1,40 @@
+! Copyright (C) 2009 Doug Coleman.
+! See http://factorcode.org/license.txt for BSD license.
+USING: tools.test sorting.title sorting.slots ;
+IN: sorting.title.tests
+
+: sort-me ( -- seq )
+    {
+        "The Beatles"
+        "A river runs through it"
+        "Another"
+        "la vida loca"
+        "Basketball"
+        "racquetball"
+        "Los Fujis"
+        "los Fujis"
+        "La cucaracha"
+        "a day to remember"
+        "of mice and men"
+        "on belay"
+        "for the horde"
+    } ;
+[
+    {
+        "Another"
+        "Basketball"
+        "The Beatles"
+        "La cucaracha"
+        "a day to remember"
+        "for the horde"
+        "Los Fujis"
+        "los Fujis"
+        "of mice and men"
+        "on belay"
+        "racquetball"
+        "A river runs through it"
+        "la vida loca"
+    }
+] [
+    sort-me { title<=> } sort-by
+] unit-test

basis/sorting/title/title.factor

@@ -0,0 +1,7 @@
+! Copyright (C) 2009 Doug Coleman.
+! See http://factorcode.org/license.txt for BSD license.
+USING: sorting.functor regexp kernel accessors sequences
+unicode.case ;
+IN: sorting.title
+
+<< "title" [ >lower dup R/ ^(the|a|an|el|la|los|las|il) / first-match [ to>> tail-slice ] when* ] define-sorting >>

basis/stack-checker/known-words/known-words.factor

@@ -605,6 +605,8 @@ M: object infer-call*
 
 \ fflush { alien } { } define-primitive
 
+\ fseek { alien integer integer } { } define-primitive
+
 \ fclose { alien } { } define-primitive
 
 \ <wrapper> { object } { wrapper } define-primitive

basis/syndication/syndication-docs.factor

@@ -35,9 +35,9 @@ HELP: download-feed
 { $values { "url" url } { "feed" feed } }
 { $description "Downloads a feed from a URL using the " { $link "http.client" } "." } ;
 
-HELP: string>feed
+HELP: parse-feed
-{ $values { "string" string } { "feed" feed } }
+{ $values { "seq" "a string or a byte array" } { "feed" feed } }
-{ $description "Parses a feed in string form." } ;
+{ $description "Parses a feed." } ;
 
 HELP: xml>feed
 { $values { "xml" xml } { "feed" feed } }
@@ -58,7 +58,7 @@ $nl
 { $subsection <entry> }
 "Reading feeds:"
 { $subsection download-feed }
-{ $subsection string>feed }
+{ $subsection parse-feed }
 { $subsection xml>feed }
 "Writing feeds:"
 { $subsection feed>xml }

basis/syndication/syndication-tests.factor

@@ -1,4 +1,4 @@
-USING: syndication io kernel io.files tools.test io.encodings.utf8
+USING: syndication io kernel io.files tools.test io.encodings.binary
 calendar urls xml.writer ;
 IN: syndication.tests
 
@@ -8,7 +8,7 @@ IN: syndication.tests
 : load-news-file ( filename -- feed )
     #! Load an news syndication file and process it, returning
     #! it as an feed tuple.
-    utf8 file-contents string>feed ;
+    binary file-contents parse-feed ;
 
 [ T{
     feed

basis/syndication/syndication.factor

@@ -1,11 +1,11 @@
 ! Copyright (C) 2006 Chris Double, Daniel Ehrenberg.
-! Portions copyright (C) 2008 Slava Pestov.
+! Portions copyright (C) 2008, 2009 Slava Pestov.
 ! See http://factorcode.org/license.txt for BSD license.
-USING: xml.traversal kernel assocs math.order
+USING: xml.traversal kernel assocs math.order strings sequences
-    strings sequences xml.data xml.writer
+xml.data xml.writer io.streams.string combinators xml
-    io.streams.string combinators xml xml.entities.html io.files io
+xml.entities.html io.files io http.client namespaces make
-    http.client namespaces make xml.syntax hashtables
+xml.syntax hashtables calendar.format accessors continuations
-    calendar.format accessors continuations urls present ;
+urls present byte-arrays ;
 IN: syndication
 
 : any-tag-named ( tag names -- tag-inside )
@@ -106,12 +106,15 @@ TUPLE: entry title url description date ;
         { "feed" [ atom1.0 ] }
     } case ;
 
-: string>feed ( string -- feed )
+GENERIC: parse-feed ( seq -- feed )
-    [ string>xml xml>feed ] with-html-entities ;
+
+M: string parse-feed [ string>xml xml>feed ] with-html-entities ;
+
+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 string>feed ;
+    http-get nip parse-feed ;
 
 ! Atom generation
 

basis/tools/deploy/macosx/macosx.factor

@@ -42,11 +42,12 @@ IN: tools.deploy.macosx
 
 : create-app-dir ( vocab bundle-name -- vm )
     [
-        nip
+        nip {
-        [ copy-dll ]
+            [ copy-dll ]
-        [ copy-nib ]
+            [ copy-nib ]
-        [ "Contents/Resources" append-path make-directories ]
+            [ "Contents/Resources" append-path make-directories ]
-        tri
+            [ "Contents/Resources" copy-theme ]
+        } cleave
     ]
     [ create-app-plist ]
     [ "Contents/MacOS/" append-path copy-vm ] 2tri

basis/tools/deploy/shaker/shaker.factor

@@ -157,6 +157,8 @@ IN: tools.deploy.shaker
                 "specializer"
                 "step-into"
                 "step-into?"
+                ! UI needs this
+                ! "superclass"
                 "transform-n"
                 "transform-quot"
                 "tuple-dispatch-generic"
@@ -275,7 +277,6 @@ IN: tools.deploy.shaker
                 lexer-factory
                 print-use-hook
                 root-cache
-                vocab-roots
                 vocabs:dictionary
                 vocabs:load-vocab-hook
                 word

basis/tools/deploy/windows/windows.factor

@@ -9,11 +9,6 @@ IN: tools.deploy.windows
 : copy-dll ( bundle-name -- )
     "resource:factor.dll" swap copy-file-into ;
 
-: copy-pango ( bundle-name -- )
-    "resource:build-support/dlls.txt" ascii file-lines
-    [ "resource:" prepend-path ] map
-    swap copy-files-into ;
-
 :: copy-vm ( executable bundle-name extension -- vm )
     vm "." split1-last drop extension append
     bundle-name executable ".exe" append append-path
@@ -22,9 +17,7 @@ IN: tools.deploy.windows
 : create-exe-dir ( vocab bundle-name -- vm )
     dup copy-dll
     deploy-ui? get [
-        [ copy-pango ]
+        [ "" copy-theme ] [ ".exe" copy-vm ] bi
-        [ "" copy-theme ]
-        [ ".exe" copy-vm ] tri
     ] [ ".com" copy-vm ] if ;
 
 M: winnt deploy*

basis/tools/scaffold/scaffold-tests.factor

@@ -0,0 +1,21 @@
+! Copyright (C) 2009 Doug Coleman.
+! See http://factorcode.org/license.txt for BSD license.
+USING: tools.test tools.scaffold unicode.case kernel
+multiline tools.scaffold.private io.streams.string ;
+IN: tools.scaffold.tests
+
+: undocumented-word ( obj1 obj2 -- obj3 obj4 )
+    [ >lower ] [ >upper ] bi* ;
+
+[
+<" HELP: undocumented-word
+{ $values
+    { "obj1" object } { "obj2" object }
+    { "obj3" object } { "obj4" object }
+}
+{ $description "" } ;
+">
+]
+[
+    [ \ undocumented-word (help.) ] with-string-writer
+] unit-test

basis/tools/scaffold/scaffold.factor

@@ -134,7 +134,7 @@ ERROR: no-vocab vocab ;
     vocabulary>> using get [ conjoin ] [ drop ] if* ;
 
 : ($values.) ( array -- )
-    [
+    [ bl ] [
         "{ " write
         dup array? [ first ] when
         dup lookup-type [
@@ -145,7 +145,7 @@ ERROR: no-vocab vocab ;
             null add-using
         ] if
         " }" write
-    ] each ;
+    ] interleave ;
 
 : 4bl ( -- )
     "    " write ; inline

basis/ui/backend/backend.factor

@@ -29,6 +29,6 @@ HOOK: offscreen-pixels ui-backend ( world -- alien w h )
 
 : with-gl-context ( handle quot -- )
     swap [ select-gl-context call ] keep
-    glFlush flush-gl-context gl-error ; inline
+    flush-gl-context gl-error ; inline
 
 HOOK: (with-ui) ui-backend ( quot -- )

basis/ui/backend/windows/windows.factor

@@ -1,16 +1,16 @@
 ! Copyright (C) 2005, 2006 Doug Coleman.
 ! Portions copyright (C) 2007, 2009 Slava Pestov.
 ! See http://factorcode.org/license.txt for BSD license.
-USING: alien alien.c-types alien.strings arrays assocs ui
+USING: alien alien.c-types alien.strings arrays assocs ui ui.private
-ui.private ui.gadgets ui.gadgets.private ui.backend
+ui.gadgets ui.gadgets.private ui.backend ui.clipboards
-ui.clipboards ui.gadgets.worlds ui.gestures ui.event-loop io
+ui.gadgets.worlds ui.gestures ui.event-loop io kernel math
-kernel math math.vectors namespaces make sequences strings
+math.vectors namespaces make sequences strings vectors words
-vectors words windows.kernel32 windows.gdi32 windows.user32
+windows.kernel32 windows.gdi32 windows.user32 windows.opengl32
-windows.opengl32 windows.messages windows.types windows.nt
+windows.messages windows.types windows.offscreen windows.nt windows
-windows threads libc combinators fry combinators.short-circuit
+threads libc combinators fry combinators.short-circuit continuations
-continuations command-line shuffle opengl ui.render ascii
+command-line shuffle opengl ui.render ascii math.bitwise locals
-math.bitwise locals accessors math.rectangles math.order ascii
+accessors math.rectangles math.order ascii calendar
-calendar io.encodings.utf16n ;
+io.encodings.utf16n ;
 IN: ui.backend.windows
 
 SINGLETON: windows-ui-backend
@@ -433,12 +433,7 @@ M: windows-ui-backend do-events
     style 0 ex-style AdjustWindowRectEx win32-error=0/f ;
 
 : make-RECT ( world -- RECT )
-    [ window-loc>> dup ] [ dim>> ] bi v+
+    [ window-loc>> ] [ dim>> ] bi <RECT> ;
-    "RECT" <c-object>
-    over first over set-RECT-right
-    swap second over set-RECT-bottom
-    over first over set-RECT-left
-    swap second over set-RECT-top ;
 
 : default-position-RECT ( RECT -- )
     dup get-RECT-dimensions [ 2drop ] 2dip
@@ -501,35 +496,12 @@ M: windows-ui-backend (open-window) ( world -- )
     hWnd>> show-window ;
 
 M: win-base select-gl-context ( handle -- )
-    [ hDC>> ] keep hRC>> wglMakeCurrent win32-error=0/f
+    [ hDC>> ] [ hRC>> ] bi wglMakeCurrent win32-error=0/f
     GdiFlush drop ;
 
 M: win-base flush-gl-context ( handle -- )
     hDC>> SwapBuffers win32-error=0/f ;
 
-: (bitmap-info) ( dim -- BITMAPINFO )
-    "BITMAPINFO" <c-object> [
-        BITMAPINFO-bmiHeader {
-            [ nip "BITMAPINFOHEADER" heap-size swap set-BITMAPINFOHEADER-biSize ]
-            [ [ first ] dip set-BITMAPINFOHEADER-biWidth ]
-            [ [ second ] dip set-BITMAPINFOHEADER-biHeight ]
-            [ nip 1 swap set-BITMAPINFOHEADER-biPlanes ]
-            [ nip 32 swap set-BITMAPINFOHEADER-biBitCount ]
-            [ nip BI_RGB swap set-BITMAPINFOHEADER-biCompression ]
-            [ [ first2 * 4 * ] dip set-BITMAPINFOHEADER-biSizeImage ]
-            [ nip 72 swap set-BITMAPINFOHEADER-biXPelsPerMeter ]
-            [ nip 72 swap set-BITMAPINFOHEADER-biYPelsPerMeter ]
-            [ nip 0 swap set-BITMAPINFOHEADER-biClrUsed ]
-            [ nip 0 swap set-BITMAPINFOHEADER-biClrImportant ]
-        } 2cleave
-    ] keep ;
-
-: make-offscreen-dc-and-bitmap ( dim -- hDC hBitmap bits )
-    f CreateCompatibleDC
-    dup rot (bitmap-info) DIB_RGB_COLORS f <void*>
-    [ f 0 CreateDIBSection ] keep *void*
-    [ 2dup SelectObject drop ] dip ;
-
 : setup-offscreen-gl ( dim -- hDC hRC hBitmap bits )
     make-offscreen-dc-and-bitmap [
         [ dup offscreen-pfd-dwFlags setup-pixel-format ]
@@ -548,13 +520,12 @@ M: windows-ui-backend (close-offscreen-buffer) ( handle -- )
 ! each pixel; it's left as zero
 
 : (make-opaque) ( byte-array -- byte-array' )
-    [ length 4 / ]
+    [ length 4 /i ]
     [ '[ 255 swap 4 * 3 + _ set-nth ] each ]
     [ ] tri ;
 
 : (opaque-pixels) ( world -- pixels )
-    [ handle>> bits>> ] [ dim>> first2 * 4 * ] bi
+    [ handle>> bits>> ] [ dim>> ] bi bitmap>byte-array (make-opaque) ;
-    memory>byte-array (make-opaque) ;
 
 M: windows-ui-backend offscreen-pixels ( world -- alien w h )
     [ (opaque-pixels) ] [ dim>> first2 ] bi ;

basis/ui/gadgets/editors/editors.factor

@@ -141,7 +141,7 @@ M: editor ungraft*
 : scroll>caret ( editor -- )
     dup graft-state>> second [
         [
-            [ caret-loc ] [ caret-dim { 1 0 } v+ ] bi <rect>
+            [ caret-loc ] [ caret-dim { 2 1 } v+ ] bi <rect>
         ] keep scroll>rect
     ] [ drop ] if ;
 

basis/ui/gadgets/gadgets.factor

@@ -11,6 +11,7 @@ CONSTANT: horizontal { 1 0 }
 CONSTANT: vertical { 0 1 }
 
 TUPLE: gadget < rect
+id
 pref-dim
 parent
 children
@@ -28,7 +29,7 @@ model ;
 
 M: gadget equal? 2drop f ;
 
-M: gadget hashcode* drop gadget hashcode* ;
+M: gadget hashcode* nip [ [ \ gadget counter ] unless* ] change-id id>> ;
 
 M: gadget model-changed 2drop ;
 

basis/ui/gadgets/line-support/line-support.factor

@@ -30,6 +30,9 @@ M: line-gadget line-height font>> font-metrics height>> ceiling ;
 : validate-line ( m gadget -- n )
     control-value [ drop f ] [ length 1- min 0 max ] if-empty ;
 
+: valid-line? ( n gadget -- ? )
+    control-value length 1- 0 swap between? ;
+
 : visible-line ( gadget quot -- n )
     '[
         [ clip get @ origin get [ second ] bi@ - ] dip

basis/ui/gadgets/panes/panes.factor

@@ -49,13 +49,13 @@ M: pane-stream stream-element-type drop +character+ ;
 : pane-caret&mark ( pane -- caret mark )
     [ caret>> ] [ mark>> ] bi ; inline
 
-: selected-children ( pane -- seq )
+: selected-subtree ( pane -- seq )
     [ pane-caret&mark sort-pair ] keep gadget-subtree ;
 
 M: pane gadget-selection? pane-caret&mark and ;
 
 M: pane gadget-selection ( pane -- string/f )
-    selected-children gadget-text ;
+    selected-subtree gadget-text ;
 
 : init-prototype ( pane -- pane )
     <shelf> +baseline+ >>align >>prototype ; inline
@@ -72,31 +72,12 @@ M: pane gadget-selection ( pane -- string/f )
     [ >>last-line ] [ 1 track-add ] bi
     dup prepare-last-line ; inline
 
-GENERIC: draw-selection ( loc obj -- )
+M: pane selected-children
-
-: if-fits ( rect quot -- )
-    [ clip get over contains-rect? ] dip [ drop ] if ; inline
-
-M: gadget draw-selection ( loc gadget -- )
-    swap offset-rect [
-        rect-bounds gl-fill-rect
-    ] if-fits ;
-
-M: node draw-selection ( loc node -- )
-    2dup value>> swap offset-rect [
-        drop 2dup
-        [ value>> loc>> v+ ] keep
-        children>> [ draw-selection ] with each
-    ] if-fits 2drop ;
-
-M: pane draw-gadget*
     dup gadget-selection? [
-        [ selection-color>> gl-color ]
+        [ selected-subtree leaves ]
-        [
+        [ selection-color>> ]
-            [ loc>> vneg ] keep selected-children
+        bi
-            [ draw-selection ] with each
+    ] [ drop f f ] if ;
-        ] bi
-    ] [ drop ] if ;
 
 : scroll-pane ( pane -- )
     dup scrolls?>> [ scroll>bottom ] [ drop ] if ;

basis/ui/gadgets/scrollers/scrollers-docs.factor

@@ -11,11 +11,11 @@ HELP: find-scroller
 { $values { "gadget" gadget } { "scroller/f" { $maybe scroller } } }
 { $description "Finds the first parent of " { $snippet "gadget" } " which is a " { $link scroller } ". Outputs " { $link f } " if the gadget is not contained in a " { $link scroller } "." } ;
 
-HELP: scroller-value
+HELP: scroll-position
 { $values { "scroller" scroller } { "loc" "a pair of integers" } }
 { $description "Outputs the offset of the top-left corner of the scroller's " { $link viewport } "'s child." } ;
 
-{ scroller-value scroll scroll>bottom scroll>top scroll>rect } related-words
+{ scroll-position set-scroll-position scroll>bottom scroll>top scroll>rect } related-words
 
 HELP: <scroller>
 { $values { "gadget" gadget } { "scroller" "a new " { $link scroller } } }
@@ -23,7 +23,7 @@ HELP: <scroller>
 
 { <viewport> <scroller> } related-words
 
-HELP: scroll
+HELP: set-scroll-position
 { $values { "scroller" scroller } { "value" "a pair of integers" } }
 { $description "Sets the offset of the top-left corner of the scroller's " { $link viewport } "'s child." } ;
 
@@ -48,8 +48,8 @@ ARTICLE: "ui.gadgets.scrollers" "Scroller gadgets"
 { $subsection scroller }
 { $subsection <scroller> }
 "Getting and setting the scroll position:"
-{ $subsection scroller-value }
+{ $subsection scroll-position }
-{ $subsection scroll }
+{ $subsection set-scroll-position }
 "Writing scrolling-aware gadgets:"
 { $subsection scroll>bottom }
 { $subsection scroll>top }

basis/ui/gadgets/scrollers/scrollers-tests.factor

@@ -45,13 +45,13 @@ IN: ui.gadgets.scrollers.tests
 
     [ { 100 100 } ] [ "s" get viewport>> gadget-child pref-dim ] unit-test
 
-    [ ] [ { 0 0 } "s" get scroll ] unit-test
+    [ ] [ { 0 0 } "s" get set-scroll-position ] unit-test
 
     [ { 0 0 } ] [ "s" get model>> range-min-value ] unit-test
 
     [ { 100 100 } ] [ "s" get model>> range-max-value ] unit-test
 
-    [ ] [ { 10 20 } "s" get scroll ] unit-test
+    [ ] [ { 10 20 } "s" get set-scroll-position ] unit-test
 
     [ { 10 20 } ] [ "s" get model>> range-value ] unit-test
 
@@ -74,7 +74,7 @@ dup layout
         drop
         "g2" get scroll>gadget
         "s" get layout
-        "s" get scroller-value
+        "s" get scroll-position
     ] map [ { 0 0 } = ] all?
 ] unit-test
 

basis/ui/gadgets/scrollers/scrollers.factor

@@ -29,6 +29,13 @@ M: gadget viewport-column-header drop f ;
 
 : scroll-down-line ( scroller -- ) y>> 1 swap slide-by-line ;
 
+: set-scroll-position ( value scroller -- )
+    [
+        viewport>> [ dim>> { 0 0 } ] [ gadget-child pref-dim ] bi
+        4array flip
+    ] keep
+    2dup control-value = [ 2drop ] [ set-control-value ] if ;
+
 <PRIVATE
 
 : do-mouse-scroll ( scroller -- )
@@ -46,21 +53,14 @@ scroller H{
 
 M: viewport pref-dim* gadget-child pref-viewport-dim ;
 
-: scroll ( value scroller -- )
-    [
-        viewport>> [ dim>> { 0 0 } ] [ gadget-child pref-dim ] bi
-        4array flip
-    ] keep
-    2dup control-value = [ 2drop ] [ set-control-value ] if ;
-
 : (scroll>rect) ( rect scroller -- )
-    [ [ loc>> ] [ dim>> { 1 1 } v+ ] bi <rect> ] dip
     {
-        [ scroller-value vneg offset-rect ]
+        [ scroll-position vneg offset-rect ]
         [ viewport>> dim>> rect-min ]
+        [ viewport>> loc>> offset-rect ]
         [ viewport>> [ v- { 0 0 } vmin ] [ v- { 0 0 } vmax ] with-rect-extents v+ ]
-        [ scroller-value v+ ]
+        [ scroll-position v+ ]
-        [ scroll ]
+        [ set-scroll-position ]
     } cleave ;
 
 : relative-scroll-rect ( rect gadget scroller -- newrect )
@@ -72,7 +72,7 @@ M: viewport pref-dim* gadget-child pref-viewport-dim ;
     2&& ;
 
 : (update-scroller) ( scroller -- )
-    [ scroller-value ] keep scroll ;
+    [ scroll-position ] keep set-scroll-position ;
 
 : (scroll>gadget) ( gadget scroller -- )
     2dup swap child? [
@@ -82,7 +82,8 @@ M: viewport pref-dim* gadget-child pref-viewport-dim ;
     ] [ f >>follows (update-scroller) drop ] if ;
 
 : (scroll>bottom) ( scroller -- )
-    [ viewport>> gadget-child pref-dim { 0 1 } v* ] keep scroll ;
+    [ viewport>> gadget-child pref-dim { 0 1 } v* ] keep
+    set-scroll-position ;
 
 GENERIC: update-scroller ( scroller follows -- )
 

basis/ui/gadgets/search-tables/search-tables-tests.factor

@@ -0,0 +1,3 @@
+IN: ui.gadgets.search-tables.tests
+USING: ui.gadgets.search-tables sequences tools.test ;
+[ [ second ] <search-table> ] must-infer

basis/ui/gadgets/search-tables/search-tables.factor

@@ -28,6 +28,7 @@ TUPLE: search-field < track field ;
 
 : <search-field> ( model -- gadget )
     horizontal search-field new-track
+        0 >>fill
         { 5 5 } >>gap
         +baseline+ >>align
         swap <model-field> 10 >>min-cols >>field

basis/ui/gadgets/tables/tables.factor

@@ -268,12 +268,13 @@ M: table model-changed
 : mouse-row ( table -- n )
     [ hand-rel second ] keep y>line ;
 
+: if-mouse-row ( table true: ( table mouse-index -- ) false: ( table -- ) -- )
+    [ [ mouse-row ] keep 2dup valid-line? ]
+    [ ] [ '[ nip @ ] ] tri* if ; inline
+
 : table-button-down ( table -- )
     dup takes-focus?>> [ dup request-focus ] when
-    dup control-value empty? [ drop ] [
+    [ swap [ >>mouse-index ] [ (select-row) ] bi ] [ drop ] if-mouse-row ;
-        dup [ mouse-row ] keep validate-line
-        [ >>mouse-index ] [ (select-row) ] bi
-    ] if ;
 
 PRIVATE>
 
@@ -283,11 +284,14 @@ PRIVATE>
     [ 2drop ]
     if ;
 
+: row-action? ( table -- ? )
+    [ [ mouse-row ] keep valid-line? ]
+    [ single-click?>> hand-click# get 2 = or ] bi and ;
+
 <PRIVATE
 
 : table-button-up ( table -- )
-    dup single-click?>> hand-click# get 2 = or
+    dup row-action? [ row-action ] [ update-selected-value ] if ;
-    [ row-action ] [ update-selected-value ] if ;
 
 : select-row ( table n -- )
     over validate-line
@@ -320,13 +324,6 @@ PRIVATE>
 : next-page ( table -- )
     1 prev/next-page ;
 
-: valid-row? ( row table -- ? )
-    control-value length 1- 0 swap between? ;
-
-: if-mouse-row ( table true false -- )
-    [ [ mouse-row ] keep 2dup valid-row? ]
-    [ ] [ '[ nip @ ] ] tri* if ; inline
-
 : show-mouse-help ( table -- )
     [
         swap

basis/ui/gadgets/viewports/viewports.factor

@@ -23,7 +23,7 @@ M: viewport layout*
 M: viewport focusable-child*
     gadget-child ;
 
-: scroller-value ( scroller -- loc )
+: scroll-position ( scroller -- loc )
     model>> range-value [ >integer ] map ;
 
 M: viewport model-changed
@@ -31,7 +31,7 @@ M: viewport model-changed
     [ relayout-1 ]
     [
         [ gadget-child ]
-        [ scroller-value vneg ]
+        [ scroll-position vneg ]
         [ constraint>> ]
         tri v* >>loc drop
     ] bi ;

basis/ui/gadgets/worlds/worlds.factor

@@ -3,8 +3,7 @@
 USING: accessors arrays assocs continuations kernel math models
 namespaces opengl sequences io combinators combinators.short-circuit
 fry math.vectors math.rectangles cache ui.gadgets ui.gestures
-ui.render ui.text ui.text.private ui.backend ui.gadgets.tracks
+ui.render ui.backend ui.gadgets.tracks ui.commands ;
-ui.commands ;
 IN: ui.gadgets.worlds
 
 TUPLE: world < track
@@ -53,7 +52,6 @@ M: world request-focus-on ( child gadget -- )
         swap >>status
         swap >>title
         swap 1 track-add
-    dup init-text-rendering
     dup request-focus ;
 
 : <world> ( gadget title status -- world )
@@ -74,15 +72,20 @@ M: world remove-gadget
     2dup layers>> memq?
     [ layers>> delq ] [ call-next-method ] if ;
 
+SYMBOL: flush-layout-cache-hook
+
+flush-layout-cache-hook [ [ ] ] initialize
+
 : (draw-world) ( world -- )
     dup handle>> [
         {
             [ init-gl ]
             [ draw-gadget ]
-            [ finish-text-rendering ]
+            [ text-handle>> [ purge-cache ] when* ]
             [ images>> [ purge-cache ] when* ]
         } cleave
-    ] with-gl-context ;
+    ] with-gl-context
+    flush-layout-cache-hook get call( -- ) ;
 
 : draw-world? ( world -- ? )
     #! We don't draw deactivated worlds, or those with 0 size.

basis/ui/render/render.factor

@@ -1,7 +1,7 @@
 ! Copyright (C) 2005, 2009 Slava Pestov.
 ! See http://factorcode.org/license.txt for BSD license.
 USING: math.rectangles math.vectors namespaces kernel accessors
-combinators sequences opengl opengl.gl opengl.glu colors
+assocs combinators sequences opengl opengl.gl opengl.glu colors
 colors.constants ui.gadgets ui.pens ;
 IN: ui.render
 
@@ -55,21 +55,57 @@ SYMBOL: origin
 
 GENERIC: draw-children ( gadget -- )
 
+! For gadget selection
+SYMBOL: selected-gadgets
+
+SYMBOL: selection-background
+
+GENERIC: selected-children ( gadget -- assoc/f selection-background )
+
+M: gadget selected-children drop f f ;
+
+! For text rendering
+SYMBOL: background
+
+SYMBOL: foreground
+
+GENERIC: gadget-background ( gadget -- color )
+
+M: gadget gadget-background dup interior>> pen-background ;
+
+GENERIC: gadget-foreground ( gadget -- color )
+
+M: gadget gadget-foreground dup interior>> pen-foreground ;
+
+<PRIVATE
+
+: draw-selection-background ( gadget -- )
+    selection-background get background set
+    selection-background get gl-color
+    [ { 0 0 } ] dip dim>> gl-fill-rect ;
+
+: draw-standard-background ( object -- )
+    dup interior>> dup [ draw-interior ] [ 2drop ] if ;
+
+: draw-background ( gadget -- )
+    origin get [
+        [
+            dup selected-gadgets get key?
+            [ draw-selection-background ]
+            [ draw-standard-background ] if
+        ] [ draw-gadget* ] bi
+    ] with-translation ;
+
+: draw-border ( object -- )
+    dup boundary>> dup [
+        origin get [ draw-boundary ] with-translation
+    ] [ 2drop ] if ;
+
+PRIVATE>
+
 : (draw-gadget) ( gadget -- )
     dup loc>> origin get v+ origin [
-        [
+        [ draw-background ] [ draw-children ] [ draw-border ] tri
-            origin get [
-                [ dup interior>> dup [ draw-interior ] [ 2drop ] if ]
-                [ draw-gadget* ]
-                bi
-            ] with-translation
-        ]
-        [ draw-children ]
-        [
-            dup boundary>> dup [
-                origin get [ draw-boundary ] with-translation
-            ] [ 2drop ] if
-        ] tri
     ] with-variable ;
 
 : >absolute ( rect -- rect )
@@ -88,27 +124,24 @@ GENERIC: draw-children ( gadget -- )
         [ [ (draw-gadget) ] with-clipping ]
     } cond ;
 
-! For text rendering
-SYMBOL: background
-
-SYMBOL: foreground
-
-GENERIC: gadget-background ( gadget -- color )
-
-M: gadget gadget-background dup interior>> pen-background ;
-
-GENERIC: gadget-foreground ( gadget -- color )
-
-M: gadget gadget-foreground dup interior>> pen-foreground ;
-
 M: gadget draw-children
-    [ visible-children ]
+    dup children>> [
-    [ gadget-background ]
+        {
-    [ gadget-foreground ] tri [
+            [ visible-children ]
-        [ foreground set ] when*
+            [ selected-children ]
-        [ background set ] when*
+            [ gadget-background ]
-        [ draw-gadget ] each
+            [ gadget-foreground ]
-    ] with-scope ;
+        } cleave [
+            
+            {
+                [ [ selected-gadgets set ] when* ]
+                [ [ selection-background set ] when* ]
+                [ [ background set ] when* ]
+                [ [ foreground set ] when* ]
+            } spread
+            [ draw-gadget ] each
+        ] with-scope
+    ] [ drop ] if ;
 
 CONSTANT: selection-color T{ rgba f 0.8 0.8 1.0 1.0 }
 

basis/ui/text/core-text/core-text.factor

@@ -10,22 +10,18 @@ IN: ui.text.core-text
 
 SINGLETON: core-text-renderer
 
-M: core-text-renderer init-text-rendering
-    <cache-assoc> >>text-handle drop ;
-
 M: core-text-renderer string-dim
     [ " " string-dim { 0 1 } v* ]
     [ cached-line dim>> ]
     if-empty ;
 
-M: core-text-renderer finish-text-rendering
+M: core-text-renderer flush-layout-cache
-    text-handle>> purge-cache
     cached-lines get purge-cache ;
 
 : rendered-line ( font string -- texture )
-    world get text-handle>>
+    world get world-text-handle [
-    [ cached-line [ image>> ] [ loc>> ] bi <texture> ]
+        cached-line [ image>> ] [ loc>> ] bi <texture>
-    2cache ;
+    ] 2cache ;
 
 M: core-text-renderer draw-string ( font string -- )
     rendered-line draw-texture ;

basis/ui/text/pango/pango.factor

@@ -7,21 +7,17 @@ IN: ui.text.pango
 
 SINGLETON: pango-renderer
 
-M: pango-renderer init-text-rendering
-    <cache-assoc> >>text-handle drop ;
-
 M: pango-renderer string-dim
     [ " " string-dim { 0 1 } v* ]
     [ cached-layout logical-rect>> dim>> [ >integer ] map ] if-empty ;
 
-M: pango-renderer finish-text-rendering
+M: pango-renderer flush-layout-cache
-    text-handle>> purge-cache
     cached-layouts get purge-cache ;
 
 : rendered-layout ( font string -- texture )
-    world get text-handle>>
+    world get world-text-handle [
-    [ cached-layout [ image>> ] [ text-position vneg ] bi <texture> ]
+        cached-layout [ image>> ] [ text-position vneg ] bi <texture>
-    2cache ;
+    ] 2cache ;
 
 M: pango-renderer draw-string ( font string -- )
     rendered-layout draw-texture ;

basis/ui/text/pango/summary.txt

@@ -0,0 +1 @@
+UI text rendering implementation using cross-platform Pango library

basis/ui/text/text-tests.factor

@@ -1,6 +1,22 @@
 ! Copyright (C) 2009 Slava Pestov.
 ! See http://factorcode.org/license.txt for BSD license.
-USING: tools.test ui.text fonts ;
+USING: tools.test ui.text fonts math accessors kernel sequences ;
 IN: ui.text.tests
 
-[ 0.0 ] [ 0 sans-serif-font "aaa" offset>x ] unit-test
+[ t ] [ 0 sans-serif-font "aaa" offset>x zero? ] unit-test
+[ t ] [ 1 sans-serif-font "aaa" offset>x 0.0 > ] unit-test
+[ t ] [ 3 sans-serif-font "aaa" offset>x 0.0 > ] unit-test
+[ t ] [ 1 monospace-font "a" offset>x 0.0 > ] unit-test
+[ 0 ] [ 0 sans-serif-font "aaa" x>offset ] unit-test
+[ 3 ] [ 100 sans-serif-font "aaa" x>offset ] unit-test
+[ 0 ] [ 0 sans-serif-font "" x>offset ] unit-test
+
+[ t ] [
+    sans-serif-font "aaa" line-metrics
+    [ [ ascent>> ] [ descent>> ] bi + ] [ height>> ] bi =
+] unit-test
+
+[ f ] [ sans-serif-font "\0a" text-dim first zero? ] unit-test
+[ t ] [ sans-serif-font "" text-dim first zero? ] unit-test
+
+[ f ] [ sans-serif-font font-metrics height>> zero? ] unit-test

basis/ui/text/text.factor

@@ -1,18 +1,21 @@
 ! Copyright (C) 2009 Slava Pestov.
 ! See http://factorcode.org/license.txt for BSD license.
-USING: kernel arrays sequences math math.order opengl opengl.gl
+USING: kernel arrays sequences math math.order cache opengl
-strings fonts colors accessors ;
+opengl.gl strings fonts colors accessors namespaces
+ui.gadgets.worlds ;
 IN: ui.text
 
 <PRIVATE
 
 SYMBOL: font-renderer
 
-HOOK: init-text-rendering font-renderer ( world -- )
+: world-text-handle ( world -- handle )
+    dup text-handle>> [ <cache-assoc> >>text-handle ] unless
+    text-handle>> ;
 
-HOOK: finish-text-rendering font-renderer ( world -- )
+HOOK: flush-layout-cache font-renderer ( -- )
 
-M: object finish-text-rendering drop ;
+[ flush-layout-cache ] flush-layout-cache-hook set-global
 
 HOOK: string-dim font-renderer ( font string -- dim )
 
@@ -63,9 +66,19 @@ M: string draw-text draw-string ;
 M: selection draw-text draw-string ;
 
 M: array draw-text
-    GL_MODELVIEW [
+    [
         [
             [ draw-string ]
             [ [ 0.0 ] 2dip string-height 0.0 glTranslated ] 2bi
         ] with each
-    ] do-matrix ;
+    ] do-matrix ;
+
+USING: vocabs.loader namespaces system combinators ;
+
+"ui-backend" get [
+    {
+        { [ os macosx? ] [ "core-text" ] }
+        { [ os windows? ] [ "uniscribe" ] }
+        { [ os unix? ] [ "pango" ] }
+    } cond
+] unless* "ui.text." prepend require

basis/ui/text/uniscribe/authors.txt

@@ -0,0 +1 @@
+Slava Pestov

basis/ui/text/uniscribe/summary.txt

@@ -0,0 +1 @@
+UI text rendering implementation using the MS Windows Uniscribe library

basis/ui/text/uniscribe/tags.txt

@@ -0,0 +1 @@
+unportable

basis/ui/text/uniscribe/uniscribe.factor

@@ -0,0 +1,42 @@
+! Copyright (C) 2009 Slava Pestov.
+! See http://factorcode.org/license.txt for BSD license.
+USING: accessors assocs cache kernel math math.vectors sequences fonts
+namespaces opengl.textures ui.text ui.text.private ui.gadgets.worlds 
+windows.uniscribe ;
+IN: ui.text.uniscribe
+
+SINGLETON: uniscribe-renderer
+
+M: uniscribe-renderer string-dim
+    [ " " string-dim { 0 1 } v* ]
+    [ cached-script-string size>> ] if-empty ;
+
+M: uniscribe-renderer flush-layout-cache
+    cached-script-strings get purge-cache ;
+
+: rendered-script-string ( font string -- texture )
+    world get world-text-handle
+    [ cached-script-string image>> { 0 0 } <texture> ]
+    2cache ;
+
+M: uniscribe-renderer draw-string ( font string -- )
+    dup dup selection? [ string>> ] when empty?
+    [ 2drop ] [ rendered-script-string draw-texture ] if ;
+
+M: uniscribe-renderer x>offset ( x font string -- n )
+    [ 2drop 0 ] [
+        cached-script-string x>line-offset 0 = [ 1+ ] unless
+    ] if-empty ;
+
+M: uniscribe-renderer offset>x ( n font string -- x )
+    [ 2drop 0 ] [ cached-script-string line-offset>x ] if-empty ;
+
+M: uniscribe-renderer font-metrics ( font -- metrics )
+    " " cached-script-string metrics>> clone f >>width ;
+
+M: uniscribe-renderer line-metrics ( font string -- metrics )
+    [ " " line-metrics clone 0 >>width ]
+    [ cached-script-string metrics>> 50 >>width 10 >>cap-height 10 >>x-height ]
+    if-empty ;
+
+uniscribe-renderer font-renderer set-global

basis/ui/tools/browser/browser-docs.factor

@@ -2,7 +2,7 @@ USING: help.markup help.syntax ui.commands ;
 IN: ui.tools.browser
 
 ARTICLE: "ui-browser" "UI browser"
-"The browser is used to display Factor code, documentation, and vocabularies. The browser is opened when a word or articlelink presentation is clicked. It can also be opened using words:"
+"The browser is used to display Factor code, documentation, and vocabularies. The browser is opened when a word or article link presentation is clicked. It can also be opened using words:"
 { $subsection com-browse }
 { $subsection browser-window }
 { $command-map browser-gadget "toolbar" }

basis/ui/tools/browser/browser.factor

@@ -1,23 +1,33 @@
 ! Copyright (C) 2006, 2009 Slava Pestov.
 ! See http://factorcode.org/license.txt for BSD license.
-USING: debugger help help.topics help.crossref help.home kernel
+USING: debugger help help.topics help.crossref help.home kernel models
-models compiler.units assocs words vocabs accessors fry
+compiler.units assocs words vocabs accessors fry arrays
-combinators.short-circuit namespaces sequences models
+combinators.short-circuit namespaces sequences models help.apropos
-models.history help.apropos combinators ui.commands ui.gadgets
+combinators ui ui.commands ui.gadgets ui.gadgets.panes
-ui.gadgets.panes ui.gadgets.scrollers ui.gadgets.tracks
+ui.gadgets.scrollers ui.gadgets.tracks ui.gestures ui.gadgets.buttons
-ui.gestures ui.gadgets.buttons ui.gadgets.packs
+ui.gadgets.packs ui.gadgets.editors ui.gadgets.labels
-ui.gadgets.editors ui.gadgets.labels ui.gadgets.status-bar
+ui.gadgets.status-bar ui.gadgets.glass ui.gadgets.borders ui.gadgets.viewports
-ui.gadgets.glass ui.gadgets.borders ui.tools.common
+ui.tools.common ui.tools.browser.popups ui.tools.browser.history ;
-ui.tools.browser.popups ui ;
 IN: ui.tools.browser
 
-TUPLE: browser-gadget < tool pane scroller search-field popup ;
+TUPLE: browser-gadget < tool history pane scroller search-field popup ;
 
 { 650 400 } browser-gadget set-tool-dim
 
+M: browser-gadget history-value
+    [ control-value ] [ scroller>> scroll-position ]
+    bi 2array ;
+
+M: browser-gadget set-history-value
+    [ first2 ] dip
+    [ set-control-value ] [ scroller>> set-scroll-position ]
+    bi-curry bi* ;
+
 : show-help ( link browser-gadget -- )
-    [ >link ] [ model>> ] bi*
+    [ >link ] dip
-    [ [ add-recent ] [ add-history ] bi* ] [ set-model ] 2bi ;
+    [ [ add-recent ] [ history>> add-history ] bi* ]
+    [ model>> set-model ]
+    2bi ;
 
 : <help-pane> ( browser-gadget -- gadget )
     model>> [ '[ _ print-topic ] try ] <pane-control> ;
@@ -41,7 +51,8 @@ TUPLE: browser-gadget < tool pane scroller search-field popup ;
 : <browser-gadget> ( link -- gadget )
     vertical browser-gadget new-track
         1 >>fill
-        swap >link <history> >>model
+        swap >link <model> >>model
+        dup <history> >>history
         dup <search-field> >>search-field
         dup <browser-toolbar> { 3 3 } <border> { 1 0 } >>fill f track-add
         dup <help-pane> >>pane
@@ -93,9 +104,9 @@ M: browser-gadget focusable-child* search-field>> ;
 
 \ show-browser H{ { +nullary+ t } } define-command
 
-: com-back ( browser -- ) model>> go-back ;
+: com-back ( browser -- ) history>> go-back ;
 
-: com-forward ( browser -- ) model>> go-forward ;
+: com-forward ( browser -- ) history>> go-forward ;
 
 : com-home ( browser -- ) "help.home" swap show-help ;
 

basis/ui/tools/browser/history/authors.txt

@@ -0,0 +1 @@
+Slava Pestov