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

* 'master' of git://factorcode.org/git/factor: (66 commits)
  Better error message for syntax error in : foo ( : bar
  remove some dead code, make spider use count and max-count again
  left and right arrow keys move between graphemes in UI
  Adding functionality to unicode breaks API for future UI changes
  state-parser works with sequences, not strings
  rename word
  redo spider without dynamic variables
  remove duplication, refactor html.parser to use new state parser
  redo state parser to avoid dynamic variables
  fix help-lint for syndication
  Small speedup for code using H{ } clone and with-scope
  Small size reduction for deployed images
  Tweak some code to reduce deployed image size
  syndication: fix help lint
  Fix parse-feed for byte arrays
  refactor some error handling in peg, more unit tests
  Fix C99 complex number support in FFI on Mac OS X/PPC
  add unit tests for quoting
  Fix model docs
  Some cleanup in documents.elements
  ...

Makefile

@@ -11,6 +11,7 @@ IMAGE = factor.image
 BUNDLE = Factor.app
 LIBPATH = -L/usr/X11R6/lib
 CFLAGS = -Wall
+FFI_TEST_CFLAGS = -fPIC
 
 ifdef DEBUG
 	CFLAGS += -g
@@ -140,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 \
@@ -159,16 +161,19 @@ factor-console: $(DLL_OBJS) $(EXE_OBJS)
 	$(CC) $(LIBS) $(LIBPATH) -L. $(LINK_WITH_ENGINE) \
 		$(CFLAGS) $(CFLAGS_CONSOLE) -o factor$(EXE_SUFFIX)$(CONSOLE_EXTENSION) $(EXE_OBJS)
 
-factor-ffi-test: $(TEST_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
 
+vm/ffi_test.o: vm/ffi_test.c
+	$(CC) -c $(CFLAGS) $(FFI_TEST_CFLAGS) -o $@ $<
+
 .c.o:
 	$(CC) -c $(CFLAGS) -o $@ $<
 

basis/alien/libraries/libraries.factor

@@ -18,5 +18,4 @@ TUPLE: library path abi dll ;
     library dup [ dll>> ] when ;
 
 : add-library ( name path abi -- )
-    [ dup [ normalize-path ] when ] dip
     <library> swap libraries get set-at ;

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

@@ -1,18 +1,20 @@
-IN: compiler.tests
 USING: alien alien.c-types alien.syntax compiler kernel
 namespaces namespaces tools.test sequences stack-checker
 stack-checker.errors words arrays parser quotations
 continuations effects namespaces.private io io.streams.string
 memory system threads tools.test math accessors combinators
-specialized-arrays.float alien.libraries ;
+specialized-arrays.float alien.libraries io.pathnames
+io.backend ;
+IN: compiler.tests
 
 <<
 : libfactor-ffi-tests-path ( -- string )
+    "resource:" (normalize-path)
     {
-        { [ os winnt? ]  [ "resource:libfactor-ffi-test.dll" ] }
+        { [ os winnt? ]  [ "libfactor-ffi-test.dll" ] }
-        { [ os macosx? ] [ "resource:libfactor-ffi-test.dylib" ] }
+        { [ os macosx? ] [ "libfactor-ffi-test.dylib" ] }
-        { [ os unix?  ]  [ "resource:libfactor-ffi-test.so" ] }
+        { [ os unix?  ]  [ "libfactor-ffi-test.so" ] }
-    } cond ;
+    } cond append-path ;
 
 "f-cdecl" libfactor-ffi-tests-path "cdecl" add-library
 
@@ -122,8 +124,6 @@ unit-test
     "int" { "int" "int" "int" "int" } "stdcall" alien-indirect
     gc ;
 
-LIBRARY: f-stdcall
-
 [ f ] [ "f-stdcall" load-library f = ] unit-test
 [ "stdcall" ] [ "f-stdcall" library abi>> ] unit-test
 
@@ -164,7 +164,7 @@ FUNCTION: void ffi_test_20 double x1, double x2, double x3,
 
 : ffi_test_31 ( a a a a a a a a a a a a a a a a a a a a a a a a a a a a a a a a a a a a a a a a a a -- result y )
     "int"
-    "f-stdcall" "ffi_test_31"
+    "f-cdecl" "ffi_test_31"
     { "int" "int" "int" "int" "int" "int" "int" "int" "int" "int" "int" "int" "int" "int" "int" "int" "int" "int" "int" "int" "int" "int" "int" "int" "int" "int" "int" "int" "int" "int" "int" "int" "int" "int" "int" "int" "int" "int" "int" "int" "int" "int" }
     alien-invoke gc 3 ;
 
@@ -172,7 +172,7 @@ FUNCTION: void ffi_test_20 double x1, double x2, double x3,
 
 : ffi_test_31_point_5 ( a a a a a a a a a a a a a a a a a a a a a a a a a a a a a a a a a a a a a a a a a a -- result )
     "float"
-    "f-stdcall" "ffi_test_31_point_5"
+    "f-cdecl" "ffi_test_31_point_5"
     { "float" "float" "float" "float" "float" "float" "float" "float" "float" "float" "float" "float" "float" "float" "float" "float" "float" "float" "float" "float" "float" "float" "float" "float" "float" "float" "float" "float" "float" "float" "float" "float" "float" "float" "float" "float" "float" "float" "float" "float" "float" "float" }
     alien-invoke ;
 

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/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/tips/tips-docs.factor

@@ -17,7 +17,14 @@ TIP: "You can write documentation for your own code using the " { $link "help" }
 TIP: "You can write graphical applications using the " { $link "ui" } "." ;
 
 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." ;
+
+HELP: TIP:
+{ $syntax "TIP: content ;" }
+{ $values { "content" "a markup element" } }
+{ $description "Defines a new tip of the day." } ;
+  
 ARTICLE: "all-tips-of-the-day" "All tips of the day"
 { $tips-of-the-day } ;
 

basis/help/tips/tips.factor

@@ -1,14 +1,28 @@
 ! Copyright (C) 2009 Slava Pestov.
 ! See http://factorcode.org/license.txt for BSD license.
-USING: parser arrays namespaces sequences random help.markup kernel io
+USING: parser arrays namespaces sequences random help.markup help.stylesheet
-io.styles colors.constants ;
+kernel io io.styles colors.constants definitions accessors ;
 IN: help.tips
 
 SYMBOL: tips
 
 tips [ V{ } clone ] initialize
 
-SYNTAX: TIP: parse-definition >array tips get push ;
+TUPLE: tip < identity-tuple content loc ;
+
+M: tip forget* tips get delq ;
+
+M: tip where loc>> ;
+
+M: tip set-where (>>loc) ;
+
+: <tip> ( content -- tip ) f tip boa ;
+
+: add-tip ( tip -- ) tips get push ;
+
+SYNTAX: TIP:
+    parse-definition >array <tip>
+    [ save-location ] [ add-tip ] bi ;
 
 : a-tip ( -- tip ) tips get random ;
 
@@ -20,13 +34,20 @@ H{
     { wrap-margin 500 }
 } tip-of-the-day-style set-global
 
+: $tip-title ( tip -- )
+    [
+        heading-style get [
+            [ "Tip of the day" ] dip write-object
+        ] with-style
+    ] ($block) ;
+
 : $tip-of-the-day ( element -- )
     drop
     [
         tip-of-the-day-style get
         [
             last-element off
-            "Tip of the day" $heading a-tip print-element nl
+            a-tip [ $tip-title ] [ content>> print-element nl ] bi
             "— " print-element "all-tips-of-the-day" ($link)
         ]
         with-nesting
@@ -35,4 +56,6 @@ H{
 : tip-of-the-day. ( -- ) { $tip-of-the-day } print-content nl ;
 
 : $tips-of-the-day ( element -- )
-    drop tips get [ nl nl ] [ print-element ] interleave ;
+    drop tips get [ nl nl ] [ content>> print-element ] interleave ;
+
+INSTANCE: tip definition

basis/help/topics/topics.factor

@@ -7,8 +7,12 @@ IN: help.topics
 
 TUPLE: link name ;
 
+INSTANCE: link definition
+
 MIXIN: topic
+
 INSTANCE: link topic
+
 INSTANCE: word topic
 
 GENERIC: >link ( obj -- obj )

basis/hints/hints.factor

@@ -34,16 +34,18 @@ M: object specializer-declaration class ;
         [ specializer-declaration ] map '[ _ declare ] pick append
     ] { } map>assoc ;
 
+: specialize-quot ( quot specializer -- quot' )
+    specializer-cases alist>quot ;
+
 : method-declaration ( method -- quot )
     [ "method-generic" word-prop dispatch# object <array> ]
     [ "method-class" word-prop ]
     bi prefix ;
 
 : specialize-method ( quot method -- quot' )
-    method-declaration '[ _ declare ] prepend ;
+    [ method-declaration '[ _ declare ] prepend ]
-
+    [ "method-generic" word-prop "specializer" word-prop ] bi
-: specialize-quot ( quot specializer -- quot' )
+    [ specialize-quot ] when* ;
-    specializer-cases alist>quot ;
 
 : standard-method? ( method -- ? )
     dup method-body? [
@@ -52,9 +54,11 @@ M: object specializer-declaration class ;
 
 : specialized-def ( word -- quot )
     [ def>> ] keep
-    [ dup standard-method? [ specialize-method ] [ drop ] if ]
+    dup generic? [ drop ] [
-    [ "specializer" word-prop [ specialize-quot ] when* ]
+        [ dup standard-method? [ specialize-method ] [ drop ] if ]
-    bi ;
+        [ "specializer" word-prop [ specialize-quot ] when* ]
+        bi
+    ] if ;
 
 : specialized-length ( specializer -- n )
     dup [ array? ] all? [ first ] when length ;
@@ -115,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,16 +1,14 @@
 ! Copyright (C) 2009 Doug Coleman.
 ! See http://factorcode.org/license.txt for BSD license.
-USING: kernel accessors grouping sequences combinators
+USING: combinators kernel ;
-math specialized-arrays.direct.uint byte-arrays fry
-specialized-arrays.direct.ushort specialized-arrays.uint
-specialized-arrays.ushort specialized-arrays.float ;
 IN: images
 
-SINGLETONS: BGR RGB BGRA RGBA ABGR ARGB RGBX XRGB BGRX XBGR
+SINGLETONS: L BGR RGB BGRA RGBA ABGR ARGB RGBX XRGB BGRX XBGR
 R16G16B16 R32G32B32 R16G16B16A16 R32G32B32A32 ;
 
 : bytes-per-pixel ( component-order -- n )
     {
+        { L [ 1 ] }
         { BGR [ 3 ] }
         { RGB [ 3 ] }
         { BGRA [ 4 ] }
@@ -31,71 +29,4 @@ TUPLE: image dim component-order upside-down? bitmap ;
 
 : <image> ( -- image ) image new ; inline
 
-GENERIC: load-image* ( path tuple -- image )
+GENERIC: load-image* ( path tuple -- image )
-
-: add-dummy-alpha ( seq -- seq' )
-    3 <groups> [ 255 suffix ] map concat ;
-
-: normalize-floats ( byte-array -- byte-array )
-    byte-array>float-array [ 255.0 * >integer ] B{ } map-as ;
-
-GENERIC: normalize-component-order* ( image component-order -- image )
-
-: normalize-component-order ( image -- image )
-    dup component-order>> '[ _ normalize-component-order* ] change-bitmap ;
-
-M: RGBA normalize-component-order* drop ;
-
-M: R32G32B32A32 normalize-component-order*
-    drop normalize-floats ;
-
-M: R32G32B32 normalize-component-order*
-    drop normalize-floats add-dummy-alpha ;
-
-: RGB16>8 ( bitmap -- bitmap' )
-    byte-array>ushort-array [ -8 shift ] B{ } map-as ; inline
-
-M: R16G16B16A16 normalize-component-order*
-    drop RGB16>8 ;
-
-M: R16G16B16 normalize-component-order*
-    drop RGB16>8 add-dummy-alpha ;
-
-: BGR>RGB ( bitmap -- pixels )
-    3 <sliced-groups> [ <reversed> ] map B{ } join ; inline
-
-: BGRA>RGBA ( bitmap -- pixels )
-    4 <sliced-groups>
-    [ unclip-last-slice [ <reversed> ] dip suffix ] map concat ; inline
-
-M: BGRA normalize-component-order*
-    drop BGRA>RGBA ;
-
-M: RGB normalize-component-order*
-    drop add-dummy-alpha ;
-
-M: BGR normalize-component-order*
-    drop BGR>RGB add-dummy-alpha ;
-
-: ARGB>RGBA ( bitmap -- bitmap' )
-    4 <groups> [ unclip suffix ] map B{ } join ; inline
-
-M: ARGB normalize-component-order*
-    drop ARGB>RGBA ;
-
-M: ABGR normalize-component-order*
-    drop ARGB>RGBA BGRA>RGBA ;
-
-: normalize-scan-line-order ( image -- image )
-    dup upside-down?>> [
-        dup dim>> first 4 * '[
-            _ <groups> reverse concat
-        ] change-bitmap
-        f >>upside-down?
-    ] when ;
-
-: normalize-image ( image -- image )
-    [ >byte-array ] change-bitmap
-    normalize-component-order
-    normalize-scan-line-order
-    RGBA >>component-order ;

basis/images/loader/loader.factor

@@ -1,7 +1,7 @@
 ! Copyright (C) 2009 Doug Coleman.
 ! See http://factorcode.org/license.txt for BSD license.
 USING: constructors kernel splitting unicode.case combinators
-accessors images.bitmap images.tiff images io.backend
+accessors images.bitmap images.tiff images images.normalization
 io.pathnames ;
 IN: images.loader
 

basis/images/normalization/authors.txt

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

basis/images/normalization/normalization.factor

@@ -0,0 +1,78 @@
+! Copyright (C) 2009 Doug Coleman
+! See http://factorcode.org/license.txt for BSD license.
+USING: kernel accessors grouping sequences combinators
+math specialized-arrays.direct.uint byte-arrays fry
+specialized-arrays.direct.ushort specialized-arrays.uint
+specialized-arrays.ushort specialized-arrays.float images ;
+IN: images.normalization
+
+<PRIVATE
+
+: add-dummy-alpha ( seq -- seq' )
+    3 <groups> [ 255 suffix ] map concat ;
+
+: normalize-floats ( byte-array -- byte-array )
+    byte-array>float-array [ 255.0 * >integer ] B{ } map-as ;
+
+GENERIC: normalize-component-order* ( image component-order -- image )
+
+: normalize-component-order ( image -- image )
+    dup component-order>> '[ _ normalize-component-order* ] change-bitmap ;
+
+M: RGBA normalize-component-order* drop ;
+
+M: R32G32B32A32 normalize-component-order*
+    drop normalize-floats ;
+
+M: R32G32B32 normalize-component-order*
+    drop normalize-floats add-dummy-alpha ;
+
+: RGB16>8 ( bitmap -- bitmap' )
+    byte-array>ushort-array [ -8 shift ] B{ } map-as ; inline
+
+M: R16G16B16A16 normalize-component-order*
+    drop RGB16>8 ;
+
+M: R16G16B16 normalize-component-order*
+    drop RGB16>8 add-dummy-alpha ;
+
+: BGR>RGB ( bitmap -- pixels )
+    3 <sliced-groups> [ <reversed> ] map B{ } join ; inline
+
+: BGRA>RGBA ( bitmap -- pixels )
+    4 <sliced-groups>
+    [ unclip-last-slice [ <reversed> ] dip suffix ] map concat ; inline
+
+M: BGRA normalize-component-order*
+    drop BGRA>RGBA ;
+
+M: RGB normalize-component-order*
+    drop add-dummy-alpha ;
+
+M: BGR normalize-component-order*
+    drop BGR>RGB add-dummy-alpha ;
+
+: ARGB>RGBA ( bitmap -- bitmap' )
+    4 <groups> [ unclip suffix ] map B{ } join ; inline
+
+M: ARGB normalize-component-order*
+    drop ARGB>RGBA ;
+
+M: ABGR normalize-component-order*
+    drop ARGB>RGBA BGRA>RGBA ;
+
+: normalize-scan-line-order ( image -- image )
+    dup upside-down?>> [
+        dup dim>> first 4 * '[
+            _ <groups> reverse concat
+        ] change-bitmap
+        f >>upside-down?
+    ] when ;
+
+PRIVATE>
+
+: normalize-image ( image -- image )
+    [ >byte-array ] change-bitmap
+    normalize-component-order
+    normalize-scan-line-order
+    RGBA >>component-order ;

basis/images/tesselation/authors.txt

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

basis/images/tesselation/tesselation-tests.factor

@@ -0,0 +1,46 @@
+USING: images accessors kernel tools.test literals math.ranges
+byte-arrays ;
+IN: images.tesselation
+
+! Check an invariant we depend on
+[ t ] [
+    <image> B{ 1 2 3 } >>bitmap dup clone [ bitmap>> ] bi@ eq?
+] unit-test
+
+[
+    {
+        {
+            T{ image f { 2 2 } L f B{ 1 2 5 6 } }
+            T{ image f { 2 2 } L f B{ 3 4 7 8 } }
+        }
+        {
+            T{ image f { 2 2 } L f B{ 9 10 13 14 } }
+            T{ image f { 2 2 } L f B{ 11 12 15 16 } }
+        }
+    }
+] [
+    <image>
+        1 16 [a,b] >byte-array >>bitmap
+        { 4 4 } >>dim
+        L >>component-order
+    { 2 2 } tesselate
+] unit-test
+
+[
+    {
+        {
+            T{ image f { 2 2 } L f B{ 1 2 4 5 } }
+            T{ image f { 1 2 } L f B{ 3 6 } }
+        }
+        {
+            T{ image f { 2 1 } L f B{ 7 8 } }
+            T{ image f { 1 1 } L f B{ 9 } }
+        }
+    }
+] [
+    <image>
+        1 9 [a,b] >byte-array >>bitmap
+        { 3 3 } >>dim
+        L >>component-order
+    { 2 2 } tesselate
+] unit-test

basis/images/tesselation/tesselation.factor

@@ -0,0 +1,35 @@
+! Copyright (C) 2009 Slava Pestov.
+! See http://factorcode.org/license.txt for BSD license.
+USING: sequences kernel math grouping fry columns locals accessors
+images math math.vectors arrays ;
+IN: images.tesselation
+
+: group-rows ( bitmap bitmap-dim -- rows )
+    first <sliced-groups> ; inline
+
+: tesselate-rows ( bitmap-rows tess-dim -- bitmaps )
+    second <sliced-groups> ; inline
+
+: tesselate-columns ( bitmap-rows tess-dim -- bitmaps )
+    first '[ _ <sliced-groups> ] map flip ; inline
+
+: tesselate-bitmap ( bitmap bitmap-dim tess-dim -- bitmap-grid )
+    [ group-rows ] dip
+    [ tesselate-rows ] keep
+    '[ _ tesselate-columns ] map ;
+
+: tile-width ( tile-bitmap original-image -- width )
+    [ first length ] [ component-order>> bytes-per-pixel ] bi* /i ;
+
+: <tile-image> ( tile-bitmap original-image -- tile-image )
+    clone
+        swap
+        [ concat >>bitmap ]
+        [ [ over tile-width ] [ length ] bi 2array >>dim ] bi ;
+
+:: tesselate ( image tess-dim -- image-grid )
+    image component-order>> bytes-per-pixel :> bpp
+    image dim>> { bpp 1 } v* :> image-dim'
+    tess-dim { bpp 1 } v* :> tess-dim'
+    image bitmap>> image-dim' tess-dim' tesselate-bitmap
+    [ [ image <tile-image> ] map ] map ;

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/io/streams/byte-array/byte-array-tests.factor

@@ -1,5 +1,5 @@
 USING: tools.test io.streams.byte-array io.encodings.binary
-io.encodings.utf8 io kernel arrays strings ;
+io.encodings.utf8 io kernel arrays strings namespaces ;
 
 [ B{ 1 2 3 } ] [ binary [ { 1 2 3 } write ] with-byte-writer ] unit-test
 [ B{ 1 2 3 } ] [ { 1 2 3 } binary [ 3 read ] with-byte-reader ] unit-test
@@ -7,3 +7,23 @@ io.encodings.utf8 io kernel arrays strings ;
 [ B{ BIN: 11110101 BIN: 10111111 BIN: 10000000 BIN: 10111111 BIN: 11101111 BIN: 10000000 BIN: 10111111 BIN: 11011111 BIN: 10000000 CHAR: x } ]
 [ { BIN: 101111111000000111111 BIN: 1111000000111111 BIN: 11111000000 CHAR: x } utf8 [ write ] with-byte-writer ] unit-test
 [ { BIN: 101111111000000111111 } t ] [ { BIN: 11110101 BIN: 10111111 BIN: 10000000 BIN: 10111111 } utf8 <byte-reader> contents dup >array swap string? ] unit-test
+
+[ B{ 121 120 } 0 ] [
+    B{ 0 121 120 0 0 0 0 0 0 } binary
+    [ 1 read drop "\0" read-until ] with-byte-reader
+] unit-test
+
+[ 1 1 4 11 f ] [
+    B{ 1 2 3 4 5 6 7 8 9 10 11 12 } binary
+    [
+        read1
+        0 seek-absolute input-stream get stream-seek
+        read1
+        2 seek-relative input-stream get stream-seek
+        read1
+        -2 seek-end input-stream get stream-seek
+        read1
+        0 seek-end input-stream get stream-seek
+        read1
+    ] with-byte-reader
+] unit-test

basis/io/streams/byte-array/byte-array.factor

@@ -28,7 +28,7 @@ M: byte-reader stream-seek ( n seek-type stream -- )
     swap {
         { seek-absolute [ (>>i) ] }
         { seek-relative [ [ + ] change-i drop ] }
-        { seek-end [ dup underlying>> length >>i [ + ] change-i drop ] }
+        { seek-end [ [ underlying>> length + ] keep (>>i) ] }
         [ bad-seek-type ]
     } case ;
 

basis/math/bitwise/bitwise.factor

@@ -37,7 +37,7 @@ IN: math.bitwise
 
 ! flags
 MACRO: flags ( values -- )
-    [ 0 ] [ [ dup word? [ execute ] when bitor ] curry compose ] reduce ;
+    [ 0 ] [ [ ?execute bitor ] curry compose ] reduce ;
 
 ! bitfield
 <PRIVATE

basis/math/blas/ffi/ffi.factor

@@ -7,7 +7,11 @@ IN: math.blas.ffi
     { [ os macosx? ] [ "libblas.dylib" intel-unix-abi 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 ] }
+    {
+        [ os [ freebsd? ] [ linux? cpu x86.32? and ] bi or ]
+        [ "libblas.so" gfortran-abi add-fortran-library ]
+    }
+    { [ os [ freebsd? ] [ linux? ] bi or ] [ "libblas.so" gfortran-abi add-fortran-library ] }
     [ "libblas.so" f2c-abi add-fortran-library ]
 } cond
 >>

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>

basis/opengl/opengl-docs.factor

@@ -23,11 +23,11 @@ HELP: gl-line
 { $description "Draws a line between two points." } ;
 
 HELP: gl-fill-rect
-{ $values { "dim" "a pair of integers" } }
+{ $values { "loc" "a pair of integers" } { "dim" "a pair of integers" } }
 { $description "Draws a filled rectangle with the top-left corner at the origin and the given dimensions." } ;
 
 HELP: gl-rect
-{ $values { "dim" "a pair of integers" } }
+{ $values { "loc" "a pair of integers" } { "dim" "a pair of integers" } }
 { $description "Draws the outline of a rectangle with the top-left corner at the origin and the given dimensions." } ;
 
 HELP: gen-gl-buffer

basis/opengl/opengl.factor

@@ -3,8 +3,8 @@
 ! Portions copyright (C) 2008 Joe Groff.
 ! See http://factorcode.org/license.txt for BSD license.
 USING: alien alien.c-types continuations kernel libc math macros
-namespaces math.vectors math.parser opengl.gl opengl.glu
+namespaces math.vectors math.parser opengl.gl opengl.glu combinators
-combinators arrays sequences splitting words byte-arrays assocs
+combinators.smart arrays sequences splitting words byte-arrays assocs
 colors colors.constants accessors generalizations locals fry
 specialized-arrays.float specialized-arrays.uint ;
 IN: opengl
@@ -28,7 +28,7 @@ IN: opengl
     over glEnableClientState dip glDisableClientState ; inline
 
 : words>values ( word/value-seq -- value-seq )
-    [ dup word? [ execute ] when ] map ;
+    [ ?execute ] map ;
 
 : (all-enabled) ( seq quot -- )
     over [ glEnable ] each dip [ glDisable ] each ; inline
@@ -67,42 +67,46 @@ MACRO: all-enabled-client-state ( seq quot -- )
 : gl-line ( a b -- )
     line-vertices GL_LINES 0 2 glDrawArrays ;
 
-: (rect-vertices) ( dim -- vertices )
+:: (rect-vertices) ( loc dim -- vertices )
     #! We use GL_LINE_STRIP with a duplicated first vertex
     #! instead of GL_LINE_LOOP to work around a bug in Apple's
     #! X3100 driver.
-    {
+    loc first2 :> y :> x
-        [ drop 0.5 0.5 ]
+    dim first2 :> h :> w
-        [ first 0.3 - 0.5 ]
+    [
-        [ [ first 0.3 - ] [ second 0.3 - ] bi ]
+        x 0.5 +     y 0.5 +
-        [ second 0.3 - 0.5 swap ]
+        x w + 0.3 - y 0.5 +
-        [ drop 0.5 0.5 ]
+        x w + 0.3 - y h + 0.3 -
-    } cleave 10 float-array{ } nsequence ;
+        x           y h + 0.3 -
+        x 0.5 +     y 0.5 +
+    ] float-array{ } output>sequence ;
 
-: rect-vertices ( dim -- )
+: rect-vertices ( loc dim -- )
     (rect-vertices) gl-vertex-pointer ;
 
 : (gl-rect) ( -- )
     GL_LINE_STRIP 0 5 glDrawArrays ;
 
-: gl-rect ( dim -- )
+: gl-rect ( loc dim -- )
     rect-vertices (gl-rect) ;
 
-: (fill-rect-vertices) ( dim -- vertices )
+:: (fill-rect-vertices) ( loc dim -- vertices )
-    {
+    loc first2 :> y :> x
-        [ drop 0 0 ]
+    dim first2 :> h :> w
-        [ first 0 ]
+    [
-        [ first2 ]
+        x      y
-        [ second 0 swap ]
+        x w +  y
-    } cleave 8 float-array{ } nsequence ;
+        x w +  y h +
+        x      y h +
+    ] float-array{ } output>sequence ;
 
-: fill-rect-vertices ( dim -- )
+: fill-rect-vertices ( loc dim -- )
     (fill-rect-vertices) gl-vertex-pointer ;
 
 : (gl-fill-rect) ( -- )
     GL_QUADS 0 4 glDrawArrays ;
 
-: gl-fill-rect ( dim -- )
+: gl-fill-rect ( loc dim -- )
     fill-rect-vertices (gl-fill-rect) ;
 
 : do-attribs ( bits quot -- )

basis/opengl/textures/textures-tests.factor

@@ -1,7 +1,8 @@
 ! Copyright (C) 2009 Slava Pestov.
 ! See http://factorcode.org/license.txt for BSD license.
 USING: tools.test opengl.textures opengl.textures.private
-images kernel namespaces ;
+opengl.textures.private images kernel namespaces accessors
+sequences ;
 IN: opengl.textures.tests
 
 [ ] [
@@ -52,4 +53,17 @@ IN: opengl.textures.tests
        { component-order R32G32B32 }
        { bitmap B{ } }
     } power-of-2-image
+] unit-test
+
+[
+    {
+        { { 0 0 } { 10 0 } }
+        { { 0 20 } { 10 20 } }
+    }
+] [
+    {
+        { { 10 20 } { 30 20 } }
+        { { 10 30 } { 30 300 } }
+    }
+    [ [ image new swap >>dim ] map ] map image-locs
 ] unit-test

basis/opengl/textures/textures.factor

@@ -1,16 +1,15 @@
 ! Copyright (C) 2009 Slava Pestov.
 ! See http://factorcode.org/license.txt for BSD license.
 USING: accessors assocs cache colors.constants destructors fry kernel
-opengl opengl.gl combinators images grouping specialized-arrays.float
+opengl opengl.gl combinators images images.tesselation grouping
-locals sequences math math.vectors generalizations ;
+specialized-arrays.float locals sequences math math.vectors
+math.matrices generalizations fry columns ;
 IN: opengl.textures
 
 : gen-texture ( -- id ) [ glGenTextures ] (gen-gl-object) ;
 
 : delete-texture ( id -- ) [ glDeleteTextures ] (delete-gl-object) ;
 
-TUPLE: texture loc dim texture-coords texture display-list disposed ;
-
 GENERIC: component-order>format ( component-order -- format type )
 
 M: RGB component-order>format drop GL_RGB GL_UNSIGNED_BYTE ;
@@ -19,8 +18,14 @@ 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 ;
 
+GENERIC: draw-texture ( texture -- )
+
+GENERIC: draw-scaled-texture ( dim texture -- )
+
 <PRIVATE
 
+TUPLE: single-texture loc dim texture-coords texture display-list disposed ;
+
 : repeat-last ( seq n -- seq' )
     over peek pad-tail concat ;
 
@@ -69,20 +74,27 @@ M: BGRA component-order>format drop GL_BGRA_EXT GL_UNSIGNED_BYTE ;
     GL_TEXTURE_2D GL_TEXTURE_WRAP_S GL_REPEAT glTexParameteri
     GL_TEXTURE_2D GL_TEXTURE_WRAP_T GL_REPEAT glTexParameteri ;
 
-: draw-textured-rect ( dim texture -- )
+: with-texturing ( quot -- )
     GL_TEXTURE_2D [
         GL_TEXTURE_BIT [
             GL_TEXTURE_COORD_ARRAY [
                 COLOR: white gl-color
-                dup loc>> [
+                call
-                    [ [ GL_TEXTURE_2D ] dip texture>> glBindTexture ]
-                    [ init-texture texture-coords>> gl-texture-coord-pointer ] bi
-                    fill-rect-vertices (gl-fill-rect)
-                    GL_TEXTURE_2D 0 glBindTexture
-                ] with-translation
             ] do-enabled-client-state
         ] do-attribs
-    ] do-enabled ;
+    ] do-enabled ; inline
+
+: (draw-textured-rect) ( dim texture -- )
+    [ loc>> ]
+    [ [ GL_TEXTURE_2D ] dip texture>> glBindTexture ]
+    [ init-texture texture-coords>> gl-texture-coord-pointer ] tri
+    swap gl-fill-rect ;
+
+: draw-textured-rect ( dim texture -- )
+    [
+        (draw-textured-rect)
+        GL_TEXTURE_2D 0 glBindTexture
+    ] with-texturing ;
 
 : texture-coords ( dim -- coords )
     [ dup next-power-of-2 /f ] map
@@ -92,10 +104,8 @@ M: BGRA component-order>format drop GL_BGRA_EXT GL_UNSIGNED_BYTE ;
 : make-texture-display-list ( texture -- dlist )
     GL_COMPILE [ [ dim>> ] keep draw-textured-rect ] make-dlist ;
 
-PRIVATE>
+: <single-texture> ( image loc -- texture )
-
+   single-texture new swap >>loc
-: <texture> ( image loc -- texture )
-    texture new swap >>loc
     swap
     [ dim>> >>dim ] keep
     [ dim>> product 0 = ] keep '[
@@ -105,12 +115,59 @@ PRIVATE>
         dup make-texture-display-list >>display-list
     ] unless ;
 
-M: texture dispose*
+M: single-texture dispose*
     [ texture>> [ delete-texture ] when* ]
     [ display-list>> [ delete-dlist ] when* ] bi ;
 
-: draw-texture ( texture -- )
+M: single-texture draw-texture display-list>> [ glCallList ] when* ;
-    display-list>> [ glCallList ] when* ;
 
-: draw-scaled-texture ( dim texture -- )
+M: single-texture draw-scaled-texture
-    dup texture>> [ draw-textured-rect ] [ 2drop ] if ;
+    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
+    [ 0 [ + ] accumulate nip ] bi@
+    cross-zip flip ;
+
+: <texture-grid> ( image-grid loc -- grid )
+    [ dup image-locs ] dip
+    '[ [ _ v+ <single-texture> |dispose ] 2map ] 2map ;
+
+: draw-textured-grid ( grid -- )
+    [ [ [ dim>> ] keep (draw-textured-rect) ] each ] each ;
+
+: make-textured-grid-display-list ( grid -- dlist )
+    GL_COMPILE [
+        [
+            [
+                [
+                    [ dim>> ] keep (draw-textured-rect)
+                ] each
+            ] each
+            GL_TEXTURE_2D 0 glBindTexture
+        ] with-texturing
+    ] make-dlist ;
+
+: <multi-texture> ( image-grid loc -- multi-texture )
+    [
+        [
+            <texture-grid> dup
+            make-textured-grid-display-list
+        ] keep
+        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 }
+
+PRIVATE>
+
+: <texture> ( image loc -- texture )
+    over dim>> max-texture-size [ <= ] 2all?
+    [ <single-texture> ]
+    [ [ max-texture-size tesselate ] dip <multi-texture> ] if ;

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/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-docs.factor

@@ -1,6 +1,6 @@
 ! Copyright (C) 2008 Doug Coleman.
 ! See http://factorcode.org/license.txt for BSD license.
-USING: help.markup help.syntax kernel math ;
+USING: help.markup help.syntax kernel math strings ;
 IN: roman
 
 HELP: >roman
@@ -39,7 +39,7 @@ HELP: roman>
 { >roman >ROMAN roman> } related-words
 
 HELP: roman+
-{ $values { "str1" "a string" } { "str2" "a string" } { "str3" "a string" } }
+{ $values { "string" string } { "string" string } { "string" string } }
 { $description "Adds two Roman numerals." }
 { $examples 
     { $example "USING: io roman ;"
@@ -49,7 +49,7 @@ HELP: roman+
 } ;
 
 HELP: roman-
-{ $values { "str1" "a string" } { "str2" "a string" } { "str3" "a string" } }
+{ $values { "string" string } { "string" string } { "string" string } }
 { $description "Subtracts two Roman numerals." }
 { $examples 
     { $example "USING: io roman ;"
@@ -61,7 +61,7 @@ HELP: roman-
 { roman+ roman- } related-words
 
 HELP: roman*
-{ $values { "str1" "a string" } { "str2" "a string" } { "str3" "a string" } }
+{ $values { "string" string } { "string" string } { "string" string } }
 { $description "Multiplies two Roman numerals." }
 { $examples 
     { $example "USING: io roman ;"
@@ -71,7 +71,7 @@ HELP: roman*
 } ;
 
 HELP: roman/i
-{ $values { "str1" "a string" } { "str2" "a string" } { "str3" "a string" } }
+{ $values { "string" string } { "string" string } { "string" string } }
 { $description "Computes the integer division of two Roman numerals." }
 { $examples 
     { $example "USING: io roman ;"
@@ -81,7 +81,7 @@ HELP: roman/i
 } ;
 
 HELP: roman/mod
-{ $values { "str1" "a string" } { "str2" "a string" } { "str3" "a string" } { "str4" "a string" } }
+{ $values { "string" string } { "string" string } { "string" string } { "string" string } }
 { $description "Computes the quotient and remainder of two Roman numerals." }
 { $examples 
     { $example "USING: kernel io roman ;"

basis/roman/roman-tests.factor

@@ -38,3 +38,9 @@ USING: arrays kernel math roman roman.private sequences tools.test ;
 [ "iii" "iii"  roman- ] must-fail
 
 [ 30 ] [ ROMAN: xxx ] unit-test
+
+[ roman+ ] must-infer
+[ roman- ] must-infer
+[ roman* ] must-infer
+[ roman/i ] must-infer
+[ roman/mod ] must-infer

basis/roman/roman.factor

@@ -1,29 +1,33 @@
 ! Copyright (C) 2007 Doug Coleman.
 ! See http://factorcode.org/license.txt for BSD license.
-USING: arrays assocs kernel math math.order math.vectors
+USING: accessors arrays assocs fry generalizations grouping
-namespaces make quotations sequences splitting.monotonic
+kernel lexer macros make math math.order math.vectors
-sequences.private strings unicode.case lexer parser
+namespaces parser quotations sequences sequences.private
-grouping ;
+splitting.monotonic stack-checker strings unicode.case
+words effects ;
 IN: roman
 
 <PRIVATE
 
-: roman-digits ( -- seq )
+CONSTANT: roman-digits
-    { "m" "cm" "d" "cd" "c" "xc" "l" "xl" "x" "ix" "v" "iv" "i" } ;
+    { "m" "cm" "d" "cd" "c" "xc" "l" "xl" "x" "ix" "v" "iv" "i" }
 
-: roman-values ( -- seq )
+CONSTANT: roman-values
-    { 1000 900 500 400 100 90 50 40 10 9 5 4 1 } ;
+    { 1000 900 500 400 100 90 50 40 10 9 5 4 1 }
 
 ERROR: roman-range-error n ;
 
 : roman-range-check ( n -- )
     dup 1 3999 between? [ drop ] [ roman-range-error ] if ;
 
+: roman-digit-index ( ch -- n )
+    1string roman-digits index ; inline
+
 : roman<= ( ch1 ch2 -- ? )
-    [ 1string roman-digits index ] bi@ >= ;
+    [ roman-digit-index ] bi@ >= ;
 
 : roman>n ( ch -- n )
-    1string roman-digits index roman-values nth ;
+    roman-digit-index roman-values nth ;
 
 : (>roman) ( n -- )
     roman-values roman-digits [
@@ -31,47 +35,39 @@ ERROR: roman-range-error n ;
     ] 2each drop ;
 
 : (roman>) ( seq -- n )
-    [ [ roman>n ] map ] [ all-eq? ] bi [
+    [ [ roman>n ] map ] [ all-eq? ] bi
-        sum
+    [ sum ] [ first2 swap - ] if ;
-    ] [
-        first2 swap -
-    ] if ;
 
 PRIVATE>
 
 : >roman ( n -- str )
-    dup roman-range-check
+    dup roman-range-check [ (>roman) ] "" make ;
-    [ (>roman) ] "" make ;
 
 : >ROMAN ( n -- str ) >roman >upper ;
 
 : roman> ( str -- n )
-    >lower [ roman<= ] monotonic-split
+    >lower [ roman<= ] monotonic-split [ (roman>) ] sigma ;
-    [ (roman>) ] sigma ;
 
 <PRIVATE
 
-: 2roman> ( str1 str2 -- m n )
+MACRO: binary-roman-op ( quot -- quot' )
-    [ roman> ] bi@ ;
+    [ infer in>> ] [ ] [ infer out>> ] tri
-
+    '[ [ roman> ] _ napply @ [ >roman ] _ napply ] ;
-: binary-roman-op ( str1 str2 quot -- str3 )
-    [ 2roman> ] dip call >roman ; inline
 
 PRIVATE>
 
-: roman+ ( str1 str2 -- str3 )
+<<
-    [ + ] binary-roman-op ;
+SYNTAX: ROMAN-OP:
+    scan-word [ name>> "roman" prepend create-in ] keep
+    1quotation '[ _ binary-roman-op ]
+    dup infer [ in>> ] [ out>> ] bi
+    [ "string" <repetition> ] bi@ <effect> define-declared ;
+>>
 
-: roman- ( str1 str2 -- str3 )
+ROMAN-OP: +
-    [ - ] binary-roman-op ;
+ROMAN-OP: -
-
+ROMAN-OP: *
-: roman* ( str1 str2 -- str3 )
+ROMAN-OP: /i
-    [ * ] binary-roman-op ;
+ROMAN-OP: /mod
-
-: roman/i ( str1 str2 -- str3 )
-    [ /i ] binary-roman-op ;
-
-: roman/mod ( str1 str2 -- str3 str4 )
-    [ /mod ] binary-roman-op [ >roman ] dip ;
 
 SYNTAX: ROMAN: scan roman> parsed ;

basis/sorting/human/human.factor

@@ -11,7 +11,7 @@ IN: sorting.human
 
 : human>=< ( obj1 obj2 -- >=< ) human<=> invert-comparison ; inline
 
-: human-compare ( obj1 obj2 quot -- <=> ) bi@ human<=> ;
+: human-compare ( obj1 obj2 quot -- <=> ) bi@ human<=> ; inline
 
 : human-sort ( seq -- seq' ) [ human<=> ] sort ;
 

basis/specialized-vectors/specialized-vectors-tests.factor

@@ -1,5 +1,9 @@
 IN: specialized-vectors.tests
-USING: specialized-vectors.double tools.test kernel sequences ;
+USING: specialized-arrays.float
+specialized-vectors.float
+specialized-vectors.double
+tools.test kernel sequences ;
 
 [ 3 ] [ double-vector{ 1 2 } 3 over push length ] unit-test
 
+[ t ] [ 10 float-array{ } new-resizable float-vector? ] unit-test

basis/stack-checker/transforms/transforms.factor

@@ -154,6 +154,15 @@ CONSTANT: bit-member-max 256
     dup sequence? [ memq-quot ] [ drop f ] if
 ] 1 define-transform
 
+! Index search
+\ index [
+    dup sequence? [
+        dup length 4 >= [
+            dup length zip >hashtable '[ _ at ]
+        ] [ drop f ] if
+    ] [ drop f ] if
+] 1 define-transform
+
 ! Shuffling
 : nths-quot ( indices -- quot )
     [ [ '[ _ swap nth ] ] map ] [ length ] bi

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/shaker/shaker.factor

@@ -157,6 +157,7 @@ IN: tools.deploy.shaker
                 "specializer"
                 "step-into"
                 "step-into?"
+                "superclass"
                 "transform-n"
                 "transform-quot"
                 "tuple-dispatch-generic"

basis/tools/scaffold/scaffold-docs.factor

@@ -26,7 +26,7 @@ HELP: scaffold-undocumented
 HELP: scaffold-vocab
 { $values
      { "vocab-root" "a vocabulary root string" } { "string" string } }
-{ $description "Creates a directory in the given root for a new vocabulary and adds a main .factor file, a tests file, and an authors.txt file." } ;
+{ $description "Creates a directory in the given root for a new vocabulary and adds a main .factor file and an authors.txt file." } ;
 
 HELP: scaffold-emacs
 { $description "Touches the .emacs file in your home directory and provides a clickable link to open it in an editor." } ;

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/gadgets/debug/debug.factor

@@ -58,7 +58,7 @@ M: metrics-paint draw-boundary
     COLOR: red gl-color
     [ dim>> ] [ >label< line-metrics ] bi
     [ [ first ] [ ascent>> ] bi* [ nip 0 swap 2array ] [ 2array ] 2bi gl-line ]
-    [ drop gl-rect ]
+    [ drop { 0 0 } swap gl-rect ]
     2bi ;
 
 : <metrics-gadget> ( text font -- gadget )

basis/ui/gadgets/editors/editors.factor

@@ -172,11 +172,10 @@ TUPLE: selected-line start end first? last? ;
 
 :: draw-selection ( line pair editor -- )
     pair [ editor font>> line offset>x ] map :> pair
-    pair first 0 2array [
+    editor selection-color>> gl-color
-        editor selection-color>> gl-color
+    pair first 0 2array
-        pair second pair first - round 1 max
+    pair second pair first - round 1 max editor line-height 2array
-        editor line-height 2array gl-fill-rect
+    gl-fill-rect ;
-    ] with-translation ;
 
 : draw-unselected-line ( line editor -- )
     font>> swap draw-text ;

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

@@ -3,9 +3,6 @@ namespaces math.rectangles accessors ui.gadgets.grids.private
 ui.gadgets.debug sequences ;
 IN: ui.gadgets.grids.tests
 
-[ { { { 1 "a" } { 1 "b" } } { { 2 "a" } { 2 "b" } } } ]
-[ { 1 2 } { "a" "b" } cross-zip ] unit-test
-
 [ { 0 0 } ] [ { } <grid> pref-dim ] unit-test
 
 : 100x100 ( -- gadget ) <gadget> { 100 100 } >>dim ;

basis/ui/gadgets/grids/grids.factor

@@ -1,6 +1,6 @@
 ! Copyright (C) 2006, 2009 Slava Pestov.
 ! See http://factorcode.org/license.txt for BSD license.
-USING: arrays kernel math math.order namespaces make sequences words io
+USING: arrays kernel math math.order math.matrices namespaces make sequences words io
 math.vectors ui.gadgets ui.baseline-alignment columns accessors strings.tables
 math.rectangles fry ;
 IN: ui.gadgets.grids
@@ -33,9 +33,6 @@ PRIVATE>
 
 <PRIVATE
 
-: cross-zip ( seq1 seq2 -- seq1xseq2 )
-    [ [ 2array ] with map ] curry map ;
-
 TUPLE: cell pref-dim baseline cap-height ;
 
 : <cell> ( gadget -- cell )
@@ -116,7 +113,7 @@ M: grid layout* [ grid>> ] [ <grid-layout> ] bi grid-layout ;
 
 M: grid children-on ( rect gadget -- seq )
     dup children>> empty? [ 2drop f ] [
-        { 0 1 } swap grid>>
+        [ { 0 1 } ] dip grid>>
         [ 0 <column> fast-children-on ] keep
         <slice> concat
     ] if ;

basis/ui/gadgets/panes/panes.factor

@@ -79,9 +79,7 @@ GENERIC: draw-selection ( loc obj -- )
 
 M: gadget draw-selection ( loc gadget -- )
     swap offset-rect [
-        dup loc>> [
+        rect-bounds gl-fill-rect
-            dim>> gl-fill-rect
-        ] with-translation
     ] if-fits ;
 
 M: node draw-selection ( loc node -- )

basis/ui/gadgets/tables/tables.factor

@@ -121,16 +121,15 @@ M: table layout*
     [ [ line-height ] dip * 0 swap 2array ]
     [ drop [ dim>> first ] [ line-height ] bi 2array ] 2bi <rect> ;
 
-: highlight-row ( table row color quot -- )
+: row-bounds ( table row -- loc dim )
-    [ [ row-rect rect-bounds ] dip gl-color ] dip
+    row-rect rect-bounds ; inline
-    '[ _ @ ] with-translation ; inline
 
 : draw-selected-row ( table -- )
     {
         { [ dup selected-index>> not ] [ drop ] }
         [
-            [ ] [ selected-index>> ] [ selection-color>> ] tri
+            [ ] [ selected-index>> ] [ selection-color>> gl-color ] tri
-            [ gl-fill-rect ] highlight-row
+            row-bounds gl-fill-rect
         ]
     } cond ;
 
@@ -139,14 +138,15 @@ M: table layout*
         { [ dup focused?>> not ] [ drop ] }
         { [ dup selected-index>> not ] [ drop ] }
         [
-            [ ] [ selected-index>> ] [ focus-border-color>> ] tri
+            [ ] [ selected-index>> ] [ focus-border-color>> gl-color ] tri
-            [ gl-rect ] highlight-row
+            row-bounds gl-rect
         ]
     } cond ;
 
 : draw-moused-row ( table -- )
     dup mouse-index>> dup [
-        over mouse-color>> [ gl-rect ] highlight-row
+        over mouse-color>> gl-color
+        row-bounds gl-rect
     ] [ 2drop ] if ;
 
 : column-line-offsets ( table -- xs )
@@ -279,7 +279,7 @@ PRIVATE>
 
 : row-action ( table -- )
     dup selected-row
-    [ swap [ action>> call ] [ dup hook>> call ] bi ]
+    [ swap [ action>> call( value -- ) ] [ dup hook>> call( table -- ) ] bi ]
     [ 2drop ]
     if ;
 

basis/ui/pens/solid/solid.factor

@@ -9,8 +9,8 @@ TUPLE: solid < caching-pen color interior-vertices boundary-vertices ;
 
 M: solid recompute-pen
     swap dim>>
-    [ (fill-rect-vertices) >>interior-vertices ]
+    [ [ { 0 0 } ] dip (fill-rect-vertices) >>interior-vertices ]
-    [ (rect-vertices) >>boundary-vertices ]
+    [ [ { 0 0 } ] dip (rect-vertices) >>boundary-vertices ]
     bi drop ;
 
 <PRIVATE

basis/ui/render/render.factor

@@ -38,7 +38,7 @@ SYMBOL: viewport-translation
     ! white gl-clear is broken w.r.t window resizing
     ! Linux/PPC Radeon 9200
     COLOR: white gl-color
-    clip get dim>> gl-fill-rect ;
+    { 0 0 } clip get dim>> gl-fill-rect ;
 
 GENERIC: draw-gadget* ( gadget -- )
 

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/listener/listener.factor

@@ -263,8 +263,9 @@ M: listener-operation invoke-command ( target command -- )
 
 : listener-run-files ( seq -- )
     [
-        [ \ listener-run-files ] dip
+        '[ _ [ run-file ] each ]
-        '[ _ [ run-file ] each ] call-listener
+        \ listener-run-files
+        call-listener
     ] unless-empty ;
 
 : com-end ( listener -- )

basis/ui/tools/operations/operations.factor

@@ -81,8 +81,6 @@ IN: ui.tools.operations
     { +listener+ t }
 } define-operation
 
-UNION: definition word method-spec link vocab vocab-link ;
-
 [ definition? ] \ edit H{
     { +keyboard+ T{ key-down f { C+ } "e" } }
     { +listener+ t }

basis/unicode/breaks/breaks-tests.factor

@@ -9,6 +9,9 @@ IN: unicode.breaks.tests
 [ 3 ] [ "\u001112\u001161\u0011abA\u000300a"
         dup last-grapheme head last-grapheme ] unit-test
 
+[ 3 ] [ 2 "hello" first-grapheme-from ] unit-test
+[ 1 ] [ 2 "hello" last-grapheme-from ] unit-test
+
 : grapheme-break-test ( -- filename )
     "vocab:unicode/breaks/GraphemeBreakTest.txt" ;
 

basis/unicode/breaks/breaks.factor

@@ -60,7 +60,7 @@ SYMBOL: table
 : finish-table ( -- table )
     table get [ [ 1 = ] map ] map ;
 
-: eval-seq ( seq -- seq ) [ dup word? [ execute ] when ] map ;
+: eval-seq ( seq -- seq ) [ ?execute ] map ;
 
 : (set-table) ( class1 class2 val -- )
     [ table get nth ] dip '[ _ or ] change-nth ;
@@ -101,6 +101,16 @@ PRIVATE>
     [ grapheme-class [ nip ] [ grapheme-break? ] 2bi ] find drop
     nip swap length or 1+ ;
 
+: first-grapheme-from ( start str -- i )
+    over tail-slice first-grapheme + ;
+
+: last-grapheme ( str -- i )
+    unclip-last-slice grapheme-class swap
+    [ grapheme-class dup rot grapheme-break? ] find-last drop ?1+ nip ;
+
+: last-grapheme-from ( end str -- i )
+    swap head-slice last-grapheme ;
+
 <PRIVATE
 
 : >pieces ( str quot: ( str -- i ) -- graphemes )
@@ -114,10 +124,6 @@ PRIVATE>
 : string-reverse ( str -- rts )
     >graphemes reverse concat ;
 
-: last-grapheme ( str -- i )
-    unclip-last-slice grapheme-class swap
-    [ grapheme-class dup rot grapheme-break? ] find-last drop ?1+ nip ;
-
 <PRIVATE
 
 graphemes init-table table

basis/xmode/code2html/code2html-tests.factor

@@ -18,4 +18,12 @@ kernel io.streams.string xml.writer ;
     <" int x = "hi";
 /* a comment */ "> <string-reader> htmlize-stream
     write-xml
+] unit-test
+
+[ "<span class=\"MARKUP\">: foo</span> <span class=\"MARKUP\">;</span>" ] [
+    { ": foo ;" } "factor" htmlize-lines xml>string
+] unit-test
+
+[ ":foo" ] [
+    { ":foo" } "factor" htmlize-lines xml>string
 ] unit-test

basis/xmode/marker/marker.factor

@@ -84,7 +84,7 @@ M: string-matcher text-matches?
     ] keep string>> length and ;
 
 M: regexp text-matches?
-    [ >string ] dip re-contains? ;
+    [ >string ] dip first-match dup [ to>> ] when ;
 
 : rule-start-matches? ( rule -- match-count/f )
     dup start>> tuck swap can-match-here? [

core/definitions/definitions.factor

@@ -3,6 +3,8 @@
 USING: kernel sequences namespaces assocs graphs math math.order ;
 IN: definitions
 
+MIXIN: definition
+
 ERROR: no-compilation-unit definition ;
 
 SYMBOLS: inlined-dependency flushed-dependency called-dependency ;

core/effects/parser/parser.factor

@@ -15,6 +15,7 @@ ERROR: bad-effect ;
                 scan {
                     { "(" [ ")" parse-effect ] }
                     { f [ ")" unexpected-eof ] }
+                    [ bad-effect ]
                 } case 2array
             ] when
         ] if
@@ -31,4 +32,4 @@ ERROR: bad-effect ;
     "(" expect ")" parse-effect ;
 
 : parse-call( ( accum word -- accum )
-    [ ")" parse-effect ] dip 2array over push-all ;
+    [ ")" parse-effect ] dip 2array over push-all ;

core/generic/generic.factor

@@ -1,4 +1,4 @@
-! Copyright (C) 2006, 2008 Slava Pestov.
+! Copyright (C) 2006, 2009 Slava Pestov.
 ! See http://factorcode.org/license.txt for BSD license.
 USING: accessors words kernel sequences namespaces make assocs
 hashtables definitions kernel.private classes classes.private
@@ -27,6 +27,8 @@ M: generic definition drop f ;
 PREDICATE: method-spec < pair
     first2 generic? swap class? and ;
 
+INSTANCE: method-spec definition
+
 : order ( generic -- seq )
     "methods" word-prop keys sort-classes ;
 

core/hashtables/hashtables.factor

@@ -79,7 +79,7 @@ TUPLE: hashtable
 : grow-hash ( hash -- )
     [ [ >alist ] [ assoc-size 1+ ] bi ] keep
     [ reset-hash ] keep
-    swap (rehash) ; inline
+    swap (rehash) ;
 
 : ?grow-hash ( hash -- )
     dup hash-large? [
@@ -95,7 +95,7 @@ TUPLE: hashtable
 PRIVATE>
 
 : <hashtable> ( n -- hash )
-    hashtable new [ reset-hash ] keep ;
+    hashtable new [ reset-hash ] keep ; inline
 
 M: hashtable at* ( key hash -- value ? )
     key@ [ 3 fixnum+fast slot t ] [ 2drop f f ] if ;

core/io/streams/sequence/sequence.factor

@@ -15,11 +15,10 @@ SLOT: i
     [ 1+ ] change-i drop ; inline
 
 : sequence-read1 ( stream -- elt/f )
-    [ >sequence-stream< ?nth ]
+    [ >sequence-stream< ?nth ] [ next ] bi ; inline
-    [ next ] bi ; inline
 
 : add-length ( n stream -- i+n )
-    [ i>> + ] [ underlying>> length ] bi min  ; inline
+    [ i>> + ] [ underlying>> length ] bi min ; inline
 
 : (sequence-read) ( n stream -- seq/f )
     [ add-length ] keep
@@ -32,8 +31,8 @@ SLOT: i
     [ (sequence-read) ] [ 2drop f ] if ; inline
 
 : find-sep ( seps stream -- sep/f n )
-    swap [ >sequence-stream< ] dip
+    swap [ >sequence-stream< swap tail-slice ] dip
-    [ memq? ] curry find-from swap ; inline
+    [ memq? ] curry find swap ; inline
 
 : sequence-read-until ( separators stream -- seq sep/f )
     [ find-sep ] keep

core/kernel/kernel.factor

@@ -23,6 +23,10 @@ GENERIC: call ( callable -- )
 
 GENERIC: execute ( word -- )
 
+GENERIC: ?execute ( word -- value )
+
+M: object ?execute ;
+
 DEFER: if
 
 : ? ( ? true false -- true/false )

core/namespaces/namespaces.factor

@@ -30,6 +30,6 @@ PRIVATE>
 : bind ( ns quot -- ) swap >n call ndrop ; inline
 : counter ( variable -- n ) global [ 0 or 1+ dup ] change-at ;
 : make-assoc ( quot exemplar -- hash ) 20 swap new-assoc [ swap bind ] keep ; inline
-: with-scope ( quot -- ) H{ } clone swap bind ; inline
+: with-scope ( quot -- ) 5 <hashtable> swap bind ; inline
 : with-variable ( value key quot -- ) [ associate ] dip bind ; inline
 : initialize ( variable quot -- ) [ global ] dip [ unless* ] curry change-at ; inline

core/syntax/syntax-docs.factor

@@ -556,18 +556,18 @@ HELP: BIN:
 { $examples { $example "USE: prettyprint" "BIN: 100 ." "4" } } ;
 
 HELP: GENERIC:
-{ $syntax "GENERIC: word" "GENERIC: word ( stack -- effect )" }
+{ $syntax "GENERIC: word ( stack -- effect )" }
 { $values { "word" "a new word to define" } }
 { $description "Defines a new generic word in the current vocabulary. Initially, it contains no methods, and thus will throw a " { $link no-method } " error when called." } ;
 
 HELP: GENERIC#
-{ $syntax "GENERIC# word n" "GENERIC# word n ( stack -- effect )" }
+{ $syntax "GENERIC# word n ( stack -- effect )" }
 { $values { "word" "a new word to define" } { "n" "the stack position to dispatch on" } }
 { $description "Defines a new generic word which dispatches on the " { $snippet "n" } "th most element from the top of the stack in the current vocabulary. Initially, it contains no methods, and thus will throw a " { $link no-method } " error when called." }
 { $notes
     "The following two definitions are equivalent:"
-    { $code "GENERIC: foo" }
+    { $code "GENERIC: foo ( obj -- )" }
-    { $code "GENERIC# foo 0" }
+    { $code "GENERIC# foo 0 ( obj -- )" }
 } ;
 
 HELP: MATH:
@@ -576,7 +576,7 @@ HELP: MATH:
 { $description "Defines a new generic word which uses the " { $link math-combination } " method combination." } ;
 
 HELP: HOOK:
-{ $syntax "HOOK: word variable" "HOOK: word variable ( stack -- effect ) " }
+{ $syntax "HOOK: word variable ( stack -- effect ) " }
 { $values { "word" "a new word to define" } { "variable" word } }
 { $description "Defines a new hook word in the current vocabulary. Hook words are generic words which dispatch on the value of a variable, so methods are defined with " { $link POSTPONE: M: } ". Hook words differ from other generic words in that the dispatch value is removed from the stack before the chosen method is called." }
 { $examples

core/syntax/syntax.factor

@@ -138,7 +138,7 @@ IN: bootstrap.syntax
     ] define-core-syntax
 
     "CONSTANT:" [
-        CREATE scan-object define-constant
+        CREATE-WORD scan-object define-constant
     ] define-core-syntax
 
     ":" [

core/vocabs/vocabs.factor

@@ -108,4 +108,6 @@ SYMBOL: load-vocab-hook ! ( name -- vocab )
 : load-vocab ( name -- vocab ) load-vocab-hook get call( name -- vocab ) ;
 
 PREDICATE: runnable-vocab < vocab
-    vocab-main >boolean ;
+    vocab-main >boolean ;
+
+INSTANCE: vocab-spec definition

core/words/alias/alias-tests.factor

@@ -0,0 +1,6 @@
+USING: math eval tools.test effects ;
+IN: words.alias.tests
+
+ALIAS: foo +
+[ ] [ "IN: words.alias.tests CONSTANT: foo 5" eval ] unit-test
+[ (( -- value )) ] [ \ foo stack-effect ] unit-test

core/words/words.factor

@@ -12,6 +12,8 @@ IN: words
 
 M: word execute (execute) ;
 
+M: word ?execute execute( -- value ) ;
+
 M: word <=>
     [ [ name>> ] [ vocabulary>> ] bi 2array ] compare ;
 
@@ -260,3 +262,5 @@ M: word hashcode*
 M: word literalize <wrapper> ;
 
 : xref-words ( -- ) all-words [ xref ] each ;
+
+INSTANCE: word definition

extra/bank/bank.factor

@@ -59,11 +59,11 @@ C: <transaction> transaction
         [ dup [ over [ swap call ] dip ] dip 1 days time+ ] dip each-day
     ] [
         3drop
-    ] if ;
+    ] if ; inline recursive
 
 : process-to-date ( account date -- account )
     over interest-last-paid>> 1 days time+
-    [ dupd process-day ] spin each-day ;
+    [ dupd process-day ] spin each-day ; inline
 
 : inserting-transactions ( account transactions -- account )
     [ [ date>> process-to-date ] keep >>transaction ] each ;

extra/cap/cap.factor

@@ -1,8 +1,8 @@
 ! Copyright (C) 2008 Doug Coleman, Joe Groff.
 ! See http://factorcode.org/license.txt for BSD license.
 USING: accessors arrays byte-arrays kernel math namespaces
-opengl.gl sequences math.vectors ui images images.viewer
+opengl.gl sequences math.vectors ui images images.normalization
-models ui.gadgets.worlds ui.gadgets fry alien.syntax ;
+images.viewer models ui.gadgets.worlds ui.gadgets fry alien.syntax ;
 IN: cap
 
 : screenshot-array ( world -- byte-array )

extra/game-input/game-input-tests.factor

@@ -1,8 +1,12 @@
 IN: game-input.tests
-USING: game-input tools.test kernel system threads ;
+USING: ui game-input tools.test kernel system threads
+combinators.short-circuit calendar ;
 
-os windows? os macosx? or [
+{
+    [ os windows? ui-running? and ]
+    [ os macosx? ]
+} 0|| [
     [ ] [ open-game-input ] unit-test
-    [ ] [ yield ] unit-test
+    [ ] [ 1 seconds sleep ] unit-test
     [ ] [ close-game-input ] unit-test
 ] when

extra/html/parser/parser.factor

@@ -1,10 +1,12 @@
 ! Copyright (C) 2008 Doug Coleman.
 ! See http://factorcode.org/license.txt for BSD license.
-USING: accessors arrays html.parser.utils hashtables io kernel
+USING: accessors arrays hashtables html.parser.state
-namespaces make prettyprint quotations sequences splitting
+html.parser.utils kernel make namespaces sequences
-html.parser.state strings unicode.categories unicode.case ;
+unicode.case unicode.categories combinators.short-circuit
+quoting ;
 IN: html.parser
 
+
 TUPLE: tag name attributes text closing? ;
 
 SINGLETON: text
@@ -28,116 +30,103 @@ SYMBOL: tagstack
 : make-tag ( string attribs -- tag )
     [ [ closing-tag? ] keep "/" trim1 ] dip rot <tag> ;
 
-: make-text-tag ( string -- tag )
+: new-tag ( string type -- tag )
     tag new
-        text >>name
+        swap >>name
-        swap >>text ;
+        swap >>text ; inline
 
-: make-comment-tag ( string -- tag )
+: make-text-tag ( string -- tag ) text new-tag ; inline
-    tag new
-        comment >>name
-        swap >>text ;
 
-: make-dtd-tag ( string -- tag )
+: make-comment-tag ( string -- tag ) comment new-tag ; inline
-    tag new
-        dtd >>name
-        swap >>text ;
 
-: read-whitespace ( -- string )
+: make-dtd-tag ( string -- tag ) dtd new-tag ; inline
-    [ get-char blank? not ] take-until ;
 
-: read-whitespace* ( -- ) read-whitespace drop ;
+: read-single-quote ( state-parser -- string )
+    [ [ CHAR: ' = ] take-until ] [ next drop ] bi ;
 
-: read-token ( -- string )
+: read-double-quote ( state-parser -- string )
-    read-whitespace*
+    [ [ CHAR: " = ] take-until ] [ next drop ] bi ;
-    [ get-char blank? ] take-until ;
 
-: read-single-quote ( -- string )
+: read-quote ( state-parser -- string )
-    [ get-char CHAR: ' = ] take-until ;
+    dup get+increment CHAR: ' =
+    [ read-single-quote ] [ read-double-quote ] if ;
 
-: read-double-quote ( -- string )
+: read-key ( state-parser -- string )
-    [ get-char CHAR: " = ] take-until ;
+    skip-whitespace
+    [ { [ CHAR: = = ] [ blank? ] } 1|| ] take-until ;
 
-: read-quote ( -- string )
+: read-= ( state-parser -- )
-    get-char next CHAR: ' =
+    skip-whitespace
-    [ read-single-quote ] [ read-double-quote ] if next ;
+    [ [ CHAR: = = ] take-until drop ] [ next drop ] bi ;
 
-: read-key ( -- string )
+: read-token ( state-parser -- string )
-    read-whitespace*
+    [ blank? ] take-until ;
-    [ get-char [ CHAR: = = ] [ blank? ] bi or ] take-until ;
 
-: read-= ( -- )
+: read-value ( state-parser -- string )
-    read-whitespace*
+    skip-whitespace
-    [ get-char CHAR: = = ] take-until drop next ;
+    dup get-char quote? [ read-quote ] [ read-token ] if
-
-: read-value ( -- string )
-    read-whitespace*
-    get-char quote? [ read-quote ] [ read-token ] if
     [ blank? ] trim ;
 
-: read-comment ( -- )
+: read-comment ( state-parser -- )
-    "-->" take-string make-comment-tag push-tag ;
+    "-->" take-until-sequence make-comment-tag push-tag ;
 
-: read-dtd ( -- )
+: read-dtd ( state-parser -- )
-    ">" take-string make-dtd-tag push-tag ;
+    ">" take-until-sequence make-dtd-tag push-tag ;
 
-: read-bang ( -- )
+: read-bang ( state-parser -- )
-    next get-char CHAR: - = get-next CHAR: - = and [
+    next dup { [ get-char CHAR: - = ] [ get-next CHAR: - = ] } 1&& [
         next next
         read-comment
     ] [
         read-dtd
     ] if ;
 
-: read-tag ( -- string )
+: read-tag ( state-parser -- string )
-    [ get-char CHAR: > = get-char CHAR: < = or ] take-until
+    [ [ "><" member? ] take-until ]
-    get-char CHAR: < = [ next ] unless ;
+    [ dup get-char CHAR: < = [ next ] unless drop ] bi ;
 
-: read-< ( -- string )
+: read-until-< ( state-parser -- string )
-    next get-char CHAR: ! = [
+    [ CHAR: < = ] take-until ;
-        read-bang f
+
+: parse-text ( state-parser -- )
+    read-until-< [ make-text-tag push-tag ] unless-empty ;
+
+: (parse-attributes) ( state-parser -- )
+    skip-whitespace
+    dup state-parse-end? [
+        drop
     ] [
-        read-tag
+        [
+            [ read-key >lower ] [ read-= ] [ read-value ] tri
+            2array ,
+        ] keep (parse-attributes)
     ] if ;
 
-: read-until-< ( -- string )
+: parse-attributes ( state-parser -- hashtable )
-    [ get-char CHAR: < = ] take-until ;
-
-: parse-text ( -- )
-    read-until-< [
-        make-text-tag push-tag
-    ] unless-empty ;
-
-: (parse-attributes) ( -- )
-    read-whitespace*
-    string-parse-end? [
-        read-key >lower read-= read-value
-        2array , (parse-attributes)
-    ] unless ;
-
-: parse-attributes ( -- hashtable )
     [ (parse-attributes) ] { } make >hashtable ;
 
 : (parse-tag) ( string -- string' hashtable )
     [
-        read-token >lower
+        [ read-token >lower ] [ parse-attributes ] bi
-        parse-attributes
+    ] state-parse ;
-    ] string-parse ;
 
-: parse-tag ( -- )
+: read-< ( state-parser -- string/f )
-    read-< [
+    next dup get-char [
-        (parse-tag) make-tag push-tag
+        CHAR: ! = [ read-bang f ] [ read-tag ] if
-    ] unless-empty ;
+    ] [
+        drop f
+    ] if* ;
 
-: (parse-html) ( -- )
+: parse-tag ( state-parser -- )
-    get-next [
+    read-< [ (parse-tag) make-tag push-tag ] unless-empty ;
-        parse-text
+
-        parse-tag
+: (parse-html) ( state-parser -- )
-        (parse-html)
+    dup get-next [
-    ] when ;
+        [ parse-text ] [ parse-tag ] [ (parse-html) ] tri
+    ] [ drop ] if ;
 
 : tag-parse ( quot -- vector )
-    V{ } clone tagstack [ string-parse ] with-variable ; inline
+    V{ } clone tagstack [ state-parse ] with-variable ; inline
 
 : parse-html ( string -- vector )
     [ (parse-html) tagstack get ] tag-parse ;

extra/html/parser/state/state-tests.factor

@@ -1,14 +1,36 @@
-USING: tools.test html.parser.state ascii kernel ;
+USING: tools.test html.parser.state ascii kernel accessors ;
 IN: html.parser.state.tests
 
-: take-rest ( -- string )
+[ "hello" ]
-    [ f ] take-until ;
+[ "hello" [ take-rest ] state-parse ] unit-test
 
-: take-char ( -- string )
+[ "hi" " how are you?" ]
-    [ get-char = ] curry take-until ;
+[
+    "hi how are you?"
+    [ [ [ blank? ] take-until ] [ take-rest ] bi ] state-parse
+] unit-test
+
+[ "foo" ";bar" ]
+[
+    "foo;bar" [
+        [ CHAR: ; take-until-object ] [ take-rest ] bi
+    ] state-parse
+] unit-test
 
-[ "hello" ] [ "hello" [ take-rest ] string-parse ] unit-test
-[ "hi" " how are you?" ] [ "hi how are you?" [ [ get-char blank? ] take-until take-rest ] string-parse ] unit-test
-[ "foo" ";bar" ] [ "foo;bar" [ CHAR: ; take-char take-rest ] string-parse ] unit-test
 [ "foo " " bar" ]
-[ "foo and bar" [ "and" take-string take-rest ] string-parse ] unit-test
+[
+    "foo and bar" [
+        [ "and" take-until-sequence ] [ take-rest ] bi 
+    ] state-parse
+] unit-test
+
+[ 6 ]
+[
+    "      foo   " [ skip-whitespace n>> ] state-parse
+] unit-test
+
+[ { 1 2 } ]
+[ { 1 2 3 } <state-parser> [ 3 = ] take-until ] unit-test
+
+[ { 1 2 } ]
+[ { 1 2 3 4 } <state-parser> { 3 4 } take-until-sequence ] unit-test

extra/html/parser/state/state.factor

@@ -1,41 +1,67 @@
 ! Copyright (C) 2005, 2009 Daniel Ehrenberg
 ! See http://factorcode.org/license.txt for BSD license.
-USING: namespaces math kernel sequences accessors fry circular ;
+USING: namespaces math kernel sequences accessors fry circular
+unicode.case unicode.categories locals ;
+
 IN: html.parser.state
 
-TUPLE: state string i ;
+TUPLE: state-parser sequence n ;
 
-: get-i ( -- i ) state get i>> ; inline
+: <state-parser> ( sequence -- state-parser )
+    state-parser new
+        swap >>sequence
+        0 >>n ;
 
-: get-char ( -- char )
+: (get-char) ( n state -- char/f )
-    state get [ i>> ] [ string>> ] bi ?nth ; inline
+    sequence>> ?nth ; inline
 
-: get-next ( -- char )
+: get-char ( state -- char/f )
-    state get [ i>> 1+ ] [ string>> ] bi ?nth ; inline
+    [ n>> ] keep (get-char) ; inline
 
-: next ( -- )
+: get-next ( state -- char/f )
-    state get [ 1+ ] change-i drop ; inline
+    [ n>> 1 + ] keep (get-char) ; inline
 
-: string-parse ( string quot -- )
+: next ( state -- state )
-    [ 0 state boa state ] dip with-variable ; inline
+    [ 1 + ] change-n ; inline
 
-: short* ( n seq -- n' seq )
+: get+increment ( state -- char/f )
-    over [ nip dup length swap ] unless ; inline
+    [ get-char ] [ next drop ] bi ; inline
 
-: skip-until ( quot: ( -- ? ) -- )
+: state-parse ( sequence quot -- )
-    get-char [
+    [ <state-parser> ] dip call ; inline
-        [ call ] keep swap
-        [ drop ] [ next skip-until ] if
-    ] [ drop ] if ; inline recursive
 
-: take-until ( quot: ( -- ? ) -- )
+:: skip-until ( state quot: ( obj -- ? ) -- )
-    get-i [ skip-until ] dip get-i
+    state get-char [
-    state get string>> subseq ; inline
+        quot call [ state next quot skip-until ] unless
+    ] when* ; inline recursive
 
-: string-matches? ( string circular -- ? )
+: state-parse-end? ( state -- ? ) get-next not ;
-    get-char over push-growing-circular sequence= ; inline
 
-: take-string ( match -- string )
+: take-until ( state quot: ( obj -- ? ) -- sequence/f )
-    dup length <growing-circular>
+    over state-parse-end? [
-    [ 2dup string-matches? ] take-until nip
+        2drop f
-    dup length rot length 1- - head next ; inline
+    ] [
+        [ drop n>> ]
+        [ skip-until ]
+        [ drop [ n>> ] [ sequence>> ] bi ] 2tri subseq
+    ] if ; inline
+
+:: take-until-sequence ( state-parser sequence -- sequence' )
+    sequence length <growing-circular> :> growing
+    state-parser
+    [
+        growing push-growing-circular
+        sequence growing sequence=
+    ] take-until :> found
+    found dup length
+    growing length 1- - head
+    state-parser next drop ;
+    
+: skip-whitespace ( state -- state )
+    [ [ blank? not ] take-until drop ] keep ;
+
+: take-rest ( state -- sequence )
+    [ drop f ] take-until ; inline
+
+: take-until-object ( state obj -- sequence )
+    '[ _ = ] take-until ;

extra/html/parser/utils/utils-tests.factor

@@ -1,20 +1,13 @@
 USING: assocs combinators continuations hashtables
 hashtables.private io kernel math
 namespaces prettyprint quotations sequences splitting
-strings tools.test ;
+strings tools.test html.parser.utils quoting ;
-USING: html.parser.utils ;
 IN: html.parser.utils.tests
 
 [ "'Rome'" ] [ "Rome" single-quote ] unit-test
 [ "\"Roma\"" ] [ "Roma" double-quote ] unit-test
 [ "'Firenze'" ] [ "Firenze" quote ] unit-test
 [ "\"Caesar's\"" ] [ "Caesar's" quote ] unit-test
-[ 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
 [ "'Italy'" ] [ "Italy" ?quote ] unit-test
 [ "'Italy'" ] [ "'Italy'" ?quote ] unit-test
 [ "\"Italy\"" ] [ "\"Italy\"" ?quote ] unit-test

extra/html/parser/utils/utils.factor

@@ -3,16 +3,12 @@
 USING: assocs circular combinators continuations hashtables
 hashtables.private io kernel math namespaces prettyprint
 quotations sequences splitting html.parser.state strings
-combinators.short-circuit ;
+combinators.short-circuit quoting ;
 IN: html.parser.utils
 
-: string-parse-end? ( -- ? ) get-next not ;
-
 : trim1 ( seq ch -- newseq )
     [ [ ?head-slice drop ] [ ?tail-slice drop ] bi ] 2keep drop like ;
 
-: quote? ( ch -- ? ) "'\"" member? ;
-
 : single-quote ( str -- newstr ) "'" dup surround ;
 
 : double-quote ( str -- newstr ) "\"" dup surround ;
@@ -21,14 +17,4 @@ IN: html.parser.utils
     CHAR: ' over member?
     [ double-quote ] [ single-quote ] if ;
 
-: quoted? ( str -- ? )
-    {
-        [ length 1 > ]
-        [ first quote? ]
-        [ [ first ] [ peek ] bi = ]
-    } 1&& ;
-
 : ?quote ( str -- newstr ) dup quoted? [ quote ] unless ;
-
-: unquote ( str -- newstr )
-    dup quoted? [ but-last-slice rest-slice >string ] when ;

extra/id3/id3-docs.factor

@@ -1,23 +1,113 @@
 ! Copyright (C) 2008 Tim Wawrzynczak
 ! See http://factorcode.org/license.txt for BSD license.
-USING: help.markup help.syntax sequences kernel accessors ;
+USING: help.markup help.syntax sequences kernel accessors
+id3.private strings ;
 IN: id3
 
-HELP: file-id3-tags
+HELP: mp3>id3
 { $values 
     { "path" "a path string" } 
     { "id3v2-info/f" "a tuple storing ID3v2 metadata or f" } }
-    { $description "Return a tuple containing the ID3 information parsed out of the MP3 file, or " { $link f } " if no metadata is present.  Currently, the parser supports the following tags: "
+    { $description "Return a tuple containing the ID3 information parsed out of the MP3 file, or " { $link f } " if no metadata is present. Words to access the ID3v1 information are here:"
-      $nl { $link title>> }
+        { $list
-      $nl { $link artist>> }
+          { $link title }
-      $nl { $link album>> }
+          { $link artist }
-      $nl { $link year>> }
+          { $link album }
-      $nl { $link genre>> }
+          { $link year }
-      $nl { $link comment>> } } ;
+          { $link genre }
+          { $link comment }
+        }
+        "For other fields, use the " { $link find-id3-frame } " word."
+    } ;
+
+HELP: album
+{ $values
+    { "id3" id3v2-info }
+    { "album/f" "string or f" }
+}
+{ $description "Returns the album, or " { $link f } " if this field is missing, from a parsed id3 tag." } ;
+
+HELP: artist
+{ $values
+    { "id3" id3v2-info }
+    { "artist/f" "string or f" }
+}
+{ $description "Returns the artist, or " { $link f } " if this field is missing, from a parsed id3 tag." } ;
+
+HELP: comment
+{ $values
+    { "id3" id3v2-info }
+    { "comment/f" "string or f" }
+}
+{ $description "Returns the comment, or " { $link f } " if this field is missing, from a parsed id3 tag." } ;
+
+HELP: genre
+{ $values
+    { "id3" id3v2-info }
+    { "genre/f" "string or f" }
+}
+{ $description "Returns the genre, or " { $link f } " if this field is missing, from a parsed id3 tag." } ;
+
+HELP: title
+{ $values
+    { "id3" id3v2-info }
+    { "title/f" "string or f" }
+}
+{ $description "Returns the title, or " { $link f } " if this field is missing, from a parsed id3 tag." } ;
+
+HELP: year
+{ $values
+    { "id3" id3v2-info }
+    { "year/f" "string or f" }
+}
+{ $description "Returns the year, or " { $link f } " if this field is missing, from a parsed id3 tag." } ;
+
+HELP: find-id3-frame
+{ $values
+    { "id3" id3v2-info } { "name" string }
+    { "obj/f" "object or f" }
+}
+{ $description "Returns the " { $slot "data" } " slot of the ID3 frame with the given name, or " { $link f } "." } ;
+
+HELP: mp3-paths>id3s
+{ $values
+    { "seq" sequence }
+    { "seq'" sequence }
+}
+{ $description "From a sequence of pathnames, parses each ID3 header and returns a sequence of key/value pairs of pathnames and ID3 objects." } ;
+
+HELP: find-mp3s
+{ $values
+    { "path" "a pathname string" }
+    { "seq" sequence }
+}
+{ $description "Returns a sequence of MP3 pathnames from a directory and all of its subdirectories." } ;
+
+HELP: parse-mp3-directory
+{ $values
+    { "path" "a pathname string" }
+    { "seq" sequence }
+}
+{ $description "Returns a sequence of key/value pairs where the key is the path of an MP3 and the value is the parsed ID3 header or " { $link f } " recursively for each MP3 file in the directory and all subdirectories." } ;
 
 ARTICLE: "id3" "ID3 tags"
 "The " { $vocab-link "id3" } " vocabulary contains words for parsing " { $emphasis "ID3" } " tags, which are textual fields storing an MP3's title, artist, and other metadata." $nl
-"Parsing ID3 tags from an MP3 file:"
+"Parsing ID3 tags for a directory of MP3s, recursively:"
-{ $subsection file-id3-tags } ;
+{ $subsection parse-mp3-directory }
+"Finding MP3 files recursively:"
+{ $subsection find-mp3s }
+"Parsing a sequence of MP3 pathnames:"
+{ $subsection mp3-paths>id3s }
+"Parsing an MP3 file's ID3 tags:"
+{ $subsection mp3>id3 }
+"ID3v1 frame tag accessors:"
+{ $subsection album }
+{ $subsection artist }
+{ $subsection comment }
+{ $subsection genre }
+{ $subsection title }
+{ $subsection year }
+"Access any frame tag:"
+{ $subsection find-id3-frame } ;
 
 ABOUT: "id3"

extra/id3/id3-tests.factor

@@ -5,12 +5,12 @@ IN: id3.tests
 
 : id3-params ( id3 -- title artist album year comment genre )
     {
-        [ id3-title ]
+        [ title ]
-        [ id3-artist ]
+        [ artist ]
-        [ id3-album ]
+        [ album ]
-        [ id3-year ]
+        [ year ]
-        [ id3-comment ]
+        [ comment ]
-        [ id3-genre ]
+        [ genre ]
     } cleave ;
 
 [
@@ -20,7 +20,7 @@ IN: id3.tests
    "2009"
    "COMMENT"
    "Bluegrass"
-] [ "vocab:id3/tests/blah.mp3" file-id3-tags id3-params ] unit-test
+] [ "vocab:id3/tests/blah.mp3" mp3>id3 id3-params ] unit-test
 
 [
     "Anthem of the Trinity"
@@ -29,7 +29,7 @@ IN: id3.tests
     f
     f
     "Classical"
-] [ "vocab:id3/tests/blah2.mp3" file-id3-tags id3-params ] unit-test
+] [ "vocab:id3/tests/blah2.mp3" mp3>id3 id3-params ] unit-test
 
 [    
    "Stormy Weather"
@@ -38,5 +38,5 @@ IN: id3.tests
     f
    "eng, AG# 08E1C12E"
    "Big Band"
-] [ "vocab:id3/tests/blah3.mp3" file-id3-tags id3-params ] unit-test
+] [ "vocab:id3/tests/blah3.mp3" mp3>id3 id3-params ] unit-test
 

extra/id3/id3.factor

@@ -48,15 +48,14 @@ TUPLE: id3v2-info header frames ;
 
 TUPLE: id3v1-info title artist album year comment genre ;
 
-: <id3v1-info> ( -- object ) id3v1-info new ;
+: <id3v1-info> ( -- object ) id3v1-info new ; inline
 
 : <id3v2-info> ( header frames -- object )
-    [ [ frame-id>> ] keep ] H{ } map>assoc
+    [ [ frame-id>> ] keep ] H{ } map>assoc id3v2-info boa ;
-    id3v2-info boa ;
 
-: <header> ( -- object ) header new ;
+: <header> ( -- object ) header new ; inline
 
-: <frame> ( -- object ) frame new ;
+: <frame> ( -- object ) frame new ; inline
 
 : id3v2? ( mmap -- ? ) "ID3" head? ; inline
 
@@ -66,7 +65,7 @@ TUPLE: id3v1-info title artist album year comment genre ;
 : id3v1-frame ( string key -- frame )
     <frame>
         swap >>frame-id
-        swap >>data ;
+        swap >>data ; inline
 
 : id3v1>id3v2 ( id3v1 -- id3v2 )
     [
@@ -78,7 +77,7 @@ TUPLE: id3v1-info title artist album year comment genre ;
             [ comment>> "COMM" id3v1-frame ]
             [ genre>> "TCON" id3v1-frame ]
         } cleave
-    ] output>array f swap <id3v2-info> ;
+    ] output>array f swap <id3v2-info> ; inline
 
 : >28bitword ( seq -- int )
     0 [ [ 7 shift ] dip bitor ] reduce ; inline
@@ -104,11 +103,11 @@ TUPLE: id3v1-info title artist album year comment genre ;
         [ [ 4 8 ] dip subseq >28bitword >>size ]
         [ [ 8 10 ] dip subseq >byte-array >>flags ]
         [ read-frame-data decode-text >>data ]
-    } cleave ;
+    } cleave ; inline
 
 : read-frame ( mmap -- frame/f )
     dup 4 head-slice valid-frame-id?
-    [ (read-frame) ] [ drop f ] if ;
+    [ (read-frame) ] [ drop f ] if ; inline
 
 : remove-frame ( mmap frame -- mmap )
     size>> 10 + tail-slice ; inline
@@ -116,10 +115,8 @@ TUPLE: id3v1-info title artist album year comment genre ;
 : read-frames ( mmap -- frames )
     [ dup read-frame dup ]
     [ [ remove-frame ] keep ]
-    produce 2nip ;
+    produce 2nip ; inline
     
-! header stuff
-
 : read-v2-header ( seq -- id3header )
     [ <header> ] dip
     {
@@ -133,8 +130,6 @@ TUPLE: id3v1-info title artist album year comment genre ;
     [ read-v2-header ]
     [ read-frames ] bi* <id3v2-info> ; inline
     
-! v1 information
-
 : skip-to-v1-data ( seq -- seq ) 125 tail-slice* ; inline
 
 : (read-v1-tag-data) ( seq -- mp3-file )
@@ -159,28 +154,7 @@ TUPLE: id3v1-info title artist album year comment genre ;
         drop
     ] if ; inline
 
-PRIVATE>
+: (mp3>id3) ( path -- id3v2-info/f )
-
-: frame-named ( id3 name quot -- obj )
-    [ swap frames>> at* ] dip
-    [ data>> ] prepose [ drop f ] if ; inline
-
-: id3-title ( id3 -- title/f ) "TIT2" [ ] frame-named ; inline
-
-: id3-artist ( id3 -- artist/f ) "TPE1" [ ] frame-named ; inline
-
-: id3-album ( id3 -- album/f ) "TALB" [ ] frame-named ; inline
-
-: id3-year ( id3 -- year/f ) "TYER" [ ] frame-named ; inline
-
-: id3-comment ( id3 -- comment/f ) "COMM" [ ] frame-named ; inline
-
-: id3-genre ( id3 -- genre/f )
-    "TCON" [ parse-genre ] frame-named ; inline
-
-: id3-frame ( id3 key -- value/f ) [ ] frame-named ; inline
-
-: (file-id3-tags) ( path -- id3v2-info/f )
     [
         {
             { [ dup id3v2? ] [ read-v2-tag-data ] }
@@ -189,9 +163,36 @@ PRIVATE>
         } cond
     ] with-mapped-uchar-file ;
 
-: file-id3-tags ( path -- id3v2-info/f )
+: (find-id3-frame) ( id3 name quot: ( obj -- obj' ) -- obj' )
-    dup file-info size>> 0 <= [ drop f ] [ (file-id3-tags) ] if ;
+    [ swap frames>> at* ] dip
+    [ data>> ] prepose [ drop f ] if ; inline
 
-: parse-id3s ( path -- seq )
+PRIVATE>
-    [ >lower ".mp3" tail? ] find-all-files
+
-    [ dup file-id3-tags ] { } map>assoc ;
+: mp3>id3 ( path -- id3v2-info/f )
+    dup file-info size>> 0 <= [ drop f ] [ (mp3>id3) ] if ; inline
+
+: find-id3-frame ( id3 name -- obj/f )
+    [ ] (find-id3-frame) ; inline
+
+: title ( id3 -- title/f ) "TIT2" find-id3-frame ; inline
+
+: artist ( id3 -- artist/f ) "TPE1" find-id3-frame ; inline
+
+: album ( id3 -- album/f ) "TALB" find-id3-frame ; inline
+
+: year ( id3 -- year/f ) "TYER" find-id3-frame ; inline
+
+: comment ( id3 -- comment/f ) "COMM" find-id3-frame ; inline
+
+: genre ( id3 -- genre/f )
+    "TCON" [ parse-genre ] (find-id3-frame) ; inline
+
+: find-mp3s ( path -- seq )
+    [ >lower ".mp3" tail? ] find-all-files ; inline
+
+: mp3-paths>id3s ( seq -- seq' )
+    [ dup mp3>id3 ] { } map>assoc ; inline
+
+: parse-mp3-directory ( path -- seq )
+    find-mp3s mp3-paths>id3s ;

extra/irc/client/client.factor

@@ -165,7 +165,7 @@ M: irc-chat to-chat in-messages>> mailbox-put ;
     " hostname servername :irc.factor" irc-print ;
 
 : /CONNECT ( server port -- stream )
-    irc> connect>> call drop ;
+    irc> connect>> call drop ; inline
 
 : /JOIN ( channel password -- )
     "JOIN " irc-write

extra/math/matrices/matrices-tests.factor

@@ -104,3 +104,6 @@ USING: math.matrices math.vectors tools.test math ;
 [ { 0 1 0 } ] [ { 0 0 1 } { 1 0 0 } cross ] unit-test
 
 [ { 1 0 0 } ] [ { 1 1 0 } { 1 0 0 } proj ] unit-test
+
+[ { { { 1 "a" } { 1 "b" } } { { 2 "a" } { 2 "b" } } } ]
+[ { 1 2 } { "a" "b" } cross-zip ] unit-test

extra/math/matrices/matrices.factor

@@ -1,4 +1,4 @@
-! Copyright (C) 2005, 2008 Slava Pestov.
+! Copyright (C) 2005, 2009 Slava Pestov.
 ! See http://factorcode.org/license.txt for BSD license.
 USING: arrays kernel math math.order math.vectors sequences ;
 IN: math.matrices
@@ -57,3 +57,6 @@ PRIVATE>
 
 : norm-gram-schmidt ( seq -- orthonormal )
     gram-schmidt [ normalize ] map ;
+
+: cross-zip ( seq1 seq2 -- seq1xseq2 )
+    [ [ 2array ] with map ] curry map ;

extra/spider/spider-docs.factor

@@ -16,11 +16,6 @@ HELP: run-spider
      { "spider" spider } }
 { $description "Runs a spider until completion. See the " { $subsection "spider-tutorial" } " for a complete description of the tuple slots that affect how thet spider works." } ;
 
-HELP: slurp-heap-while
-{ $values
-     { "heap" "a heap" } { "quot1" quotation } { "quot2" quotation } }
-{ $description "Removes values from a heap that match the predicate quotation " { $snippet "quot1" } " and processes them with " { $snippet "quot2" } " until the predicate quotation no longer matches." } ;
-
 ARTICLE: "spider-tutorial" "Spider tutorial"
 "To create a new spider, call the " { $link <spider> } " word with a link to the site you wish to spider."
 { $code <" "http://concatenative.org" <spider> "> }

extra/spider/spider.factor

@@ -3,8 +3,8 @@
 USING: accessors fry html.parser html.parser.analyzer
 http.client kernel tools.time sets assocs sequences
 concurrency.combinators io threads namespaces math multiline
-heaps math.parser inspector urls assoc-heaps logging
+math.parser inspector urls logging combinators.short-circuit
-combinators.short-circuit continuations calendar prettyprint ;
+continuations calendar prettyprint dlists deques locals ;
 IN: spider
 
 TUPLE: spider base count max-count sleep max-depth initial-links
@@ -13,12 +13,33 @@ filters spidered todo nonmatching quiet ;
 TUPLE: spider-result url depth headers fetch-time parsed-html
 links processing-time timestamp ;
 
+TUPLE: todo-url url depth ;
+
+: <todo-url> ( url depth -- todo-url )
+    todo-url new
+        swap >>depth
+        swap >>url ;
+
+TUPLE: unique-deque assoc deque ;
+
+: <unique-deque> ( -- unique-deque )
+    H{ } clone <dlist> unique-deque boa ;
+
+: push-url ( url depth unique-deque -- )
+    [ <todo-url> ] dip
+    [ [ [ t ] dip url>> ] [ assoc>> ] bi* set-at ]
+    [ deque>> push-back ] 2bi ;
+
+: pop-url ( unique-deque -- todo-url ) deque>> pop-front ;
+
+: peek-url ( unique-deque -- todo-url ) deque>> peek-front ;
+
 : <spider> ( base -- spider )
     >url
     spider new
         over >>base
-        swap 0 <unique-min-heap> [ heap-push ] keep >>todo
+        swap 0 <unique-deque> [ push-url ] keep >>todo
-        <unique-min-heap> >>nonmatching
+        <unique-deque> >>nonmatching
         0 >>max-depth
         0 >>count
         1/0. >>max-count
@@ -27,10 +48,10 @@ links processing-time timestamp ;
 <PRIVATE
 
 : apply-filters ( links spider -- links' )
-    filters>> [ '[ _ 1&& ] filter ] when* ;
+    filters>> [ '[ [ _ 1&& ] filter ] call( seq -- seq' ) ] when* ;
 
-: push-links ( links level assoc-heap -- )
+: push-links ( links level unique-deque -- )
-    '[ _ _ heap-push ] each ;
+    '[ _ _ push-url ] each ;
 
 : add-todo ( links level spider -- )
     todo>> push-links ;
@@ -38,64 +59,72 @@ links processing-time timestamp ;
 : add-nonmatching ( links level spider -- )
     nonmatching>> push-links ;
 
-: filter-base ( spider spider-result -- base-links nonmatching-links )
+: filter-base-links ( spider spider-result -- base-links nonmatching-links )
     [ base>> host>> ] [ links>> prune ] bi*
     [ host>> = ] with partition ;
 
 : add-spidered ( spider spider-result -- )
     [ [ 1+ ] change-count ] dip
     2dup [ spidered>> ] [ dup url>> ] bi* rot set-at
-    [ filter-base ] 2keep
+    [ filter-base-links ] 2keep
     depth>> 1+ swap
     [ add-nonmatching ]
     [ tuck [ apply-filters ] 2dip add-todo ] 2bi ;
 
-: normalize-hrefs ( links -- links' )
+: normalize-hrefs ( links spider -- links' )
-    [ >url ] map
+    [ [ >url ] map ] dip
-    spider get base>> swap [ derive-url ] with map ;
+    base>> swap [ derive-url ] with map ;
 
 : print-spidering ( url depth -- )
     "depth: " write number>string write
     ", spidering: " write . yield ;
 
-: (spider-page) ( url depth -- spider-result )
+:: new-spidered-result ( spider url depth -- spider-result )
-    f pick spider get spidered>> set-at
+    f url spider spidered>> set-at
-    over '[ _ http-get ] benchmark swap
+    [ url http-get ] benchmark :> fetch-time :> html :> headers
-    [ parse-html dup find-hrefs normalize-hrefs ] benchmark
+    [
+        html parse-html [ ] [ find-hrefs spider normalize-hrefs ] bi
+    ] benchmark :> processing-time :> links :> parsed-html
+    url depth headers fetch-time parsed-html links processing-time
     now spider-result boa ;
 
-: spider-page ( url depth -- )
+:: spider-page ( spider url depth -- )
-    spider get quiet>> [ 2dup print-spidering ] unless
+    spider quiet>> [ url depth print-spidering ] unless
-    (spider-page)
+    spider url depth new-spidered-result :> spidered-result
-    spider get [ quiet>> [ dup describe ] unless ]
+    spider quiet>> [ spidered-result describe ] unless
-    [ swap add-spidered ] bi ;
+    spider spidered-result add-spidered ;
 
 \ spider-page ERROR add-error-logging
 
-: spider-sleep ( -- )
+: spider-sleep ( spider -- )
-    spider get sleep>> [ sleep ] when* ;
+    sleep>> [ sleep ] when* ;
 
-: queue-initial-links ( spider -- spider )
+:: queue-initial-links ( spider -- spider )
-    [ initial-links>> normalize-hrefs 0 ] keep
+    spider initial-links>> spider normalize-hrefs 0 spider add-todo spider ;
-    [ add-todo ] keep ;
 
-: slurp-heap-while ( heap quot1 quot2: ( value key -- ) -- )
+: spider-page? ( spider -- ? )
-    pick heap-empty? [ 3drop ] [
+    {
-        [ [ heap-pop dup ] 2dip slip [ t ] compose [ 2drop f ] if ]
+        [ todo>> deque>> deque-empty? not ]
-        [ roll [ slurp-heap-while ] [ 3drop ] if ] 3bi
+        [ [ todo>> peek-url depth>> ] [ max-depth>> ] bi < ]
-    ] if ; inline recursive
+        [ [ count>> ] [ max-count>> ] bi < ]
+    } 1&& ;
+
+: setup-next-url ( spider -- spider url depth )
+    dup todo>> pop-url [ url>> ] [ depth>> ] bi ;
+
+: spider-next-page ( spider -- )
+    setup-next-url spider-page ;
 
 PRIVATE>
 
+: run-spider-loop ( spider -- )
+    dup spider-page? [
+        [ spider-next-page ] [ run-spider-loop ] bi
+    ] [
+        drop
+    ] if ;
+
 : run-spider ( spider -- spider )
     "spider" [
-        dup spider [
+        queue-initial-links [ run-spider-loop ] keep
-            queue-initial-links
-            [ todo>> ] [ max-depth>> ] bi
-            '[
-                _ <= spider get
-                [ count>> ] [ max-count>> ] bi < and
-            ] [ spider-page spider-sleep ] slurp-heap-while
-            spider get
-        ] with-variable
     ] with-logging ;

extra/tetris/gl/gl.factor

@@ -8,7 +8,7 @@ IN: tetris.gl
 #! OpenGL rendering for tetris
 
 : draw-block ( block -- )
-    [ { 1 1 } gl-fill-rect ] with-translation ;
+    { 1 1 } gl-fill-rect ;
 
 : draw-piece-blocks ( piece -- )
     piece-blocks [ draw-block ] each ;

extra/ui/gadgets/lists/lists.factor

@@ -57,9 +57,7 @@ M: list draw-gadget*
     origin get [
         dup color>> gl-color
         selected-rect [
-            dup loc>> [
+            rect-bounds gl-fill-rect
-                dim>> gl-fill-rect
-            ] with-translation
         ] when*
     ] with-translation ;
 

extra/webapps/wiki/wiki-common.xml

@@ -20,7 +20,7 @@
 								</t:a>
 							</h2>
 
-							<t:farkup t:name="parsed" t:parsed="true" />
+							<t:farkup t:name="content" />
 						</t:bind>
 					</div>
 				</td>
@@ -58,7 +58,7 @@
 			<tr>
 				<td colspan="2" class="footer">
 					<t:bind t:name="footer">
-						<t:farkup t:name="parsed" t:parsed="true" />
+						<t:farkup t:name="content" />
 					</t:bind>
 				</td>
 			</tr>

vm/Config.linux.x86.64

@@ -1,4 +1,3 @@
 include vm/Config.linux
 include vm/Config.x86.64
 LIBPATH = -L/usr/X11R6/lib64 -L/usr/X11R6/lib
-FFI_TEST_CFLAGS = -fPIC