Merge branch 'master' of git://github.com/erikcharlebois/factor

diff --git a/basis/compiler/tree/propagation/branches/branches.factor b/basis/compiler/tree/propagation/branches/branches.factor
index 28f34cb425c5ccc9118832b01a7a984900876b0b..ef9e4e8f0b0740e26fd432325f435dd6eb126cd5 100644 (file)
--- a/basis/compiler/tree/propagation/branches/branches.factor
+++ b/basis/compiler/tree/propagation/branches/branches.factor
@@ -1,8 +1,8 @@
-! Copyright (C) 2008, 2009 Slava Pestov.
+! Copyright (C) 2008, 2010 Slava Pestov.
 ! See http://factorcode.org/license.txt for BSD license.
-USING: fry kernel sequences assocs accessors namespaces
+USING: fry kernel sequences assocs accessors
 math.intervals arrays classes.algebra combinators columns
-stack-checker.branches locals math
+stack-checker.branches locals math namespaces
 compiler.utilities
 compiler.tree
 compiler.tree.combinators
@@ -10,6 +10,8 @@ compiler.tree.propagation.info
 compiler.tree.propagation.nodes
 compiler.tree.propagation.simple
 compiler.tree.propagation.constraints ;
+FROM: sets => union ;
+FROM: assocs => change-at ;
 IN: compiler.tree.propagation.branches
 
 ! For conditionals, an assoc of child node # --> constraint
@@ -90,7 +92,7 @@ M: #phi propagate-before ( #phi -- )
     bi ;
 
 :: update-constraints ( new old -- )
-    new [| key value | key old [ value append ] change-at ] assoc-each ;
+    new [| key value | key old [ value union ] change-at ] assoc-each ;
 
 : include-child-constraints ( i -- )
     infer-children-data get nth constraints swap at last

diff --git a/basis/compiler/tree/propagation/constraints/constraints.factor b/basis/compiler/tree/propagation/constraints/constraints.factor
index 617352d6998fcc8fbd7e627725e7451ec166f052..f9988ba22061f465b866e3388156e4b32375489b 100644 (file)
--- a/basis/compiler/tree/propagation/constraints/constraints.factor
+++ b/basis/compiler/tree/propagation/constraints/constraints.factor
@@ -1,4 +1,4 @@
-! Copyright (C) 2008 Slava Pestov.
+! Copyright (C) 2008, 2010 Slava Pestov.
 ! See http://factorcode.org/license.txt for BSD license.
 USING: arrays assocs math math.intervals kernel accessors
 sequences namespaces classes classes.algebra
@@ -87,8 +87,11 @@ TUPLE: implication p q ;
 
 C: --> implication
 
+: maybe-add ( elt seq -- seq' )
+    2dup member? [ nip ] [ swap suffix ] if ;
+
 : assume-implication ( q p -- )
-    [ constraints get [ assoc-stack swap suffix ] 2keep last set-at ]
+    [ constraints get [ assoc-stack maybe-add ] 2keep last set-at ]
     [ satisfied? [ assume ] [ drop ] if ] 2bi ;
 
 M: implication assume*

diff --git a/basis/formatting/formatting-tests.factor b/basis/formatting/formatting-tests.factor
index 5710ceb985d582607ebd2f0c56cb671b584686ba..35b1dfff4a293df6858ba447088bf49ba65585db 100644 (file)
--- a/basis/formatting/formatting-tests.factor
+++ b/basis/formatting/formatting-tests.factor
@@ -16,6 +16,7 @@ IN: formatting.tests
 [ t ] [ "+0010" 10 "%+05d" sprintf = ] unit-test
 [ t ] [ "123.456000" 123.456 "%f" sprintf = ] unit-test
 [ t ] [ "2.44" 2.436 "%.2f" sprintf = ] unit-test
+[ t ] [ "8.950" 8.950179003580072 "%.3f" sprintf = ] unit-test
 [ t ] [ "123.10" 123.1 "%01.2f" sprintf = ] unit-test
 [ t ] [ "1.2346" 1.23456789 "%.4f" sprintf = ] unit-test
 [ t ] [ "  1.23" 1.23456789 "%6.2f" sprintf = ] unit-test

diff --git a/basis/formatting/formatting.factor b/basis/formatting/formatting.factor
index ec3c9f1d8eb13b5046f5dffdbbdb77d11473f8c3..5abcb12916cab80832235b16eeffcc875ba0a9b2 100644 (file)
--- a/basis/formatting/formatting.factor
+++ b/basis/formatting/formatting.factor
@@ -3,7 +3,9 @@
 USING: accessors arrays assocs calendar combinators fry kernel
 generalizations io io.streams.string macros math math.functions
 math.parser peg.ebnf quotations sequences splitting strings
-unicode.categories unicode.case vectors combinators.smart ;
+unicode.categories unicode.case vectors combinators.smart
+present ;
+FROM: math.parser.private => format-float ;
 IN: formatting
 
 <PRIVATE
@@ -26,31 +28,15 @@ IN: formatting
 : >digits ( string -- digits )
     [ 0 ] [ string>number ] if-empty ;
 
-: pad-digits ( string digits -- string' )
-    [ "." split1 ] dip [ CHAR: 0 pad-tail ] [ head-slice ] bi "." glue ;
+: format-simple ( x digits string -- string )
+    [ [ >float ] [ number>string ] bi* "%." ] dip
+    surround format-float ;
 
-: max-digits ( n digits -- n' )
-    10^ [ * round ] keep / ; inline
+: format-scientific ( x digits -- string ) "e" format-simple ;
 
-: >exp ( x -- exp base )
-    [
-        abs 0 swap
-        [ dup [ 10.0 >= ] [ 1.0 < ] bi or ]
-        [ dup 10.0 >=
-          [ 10.0 / [ 1 + ] dip ]
-          [ 10.0 * [ 1 - ] dip ] if
-        ] while
-     ] keep 0 < [ neg ] when ;
-
-: exp>string ( exp base digits -- string )
-    [ max-digits ] keep -rot
-    [
-        [ 0 < "-" "+" ? ]
-        [ abs number>string 2 CHAR: 0 pad-head ] bi
-        "e" -rot 3append
-    ]
-    [ number>string ] bi*
-    rot pad-digits prepend ;
+: format-decimal ( x digits -- string ) "f" format-simple ;
+
+ERROR: unknown-printf-directive ;
 
 EBNF: parse-printf
 
@@ -73,15 +59,15 @@ digits    = (digits_)?           => [[ 6 or ]]
 fmt-%     = "%"                  => [[ [ "%" ] ]]
 fmt-c     = "c"                  => [[ [ 1string ] ]]
 fmt-C     = "C"                  => [[ [ 1string >upper ] ]]
-fmt-s     = "s"                  => [[ [ dup number? [ number>string ] when ] ]]
-fmt-S     = "S"                  => [[ [ dup number? [ number>string ] when >upper ] ]]
-fmt-d     = "d"                  => [[ [ >fixnum number>string ] ]]
-fmt-e     = digits "e"           => [[ first '[ >exp _ exp>string ] ]]
-fmt-E     = digits "E"           => [[ first '[ >exp _ exp>string >upper ] ]]
-fmt-f     = digits "f"           => [[ first dup '[ >float _ max-digits number>string _ pad-digits ] ]]
+fmt-s     = "s"                  => [[ [ present ] ]]
+fmt-S     = "S"                  => [[ [ present >upper ] ]]
+fmt-d     = "d"                  => [[ [ >integer number>string ] ]]
+fmt-e     = digits "e"           => [[ first '[ _ format-scientific ] ]]
+fmt-E     = digits "E"           => [[ first '[ _ format-scientific >upper ] ]]
+fmt-f     = digits "f"           => [[ first '[ _ format-decimal ] ]]
 fmt-x     = "x"                  => [[ [ >hex ] ]]
 fmt-X     = "X"                  => [[ [ >hex >upper ] ]]
-unknown   = (.)*                 => [[ "Unknown directive" throw ]]
+unknown   = (.)*                 => [[ unknown-printf-directive ]]
 
 strings_  = fmt-c|fmt-C|fmt-s|fmt-S
 strings   = pad width strings_   => [[ reverse compose-all ]]

diff --git a/basis/stack-checker/known-words/known-words.factor b/basis/stack-checker/known-words/known-words.factor
index 15895184df8c25d7698831cf452f16c386b01df1..1fa9a94677e378fa7859be3e7026d73a80e3f2fb 100644 (file)
--- a/basis/stack-checker/known-words/known-words.factor
+++ b/basis/stack-checker/known-words/known-words.factor
@@ -289,7 +289,7 @@ M: bad-executable summary
 \ (dlsym) { byte-array object } { c-ptr } define-primitive
 \ (exists?) { string } { object } define-primitive
 \ (exit) { integer } { } define-primitive
-\ (float>string) { float } { byte-array } define-primitive \ (float>string) make-foldable
+\ (format-float) { float byte-array } { byte-array } define-primitive \ (format-float) make-foldable
 \ (fopen) { byte-array byte-array } { alien } define-primitive
 \ (identity-hashcode) { object } { fixnum } define-primitive
 \ (save-image) { byte-array byte-array } { } define-primitive

diff --git a/core/bootstrap/primitives.factor b/core/bootstrap/primitives.factor
index 87963848bf32ccdba218b0ce17dcaf27a57cc913..c466b0c1f84fe6dea7648a58c0a6fe920032c099 100644 (file)
--- a/core/bootstrap/primitives.factor
+++ b/core/bootstrap/primitives.factor
@@ -470,7 +470,7 @@ tuple
     { "byte-array>bignum" "math" "primitive_byte_array_to_bignum" (( x -- y )) }
     { "double>bits" "math" "primitive_double_bits" (( x -- n )) }
     { "float>bits" "math" "primitive_float_bits" (( x -- n )) }
-    { "(float>string)" "math.parser.private" "primitive_float_to_str" (( n -- str )) }
+    { "(format-float)" "math.parser.private" "primitive_format_float" (( n format -- byte-array )) }
     { "bignum*" "math.private" "primitive_bignum_multiply" (( x y -- z )) }
     { "bignum+" "math.private" "primitive_bignum_add" (( x y -- z )) }
     { "bignum-" "math.private" "primitive_bignum_subtract" (( x y -- z )) }

diff --git a/core/math/parser/parser.factor b/core/math/parser/parser.factor
index 5bb024db9dd3c85cae95744c940f64e9232c88de..14fd6a298392451ad9749fe63dc998fa67eed173 100644 (file)
--- a/core/math/parser/parser.factor
+++ b/core/math/parser/parser.factor
@@ -1,6 +1,7 @@
 ! (c)2009 Joe Groff bsd license
-USING: accessors combinators kernel kernel.private math
-namespaces sequences sequences.private splitting strings make ;
+USING: accessors byte-arrays combinators kernel kernel.private
+math namespaces sequences sequences.private splitting strings
+make ;
 IN: math.parser
 
 : digit> ( ch -- n )
@@ -356,15 +357,15 @@ M: ratio >base
         mantissa-expt [ float>hex-value ] [ float>hex-expt ] bi*
     ] bi 3append ;
 
-: float>decimal ( n -- str )
-    (float>string)
-    [ 0 = ] trim-tail >string
+: format-float ( n format -- string )
+    0 suffix >byte-array (format-float)
+    dup [ 0 = ] find drop head >string
     fix-float ;
 
 : float>base ( n base -- str )
     {
         { 16 [ float>hex ] }
-        [ drop float>decimal ]
+        [ drop "%.16g" format-float ]
     } case ; inline
 
 PRIVATE>

diff --git a/extra/benchmark/knucleotide/knucleotide.factor b/extra/benchmark/knucleotide/knucleotide.factor
index 70fa1bb061b367cac6f1a825ef3a5efc546819fc..f03e26675e4553f64495ea553fb312d603d5cce2 100644 (file)
--- a/extra/benchmark/knucleotide/knucleotide.factor
+++ b/extra/benchmark/knucleotide/knucleotide.factor
@@ -1,16 +1,9 @@
-USING: kernel locals io io.files splitting strings io.encodings.ascii
-       hashtables sequences assocs math namespaces prettyprint
-       math.parser combinators arrays sorting unicode.case ;
-
+USING: ascii kernel io io.files splitting strings
+io.encodings.ascii hashtables sequences assocs math
+math.statistics namespaces prettyprint math.parser combinators
+arrays sorting formatting grouping fry ;
 IN: benchmark.knucleotide
 
-: float>string ( float places -- string )
-    swap >float number>string
-    "." split1 rot
-    over length over <
-    [ CHAR: 0 pad-tail ] 
-    [ head ] if "." glue ;
-
 : discard-lines ( -- )
     readln
     [ ">THREE" head? [ discard-lines ] unless ] when* ;
@@ -20,37 +13,25 @@ IN: benchmark.knucleotide
     ">" read-until drop
     CHAR: \n swap remove >upper ;
 
-: tally ( x exemplar -- b )
-    clone [ [ inc-at ] curry each ] keep ;
-
-: small-groups ( x n -- b )
-    swap
-    [ length swap - 1 + iota ] 2keep
-    [ [ over + ] dip subseq ] 2curry map ;
-
 : handle-table ( inputs n -- )
-    small-groups
-    [ length ] keep
-    H{ } tally >alist
-    sort-values reverse
-    [
-      dup first write bl
-      second 100 * over / 3 float>string print
-    ] each
-    drop ;
+    clump
+    [ histogram >alist sort-values reverse ] [ length ] bi
+    '[
+        [ first write bl ]
+        [ second 100 * _ /f "%.3f" printf nl ] bi
+    ] each ;
 
-:: handle-n ( inputs x -- )
-    inputs x length small-groups :> groups
-    groups H{ } tally :> b
-    x b at [ 0 ] unless*
-    number>string 8 CHAR: \s pad-tail write ;
+: handle-n ( input x -- )
+    [ nip ] [ length clump histogram ] 2bi at 0 or "%d\t" printf ;
 
 : process-input ( input -- )
-    dup 1 handle-table nl
-    dup 2 handle-table nl
-    { "GGT" "GGTA" "GGTATT" "GGTATTTTAATT" "GGTATTTTAATTTATAGT" }
-    [ [ dupd handle-n ] keep print ] each
-    drop ;
+    [ 1 handle-table nl ]
+    [ 2 handle-table nl ]
+    [
+        { "GGT" "GGTA" "GGTATT" "GGTATTTTAATT" "GGTATTTTAATTTATAGT" }
+        [ [ handle-n ] keep print ] with each
+    ]
+    tri ;
 
 : knucleotide ( -- )
     "resource:extra/benchmark/knucleotide/knucleotide-input.txt"

diff --git a/vm/callstack.cpp b/vm/callstack.cpp
index ad7528ab84c2b8e2f8c2c5a76498181b026de6cf..eae976219f505d29511e8c1eb161962a7780c691 100755 (executable)
--- a/vm/callstack.cpp
+++ b/vm/callstack.cpp
@@ -122,7 +122,7 @@ cell factor_vm::frame_scan(stack_frame *frame)
                        if(obj.type_p(QUOTATION_TYPE))
                        {
                                char *return_addr = (char *)FRAME_RETURN_ADDRESS(frame,this);
-                               char *quot_entry_point = (char *)(frame_code(frame) + 1);
+                               char *quot_entry_point = (char *)frame_code(frame)->entry_point();
 
                                return tag_fixnum(quot_code_offset_to_scan(
                                        obj.value(),(cell)(return_addr - quot_entry_point)));

diff --git a/vm/io.cpp b/vm/io.cpp
index 8ce7ff52564ddb66d91d00b998918b328f710a1a..94e6e64d1da760e8ca3f7d1b8b234c4f80dad98d 100755 (executable)
--- a/vm/io.cpp
+++ b/vm/io.cpp
@@ -216,7 +216,7 @@ void factor_vm::primitive_fread()
                if(feof(file))
                {
                        byte_array *new_buf = allot_byte_array(c);
-                       memcpy(new_buf + 1, buf.untagged() + 1,c);
+                       memcpy(new_buf->data<char>(), buf->data<char>(),c);
                        buf = new_buf;
                }
 

diff --git a/vm/math.cpp b/vm/math.cpp
index a4622323449742677ce9f37786c019ea8e60f8d3..e64db2690ed43e58da2fca01da78a6606a316b2b 100755 (executable)
--- a/vm/math.cpp
+++ b/vm/math.cpp
@@ -260,10 +260,12 @@ void factor_vm::primitive_bignum_to_float()
        ctx->replace(allot_float(bignum_to_float(ctx->peek())));
 }
 
-void factor_vm::primitive_float_to_str()
+void factor_vm::primitive_format_float()
 {
-       byte_array *array = allot_byte_array(33);
-       SNPRINTF((char *)(array + 1),32,"%.16g",untag_float_check(ctx->pop()));
+       byte_array *array = allot_byte_array(100);
+       char *format = alien_offset(ctx->pop());
+       double value = untag_float_check(ctx->pop());
+       SNPRINTF(array->data<char>(),99,format,value);
        ctx->push(tag<byte_array>(array));
 }
 

diff --git a/vm/primitives.hpp b/vm/primitives.hpp
index ff0947912cad70cd3c35a3f1cb35e224bc753afb..e98cf508b6bb0be67db8d2caa3ba3b0c602b02d1 100644 (file)
--- a/vm/primitives.hpp
+++ b/vm/primitives.hpp
@@ -82,8 +82,8 @@ namespace factor
        _(float_subtract) \
        _(float_to_bignum) \
        _(float_to_fixnum) \
-       _(float_to_str) \
        _(fopen) \
+       _(format_float) \
        _(fputc) \
        _(fread) \
        _(fseek) \

diff --git a/vm/vm.hpp b/vm/vm.hpp
index 36ec3260d6563352128e28876f5d052b92836ec2..dd1d48cf0388184f631b63f14a99dee9efcaa1c3 100755 (executable)
--- a/vm/vm.hpp
+++ b/vm/vm.hpp
@@ -464,7 +464,7 @@ struct factor_vm
        cell unbox_array_size_slow();
        void primitive_fixnum_to_float();
        void primitive_bignum_to_float();
-       void primitive_float_to_str();
+       void primitive_format_float();
        void primitive_float_eq();
        void primitive_float_add();
        void primitive_float_subtract();