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

basis/compiler/tree/escape-analysis/escape-analysis-tests.factor

@@ -329,3 +329,18 @@ TUPLE: empty-tuple ;
     [ { vector } declare length>> ]
     count-unboxed-allocations
 ] unit-test
+
+! Bug found while tweaking benchmark.raytracer-simd
+
+TUPLE: point-2d { x read-only } { y read-only } ;
+TUPLE: point-3d < point-2d { z read-only } ;
+
+[ 0 ] [
+    [ { point-2d } declare dup point-3d? [ z>> ] [ x>> ] if ]
+    count-unboxed-allocations
+] unit-test
+
+[ 0 ] [
+    [ point-2d boa dup point-3d? [ z>> ] [ x>> ] if ]
+    count-unboxed-allocations
+] unit-test

basis/compiler/tree/escape-analysis/simple/simple.factor

@@ -61,22 +61,28 @@ M: #push escape-analysis*
 
 : record-tuple-allocation ( #call -- )
     dup immutable-tuple-boa?
-    [ [ in-d>> but-last ] [ out-d>> first ] bi record-allocation ]
+    [ [ in-d>> but-last { } like ] [ out-d>> first ] bi record-allocation ]
     [ record-unknown-allocation ]
     if ;
 
 : slot-offset ( #call -- n/f )
-    dup in-d>>
+    dup in-d>> second node-value-info literal>> dup [ 2 - ] when ;
-    [ second node-value-info literal>> ]
+
-    [ first node-value-info class>> ] 2bi
+: valid-slot-offset? ( slot# in -- ? )
-    2dup [ fixnum? ] [ tuple class<= ] bi* and [
+    over [
-        over 2 >= [ drop 2 - ] [ 2drop f ] if
+        allocation dup [
+            dup array? [ bounds-check? ] [ 2drop f ] if
+        ] [ 2drop t ] if
     ] [ 2drop f ] if ;
 
+: unknown-slot-call ( out slot# in -- )
+    [ unknown-allocation ] [ drop ] [ add-escaping-value ] tri* ;
+
 : record-slot-call ( #call -- )
-    [ out-d>> first ] [ slot-offset ] [ in-d>> first ] tri over
+    [ out-d>> first ] [ slot-offset ] [ in-d>> first ] tri
+    2dup valid-slot-offset?
     [ [ record-slot-access ] [ copy-slot-value ] 3bi ]
-    [ [ unknown-allocation ] [ drop ] [ add-escaping-value ] tri* ]
+    [ unknown-slot-call ]
     if ;
 
 M: #call escape-analysis*

basis/compiler/tree/propagation/transforms/transforms.factor

@@ -103,10 +103,7 @@ IN: compiler.tree.propagation.transforms
 
 ! Speeds up 2^
 : 2^? ( #call -- ? )
-    in-d>> first2 [ value-info ] bi@
+    in-d>> first value-info literal>> 1 eq? ;
-    [ { [ literal>> 1 = ] [ class>> fixnum class<= ] } 1&& ]
-    [ class>> fixnum class<= ]
-    bi* and ;
 
 \ shift [
     2^? [

basis/io/backend/unix/unix.factor

@@ -22,10 +22,6 @@ TUPLE: fd < disposable fd ;
     ] with-destructors ;
 
 : <fd> ( n -- fd )
-    #! We drop the error code rather than calling io-error,
-    #! since on OS X 10.3, this operation fails from init-io
-    #! when running the Factor.app (presumably because fd 0 and
-    #! 1 are closed).
     fd new-disposable swap >>fd ;
 
 M: fd dispose
@@ -197,5 +193,5 @@ TUPLE: mx-port < port mx ;
         [ drop 0 ] [ (io-error) ] if
     ] when ;
 
-: ?flag ( n mask symbol -- n )
+:: ?flag ( n mask symbol -- n )
-    pick rot bitand 0 > [ , ] [ drop ] if ;
+    n mask bitand 0 > [ symbol , ] when n ;

basis/io/directories/unix/linux/linux.factor

@@ -4,7 +4,7 @@ USING: alien.c-types io.directories.unix kernel system unix
 classes.struct unix.ffi ;
 IN: io.directories.unix.linux
 
-M: unix find-next-file ( DIR* -- dirent )
+M: linux find-next-file ( DIR* -- dirent )
     dirent <struct>
     f <void*>
     [ [ readdir64_r ] unix-system-call 0 = [ (io-error) ] unless ] 2keep

basis/io/files/info/info.factor

@@ -26,7 +26,7 @@ available-space free-space used-space total-space ;
 HOOK: file-system-info os ( path -- file-system-info )
 
 {
-    { [ os unix? ] [ "io.files.info" ] }
+    { [ os unix? ] [ "io.files.info.unix" ] }
     { [ os windows? ] [ "io.files.info.windows" ] }
 } cond require
 

basis/io/styles/styles.factor

@@ -163,9 +163,3 @@ M: input summary
 : write-object ( str obj -- ) presented associate format ;
 
 : write-image ( image -- ) [ "" ] dip image associate format ;
-
-SYMBOL: stack-effect-style
-H{
-    { foreground COLOR: FactorDarkGreen }
-    { font-style plain }
-} stack-effect-style set-global

basis/math/bitwise/bitwise.factor

@@ -99,7 +99,7 @@ M: bignum (bit-count)
     ] if ;
 
 : byte-array-bit-count ( byte-array -- n )
-    0 [ byte-bit-count + ] reduce ;
+    0 [ byte-bit-count + ] reduce ; inline
 
 PRIVATE>
 

basis/prettyprint/stylesheet/stylesheet.factor

@@ -42,5 +42,12 @@ PRIVATE>
 : vocab-style ( vocab -- style )
     dim-color colored-presentation-style ;
 
+SYMBOL: stack-effect-style
+
+H{
+    { foreground COLOR: FactorDarkGreen }
+    { font-style plain }
+} stack-effect-style set-global
+
 : effect-style ( effect -- style )
     presented associate stack-effect-style get assoc-union ;

basis/tools/annotations/annotations.factor

@@ -1,4 +1,4 @@
-! Copyright (C) 2005, 2009 Slava Pestov.
+! Copyright (C) 2005, 2010 Slava Pestov.
 ! See http://factorcode.org/license.txt for BSD license.
 USING: accessors kernel math sorting words parser io summary
 quotations sequences prettyprint continuations effects
@@ -108,5 +108,5 @@ PRIVATE>
 
 : word-timing. ( -- )
     word-timing get
-    >alist [ 1000000 /f ] assoc-map sort-values
+    >alist [ 1,000,000,000 /f ] assoc-map sort-values
     simple-table. ;

basis/tools/deploy/deploy-tests.factor

@@ -117,3 +117,9 @@ os macosx? [
 [ ] [ "tools.deploy.test.16" shake-and-bake run-temp-image ] unit-test
 
 [ ] [ "tools.deploy.test.17" shake-and-bake run-temp-image ] unit-test
+
+[ t ] [
+    "tools.deploy.test.18" shake-and-bake
+    deploy-test-command ascii [ readln ] with-process-reader
+    "test.image" temp-file =
+] unit-test

basis/tools/deploy/shaker/shaker.factor

@@ -1,11 +1,11 @@
 ! Copyright (C) 2007, 2010 Slava Pestov.
 ! See http://factorcode.org/license.txt for BSD license.
-USING: arrays accessors io.backend io.streams.c init fry
+USING: arrays accessors io.backend io.pathnames io.streams.c
-namespaces math make assocs kernel parser parser.notes lexer
+init fry namespaces math make assocs kernel parser parser.notes
-strings.parser vocabs sequences sequences.deep sequences.private
+lexer strings.parser vocabs sequences sequences.deep
-words memory kernel.private continuations io vocabs.loader
+sequences.private words memory kernel.private continuations io
-system strings sets vectors quotations byte-arrays sorting
+vocabs.loader system strings sets vectors quotations byte-arrays
-compiler.units definitions generic generic.standard
+sorting compiler.units definitions generic generic.standard
 generic.single tools.deploy.config combinators classes
 classes.builtin slots.private grouping command-line ;
 QUALIFIED: bootstrap.stage2
@@ -43,13 +43,11 @@ IN: tools.deploy.shaker
         "io.thread" startup-hooks get delete-at
     ] unless
     strip-io? [
-        "io.files" startup-hooks get delete-at
         "io.backend" startup-hooks get delete-at
         "io.thread" startup-hooks get delete-at
     ] when
     strip-dictionary? [
         {
-            ! "compiler.units"
             "vocabs"
             "vocabs.cache"
             "source-files.errors"
@@ -294,6 +292,9 @@ IN: tools.deploy.shaker
             input-stream
             output-stream
             error-stream
+            vm
+            image
+            current-directory
         } %
 
         "io-thread" "io.thread" lookup ,

basis/tools/deploy/test/18/18.factor

@@ -0,0 +1,8 @@
+! Copyright (C) 2010 Slava Pestov.
+! See http://factorcode.org/license.txt for BSD license.
+USING: accessors io.streams.c math.parser system ;
+IN: tools.deploy.test.18
+
+: main ( -- ) image show ;
+
+MAIN: main

basis/tools/deploy/test/18/authors.txt

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

basis/tools/deploy/test/18/deploy.factor

@@ -0,0 +1,14 @@
+USING: tools.deploy.config ;
+H{
+    { deploy-name "tools.deploy.test.18" }
+    { deploy-ui? f }
+    { deploy-c-types? f }
+    { deploy-unicode? f }
+    { "stop-after-last-window?" t }
+    { deploy-io 1 }
+    { deploy-reflection 1 }
+    { deploy-word-props? f }
+    { deploy-math? f }
+    { deploy-threads? f }
+    { deploy-word-defs? f }
+}

core/assocs/assocs-docs.factor

@@ -1,7 +1,8 @@
 ! Copyright (C) 2007, 2009 Daniel Ehrenberg, Slava Pestov, and Doug Coleman
 ! See http://factorcode.org/license.txt for BSD license.
 USING: help.markup help.syntax kernel sequences
-sequences.private namespaces math quotations assocs.private ;
+sequences.private namespaces math quotations assocs.private
+sets ;
 IN: assocs
 
 ARTICLE: "alists" "Association lists"
@@ -90,6 +91,8 @@ ARTICLE: "assocs-values" "Transposed assoc operations"
 
 ARTICLE: "assocs-sets" "Set-theoretic operations on assocs"
 "It is often useful to use the keys of an associative mapping as a set, exploiting the constant or logarithmic lookup time of most implementations (" { $link "alists" } " being a notable exception)."
+$nl
+"Set-theoretic operations:"
 { $subsections
     assoc-subset?
     assoc-intersect
@@ -98,6 +101,11 @@ ARTICLE: "assocs-sets" "Set-theoretic operations on assocs"
     substitute
     extract-keys
 }
+"Adding elements to sets:"
+{ $subsections
+    conjoin
+    conjoin-at
+}
 "Destructive operations:"
 { $subsections
     assoc-union!

core/classes/classes-tests.factor

@@ -119,3 +119,9 @@ TUPLE: forgotten-predicate-test ;
 
 [ ] [ [ \ forgotten-predicate-test forget ] with-compilation-unit ] unit-test
 [ f ] [ \ forgotten-predicate-test? predicate? ] unit-test
+
+GENERIC: generic-predicate? ( a -- b )
+
+[ ] [ "IN: classes.tests TUPLE: generic-predicate ;" eval( -- ) ] unit-test
+
+[ f ] [ \ generic-predicate? generic? ] unit-test

core/classes/classes.factor

@@ -59,14 +59,15 @@ PRIVATE>
 
 : classes ( -- seq ) implementors-map get keys ;
 
+PREDICATE: predicate < word "predicating" word-prop >boolean ;
+
 : create-predicate-word ( word -- predicate )
-    [ name>> "?" append ] [ vocabulary>> ] bi create ;
+    [ name>> "?" append ] [ vocabulary>> ] bi create
+    dup predicate? [ dup reset-generic ] unless ;
 
 : predicate-word ( word -- predicate )
     "predicate" word-prop first ;
 
-PREDICATE: predicate < word "predicating" word-prop >boolean ;
-
 M: predicate flushable? drop t ;
 
 M: predicate forget*

core/classes/tuple/tuple-tests.factor

@@ -764,3 +764,9 @@ DEFER: factor-crashes-anymore
 ] unit-test
 
 [ 31337 ] [ factor-crashes-anymore ] unit-test
+
+TUPLE: tuple-predicate-redefine-test ;
+
+[ ] [ "IN: classes.tuple.tests TUPLE: tuple-predicate-redefine-test ;" eval( -- ) ] unit-test
+
+[ t ] [ \ tuple-predicate-redefine-test? predicate? ] unit-test

core/sets/sets-docs.factor

@@ -29,8 +29,6 @@ $nl
 "Adding elements to sets:"
 { $subsections
     adjoin
-    conjoin
-    conjoin-at
 }
 { $see-also member? member-eq? any? all? "assocs-sets" } ;
 

extra/benchmark/raytracer-simd/raytracer-simd.factor

@@ -1,13 +1,14 @@
 ! Factor port of the raytracer benchmark from
-! http://www.ffconsultancy.com/free/ray_tracer/languages.html
+! http://www.ffconsultancy.com/languages/ray_tracer/index.html
 
 USING: arrays accessors io io.files io.files.temp
 io.encodings.binary kernel math math.constants math.functions
-math.vectors math.vectors.simd math.vectors.simd.cords math.parser
+math.vectors math.vectors.simd math.vectors.simd.cords
-make sequences sequences.private words hints classes.struct ;
+math.parser make sequences words combinators ;
-QUALIFIED-WITH: alien.c-types c
 IN: benchmark.raytracer-simd
 
+<< SYNTAX: no-compile word t "no-compile" set-word-prop ; >>
+
 ! parameters
 
 ! Normalized { -1 -3 2 }.
@@ -25,7 +26,7 @@ CONSTANT: levels 3
 
 CONSTANT: size 200
 
-: delta ( -- n ) epsilon sqrt ; inline
+: delta ( -- n ) epsilon sqrt ; inline no-compile
 
 TUPLE: ray { orig double-4 read-only } { dir double-4 read-only } ;
 
@@ -35,80 +36,69 @@ TUPLE: hit { normal double-4 read-only } { lambda float read-only } ;
 
 C: <hit> hit
 
-GENERIC: intersect-scene ( hit ray scene -- hit )
-
 TUPLE: sphere { center double-4 read-only } { radius float read-only } ;
 
 C: <sphere> sphere
 
-: sphere-v ( sphere ray -- v )
+: sphere-v ( sphere ray -- v ) [ center>> ] [ orig>> ] bi* v- ; inline no-compile
-    [ center>> ] [ orig>> ] bi* v- ; inline
 
-: sphere-b ( v ray -- b )
+: sphere-b ( v ray -- b ) dir>> v. ; inline no-compile
-    dir>> v. ; inline
 
-: sphere-d ( sphere b v -- d )
+: sphere-d ( sphere b v -- d ) [ radius>> sq ] [ sq ] [ norm-sq ] tri* - + ; inline no-compile
-    [ radius>> sq ] [ sq ] [ norm-sq ] tri* - + ; inline
 
-: -+ ( x y -- x-y x+y )
+: -+ ( x y -- x-y x+y ) [ - ] [ + ] 2bi ; inline no-compile
-    [ - ] [ + ] 2bi ; inline
 
 : sphere-t ( b d -- t )
     -+ dup 0.0 <
-    [ 2drop 1/0. ] [ [ [ 0.0 > ] keep ] dip ? ] if ; inline
+    [ 2drop 1/0. ] [ [ [ 0.0 > ] keep ] dip ? ] if ; inline no-compile
 
 : sphere-b&v ( sphere ray -- b v )
     [ sphere-v ] [ nip ] 2bi
-    [ sphere-b ] [ drop ] 2bi ; inline
+    [ sphere-b ] [ drop ] 2bi ; inline no-compile
 
 : ray-sphere ( sphere ray -- t )
     [ drop ] [ sphere-b&v ] 2bi
     [ drop ] [ sphere-d ] 3bi
-    dup 0.0 < [ 3drop 1/0. ] [ sqrt sphere-t nip ] if ; inline
+    dup 0.0 < [ 3drop 1/0. ] [ sqrt sphere-t nip ] if ; inline no-compile
 
-: if-ray-sphere ( hit ray sphere quot -- hit )
+: if-ray-sphere ( hit ray sphere quot: ( hit ray sphere l -- hit ) -- hit )
-    #! quot: hit ray sphere l -- hit
     [
         [ ] [ swap ray-sphere nip ] [ 2drop lambda>> ] 3tri
         [ drop ] [ < ] 2bi
-    ] dip [ 3drop ] if ; inline
+    ] dip [ 3drop ] if ; inline no-compile
 
 : sphere-n ( ray sphere l -- n )
     [ [ orig>> ] [ dir>> ] bi ] [ center>> ] [ ] tri*
-    swap [ v*n ] dip v- v+ ; inline
+    swap [ v*n ] dip v- v+ ; inline no-compile
-
-M: sphere intersect-scene ( hit ray sphere -- hit )
-    [ [ sphere-n normalize ] keep <hit> nip ] if-ray-sphere ;
-
-HINTS: M\ sphere intersect-scene { hit ray sphere } ;
 
 TUPLE: group < sphere { objs array read-only } ;
 
 : <group> ( objs bound -- group )
-    [ center>> ] [ radius>> ] bi rot group boa ; inline
+    swap [ [ center>> ] [ radius>> ] bi ] dip group boa ; inline no-compile
 
 : make-group ( bound quot -- )
-    swap [ { } make ] dip <group> ; inline
+    swap [ { } make ] dip <group> ; inline no-compile
 
-M: group intersect-scene ( hit ray group -- hit )
+: intersect-scene ( hit ray scene -- hit )
-    [ drop objs>> [ intersect-scene ] with each ] if-ray-sphere ;
+    {
-
+        { [ dup group? ] [ [ drop objs>> [ intersect-scene ] with each ] if-ray-sphere ] }
-HINTS: M\ group intersect-scene { hit ray group } ;
+        { [ dup sphere? ] [ [ [ sphere-n normalize ] keep <hit> nip ] if-ray-sphere ] }
+    } cond ; inline recursive no-compile
 
 CONSTANT: initial-hit T{ hit f double-4{ 0.0 0.0 0.0 0.0 } 1/0. }
 
 : initial-intersect ( ray scene -- hit )
-    [ initial-hit ] 2dip intersect-scene ; inline
+    [ initial-hit ] 2dip intersect-scene ; inline no-compile
 
 : ray-o ( ray hit -- o )
     [ [ orig>> ] [ normal>> delta v*n ] bi* ]
     [ [ dir>> ] [ lambda>> ] bi* v*n ]
-    2bi v+ v+ ; inline
+    2bi v+ v+ ; inline no-compile
 
 : sray-intersect ( ray scene hit -- ray )
-    swap [ ray-o light vneg <ray> ] dip initial-intersect ; inline
+    swap [ ray-o light vneg <ray> ] dip initial-intersect ; inline no-compile
 
-: ray-g ( hit -- g ) normal>> light v. ; inline
+: ray-g ( hit -- g ) normal>> light v. ; inline no-compile
 
 : cast-ray ( ray scene -- g )
     2dup initial-intersect dup lambda>> 1/0. = [
@@ -116,66 +106,61 @@ CONSTANT: initial-hit T{ hit f double-4{ 0.0 0.0 0.0 0.0 } 1/0. }
     ] [
         [ sray-intersect lambda>> 1/0. = ] keep swap
         [ ray-g neg ] [ drop 0.0 ] if
-    ] if ; inline
+    ] if ; inline no-compile
 
 : create-center ( c r d -- c2 )
-    [ 3.0 12.0 sqrt / * ] dip n*v v+ ; inline
+    [ 3.0 12.0 sqrt / * ] dip n*v v+ ; inline no-compile
 
 DEFER: create ( level c r -- scene )
 
 : create-step ( level c r d -- scene )
     over [ create-center ] dip 2.0 / [ 1 - ] 2dip create ;
 
-: create-offsets ( quot -- )
+CONSTANT: create-offsets
     {
         double-4{ -1.0 1.0 -1.0 0.0 }
         double-4{ 1.0 1.0 -1.0 0.0 }
         double-4{ -1.0 1.0 1.0 0.0 }
         double-4{ 1.0 1.0 1.0 0.0 }
-    } swap each ; inline
+    }
 
 : create-bound ( c r -- sphere ) 3.0 * <sphere> ;
 
 : create-group ( level c r -- scene )
     2dup create-bound [
         2dup <sphere> ,
-        [ [ 3dup ] dip create-step , ] create-offsets 3drop
+        create-offsets [ create-step , ] with with with each
     ] make-group ;
 
 : create ( level c r -- scene )
     pick 1 = [ <sphere> nip ] [ create-group ] if ;
 
 : ss-point ( dx dy -- point )
-    [ oversampling /f ] bi@ 0.0 0.0 double-4-boa ;
+    [ oversampling /f ] bi@ 0.0 0.0 double-4-boa ; inline no-compile
 
-: ss-grid ( -- ss-grid )
+: ray-pixel ( scene point -- ray-grid )
-    oversampling iota [ oversampling iota [ ss-point ] with map ] map ;
+    [ 0.0 ] 2dip
+    oversampling iota [
+        oversampling iota [
+            ss-point v+ normalize
+            double-4{ 0.0 0.0 -4.0 0.0 } swap <ray>
+            swap cast-ray +
+        ] with with with each
+    ] with with each ; inline no-compile
 
-: ray-grid ( point ss-grid -- ray-grid )
+: ray-trace ( scene -- grid )
-    [
+    size iota <reversed> [
-        [ v+ normalize double-4{ 0.0 0.0 -4.0 0.0 } swap <ray> ] with map
-    ] with map ;
-
-: ray-pixel ( scene point -- n )
-    ss-grid ray-grid [ 0.0 ] 2dip
-    [ [ swap cast-ray + ] with each ] with each ;
-
-: pixel-grid ( -- grid )
-    size iota reverse [
         size iota [
             [ size 0.5 * - ] bi@ swap size
-            0.0 double-4-boa
+            0.0 double-4-boa ray-pixel
-        ] with map
+        ] with with map
-    ] map ;
+    ] with map ;
 
 : pgm-header ( w h -- )
     "P5\n" % swap # " " % # "\n255\n" % ;
 
 : pgm-pixel ( n -- ) 255 * 0.5 + >fixnum , ;
 
-: ray-trace ( scene -- pixels )
-    pixel-grid [ [ ray-pixel ] with map ] with map ;
-
 : run ( -- string )
     levels double-4{ 0.0 -1.0 0.0 0.0 } 1.0 create ray-trace [
         size size pgm-header

extra/mason/source/source.factor

@@ -8,11 +8,17 @@ IN: mason.source
 : clone-factor ( -- )
     { "git" "clone" } home "factor" append-path suffix try-process ;
 
+: save-git-id ( -- )
+    git-id "git-id" to-file ;
+
+: delete-git-tree ( -- )
+    ".git" delete-tree ;
+
+: download-images ( -- )
+    images [ download-image ] each ;
+
 : prepare-source ( -- )
-    "factor" [
+    "factor" [ save-git-id delete-git-tree download-images ] with-directory ;
-        ".git" delete-tree
-        images [ download-image ] each
-    ] with-directory ;
 
 : package-name ( version -- string )
     "factor-src-" ".zip" surround ;

extra/project-euler/ave-time/ave-time.factor

@@ -1,11 +1,11 @@
 ! Copyright (c) 2007, 2008 Aaron Schaefer.
 ! See http://factorcode.org/license.txt for BSD license.
-USING: combinators.smart formatting fry io kernel macros math
+USING: combinators.smart formatting fry io kernel macros math math.functions
-math.functions math.statistics memory sequences tools.time ;
+math.statistics memory sequences tools.time ;
 IN: project-euler.ave-time
 
 MACRO: collect-benchmarks ( quot n -- seq )
-    swap '[ _ [ [ [ _ nullary ] preserving ] gc benchmark 1000 / ] replicate ] ;
+    swap '[ _ [ [ [ _ nullary ] preserving ] gc benchmark 6 10^ / ] replicate ] ;
 
 : ave-time ( quot n -- )
     [