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

diff --git a/Nmakefile b/Nmakefile
index d0b543d7abde02fe8837031ba727191c5f1930da..8f60176d58ef69fc9e5f320a1050a709157cf738 100755 (executable)
--- a/Nmakefile
+++ b/Nmakefile
@@ -1,3 +1,7 @@
+!IF !DEFINED(BOOTIMAGE_VERSION)
+BOOTIMAGE_VERSION = latest
+!ENDIF
+
 !IF DEFINED(PLATFORM)
 
 LINK_FLAGS = /nologo shell32.lib
@@ -115,6 +119,12 @@ clean:
        del factor.dll
        del factor.dll.lib
 
-.PHONY: all default x86-32 x86-64 clean
+bootimage-x86-32:
+       cscript /nologo build-support\http-get.vbs http://factorcode.org/images/$(BOOTIMAGE_VERSION)/boot.winnt-x86.32.image boot.winnt-x86.32.image
+
+bootimage-x86-64:
+       cscript /nologo build-support\http-get.vbs http://factorcode.org/images/$(BOOTIMAGE_VERSION)/boot.winnt-x86.64.image boot.winnt.x86.64.image
+
+.PHONY: all bootimage-x86-32 bootimage-x86-64 default x86-32 x86-64 clean
 
 .SUFFIXES: .rs

diff --git a/basis/math/vectors/simd/intrinsics/intrinsics.factor b/basis/math/vectors/simd/intrinsics/intrinsics.factor
index 121293f45e661ac370f38951628a21070de49ad5..0ccb6651b992feb01209af9a4cde96292aea14e7 100644 (file)
--- a/basis/math/vectors/simd/intrinsics/intrinsics.factor
+++ b/basis/math/vectors/simd/intrinsics/intrinsics.factor
@@ -1,9 +1,10 @@
 ! (c)2009 Slava Pestov, Joe Groff bsd license
 USING: accessors alien alien.c-types alien.data combinators
 sequences.cords cpu.architecture fry generalizations grouping
-kernel libc locals math math.libm math.order math.ranges
-math.vectors sequences sequences.generalizations
-sequences.private specialized-arrays vocabs.loader ;
+kernel libc locals macros math math.libm math.order
+math.ranges math.vectors sequences sequences.generalizations
+sequences.private sequences.unrolled specialized-arrays
+vocabs.loader words effects.parser locals.parser ;
 QUALIFIED-WITH: alien.c-types c
 SPECIALIZED-ARRAYS:
     c:char c:short c:int c:longlong
@@ -11,6 +12,20 @@ SPECIALIZED-ARRAYS:
     c:float c:double ;
 IN: math.vectors.simd.intrinsics
 
+<<
+: simd-intrinsic-body ( def effect -- def' )
+    '[ _ _ call-effect ] ;
+
+: define-simd-intrinsic ( word def effect -- )
+    [ simd-intrinsic-body ] keep define-declared ;
+
+SYNTAX: SIMD-INTRINSIC:
+    (:) define-declared ;
+SYNTAX: SIMD-INTRINSIC::
+    (::) define-declared ;
+
+>>
+
 : assert-positive ( x -- y ) ;
 
 <PRIVATE
@@ -45,16 +60,16 @@ IN: math.vectors.simd.intrinsics
 
 : [byte>rep-array] ( rep -- class )
     {
-        { char-16-rep      [ [ char-array-cast      ] ] }
-        { uchar-16-rep     [ [ uchar-array-cast     ] ] }
-        { short-8-rep      [ [ short-array-cast     ] ] }
-        { ushort-8-rep     [ [ ushort-array-cast    ] ] }
-        { int-4-rep        [ [ int-array-cast       ] ] }
-        { uint-4-rep       [ [ uint-array-cast      ] ] }
-        { longlong-2-rep   [ [ longlong-array-cast  ] ] }
-        { ulonglong-2-rep  [ [ ulonglong-array-cast ] ] }
-        { float-4-rep      [ [ float-array-cast     ] ] }
-        { double-2-rep     [ [ double-array-cast    ] ] }
+        { char-16-rep      [ [ 16 <direct-char-array>      ] ] }
+        { uchar-16-rep     [ [ 16 <direct-uchar-array>     ] ] }
+        { short-8-rep      [ [  8 <direct-short-array>     ] ] }
+        { ushort-8-rep     [ [  8 <direct-ushort-array>    ] ] }
+        { int-4-rep        [ [  4 <direct-int-array>       ] ] }
+        { uint-4-rep       [ [  4 <direct-uint-array>      ] ] }
+        { longlong-2-rep   [ [  2 <direct-longlong-array>  ] ] }
+        { ulonglong-2-rep  [ [  2 <direct-ulonglong-array> ] ] }
+        { float-4-rep      [ [  4 <direct-float-array>     ] ] }
+        { double-2-rep     [ [  2 <direct-double-array>    ] ] }
     } case ; foldable
 
 : [>rep-array] ( rep -- class )
@@ -133,10 +148,10 @@ IN: math.vectors.simd.intrinsics
 
 PRIVATE>
 
-: (simd-v+)                ( a b rep -- c ) [ + ] components-2map ;
-: (simd-v-)                ( a b rep -- c ) [ - ] components-2map ;
-: (simd-vneg)              ( a   rep -- c ) [ neg ] components-map ;
-:: (simd-v+-)              ( a b rep -- c ) 
+SIMD-INTRINSIC: (simd-v+)                ( a b rep -- c ) [ + ] components-2map ;
+SIMD-INTRINSIC: (simd-v-)                ( a b rep -- c ) [ - ] components-2map ;
+SIMD-INTRINSIC: (simd-vneg)              ( a   rep -- c ) [ neg ] components-map ;
+SIMD-INTRINSIC:: (simd-v+-)              ( a b rep -- c ) 
     a b rep 2>rep-array :> ( a' b' )
     rep <rep-array> :> c'
     0  rep rep-length 1 -  2 <range> [| n |
@@ -147,16 +162,16 @@ PRIVATE>
         n 1 + c' set-nth-unsafe
     ] each
     c' underlying>> ;
-: (simd-vs+)               ( a b rep -- c )
+SIMD-INTRINSIC: (simd-vs+)               ( a b rep -- c )
     dup rep-component-type '[ + _ c-type-clamp ] components-2map ;
-: (simd-vs-)               ( a b rep -- c )
+SIMD-INTRINSIC: (simd-vs-)               ( a b rep -- c )
     dup rep-component-type '[ - _ c-type-clamp ] components-2map ;
-: (simd-vs*)               ( a b rep -- c )
+SIMD-INTRINSIC: (simd-vs*)               ( a b rep -- c )
     dup rep-component-type '[ * _ c-type-clamp ] components-2map ;
-: (simd-v*)                ( a b rep -- c ) [ * ] components-2map ;
-: (simd-v*high)            ( a b rep -- c )
+SIMD-INTRINSIC: (simd-v*)                ( a b rep -- c ) [ * ] components-2map ;
+SIMD-INTRINSIC: (simd-v*high)            ( a b rep -- c )
     dup rep-component-type heap-size -8 * '[ * _ shift ] components-2map ;
-:: (simd-v*hs+)            ( a b rep -- c )
+SIMD-INTRINSIC:: (simd-v*hs+)            ( a b rep -- c )
     rep { char-16-rep uchar-16-rep } member-eq?
     [ uchar-16-rep char-16-rep ]
     [ rep rep ] if :> ( a-rep b-rep )
@@ -169,38 +184,38 @@ PRIVATE>
         [ [ second ] bi@ * ] 2bi +
         wide-type c-type-clamp
     ] wide-rep <rep-array> 2map-as underlying>> ;
-: (simd-v/)                ( a b rep -- c ) [ / ] components-2map ;
-: (simd-vavg)              ( a b rep -- c )
+SIMD-INTRINSIC: (simd-v/)                ( a b rep -- c ) [ / ] components-2map ;
+SIMD-INTRINSIC: (simd-vavg)              ( a b rep -- c )
     [ + dup integer? [ 1 + -1 shift ] [ 0.5 * ] if ] components-2map ;
-: (simd-vmin)              ( a b rep -- c ) [ min ] components-2map ;
-: (simd-vmax)              ( a b rep -- c ) [ max ] components-2map ;
-: (simd-v.)                ( a b rep -- n )
+SIMD-INTRINSIC: (simd-vmin)              ( a b rep -- c ) [ min ] components-2map ;
+SIMD-INTRINSIC: (simd-vmax)              ( a b rep -- c ) [ max ] components-2map ;
+SIMD-INTRINSIC: (simd-v.)                ( a b rep -- n )
     [ 2>rep-array [ [ first ] bi@ * ] 2keep ] keep
     1 swap rep-length [a,b) [ '[ _ swap nth-unsafe ] bi@ * + ] with with each ;
-: (simd-vsqrt)             ( a   rep -- c ) [ fsqrt ] components-map ;
-: (simd-vsad)              ( a b rep -- c ) 2>rep-array [ - abs ] [ + ] 2map-reduce ;
-: (simd-sum)               ( a   rep -- n ) [ + ] components-reduce ;
-: (simd-vabs)              ( a   rep -- c ) [ abs ] components-map ;
-: (simd-vbitand)           ( a b rep -- c ) [ bitand ] bitwise-components-2map ;
-: (simd-vbitandn)          ( a b rep -- c ) [ [ bitnot ] dip bitand ] bitwise-components-2map ;
-: (simd-vbitor)            ( a b rep -- c ) [ bitor ] bitwise-components-2map ;
-: (simd-vbitxor)           ( a b rep -- c ) [ bitxor ] bitwise-components-2map ;
-: (simd-vbitnot)           ( a   rep -- c ) [ bitnot ] bitwise-components-map ;
-: (simd-vand)              ( a b rep -- c ) [ bitand ] bitwise-components-2map ;
-: (simd-vandn)             ( a b rep -- c ) [ [ bitnot ] dip bitand ] bitwise-components-2map ;
-: (simd-vor)               ( a b rep -- c ) [ bitor ] bitwise-components-2map ;
-: (simd-vxor)              ( a b rep -- c ) [ bitxor ] bitwise-components-2map ;
-: (simd-vnot)              ( a   rep -- c ) [ bitnot ] bitwise-components-map ;
-: (simd-vlshift)           ( a n rep -- c ) swap '[ _ shift ] bitwise-components-map ;
-: (simd-vrshift)           ( a n rep -- c ) swap '[ _ neg shift ] bitwise-components-map ;
-: (simd-hlshift)           ( a n rep -- c )
+SIMD-INTRINSIC: (simd-vsqrt)             ( a   rep -- c ) [ fsqrt ] components-map ;
+SIMD-INTRINSIC: (simd-vsad)              ( a b rep -- c ) 2>rep-array [ - abs ] [ + ] 2map-reduce ;
+SIMD-INTRINSIC: (simd-sum)               ( a   rep -- n ) [ + ] components-reduce ;
+SIMD-INTRINSIC: (simd-vabs)              ( a   rep -- c ) [ abs ] components-map ;
+SIMD-INTRINSIC: (simd-vbitand)           ( a b rep -- c ) [ bitand ] bitwise-components-2map ;
+SIMD-INTRINSIC: (simd-vbitandn)          ( a b rep -- c ) [ [ bitnot ] dip bitand ] bitwise-components-2map ;
+SIMD-INTRINSIC: (simd-vbitor)            ( a b rep -- c ) [ bitor ] bitwise-components-2map ;
+SIMD-INTRINSIC: (simd-vbitxor)           ( a b rep -- c ) [ bitxor ] bitwise-components-2map ;
+SIMD-INTRINSIC: (simd-vbitnot)           ( a   rep -- c ) [ bitnot ] bitwise-components-map ;
+SIMD-INTRINSIC: (simd-vand)              ( a b rep -- c ) [ bitand ] bitwise-components-2map ;
+SIMD-INTRINSIC: (simd-vandn)             ( a b rep -- c ) [ [ bitnot ] dip bitand ] bitwise-components-2map ;
+SIMD-INTRINSIC: (simd-vor)               ( a b rep -- c ) [ bitor ] bitwise-components-2map ;
+SIMD-INTRINSIC: (simd-vxor)              ( a b rep -- c ) [ bitxor ] bitwise-components-2map ;
+SIMD-INTRINSIC: (simd-vnot)              ( a   rep -- c ) [ bitnot ] bitwise-components-map ;
+SIMD-INTRINSIC: (simd-vlshift)           ( a n rep -- c ) swap '[ _ shift ] bitwise-components-map ;
+SIMD-INTRINSIC: (simd-vrshift)           ( a n rep -- c ) swap '[ _ neg shift ] bitwise-components-map ;
+SIMD-INTRINSIC: (simd-hlshift)           ( a n rep -- c )
     drop head-slice* 16 0 pad-head ;
-: (simd-hrshift)           ( a n rep -- c )
+SIMD-INTRINSIC: (simd-hrshift)           ( a n rep -- c )
     drop tail-slice 16 0 pad-tail ;
-: (simd-vshuffle-elements) ( a n rep -- c ) [ rep-length 0 pad-tail ] keep (vshuffle) ;
-: (simd-vshuffle2-elements) ( a b n rep -- c ) [ rep-length 0 pad-tail ] keep (vshuffle2) ;
-: (simd-vshuffle-bytes)    ( a b rep -- c ) drop uchar-16-rep (vshuffle) ;
-:: (simd-vmerge-head)      ( a b rep -- c )
+SIMD-INTRINSIC: (simd-vshuffle-elements) ( a n rep -- c ) [ rep-length 0 pad-tail ] keep (vshuffle) ;
+SIMD-INTRINSIC: (simd-vshuffle2-elements) ( a b n rep -- c ) [ rep-length 0 pad-tail ] keep (vshuffle2) ;
+SIMD-INTRINSIC: (simd-vshuffle-bytes)    ( a b rep -- c ) drop uchar-16-rep (vshuffle) ;
+SIMD-INTRINSIC:: (simd-vmerge-head)      ( a b rep -- c )
     a b rep 2>rep-array :> ( a' b' )
     rep <rep-array> :> c'
     rep rep-length 2 /i iota [| n |
@@ -208,7 +223,7 @@ PRIVATE>
         n b' nth-unsafe n 2 * 1 + c' set-nth-unsafe
     ] each
     c' underlying>> ;
-:: (simd-vmerge-tail)      ( a b rep -- c )
+SIMD-INTRINSIC:: (simd-vmerge-tail)      ( a b rep -- c )
     a b rep 2>rep-array :> ( a' b' )
     rep <rep-array> :> c'
     rep rep-length 2 /i :> len
@@ -217,49 +232,49 @@ PRIVATE>
         n len + b' nth-unsafe n 2 * 1 + c' set-nth-unsafe
     ] each
     c' underlying>> ;
-: (simd-v<=)               ( a b rep -- c )
+SIMD-INTRINSIC: (simd-v<=)               ( a b rep -- c )
     dup rep-tf-values '[ <= _ _ ? ] components-2map ; 
-: (simd-v<)                ( a b rep -- c )
+SIMD-INTRINSIC: (simd-v<)                ( a b rep -- c )
     dup rep-tf-values '[ <  _ _ ? ] components-2map ;
-: (simd-v=)                ( a b rep -- c )
+SIMD-INTRINSIC: (simd-v=)                ( a b rep -- c )
     dup rep-tf-values '[ =  _ _ ? ] components-2map ;
-: (simd-v>)                ( a b rep -- c )
+SIMD-INTRINSIC: (simd-v>)                ( a b rep -- c )
     dup rep-tf-values '[ >  _ _ ? ] components-2map ;
-: (simd-v>=)               ( a b rep -- c )
+SIMD-INTRINSIC: (simd-v>=)               ( a b rep -- c )
     dup rep-tf-values '[ >= _ _ ? ] components-2map ;
-: (simd-vunordered?)       ( a b rep -- c )
+SIMD-INTRINSIC: (simd-vunordered?)       ( a b rep -- c )
     dup rep-tf-values '[ unordered? _ _ ? ] components-2map ;
-: (simd-vany?)             ( a   rep -- ? ) [ bitor  ] bitwise-components-reduce zero? not ;
-: (simd-vall?)             ( a   rep -- ? ) [ bitand ] bitwise-components-reduce zero? not ;
-: (simd-vnone?)            ( a   rep -- ? ) [ bitor  ] bitwise-components-reduce zero?     ;
-: (simd-v>float)           ( a   rep -- c )
+SIMD-INTRINSIC: (simd-vany?)             ( a   rep -- ? ) [ bitor  ] bitwise-components-reduce zero? not ;
+SIMD-INTRINSIC: (simd-vall?)             ( a   rep -- ? ) [ bitand ] bitwise-components-reduce zero? not ;
+SIMD-INTRINSIC: (simd-vnone?)            ( a   rep -- ? ) [ bitor  ] bitwise-components-reduce zero?     ;
+SIMD-INTRINSIC: (simd-v>float)           ( a   rep -- c )
     [ >rep-array [ >float ] ] [ >float-vector-rep <rep-array> ] bi map-as underlying>> ;
-: (simd-v>integer)         ( a   rep -- c )
+SIMD-INTRINSIC: (simd-v>integer)         ( a   rep -- c )
     [ >rep-array [ >integer ] ] [ >int-vector-rep <rep-array> ] bi map-as underlying>> ;
-: (simd-vpack-signed)      ( a b rep -- c )
+SIMD-INTRINSIC: (simd-vpack-signed)      ( a b rep -- c )
     [ 2>rep-array cord-append ]
     [ narrow-vector-rep [ <rep-array> ] [ rep-component-type ] bi ] bi
     '[ _ c-type-clamp ] swap map-as underlying>> ;
-: (simd-vpack-unsigned)    ( a b rep -- c )
+SIMD-INTRINSIC: (simd-vpack-unsigned)    ( a b rep -- c )
     [ 2>rep-array cord-append ]
     [ narrow-vector-rep >uint-vector-rep [ <rep-array> ] [ rep-component-type ] bi ] bi
     '[ _ c-type-clamp ] swap map-as underlying>> ;
-: (simd-vunpack-head)      ( a   rep -- c ) 
+SIMD-INTRINSIC: (simd-vunpack-head)      ( a   rep -- c ) 
     [ >rep-array ] [ widen-vector-rep [ rep-length ] [ [>rep-array] ] bi ] bi
     [ head-slice ] dip call( a' -- c' ) underlying>> ;
-: (simd-vunpack-tail)      ( a   rep -- c )
+SIMD-INTRINSIC: (simd-vunpack-tail)      ( a   rep -- c )
     [ >rep-array ] [ widen-vector-rep [ rep-length ] [ [>rep-array] ] bi ] bi
     [ tail-slice ] dip call( a' -- c' ) underlying>> ;
-: (simd-with)              (   n rep -- v )
+SIMD-INTRINSIC: (simd-with)              (   n rep -- v )
     [ rep-length swap '[ _ ] ] [ <rep-array> ] bi replicate-as 
     underlying>> ;
-: (simd-gather-2)          ( m n rep -- v ) <rep-array> [ 2 set-firstn ] keep underlying>> ;
-: (simd-gather-4)          ( m n o p rep -- v ) <rep-array> [ 4 set-firstn ] keep underlying>> ;
-: (simd-select)            ( a n rep -- x ) [ swap ] dip >rep-array nth-unsafe ;
+SIMD-INTRINSIC: (simd-gather-2)          ( m n rep -- v ) <rep-array> [ 2 set-firstn ] keep underlying>> ;
+SIMD-INTRINSIC: (simd-gather-4)          ( m n o p rep -- v ) <rep-array> [ 4 set-firstn ] keep underlying>> ;
+SIMD-INTRINSIC: (simd-select)            ( a n rep -- x ) [ swap ] dip >rep-array nth-unsafe ;
 
-: alien-vector     (       c-ptr n rep -- value )
+SIMD-INTRINSIC: alien-vector     (       c-ptr n rep -- value )
     [ swap <displaced-alien> ] dip rep-size memory>byte-array ;
-: set-alien-vector ( value c-ptr n rep --       )
+SIMD-INTRINSIC: set-alien-vector ( value c-ptr n rep --       )
     [ swap <displaced-alien> swap ] dip rep-size memcpy ;
 
 "compiler.cfg.intrinsics.simd" require

diff --git a/basis/sequences/unrolled/unrolled-docs.factor b/basis/sequences/unrolled/unrolled-docs.factor
index 14533d37e3887611b24664fde53b58396b4ac38b..1e6ba3989748657564b5780f67dd282fddc27365 100644 (file)
--- a/basis/sequences/unrolled/unrolled-docs.factor
+++ b/basis/sequences/unrolled/unrolled-docs.factor
@@ -5,70 +5,70 @@ IN: sequences.unrolled
 
 HELP: unrolled-collect
 { $values
-    { "n" integer } { "quot" { $quotation "( ... n -- ... value )" } } { "into" sequence }
+    { "n" integer } { "quot" { $quotation "( n -- value )" } } { "into" sequence }
 }
 { $description "Unrolled version of " { $link collect } ". " { $snippet "n" } " must be a compile-time constant." } ;
 
 HELP: unrolled-each
 { $values
-    { "seq" sequence } { "len" integer } { "quot" { $quotation "( ... x -- ... )" } }
+    { "seq" sequence } { "len" integer } { "quot" { $quotation "( x -- )" } }
 }
 { $description "Unrolled version of " { $link each } " that iterates over the first " { $snippet "len" } " elements of " { $snippet "seq" } ". " { $snippet "len" } " must be a compile-time constant. If " { $snippet "seq" } " has fewer than " { $snippet "len" } " elements, raises an " { $link unrolled-bounds-error } "." } ;
 
 HELP: unrolled-2each
 { $values
-    { "xseq" sequence } { "yseq" sequence } { "len" integer } { "quot" { $quotation "( ... x y -- ... )" } }
+    { "xseq" sequence } { "yseq" sequence } { "len" integer } { "quot" { $quotation "( x y -- )" } }
 }
 { $description "Unrolled version of " { $link 2each } " that iterates over the first " { $snippet "len" } " elements of " { $snippet "xseq" } " and " { $snippet "yseq" } ". " { $snippet "len" } " must be a compile-time constant. If " { $snippet "seq" } " has fewer than " { $snippet "len" } " elements, raises an " { $link unrolled-bounds-error } "." } ;
 
 HELP: unrolled-each-index
 { $values
-    { "seq" sequence } { "len" integer } { "quot" { $quotation "( ... x i -- ... )" } }
+    { "seq" sequence } { "len" integer } { "quot" { $quotation "( x i -- )" } }
 }
 { $description "Unrolled version of " { $link each-index } " that iterates over the first " { $snippet "len" } " elements of " { $snippet "seq" } ". " { $snippet "len" } " must be a compile-time constant. If " { $snippet "seq" } " has fewer than " { $snippet "len" } " elements, raises an " { $link unrolled-bounds-error } "." } ;
 
 HELP: unrolled-each-integer
 { $values
-    { "n" integer } { "quot" { $quotation "( ... i -- ... )" } }
+    { "n" integer } { "quot" { $quotation "( i -- )" } }
 }
 { $description "Unrolled version of " { $link each-integer } ". " { $snippet "n" } " must be a compile-time constant." } ;
 
 HELP: unrolled-map
 { $values
-    { "seq" sequence } { "len" integer } { "quot" { $quotation "( ... x -- ... newx )" } }
+    { "seq" sequence } { "len" integer } { "quot" { $quotation "( x -- newx )" } }
     { "newseq" sequence }
 }
 { $description "Unrolled version of " { $link map } " that maps over the first " { $snippet "len" } " elements of " { $snippet "seq" } ". " { $snippet "len" } " must be a compile-time constant. If " { $snippet "seq" } " has fewer than " { $snippet "len" } " elements, raises an " { $link unrolled-bounds-error } "." } ;
 
 HELP: unrolled-map-as
 { $values
-    { "seq" sequence } { "len" integer } { "quot" { $quotation "( ... x -- ... newx )" } } { "exemplar" sequence }
+    { "seq" sequence } { "len" integer } { "quot" { $quotation "( x -- newx )" } } { "exemplar" sequence }
     { "newseq" sequence }
 }
 { $description "Unrolled version of " { $link map-as } " that maps over the first " { $snippet "len" } " elements of " { $snippet "seq" } ". " { $snippet "len" } " must be a compile-time constant. If " { $snippet "seq" } " has fewer than " { $snippet "len" } " elements, raises an " { $link unrolled-bounds-error } "." } ;
 
 HELP: unrolled-2map
 { $values
-    { "xseq" sequence } { "yseq" sequence } { "len" integer } { "quot" { $quotation "( ... x y -- ... newx )" } } { "newseq" sequence }
+    { "xseq" sequence } { "yseq" sequence } { "len" integer } { "quot" { $quotation "( x y -- newx )" } } { "newseq" sequence }
 }
 { $description "Unrolled version of " { $link 2map } " that iterates over the first " { $snippet "len" } " elements of " { $snippet "xseq" } " and " { $snippet "yseq" } ". " { $snippet "len" } " must be a compile-time constant. If " { $snippet "seq" } " has fewer than " { $snippet "len" } " elements, raises an " { $link unrolled-bounds-error } "." } ;
 
 HELP: unrolled-2map-as
 { $values
-    { "xseq" sequence } { "yseq" sequence } { "len" integer } { "quot" { $quotation "( ... x y -- ... newx )" } } { "exemplar" sequence } { "newseq" sequence }
+    { "xseq" sequence } { "yseq" sequence } { "len" integer } { "quot" { $quotation "( x y -- newx )" } } { "exemplar" sequence } { "newseq" sequence }
 }
 { $description "Unrolled version of " { $link 2map-as } " that iterates over the first " { $snippet "len" } " elements of " { $snippet "xseq" } " and " { $snippet "yseq" } ". " { $snippet "len" } " must be a compile-time constant. If " { $snippet "seq" } " has fewer than " { $snippet "len" } " elements, raises an " { $link unrolled-bounds-error } "." } ;
 
 HELP: unrolled-map-index
 { $values
-    { "seq" sequence } { "len" integer } { "quot" { $quotation "( ... x i -- ... newx )" } }
+    { "seq" sequence } { "len" integer } { "quot" { $quotation "( x i -- newx )" } }
     { "newseq" sequence }
 }
 { $description "Unrolled version of " { $link map-index } " that maps over the first " { $snippet "len" } " elements of " { $snippet "seq" } ". " { $snippet "len" } " must be a compile-time constant. If " { $snippet "seq" } " has fewer than " { $snippet "len" } " elements, raises an " { $link unrolled-bounds-error } "." } ;
 
 HELP: unrolled-map-integers
 { $values
-    { "n" integer } { "quot" { $quotation "( ... n -- ... value )" } } { "exemplar" sequence } { "newseq" sequence }
+    { "n" integer } { "quot" { $quotation "( n -- value )" } } { "exemplar" sequence } { "newseq" sequence }
 }
 { $description "Unrolled version of " { $link map-integers } ". " { $snippet "n" } " must be a compile-time constant." } ;
 

diff --git a/basis/sequences/unrolled/unrolled-tests.factor b/basis/sequences/unrolled/unrolled-tests.factor
index 57a1099d8faa31b7618b6ded31b528a9b2fe04c7..b9b82e2fea1eeeafac4172d56e273b4204a8cf88 100644 (file)
--- a/basis/sequences/unrolled/unrolled-tests.factor
+++ b/basis/sequences/unrolled/unrolled-tests.factor
@@ -7,18 +7,28 @@ IN: sequences.unrolled.tests
 [ { "0" "1" "2" } ] [ { 0 1 2 } [ 3 [ number>string ] unrolled-map ] compile-call ] unit-test
 
 [ { "0" "1" "2" } ] [ [ { 0 1 2 } 3 [ number>string , ] unrolled-each ] { } make ] unit-test
+[ { "0" "1" "2" } ] [ [ { 0 1 2 } [ 3 [ number>string , ] unrolled-each ] compile-call ] { } make ] unit-test
 
 [ { "a0" "b1" "c2" } ]
 [ [ { "a" "b" "c" } 3 [ number>string append , ] unrolled-each-index ] { } make ] unit-test
 
+[ { "a0" "b1" "c2" } ]
+[ [ { "a" "b" "c" } [ 3 [ number>string append , ] unrolled-each-index ] compile-call ] { } make ] unit-test
+
 [ { "aI" "bII" "cIII" } ]
-[ [ { "a" "b" "c" } { "I" "II" "III" } 3 [ append , ] unrolled-2each ] { } make ] unit-test
+[ [ { "a" "b" "c" } { "I" "II" "III" } [ 3 [ append , ] unrolled-2each ] compile-call ] { } make ] unit-test
 
 [ { "aI" "bII" "cIII" } ]
 [ { "a" "b" "c" } { "I" "II" "III" } 3 [ append ] unrolled-2map ] unit-test
 
+[ { "aI" "bII" "cIII" } ]
+[ { "a" "b" "c" } { "I" "II" "III" } [ 3 [ append ] unrolled-2map ] compile-call ] unit-test
+
 [ { "a0" "b1" "c2" } ]
 [ { "a" "b" "c" } 3 [ number>string append ] unrolled-map-index ] unit-test
 
+[ { "a0" "b1" "c2" } ]
+[ { "a" "b" "c" } [ 3 [ number>string append ] unrolled-map-index ] compile-call ] unit-test
+
 [ { 0 1 2 } 4 [ number>string ] unrolled-map ] [ unrolled-bounds-error? ] must-fail-with
 [ { 0 1 2 3 } { 0 1 2 } 4 [ number>string append ] unrolled-2map ] [ unrolled-2bounds-error? ] must-fail-with

diff --git a/basis/sequences/unrolled/unrolled.factor b/basis/sequences/unrolled/unrolled.factor
index dd94bfa9418f072bd5ce2663b1a22f65593f6925..23ba40202c767a1fc15c535e6508384d77dc3a89 100644 (file)
--- a/basis/sequences/unrolled/unrolled.factor
+++ b/basis/sequences/unrolled/unrolled.factor
@@ -1,21 +1,25 @@
 ! (c)2010 Joe Groff bsd license
-USING: combinators.short-circuit fry generalizations kernel
-locals macros math quotations sequences ;
+USING: combinators combinators.short-circuit fry generalizations kernel
+locals macros math quotations sequences compiler.tree.propagation.transforms ;
 FROM: sequences.private => (each) (each-index) (collect) (2each) ;
 IN: sequences.unrolled
 
 <PRIVATE
-MACRO: (unrolled-each-integer) ( n -- )
-    [ iota >quotation ] keep '[ _ dip _ napply ] ;
+: (unrolled-each-integer) ( quot n -- )
+    swap '[ _ call( i -- ) ] each-integer ;
+
+<< \ (unrolled-each-integer) [
+    iota [ '[ _ swap call( i -- ) ] ] [ ] map-as '[ _ cleave ]
+] 1 define-partial-eval >>
 PRIVATE>
 
-: unrolled-each-integer ( ... n quot: ( ... i -- ... ) -- ... )
+: unrolled-each-integer ( n quot: ( i -- ) -- )
     swap (unrolled-each-integer) ; inline
 
-: unrolled-collect ( ... n quot: ( ... n -- ... value ) into -- ... )
+: unrolled-collect ( n quot: ( n -- value ) into -- )
     (collect) unrolled-each-integer ; inline
 
-: unrolled-map-integers ( ... n quot: ( ... n -- ... value ) exemplar -- ... newseq )
+: unrolled-map-integers ( n quot: ( n -- value ) exemplar -- newseq )
     [ over ] dip [ [ unrolled-collect ] keep ] new-like ; inline
 
 ERROR: unrolled-bounds-error
@@ -42,44 +46,44 @@ ERROR: unrolled-2bounds-error
 : (unrolled-2each) ( xseq yseq len quot -- len quot )
     [ '[ _ ] 2dip ] dip (2each) nip ; inline
 
-: unrolled-each-unsafe ( ... seq len quot: ( ... x -- ... ) -- ... )
+: unrolled-each-unsafe ( seq len quot: ( x -- ) -- )
     (unrolled-each) unrolled-each-integer ; inline
 
-: unrolled-2each-unsafe ( ... xseq yseq len quot: ( ... x y -- ... ) -- ... )
+: unrolled-2each-unsafe ( xseq yseq len quot: ( x y -- ) -- )
     (unrolled-2each) unrolled-each-integer ; inline
 
-: unrolled-each-index-unsafe ( ... seq len quot: ( ... x -- ... ) -- ... )
+: unrolled-each-index-unsafe ( seq len quot: ( x -- ) -- )
     (unrolled-each-index) unrolled-each-integer ; inline
 
-: unrolled-map-as-unsafe ( ... seq len quot: ( ... x -- ... newx ) exemplar -- ... newseq )
+: unrolled-map-as-unsafe ( seq len quot: ( x -- newx ) exemplar -- newseq )
     [ (unrolled-each) ] dip unrolled-map-integers ; inline
 
-: unrolled-2map-as-unsafe ( ... xseq yseq len quot: ( ... x y -- ... newx ) exemplar -- ... newseq )
+: unrolled-2map-as-unsafe ( xseq yseq len quot: ( x y -- newx ) exemplar -- newseq )
     [ (unrolled-2each) ] dip unrolled-map-integers ; inline
 
 PRIVATE>
 
-: unrolled-each ( ... seq len quot: ( ... x -- ... ) -- ... )
+: unrolled-each ( seq len quot: ( x -- ) -- )
     unrolled-bounds-check unrolled-each-unsafe ; inline
 
-: unrolled-2each ( ... xseq yseq len quot: ( ... x y -- ... ) -- ... )
+: unrolled-2each ( xseq yseq len quot: ( x y -- ) -- )
     unrolled-2bounds-check unrolled-2each-unsafe ; inline
 
-: unrolled-each-index ( ... seq len quot: ( ... x i -- ... ) -- ... )
+: unrolled-each-index ( seq len quot: ( x i -- ) -- )
     unrolled-bounds-check unrolled-each-index-unsafe ; inline
 
-: unrolled-map-as ( ... seq len quot: ( ... x -- ... newx ) exemplar -- ... newseq )
+: unrolled-map-as ( seq len quot: ( x -- newx ) exemplar -- newseq )
     [ unrolled-bounds-check ] dip unrolled-map-as-unsafe ; inline
 
-: unrolled-2map-as ( ... xseq yseq len quot: ( ... x y -- ... newx ) exemplar -- ... newseq )
+: unrolled-2map-as ( xseq yseq len quot: ( x y -- newx ) exemplar -- newseq )
     [ unrolled-2bounds-check ] dip unrolled-2map-as-unsafe ; inline
 
-: unrolled-map ( ... seq len quot: ( ... x -- ... newx ) -- ... newseq )
+: unrolled-map ( seq len quot: ( x -- newx ) -- newseq )
     pick unrolled-map-as ; inline
 
-: unrolled-2map ( ... xseq yseq len quot: ( ... x y -- ... newx ) -- ... newseq )
+: unrolled-2map ( xseq yseq len quot: ( x y -- newx ) -- newseq )
     4 npick unrolled-2map-as ; inline
 
-: unrolled-map-index ( ... seq len quot: ( ... x i -- ... newx ) -- ... newseq )
+: unrolled-map-index ( seq len quot: ( x i -- newx ) -- newseq )
     [ dup length iota ] 2dip unrolled-2map ; inline
 

diff --git a/build-support/http-get.vbs b/build-support/http-get.vbs
new file mode 100644 (file)
index 0000000..1a279e2
--- /dev/null
+++ b/build-support/http-get.vbs
@@ -0,0 +1,29 @@
+if WScript.Arguments.Count < 2 then\r
+    WScript.Echo "usage: http-get.vbs source-url dest-file"\r
+    WScript.Quit 1\r
+else\r
+    source_url = WScript.Arguments.Item(0)\r
+    dest_filename = WScript.Arguments.Item(1)\r
+\r
+    dim http, source_data\r
+    set http = CreateObject("WinHttp.WinHttpRequest.5.1")\r
+    http.Open "GET", source_url, false\r
+    http.Send\r
+\r
+    if http.Status = 200 then\r
+        dim dest_stream\r
+        set dest_stream = CreateObject("ADODB.Stream")\r
+\r
+        dest_stream.Type = 1 ' adTypeBinary\r
+        dest_stream.Open\r
+        dest_stream.Write http.ResponseBody\r
+        dest_stream.SaveToFile dest_filename, 2 ' adSaveCreateOverWrite\r
+\r
+        set dest_stream = nothing\r
+    else\r
+        WScript.Echo CStr(http.Status) + " " + http.StatusText + " when fetching " + source_url\r
+        WScript.Quit 1\r
+    end if\r
+\r
+    set http = nothing\r
+end if\r