Merge branch 'master' of git://factorcode.org/git/factor into clean-linux-x86-32

Makefile

@@ -162,11 +162,11 @@ factor-console: $(DLL_OBJS) $(EXE_OBJS)
 		$(CFLAGS) $(CFLAGS_CONSOLE) -o factor$(EXE_SUFFIX)$(CONSOLE_EXTENSION) $(EXE_OBJS)
 
 factor-ffi-test: vm/ffi_test.o
-	$(CC) $(LIBPATH) $(CFLAGS) $(FFI_TEST_CFLAGS) $(SHARED_FLAG) -o libfactor-ffi-test$(DLL_EXTENSION) $(TEST_OBJS)
+	$(CC) $(LIBPATH) $(CFLAGS) $(FFI_TEST_CFLAGS) $(SHARED_FLAG) -o libfactor-ffi-test$(SHARED_DLL_EXTENSION) $(TEST_OBJS)
 
 clean:
 	rm -f vm/*.o
-	rm -f factor*.dll libfactor.{a,so,dylib}
+	rm -f factor*.dll libfactor.{a,so,dylib} libfactor-ffi-test.{a,so,dylib}
 
 vm/resources.o:
 	$(WINDRES) vm/factor.rs vm/resources.o

basis/bootstrap/ui/ui.factor

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

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

@@ -13,7 +13,7 @@ IN: compiler.tests
     {
         { [ os winnt? ]  [ "libfactor-ffi-test.dll" ] }
         { [ os macosx? ] [ "libfactor-ffi-test.dylib" ] }
-        { [ os unix?  ]  [ "libfactor-ffi-test.a" ] }
+        { [ os unix?  ]  [ "libfactor-ffi-test.so" ] }
     } cond append-path ;
 
 "f-cdecl" libfactor-ffi-tests-path "cdecl" add-library

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

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

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

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 [
+            [ nip rest ] dip
             "}]" take-until
             [ code boa ] dip swap
+        ] [ drop take-line make-paragraph ] if*
     ] if ;
 
 : parse-item ( state -- state' item )

basis/hints/hints.factor

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

basis/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
@@ -20,5 +20,3 @@ M: ascii encode-char
 
 M: ascii decode-char
     128 decode-if< ;
-
-ascii "ANSI_X3.4-1968" register-encoding

basis/io/encodings/iana/iana.factor

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

basis/math/blas/ffi/ffi.factor

@@ -7,6 +7,10 @@ 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? ] [ 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/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 
@@ -368,14 +378,15 @@ M: ebnf-tokenizer (transform) ( ast -- parser )
   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 )
@@ -467,13 +478,17 @@ ERROR: bad-effect quot effect ;
     [ bad-effect ]
   } cond ;
 
+: ebnf-transform ( ast -- parser quot )
+  [ parser>> (transform) ]
+  [ code>> insert-escapes ]
+  [ parser>> ] tri build-locals  
+  [ string-lines parse-lines ] call( string -- quot ) ;
+ 
 M: ebnf-action (transform) ( ast -- parser )
-  [ parser>> (transform) ] [ code>> insert-escapes ] [ parser>> ] tri build-locals  
+  ebnf-transform check-action-effect action ;
-  [ string-lines parse-lines ] call( string -- quot ) check-action-effect action ;
 
 M: ebnf-semantic (transform) ( ast -- parser )
-  [ parser>> (transform) ] [ code>> insert-escapes ] [ parser>> ] tri build-locals 
+  ebnf-transform semantic ;
-  [ string-lines parse-lines ] call( string -- quot ) semantic ;
 
 M: ebnf-var (transform) ( ast -- parser )
   parser>> (transform) ;
@@ -481,19 +496,20 @@ M: ebnf-var (transform) ( ast -- parser )
 M: ebnf-terminal (transform) ( ast -- parser )
   symbol>> tokenizer one>> call( symbol -- parser ) ;
 
+ERROR: ebnf-foreign-not-found name ;
+
+M: ebnf-foreign-not-found summary
+  name>> "Foreign word '" "' not found" surround ;
+
 M: ebnf-foreign (transform) ( ast -- parser )
-  dup word>> search
+  dup word>> search [ word>> ebnf-foreign-not-found ] unless*
-  [ "Foreign word '" swap word>> append "' not found" append throw ] unless*
   swap rule>> [ main ] unless* over rule [
     nip
   ] [
     execute( -- parser )
   ] if* ;
 
-: parser-not-found ( name -- * )
+ERROR: parser-not-found name ;
-  [
-    "Parser '" % % "' not found." %
-  ] "" make throw ;
 
 M: ebnf-non-terminal (transform) ( ast -- parser )
   symbol>>  [
@@ -504,16 +520,16 @@ M: ebnf-non-terminal (transform) ( ast -- parser )
   'ebnf' parse transform ;
 
 : check-parse-result ( result -- result )
-  dup [
+  [
-    dup remaining>> [ blank? ] trim empty? [
+    dup remaining>> [ blank? ] trim [
       [ 
         "Unable to fully parse EBNF. Left to parse was: " %
         remaining>> % 
       ] "" make throw
-    ] unless
+    ] unless-empty
   ] [
     "Could not parse EBNF" throw
-  ] if ;
+  ] if* ;
 
 : parse-ebnf ( string -- hashtable )
   'ebnf' (parse) check-parse-result ast>> transform ;
@@ -522,14 +538,18 @@ M: ebnf-non-terminal (transform) ( ast -- parser )
   parse-ebnf dup dup parser [ main swap at compile ] with-variable
   [ compiled-parse ] curry [ with-scope ast>> ] curry ;
 
-SYNTAX: <EBNF "EBNF>" reset-tokenizer parse-multiline-string parse-ebnf main swap at  
+SYNTAX: <EBNF
+  "EBNF>"
+  reset-tokenizer parse-multiline-string parse-ebnf main swap at  
   parsed reset-tokenizer ;
 
-SYNTAX: [EBNF "EBNF]" reset-tokenizer parse-multiline-string ebnf>quot nip 
+SYNTAX: [EBNF
+  "EBNF]"
+  reset-tokenizer parse-multiline-string ebnf>quot nip 
   parsed \ call parsed reset-tokenizer ;
 
 SYNTAX: EBNF: 
   reset-tokenizer CREATE-WORD dup ";EBNF" parse-multiline-string  
-  ebnf>quot swapd (( input -- ast )) define-declared "ebnf-parser" set-word-prop 
+  ebnf>quot swapd
+  (( input -- ast )) define-declared "ebnf-parser" set-word-prop 
   reset-tokenizer ;
-

basis/peg/peg.factor

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

basis/quoting/quoting-tests.factor

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

basis/regexp/compiler/compiler.factor

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

basis/roman/roman.factor

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

basis/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/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-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/worlds/worlds.factor

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

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

@@ -18,12 +18,11 @@ M: core-text-renderer string-dim
     [ cached-line dim>> ]
     if-empty ;
 
-M: core-text-renderer finish-text-rendering
+M: core-text-renderer flush-layout-cache
-    text-handle>> purge-cache
     cached-lines get purge-cache ;
 
 : rendered-line ( font string -- texture )
-    world get text-handle>>
+    world get world-text-handle
     [ cached-line [ image>> ] [ loc>> ] bi <texture> ]
     2cache ;
 

basis/ui/text/pango/pango.factor

@@ -14,12 +14,11 @@ M: pango-renderer string-dim
     [ " " string-dim { 0 1 } v* ]
     [ cached-layout logical-rect>> dim>> [ >integer ] map ] if-empty ;
 
-M: pango-renderer finish-text-rendering
+M: pango-renderer flush-layout-cache
-    text-handle>> purge-cache
     cached-layouts get purge-cache ;
 
 : rendered-layout ( font string -- texture )
-    world get text-handle>>
+    world get world-text-handle
     [ cached-layout [ image>> ] [ text-position vneg ] bi <texture> ]
     2cache ;
 

basis/ui/text/text.factor

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

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

@@ -4,8 +4,7 @@ USING: arrays assocs io kernel math models namespaces make dlists
 deques sequences threads sequences words continuations init
 combinators hashtables concurrency.flags sets accessors calendar fry
 destructors ui.gadgets ui.gadgets.private ui.gadgets.worlds
-ui.gadgets.tracks ui.gestures ui.backend ui.render ui.text
+ui.gadgets.tracks ui.gestures ui.backend ui.render ;
-ui.text.private ;
 IN: ui
 
 <PRIVATE
@@ -63,7 +62,7 @@ M: world graft*
 : (ungraft-world) ( world -- )
     {
         [ handle>> select-gl-context ]
-        [ text-handle>> dispose ]
+        [ text-handle>> [ dispose ] when* ]
         [ images>> [ dispose ] when* ]
         [ hand-clicked close-global ]
         [ hand-gadget close-global ]
@@ -95,8 +94,7 @@ M: world ungraft*
 : restore-world ( world -- )
     {
         [ reset-world ]
-        [ init-text-rendering ]
+        [ f >>text-handle f >>images drop ]
-        [ f >>images drop ]
         [ restore-gadget ]
     } cleave ;
 

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

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

@@ -19,3 +19,11 @@ kernel io.streams.string xml.writer ;
 /* 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/effects/parser/parser.factor

@@ -15,6 +15,7 @@ ERROR: bad-effect ;
                 scan {
                     { "(" [ ")" parse-effect ] }
                     { f [ ")" unexpected-eof ] }
+                    [ bad-effect ]
                 } case 2array
             ] when
         ] if

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

@@ -97,7 +97,7 @@ ERROR: bad-slot-value value class ;
     "writing" associate ;
 
 : define-writer-generic ( name -- )
-    writer-word (( object value -- )) define-simple-generic ;
+    writer-word (( value object -- )) define-simple-generic ;
 
 : define-writer ( class slot-spec -- )
     [ nip name>> define-writer-generic ] [

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

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/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,9 +115,7 @@ 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/smalltalk/ast/ast.factor

@@ -0,0 +1,53 @@
+! Copyright (C) 2009 Slava Pestov.
+! See http://factorcode.org/license.txt for BSD license.
+USING: strings arrays memoize kernel sequences accessors combinators ;
+IN: smalltalk.ast
+
+SINGLETONS: nil self super ;
+
+TUPLE: ast-comment { string string } ;
+TUPLE: ast-block { arguments array } { temporaries array } { body array } ;
+TUPLE: ast-message-send receiver { selector string } { arguments array } ;
+TUPLE: ast-message { selector string } { arguments array } ;
+TUPLE: ast-cascade receiver { messages array } ;
+TUPLE: ast-name { name string } ;
+TUPLE: ast-return value ;
+TUPLE: ast-assignment { name ast-name } value ;
+TUPLE: ast-local-variables { names array } ;
+TUPLE: ast-method { name string } { body ast-block } ;
+TUPLE: ast-class { name string } { superclass string } { ivars array } { methods array } ;
+TUPLE: ast-foreign { class string } { name string } ;
+TUPLE: ast-sequence { temporaries array } { body array } ;
+
+! We treat a sequence of statements like a block in a few places to
+! simplify handling of top-level forms
+M: ast-sequence arguments>> drop { } ;
+
+: unclip-temporaries ( statements -- temporaries statements' )
+    {
+        { [ dup empty? ] [ { } ] }
+        { [ dup first ast-local-variables? not ] [ { } ] }
+        [ unclip names>> ]
+    } cond swap ;
+
+: <ast-block> ( arguments body -- block )
+    unclip-temporaries ast-block boa ;
+
+: <ast-sequence> ( body -- block )
+    unclip-temporaries ast-sequence boa ;
+
+! The parser parses normal message sends as cascades with one message, but
+! we represent them differently in the AST to simplify generated code in
+! the common case
+: <ast-cascade> ( receiver messages -- ast )
+    dup length 1 =
+    [ first [ selector>> ] [ arguments>> ] bi ast-message-send boa ]
+    [ ast-cascade boa ]
+    if ;
+
+! Methods return self by default
+: <ast-method> ( class arguments body -- method )
+    self suffix <ast-block> ast-method boa ;
+
+TUPLE: symbol { name string } ;
+MEMO: intern ( name -- symbol ) symbol boa ;

extra/smalltalk/ast/authors.txt

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

extra/smalltalk/authors.txt

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

extra/smalltalk/classes/authors.txt

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

extra/smalltalk/classes/classes.factor

@@ -0,0 +1,25 @@
+! Copyright (C) 2009 Slava Pestov.
+! See http://factorcode.org/license.txt for BSD license.
+USING: kernel namespaces assocs accessors words sequences classes.tuple ;
+IN: smalltalk.classes
+
+SYMBOL: classes
+
+classes [ H{ } clone ] initialize
+
+: create-class ( class -- class )
+    "smalltalk.classes" create ;
+
+ERROR: no-class name ;
+
+: lookup-class ( class -- class )
+    classes get ?at [ ] [ no-class ] if ;
+
+: define-class ( class superclass ivars -- class-word )
+    [ create-class ] [ lookup-class ] [ ] tri*
+    [ define-tuple-class ] [ 2drop dup dup name>> classes get set-at ] 3bi ;
+
+: define-foreign ( class name -- )
+    classes get set-at ;
+
+tuple "Object" define-foreign

extra/smalltalk/compiler/assignment/assignment.factor

@@ -0,0 +1,36 @@
+! Copyright (C) 2009 Slava Pestov.
+! See http://factorcode.org/license.txt for BSD license.
+USING: accessors arrays kernel sequences sets smalltalk.ast ;
+IN: smalltalk.compiler.assignment
+
+GENERIC: assigned-locals ( ast -- seq )
+
+M: ast-return assigned-locals value>> assigned-locals ;
+
+M: ast-block assigned-locals
+    [ body>> assigned-locals ] [ arguments>> ] bi diff ;
+
+M: ast-message-send assigned-locals
+    [ receiver>> assigned-locals ]
+    [ arguments>> assigned-locals ]
+    bi append ;
+
+M: ast-cascade assigned-locals
+    [ receiver>> assigned-locals ]
+    [ messages>> assigned-locals ]
+    bi append ;
+
+M: ast-message assigned-locals
+    arguments>> assigned-locals ;
+
+M: ast-assignment assigned-locals
+    [ name>> dup ast-name? [ name>> 1array ] [ drop { } ] if ]
+    [ value>> assigned-locals ] bi append ;
+
+M: ast-sequence assigned-locals
+    body>> assigned-locals ;
+
+M: array assigned-locals
+    [ assigned-locals ] map concat ;
+
+M: object assigned-locals drop f ;

extra/smalltalk/compiler/assignment/authors.txt

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

extra/smalltalk/compiler/authors.txt

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

extra/smalltalk/compiler/compiler-tests.factor

@@ -0,0 +1,87 @@
+USING: smalltalk.compiler tools.test prettyprint smalltalk.ast
+smalltalk.compiler.lexenv stack-checker locals.rewrite.closures
+kernel accessors compiler.units sequences arrays ;
+IN: smalltalk.compiler.tests
+
+: test-compilation ( ast -- quot )
+    [
+        1array ast-sequence new swap >>body
+        compile-smalltalk [ call ] append
+    ] with-compilation-unit ;
+
+: test-inference ( ast -- in# out# )
+    test-compilation infer [ in>> ] [ out>> ] bi ;
+
+[ 2 1 ] [
+    T{ ast-block f
+       { "a" "b" }
+       {
+           T{ ast-message-send f
+              T{ ast-name f "a" }
+              "+"
+              { T{ ast-name f "b" } }
+           }
+       }
+    } test-inference
+] unit-test
+
+[ 3 1 ] [
+    T{ ast-block f
+       { "a" "b" "c" }
+       {
+           T{ ast-assignment f
+              T{ ast-name f "a" }
+              T{ ast-message-send f
+                 T{ ast-name f "c" }
+                 "+"
+                 { T{ ast-name f "b" } }
+              }
+           }
+           T{ ast-message-send f
+              T{ ast-name f "b" }
+              "blah:"
+              { 123.456 }
+           }
+           T{ ast-return f T{ ast-name f "c" } }
+       }
+    } test-inference
+] unit-test
+
+[ 0 1 ] [
+    T{ ast-block f
+       { }
+       { }
+       {
+           T{ ast-message-send
+              { receiver 1 }
+              { selector "to:do:" }
+              { arguments
+                {
+                    10
+                    T{ ast-block
+                       { arguments { "i" } }
+                       { body
+                         {
+                             T{ ast-message-send
+                                { receiver
+                                  T{ ast-name { name "i" } }
+                                }
+                                { selector "print" }
+                             }
+                         }
+                       }
+                    }
+                }
+              }
+           }
+       }
+    } test-inference
+] unit-test
+
+[ "a" ] [
+    T{ ast-block f
+       { }
+       { }
+       { { T{ ast-block { body { "a" } } } } }
+    } test-compilation call first call
+] unit-test

extra/smalltalk/compiler/compiler.factor

@@ -0,0 +1,157 @@
+! Copyright (C) 2009 Slava Pestov.
+! See http://factorcode.org/license.txt for BSD license.
+USING: accessors arrays assocs combinators.short-circuit
+continuations fry kernel namespaces quotations sequences sets
+generalizations slots locals.types splitting math
+locals.rewrite.closures generic words combinators locals smalltalk.ast
+smalltalk.compiler.lexenv smalltalk.compiler.assignment
+smalltalk.compiler.return smalltalk.selectors smalltalk.classes ;
+IN: smalltalk.compiler
+
+GENERIC: compile-ast ( lexenv ast -- quot )
+
+M: object compile-ast nip 1quotation ;
+
+M: self compile-ast drop self>> 1quotation ;
+
+ERROR: unbound-local name ;
+
+M: ast-name compile-ast name>> swap lookup-reader ;
+
+: compile-arguments ( lexenv ast -- quot )
+    arguments>> [ compile-ast ] with map [ ] join ;
+
+: compile-new ( lexenv ast -- quot )
+    [ receiver>> compile-ast ]
+    [ compile-arguments ] 2bi
+    [ new ] 3append ;
+
+: compile-ifTrue:ifFalse: ( lexenv ast -- quot )
+    [ receiver>> compile-ast ]
+    [ compile-arguments ] 2bi
+    [ if ] 3append ;
+
+M: ast-message-send compile-ast
+    dup selector>> {
+        { "ifTrue:ifFalse:" [ compile-ifTrue:ifFalse: ] }
+        { "new" [ compile-new ] }
+        [
+            drop
+            [ compile-arguments ]
+            [ receiver>> compile-ast ]
+            [ nip selector>> selector>generic ]
+            2tri [ append ] dip suffix
+        ]
+    } case ;
+
+M: ast-cascade compile-ast
+    [ receiver>> compile-ast ]
+    [
+        messages>> [
+            [ compile-arguments \ dip ]
+            [ selector>> selector>generic ] bi
+            [ ] 3sequence
+        ] with map
+        unclip-last [ [ [ drop ] append ] map ] dip suffix
+        cleave>quot
+    ] 2bi append ;
+
+M: ast-return compile-ast
+    [ value>> compile-ast ] [ drop return>> 1quotation ] 2bi
+    [ continue-with ] 3append ;
+
+: (compile-sequence) ( lexenv asts -- quot )
+    [ drop [ nil ] ] [
+        [ compile-ast ] with map [ drop ] join
+    ] if-empty ;
+
+: block-lexenv ( block -- lexenv )
+    [ [ arguments>> ] [ temporaries>> ] bi append ]
+    [ body>> [ assigned-locals ] map concat unique ] bi
+    '[
+        dup dup _ key?
+        [ <local-reader> ]
+        [ <local> ]
+        if
+    ] H{ } map>assoc
+    dup
+    [ nip local-reader? ] assoc-filter
+    [ <local-writer> ] assoc-map
+    <lexenv> swap >>local-writers swap >>local-readers ;
+
+: lookup-block-vars ( vars lexenv -- seq )
+    local-readers>> '[ _ at ] map ;
+
+: make-temporaries ( block lexenv -- quot )
+    [ temporaries>> ] dip lookup-block-vars
+    [ <def> [ f ] swap suffix ] map [ ] join ;
+
+:: compile-sequence ( lexenv block -- vars quot )
+    lexenv block block-lexenv lexenv-union :> lexenv
+    block arguments>> lexenv lookup-block-vars
+    lexenv block body>> (compile-sequence) block lexenv make-temporaries prepend ;
+
+M: ast-sequence compile-ast
+    compile-sequence nip ;
+
+GENERIC: contains-blocks? ( obj -- ? )
+
+M: ast-block contains-blocks? drop t ;
+
+M: object contains-blocks? drop f ;
+
+M: array contains-blocks? [ contains-blocks? ] any? ;
+
+M: array compile-ast
+    dup contains-blocks? [
+        [ [ compile-ast ] with map [ ] join ] [ length ] bi
+        '[ @ _ narray ]
+    ] [ call-next-method ] if ;
+
+GENERIC: compile-assignment ( lexenv name -- quot )
+
+M: ast-name compile-assignment name>> swap lookup-writer ;
+
+M: ast-assignment compile-ast
+    [ value>> compile-ast [ dup ] ] [ name>> compile-assignment ] 2bi 3append ;
+
+M: ast-block compile-ast
+    compile-sequence <lambda> '[ _ ] ;
+
+:: (compile-method-body) ( lexenv block -- lambda )
+    lexenv block compile-sequence
+    [ lexenv self>> suffix ] dip <lambda> ;
+
+: compile-method-body ( lexenv block -- quot )
+    [ [ (compile-method-body) ] [ arguments>> length 1+ ] bi ] 2keep
+    make-return ;
+
+: compile-method ( lexenv ast-method -- )
+    [ [ class>> ] [ name>> selector>generic ] bi* create-method ]
+    [ body>> compile-method-body ]
+    2bi define ;
+
+: <class-lexenv> ( class -- lexenv )
+    <lexenv> swap >>class "self" <local> >>self "^" <local> >>return ;
+
+M: ast-class compile-ast
+    nip
+    [
+        [ name>> ] [ superclass>> ] [ ivars>> ] tri
+        define-class <class-lexenv> 
+    ]
+    [ methods>> ] bi
+    [ compile-method ] with each
+    [ nil ] ;
+
+ERROR: no-word name ;
+
+M: ast-foreign compile-ast
+    nip
+    [ class>> dup ":" split1 lookup [ ] [ no-word ] ?if ]
+    [ name>> ] bi define-foreign
+    [ nil ] ;
+
+: compile-smalltalk ( statement -- quot )
+    [ empty-lexenv ] dip [ compile-sequence nip 0 ]
+    2keep make-return ;

extra/smalltalk/compiler/lexenv/authors.txt

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

extra/smalltalk/compiler/lexenv/lexenv-tests.factor

@@ -0,0 +1,24 @@
+USING: smalltalk.compiler.lexenv tools.test kernel namespaces accessors ;
+IN: smalltalk.compiler.lexenv.tests
+
+TUPLE: some-class x y z ;
+
+SYMBOL: fake-self
+
+SYMBOL: fake-local
+
+<lexenv>
+    some-class >>class
+    fake-self >>self
+    H{ { "mumble" fake-local } } >>local-readers
+    H{ { "jumble" fake-local } } >>local-writers
+lexenv set
+
+[ [ fake-local ] ] [ "mumble" lexenv get lookup-reader ] unit-test
+[ [ fake-self x>> ] ] [ "x" lexenv get lookup-reader ] unit-test
+[ [ \ tuple ] ] [ "Object" lexenv get lookup-reader ] unit-test
+
+[ [ fake-local ] ] [ "jumble" lexenv get lookup-writer ] unit-test
+[ [ fake-self (>>y) ] ] [ "y" lexenv get lookup-writer ] unit-test
+
+[ "blahblah" lexenv get lookup-writer ] must-fail

extra/smalltalk/compiler/lexenv/lexenv.factor

@@ -0,0 +1,67 @@
+! Copyright (C) 2009 Slava Pestov.
+! See http://factorcode.org/license.txt for BSD license.
+USING: assocs kernel accessors quotations slots words
+sequences namespaces combinators combinators.short-circuit
+summary smalltalk.classes ;
+IN: smalltalk.compiler.lexenv
+
+! local-readers: assoc string => word
+! local-writers: assoc string => word
+! self: word or f for top-level forms
+! class: class word or f for top-level forms
+! method: generic word or f for top-level forms
+TUPLE: lexenv local-readers local-writers self return class method ;
+
+: <lexenv> ( -- lexenv ) lexenv new ; inline
+
+CONSTANT: empty-lexenv T{ lexenv }
+
+: lexenv-union ( lexenv1 lexenv2 -- lexenv )
+    [ <lexenv> ] 2dip {
+        [ [ local-readers>> ] bi@ assoc-union >>local-readers ]
+        [ [ local-writers>> ] bi@ assoc-union >>local-writers ]
+        [ [ self>> ] either? >>self ]
+        [ [ return>> ] either? >>return ]
+        [ [ class>> ] either? >>class ]
+        [ [ method>> ] either? >>method ]
+    } 2cleave ;
+
+: local-reader ( name lexenv -- local )
+    local-readers>> at dup [ 1quotation ] when ;
+
+: ivar-reader ( name lexenv -- quot/f )
+    dup class>> [
+        [ class>> "slots" word-prop slot-named ] [ self>> ] bi
+        swap dup [ name>> reader-word [ ] 2sequence ] [ 2drop f ] if
+    ] [ 2drop f ] if ;
+
+: class-name ( name -- quot/f )
+    classes get at dup [ [ ] curry ] when ;
+
+ERROR: bad-identifier name ;
+
+M: bad-identifier summary drop "Unknown identifier" ;
+
+: lookup-reader ( name lexenv -- reader-quot )
+    {
+        [ local-reader ]
+        [ ivar-reader ]
+        [ drop class-name ]
+        [ drop bad-identifier ]
+    } 2|| ;
+
+: local-writer ( name lexenv -- local )
+    local-writers>> at dup [ 1quotation ] when ;
+
+: ivar-writer ( name lexenv -- quot/f )
+    dup class>> [
+        [ class>> "slots" word-prop slot-named ] [ self>> ] bi
+        swap dup [ name>> writer-word [ ] 2sequence ] [ 2drop f ] if
+    ] [ 2drop f ] if ;
+
+: lookup-writer ( name lexenv -- writer-quot )
+    {
+        [ local-writer ]
+        [ ivar-writer ]
+        [ drop bad-identifier ]
+    } 2|| ;

extra/smalltalk/compiler/return/authors.txt

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

extra/smalltalk/compiler/return/return-tests.factor

@@ -0,0 +1,3 @@
+USING: smalltalk.parser smalltalk.compiler.return tools.test ;
+
+[ t ] [ "(i <= 1) ifTrue: [^1] ifFalse: [^((Fib new i:(i-1)) compute + (Fib new i:(i-2)) compute)]" parse-smalltalk need-return-continuation? ] unit-test

extra/smalltalk/compiler/return/return.factor

@@ -0,0 +1,45 @@
+! Copyright (C) 2009 Slava Pestov.
+! See http://factorcode.org/license.txt for BSD license.
+USING: accessors arrays combinators.short-circuit continuations
+fry generalizations kernel locals locals.types locals.rewrite.closures
+namespaces make sequences smalltalk.ast ;
+IN: smalltalk.compiler.return
+
+SYMBOL: return-continuation
+
+GENERIC: need-return-continuation? ( ast -- ? )
+
+M: ast-return need-return-continuation? drop t ;
+
+M: ast-block need-return-continuation? body>> need-return-continuation? ;
+
+M: ast-message-send need-return-continuation?
+    {
+        [ receiver>> need-return-continuation? ]
+        [ arguments>> need-return-continuation? ]
+    } 1|| ;
+
+M: ast-cascade need-return-continuation?
+    {
+        [ receiver>> need-return-continuation? ]
+        [ messages>> need-return-continuation? ]
+    } 1|| ;
+
+M: ast-message need-return-continuation?
+    arguments>> need-return-continuation? ;
+
+M: ast-assignment need-return-continuation?
+    value>> need-return-continuation? ;
+
+M: ast-sequence need-return-continuation?
+    body>> need-return-continuation? ;
+
+M: array need-return-continuation? [ need-return-continuation? ] any? ;
+
+M: object need-return-continuation? drop f ;
+
+:: make-return ( quot n lexenv block -- quot )
+    block need-return-continuation? [
+        quot clone [ lexenv return>> <def> '[ _ ] prepend ] change-body
+        n '[ _ _ ncurry callcc1 ]
+    ] [ quot ] if rewrite-closures first ;

extra/smalltalk/eval/authors.txt

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

extra/smalltalk/eval/eval-tests.factor

@@ -0,0 +1,11 @@
+IN: smalltalk.eval.tests
+USING: smalltalk.eval tools.test io.streams.string kernel ;
+
+[ 3 ] [ "1+2" eval-smalltalk ] unit-test
+[ "HAI" ] [ "(1<10) ifTrue:['HAI'] ifFalse:['BAI']" eval-smalltalk ] unit-test
+[ 7 ] [ "1+2+3;+4" eval-smalltalk ] unit-test
+[ 6 "5\n6\n" ] [ [ "[:x|x print] value: 5; value: 6" eval-smalltalk ] with-string-writer ] unit-test
+[ 5 ] [ "|x| x:=5. x" eval-smalltalk ] unit-test
+[ 11 ] [ "[:i| |x| x:=5. i+x] value: 6" eval-smalltalk ] unit-test
+[ t ] [ "class Blah [method foo [5]]. Blah new foo" eval-smalltalk tuple? ] unit-test
+[ 196418 ] [ "vocab:smalltalk/eval/fib.st" eval-smalltalk-file ] unit-test

extra/smalltalk/eval/eval.factor

@@ -0,0 +1,13 @@
+! Copyright (C) 2009 Slava Pestov.
+! See http://factorcode.org/license.txt for BSD license.
+USING: io.files io.encodings.utf8
+compiler.units smalltalk.parser smalltalk.compiler
+smalltalk.library ;
+IN: smalltalk.eval
+
+: eval-smalltalk ( string -- result )
+    [ parse-smalltalk compile-smalltalk ] with-compilation-unit
+    call( -- result ) ;
+
+: eval-smalltalk-file ( path -- result )
+    utf8 file-contents eval-smalltalk ;

extra/smalltalk/eval/fib.st

@@ -0,0 +1,11 @@
+class Fib [
+    |i|
+    method i: newI [i:=newI].
+    method compute [
+        (i <= 1)
+          ifTrue: [^1]
+          ifFalse: [^((Fib new i:(i-1)) compute + (Fib new i:(i-2)) compute)]
+    ].
+].
+
+[(Fib new i: 26) compute] time

extra/smalltalk/library/authors.txt

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

extra/smalltalk/library/library.factor

@@ -0,0 +1,101 @@
+! Copyright (C) 2009 Slava Pestov.
+! See http://factorcode.org/license.txt for BSD license.
+USING: kernel present io math sequences assocs math.ranges
+math.order fry tools.time locals smalltalk.selectors
+smalltalk.ast smalltalk.classes ;
+IN: smalltalk.library
+
+SELECTOR: print
+SELECTOR: asString
+
+M: object selector-print dup present print ;
+M: object selector-asString present ;
+
+SELECTOR: print:
+SELECTOR: nextPutAll:
+SELECTOR: tab
+SELECTOR: nl
+
+M: object selector-print: [ present ] dip stream-print nil ;
+M: object selector-nextPutAll: selector-print: ;
+M: object selector-tab "    " swap selector-print: ;
+M: object selector-nl stream-nl nil ;
+
+SELECTOR: +
+SELECTOR: -
+SELECTOR: *
+SELECTOR: /
+SELECTOR: <
+SELECTOR: >
+SELECTOR: <=
+SELECTOR: >=
+SELECTOR: =
+
+M: object selector-+  swap +  ;
+M: object selector--  swap -  ;
+M: object selector-*  swap *  ;
+M: object selector-/  swap /  ;
+M: object selector-<  swap <  ;
+M: object selector->  swap >  ;
+M: object selector-<= swap <= ;
+M: object selector->= swap >= ;
+M: object selector-=  swap =  ;
+
+SELECTOR: min:
+SELECTOR: max:
+
+M: object selector-min: min ;
+M: object selector-max: max ;
+
+SELECTOR: ifTrue:
+SELECTOR: ifFalse:
+SELECTOR: ifTrue:ifFalse:
+
+M: object selector-ifTrue: [ call( -- result ) ] [ drop nil ] if ;
+M: object selector-ifFalse: [ drop nil ] [ call( -- result ) ] if ;
+M: object selector-ifTrue:ifFalse: [ drop call( -- result ) ] [ nip call( -- result ) ] if ;
+
+SELECTOR: isNil
+
+M: object selector-isNil nil eq? ;
+
+SELECTOR: at:
+SELECTOR: at:put:
+
+M: sequence selector-at: nth ;
+M: sequence selector-at:put: ( key value receiver -- receiver ) [ swapd set-nth ] keep ;
+
+M: assoc selector-at: at ;
+M: assoc selector-at:put: ( key value receiver -- receiver ) [ swapd set-at ] keep ;
+
+SELECTOR: do:
+
+M:: object selector-do: ( quot receiver -- nil )
+    receiver [ quot call( elt -- result ) drop ] each nil ;
+
+SELECTOR: to:
+SELECTOR: to:do:
+
+M: object selector-to: swap [a,b] ;
+M:: object selector-to:do: ( to quot from -- nil )
+    from to [a,b] [ quot call( i -- result ) drop ] each nil ;
+
+SELECTOR: value
+SELECTOR: value:
+SELECTOR: value:value:
+SELECTOR: value:value:value:
+SELECTOR: value:value:value:value:
+
+M: object selector-value call( -- result ) ;
+M: object selector-value: call( input -- result ) ;
+M: object selector-value:value: call( input input -- result ) ;
+M: object selector-value:value:value: call( input input input -- result ) ;
+M: object selector-value:value:value:value: call( input input input input -- result ) ;
+
+SELECTOR: new
+
+M: object selector-new new ;
+
+SELECTOR: time
+
+M: object selector-time '[ _ call( -- result ) ] time ;

extra/smalltalk/listener/authors.txt

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

extra/smalltalk/listener/listener.factor

@@ -0,0 +1,18 @@
+! Copyright (C) 2009 Slava Pestov.
+! See http://factorcode.org/license.txt for BSD license.
+USING: kernel prettyprint io io.styles colors.constants compiler.units
+fry debugger sequences locals.rewrite.closures smalltalk.ast
+smalltalk.eval smalltalk.printer smalltalk.listener ;
+IN: smalltalk.listener
+
+: eval-interactively ( string -- )
+    '[
+        _ eval-smalltalk
+        dup nil? [ drop ] [ "Result: " write smalltalk>string print ] if
+    ] try ;
+
+: smalltalk-listener ( -- )
+    "Smalltalk>" { { background COLOR: light-blue } } format bl flush readln
+    [ eval-interactively smalltalk-listener ] when* ;
+
+MAIN: smalltalk-listener

extra/smalltalk/parser/authors.txt

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

extra/smalltalk/parser/parser-tests.factor

@@ -0,0 +1,300 @@
+IN: smalltalk.parser.tests
+USING: smalltalk.parser smalltalk.ast
+peg.ebnf tools.test accessors
+io.files io.encodings.ascii kernel ;
+
+EBNF: test-Character
+test         = <foreign parse-smalltalk Character>
+;EBNF
+
+[ CHAR: a ] [ "a" test-Character ] unit-test
+
+EBNF: test-Comment
+test         = <foreign parse-smalltalk Comment>
+;EBNF
+
+[ T{ ast-comment f "Hello, this is a comment." } ]
+[ "\"Hello, this is a comment.\"" test-Comment ]
+unit-test
+
+[ T{ ast-comment f "Hello, \"this\" is a comment." } ]
+[ "\"Hello, \"\"this\"\" is a comment.\"" test-Comment ]
+unit-test
+
+EBNF: test-Identifier
+test         = <foreign parse-smalltalk Identifier>
+;EBNF
+
+[ "OrderedCollection" ] [ "OrderedCollection" test-Identifier ] unit-test
+
+EBNF: test-Literal
+test         = <foreign parse-smalltalk Literal>
+;EBNF
+
+[ nil ] [ "nil" test-Literal ] unit-test
+[ 123 ] [ "123" test-Literal ] unit-test
+[ HEX: deadbeef ] [ "16rdeadbeef" test-Literal ] unit-test
+[ -123 ] [ "-123" test-Literal ] unit-test
+[ 1.2 ] [ "1.2" test-Literal ] unit-test
+[ -1.24 ] [ "-1.24" test-Literal ] unit-test
+[ 12.4e7 ] [ "12.4e7" test-Literal ] unit-test
+[ 12.4e-7 ] [ "12.4e-7" test-Literal ] unit-test
+[ -12.4e7 ] [ "-12.4e7" test-Literal ] unit-test
+[ CHAR: x ] [ "$x" test-Literal ] unit-test
+[ "Hello, world" ] [ "'Hello, world'" test-Literal ] unit-test
+[ "Hello, 'funny' world" ] [ "'Hello, ''funny'' world'" test-Literal ] unit-test
+[ T{ symbol f "foo" } ] [ "#foo" test-Literal ] unit-test
+[ T{ symbol f "+" } ] [ "#+" test-Literal ] unit-test
+[ T{ symbol f "at:put:" } ] [ "#at:put:" test-Literal ] unit-test
+[ T{ symbol f "Hello world" } ] [ "#'Hello world'" test-Literal ] unit-test
+[ B{ 1 2 3 4 } ] [ "#[1 2 3 4]" test-Literal ] unit-test
+[ { nil t f } ] [ "#(nil true false)" test-Literal ] unit-test
+[ { nil { t f } } ] [ "#(nil (true false))" test-Literal ] unit-test
+[ T{ ast-block f { } { } { } } ] [ "[]" test-Literal ] unit-test
+[ T{ ast-block f { "x" } { } { T{ ast-return f T{ ast-name f "x" } } } } ] [ "[ :x|^x]" test-Literal ] unit-test
+[ T{ ast-block f { } { } { T{ ast-return f self } } } ] [ "[^self]" test-Literal ] unit-test
+
+[
+    T{ ast-block
+       { arguments { "i" } }
+       { body
+         {
+             T{ ast-message-send
+                { receiver T{ ast-name { name "i" } } }
+                { selector "print" }
+             }
+         }
+       }
+    }
+]
+[ "[ :i | i print ]" test-Literal ] unit-test
+
+[
+    T{ ast-block
+       { body { 5 self } }
+    }
+]
+[ "[5. self]" test-Literal ] unit-test
+
+EBNF: test-FormalBlockArgumentDeclarationList
+test         = <foreign parse-smalltalk FormalBlockArgumentDeclarationList>
+;EBNF
+
+[ V{ "x" "y" "elt" } ] [ ":x :y :elt" test-FormalBlockArgumentDeclarationList ] unit-test
+
+EBNF: test-Operand
+test         = <foreign parse-smalltalk Operand>
+;EBNF
+
+[ { 123 15.6 { t f } } ] [ "#(123 15.6 (true false))" test-Operand ] unit-test
+[ T{ ast-name f "x" } ] [ "x" test-Operand ] unit-test
+
+EBNF: test-Expression
+test         = <foreign parse-smalltalk Expression>
+;EBNF
+
+[ self ] [ "self" test-Expression ] unit-test
+[ { 123 15.6 { t f } } ] [ "#(123 15.6 (true false))" test-Expression ] unit-test
+[ T{ ast-name f "x" } ] [ "x" test-Expression ] unit-test
+[ T{ ast-message-send f 5 "print" { } } ] [ "5 print" test-Expression ] unit-test
+[ T{ ast-message-send f T{ ast-message-send f 5 "squared" { } } "print" { } } ] [ "5 squared print" test-Expression ] unit-test
+[ T{ ast-message-send f 2 "+" { 2 } } ] [ "2+2" test-Expression ] unit-test
+
+[
+    T{ ast-message-send f
+        T{ ast-message-send f 3 "factorial" { } }
+        "+"
+        { T{ ast-message-send f 4 "factorial" { } } }
+    }
+]
+[ "3 factorial + 4 factorial" test-Expression ] unit-test
+
+[
+    T{ ast-message-send f
+        T{ ast-message-send f 3 "factorial" { } }
+        "+"
+        { T{ ast-message-send f 4 "factorial" { } } }
+    }
+]
+[ "   3 factorial + 4 factorial" test-Expression ] unit-test
+
+[
+    T{ ast-message-send f
+        T{ ast-message-send f 3 "factorial" { } }
+        "+"
+        { T{ ast-message-send f 4 "factorial" { } } }
+    }
+]
+[ "   3 factorial + 4 factorial     " test-Expression ] unit-test
+
+[
+    T{ ast-message-send f
+        T{ ast-message-send f
+            T{ ast-message-send f 3 "factorial" { } }
+            "+"
+            { 4 }
+        }
+        "factorial"
+        { }
+    }
+]
+[ "(3 factorial + 4) factorial" test-Expression ] unit-test
+
+[
+    T{ ast-message-send
+       { receiver
+         T{ ast-message-send
+            { receiver
+              T{ ast-message-send
+                 { receiver 1 }
+                 { selector "<" }
+                 { arguments { 10 } }
+              }
+            }
+            { selector "ifTrue:ifFalse:" }
+            { arguments
+              {
+                  T{ ast-block { body { "HI" } } }
+                  T{ ast-block { body { "BYE" } } }
+              }
+            }
+         }
+       }
+       { selector "print" }
+    }
+]
+[ "((1 < 10) ifTrue: [ 'HI' ] ifFalse: [ 'BYE' ]) print" test-Expression ] unit-test
+
+[
+    T{ ast-cascade
+       { receiver 12 }
+       { messages
+         {
+           T{ ast-message f "sqrt" }
+           T{ ast-message f "+" { 2 } }
+         }
+       }
+    }
+]
+[ "12 sqrt; + 2" test-Expression ] unit-test
+
+[
+    T{ ast-cascade
+       { receiver T{ ast-message-send f 12 "sqrt" } }
+       { messages
+         {
+           T{ ast-message f "+" { 1 } }
+           T{ ast-message f "+" { 2 } }
+         }
+       }
+    }
+]
+[ "12 sqrt + 1; + 2" test-Expression ] unit-test
+
+[
+    T{ ast-cascade
+       { receiver T{ ast-message-send f 12 "squared" } }
+       { messages
+         {
+           T{ ast-message f "to:" { 100 } }
+           T{ ast-message f "sqrt" }
+         }
+       }
+    }
+]
+[ "12 squared to: 100; sqrt" test-Expression ] unit-test
+
+[
+    T{ ast-message-send f
+        T{ ast-message-send f 1 "+" { 2 } }
+        "*"
+        { 3 }
+    }
+]
+[ "1+2*3" test-Expression ] unit-test
+
+[
+    T{ ast-message-send
+       { receiver
+         T{ ast-message-send
+            { receiver { T{ ast-block { body { "a" } } } } }
+            { selector "at:" }
+            { arguments { 0 } }
+         }
+       }
+       { selector "value" }
+    }
+]
+[ "(#(['a']) at: 0) value" test-Expression ] unit-test
+
+EBNF: test-FinalStatement
+test         = <foreign parse-smalltalk FinalStatement>
+;EBNF
+
+[ T{ ast-name f "value" } ] [ "value" test-FinalStatement ] unit-test
+[ T{ ast-return f T{ ast-name f "value" } } ] [ "^value" test-FinalStatement ] unit-test
+[ T{ ast-assignment f T{ ast-name f "value" } 5 } ] [ "value:=5" test-FinalStatement ] unit-test
+
+EBNF: test-LocalVariableDeclarationList
+test         = <foreign parse-smalltalk LocalVariableDeclarationList>
+;EBNF
+
+[ T{ ast-local-variables f { "i" "j" } } ] [ " |  i j   |" test-LocalVariableDeclarationList ] unit-test
+
+
+[ T{ ast-message-send f T{ ast-name f "x" } "foo:bar:" { 1 2 } } ]
+[ "x foo:1 bar:2" test-Expression ] unit-test
+
+[
+    T{ ast-message-send
+        f
+        T{ ast-message-send f
+            T{ ast-message-send f 3 "factorial" { } }
+            "+"
+            { T{ ast-message-send f 4 "factorial" { } } }
+        }
+        "between:and:"
+        { 10 100 }
+    }
+]
+[ "3 factorial + 4 factorial between: 10 and: 100" test-Expression ] unit-test
+
+[ T{ ast-sequence f { } { 1 2 } } ] [ "1. 2" parse-smalltalk ] unit-test
+
+[ T{ ast-sequence f { } { 1 2 } } ] [ "1. 2." parse-smalltalk ] unit-test
+
+[
+    T{ ast-sequence f { }
+        {
+            T{ ast-class
+               { name "Test" }
+               { superclass "Object" }
+               { ivars { "a" } }
+            }
+        }
+    }
+]
+[ "class Test [|a|]" parse-smalltalk ] unit-test
+
+[
+    T{ ast-sequence f { }
+        {
+            T{ ast-class
+               { name "Test1" }
+               { superclass "Object" }
+               { ivars { "a" } }
+            }
+
+            T{ ast-class
+               { name "Test2" }
+               { superclass "Test1" }
+               { ivars { "b" } }
+            }
+        }
+    }
+]
+[ "class Test1 [|a|]. class Test2 extends Test1 [|b|]" parse-smalltalk ] unit-test
+
+[ ] [ "class Foo []. Tests blah " parse-smalltalk drop ] unit-test
+
+[ ] [ "vocab:smalltalk/parser/test.st" ascii file-contents parse-smalltalk drop ] unit-test

extra/smalltalk/parser/parser.factor

@@ -0,0 +1,228 @@
+! Copyright (C) 2009 Slava Pestov.
+! See http://factorcode.org/license.txt for BSD license.
+USING: peg peg.ebnf smalltalk.ast sequences sequences.deep strings
+math.parser kernel arrays byte-arrays math assocs accessors ;
+IN: smalltalk.parser
+
+! :mode=text:noTabs=true:
+
+! Based on http://chronos-st.blogspot.com/2007/12/smalltalk-in-one-page.html
+
+ERROR: bad-number str ;
+
+: check-number ( str -- n )
+    >string dup string>number [ ] [ bad-number ] ?if ;
+
+EBNF: parse-smalltalk
+
+Character = .
+WhitespaceCharacter = (" " | "\t" | "\n" | "\r" )
+DecimalDigit = [0-9]
+Letter = [A-Za-z]
+
+CommentCharacter = [^"] | '""' => [[ CHAR: " ]]
+Comment = '"' (CommentCharacter)*:s '"' => [[ s >string ast-comment boa ]]
+
+OptionalWhiteSpace = (WhitespaceCharacter | Comment)*
+Whitespace = (WhitespaceCharacter | Comment)+
+
+LetterOrDigit = DecimalDigit | Letter
+Identifier = (Letter | "_"):h (LetterOrDigit | "_")*:t => [[ { h t } flatten >string ]]
+Reference = Identifier => [[ ast-name boa ]]
+
+ConstantReference =   "nil" => [[ nil ]]
+                    | "false" => [[ f ]]
+                    | "true" => [[ t ]]
+PseudoVariableReference =   "self" => [[ self ]]
+                          | "super" => [[ super ]]
+ReservedIdentifier = PseudoVariableReference | ConstantReference
+
+BindableIdentifier = Identifier
+
+UnaryMessageSelector = Identifier
+
+Keyword = Identifier:i ":" => [[ i ":" append ]]
+
+KeywordMessageSelector = Keyword+ => [[ concat ]]
+BinarySelectorChar =   "~" | "!" | "@" | "%" | "&" | "*" | "-" | "+"
+                     | "=" | "|" | "\" | "<" | ">" | "," | "?" | "/"
+BinaryMessageSelector = BinarySelectorChar+ => [[ concat ]]
+
+OptionalMinus = ("-" => [[ CHAR: - ]])?
+IntegerLiteral = (OptionalMinus:m UnsignedIntegerLiteral:i) => [[ i m [ neg ] when ]]
+UnsignedIntegerLiteral =   Radix:r "r" BaseNIntegerLiteral:b => [[ b >string r base> ]]
+                         | DecimalIntegerLiteral => [[ check-number ]]
+DecimalIntegerLiteral = DecimalDigit+
+Radix = DecimalIntegerLiteral => [[ check-number ]]
+BaseNIntegerLiteral = LetterOrDigit+
+FloatingPointLiteral = (OptionalMinus
+                        DecimalIntegerLiteral
+                        ("." => [[ CHAR: . ]] DecimalIntegerLiteral Exponent? | Exponent))
+                        => [[ flatten check-number ]]
+Exponent = "e" => [[ CHAR: e ]] (OptionalMinus DecimalIntegerLiteral)?
+
+CharacterLiteral = "$" Character:c => [[ c ]]
+
+StringLiteral = "'" (StringLiteralCharacter | "''" => [[ CHAR: ' ]])*:s "'"
+                => [[ s >string ]]
+StringLiteralCharacter = [^']
+
+SymbolInArrayLiteral =   KeywordMessageSelector
+                       | UnaryMessageSelector
+                       | BinaryMessageSelector
+SymbolLiteral = "#" (SymbolInArrayLiteral | StringLiteral):s => [[ s intern ]]
+
+ArrayLiteral = (ObjectArrayLiteral | ByteArrayLiteral)
+ObjectArrayLiteral = "#" NestedObjectArrayLiteral:elts => [[ elts ]]
+NestedObjectArrayLiteral = "(" OptionalWhiteSpace
+                           (LiteralArrayElement:h
+                            (Whitespace LiteralArrayElement:e => [[ e ]])*:t
+                            => [[ t h prefix ]]
+                           )?:elts OptionalWhiteSpace ")" => [[ elts >array ]]
+
+LiteralArrayElement =   Literal
+                      | NestedObjectArrayLiteral
+                      | SymbolInArrayLiteral
+                      | ConstantReference
+
+ByteArrayLiteral = "#[" OptionalWhiteSpace
+                        (UnsignedIntegerLiteral:h
+                         (Whitespace UnsignedIntegerLiteral:i => [[ i ]])*:t
+                         => [[ t h prefix ]]
+                        )?:elts OptionalWhiteSpace "]" => [[ elts >byte-array ]]
+
+FormalBlockArgumentDeclaration = ":" BindableIdentifier:i => [[ i ]]
+FormalBlockArgumentDeclarationList =
+                FormalBlockArgumentDeclaration:h
+                (Whitespace FormalBlockArgumentDeclaration:v => [[ v ]])*:t
+                => [[ t h prefix ]]
+
+BlockLiteral = "["
+                (OptionalWhiteSpace
+                 FormalBlockArgumentDeclarationList:args
+                 OptionalWhiteSpace
+                 "|"
+                 => [[ args ]]
+                )?:args
+                ExecutableCode:body
+                "]" => [[ args >array body <ast-block> ]]
+
+Literal = (ConstantReference
+                | FloatingPointLiteral
+                | IntegerLiteral
+                | CharacterLiteral
+                | StringLiteral
+                | ArrayLiteral
+                | SymbolLiteral
+                | BlockLiteral)
+
+NestedExpression = "(" Statement:s OptionalWhiteSpace ")" => [[ s ]]
+Operand =       Literal
+                | PseudoVariableReference
+                | Reference
+                | NestedExpression
+
+UnaryMessage = OptionalWhiteSpace
+               UnaryMessageSelector:s !(":")
+               => [[ s { } ast-message boa ]]
+
+BinaryMessage = OptionalWhiteSpace
+                BinaryMessageSelector:selector
+                OptionalWhiteSpace
+                (UnaryMessageSend | Operand):rhs
+                => [[ selector { rhs } ast-message boa ]]
+                                   
+KeywordMessageSegment = Keyword:k OptionalWhiteSpace (BinaryMessageSend | UnaryMessageSend | Operand):arg => [[ { k arg } ]]
+KeywordMessage = OptionalWhiteSpace
+                 KeywordMessageSegment:h
+                 (OptionalWhiteSpace KeywordMessageSegment:s => [[ s ]])*:t
+                 => [[ t h prefix unzip [ concat ] dip ast-message boa ]]
+
+Message = BinaryMessage | UnaryMessage | KeywordMessage
+
+UnaryMessageSend = (UnaryMessageSend | Operand):lhs
+              UnaryMessage:h
+              (OptionalWhiteSpace ";" Message:m => [[ m ]])*:t
+              => [[ lhs t h prefix >array <ast-cascade> ]]
+
+BinaryMessageSend = (BinaryMessageSend | UnaryMessageSend | Operand):lhs
+              BinaryMessage:h
+              (OptionalWhiteSpace ";" Message:m => [[ m ]])*:t
+              => [[ lhs t h prefix >array <ast-cascade> ]]
+
+KeywordMessageSend = (BinaryMessageSend | UnaryMessageSend | Operand):lhs
+              KeywordMessage:h
+              (OptionalWhiteSpace ";" Message:m => [[ m ]])*:t
+              => [[ lhs t h prefix >array <ast-cascade> ]]
+
+Expression = OptionalWhiteSpace
+             (KeywordMessageSend | BinaryMessageSend | UnaryMessageSend | Operand):e
+             => [[ e ]]
+
+AssignmentOperation = OptionalWhiteSpace BindableIdentifier:i
+                      OptionalWhiteSpace ":=" OptionalWhiteSpace => [[ i ast-name boa ]]
+AssignmentStatement = AssignmentOperation:a Statement:s => [[ a s ast-assignment boa ]]
+Statement = ClassDeclaration | ForeignClassDeclaration | AssignmentStatement | Expression
+
+MethodReturnOperator = OptionalWhiteSpace "^"
+FinalStatement = (MethodReturnOperator Statement:s => [[ s ast-return boa ]])
+                 | Statement
+
+LocalVariableDeclarationList = OptionalWhiteSpace "|" OptionalWhiteSpace
+                (BindableIdentifier:h
+                 (Whitespace BindableIdentifier:b => [[ b ]])*:t
+                 => [[ t h prefix ]]
+                )?:b OptionalWhiteSpace "|" => [[ b >array ast-local-variables boa ]]
+
+EndStatement = "."
+
+ExecutableCode = (LocalVariableDeclarationList)?:locals
+                 (Statement:s OptionalWhiteSpace EndStatement => [[ s ]])*:h
+                 (FinalStatement:t (EndStatement)? => [[ t ]])?:t
+                 OptionalWhiteSpace
+                 => [[ h t [ suffix ] when* locals [ prefix ] when* >array ]]
+
+TopLevelForm = ExecutableCode => [[ <ast-sequence> ]]
+
+UnaryMethodHeader = UnaryMessageSelector:selector
+                  => [[ { selector { } } ]]
+BinaryMethodHeader = BinaryMessageSelector:selector OptionalWhiteSpace BindableIdentifier:identifier
+                   => [[ { selector { identifier } } ]]
+KeywordMethodHeaderSegment = Keyword:keyword
+                             OptionalWhiteSpace
+                             BindableIdentifier:identifier => [[ { keyword identifier } ]]
+KeywordMethodHeader = KeywordMethodHeaderSegment:h (Whitespace KeywordMethodHeaderSegment:s => [[ s ]])*:t
+                    => [[ t h prefix unzip [ concat ] dip 2array ]]
+MethodHeader =   KeywordMethodHeader
+               | BinaryMethodHeader
+               | UnaryMethodHeader
+MethodDeclaration = OptionalWhiteSpace "method" OptionalWhiteSpace MethodHeader:header
+        OptionalWhiteSpace "["
+        ExecutableCode:code
+        "]"
+        => [[ header first2 code <ast-method> ]]
+
+ClassDeclaration = OptionalWhiteSpace "class" OptionalWhiteSpace Identifier:name
+        OptionalWhiteSpace
+        ("extends" OptionalWhiteSpace Identifier:superclass OptionalWhiteSpace => [[ superclass ]])?:superclass
+        OptionalWhiteSpace "["
+        (OptionalWhiteSpace LocalVariableDeclarationList:l => [[ l names>> ]])?:ivars
+        (MethodDeclaration:h
+         (OptionalWhiteSpace
+          EndStatement
+          OptionalWhiteSpace
+          MethodDeclaration:m => [[ m ]])*:t (EndStatement)?
+          => [[ t h prefix ]]
+         )?:methods
+        OptionalWhiteSpace "]"
+        => [[ name superclass "Object" or ivars >array methods >array ast-class boa ]]
+
+ForeignClassDeclaration = OptionalWhiteSpace "foreign"
+                          OptionalWhiteSpace Identifier:name
+                          OptionalWhiteSpace Literal:class
+                          => [[ class name ast-foreign boa ]]
+End = !(.)
+
+Program = TopLevelForm End
+
+;EBNF

extra/smalltalk/parser/test.st

@@ -0,0 +1,65 @@
+class TreeNode extends Object [
+    |left right item|
+
+    method binarytrees: n to: output [
+        | minDepth maxDepth stretchDepth check longLivedTree iterations |
+        minDepth := 4.
+        maxDepth := minDepth + 2 max: n.
+        stretchDepth := maxDepth + 1.
+
+        check := (TreeNode bottomUpTree: 0 depth: stretchDepth) itemCheck.
+        output
+            nextPutAll: 'stretch tree of depth '; print: stretchDepth; tab;
+            nextPutAll: ' check: '; print: check; nl.
+
+        longLivedTree := TreeNode bottomUpTree: 0 depth: maxDepth.
+        minDepth to: maxDepth by: 2 do: [:depth|
+            iterations := 1 bitShift: maxDepth - depth + minDepth.
+
+            check := 0.
+            1 to: iterations do: [:i|
+                check := check + (TreeNode bottomUpTree: i depth: depth) itemCheck.
+                check := check + (TreeNode bottomUpTree: -1*i depth: depth) itemCheck
+            ].
+            output
+                print:  (2*iterations); tab;
+                nextPutAll: ' trees of depth '; print: depth; tab;
+                nextPutAll: ' check: '; print: check; nl
+            ].
+
+        output
+            nextPutAll: 'long lived tree of depth '; print: maxDepth; tab;
+            nextPutAll: ' check: '; print: longLivedTree itemCheck; nl
+    ].
+    
+    method binarytrees: arg [
+        self binarytrees: arg to: self stdout.
+        ^''
+    ].
+
+    method left: leftChild right: rightChild item: anItem [
+        left := leftChild.
+        right := rightChild.
+        item := anItem
+    ].
+
+    method itemCheck [
+        ^left isNil
+            ifTrue: [item] ifFalse: [item + (left itemCheck - right itemCheck)]
+    ].
+
+    method bottomUpTree: anItem depth: anInteger [
+        ^(anInteger > 0)
+            ifTrue: [
+                self
+                    left: (self bottomUpTree: 2*anItem - 1 depth: anInteger - 1)
+                    right: (self bottomUpTree: 2*anItem depth: anInteger - 1)
+                    item: anItem
+            ] ifFalse: [self left: nil right: nil item: anItem]
+    ].
+
+    method left: leftChild right: rightChild item: anItem [
+        ^(super new) left: leftChild right: rightChild item: anItem
+    ]
+].
+

extra/smalltalk/printer/authors.txt

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

extra/smalltalk/printer/printer-tests.factor

@@ -0,0 +1,4 @@
+IN: smalltalk.printer.tests
+USING: smalltalk.printer tools.test ;
+
+[ "#((1 2) 'hi')" ] [ { { 1 2 } "hi" } smalltalk>string ] unit-test

extra/smalltalk/printer/printer.factor

@@ -0,0 +1,34 @@
+! Copyright (C) 2009 Slava Pestov.
+! See http://factorcode.org/license.txt for BSD license.
+USING: accessors arrays byte-arrays kernel make math
+math.parser prettyprint sequences smalltalk.ast strings ;
+IN: smalltalk.printer
+
+GENERIC: smalltalk>string ( object -- string )
+
+M: real smalltalk>string number>string ;
+
+M: string smalltalk>string
+    [
+        "'" %
+        [ dup CHAR: ' = [ dup , , ] [ , ] if ] each
+        "'" %
+    ] "" make ;
+
+GENERIC: array-element>string ( object -- string )
+
+M: object array-element>string smalltalk>string ;
+
+M: array array-element>string
+    [ array-element>string ] map " " join "(" ")" surround ;
+
+M: array smalltalk>string
+    array-element>string "#" prepend ;
+
+M: byte-array smalltalk>string
+    [ number>string ] { } map-as " " join "#[" "]" surround ;
+
+M: symbol smalltalk>string
+    name>> smalltalk>string "#" prepend ;
+
+M: object smalltalk>string unparse-short ;

extra/smalltalk/selectors/authors.txt

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

extra/smalltalk/selectors/selectors.factor

@@ -0,0 +1,28 @@
+! Copyright (C) 2009 Slava Pestov.
+! See http://factorcode.org/license.txt for BSD license.
+USING: combinators effects generic generic.standard
+kernel sequences words lexer ;
+IN: smalltalk.selectors
+
+SYMBOLS: unary binary keyword ;
+
+: selector-type ( selector -- type )
+    {
+        { [ dup [ "~!@%&*-+=|\\<>,?/" member? ] all? ] [ binary ] }
+        { [ CHAR: : over member? ] [ keyword ] }
+        [ unary ]
+    } cond nip ;
+
+: selector>effect ( selector -- effect )
+    dup selector-type {
+        { unary [ drop 0 ] }
+        { binary [ drop 1 ] }
+        { keyword [ [ CHAR: : = ] count ] }
+    } case "receiver" suffix { "result" } <effect> ;
+
+: selector>generic ( selector -- generic )
+    [ "selector-" prepend "smalltalk.selectors" create dup ]
+    [ selector>effect ]
+    bi define-simple-generic ;
+
+SYNTAX: SELECTOR: scan selector>generic drop ;

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 ;

vm/Config.macosx

@@ -4,6 +4,7 @@ CFLAGS += -fPIC
 PLAF_DLL_OBJS += vm/os-macosx.o vm/mach_signal.o
 
 DLL_EXTENSION = .dylib
+SHARED_DLL_EXTENSION = .dylib
 
 SHARED_FLAG = -dynamiclib
 

vm/Config.unix

@@ -5,7 +5,7 @@ endif
 EXE_SUFFIX =
 DLL_PREFIX = lib
 DLL_EXTENSION = .a
-# DLL_EXTENSION = .so
+SHARED_DLL_EXTENSION = .so
 SHARED_FLAG = -shared
 
 PLAF_DLL_OBJS = vm/os-unix.o

vm/Config.windows

@@ -5,5 +5,6 @@ SHARED_FLAG = -shared
 EXE_EXTENSION=.exe
 CONSOLE_EXTENSION=.com
 DLL_EXTENSION=.dll
+SHARED_DLL_EXTENSION=.dll
 LINKER = $(CC) -shared -mno-cygwin -o 
 LINK_WITH_ENGINE = -l$(DLL_PREFIX)factor$(DLL_SUFFIX)

vm/alien.c

@@ -160,7 +160,7 @@ void box_value_struct(void *src, CELL size)
 	dpush(tag_object(array));
 }
 
-/* On OS X, structs <= 8 bytes are returned in registers. */
+/* On some x86 OSes, structs <= 8 bytes are returned in registers. */
 void box_small_struct(CELL x, CELL y, CELL size)
 {
 	CELL data[2];
@@ -169,6 +169,17 @@ void box_small_struct(CELL x, CELL y, CELL size)
 	box_value_struct(data,size);
 }
 
+/* On OS X/PPC, complex numbers are returned in registers. */
+void box_medium_struct(CELL x1, CELL x2, CELL x3, CELL x4, CELL size)
+{
+	CELL data[4];
+	data[0] = x1;
+	data[1] = x2;
+	data[2] = x3;
+	data[3] = x4;
+	box_value_struct(data,size);
+}
+
 /* open a native library and push a handle */
 void primitive_dlopen(void)
 {

vm/alien.h

@@ -40,6 +40,7 @@ void primitive_set_alien_cell(void);
 DLLEXPORT void to_value_struct(CELL src, void *dest, CELL size);
 DLLEXPORT void box_value_struct(void *src, CELL size);
 DLLEXPORT void box_small_struct(CELL x, CELL y, CELL size);
+void box_medium_struct(CELL x1, CELL x2, CELL x3, CELL x4, CELL size);
 
 DEFINE_UNTAG(F_DLL,DLL_TYPE,dll)
 

vm/callstack.c

@@ -103,7 +103,7 @@ CELL frame_type(F_STACK_FRAME *frame)
 CELL frame_executing(F_STACK_FRAME *frame)
 {
 	F_CODE_BLOCK *compiled = frame_code(frame);
-	if(compiled->literals == F)
+	if(compiled->literals == F || !stack_traces_p())
 		return F;
 	else
 	{

vm/code_block.c

@@ -11,7 +11,7 @@ void iterate_relocations(F_CODE_BLOCK *compiled, RELOCATION_ITERATOR iter)
 	{
 		F_BYTE_ARRAY *relocation = untag_object(compiled->relocation);
 
-		CELL index = 1;
+		CELL index = stack_traces_p() ? 1 : 0;
 
 		F_REL *rel = (F_REL *)(relocation + 1);
 		F_REL *rel_end = (F_REL *)((char *)rel + byte_array_capacity(relocation));
@@ -195,8 +195,6 @@ void mark_code_block(F_CODE_BLOCK *compiled)
 
 	copy_handle(&compiled->literals);
 	copy_handle(&compiled->relocation);
-
-	flush_icache_for(compiled);
 }
 
 void mark_stack_frame_step(F_STACK_FRAME *frame)
@@ -370,11 +368,6 @@ void deposit_integers(CELL here, F_ARRAY *array, CELL format)
 	}
 }
 
-bool stack_traces_p(void)
-{
-	return to_boolean(userenv[STACK_TRACES_ENV]);
-}
-
 CELL compiled_code_format(void)
 {
 	return untag_fixnum_fast(userenv[JIT_CODE_FORMAT]);
@@ -431,6 +424,10 @@ F_CODE_BLOCK *add_code_block(
 	UNREGISTER_ROOT(relocation);
 	UNREGISTER_ROOT(literals);
 
+	/* slight space optimization */
+	if(type_of(literals) == ARRAY_TYPE && array_capacity(untag_object(literals)) == 0)
+		literals = F;
+
 	/* compiled header */
 	compiled->block.type = type;
 	compiled->block.last_scan = NURSERY;

vm/code_block.h

@@ -75,7 +75,10 @@ void relocate_code_block(F_CODE_BLOCK *relocating);
 
 CELL compiled_code_format(void);
 
-bool stack_traces_p(void);
+INLINE bool stack_traces_p(void)
+{
+	return userenv[STACK_TRACES_ENV] != F;
+}
 
 F_CODE_BLOCK *add_code_block(
 	CELL type,