Merge branch 'master' into smalltalk

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

@@ -36,7 +36,7 @@ HELP: download-feed
 { $description "Downloads a feed from a URL using the " { $link "http.client" } "." } ;
 
 HELP: parse-feed
-{ $values { "sequence" "a string or a byte array" } { "feed" feed } }
+{ $values { "seq" "a string or a byte array" } { "feed" feed } }
 { $description "Parses a feed." } ;
 
 HELP: xml>feed

basis/syndication/syndication.factor

@@ -106,7 +106,7 @@ TUPLE: entry title url description date ;
         { "feed" [ atom1.0 ] }
     } case ;
 
-GENERIC: parse-feed ( string -- feed )
+GENERIC: parse-feed ( seq -- feed )
 
 M: string parse-feed [ string>xml xml>feed ] with-html-entities ;
 

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"

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

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,113 +30,100 @@ 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-string make-comment-tag push-tag ;
 
-: read-dtd ( -- )
+: read-dtd ( state-parser -- )
-    ">" take-string make-dtd-tag push-tag ;
+    ">" take-until-string 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 string-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
     ] 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

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

@@ -1,14 +1,30 @@
-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 ] string-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 ] string-parse
+] unit-test
+
+[ "foo" ";bar" ]
+[
+    "foo;bar" [
+        [ CHAR: ; take-until-char ] [ take-rest ] bi
+    ] string-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-string ] [ take-rest ] bi 
+    ] string-parse
+] unit-test
+
+[ 6 ]
+[
+    "      foo   " [ skip-whitespace i>> ] string-parse
+] unit-test

extra/html/parser/state/state.factor

@@ -1,41 +1,62 @@
 ! 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 string i ;
 
-: get-i ( -- i ) state get i>> ; inline
+: <state-parser> ( string -- state-parser )
+    state-parser new
+        swap >>string
+        0 >>i ;
 
-: get-char ( -- char )
+: (get-char) ( i state -- char/f )
-    state get [ i>> ] [ string>> ] bi ?nth ; inline
+    string>> ?nth ; inline
 
-: get-next ( -- char )
+: get-char ( state -- char/f )
-    state get [ i>> 1+ ] [ string>> ] bi ?nth ; inline
+    [ i>> ] keep (get-char) ; inline
 
-: next ( -- )
+: get-next ( state -- char/f )
-    state get [ 1+ ] change-i drop ; inline
+    [ i>> 1+ ] keep (get-char) ; inline
+
+: next ( state -- state )
+    [ 1+ ] change-i ; inline
+
+: get+increment ( state -- char/f )
+    [ get-char ] [ next drop ] bi ; inline
 
 : string-parse ( string quot -- )
-    [ 0 state boa state ] dip with-variable ; inline
+    [ <state-parser> ] dip call ; inline
 
-: short* ( n seq -- n' seq )
+:: skip-until ( state quot: ( obj -- ? ) -- )
-    over [ nip dup length swap ] unless ; inline
+    state get-char [
+        quot call [ state next quot skip-until ] unless
+    ] when* ; inline recursive
 
-: skip-until ( quot: ( -- ? ) -- )
+: take-until ( state quot: ( obj -- ? ) -- string )
-    get-char [
+    [ drop i>> ]
-        [ call ] keep swap
+    [ skip-until ]
-        [ drop ] [ next skip-until ] if
+    [ drop [ i>> ] [ string>> ] bi ] 2tri subseq ; inline
-    ] [ drop ] if ; inline recursive
 
-: take-until ( quot: ( -- ? ) -- )
+:: take-until-string ( state-parser string -- string' )
-    get-i [ skip-until ] dip get-i
+    string length <growing-circular> :> growing
-    state get string>> subseq ; inline
+    state-parser
+    [
+        growing push-growing-circular
+        string growing sequence=
+    ] take-until :> found
+    found dup length
+    growing length 1- - head
+    state-parser next drop ;
     
-: string-matches? ( string circular -- ? )
+: skip-whitespace ( state -- state )
-    get-char over push-growing-circular sequence= ; inline
+    [ [ blank? not ] take-until drop ] keep ;
 
-: take-string ( match -- string )
+: take-rest ( state -- string )
-    dup length <growing-circular>
+    [ drop f ] take-until ; inline
-    [ 2dup string-matches? ] take-until nip
+
-    dup length rot length 1- - head next ; inline
+: take-until-char ( state ch -- string )
+    '[ _ = ] take-until ;
+
+: string-parse-end? ( state -- ? ) get-next not ;

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 ;

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));
@@ -368,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]);
@@ -429,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,

vm/debug.c

@@ -311,7 +311,7 @@ void find_data_references(CELL look_for_)
 /* Dump all code blocks for debugging */
 void dump_code_heap(void)
 {
-	CELL size = 0;
+	CELL reloc_size = 0, literal_size = 0;
 
 	F_BLOCK *scan = first_block(&code_heap);
 
@@ -324,11 +324,13 @@ void dump_code_heap(void)
 			status = "free";
 			break;
 		case B_ALLOCATED:
-			size += object_size(((F_CODE_BLOCK *)scan)->relocation);
+			reloc_size += object_size(((F_CODE_BLOCK *)scan)->relocation);
+			literal_size += object_size(((F_CODE_BLOCK *)scan)->literals);
 			status = "allocated";
 			break;
 		case B_MARKED:
-			size += object_size(((F_CODE_BLOCK *)scan)->relocation);
+			reloc_size += object_size(((F_CODE_BLOCK *)scan)->relocation);
+			literal_size += object_size(((F_CODE_BLOCK *)scan)->literals);
 			status = "marked";
 			break;
 		default:
@@ -343,7 +345,8 @@ void dump_code_heap(void)
 		scan = next_block(&code_heap,scan);
 	}
 	
-	print_cell(size); print_string(" bytes of relocation data\n");
+	print_cell(reloc_size); print_string(" bytes of relocation data\n");
+	print_cell(literal_size); print_string(" bytes of literal data\n");
 }
 
 void factorbug(void)

vm/quotations.c

@@ -180,7 +180,8 @@ void jit_compile(CELL quot, bool relocate)
 	GROWABLE_ARRAY(literals);
 	REGISTER_ROOT(literals);
 
-	GROWABLE_ARRAY_ADD(literals,stack_traces_p() ? quot : F);
+	if(stack_traces_p())
+		GROWABLE_ARRAY_ADD(literals,quot);
 
 	bool stack_frame = jit_stack_frame_p(untag_object(array));