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

basis/alien/c-types/c-types.factor

@@ -265,9 +265,15 @@ M: f byte-length drop 0 ; inline
 : malloc-array ( n type -- alien )
     [ heap-size calloc ] [ <c-type-direct-array> ] 2bi ; inline
 
+: (malloc-array) ( n type -- alien )
+    [ heap-size * malloc ] [ <c-type-direct-array> ] 2bi ; inline
+
 : malloc-object ( type -- alien )
     1 swap heap-size calloc ; inline
 
+: (malloc-object) ( type -- alien )
+    heap-size malloc ; inline
+
 : malloc-byte-array ( byte-array -- alien )
     dup byte-length [ nip malloc dup ] 2keep memcpy ;
 

basis/alien/complex/functor/functor.factor

@@ -1,6 +1,6 @@
 ! Copyright (C) 2009 Slava Pestov.
 ! See http://factorcode.org/license.txt for BSD license.
-USING: accessors alien.structs alien.c-types classes.struct math
+USING: accessors alien alien.structs alien.c-types classes.struct math
 math.functions sequences arrays kernel functors vocabs.parser
 namespaces quotations ;
 IN: alien.complex.functor
@@ -17,7 +17,7 @@ WHERE
 STRUCT: T-class { real N } { imaginary N } ;
 
 : <T> ( z -- alien )
-    >rect T-class <struct-boa> ;
+    >rect T-class <struct-boa> >c-ptr ;
 
 : *T ( alien -- z )
     T-class memory>struct [ real>> ] [ imaginary>> ] bi rect> ; inline

basis/classes/struct/struct-docs.factor

@@ -9,6 +9,15 @@ HELP: <struct-boa>
 }
 { $description "This macro implements " { $link boa } " for " { $link struct } " classes. A struct of the given class is constructed, and its slots are initialized using values off the top of the datastack." } ;
 
+HELP: (struct)
+{ $values
+    { "class" class }
+    { "struct" struct }
+}
+{ $description "Allocates garbage-collected heap memory for a new " { $link struct } " of the specified " { $snippet "class" } ". The new struct's slots are left uninitialized; in most cases, the " { $link <struct> } " word, which initializes the struct's slots with their initial values, should be used instead." } ;
+
+{ (struct) (malloc-struct) } related-words
+
 HELP: <struct>
 { $values
     { "class" class }
@@ -55,7 +64,14 @@ HELP: malloc-struct
     { "class" class }
     { "struct" struct }
 }
-{ $description "Allocates unmanaged C heap memory for a new " { $link struct } " of the specified " { $snippet "class" } ". The new struct's slots are zeroed out. The struct should be " { $link free } "d when it is no longer needed." } ;
+{ $description "Allocates unmanaged C heap memory for a new " { $link struct } " of the specified " { $snippet "class" } ". The new struct's slots are initialized to their initial values. The struct should be " { $link free } "d when it is no longer needed." } ;
+
+HELP: (malloc-struct)
+{ $values
+    { "class" class }
+    { "struct" struct }
+}
+{ $description "Allocates unmanaged C heap memory for a new " { $link struct } " of the specified " { $snippet "class" } ". The new struct's slots are left uninitialized; to initialize the allocated memory with the slots' initial values, use " { $link malloc-struct } ". The struct should be " { $link free } "d when it is no longer needed." } ;
 
 HELP: memory>struct
 { $values
@@ -80,6 +96,9 @@ ARTICLE: "classes.struct" "Struct classes"
 { $subsection <struct-boa> }
 { $subsection malloc-struct }
 { $subsection memory>struct }
+"When the contents of a struct will be immediately reset, faster primitive words are available that will create a struct without initializing its contents:"
+{ $subsection (struct) }
+{ $subsection (malloc-struct) }
 "Structs have literal syntax like tuples:"
 { $subsection POSTPONE: S{ }
 "Union structs are also supported, which behave like structs but share the same memory for all the type's slots."

basis/classes/struct/struct-tests.factor

@@ -1,5 +1,5 @@
 ! (c)Joe Groff bsd license
-USING: accessors alien.c-types alien.libraries
+USING: accessors alien alien.c-types alien.libraries
 alien.structs.fields alien.syntax ascii classes.struct combinators
 destructors io.encodings.utf8 io.pathnames io.streams.string
 kernel libc literals math multiline namespaces prettyprint
@@ -63,7 +63,7 @@ UNION-STRUCT: struct-test-float-and-bits
 [ 1.0 ] [ struct-test-float-and-bits <struct> 1.0 float>bits >>bits f>> ] unit-test
 [ 4 ] [ struct-test-float-and-bits heap-size ] unit-test
 
-[ ] [ [ struct-test-foo malloc-struct &free drop ] with-destructors ] unit-test
+[ 123 ] [ [ struct-test-foo malloc-struct &free y>> ] with-destructors ] unit-test
 
 STRUCT: struct-test-string-ptr
     { x char* } ;
@@ -203,3 +203,5 @@ STRUCT: struct-test-optimization
 ] unit-test
 
 [ f ] [ [ memory>struct y>> ] { memory>struct y>> } inlined? ] unit-test
+
+[ f ] [ struct-test-foo <struct> dup clone [ >c-ptr ] bi@ eq? ] unit-test

basis/classes/struct/struct.factor

@@ -37,6 +37,8 @@ M: struct equal?
         [ [ >c-ptr ] [ [ >c-ptr ] [ byte-length ] bi ] bi* memory= ]
     } 2&& ;
 
+: struct-prototype ( class -- prototype ) "prototype" word-prop ; foldable
+
 : memory>struct ( ptr class -- struct )
     [ 1array ] dip slots>tuple ;
 
@@ -44,17 +46,25 @@ M: struct equal?
     dup struct-class? [ '[ _ boa ] ] [ drop f ] if
 ] 1 define-partial-eval
 
+M: struct clone
+    [ >c-ptr ] [ byte-length memory>byte-array ] [ class memory>struct ] tri ;
+
+<PRIVATE
+: (init-struct) ( class with-prototype: ( prototype -- alien ) sans-prototype: ( class -- alien ) -- alien )
+    '[ dup struct-prototype _ _ ?if ] keep memory>struct ; inline
+PRIVATE>
+
+: (malloc-struct) ( class -- struct )
+    [ heap-size malloc ] keep memory>struct ; inline
+
 : malloc-struct ( class -- struct )
-    [ 1 swap heap-size calloc ] keep memory>struct ; inline
+    [ >c-ptr malloc-byte-array ] [ 1 swap heap-size calloc ] (init-struct) ;
 
 : (struct) ( class -- struct )
-    [ heap-size <byte-array> ] keep memory>struct ; inline
+    [ heap-size (byte-array) ] keep memory>struct ; inline
-
-: struct-prototype ( class -- prototype ) "prototype" word-prop ; foldable
 
 : <struct> ( class -- struct )
-    dup struct-prototype
+    [ >c-ptr clone ] [ heap-size <byte-array> ] (init-struct) ;
-    [ >c-ptr clone swap memory>struct ] [ (struct) ] if* ; inline
 
 MACRO: <struct-boa> ( class -- quot: ( ... -- struct ) )
     [
@@ -66,6 +76,7 @@ MACRO: <struct-boa> ( class -- quot: ( ... -- struct ) )
         ] bi
     ] [ ] output>sequence ;
 
+<PRIVATE
 : pad-struct-slots ( values class -- values' class )
     [ struct-slots [ initial>> ] map over length tail append ] keep ;
 
@@ -82,6 +93,7 @@ MACRO: <struct-boa> ( class -- quot: ( ... -- struct ) )
 
 : (unboxer-quot) ( class -- quot )
     drop [ >c-ptr ] ;
+PRIVATE>
 
 M: struct-class boa>object
     swap pad-struct-slots
@@ -98,6 +110,9 @@ M: struct-class reader-quot
 M: struct-class writer-quot
     nip (writer-quot) ;
 
+! c-types
+
+<PRIVATE
 : struct-slot-values-quot ( class -- quot )
     struct-slots
     [ name>> reader-word 1quotation ] map
@@ -112,8 +127,6 @@ M: struct-class writer-quot
     [ \ byte-length create-method-in ]
     [ heap-size \ drop swap [ ] 2sequence ] bi define ;
 
-! Struct as c-type
-
 : slot>field ( slot -- field )
     field-spec new swap {
         [ name>> >>name ]
@@ -155,6 +168,7 @@ M: struct-class writer-quot
 
 : struct-align ( slots -- align )
     [ c-type>> c-type-align ] [ max ] map-reduce ;
+PRIVATE>
 
 M: struct-class c-type
     name>> c-type ;
@@ -180,6 +194,7 @@ M: struct-class heap-size
 
 ! class definition
 
+<PRIVATE
 : make-struct-prototype ( class -- prototype )
     [ heap-size <byte-array> ]
     [ memory>struct ]
@@ -219,6 +234,7 @@ M: struct-class heap-size
         (struct-word-props)
     ]
     [ drop define-struct-for-class ] 2tri ; inline
+PRIVATE>
 
 : define-struct-class ( class slots -- )
     [ struct-offsets ] (define-struct-class) ;
@@ -228,6 +244,7 @@ M: struct-class heap-size
 
 ERROR: invalid-struct-slot token ;
 
+<PRIVATE
 : struct-slot-class ( c-type -- class' )
     c-type c-type-boxed-class
     dup \ byte-array = [ drop \ c-ptr ] when ;
@@ -250,6 +267,7 @@ ERROR: invalid-struct-slot token ;
 
 : parse-struct-definition ( -- class slots )
     CREATE-CLASS 8 <vector> [ parse-struct-slots ] [ ] while >array ;
+PRIVATE>
 
 SYNTAX: STRUCT:
     parse-struct-definition define-struct-class ;
@@ -259,6 +277,9 @@ SYNTAX: UNION-STRUCT:
 SYNTAX: S{
     scan-word dup struct-slots parse-tuple-literal-slots parsed ;
 
+! functor support
+
+<PRIVATE
 : scan-c-type` ( -- c-type/param )
     scan dup "{" = [ drop \ } parse-until >array ] [ >string-param ] if ;
 
@@ -280,6 +301,7 @@ SYNTAX: S{
         { "{" [ parse-struct-slot` t ] }
         [ invalid-struct-slot ]
     } case ;
+PRIVATE>
 
 FUNCTOR-SYNTAX: STRUCT:
     scan-param parsed

basis/images/jpeg/jpeg.factor

@@ -6,7 +6,7 @@ images.processing io io.binary io.encodings.binary io.files
 io.streams.byte-array kernel locals math math.bitwise
 math.constants math.functions math.matrices math.order
 math.ranges math.vectors memoize multiline namespaces
-sequences sequences.deep images.loader ;
+sequences sequences.deep images.loader io.streams.limited ;
 IN: images.jpeg
 
 QUALIFIED-WITH: bitstreams bs
@@ -118,18 +118,18 @@ TUPLE: jpeg-color-info
     ] with-byte-reader ;
 
 : decode-huff-table ( chunk -- )
-    data>>
+    data>> [ binary <byte-reader> ] [ length ] bi
-    binary
+    stream-throws limit
-    [
+    [   
-        1 ! %fixme: Should handle multiple tables at once
+        [ input-stream get [ count>> ] [ limit>> ] bi < ]
         [
             read4/4 swap 2 * +
             16 read
             dup [ ] [ + ] map-reduce read
             binary [ [ read [ B{ } ] unless* ] { } map-as ] with-byte-reader
             swap jpeg> huff-tables>> set-nth
-        ] times
+        ] while
-    ] with-byte-reader ;
+    ] with-input-stream* ;
 
 : decode-scan ( chunk -- )
     data>>
@@ -148,7 +148,10 @@ TUPLE: jpeg-color-info
 : singleton-first ( seq -- elt )
     [ length 1 assert= ] [ first ] bi ;
 
+ERROR: not-a-baseline-jpeg-image ;
+
 : baseline-parse ( -- )
+    jpeg> headers>> [ type>> { SOF 0 } = ] any? [ not-a-baseline-jpeg-image ] unless
     jpeg> headers>>
     {
         [ [ type>> { SOF 0 } = ] filter singleton-first decode-frame ]
@@ -221,7 +224,7 @@ MEMO: dct-matrix-blas ( -- m ) dct-matrix >float-blas-matrix ;
 : V.M ( x A -- x.A ) Mtranspose swap M.V ;
 : idct-blas ( b -- b' ) >float-blas-vector dct-matrix-blas V.M ;
 
-: idct ( b -- b' ) idct-blas ;
+: idct ( b -- b' ) idct-factor ;
 
 :: draw-block ( block x,y color-id jpeg-image -- )
     block dup length>> sqrt >fixnum group flip

basis/math/matrices/matrices-tests.factor

@@ -106,4 +106,7 @@ USING: math.matrices math.vectors tools.test math ;
 [ { 1 0 0 } ] [ { 1 1 0 } { 1 0 0 } proj ] unit-test
 
 [ { { { 1 "a" } { 1 "b" } } { { 2 "a" } { 2 "b" } } } ]
-[ { 1 2 } { "a" "b" } cross-zip ] unit-test
+[ { 1 2 } { "a" "b" } cross-zip ] unit-test
+
+[ { { 4181 6765 } { 6765 10946 } } ]
+[ { { 0 1 } { 1 1 } } 20 m^n ] unit-test

basis/math/matrices/matrices.factor

@@ -139,4 +139,4 @@ PRIVATE>
     
 : m^n ( m n -- n ) 
     make-bits over first length identity-matrix
-    [ [ dupd m. ] when [ dup m. ] dip ] reduce nip ;
+    [ [ dupd m. ] when [ dup m. ] dip ] reduce nip ;

basis/math/primes/primes.factor

@@ -56,7 +56,8 @@ PRIVATE>
 : coprime? ( a b -- ? ) gcd nip 1 = ; foldable
 
 : random-prime ( numbits -- p )
-    random-bits* next-prime ;
+    [ ] [ 2^ ] [ random-bits* next-prime ] tri
+    2dup < [ 2drop random-prime ] [ 2nip ] if ;
 
 : estimated-primes ( m -- n )
     dup log / ; foldable

basis/tools/disassembler/udis/udis.factor

@@ -3,7 +3,8 @@
 USING: tools.disassembler namespaces combinators
 alien alien.syntax alien.c-types lexer parser kernel
 sequences layouts math math.order alien.libraries
-math.parser system make fry arrays libc destructors ;
+math.parser system make fry arrays libc destructors
+tools.disassembler.utils splitting ;
 IN: tools.disassembler.udis
 
 <<
@@ -103,19 +104,21 @@ FUNCTION: char* ud_lookup_mnemonic ( int c ) ;
     dup UD_SYN_INTEL ud_set_syntax ;
 
 : with-ud ( quot: ( ud -- ) -- )
-    [ [ <ud> ] dip call ] with-destructors ; inline
+    [ [ [ <ud> ] dip call ] with-destructors ] with-words-xt ; inline
 
 SINGLETON: udis-disassembler
 
 : buf/len ( from to -- buf len ) [ drop <alien> ] [ swap - ] 2bi ;
 
+: resolve-call ( str -- str' ) "0x" split1-last [ resolve-xt append ] when* ;
+
 : format-disassembly ( lines -- lines' )
     dup [ second length ] [ max ] map-reduce
     '[
         [
             [ first >hex cell 2 * CHAR: 0 pad-head % ": " % ]
             [ second _ CHAR: \s pad-tail % "  " % ]
-            [ third % ]
+            [ third resolve-call % ]
             tri
         ] "" make
     ] map ;

basis/tools/disassembler/utils/utils.factor

@@ -0,0 +1,41 @@
+USING: accessors arrays binary-search kernel math math.order
+math.parser namespaces sequences sorting splitting vectors vocabs words ;
+IN: tools.disassembler.utils
+
+SYMBOL: words-xt
+SYMBOL: smallest-xt
+SYMBOL: greatest-xt
+
+: (words-xt) ( -- assoc )
+    vocabs [ words ] map concat [ [ word-xt ] keep 3array ] map
+    [ [ first ] bi@ <=> ] sort >vector ;
+
+: complete-address ( n seq -- str )
+    [ first - ] [ third name>> ] bi
+    over zero? [ nip ] [ swap 16 >base "0x" prepend "+" glue ] if ;
+
+: search-xt ( n -- str/f )
+    dup [ smallest-xt get < ] [ greatest-xt get > ] bi or [
+        drop f
+    ] [
+        words-xt get over [ swap first <=> ] curry search nip
+        2dup second <= [
+            [ complete-address ] [ drop f ] if*
+        ] [
+            2drop f
+        ] if
+    ] if ;
+
+: resolve-xt ( str -- str' )
+    [ "0x" prepend ] [ 16 base> ] bi
+    [ search-xt [ " (" ")" surround append ] when* ] when* ;
+
+: resolve-call ( str -- str' )
+    "0x" split1-last [ resolve-xt "0x" glue ] when* ;
+
+: with-words-xt ( quot -- )
+    [ (words-xt)
+      [ words-xt set ]
+      [ first first smallest-xt set ]
+      [ last second greatest-xt set ] tri
+    ] prepose with-scope ; inline

extra/benchmark/struct-arrays/struct-arrays.factor

@@ -2,7 +2,7 @@
 ! See http://factorcode.org/license.txt for BSD license.
 USING: accessors classes.struct combinators.smart fry kernel
 math math.functions math.order math.parser sequences
-struct-arrays hints io ;
+struct-arrays io ;
 IN: benchmark.struct-arrays
 
 STRUCT: point { x float } { y float } { z float } ;
@@ -45,8 +45,6 @@ STRUCT: point { x float } { y float } { z float } ;
 : struct-array-benchmark ( len -- )
     make-points [ normalize-points ] [ max-points ] bi print-point ;
 
-HINTS: struct-array-benchmark fixnum ;
-
 : main ( -- ) 5000000 struct-array-benchmark ;
 
 MAIN: main

extra/benchmark/terrain-generation/terrain-generation.factor

@@ -4,7 +4,7 @@ IN: benchmark.terrain-generation
 
 : terrain-generation-benchmark ( -- )
     "Generating terrain segment..." write flush yield
-    <terrain> { 0.0 0.0 } terrain-segment drop
+    <terrain> { 0 0 } terrain-segment drop
     "done" print ;
 
 MAIN: terrain-generation-benchmark