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

Nmakefile

@@ -1,3 +1,7 @@
+!IF !DEFINED(BOOTIMAGE_VERSION)
+BOOTIMAGE_VERSION = latest
+!ENDIF
+
 !IF DEFINED(PLATFORM)
 
 LINK_FLAGS = /nologo shell32.lib
@@ -102,18 +106,19 @@ default:
 	@exit 1
 
 x86-32:
-	nmake PLATFORM=x86-32 /f Nmakefile all
+	nmake /nologo PLATFORM=x86-32 /f Nmakefile all
 
 x86-64:
-	nmake PLATFORM=x86-64 /f Nmakefile all
+	nmake /nologo PLATFORM=x86-64 /f Nmakefile all
 
 clean:
 	del vm\*.obj
-	del factor.lib
+	if exist factor.lib del factor.lib
-	del factor.com
+	if exist factor.res del factor.res
-	del factor.exe
+	if exist factor.com del factor.com
-	del factor.dll
+	if exist factor.exe del factor.exe
-	del factor.dll.lib
+	if exist factor.dll del factor.dll
+	if exist factor.dll.lib del factor.dll.lib
 
 .PHONY: all default x86-32 x86-64 clean
 

basis/alarms/alarms-docs.factor

@@ -8,6 +8,10 @@ HELP: start-alarm
 { $values { "alarm" alarm } }
 { $description "Starts an alarm." } ;
 
+HELP: restart-alarm
+{ $values { "alarm" alarm } }
+{ $description "Starts or restarts an alarm. Restarting an alarm causes the a sleep of initial delay nanoseconds before looping. An alarm's parameters may be modified and restarted with this word." } ;
+
 HELP: stop-alarm
 { $values { "alarm" alarm } }
 { $description "Prevents an alarm from calling its quotation again. Has no effect on alarms that are not currently running." } ;
@@ -56,7 +60,7 @@ ARTICLE: "alarms" "Alarms"
 "Create an alarm before starting it:"
 { $subsections <alarm> }
 "Starting an alarm:"
-{ $subsections start-alarm }
+{ $subsections start-alarm restart-alarm }
 "Stopping an alarm:"
 { $subsections stop-alarm }
 

basis/alarms/alarms-tests.factor

@@ -44,3 +44,24 @@ IN: alarms.tests
     2 seconds sleep stop-alarm
     1/2 seconds sleep
 ] unit-test
+
+[ { 0 } ] [
+    { 0 }
+    dup '[ 1 _ set-first ] 300 milliseconds later
+    150 milliseconds sleep
+    [ restart-alarm ] [ 200 milliseconds sleep stop-alarm ] bi
+] unit-test
+
+[ { 1 } ] [
+    { 0 }
+    dup '[ 0 _ [ 1 + ] change-nth ] 200 milliseconds later
+    100 milliseconds sleep restart-alarm 300 milliseconds sleep
+] unit-test
+
+[ { 4 } ] [
+    { 0 }
+    dup '[ 0 _ [ 1 + ] change-nth ] 300 milliseconds 300 milliseconds
+    <alarm> dup start-alarm
+    700 milliseconds sleep dup restart-alarm
+    700 milliseconds sleep stop-alarm 500 milliseconds sleep
+] unit-test

basis/alarms/alarms.factor

@@ -12,6 +12,7 @@ TUPLE: alarm
     interval-nanos
     iteration-start-nanos
     quotation-running?
+    restart?
     thread ;
 
 <PRIVATE
@@ -33,7 +34,7 @@ M: duration >nanoseconds duration>nanoseconds >integer ;
     >>iteration-start-nanos ;
 
 : stop-alarm? ( alarm -- ? )
-    thread>> self eq? not ;
+    { [ thread>> self eq? not ] [ restart?>> ] } 1|| ;
 
 DEFER: call-alarm-loop
 
@@ -60,6 +61,19 @@ DEFER: call-alarm-loop
         maybe-loop-alarm
     ] if ;
 
+: sleep-delay ( alarm -- )
+    dup stop-alarm? [
+        drop
+    ] [
+        nano-count >>start-nanos
+        delay-nanos>> [ sleep ] when*
+    ] if ;
+
+: alarm-loop ( alarm -- )
+    [ sleep-delay ]
+    [ nano-count >>iteration-start-nanos call-alarm-loop ]
+    [ dup restart?>> [ f >>restart? alarm-loop ] [ drop ] if ] tri ;
+
 PRIVATE>
 
 : <alarm> ( quot delay-duration/f interval-duration/f -- alarm )
@@ -70,11 +84,7 @@ PRIVATE>
 
 : start-alarm ( alarm -- )
     [
-        '[
+        '[ _ alarm-loop ] "Alarm execution" spawn
-            _ nano-count >>start-nanos
-            [ delay-nanos>> [ sleep ] when* ]
-            [ nano-count >>iteration-start-nanos call-alarm-loop ] bi
-        ] "Alarm execution" spawn
     ] keep thread<< ;
 
 : stop-alarm ( alarm -- )
@@ -84,6 +94,14 @@ PRIVATE>
         [ [ interrupt ] when* f ] change-thread drop
     ] if ;
 
+: restart-alarm ( alarm -- )
+    t >>restart?
+    dup quotation-running?>> [
+        drop
+    ] [
+        dup thread>> [ nip interrupt ] [ start-alarm ] if*
+    ] if ;
+
 <PRIVATE
 
 : (start-alarm) ( quot start-duration interval-duration -- alarm )

basis/alien/prettyprint/prettyprint-tests.factor

@@ -0,0 +1,55 @@
+USING: alien.c-types alien.prettyprint alien.syntax
+io.streams.string see tools.test prettyprint ;
+IN: alien.prettyprint.tests
+
+CONSTANT: FOO 10
+
+FUNCTION: int function_test ( float x, int[4][FOO] y, char* z, ushort *w ) ;
+
+[ "USING: alien.c-types alien.syntax ;
+IN: alien.prettyprint.tests
+FUNCTION: int function_test
+    ( float x, int[4][FOO] y, char* z, ushort* w ) ;
+" ] [
+    [ \ function_test see ] with-string-writer
+] unit-test
+
+FUNCTION-ALIAS: function-test int function_test
+    ( float x, int[4][FOO] y, char* z, ushort *w ) ;
+
+[ "USING: alien.c-types alien.syntax ;
+IN: alien.prettyprint.tests
+FUNCTION-ALIAS: function-test int function_test
+    ( float x, int[4][FOO] y, char* z, ushort* w ) ;
+" ] [
+    [ \ function-test see ] with-string-writer
+] unit-test
+
+C-TYPE: opaque-c-type
+
+[ "USING: alien.syntax ;
+IN: alien.prettyprint.tests
+C-TYPE: opaque-c-type
+" ] [
+    [ \ opaque-c-type see ] with-string-writer
+] unit-test
+
+TYPEDEF: pointer: int pint
+
+[ "USING: alien.c-types alien.syntax ;
+IN: alien.prettyprint.tests
+TYPEDEF: int* pint
+" ] [
+    [ \ pint see ] with-string-writer
+] unit-test
+
+[ "pointer: int" ] [ pointer: int unparse ] unit-test
+
+CALLBACK: void callback-test ( int x, float[4] y ) ;
+
+[ "USING: alien.c-types alien.syntax ;
+IN: alien.prettyprint.tests
+CALLBACK: void callback-test ( int x, float[4] y ) ;
+" ] [
+    [ \ callback-test see ] with-string-writer
+] unit-test

basis/alien/prettyprint/prettyprint.factor

@@ -1,10 +1,10 @@
-! Copyright (C) 2008 Slava Pestov.
+! Copyright (C) 2008, 2010 Slava Pestov, Joe Groff.
 ! See http://factorcode.org/license.txt for BSD license.
 USING: accessors kernel combinators alien alien.enums
 alien.strings alien.c-types alien.parser alien.syntax arrays
-assocs effects math.parser prettyprint.backend prettyprint.custom
+assocs effects math.parser prettyprint prettyprint.backend
-prettyprint.sections definitions see see.private sequences
+prettyprint.custom prettyprint.sections definitions see
-strings words ;
+see.private sequences strings words ;
 IN: alien.prettyprint
 
 M: alien pprint*
@@ -23,21 +23,26 @@ M: c-type-word declarations. drop ;
 <PRIVATE
 GENERIC: pointer-string ( pointer -- string/f )
 M: object pointer-string drop f ;
-M: word pointer-string name>> ;
+M: word pointer-string [ record-vocab ] [ name>> ] bi ;
 M: pointer pointer-string to>> pointer-string [ CHAR: * suffix ] [ f ] if* ;
+
+GENERIC: c-type-string ( c-type -- string )
+
+M: word c-type-string [ record-vocab ] [ name>> ] bi ;
+M: pointer c-type-string dup pointer-string [ ] [ unparse ] ?if ;
+M: wrapper c-type-string wrapped>> c-type-string ;
+M: array c-type-string
+    unclip
+    [ [ unparse "[" "]" surround ] map ]
+    [ c-type-string ] bi*
+    prefix "" join ;
 PRIVATE>
 
-GENERIC: pprint-c-type ( c-type -- )
+: pprint-c-type ( c-type -- )
-M: word pprint-c-type pprint-word ;
+    [ c-type-string ] keep present-text ;
-M: pointer pprint-c-type
-    dup pointer-string
-    [ swap present-text ]
-    [ pprint* ] if* ;
-M: wrapper pprint-c-type wrapped>> pprint-word ;
-M: string pprint-c-type text ;
-M: array pprint-c-type pprint* ;
 
-M: pointer pprint* \ pointer: pprint-word to>> pprint-c-type ;
+M: pointer pprint*
+    <flow \ pointer: pprint-word to>> pprint* block> ;
 
 M: typedef-word definer drop \ TYPEDEF: f ;
 
@@ -102,11 +107,11 @@ M: alien-callback-type-word synopsis*
         [ seeing-word ]
         [ "callback-library" word-prop pprint-library ]
         [ definer. ]
-        [ def>> first pprint-c-type ]
+        [ def>> first first pprint-c-type ]
         [ pprint-word ]
         [
             <block "(" text 
-            [ def>> second ] [ "callback-effect" word-prop in>> ] bi
+            [ def>> first second ] [ "callback-effect" word-prop in>> ] bi
             pprint-function-args
             ")" text block>
         ]

basis/bootstrap/image/download/download.factor

@@ -18,20 +18,19 @@ CONSTANT: url URL" http://factorcode.org/images/latest/"
         bi = not
     ] [ drop t ] if ;
 
-: download-image ( arch -- )
+: verify-image ( image -- )
-    url swap boot-image-name >url derive-url download ;
+    need-new-image? [ "Boot image corrupt" throw ] when ;
 
-: maybe-download-image ( arch -- )
+: download-image ( image -- )
-    dup boot-image-name need-new-image? [
+    [ url swap >url derive-url download ]
-         dup download-image
+    [ verify-image ]
-         need-new-image? [
+    bi ;
-             "Boot image corrupt, or checksums.txt on server out of date" throw
-         ] when
-    ] [
-        "Boot image up to date" print
-        drop
-    ] if ;
 
-: download-my-image ( -- ) my-arch maybe-download-image ;
+: maybe-download-image ( image -- ? )
+    dup need-new-image?
+    [ download-image t ] [ drop f ] if ;
+
+: download-my-image ( -- )
+    my-arch boot-image-name maybe-download-image drop ;
 
 MAIN: download-my-image

basis/calendar/model/model.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: calendar namespaces models threads kernel init ;
 IN: calendar.model
@@ -15,5 +15,7 @@ SYMBOL: time
         (time-thread)
     ] "Time model update" spawn drop ;
 
+[
     f <model> time set-global
-[ time-thread ] "calendar.model" add-startup-hook
+    time-thread
+] "calendar.model" add-startup-hook

basis/command-line/command-line.factor

@@ -28,7 +28,7 @@ SYMBOL: command-line
 : load-vocab-roots ( -- )
     "user-init" get [
         "factor-roots" rc-path dup exists? [
-            utf8 file-lines [ add-vocab-root ] each
+            utf8 file-lines harvest [ add-vocab-root ] each
         ] [ drop ] if
     ] when ;
 

basis/compiler/cfg/instructions/instructions.factor

@@ -345,6 +345,11 @@ def: dst
 use: src1 src2
 literal: rep ;
 
+PURE-INSN: ##float-pack-vector
+def: dst
+use: src
+literal: rep ;
+
 PURE-INSN: ##signed-pack-vector
 def: dst
 use: src1 src2

basis/compiler/cfg/intrinsics/simd/backend/backend.factor

@@ -28,6 +28,7 @@ M: ##shuffle-vector-imm insn-available? rep>> %shuffle-vector-imm-reps member? ;
 M: ##shuffle-vector-halves-imm insn-available? rep>> %shuffle-vector-halves-imm-reps member? ;
 M: ##merge-vector-head insn-available? rep>> %merge-vector-reps member? ;
 M: ##merge-vector-tail insn-available? rep>> %merge-vector-reps member? ;
+M: ##float-pack-vector insn-available? rep>> %float-pack-vector-reps member? ;
 M: ##signed-pack-vector insn-available? rep>> %signed-pack-vector-reps member? ;
 M: ##unsigned-pack-vector insn-available? rep>> %unsigned-pack-vector-reps member? ;
 M: ##unpack-vector-head insn-available? rep>> %unpack-vector-head-reps member? ;

basis/compiler/cfg/intrinsics/simd/simd.factor

@@ -570,7 +570,12 @@ PREDICATE: fixnum-vector-rep < int-vector-rep
 
 : emit-simd-vpack-signed ( node -- )
     {
-        [ ^^signed-pack-vector ]
+        { double-2-rep [| src1 src2 rep |
+            src1 double-2-rep ^^float-pack-vector :> dst-head
+            src2 double-2-rep ^^float-pack-vector :> dst-tail
+            dst-head dst-tail { 0 1 0 1 } float-4-rep ^^shuffle-vector-halves-imm
+        ] }
+        { int-vector-rep [ ^^signed-pack-vector ] }
     } emit-vv-vector-op ;
 
 : emit-simd-vpack-unsigned ( node -- )

basis/compiler/codegen/codegen.factor

@@ -191,6 +191,7 @@ CODEGEN: ##shuffle-vector %shuffle-vector
 CODEGEN: ##tail>head-vector %tail>head-vector
 CODEGEN: ##merge-vector-head %merge-vector-head
 CODEGEN: ##merge-vector-tail %merge-vector-tail
+CODEGEN: ##float-pack-vector %float-pack-vector
 CODEGEN: ##signed-pack-vector %signed-pack-vector
 CODEGEN: ##unsigned-pack-vector %unsigned-pack-vector
 CODEGEN: ##unpack-vector-head %unpack-vector-head

basis/cpu/architecture/architecture.factor

@@ -314,6 +314,7 @@ HOOK: %shuffle-vector-halves-imm cpu ( dst src1 src2 shuffle rep -- )
 HOOK: %tail>head-vector cpu ( dst src rep -- )
 HOOK: %merge-vector-head cpu ( dst src1 src2 rep -- )
 HOOK: %merge-vector-tail cpu ( dst src1 src2 rep -- )
+HOOK: %float-pack-vector cpu ( dst src rep -- )
 HOOK: %signed-pack-vector cpu ( dst src1 src2 rep -- )
 HOOK: %unsigned-pack-vector cpu ( dst src1 src2 rep -- )
 HOOK: %unpack-vector-head cpu ( dst src rep -- )
@@ -371,6 +372,7 @@ HOOK: %shuffle-vector-reps cpu ( -- reps )
 HOOK: %shuffle-vector-imm-reps cpu ( -- reps )
 HOOK: %shuffle-vector-halves-imm-reps cpu ( -- reps )
 HOOK: %merge-vector-reps cpu ( -- reps )
+HOOK: %float-pack-vector-reps cpu ( -- reps )
 HOOK: %signed-pack-vector-reps cpu ( -- reps )
 HOOK: %unsigned-pack-vector-reps cpu ( -- reps )
 HOOK: %unpack-vector-head-reps cpu ( -- reps )
@@ -423,6 +425,7 @@ M: object %shuffle-vector-reps { } ;
 M: object %shuffle-vector-imm-reps { } ;
 M: object %shuffle-vector-halves-imm-reps { } ;
 M: object %merge-vector-reps { } ;
+M: object %float-pack-vector-reps { } ;
 M: object %signed-pack-vector-reps { } ;
 M: object %unsigned-pack-vector-reps { } ;
 M: object %unpack-vector-head-reps { } ;

basis/cpu/x86/sse/sse.factor

@@ -298,6 +298,14 @@ M: x86 %merge-vector-reps
         { sse2? { double-2-rep char-16-rep uchar-16-rep short-8-rep ushort-8-rep int-4-rep uint-4-rep longlong-2-rep ulonglong-2-rep } }
     } available-reps ;
 
+M: x86 %float-pack-vector
+    drop CVTPD2PS ;
+
+M: x86 %float-pack-vector-reps
+    {
+        { sse2? { double-2-rep } }
+    } available-reps ;
+
 M: x86 %signed-pack-vector
     [ two-operand ] keep
     {

basis/images/png/png.factor

@@ -290,14 +290,6 @@ ERROR: invalid-color-type/bit-depth loading-png ;
 : validate-truecolor-alpha ( loading-png -- loading-png )
     { 8 16 } validate-bit-depth ;
 
-: pad-bitmap ( image -- image )
-    dup dim>> second 4 divisor? [
-        dup [ bytes-per-pixel ]
-        [ dim>> first * ]
-        [ dim>> first 4 mod ] tri
-        '[ _ group [ _ 0 <array> append ] map B{ } concat-as ] change-bitmap
-    ] unless ;
-
 : loading-png>bitmap ( loading-png -- bytes component-order )
     dup color-type>> {
         { greyscale [
@@ -323,7 +315,7 @@ ERROR: invalid-color-type/bit-depth loading-png ;
         [ loading-png>bitmap [ >>bitmap ] [ >>component-order ] bi* ]
         [ [ width>> ] [ height>> ] bi 2array >>dim ]
         [ png-component >>component-type ]
-    } cleave pad-bitmap ;
+    } cleave ;
 
 : load-png ( stream -- loading-png )
     [

basis/io/thread/thread.factor

@@ -14,6 +14,9 @@ SYMBOL: io-thread-running?
     [ [ io-thread-running? get-global ] [ io-thread ] while ]
     "I/O wait" spawn drop ;
 
+: stop-io-thread ( -- )
+    f io-thread-running? set-global ;
+
 [
     t io-thread-running? set-global
     start-io-thread

basis/json/reader/reader-docs.factor

@@ -1,14 +1,18 @@
 ! Copyright (C) 2006 Chris Double.
 ! See http://factorcode.org/license.txt for BSD license.
-USING: help.markup help.syntax ;
+USING: help.markup help.syntax kernel ;
 IN: json.reader
 
 HELP: json>
 { $values { "string" "a string in JSON format" } { "object" "a deserialized object" } }
 { $description "Deserializes the JSON formatted string into a Factor object. JSON objects are converted to Factor hashtables. All other JSON objects convert to their obvious Factor equivalents." } ;
 
+HELP: read-jsons
+{ $values { "objects" "a vector of deserialized objects" } }
+{ $description "Reads JSON formatted strings into a vector of Factor object until the end of the stream is reached. JSON objects are converted to Factor hashtables. All other JSON objects convert to their obvious Factor equivalents." } ;
+
 ARTICLE: "json.reader" "JSON reader"
 "The " { $vocab-link "json.reader" } " vocabulary defines a word for parsing strings in JSON format."
-{ $subsections json> } ;
+{ $subsections json> read-jsons } ;
 
 ABOUT: "json.reader"

basis/json/reader/reader-tests.factor

@@ -1,5 +1,5 @@
 USING: assocs arrays json.reader kernel strings tools.test
-hashtables json ;
+hashtables json io.streams.string ;
 IN: json.reader.tests
 
 { f } [ "false" json> ] unit-test
@@ -59,5 +59,8 @@ IN: json.reader.tests
 { 0 } [ "0      " json> ] unit-test
 { 0 } [ "   0   " json> ] unit-test
 
+{ V{ H{ { "a" "b" } } H{ { "c" "d" } } } }
+[ """{"a": "b"} {"c": "d"}""" [ read-jsons ] with-string-reader ] unit-test
+
 ! empty objects are allowed as values in objects
 { H{ { "foo" H{ } } } } [ "{ \"foo\" : {}}" json> ] unit-test

basis/json/reader/reader.factor

@@ -78,7 +78,7 @@ DEFER: j-string
             { CHAR: {  [ 2 [ V{ } clone over push ] times ] }
             { CHAR: :  [ v-pick-push ] }
             { CHAR: }  [ (close-hash) ] }
-            { CHAR: \u000020 [ ] }
+            { CHAR: \s [ ] }
             { CHAR: \t [ ] }
             { CHAR: \r [ ] }
             { CHAR: \n [ ] }
@@ -89,10 +89,10 @@ DEFER: j-string
         } case
     ] when* ;
 
-: (json-parser>) ( string -- object )
-    [ V{ } clone [ read1 dup ] [ scan ] while drop first ] with-string-reader ;
-
 PRIVATE>
 
+: read-jsons ( -- objects )
+    V{ } clone [ read1 dup ] [ scan ] while drop ;
+
 : json> ( string -- object )
-    (json-parser>) ;
+    [ read-jsons first ] with-string-reader ;

basis/libc/libc.factor

@@ -100,5 +100,7 @@ FUNCTION: int memcmp ( void* a, void* b, ulong size ) ;
 
 FUNCTION: size_t strlen ( c-string alien ) ;
 
+FUNCTION: int system ( c-string command ) ;
+
 DESTRUCTOR: free
 DESTRUCTOR: (free)

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
+USING: accessors alien alien.data combinators
 sequences.cords cpu.architecture fry generalizations grouping
-kernel libc locals math math.libm math.order math.ranges
+kernel libc locals macros math math.libm math.order
-math.vectors sequences sequences.generalizations
+math.ranges math.vectors sequences sequences.generalizations
-sequences.private specialized-arrays vocabs.loader ;
+sequences.private sequences.unrolled sequences.unrolled.private
+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      ] ] }
+        { char-16-rep      [ [ 16 <direct-char-array>      ] ] }
-        { uchar-16-rep     [ [ uchar-array-cast     ] ] }
+        { uchar-16-rep     [ [ 16 <direct-uchar-array>     ] ] }
-        { short-8-rep      [ [ short-array-cast     ] ] }
+        { short-8-rep      [ [  8 <direct-short-array>     ] ] }
-        { ushort-8-rep     [ [ ushort-array-cast    ] ] }
+        { ushort-8-rep     [ [  8 <direct-ushort-array>    ] ] }
-        { int-4-rep        [ [ int-array-cast       ] ] }
+        { int-4-rep        [ [  4 <direct-int-array>       ] ] }
-        { uint-4-rep       [ [ uint-array-cast      ] ] }
+        { uint-4-rep       [ [  4 <direct-uint-array>      ] ] }
-        { longlong-2-rep   [ [ longlong-array-cast  ] ] }
+        { longlong-2-rep   [ [  2 <direct-longlong-array>  ] ] }
-        { ulonglong-2-rep  [ [ ulonglong-array-cast ] ] }
+        { ulonglong-2-rep  [ [  2 <direct-ulonglong-array> ] ] }
-        { float-4-rep      [ [ float-array-cast     ] ] }
+        { float-4-rep      [ [  4 <direct-float-array>     ] ] }
-        { double-2-rep     [ [ double-array-cast    ] ] }
+        { double-2-rep     [ [  2 <direct-double-array>    ] ] }
     } case ; foldable
 
 : [>rep-array] ( rep -- class )
@@ -96,27 +111,31 @@ IN: math.vectors.simd.intrinsics
     [<rep-array>] call( -- a' ) ; inline
 
 : components-map ( a rep quot -- c )
-    [ >rep-array ] dip map underlying>> ; inline
+    [ [ >rep-array ] [ rep-length ] bi ] dip unrolled-map-unsafe underlying>> ; inline
 : components-2map ( a b rep quot -- c )
-    [ 2>rep-array ] dip 2map underlying>> ; inline
+    [ [ 2>rep-array ] [ rep-length ] bi ] dip unrolled-2map-unsafe underlying>> ; inline
+! XXX
 : components-reduce ( a rep quot -- x )
     [ >rep-array [ ] ] dip map-reduce ; inline
 
 : bitwise-components-map ( a rep quot -- c )
-    [ >bitwise-vector-rep >rep-array ] dip map underlying>> ; inline
+    [ >bitwise-vector-rep [ >rep-array ] [ rep-length ] bi ] dip
+    unrolled-map-unsafe underlying>> ; inline
 : bitwise-components-2map ( a b rep quot -- c )
-    [ >bitwise-vector-rep 2>rep-array ] dip 2map underlying>> ; inline
+    [ >bitwise-vector-rep [ 2>rep-array ] [ rep-length ] bi ] dip
+    unrolled-2map-unsafe underlying>> ; inline
+! XXX
 : bitwise-components-reduce ( a rep quot -- x )
     [ >bitwise-vector-rep >rep-array [ ] ] dip map-reduce ; inline
 
 :: (vshuffle) ( a elts rep -- c )
     a rep >rep-array :> a'
     rep <rep-array> :> c'
-    elts [| from to |
+    elts rep rep-length [| from to |
         from rep rep-length 1 - bitand
            a' nth-unsafe
         to c' set-nth-unsafe
-    ] each-index
+    ] unrolled-each-index-unsafe
     c' underlying>> ; inline
 
 :: (vshuffle2) ( a b elts rep -- c )
@@ -124,39 +143,44 @@ IN: math.vectors.simd.intrinsics
     b rep >rep-array :> b'
     a' b' cord-append :> ab'
     rep <rep-array> :> c'
-    elts [| from to |
+    elts rep rep-length [| from to |
         from rep rep-length dup + 1 - bitand
            ab' nth-unsafe
         to c' set-nth-unsafe
-    ] each-index
+    ] unrolled-each-index-unsafe
     c' underlying>> ; inline
 
+GENERIC: native/ ( x y -- x/y )
+
+M: integer native/ /i ; inline
+M: float native/ /f ; inline
+
 PRIVATE>
 
-: (simd-v+)                ( a b rep -- c ) [ + ] components-2map ;
+SIMD-INTRINSIC: (simd-v+)                ( a b rep -- c ) [ + ] components-2map ;
-: (simd-v-)                ( a b rep -- c ) [ - ] components-2map ;
+SIMD-INTRINSIC: (simd-v-)                ( a b rep -- c ) [ - ] components-2map ;
-: (simd-vneg)              ( a   rep -- c ) [ neg ] components-map ;
+SIMD-INTRINSIC: (simd-vneg)              ( a   rep -- c ) [ neg ] components-map ;
-:: (simd-v+-)              ( a b rep -- c ) 
+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 |
+    0  rep rep-length [ 1 -  2 <range> ] [ 2 /i ] bi [| n |
         n     a' nth-unsafe n     b' nth-unsafe -
         n     c' set-nth-unsafe
 
         n 1 + a' nth-unsafe n 1 + b' nth-unsafe +
         n 1 + c' set-nth-unsafe
-    ] each
+    ] unrolled-each-unsafe
     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 ;
+    dup rep-component-type '[ + _ c: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 ;
+    dup rep-component-type '[ - _ c: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 ;
+    dup rep-component-type '[ * _ c:c-type-clamp ] components-2map ;
-: (simd-v*)                ( a b rep -- c ) [ * ] components-2map ;
+SIMD-INTRINSIC: (simd-v*)                ( a b rep -- c ) [ * ] components-2map ;
-: (simd-v*high)            ( a b rep -- c )
+SIMD-INTRINSIC: (simd-v*high)            ( a b rep -- c )
-    dup rep-component-type heap-size -8 * '[ * _ shift ] components-2map ;
+    dup rep-component-type c: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 )
@@ -164,102 +188,110 @@ PRIVATE>
     wide-rep rep-component-type :> wide-type
     a a-rep >rep-array 2 <groups> :> a'
     b b-rep >rep-array 2 <groups> :> b'
-    a' b' [
+    a' b' rep rep-length 2 /i [
         [ [ first  ] bi@ * ]
         [ [ second ] bi@ * ] 2bi +
-        wide-type c-type-clamp
+        wide-type c:c-type-clamp
-    ] wide-rep <rep-array> 2map-as underlying>> ;
+    ] wide-rep <rep-array> unrolled-2map-as-unsafe underlying>> ;
-: (simd-v/)                ( a b rep -- c ) [ / ] components-2map ;
+SIMD-INTRINSIC: (simd-v/)                ( a b rep -- c ) [ native/ ] components-2map ;
-: (simd-vavg)              ( a b rep -- c )
+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-INTRINSIC: (simd-vmin)              ( a b rep -- c ) [ min ] components-2map ;
-: (simd-vmax)              ( a b rep -- c ) [ max ] components-2map ;
+SIMD-INTRINSIC: (simd-vmax)              ( a b rep -- c ) [ max ] components-2map ;
-: (simd-v.)                ( a b rep -- n )
+! XXX
+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-INTRINSIC: (simd-vsqrt)             ( a   rep -- c ) [ fsqrt ] components-map ;
-: (simd-vsad)              ( a b rep -- c ) 2>rep-array [ - abs ] [ + ] 2map-reduce ;
+SIMD-INTRINSIC: (simd-vsad)              ( a b rep -- c ) 2>rep-array [ - abs ] [ + ] 2map-reduce ;
-: (simd-sum)               ( a   rep -- n ) [ + ] components-reduce ;
+SIMD-INTRINSIC: (simd-sum)               ( a   rep -- n ) [ + ] components-reduce ;
-: (simd-vabs)              ( a   rep -- c ) [ abs ] components-map ;
+SIMD-INTRINSIC: (simd-vabs)              ( a   rep -- c ) [ abs ] components-map ;
-: (simd-vbitand)           ( a b rep -- c ) [ bitand ] bitwise-components-2map ;
+SIMD-INTRINSIC: (simd-vbitand)           ( a b rep -- c ) [ bitand ] bitwise-components-2map ;
-: (simd-vbitandn)          ( a b rep -- c ) [ [ bitnot ] dip bitand ] bitwise-components-2map ;
+SIMD-INTRINSIC: (simd-vbitandn)          ( a b rep -- c ) [ [ bitnot ] dip bitand ] bitwise-components-2map ;
-: (simd-vbitor)            ( a b rep -- c ) [ bitor ] bitwise-components-2map ;
+SIMD-INTRINSIC: (simd-vbitor)            ( a b rep -- c ) [ bitor ] bitwise-components-2map ;
-: (simd-vbitxor)           ( a b rep -- c ) [ bitxor ] bitwise-components-2map ;
+SIMD-INTRINSIC: (simd-vbitxor)           ( a b rep -- c ) [ bitxor ] bitwise-components-2map ;
-: (simd-vbitnot)           ( a   rep -- c ) [ bitnot ] bitwise-components-map ;
+SIMD-INTRINSIC: (simd-vbitnot)           ( a   rep -- c ) [ bitnot ] bitwise-components-map ;
-: (simd-vand)              ( a b rep -- c ) [ bitand ] bitwise-components-2map ;
+SIMD-INTRINSIC: (simd-vand)              ( a b rep -- c ) [ bitand ] bitwise-components-2map ;
-: (simd-vandn)             ( a b rep -- c ) [ [ bitnot ] dip bitand ] bitwise-components-2map ;
+SIMD-INTRINSIC: (simd-vandn)             ( a b rep -- c ) [ [ bitnot ] dip bitand ] bitwise-components-2map ;
-: (simd-vor)               ( a b rep -- c ) [ bitor ] bitwise-components-2map ;
+SIMD-INTRINSIC: (simd-vor)               ( a b rep -- c ) [ bitor ] bitwise-components-2map ;
-: (simd-vxor)              ( a b rep -- c ) [ bitxor ] bitwise-components-2map ;
+SIMD-INTRINSIC: (simd-vxor)              ( a b rep -- c ) [ bitxor ] bitwise-components-2map ;
-: (simd-vnot)              ( a   rep -- c ) [ bitnot ] bitwise-components-map ;
+SIMD-INTRINSIC: (simd-vnot)              ( a   rep -- c ) [ bitnot ] bitwise-components-map ;
-: (simd-vlshift)           ( a n rep -- c ) swap '[ _ shift ] bitwise-components-map ;
+SIMD-INTRINSIC: (simd-vlshift)           ( a n rep -- c ) swap '[ _ shift ] bitwise-components-map ;
-: (simd-vrshift)           ( a n rep -- c ) swap '[ _ neg shift ] bitwise-components-map ;
+SIMD-INTRINSIC: (simd-vrshift)           ( a n rep -- c ) swap '[ _ neg shift ] bitwise-components-map ;
-: (simd-hlshift)           ( a n rep -- c )
+! XXX
+SIMD-INTRINSIC: (simd-hlshift)           ( a n rep -- c )
     drop head-slice* 16 0 pad-head ;
-: (simd-hrshift)           ( a n rep -- c )
+! XXX
+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-INTRINSIC: (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-INTRINSIC: (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-INTRINSIC: (simd-vshuffle-bytes)    ( a b rep -- c ) drop uchar-16-rep (vshuffle) ;
-:: (simd-vmerge-head)      ( a b rep -- c )
+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 |
+    rep rep-length 2 /i [| n |
         n a' nth-unsafe n 2 *     c' set-nth-unsafe
         n b' nth-unsafe n 2 * 1 + c' set-nth-unsafe
-    ] each
+    ] unrolled-each-integer
     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
-    len iota [| n |
+    len [| n |
         n len + a' nth-unsafe n 2 *     c' set-nth-unsafe
         n len + b' nth-unsafe n 2 * 1 + c' set-nth-unsafe
-    ] each
+    ] unrolled-each-integer
     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-INTRINSIC: (simd-vany?)             ( a   rep -- ? ) [ bitor  ] bitwise-components-reduce zero? not ;
-: (simd-vall?)             ( a   rep -- ? ) [ bitand ] bitwise-components-reduce zero? not ;
+SIMD-INTRINSIC: (simd-vall?)             ( a   rep -- ? ) [ bitand ] bitwise-components-reduce zero? not ;
-: (simd-vnone?)            ( a   rep -- ? ) [ bitor  ] bitwise-components-reduce zero?     ;
+SIMD-INTRINSIC: (simd-vnone?)            ( a   rep -- ? ) [ bitor  ] bitwise-components-reduce zero?     ;
-: (simd-v>float)           ( a   rep -- c )
+SIMD-INTRINSIC: (simd-v>float)           ( a   rep -- c )
-    [ >rep-array [ >float ] ] [ >float-vector-rep <rep-array> ] bi map-as underlying>> ;
+    [ [ >rep-array ] [ rep-length ] bi [ >float ] ]
-: (simd-v>integer)         ( a   rep -- c )
+    [ >float-vector-rep <rep-array> ] bi unrolled-map-as-unsafe underlying>> ;
-    [ >rep-array [ >integer ] ] [ >int-vector-rep <rep-array> ] bi map-as underlying>> ;
+SIMD-INTRINSIC: (simd-v>integer)         ( a   rep -- c )
-: (simd-vpack-signed)      ( a b rep -- c )
+    [ [ >rep-array ] [ rep-length ] bi [ >integer ] ]
-    [ 2>rep-array cord-append ]
+    [ >int-vector-rep <rep-array> ] bi unrolled-map-as-unsafe underlying>> ;
+SIMD-INTRINSIC: (simd-vpack-signed)      ( a b rep -- c )
+    [ [ 2>rep-array cord-append ] [ rep-length 2 * ] bi ]
     [ narrow-vector-rep [ <rep-array> ] [ rep-component-type ] bi ] bi
-    '[ _ c-type-clamp ] swap map-as underlying>> ;
+    '[ _ c:c-type-clamp ] swap unrolled-map-as-unsafe underlying>> ;
-: (simd-vpack-unsigned)    ( a b rep -- c )
+SIMD-INTRINSIC: (simd-vpack-unsigned)    ( a b rep -- c )
-    [ 2>rep-array cord-append ]
+    [ [ 2>rep-array cord-append ] [ rep-length 2 * ] bi ]
     [ narrow-vector-rep >uint-vector-rep [ <rep-array> ] [ rep-component-type ] bi ] bi
-    '[ _ c-type-clamp ] swap map-as underlying>> ;
+    '[ _ c:c-type-clamp ] swap unrolled-map-as-unsafe underlying>> ;
-: (simd-vunpack-head)      ( a   rep -- c ) 
+! XXX
+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 )
+! XXX
+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 )
+! XXX
+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-INTRINSIC: (simd-gather-2)          ( m n rep -- v ) <rep-array> [ 2 set-firstn-unsafe ] keep underlying>> ;
-: (simd-gather-4)          ( m n o p rep -- v ) <rep-array> [ 4 set-firstn ] keep underlying>> ;
+SIMD-INTRINSIC: (simd-gather-4)          ( m n o p rep -- v ) <rep-array> [ 4 set-firstn-unsafe ] keep underlying>> ;
-: (simd-select)            ( a n rep -- x ) [ swap ] dip >rep-array nth-unsafe ;
+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

basis/nibble-arrays/nibble-arrays.factor

@@ -1,7 +1,7 @@
-! Copyright (C) 2008 Slava Pestov.
+! Copyright (C) 2008, 2010 Slava Pestov.
 ! See http://factorcode.org/license.txt for BSD license.
 USING: math kernel sequences sequences.private byte-arrays
-alien prettyprint.custom parser accessors ;
+alien prettyprint.custom parser accessors locals ;
 IN: nibble-arrays
 
 TUPLE: nibble-array
@@ -20,8 +20,10 @@ CONSTANT: nibble BIN: 1111
 : get-nibble ( n byte -- nibble )
     swap neg shift nibble bitand ; inline
 
-: set-nibble ( value n byte -- byte' )
+:: set-nibble ( value n byte -- byte' )
-    nibble pick shift bitnot bitand -rot shift bitor ; inline
+    byte nibble n shift bitnot bitand
+    value n shift
+    bitor ; inline
 
 : nibble@ ( n nibble-array -- shift n' byte-array )
     [ >fixnum byte/nibble ] [ underlying>> ] bi* ; inline

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." } ;
 

basis/sequences/unrolled/unrolled-tests.factor

@@ -1,5 +1,5 @@
 ! (c)2010 Joe Groff bsd license
-USING: compiler.test make math.parser sequences
+USING: compiler.test compiler.tree.debugger kernel make math.parser sequences
 sequences.unrolled tools.test ;
 IN: sequences.unrolled.tests
 
@@ -7,18 +7,46 @@ 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
+
+[ t ]
+[ [ 3 [ number>string ] unrolled-map ] { call } inlined? ] unit-test
+
+[ t ]
+[ [ 3 [ number>string , ] unrolled-each ] { call } inlined? ] unit-test
+
+[ t ]
+[ [ 3 [ number>string append , ] unrolled-each-index ] { call } inlined? ] unit-test
+
+[ t ]
+[ [ 3 [ append , ] unrolled-2each ] { call } inlined? ] unit-test
+
+[ t ]
+[ [ 3 [ append ] unrolled-2map ] { call } inlined? ] unit-test
+
+[ t ]
+[ [ 3 [ number>string append ] unrolled-map-index ] { call } inlined? ] unit-test

basis/sequences/unrolled/unrolled.factor

@@ -1,21 +1,29 @@
 ! (c)2010 Joe Groff bsd license
-USING: combinators.short-circuit fry generalizations kernel
+USING: combinators combinators.short-circuit fry generalizations kernel
-locals macros math quotations sequences ;
+locals macros math quotations sequences compiler.tree.propagation.transforms ;
-FROM: sequences.private => (each) (each-index) (collect) (2each) ;
+FROM: sequences.private => (each) (each-index) (2each) nth-unsafe set-nth-unsafe ;
 IN: sequences.unrolled
 
 <PRIVATE
-MACRO: (unrolled-each-integer) ( n -- )
+: (unrolled-each-integer) ( quot n -- )
-    [ iota >quotation ] keep '[ _ dip _ napply ] ;
+    swap '[ _ call( i -- ) ] each-integer ;
+
+<< \ (unrolled-each-integer) [
+    iota [ '[ _ swap call( i -- ) ] ] [ ] map-as '[ _ cleave ]
+] 1 define-partial-eval >>
+
+: (unrolled-collect) ( quot into -- quot' )
+    '[ dup @ swap _ set-nth-unsafe ] ; inline
+
 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-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
@@ -34,52 +42,58 @@ ERROR: unrolled-2bounds-error
     [ xseq yseq len quot ] if ; inline
 
 : (unrolled-each) ( seq len quot -- len quot )
-    swapd (each) nip ; inline
+    swapd '[ _ nth-unsafe @ ] ; inline
 
 : (unrolled-each-index) ( seq len quot -- len quot )
-    swapd (each-index) nip ; inline
+    swapd '[ dup _ nth-unsafe swap @ ] ; inline
 
 : (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
 
+: unrolled-map-unsafe ( seq len quot: ( x -- newx ) -- newseq )
+    pick unrolled-map-as-unsafe ; inline
+
+: unrolled-2map-unsafe ( xseq yseq len quot: ( x y -- newx ) -- newseq )
+    4 npick unrolled-2map-as-unsafe ; 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
 

basis/tools/deploy/macosx/macosx.factor

@@ -1,4 +1,4 @@
-! Copyright (C) 2007, 2009 Slava Pestov.
+! Copyright (C) 2007, 2010 Slava Pestov.
 ! See http://factorcode.org/license.txt for BSD license.
 USING: io io.files io.files.info.unix io.pathnames
 io.directories io.directories.hierarchy kernel namespaces make
@@ -10,7 +10,10 @@ combinators vocabs.metadata vocabs.loader ;
 IN: tools.deploy.macosx
 
 : bundle-dir ( -- dir )
-    vm parent-directory parent-directory ;
+    running.app?
+    [ vm parent-directory parent-directory ]
+    [ "resource:Factor.app" ]
+    if ;
 
 : copy-bundle-dir ( bundle-name dir -- )
     [ bundle-dir prepend-path swap ] keep
@@ -70,7 +73,6 @@ IN: tools.deploy.macosx
     -> selectFile:inFileViewerRootedAtPath: drop ;
 
 M: macosx deploy* ( vocab -- )
-    ".app deploy tool" assert.app
     "resource:" [
         dup deploy-config [
             bundle-name dup exists? [ delete-tree ] [ drop ] if

basis/tools/errors/model/model.factor

@@ -1,4 +1,4 @@
-! Copyright (C) 2009 Slava Pestov.
+! Copyright (C) 2009, 2010 Slava Pestov.
 ! See http://factorcode.org/license.txt for BSD license.
 USING: models source-files.errors namespaces models.delay init
 kernel calendar ;
@@ -6,13 +6,14 @@ IN: tools.errors.model
 
 SYMBOLS: (error-list-model) error-list-model ;
 
-(error-list-model) [ f <model> ] initialize
-
-error-list-model [ (error-list-model) get-global 100 milliseconds <delay> ] initialize
-
 SINGLETON: updater
 
-M: updater errors-changed drop f (error-list-model) get-global set-model ;
+M: updater errors-changed
+    drop f (error-list-model) get-global set-model ;
 
-[ updater add-error-observer ] "ui.tools.error-list" add-startup-hook
+[
+    f <model> (error-list-model) set-global
+    (error-list-model) get-global 100 milliseconds <delay> error-list-model set-global
+    updater add-error-observer
+] "ui.tools.error-list" add-startup-hook
 

basis/ui/backend/cocoa/cocoa.factor

@@ -252,7 +252,7 @@ M: cocoa-ui-backend (with-ui)
             init-clipboard
             cocoa-startup-hook get call( -- )
             start-ui
-            f io-thread-running? set-global
+            stop-io-thread
             init-thread-timer
             reset-run-loop
             NSApp -> run

basis/ui/backend/windows/windows.factor

@@ -248,7 +248,7 @@ CONSTANT: window-control>ex-style
         { minimize-button 0 }
         { maximize-button 0 }
         { resize-handles $ WS_EX_WINDOWEDGE }
-        { small-title-bar $ WS_EX_TOOLWINDOW }
+        { small-title-bar $[ WS_EX_TOOLWINDOW WS_EX_TOPMOST bitor ] }
         { normal-title-bar $ WS_EX_APPWINDOW }
     }
 
@@ -832,24 +832,25 @@ CONSTANT: fullscreen-flags flags{ WS_CAPTION WS_BORDER WS_THICKFRAME }
     } cleave ;
 
 : exit-fullscreen ( world -- )
-    dup handle>> hWnd>>
+    [ handle>> hWnd>> ] [ world>style ] bi
     {
-        [ GWL_STYLE rot world>style SetWindowLong win32-error=0/f ]
+        [ [ GWL_STYLE ] dip SetWindowLong win32-error=0/f ]
         [
+            drop
             f
             over hwnd>RECT get-RECT-dimensions
             flags{ SWP_NOMOVE SWP_NOSIZE SWP_NOZORDER SWP_FRAMECHANGED }
             SetWindowPos win32-error=0/f
         ]
-        [ SW_RESTORE ShowWindow win32-error=0/f ]
+        [ drop SW_RESTORE ShowWindow win32-error=0/f ]
-    } cleave ;
+    } 2cleave ;
 
 M: windows-ui-backend (set-fullscreen) ( ? world -- )
     [ enter-fullscreen ] [ exit-fullscreen ] if ;
 
 M: windows-ui-backend (fullscreen?) ( world -- ? )
-    [ handle>> hWnd>> hwnd>RECT ]
+    handle>> hWnd>>
-    [ handle>> hWnd>> fullscreen-RECT ] bi
+    [ hwnd>RECT ] [ fullscreen-RECT ] bi
     [ get-RECT-dimensions 2array 2nip ] bi@ = ;
 
 windows-ui-backend ui-backend set-global

basis/ui/backend/x11/x11.factor

@@ -1,20 +1,52 @@
-! Copyright (C) 2005, 2010 Eduardo Cavazos and Slava Pestov
+! Copyright (C) 2005, 2010 Eduardo Cavazos, Slava Pestov.
 ! See http://factorcode.org/license.txt for BSD license.
-USING: accessors alien.c-types alien.data ascii assocs classes.struct
+USING: accessors arrays alien.c-types alien.data alien.syntax ascii
-combinators combinators.short-circuit command-line environment
+assocs classes.struct combinators combinators.short-circuit
-io.encodings.ascii io.encodings.string io.encodings.utf8 kernel
+command-line environment io.encodings.ascii io.encodings.string
-literals locals math namespaces sequences specialized-arrays
+io.encodings.utf8 kernel literals locals math namespaces
-strings ui ui.backend ui.clipboards ui.event-loop ui.gadgets
+sequences specialized-arrays strings ui ui.backend ui.clipboards
-ui.gadgets.private ui.gadgets.worlds ui.gestures ui.pixel-formats
+ui.event-loop ui.gadgets ui.gadgets.private ui.gadgets.worlds
-ui.pixel-formats.private ui.private x11 x11.clipboard x11.constants
+ui.gestures ui.pixel-formats ui.pixel-formats.private ui.private
-x11.events x11.glx x11.io x11.windows x11.xim x11.xlib ;
+x11 x11.clipboard x11.constants x11.events x11.glx x11.io
-FROM: unix.ffi => system ;
+x11.windows x11.xim x11.xlib ;
-SPECIALIZED-ARRAY: uchar
+FROM: libc => system ;
+SPECIALIZED-ARRAYS: uchar ulong ;
 IN: ui.backend.x11
 
 SINGLETON: x11-ui-backend
 
+: XA_NET_SUPPORTED ( -- atom ) "_NET_SUPPORTED" x-atom ;
 : XA_NET_WM_NAME ( -- atom ) "_NET_WM_NAME" x-atom ;
+: XA_NET_WM_STATE ( -- atom ) "_NET_WM_STATE" x-atom ;
+: XA_NET_WM_STATE_FULLSCREEN ( -- atom ) "_NET_WM_STATE_FULLSCREEN" x-atom ;
+: XA_NET_ACTIVE_WINDOW ( -- atom ) "_NET_ACTIVE_WINDOW" x-atom ;
+
+: supported-net-wm-hints ( -- seq )
+    { Atom int ulong ulong pointer: Atom }
+    [| type format n-atoms bytes-after atoms |
+        dpy get
+        root get
+        XA_NET_SUPPORTED
+        0
+        ulong c-type-interval nip
+        0
+        XA_ATOM
+        type
+        format
+        n-atoms
+        bytes-after
+        atoms
+        XGetWindowProperty
+        Success assert=
+    ]
+    [| type format n-atoms bytes-after atoms |
+        atoms n-atoms <direct-ulong-array> >array
+        atoms XFree
+    ]
+    with-out-parameters ;
+
+: net-wm-hint-supported? ( atom -- ? )
+    supported-net-wm-hints member? ;
 
 TUPLE: x11-handle-base glx ;
 TUPLE: x11-handle < x11-handle-base window xic ;
@@ -30,7 +62,7 @@ M: world configure-event
     ! In case dimensions didn't change
     relayout-1 ;
 
-PIXEL-FORMAT-ATTRIBUTE-TABLE: glx-visual { $ GLX_USE_GL $ GLX_RGBA } H{
+PIXEL-FORMAT-ATTRIBUTE-TABLE: glx-visual { $ GLX_RGBA } H{
     { double-buffered { $ GLX_DOUBLEBUFFER } }
     { stereo { $ GLX_STEREO } }
     { color-bits { $ GLX_BUFFER_SIZE } }
@@ -172,8 +204,7 @@ M: world selection-notify-event
     user-input ;
 
 : supported-type? ( atom -- ? )
-    { "UTF8_STRING" "STRING" "TEXT" }
+    XA_UTF8_STRING XA_STRING XA_TEXT 3array member? ;
-    [ x-atom = ] with any? ;
 
 : clipboard-for-atom ( atom -- clipboard )
     {
@@ -196,8 +227,8 @@ M: world selection-notify-event
 M: world selection-request-event
     drop dup target>> {
         { [ dup supported-type? ] [ drop dup set-selection-prop send-notify-success ] }
-        { [ dup "TARGETS" x-atom = ] [ drop dup set-targets-prop send-notify-success ] }
+        { [ dup XA_TARGETS = ] [ drop dup set-targets-prop send-notify-success ] }
-        { [ dup "TIMESTAMP" x-atom = ] [ drop dup set-timestamp-prop send-notify-success ] }
+        { [ dup XA_TIMESTAMP = ] [ drop dup set-timestamp-prop send-notify-success ] }
         [ drop send-notify-failure ]
     } cond ;
 
@@ -258,31 +289,57 @@ M: x11-ui-backend set-title ( string world -- )
     handle>> window>> swap
     [ dpy get ] 2dip [ set-title-old ] [ set-title-new ] 3bi ;
 
-: make-fullscreen-msg ( world ? -- msg )
+: make-fullscreen-msg ( window ? -- msg )
     XClientMessageEvent <struct>
         ClientMessage >>type
         dpy get >>display
-    "_NET_WM_STATE" x-atom >>message_type
+        XA_NET_WM_STATE >>message_type
         swap _NET_WM_STATE_ADD _NET_WM_STATE_REMOVE ? >>data0
-    swap handle>> window>> >>window
+        swap >>window
         32 >>format
-    "_NET_WM_STATE_FULLSCREEN" x-atom >>data1 ;
+        XA_NET_WM_STATE_FULLSCREEN >>data1 ;
+
+: send-event ( event -- )
+    [
+        dpy get
+        root get
+        0
+        SubstructureNotifyMask SubstructureRedirectMask bitor
+    ] dip XSendEvent drop ;
 
 M: x11-ui-backend (set-fullscreen) ( world ? -- )
-    [ dpy get root get 0 SubstructureNotifyMask ] 2dip
+    [ handle>> window>> ] dip make-fullscreen-msg send-event ;
-    make-fullscreen-msg XSendEvent drop ;
 
 M: x11-ui-backend (open-window) ( world -- )
-    dup gadget-window
+    dup gadget-window handle>> window>>
-    handle>> window>>
+    [ set-closable ]
-    [ set-closable ] [ dpy get swap set-class ] [ map-window ] tri ;
+    [ [ dpy get ] dip set-class ]
+    [ map-window ]
+    tri ;
+
+: make-raise-window-msg ( window -- msg )
+    XClientMessageEvent <struct>
+        ClientMessage >>type
+        1 >>send_event
+        dpy get >>display
+        swap >>window
+        XA_NET_ACTIVE_WINDOW >>message_type
+        32 >>format ;
+
+: raise-window-new ( window -- )
+    make-raise-window-msg send-event ;
+
+: raise-window-old ( window -- )
+    [ dpy get ] dip
+    [ RevertToPointerRoot CurrentTime XSetInputFocus drop ]
+    [ XRaiseWindow drop ]
+    2bi ;
 
 M: x11-ui-backend raise-window* ( world -- )
     handle>> [
-        dpy get swap window>>
+        window>>
-        [ RevertToPointerRoot CurrentTime XSetInputFocus drop ]
+        XA_NET_ACTIVE_WINDOW net-wm-hint-supported?
-        [ XRaiseWindow drop ]
+        [ raise-window-new ] [ raise-window-old ] if
-        2bi
     ] when* ;
 
 M: x11-handle select-gl-context ( handle -- )

basis/ui/gadgets/editors/editors.factor

@@ -60,14 +60,11 @@ SYMBOL: blink-interval
 750 milliseconds blink-interval set-global
 
 : stop-blinking ( editor -- )
-    [ [ stop-alarm ] when* f ] change-blink-alarm drop ;
+    blink-alarm>> [ stop-alarm ] when* ;
 
 : start-blinking ( editor -- )
-    [ stop-blinking ] [
     t >>blink
-        dup '[ _ blink-caret ] blink-interval get delayed-every
+    blink-alarm>> [ restart-alarm ] when* ;
-        >>blink-alarm drop
-    ] bi ;
 
 : restart-blinking ( editor -- )
     dup focused?>> [
@@ -80,10 +77,15 @@ PRIVATE>
 
 M: editor graft*
     [ dup caret>> activate-editor-model ]
-    [ dup mark>> activate-editor-model ] bi ;
+    [ dup mark>> activate-editor-model ]
+    [
+        [
+            '[ _ blink-caret ] blink-interval get dup <alarm>
+        ] keep blink-alarm<<
+    ] tri ;
 
 M: editor ungraft*
-    [ stop-blinking ]
+    [ [ stop-blinking ] [ f >>blink-alarm drop ] bi ]
     [ dup caret>> deactivate-editor-model ]
     [ dup mark>> deactivate-editor-model ] tri ;
 

basis/ui/gadgets/worlds/worlds.factor

@@ -20,7 +20,6 @@ CONSTANT: default-world-pixel-format-attributes
     {
         windowed
         double-buffered
-        T{ depth-bits { value 16 } }
     }
 
 CONSTANT: default-world-window-controls

basis/ui/render/render.factor

@@ -35,6 +35,8 @@ SLOT: background-color
     GL_BLEND glEnable
     GL_SRC_ALPHA GL_ONE_MINUS_SRC_ALPHA glBlendFunc
     GL_VERTEX_ARRAY glEnableClientState
+    GL_PACK_ALIGNMENT 1 glPixelStorei
+    GL_UNPACK_ALIGNMENT 1 glPixelStorei
     init-matrices
     [ init-clip ]
     [

basis/ui/tools/listener/listener.factor

@@ -195,6 +195,7 @@ TUPLE: listener-gadget < tool error-summary output scroller input ;
         H{ { table-gap { 3 3 } } } [
             [ [ [ icon>> write-image ] with-cell ] each ] with-row
         ] tabular-output
+        last-element off
         { "Press " { $command tool "common" show-error-list } " to view errors." }
         print-element
     ] unless-empty ;

basis/ui/tools/tools.factor

@@ -5,10 +5,7 @@ ui.tools.listener ui.tools.browser ui.tools.common ui.tools.error-list
 ui.tools.walker ui.commands ui.gestures ui ui.private ;
 IN: ui.tools
 
-: main ( -- )
+MAIN: listener-window
-    restore-windows? [ restore-windows ] [ listener-window ] if ;
-
-MAIN: main
 
 \ refresh-all H{ { +nullary+ t } { +listener+ t } } define-command
 

basis/ui/ui.factor

@@ -1,11 +1,12 @@
-! Copyright (C) 2006, 2009 Slava Pestov.
+! Copyright (C) 2006, 2010 Slava Pestov.
 ! See http://factorcode.org/license.txt for BSD license.
-USING: arrays assocs io kernel math models namespaces make dlists
+USING: arrays assocs boxes io kernel math models namespaces make
-deques sequences threads words continuations init
+dlists deques sequences threads words continuations init
-combinators combinators.short-circuit hashtables concurrency.flags
+combinators combinators.short-circuit hashtables
-sets accessors calendar fry destructors ui.gadgets ui.gadgets.private
+concurrency.flags sets accessors calendar fry destructors
-ui.gadgets.worlds ui.gadgets.tracks ui.gestures ui.backend ui.render
+ui.gadgets ui.gadgets.private ui.gadgets.worlds
-strings classes.tuple classes.tuple.parser lexer vocabs.parser parser ;
+ui.gadgets.tracks ui.gestures ui.backend ui.render strings
+classes.tuple classes.tuple.parser lexer vocabs.parser parser ;
 IN: ui
 
 <PRIVATE
@@ -82,12 +83,7 @@ M: world graft*
         [ [ clean-up-broken-window ] [ ui-error ] bi* ] recover
     ] bi ;
 
-: reset-world ( world -- )
+M: world ungraft*
-    #! This is used when a window is being closed, but also
-    #! when restoring saved worlds on image startup.
-    f >>handle unfocus-world ;
-
-: (ungraft-world) ( world -- )
     {
         [ set-gl-context ]
         [ text-handle>> [ dispose ] when* ]
@@ -96,38 +92,21 @@ M: world graft*
         [ hand-gadget close-global ]
         [ end-world ]
         [ [ <reversed> [ [ dispose ] when* ] each V{ } clone ] change-window-resources drop ]
+        [ [ (close-window) f ] change-handle drop ]
+        [ unfocus-world ]
     } cleave ;
 
-M: world ungraft*
-    [ (ungraft-world) ]
-    [ handle>> (close-window) ]
-    [ reset-world ] tri ;
-
 : init-ui ( -- )
+    <box> drag-timer set-global
+    f hand-gadget set-global
+    f hand-clicked set-global
+    f hand-world set-global
+    f world set-global
     <dlist> \ graft-queue set-global
     <dlist> \ layout-queue set-global
     <dlist> \ gesture-queue set-global
     V{ } clone windows set-global ;
 
-: restore-gadget-later ( gadget -- )
-    dup graft-state>> {
-        { { f f } [ ] }
-        { { f t } [ ] }
-        { { t t } [ { f f } >>graft-state ] }
-        { { t f } [ dup unqueue-graft { f f } >>graft-state ] }
-    } case graft-later ;
-
-: restore-gadget ( gadget -- )
-    dup restore-gadget-later
-    children>> [ restore-gadget ] each ;
-
-: restore-world ( world -- )
-    {
-        [ reset-world ]
-        [ f >>text-handle f >>images drop ]
-        [ restore-gadget ]
-    } cleave ;
-
 : update-hand ( world -- )
     dup hand-world get-global eq?
     [ hand-loc get-global swap move-hand ] [ drop ] if ;
@@ -188,16 +167,6 @@ PRIVATE>
 : start-ui ( quot -- )
     call( -- ) notify-ui-thread start-ui-thread ;
 
-: restore-windows ( -- )
-    [
-        windows get [ values ] [ delete-all ] bi
-        [ restore-world ] each
-        forget-rollover
-    ] (with-ui) ;
-
-: restore-windows? ( -- ? )
-    windows get empty? not ;
-
 : ?attributes ( gadget title/attributes -- attributes )
     dup string? [ world-attributes new swap >>title ] [ clone ] if
     swap [ [ [ 1array ] [ f ] if* ] curry unless* ] curry change-gadgets ;

basis/unix/ffi/ffi.factor

@@ -151,7 +151,6 @@ FUNCTION: int setuid ( uid_t uid ) ;
 FUNCTION: int socket ( int domain, int type, int protocol ) ;
 FUNCTION: int symlink ( c-string path1, c-string path2 ) ;
 FUNCTION: int link ( c-string path1, c-string path2 ) ;
-FUNCTION: int system ( c-string command ) ;
 FUNCTION: int unlink ( c-string path ) ;
 FUNCTION: int utimes ( c-string path, timeval[2] times ) ;
 FUNCTION: ssize_t write ( int fd, void* buf, size_t nbytes ) ;

basis/vocabs/refresh/monitor/monitor.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: accessors assocs command-line concurrency.messaging
 continuations init io.backend io.files io.monitors io.pathnames
-kernel namespaces sequences sets splitting threads
+kernel namespaces sequences sets splitting threads fry
 tr vocabs vocabs.loader vocabs.refresh vocabs.cache ;
 IN: vocabs.refresh.monitor
 
@@ -26,34 +26,33 @@ TR: convert-separators "/\\" ".." ;
 : path>vocab ( path -- vocab )
     chop-vocab-root path>vocab-name vocab-dir>vocab-name ;
 
-: monitor-loop ( -- )
+: monitor-loop ( monitor -- )
     #! On OS X, monitors give us the full path, so we chop it
     #! off if its there.
-    receive path>> path>vocab changed-vocab
+    [ next-change path>> path>vocab changed-vocab reset-cache ]
-    reset-cache
+    [ monitor-loop ]
-    monitor-loop ;
+    bi ;
 
-: add-monitor-for-path ( path -- )
+: (start-vocab-monitor) ( vocab-root -- )
-    dup exists? [ t my-mailbox (monitor) ] when drop ;
+    dup exists?
+    [ [ t <monitor> monitor-loop ] with-monitors ] [ drop ] if ;
 
-: monitor-thread ( -- )
+: start-vocab-monitor ( vocab-root -- )
-    [
+    [ '[ [ _ (start-vocab-monitor) ] ignore-errors ] ]
-        [
+    [ "Root monitor: " prepend ]
-            vocab-roots get [ add-monitor-for-path ] each
+    bi spawn drop ;
 
+: init-vocab-monitor ( -- )
     H{ } clone changed-vocabs set-global
-            vocabs [ changed-vocab ] each
+    vocabs [ changed-vocab ] each ;
-
-            monitor-loop
-        ] with-monitors
-    ] ignore-errors ;
-
-: start-monitor-thread ( -- )
-    #! Silently ignore errors during monitor creation since
-    #! monitors are not supported on all platforms.
-    [ monitor-thread ] "Vocabulary monitor" spawn drop ;
 
 [
-    "-no-monitors" (command-line) member?
+    "-no-monitors" (command-line) member? [
-    [ start-monitor-thread ] unless
+        [ drop ] add-vocab-root-hook set-global
+        f changed-vocabs set-global
+    ] [
+        init-vocab-monitor
+        vocab-roots get [ start-vocab-monitor ] each
+        [ start-vocab-monitor ] add-vocab-root-hook set-global
+    ] if
 ] "vocabs.refresh.monitor" add-startup-hook

basis/x11/clipboard/clipboard.factor

@@ -1,4 +1,4 @@
-! Copyright (C) 2006, 2007 Slava Pestov
+! Copyright (C) 2006, 2010 Slava Pestov
 ! See http://factorcode.org/license.txt for BSD license.
 USING: accessors alien.c-types alien.strings classes.struct
 io.encodings.utf8 kernel namespaces sequences
@@ -10,8 +10,10 @@ IN: x11.clipboard
 ! and http://common-lisp.net/~crhodes/clx/demo/clipboard.lisp.
 
 : XA_CLIPBOARD ( -- atom ) "CLIPBOARD" x-atom ;
-
 : XA_UTF8_STRING ( -- atom ) "UTF8_STRING" x-atom ;
+: XA_TARGETS ( -- atom ) "TARGETS" x-atom ;
+: XA_TIMESTAMP ( -- atom ) "TIMESTAMP" x-atom ;
+: XA_TEXT ( -- atom ) "TEXT" x-atom ;
 
 TUPLE: x-clipboard atom contents ;
 
@@ -43,16 +45,14 @@ TUPLE: x-clipboard atom contents ;
 
 : set-targets-prop ( evt -- )
     [ dpy get ] dip [ requestor>> ] [ property>> ] bi
-    "TARGETS" x-atom 32 PropModeReplace
+    XA_TARGETS 32 PropModeReplace
-    {
+    XA_UTF8_STRING XA_STRING XA_TARGETS XA_TIMESTAMP int-array{ } 4sequence
-        "UTF8_STRING" "STRING" "TARGETS" "TIMESTAMP"
-    } [ x-atom ] int-array{ } map-as
     4 XChangeProperty drop ;
 
 : set-timestamp-prop ( evt -- )
     [ dpy get ] dip
     [ requestor>> ]
-    [ property>> "TIMESTAMP" x-atom 32 PropModeReplace ]
+    [ property>> XA_TIMESTAMP 32 PropModeReplace ]
     [ time>> <int> ] tri
     1 XChangeProperty drop ;
 

basis/x11/events/events.factor

@@ -1,7 +1,8 @@
-! Copyright (C) 2005, 2006 Eduardo Cavazos and Slava Pestov
+! Copyright (C) 2005, 2010 Eduardo Cavazos, Slava Pestov.
 ! See http://factorcode.org/license.txt for BSD license.
-USING: accessors arrays classes.struct combinators kernel
+USING: accessors arrays classes.struct combinators
-math.order namespaces x11 x11.xlib ;
+combinators.short-circuit kernel math.order namespaces
+x11 x11.xlib ;
 IN: x11.events
 
 GENERIC: expose-event ( event window -- )
@@ -75,7 +76,11 @@ GENERIC: client-event ( event window -- )
 : event-dim ( event -- dim )
     [ width>> ] [ height>> ] bi 2array ;
 
+: XA_WM_PROTOCOLS ( -- atom ) "WM_PROTOCOLS" x-atom ;
+: XA_WM_DELETE_WINDOW ( -- atom ) "WM_DELETE_WINDOW" x-atom ;
+
 : close-box? ( event -- ? )
-    [ message_type>> "WM_PROTOCOLS" x-atom = ]
+    {
-    [ data0>> "WM_DELETE_WINDOW" x-atom = ]
+        [ message_type>> XA_WM_PROTOCOLS = ]
-    bi and ;
+        [ data0>> XA_WM_DELETE_WINDOW = ]
+    } 1&& ;

basis/x11/windows/platforms.txt

@@ -1 +0,0 @@
-unix

basis/x11/windows/windows.factor

@@ -1,8 +1,9 @@
-! Copyright (C) 2005, 2006 Eduardo Cavazos and Slava Pestov
+! Copyright (C) 2005, 2010 Eduardo Cavazos, Slava Pestov.
 ! See http://factorcode.org/license.txt for BSD license.
 USING: accessors kernel math math.bitwise math.vectors
-namespaces sequences x11 x11.xlib x11.constants x11.glx arrays
+namespaces sequences arrays fry classes.struct literals
-fry classes.struct literals ;
+x11 x11.xlib x11.constants x11.events
+x11.glx ;
 IN: x11.windows
 
 CONSTANT: create-window-mask
@@ -78,7 +79,7 @@ CONSTANT: event-mask
     dpy get swap XDestroyWindow drop ;
 
 : set-closable ( win -- )
-    dpy get swap "WM_DELETE_WINDOW" x-atom <Atom> 1
+    dpy get swap XA_WM_DELETE_WINDOW <Atom> 1
     XSetWMProtocols drop ;
 
 : map-window ( win -- ) dpy get swap XMapWindow drop ;

basis/xmode/catalog/catalog.factor

@@ -1,7 +1,8 @@
 USING: xmode.loader xmode.utilities xmode.rules namespaces
 strings splitting assocs sequences kernel io.files xml memoize
-words globs combinators io.encodings.utf8 sorting accessors xml.data
+words globs combinators io.encodings.utf8 io.pathnames sorting
-xml.traversal xml.syntax ;
+accessors regexp unicode.case xml.data xml.traversal
+xml.syntax ;
 IN: xmode.catalog
 
 TUPLE: mode file file-name-glob first-line-glob ;
@@ -15,6 +16,8 @@ TAG: MODE parse-mode-tag
             { "FILE_NAME_GLOB" f file-name-glob<< }
             { "FIRST_LINE_GLOB" f first-line-glob<< }
         } init-from-tag
+        [ [ >case-fold <glob> ] [ f ] if* ] change-file-name-glob
+        [ [ >case-fold <glob> ] [ f ] if* ] change-first-line-glob
     ] dip
     rot set-at ;
 
@@ -106,14 +109,18 @@ ERROR: mutually-recursive-rulesets ruleset ;
 : reset-modes ( -- )
     \ (load-mode) reset-memoized ;
 
-: ?glob-matches ( string glob/f -- ? )
+: ?matches ( string glob/f -- ? )
-    dup [ glob-matches? ] [ 2drop f ] if ;
+    [ >case-fold ] dip dup [ matches? ] [ 2drop f ] if ;
 
 : suitable-mode? ( file-name first-line mode -- ? )
-    [ nip ] 2keep first-line-glob>> ?glob-matches
+    [ nip ] 2keep first-line-glob>> ?matches
-    [ 2drop t ] [ file-name-glob>> ?glob-matches ] if ;
+    [ 2drop t ] [ file-name-glob>> ?matches ] if ;
 
-: find-mode ( file-name first-line -- mode )
+: ?find-mode ( file-name first-line -- mode/f )
+    [ file-name ] dip
     modes
     [ nip [ 2dup ] dip suitable-mode? ] assoc-find
-    2drop [ 2drop ] dip [ "text" ] unless* ;
+    2drop [ 2drop ] dip ;
+
+: find-mode ( file-name first-line -- mode )
+    ?find-mode "text" or ; inline

build-support/factor.cmd

@@ -0,0 +1,87 @@
+@echo off
+setlocal
+
+if "%1"=="/?" (
+    goto usage
+) else if "%1"=="" (
+    set _bootimage_version=latest
+) else if "%1"=="latest" (
+    set _bootimage_version=latest
+) else if "%1"=="clean" (
+    set _bootimage_version=clean
+) else goto usage
+
+if not exist Nmakefile goto wrongdir
+
+call cl 2>&1 | find "x86" >nul
+if not errorlevel 1 (
+    echo x86-32 cl.exe detected.
+    set _target=x86-32
+    set _bootimage=boot.winnt-x86.32.image
+) else (
+    call cl 2>&1 | find "x64" >nul
+    if not errorlevel 1 (
+        echo x86-64 cl.exe detected.
+        set _target=x86-64
+        set _bootimage=boot.winnt-x86.64.image
+    ) else goto nocl
+)
+
+if %_bootimage_version%==clean (
+    set _git_branch=clean-winnt-%_target%
+    set _bootimage_path=clean/winnt-%_target%
+) else (
+    set _git_branch=master
+    set _bootimage_path=latest
+)
+
+echo Updating working copy from %_git_branch%...
+call git pull http://factorcode.org/git/factor.git %_git_branch%
+if errorlevel 1 goto fail
+
+echo Building vm...
+nmake /nologo /f Nmakefile clean
+if errorlevel 1 goto fail
+nmake /nologo /f Nmakefile %_target%
+if errorlevel 1 goto fail
+
+echo Fetching %_bootimage_version% boot image...
+cscript /nologo build-support\http-get.vbs http://factorcode.org/images/%_bootimage_path%/%_bootimage% %_bootimage%
+if errorlevel 1 goto fail
+
+echo Bootstrapping...
+.\factor.com -i=%_bootimage%
+if errorlevel 1 goto fail
+
+echo Copying fresh factor.image to factor.image.fresh.
+copy factor.image factor.image.fresh
+if errorlevel 1 goto fail
+
+echo Build complete.
+goto :EOF
+
+:fail
+echo Build failed.
+goto :EOF
+
+:wrongdir
+echo build-support\factor.cmd must be run from the root of the Factor source tree.
+goto :EOF
+
+:nocl
+echo Unable to detect cl.exe target platform.
+echo Make sure you're running within the Visual Studio or Windows SDK environment.
+goto :EOF
+
+:usage
+echo Usage: build-support\factor.cmd [latest/clean]
+echo     Updates the working copy, cleans and builds the vm using nmake,
+echo     fetches a boot image, and bootstraps factor.
+echo     If latest is specified, then the working copy is updated to the
+echo     upstream "master" branch and the boot image corresponding to the
+echo     most recent factor build is downloaded. This is the default.
+echo     If clean is specified, then the working copy is updated to the
+echo     upstream "clean-winnt-*" branch corresponding to the current
+echo     platform and the corresponding boot image is downloaded.
+goto :EOF
+

build-support/http-get.vbs

@@ -0,0 +1,41 @@
+on error resume next
+
+if WScript.Arguments.Count < 2 then
+    WScript.Echo "usage: http-get.vbs source-url dest-file"
+    WScript.Quit 1
+else
+    source_url = WScript.Arguments.Item(0)
+    dest_filename = WScript.Arguments.Item(1)
+
+    dim http, source_data
+    set http = CreateObject("WinHttp.WinHttpRequest.5.1")
+
+    Err.Clear
+    http.Open "GET", source_url, false
+    http.Send
+
+    if Err.Number = 0 then
+        if http.Status = 200 then
+            dim dest_stream
+            set dest_stream = CreateObject("ADODB.Stream")
+
+            Err.Clear
+            dest_stream.Type = 1 ' adTypeBinary
+            dest_stream.Open
+            dest_stream.Write http.ResponseBody
+            dest_stream.SaveToFile dest_filename, 2 ' adSaveCreateOverWrite
+            if Err.Number <> 0 then
+                WScript.Echo "Error " + CStr(Err.Number) + " when writing " + dest_filename + ":"
+                WScript.Echo Err.Description
+                WScript.Quit 1
+            end if
+        else
+            WScript.Echo CStr(http.Status) + " " + http.StatusText + " when fetching " + source_url
+            WScript.Quit 1
+        end if
+    else
+        WScript.Echo "Error " + CStr(Err.Number) + " when fetching " + source_url + ":"
+        WScript.Echo Err.Description
+        WScript.Quit 1
+    end if
+end if

core/combinators/combinators-docs.factor

@@ -65,9 +65,9 @@ ARTICLE: "apply-combinators" "Apply combinators"
 "All of the apply combinators are equivalent to using the corresponding " { $link "spread-combinators" } " with the same quotation supplied for every value." ;
 
 ARTICLE: "dip-keep-combinators" "Preserving combinators"
-"Sometimes it is necessary to temporarily hide values on the datastack. The " { $snippet "dip" } " combinators invoke the quotation at the top of the stack, hiding some number of values underneath:"
+"Sometimes it is necessary to temporarily hide values on the datastack. The " { $snippet "dip" } " combinators invoke the quotation at the top of the stack, hiding some number of values:"
 { $subsections dip 2dip 3dip 4dip }
-"The " { $snippet "keep" } " combinators invoke a quotation and restore some number of values to the top of the stack when it completes:"
+"The " { $snippet "keep" } " combinators invoke a quotation and restore some number of values to the top of the stack:"
 { $subsections keep 2keep 3keep } ;
 
 ARTICLE: "curried-dataflow" "Curried dataflow combinators"

core/sets/sets-docs.factor

@@ -15,7 +15,7 @@ ABOUT: "sets"
 
 ARTICLE: "set-operations" "Operations on sets"
 "To test if an object is a member of a set:"
-{ $subsections member? }
+{ $subsections in? }
 "All sets can be represented as a sequence, without duplicates, of their members:"
 { $subsections members }
 "Sets can have members added or removed destructively:"

core/vocabs/loader/loader.factor

@@ -8,6 +8,9 @@ IN: vocabs.loader
 
 SYMBOL: vocab-roots
 
+SYMBOL: add-vocab-root-hook
+
+[
     V{
         "resource:core"
         "resource:basis"
@@ -15,8 +18,12 @@ V{
         "resource:work"
     } clone vocab-roots set-global
 
+    [ drop ] add-vocab-root-hook set-global
+] "vocabs.loader" add-startup-hook
+
 : add-vocab-root ( root -- )
-    vocab-roots get adjoin ;
+    [ vocab-roots get adjoin ]
+    [ add-vocab-root-hook get-global call( root -- ) ] bi ;
 
 SYMBOL: root-cache
 

extra/benchmark/binary-trees/binary-trees.factor

@@ -1,5 +1,7 @@
-USING: kernel math accessors prettyprint io locals sequences
+! Copyright (C) 2008, 2010 Slava Pestov.
-math.ranges math.order ;
+! See http://factorcode.org/license.txt for BSD license.
+USING: accessors kernel math math.ranges math.order math.parser
+io locals sequences ;
 IN: benchmark.binary-trees
 
 TUPLE: tree-node item left right ;
@@ -27,8 +29,8 @@ CONSTANT: min-depth 4
 
 : stretch-tree ( max-depth -- )
     1 + 0 over bottom-up-tree item-check
-    [ "stretch tree of depth " write pprint ]
+    [ "stretch tree of depth " write number>string write ]
-    [ "\t check: " write . ] bi* ; inline
+    [ "\t check: " write number>string print ] bi* ; inline
 
 :: long-lived-tree ( max-depth -- )
     0 max-depth bottom-up-tree
@@ -40,13 +42,13 @@ CONSTANT: min-depth 4
                 [ depth bottom-up-tree item-check + ] bi@
             ] reduce
         ]
-        [ 2 * ] bi
+        [ 2 * number>string write ] bi
-        pprint "\t trees of depth " write depth pprint
+        "\t trees of depth " write depth number>string write
-        "\t check: " write .
+        "\t check: " write number>string print
     ] each
 
-    "long lived tree of depth " write max-depth pprint
+    "long lived tree of depth " write max-depth number>string write
-    "\t check: " write item-check . ; inline
+    "\t check: " write item-check number>string print ; inline
 
 : binary-trees ( n -- )
     min-depth 2 + max [ stretch-tree ] [ long-lived-tree ] bi ; inline

extra/benchmark/binary-trees/deploy.factor

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

extra/benchmark/fasta/deploy.factor

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

extra/benchmark/knucleotide/deploy.factor

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

extra/benchmark/knucleotide/knucleotide.factor

@@ -1,9 +1,13 @@
+! Copyright (C) 2008, 2010 Slava Pestov.
+! See http://factorcode.org/license.txt for BSD license.
 USING: ascii kernel io io.files splitting strings
 io.encodings.ascii hashtables sequences assocs math
-math.statistics namespaces prettyprint math.parser combinators
+math.statistics namespaces math.parser combinators arrays
-arrays sorting formatting grouping fry ;
+sorting formatting grouping fry ;
 IN: benchmark.knucleotide
 
+CONSTANT: knucleotide-in "vocab:benchmark/knucleotide/knucleotide-input.txt"
+
 : discard-lines ( -- )
     readln
     [ ">THREE" head? [ discard-lines ] unless ] when* ;
@@ -34,7 +38,7 @@ IN: benchmark.knucleotide
     tri ;
 
 : knucleotide ( -- )
-    "resource:extra/benchmark/knucleotide/knucleotide-input.txt"
+    knucleotide-in
     ascii [ read-input ] with-file-reader
     process-input ;
 

extra/benchmark/nbody-simd/deploy.factor

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

extra/benchmark/nbody-simd/nbody-simd.factor

@@ -1,9 +1,9 @@
-! Copyright (C) 2008, 2009 Slava Pestov.
+! Copyright (C) 2008, 2010 Slava Pestov.
 ! See http://factorcode.org/license.txt for BSD license.
 USING: accessors alien.c-types fry kernel locals math
 math.constants math.functions math.vectors math.vectors.simd
-math.vectors.simd.cords prettyprint combinators.smart sequences
+math.vectors.simd.cords math.parser combinators.smart sequences
-hints classes.struct specialized-arrays ;
+hints classes.struct specialized-arrays io ;
 IN: benchmark.nbody-simd
 
 : solar-mass ( -- x ) 4 pi sq * ; inline
@@ -94,7 +94,9 @@ SPECIALIZED-ARRAY: body
 : nbody ( n -- )
     >fixnum
     <nbody-system>
-    [ energy . ] [ '[ _ 0.01 advance ] times ] [ energy . ] tri ;
+    [ energy number>string print ]
+    [ '[ _ 0.01 advance ] times ]
+    [ energy number>string print ] tri ;
 
 : nbody-main ( -- ) 1000000 nbody ;
 

extra/benchmark/regex-dna/deploy.factor

@@ -1,14 +1,15 @@
 USING: tools.deploy.config ;
 H{
-    { deploy-word-defs? f }
-    { deploy-word-props? f }
-    { deploy-math? f }
     { deploy-ui? f }
-    { deploy-c-types? f }
+    { deploy-word-defs? f }
-    { "stop-after-last-window?" t }
+    { deploy-threads? t }
+    { deploy-math? t }
+    { deploy-io 3 }
     { deploy-reflection 1 }
-    { deploy-name "benchmark.regex-dna" }
-    { deploy-io 2 }
-    { deploy-threads? f }
     { deploy-unicode? f }
+    { "stop-after-last-window?" t }
+    { deploy-console? t }
+    { deploy-word-props? f }
+    { deploy-c-types? f }
+    { deploy-name "benchmark.regex-dna" }
 }

extra/benchmark/regex-dna/regex-dna.factor

@@ -1,7 +1,7 @@
 ! Copyright (C) 2008, 2009 Slava Pestov.
 ! See http://factorcode.org/license.txt for BSD license.
 USING: accessors io io.encodings.ascii io.files kernel sequences
-assocs math.parser namespaces regexp ;
+assocs math.parser namespaces regexp benchmark.knucleotide ;
 IN: benchmark.regex-dna
 
 ! Based on http://shootout.alioth.debian.org/gp4/benchmark.php?test=regexdna&lang=ruby&id=1
@@ -55,6 +55,6 @@ SYMBOL: clen
     length number>string print ;
 
 : regex-dna-main ( -- )
-    "resource:extra/benchmark/regex-dna/regex-dna-test-in.txt" regex-dna ;
+    knucleotide-in regex-dna ;
 
 MAIN: regex-dna-main

extra/benchmark/reverse-complement/deploy.factor

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

extra/benchmark/spectral-norm-simd/authors.txt

@@ -0,0 +1 @@
+Marc Fauconneau

extra/benchmark/spectral-norm-simd/spectral-norm-simd.factor

@@ -0,0 +1,68 @@
+! Copyright (C) 2010 Marc Fauconneau.
+! See http://factorcode.org/license.txt for BSD license.
+USING: alien.c-types specialized-arrays kernel math
+math.functions math.vectors sequences sequences.private
+prettyprint words typed locals math.vectors.simd
+math.vectors.simd.cords ;
+SPECIALIZED-ARRAYS: double double-4 ;
+IN: benchmark.spectral-norm-simd
+
+:: inner-loop ( u n quot -- seq )
+    n 4 /i iota [| i |
+        n iota [| j | u i j quot call ] [ v+ ] map-reduce
+    ] double-4-array{ } map-as ; inline
+
+: eval-A ( i j -- n )
+    [ >float ] bi@
+    [ drop ] [ + [ ] [ 1 + ] bi * 0.5 * ] 2bi
+    + 1 + ; inline
+
+: vrecip ( u -- v ) double-4{ 1.0 1.0 1.0 1.0 } swap v/ ; inline
+
+:: eval4-A ( i j -- n )
+    i 4 * 0 + j eval-A
+    i 4 * 1 + j eval-A
+    i 4 * 2 + j eval-A
+    i 4 * 3 + j eval-A
+    double-4-boa vrecip ; inline
+
+: (eval-A-times-u) ( u i j -- x )
+    [ swap nth-unsafe ] [ eval4-A ] bi-curry bi* n*v ; inline
+
+: eval-A-times-u ( n u -- seq )
+    [ (eval-A-times-u) ] inner-loop ; inline
+    
+:: eval4-A' ( i j -- n )
+    j i 4 * 0 + eval-A
+    j i 4 * 1 + eval-A
+    j i 4 * 2 + eval-A
+    j i 4 * 3 + eval-A
+    double-4-boa vrecip ; inline
+
+: (eval-At-times-u) ( u i j -- x )
+    [ swap nth-unsafe ] [ eval4-A' ] bi-curry bi* n*v ; inline
+
+: eval-At-times-u ( u n -- seq )
+    [ double-array-cast ] dip [ (eval-At-times-u) ] inner-loop ; inline
+
+: eval-AtA-times-u ( u n -- seq )
+    [ double-array-cast ] dip [ eval-A-times-u ] [ eval-At-times-u ] bi ; inline
+
+: ones ( n -- seq )
+    4 /i [ double-4{ 1.0 1.0 1.0 1.0 } ] double-4-array{ } replicate-as ; inline
+
+:: u/v ( n -- u v )
+    n ones dup
+    10 [
+        drop
+        n eval-AtA-times-u
+        [ n eval-AtA-times-u ] keep
+    ] times ; inline
+
+TYPED: spectral-norm ( n: fixnum -- norm )
+    u/v [ double-array-cast ] bi@ [ v. ] [ norm-sq ] bi /f sqrt ;
+
+: spectral-norm-main ( -- )
+    2000 spectral-norm . ;
+
+MAIN: spectral-norm-main

extra/benchmark/spectral-norm/deploy.factor

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

extra/benchmark/spectral-norm/spectral-norm.factor

@@ -1,8 +1,11 @@
+! Copyright (C) 2008, 2010 Slava Pestov.
+! See http://factorcode.org/license.txt for BSD license.
+!
 ! Factor port of
 ! http://shootout.alioth.debian.org/gp4/benchmark.php?test=spectralnorm&lang=all
-USING: alien.c-types specialized-arrays kernel math
+USING: alien.c-types io kernel math math.functions math.parser
-math.functions math.vectors sequences sequences.private
+math.vectors sequences sequences.private specialized-arrays
-prettyprint words typed locals ;
+typed locals ;
 SPECIALIZED-ARRAY: double
 IN: benchmark.spectral-norm
 
@@ -47,6 +50,6 @@ TYPED: spectral-norm ( n: fixnum -- norm )
     u/v [ v. ] [ norm-sq ] bi /f sqrt ;
 
 : spectral-norm-main ( -- )
-    2000 spectral-norm . ;
+    2000 spectral-norm number>string print ;
 
 MAIN: spectral-norm-main

extra/bson/bson-tests.factor

@@ -1,10 +1,10 @@
-USING: bson.reader bson.writer byte-arrays io.encodings.binary
+USING: bson.reader bson.writer bson.constants byte-arrays io.encodings.binary
 io.streams.byte-array tools.test literals calendar kernel math ;
 
 IN: bson.tests
 
 : turnaround ( value -- value )
-    assoc>bv >byte-array binary [ H{ } stream>assoc ] with-byte-reader ;
+    assoc>bv >byte-array binary [ H{ } clone stream>assoc ] with-byte-reader ;
 
 [ H{ { "a" "a string" } } ] [ H{ { "a" "a string" } } turnaround ] unit-test
 
@@ -17,6 +17,9 @@ IN: bson.tests
 [ H{ { "a quotation" [ 1 2 + ] } } ]
 [ H{ { "a quotation" [ 1 2 + ] } } turnaround ] unit-test
 
+[ H{ { "ref" T{ dbref f "a" "b" "c" } } } ]
+[ H{ { "ref" T{ dbref f "a" "b" "c" } } } turnaround ] unit-test
+
 [ H{ { "a date" T{ timestamp { year 2009 }
                    { month 7 }
                    { day 11 }
@@ -34,10 +37,12 @@ IN: bson.tests
 ] unit-test
                    
 [ H{ { "nested" H{ { "a" "a string" } { "b" H{ { "a" "a string" } } } } }
+     { "ref" T{ dbref f "a" "b" "c" } }
      { "array" H{ { "a list" { 1 2.234 "hello world" } } } }
      { "quot" [ 1 2 + ] } }
 ]     
 [ H{ { "nested" H{ { "a" "a string" } { "b" H{ { "a" "a string" } } } } }
+     { "ref" T{ dbref f "a" "b" "c" } }
      { "array" H{ { "a list" { 1 2.234 "hello world" } } } }
      { "quot" [ 1 2 + ] } } turnaround ] unit-test
      

extra/bson/bson.factor

@@ -1,3 +1,5 @@
+! Copyright (C) 2010 Sascha Matzke.
+! See http://factorcode.org/license.txt for BSD license.
 USING: vocabs.loader ;
 
 IN: bson

extra/bson/constants/constants.factor

@@ -1,5 +1,8 @@
-USING: accessors constructors kernel strings uuid ;
+! Copyright (C) 2010 Sascha Matzke.
-
+! See http://factorcode.org/license.txt for BSD license.
+USING: accessors assocs calendar combinators
+combinators.short-circuit constructors kernel linked-assocs
+math math.bitwise random strings uuid ;
 IN: bson.constants
 
 : <objid> ( -- objid )
@@ -7,9 +10,33 @@ IN: bson.constants
 
 TUPLE: oid { a initial: 0 } { b initial: 0 } ;
 
-TUPLE: objref ns objid ;
+: <oid> ( -- oid )
+    oid new
+    now timestamp>micros >>a
+    8 random-bits 16 shift HEX: FF0000 mask
+    16 random-bits HEX: FFFF mask
+    bitor >>b ;
 
-CONSTRUCTOR: objref ( ns objid -- objref ) ;
+TUPLE: dbref ref id db ;
+
+CONSTRUCTOR: dbref ( ref id -- dbref ) ;
+
+: dbref>assoc ( dbref -- assoc )
+    [ <linked-hash> ] dip over
+    {
+        [ [ ref>> "$ref" ] [ set-at ] bi* ]
+        [ [ id>> "$id" ] [ set-at ] bi* ]
+        [ over db>> [
+                [ db>> "$db" ] [ set-at ] bi*
+            ] [ 2drop ] if ]
+    } 2cleave ; inline
+
+: assoc>dbref ( assoc -- dbref )
+    [ "$ref" swap at ] [ "$id" swap at ] [ "$db" swap at ] tri
+    dbref boa ; inline
+
+: dbref-assoc? ( assoc -- ? )
+    { [ "$ref" swap key? ] [ "$id" swap key? ] } 1&& ; inline
 
 TUPLE: mdbregexp { regexp string } { options string } ;
 

extra/bson/reader/reader.factor

@@ -1,185 +1,161 @@
-USING: accessors assocs bson.constants calendar fry io io.binary
+! Copyright (C) 2010 Sascha Matzke.
-io.encodings io.encodings.utf8 kernel math math.bitwise namespaces
+! See http://factorcode.org/license.txt for BSD license.
-sequences serialize locals ;
+USING: accessors assocs bson.constants calendar combinators
+combinators.short-circuit io io.binary kernel math locals
+namespaces sequences serialize strings vectors byte-arrays ;
 
-FROM: kernel.private => declare ;
+FROM: io.encodings.binary => binary ;
-FROM: io.encodings.private => (read-until) ;
+FROM: io.streams.byte-array => with-byte-reader ;
+FROM: typed => TYPED: ;
 
 IN: bson.reader
 
 <PRIVATE
 
 TUPLE: element { type integer } name ;
+
 TUPLE: state
-    { size initial: -1 } exemplar
+    { size initial: -1 }
-    result scope element ;
+    { exemplar assoc }
+    result
+    { scope vector }
+    { elements vector } ;
+
+TYPED: (prepare-elements) ( -- elements-vector: vector )
+    V{ } clone [ T_Object "" element boa swap push ] [ ] bi ; inline
 
 : <state> ( exemplar -- state )
     [ state new ] dip
-    [ clone >>exemplar ] keep
+    {
-    clone [ >>result ] [ V{ } clone [ push ] keep >>scope ] bi
+        [ clone >>exemplar ]
-    V{ } clone [ T_Object "" element boa swap push ] keep >>element ; 
+        [ clone >>result ]
+        [ V{ } clone [ push ] keep >>scope ]
+    } cleave
+    (prepare-elements) >>elements ;
 
-PREDICATE: bson-not-eoo < integer T_EOO > ;
+TYPED: get-state ( -- state: state )
-PREDICATE: bson-eoo     < integer T_EOO = ;
-
-PREDICATE: bson-string  < integer T_String = ;
-PREDICATE: bson-object  < integer T_Object = ;
-PREDICATE: bson-oid     < integer T_OID = ;
-PREDICATE: bson-array   < integer T_Array = ;
-PREDICATE: bson-integer < integer T_Integer = ;
-PREDICATE: bson-double  < integer T_Double = ;
-PREDICATE: bson-date    < integer T_Date = ;
-PREDICATE: bson-binary  < integer T_Binary = ;
-PREDICATE: bson-boolean < integer T_Boolean = ;
-PREDICATE: bson-regexp  < integer T_Regexp = ;
-PREDICATE: bson-null    < integer T_NULL = ;
-PREDICATE: bson-ref     < integer T_DBRef = ;
-PREDICATE: bson-binary-bytes < integer T_Binary_Bytes = ;
-PREDICATE: bson-binary-function < integer T_Binary_Function = ;
-PREDICATE: bson-binary-uuid < integer T_Binary_UUID = ;
-PREDICATE: bson-binary-custom < integer T_Binary_Custom = ;
-
-GENERIC: element-read ( type -- cont? )
-GENERIC: element-data-read ( type -- object )
-GENERIC: element-binary-read ( length type -- object )
-
-: get-state ( -- state )
     state get ; inline
 
-: read-int32 ( -- int32 )
+TYPED: read-int32 ( -- int32: integer )
     4 read signed-le> ; inline
 
-: read-longlong ( -- longlong )
+TYPED: read-longlong ( -- longlong: integer )
     8 read signed-le> ; inline
 
-: read-double ( -- double )
+TYPED: read-double ( -- double: float )
     8 read le> bits>double ; inline
 
-: read-byte-raw ( -- byte-raw )
+TYPED: read-byte-raw ( -- byte-raw: byte-array )
     1 read ; inline
 
-: read-byte ( -- byte )
+TYPED: read-byte ( -- byte: integer )
     read-byte-raw first ; inline
 
-: read-cstring ( -- string )
+TYPED: read-cstring ( -- string: string )
-    "\0" read-until drop "" like ; inline
+    "\0" read-until drop >string ; inline
 
-: read-sized-string ( length -- string )
+TYPED: read-sized-string ( length: integer -- string: string )
-    read 1 head-slice* "" like ; inline
+    read 1 head-slice* >string ; inline
 
-: read-element-type ( -- type )
+TYPED: push-element ( type: integer name: string state: state -- )
-    read-byte ; inline
+    [ element boa ] dip elements>> push ; inline
 
-: push-element ( type name -- )
+TYPED: pop-element ( state: state -- element: element )
-    element boa get-state element>> push ; inline
+    elements>> pop ; inline
 
-: pop-element ( -- element )
+TYPED: peek-scope ( state: state -- ht )
-    get-state element>> pop ; inline
-
-: peek-scope ( -- ht )
-    get-state scope>> last ; inline
-
-: read-elements ( -- )
-    read-element-type
-    element-read 
-    [ read-elements ] when ; inline recursive
-
-GENERIC: fix-result ( assoc type -- result )
-
-M: bson-object fix-result ( assoc type -- result )
-    drop ;
-
-M: bson-array fix-result ( assoc type -- result )
-    drop values ;
-
-GENERIC: end-element ( type -- )
-
-M: bson-object end-element ( type -- )
-    drop ;
-
-M: bson-array end-element ( type -- )
-    drop ;
-
-M: object end-element ( type -- )
-    pop-element 2drop ;
-
-M:: bson-eoo element-read ( type -- cont? )
-    pop-element :> element
-    get-state scope>>
-    [ pop element type>> fix-result ] [ empty? ] bi
-    [ [ get-state ] dip >>result drop f ]
-    [ element name>> peek-scope set-at t ] if ;
-
-M:: bson-not-eoo element-read ( type -- cont? )
-    peek-scope :> scope
-    type read-cstring [ push-element ] 2keep
-    [ [ element-data-read ] [ end-element ] bi ]
-    [ scope set-at t ] bi* ;
-
-: [scope-changer] ( state -- state quot )
-    dup exemplar>> '[ [ [ _ clone ] dip push ] keep ] ; inline
-
-: (object-data-read) ( type -- object )
-    drop
-    read-int32 drop
-    get-state
-    [scope-changer] change-scope
     scope>> last ; inline
 
-M: bson-object element-data-read ( type -- object )
+: bson-object-data-read ( -- object )
-    (object-data-read) ;
+    read-int32 drop get-state 
+    [ exemplar>> clone dup ] [ scope>> ] bi push ; inline
 
-M: bson-string element-data-read ( type -- object )
+: bson-binary-read ( -- binary )
-    drop
+   read-int32 read-byte 
-    read-int32 read-sized-string ;
+   {
+        { T_Binary_Bytes [ read ] }
+        { T_Binary_Custom [ read bytes>object ] }
+        { T_Binary_Function [ read ] }
+        [ drop read >string ]
+   } case ; inline
 
-M: bson-array element-data-read ( type -- object )
+TYPED: bson-regexp-read ( -- mdbregexp: mdbregexp )
-    (object-data-read) ;
+   mdbregexp new
+   read-cstring >>regexp read-cstring >>options ; inline
 
-M: bson-integer element-data-read ( type -- object )
+TYPED: bson-oid-read ( -- oid: oid )
-    drop
+    read-longlong read-int32 oid boa ; inline
-    read-int32 ;
 
-M: bson-double element-data-read ( type -- double )
+TYPED: element-data-read ( type: integer -- object )
-    drop
+    {
-    read-double ;
+        { T_OID [ bson-oid-read ] }
+        { T_String [ read-int32 read-sized-string ] }
+        { T_Integer [ read-int32 ] }
+        { T_Binary [ bson-binary-read ] }
+        { T_Object [ bson-object-data-read ] }
+        { T_Array [ bson-object-data-read ] }
+        { T_Double [ read-double ] }
+        { T_Boolean [ read-byte 1 = ] }
+        { T_Date [ read-longlong millis>timestamp ] }
+        { T_Regexp [ bson-regexp-read ] }
+        { T_NULL [ f ] }
+    } case ; inline
 
-M: bson-boolean element-data-read ( type -- boolean )
+TYPED: bson-array? ( type: integer -- ?: boolean )
-   drop
+    T_Array = ; inline
-   read-byte 1 = ;
 
-M: bson-date element-data-read ( type -- timestamp )
+TYPED: bson-object? ( type: integer -- ?: boolean )
-   drop
+    T_Object = ; inline
-   read-longlong millis>timestamp ;
 
-M: bson-binary element-data-read ( type -- binary )
+: check-object ( assoc -- object )
-   drop
+    dup dbref-assoc? [ assoc>dbref ] when ; inline
-   read-int32 read-byte element-binary-read ;
 
-M: bson-regexp element-data-read ( type -- mdbregexp )
+TYPED: fix-result ( assoc type: integer -- result )
-   drop mdbregexp new
+    {
-   read-cstring >>regexp read-cstring >>options ;
+        { T_Array [ values ] }
+        { T_Object [ check-object ] }
+    } case ; inline
 
-M: bson-null element-data-read ( type -- bf  )
+TYPED: end-element ( type: integer -- )
-    drop f ;
+    { [ bson-object? ] [ bson-array? ] } 1||
+    [ get-state pop-element drop ] unless ; inline
 
-M: bson-oid element-data-read ( type -- oid )
+TYPED: (>state<) ( -- state: state scope: vector element: element )
-    drop
+    get-state [  ] [ scope>> ] [ pop-element ] tri ; inline
-    read-longlong
-    read-int32 oid boa ;
 
-M: bson-binary-bytes element-binary-read ( size type -- bytes )
+TYPED: (prepare-result) ( scope: vector element: element -- result )
-    drop read ;
+    [ pop ] [ type>> ] bi* fix-result ; inline
 
-M: bson-binary-custom element-binary-read ( size type -- quot )
+: bson-eoo-element-read ( -- cont?: boolean )
-    drop read bytes>object ;
+    (>state<)
+    [ (prepare-result) ] [  ] [ drop empty? ] 2tri
+    [ 2drop >>result drop f ]
+    [ swap [ name>> ] [ last ] bi* set-at drop t ] if ; inline
+
+TYPED: (prepare-object) ( type: integer -- object )
+    [ element-data-read ] [ end-element ] bi ; inline
+
+:: (read-object) ( type name state -- )
+    state peek-scope :> scope
+    type (prepare-object) name scope set-at ; inline
+
+TYPED: bson-not-eoo-element-read ( type: integer -- cont?: boolean )
+    read-cstring get-state
+    [ push-element ]
+    [ (read-object) t ] 3bi ; inline
+
+TYPED: (element-read) ( type: integer -- cont?: boolean )
+    dup T_EOO > 
+    [ bson-not-eoo-element-read ]
+    [ drop bson-eoo-element-read ] if ; inline
+
+: read-elements ( -- )
+    read-byte (element-read)
+    [ read-elements ] when ; inline recursive
 
 PRIVATE>
 
-USE: tools.continuations
-
 : stream>assoc ( exemplar -- assoc )
-    <state> dup state
+    <state> read-int32 >>size
-    [ read-int32 >>size read-elements ] with-variable 
+    [ state [ read-elements ] with-variable ]
-    result>> ; 
+    [ result>> ] bi ;

extra/bson/summary.txt

@@ -1 +1 @@
-BSON reader and writer
+BSON (http://en.wikipedia.org/wiki/BSON) reader and writer

extra/bson/writer/writer.factor

@@ -1,155 +1,160 @@
-! Copyright (C) 2008 Sascha Matzke.
+! Copyright (C) 2010 Sascha Matzke.
 ! See http://factorcode.org/license.txt for BSD license.
-USING: accessors assocs bson.constants byte-arrays byte-vectors
+USING: accessors arrays assocs bson.constants byte-arrays
-calendar fry io io.binary io.encodings io.encodings.binary
+calendar combinators.short-circuit fry hashtables io io.binary
-io.encodings.utf8 io.streams.byte-array kernel math math.parser
+kernel linked-assocs literals math math.parser namespaces byte-vectors
-namespaces quotations sequences sequences.private serialize strings
+quotations sequences serialize strings vectors dlists alien.accessors ;
-words combinators.short-circuit literals ;
+FROM: words => word? word ;
-
+FROM: typed => TYPED: ;
-FROM: io.encodings.utf8.private => char>utf8 ;
+FROM: combinators => cond ;
-FROM: kernel.private => declare ;
-
 IN: bson.writer
 
 <PRIVATE
 
-SYMBOL: shared-buffer 
+CONSTANT: INT32-SIZE { 0 1 2 3 }
-
+CONSTANT: INT64-SIZE { 0 1 2 3 4 5 6 7 }
-CONSTANT: CHAR-SIZE  1
-CONSTANT: INT32-SIZE 4
-CONSTANT: INT64-SIZE 8
-
-: (buffer) ( -- buffer )
-    shared-buffer get
-    [ BV{ } clone [ shared-buffer set ] keep ] unless*
-    { byte-vector } declare ; inline 
 
 PRIVATE>
 
-: reset-buffer ( buffer -- )
+TYPED: get-output ( -- stream: byte-vector )
-    0 >>length drop ; inline
+    output-stream get ; inline
 
-: ensure-buffer ( -- )
+TYPED: with-length ( quot -- bytes-written: integer start-index: integer )
-    (buffer) drop ; inline
+    [ get-output [ length ] [ ] bi ] dip
-
-: with-buffer ( ..a quot: ( ..a -- ..b ) -- ..b byte-vector )
-    [ (buffer) [ reset-buffer ] keep dup ] dip
-    with-output-stream* ; inline
-
-: with-length ( ..a quot: ( ..a -- ..b ) -- ..b bytes-written start-index )
-    [ (buffer) [ length ] keep ] dip
     call length swap [ - ] keep ; inline
 
-: (with-length-prefix) ( ..a quot: ( ..a -- ..b ) length-quot: ( bytes-written -- length ) -- ..b )
+: (with-length-prefix) ( quot: ( .. -- .. ) length-quot: ( bytes-written -- length ) -- )
     [ [ B{ 0 0 0 0 } write ] prepose with-length ] dip swap
-    [ call ] dip (buffer) copy ; inline
+    [ call( written -- length ) get-output underlying>> ] dip set-alien-unsigned-4 ; inline
 
-: with-length-prefix ( ..a quot: ( ..a -- ..b ) -- ..b )
+: with-length-prefix ( quot: ( .. -- .. ) -- )
-    [ INT32-SIZE >le ] (with-length-prefix) ; inline
+    [ ] (with-length-prefix) ; inline
     
-: with-length-prefix-excl ( ..a quot: ( ..a -- ..b ) -- ..b )
+: with-length-prefix-excl ( quot: ( .. -- .. ) -- )
-    [ INT32-SIZE [ - ] keep >le ] (with-length-prefix) ; inline
+    [ 4 - ] (with-length-prefix) ; inline
+
+: (>le) ( x n -- )
+    [ nth-byte write1 ] with each ; inline
     
 <PRIVATE
 
-GENERIC: bson-type? ( obj -- type ) 
+TYPED: write-int32 ( int: integer -- ) INT32-SIZE (>le) ; inline
-GENERIC: bson-write ( obj -- ) 
 
-M: t bson-type? ( boolean -- type ) drop T_Boolean ; 
+TYPED: write-double ( real: float -- ) double>bits INT64-SIZE (>le) ; inline
-M: f bson-type? ( boolean -- type ) drop T_Boolean ; 
 
-M: string bson-type? ( string -- type ) drop T_String ; 
+TYPED: write-cstring ( string: string -- )
-M: integer bson-type? ( integer -- type ) drop T_Integer ; 
+    get-output [ length ] [  ] bi copy 0 write1 ; inline
-M: assoc bson-type? ( assoc -- type ) drop T_Object ;
-M: real bson-type? ( real -- type ) drop T_Double ; 
-M: tuple bson-type? ( tuple -- type ) drop T_Object ;  
-M: sequence bson-type? ( seq -- type ) drop T_Array ;
-M: timestamp bson-type? ( timestamp -- type ) drop T_Date ;
-M: mdbregexp bson-type? ( regexp -- type ) drop T_Regexp ;
 
-M: oid bson-type? ( word -- type ) drop T_OID ;
+: write-longlong ( object -- ) INT64-SIZE (>le) ; inline
-M: objref bson-type? ( objref -- type ) drop T_Binary ;
-M: word bson-type? ( word -- type ) drop T_Binary ;
-M: quotation bson-type? ( quotation -- type ) drop T_Binary ; 
-M: byte-array bson-type? ( byte-array -- type ) drop T_Binary ; 
-
-: write-int32 ( int -- ) INT32-SIZE >le write ; inline
-: write-double ( real -- ) double>bits INT64-SIZE >le write ; inline
-: write-cstring ( string -- ) B{ } like write 0 write1 ; inline
-: write-longlong ( object -- ) INT64-SIZE >le write ; inline
 
 : write-eoo ( -- ) T_EOO write1 ; inline
-: write-type ( obj -- obj ) [ bson-type? write1 ] keep ; inline
-: write-pair ( name object -- ) write-type [ write-cstring ] dip bson-write ; inline
 
-M: string bson-write ( obj -- )
+TYPED: write-header ( name: string object type: integer -- object )
-    '[ _ write-cstring ] with-length-prefix-excl ;
+    write1 [ write-cstring ] dip ; inline
 
-M: f bson-write ( f -- )
+DEFER: write-pair
-    drop 0 write1 ; 
 
-M: t bson-write ( t -- )
+TYPED: write-byte-array ( binary: byte-array -- )
-    drop 1 write1 ;
+    [ length write-int32 ]
+    [ T_Binary_Bytes write1 write ] bi ; inline
 
-M: integer bson-write ( num -- )
+TYPED: write-mdbregexp ( regexp: mdbregexp -- )
-    write-int32 ;
-
-M: real bson-write ( num -- )
-    >float write-double ;
-
-M: timestamp bson-write ( timestamp -- )
-    timestamp>millis write-longlong ;
-
-M: byte-array bson-write ( binary -- )
-    [ length write-int32 ] keep
-    T_Binary_Bytes write1
-    write ; 
-
-M: oid bson-write ( oid -- )
-    [ a>> write-longlong ] [ b>> write-int32 ] bi ;
-       
-M: mdbregexp bson-write ( regexp -- )
    [ regexp>> write-cstring ]
-   [ options>> write-cstring ] bi ; 
+   [ options>> write-cstring ] bi ; inline
 
-M: sequence bson-write ( array -- )
+TYPED: write-sequence ( array: sequence -- )
-    '[ _ [ [ write-type ] dip number>string
-           write-cstring bson-write ] each-index
-       write-eoo ] with-length-prefix ;
-
-: write-oid ( assoc -- )
-    [ MDB_OID_FIELD ] dip at
-    [ [ MDB_OID_FIELD ] dip write-pair ] when* ; inline
-
-: skip-field? ( name -- boolean )
-   { $[ MDB_OID_FIELD MDB_META_FIELD ] } member? ; inline
-
-M: assoc bson-write ( assoc -- )
    '[
-        _  [ write-oid ] keep
+        _ [ number>string swap write-pair ] each-index
-        [ over skip-field? [ 2drop ] [ write-pair ] if ] assoc-each
         write-eoo
-    ] with-length-prefix ;
+    ] with-length-prefix ; inline recursive
 
-: (serialize-code) ( code -- )
+TYPED: write-oid ( oid: oid -- )
-    object>bytes [ length write-int32 ] keep
+    [ a>> write-longlong ] [ b>> write-int32 ] bi ; inline
-    T_Binary_Custom write1
-    write ;
 
-M: quotation bson-write ( quotation -- )
+: write-oid-field ( assoc -- )
-    (serialize-code) ;
+    [ MDB_OID_FIELD dup ] dip at
+    [ dup oid? [ T_OID write-header write-oid ] [ write-pair ] if ] 
+    [ drop ] if* ; inline
 
-M: word bson-write ( word -- )
+: skip-field? ( name value -- name value boolean )
-    (serialize-code) ;
+    over { [ MDB_OID_FIELD = ] [ MDB_META_FIELD = ] } 1|| ; inline
+
+UNION: hashtables hashtable linked-assoc ;
+
+TYPED: write-assoc ( assoc: hashtables -- )
+    '[ _ [ write-oid-field ] [
+            [ skip-field? [ 2drop ] [ write-pair ] if ] assoc-each 
+         ] bi write-eoo
+    ] with-length-prefix ; inline recursive
+
+UNION: code word quotation ;
+
+TYPED: (serialize-code) ( code: code -- )
+  object>bytes
+  [ length write-int32 ]
+  [ T_Binary_Custom write1 write ] bi ; inline
+
+TYPED: write-string ( string: string -- )
+    '[ _ write-cstring ] with-length-prefix-excl ; inline
+
+TYPED: write-boolean ( bool: boolean -- )
+    [ 1 write1 ] [ 0 write1 ] if ; inline
+
+TYPED: write-pair ( name: string obj -- )
+    {
+        {
+            [ dup { [ hashtable? ] [ linked-assoc? ] } 1|| ]
+            [ T_Object write-header write-assoc ]
+        } {
+            [ dup { [ array? ] [ vector? ] [ dlist? ] } 1|| ]
+            [ T_Array write-header write-sequence ]
+        } {
+            [ dup byte-array? ]
+            [ T_Binary write-header write-byte-array ]
+        } {
+            [ dup string? ]
+            [ T_String write-header write-string ]
+        } {
+            [ dup oid? ]
+            [ T_OID write-header write-oid ]
+        } {
+            [ dup integer? ]
+            [ T_Integer write-header write-int32 ]
+        } {
+            [ dup boolean? ] 
+            [ T_Boolean write-header write-boolean ]
+        } {
+            [ dup real? ]
+            [ T_Double write-header >float write-double ]
+        } {
+            [ dup timestamp? ]
+            [ T_Date write-header timestamp>millis write-longlong ]
+        } {
+            [ dup mdbregexp? ]
+            [ T_Regexp write-header write-mdbregexp ]
+        } {
+            [ dup quotation? ]
+            [ T_Binary write-header (serialize-code) ]
+        } {
+            [ dup word? ]
+            [ T_Binary write-header (serialize-code) ]
+        } {
+            [ dup dbref? ]
+            [ T_Object write-header dbref>assoc write-assoc ]
+        } {
+            [ dup f = ]
+            [ T_NULL write-header drop ]
+        }
+    } cond ;
 
 PRIVATE>
 
-: assoc>bv ( assoc -- byte-vector )
+TYPED: assoc>bv ( assoc: hashtables -- byte-vector: byte-vector )
-    [ '[ _ bson-write ] with-buffer ] with-scope ; inline
+    [ BV{ } clone dup ] dip '[ _ write-assoc ] with-output-stream* ; inline
 
-: assoc>stream ( assoc -- )
+TYPED: assoc>stream ( assoc: hashtables -- )
-    { assoc } declare bson-write ; inline
+    write-assoc ; inline
 
-: mdb-special-value? ( value -- ? )
+TYPED: mdb-special-value? ( value -- ?: boolean )
    { [ timestamp? ] [ quotation? ] [ mdbregexp? ]
      [ oid? ] [ byte-array? ] } 1|| ; inline

extra/cuda/contexts/contexts.factor

@@ -1,8 +1,12 @@
 ! (c)2010 Joe Groff bsd license
 USING: alien.c-types alien.data continuations cuda cuda.ffi
-cuda.libraries fry kernel namespaces ;
+cuda.libraries alien.destructors fry kernel namespaces ;
 IN: cuda.contexts
 
+: set-up-cuda-context ( -- )
+    H{ } clone cuda-modules set-global
+    H{ } clone cuda-functions set-global ; inline
+
 : create-context ( device flags -- context )
     swap
     [ CUcontext <c-object> ] 2dip
@@ -16,14 +20,15 @@ IN: cuda.contexts
 
 : destroy-context ( context -- ) cuCtxDestroy cuda-error ; inline
 
-: (set-up-cuda-context) ( device flags create-quot -- )
+: clean-up-context ( context -- )
-    H{ } clone cuda-modules set-global
+    [ sync-context ] ignore-errors destroy-context ; inline
-    H{ } clone cuda-functions set
+
-    call ; inline
+DESTRUCTOR: destroy-context
+DESTRUCTOR: clean-up-context
 
 : (with-cuda-context) ( context quot -- )
-    swap '[ [ sync-context ] ignore-errors _ destroy-context ] [ ] cleanup ; inline
+    swap '[ _ clean-up-context ] [ ] cleanup ; inline
 
 : with-cuda-context ( device flags quot -- )
-    [ [ create-context ] (set-up-cuda-context) ] dip (with-cuda-context) ; inline
+    [ set-up-cuda-context create-context ] dip (with-cuda-context) ; inline
 

extra/cuda/gl/gl.factor

@@ -1,5 +1,5 @@
 ! (c)2010 Joe Groff bsd license
-USING: accessors alien.c-types alien.data alien.destructors
+USING: accessors alien alien.c-types alien.data alien.destructors
 alien.enums continuations cuda cuda.contexts cuda.ffi
 cuda.gl.ffi destructors fry gpu.buffers kernel ;
 IN: cuda.gl
@@ -10,7 +10,7 @@ IN: cuda.gl
     [ cuGLCtxCreate cuda-error ] 3keep 2drop *void* ; inline
 
 : with-gl-cuda-context ( device flags quot -- )
-    [ [ create-gl-cuda-context ] (set-up-cuda-context) ] dip (with-cuda-context) ; inline 
+    [ set-up-cuda-context create-gl-cuda-context ] dip (with-cuda-context) ; inline 
 
 : gl-buffer>resource ( gl-buffer flags -- resource )
     enum>number
@@ -39,3 +39,17 @@ DESTRUCTOR: free-resource
 
 : with-mapped-resource ( ..a resource quot: ( ..a device-ptr size -- ..b ) -- ..b )
     over [ map-resource ] 2dip '[ _ unmap-resource ] [ ] cleanup ; inline
+
+TUPLE: cuda-buffer
+    { buffer buffer }
+    { resource pinned-c-ptr } ;
+
+: <cuda-buffer> ( upload usage kind size initial-data flags -- buffer )
+    [ <buffer> dup ] dip buffer>resource cuda-buffer boa ; inline
+
+M: cuda-buffer dispose
+    [ [ free-resource ] when* f ] change-resource
+    buffer>> dispose ; inline
+
+: with-mapped-cuda-buffer ( ..a cuda-buffer quot: ( ..a device-ptr size -- ..b ) -- ..b )
+    [ resource>> ] dip with-mapped-resource ; inline

extra/game/input/demos/joysticks/joysticks.factor

@@ -3,7 +3,7 @@ colors.constants ui.render ui.pens.polygon ui.pens.solid math.vectors
 accessors fry ui.gadgets.packs game.input ui.gadgets.labels
 ui.gadgets.borders alarms calendar locals strings ui.gadgets.buttons
 combinators math.parser assocs threads ;
-IN: joystick-demo
+IN: game.input.demos.joysticks
 
 CONSTANT: SIZE { 151 151 }
 CONSTANT: INDICATOR-SIZE { 4 4 }

extra/game/input/demos/key-caps/key-caps.factor

@@ -1,8 +1,8 @@
 USING: game.input game.input.scancodes
 kernel ui.gadgets ui.gadgets.buttons sequences accessors
 words arrays assocs math calendar fry alarms ui
-ui.gadgets.borders ui.gestures ;
+ui.gadgets.borders ui.gestures literals ;
-IN: key-caps
+IN: game.input.demos.key-caps
 
 CONSTANT: key-locations H{
     { key-escape        { {   0   0 } {  10  10 } } }
@@ -132,7 +132,7 @@ CONSTANT: key-locations H{
 }
 
 CONSTANT: KEYBOARD-SIZE { 230 65 }
-: FREQUENCY ( -- f ) 30 recip seconds ;
+CONSTANT: FREQUENCY $[ 1/30 seconds ]
 
 TUPLE: key-caps-gadget < gadget keys alarm ;
 

extra/gpu/buffers/buffers-docs.factor

@@ -149,6 +149,10 @@ HELP: dynamic-upload
 HELP: gpu-data-ptr
 { $class-description "This class is a union of the " { $link c-ptr } " and " { $link buffer-ptr } " classes. It represents a value that can be supplied either from CPU or GPU memory." } ;
 
+HELP: grow-buffer
+{ $values { "buffer" buffer } { "target-size" integer } }
+{ $description "If the " { $link buffer-size } " of the given " { $link buffer } " is less than " { $snippet "target-size" } ", reallocates the buffer to a size large enough to accommodate " { $snippet "target-size" } " bytes. If the buffer is reallocated, the original contents are lost." } ;
+
 HELP: index-buffer
 { $class-description "This " { $link buffer-kind } " declares that a " { $link buffer } "'s primary use will be to index vertex arrays." } ;
 
@@ -243,6 +247,7 @@ ARTICLE: "gpu.buffers" "Buffer objects"
 { $subsections
     allocate-buffer
     allocate-byte-array
+    grow-buffer
     update-buffer
     read-buffer
     copy-buffer

extra/gpu/buffers/buffers.factor

@@ -132,6 +132,13 @@ TYPED:: copy-buffer ( to-buffer-ptr: buffer-ptr from-buffer-ptr: buffer-ptr size
     from-buffer-ptr offset>> to-buffer-ptr offset>>
     size glCopyBufferSubData ;
 
+: (grow-buffer-size) ( target-size old-size -- new-size )
+    [ 2dup > ] [ 2 * ] while nip ; inline
+
+TYPED: grow-buffer ( buffer: buffer target-size: integer -- )
+    over buffer-size 2dup >
+    [ (grow-buffer-size) f allocate-buffer ] [ 3drop ] if ; inline
+
 :: with-mapped-buffer ( ..a buffer access quot: ( ..a alien -- ..b ) -- ..b )
     buffer bind-buffer :> target
     target access gl-access glMapBuffer

extra/key-logger/authors.txt

@@ -0,0 +1 @@
+Doug Coleman

extra/key-logger/deploy.factor

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

extra/key-logger/key-logger.factor

@@ -0,0 +1,35 @@
+! Copyright (C) 2010 Doug Coleman.
+! See http://factorcode.org/license.txt for BSD license.
+USING: accessors alarms bit-arrays calendar game.input io
+io.binary io.encodings.binary io.files kernel literals math
+namespaces system threads ;
+IN: key-logger
+
+CONSTANT: frequency $[ 1/30 seconds ]
+
+CONSTANT: path "resource:key-log.txt"
+
+: update-key-caps-state ( -- )
+    read-keyboard keys>>
+    path binary [
+        [ gmt unix-1970 time- duration>nanoseconds >integer ]
+        [ bit-array>integer ] bi*
+        [ 8 >be write ] bi@ flush
+    ] with-file-appender ;
+
+SYMBOL: key-logger
+
+: start-key-logger ( -- )
+    key-logger get-global [
+        [
+            open-game-input
+            [ update-key-caps-state ] frequency every key-logger set-global
+        ] in-thread
+    ] unless ;
+
+: stop-key-logger ( -- )
+    key-logger get-global [ stop-alarm ] when*
+    f key-logger set-global
+    close-game-input ;
+
+MAIN: start-key-logger

extra/mason/updates/updates.factor

@@ -1,4 +1,4 @@
-! Copyright (C) 2008 Eduardo Cavazos, Slava Pestov.
+! Copyright (C) 2008, 2010 Eduardo Cavazos, Slava Pestov.
 ! See http://factorcode.org/license.txt for BSD license.
 USING: kernel io.launcher bootstrap.image.download
 mason.common mason.platform ;
@@ -20,8 +20,7 @@ IN: mason.updates
     = not ;
 
 : new-image-available? ( -- ? )
-    boot-image-name need-new-image?
+    boot-image-name maybe-download-image ;
-    [ boot-image-arch download-image t ] [ f ] if ;
 
 : new-code-available? ( -- ? )
     updates-available?

extra/mongodb/benchmark/benchmark.factor

@@ -247,7 +247,8 @@ CONSTANT: DOC-LARGE H{ { "base_url" "http://www.example.com/test-me" }
 : [bench-quot] ( feat-seq op-word -- quot: ( doc-word -- ) )
     '[ _ swap _
        '[ [ [ _ execute( -- quot ) ] dip
-          [ execute( -- ) ] each _ execute( quot -- quot ) gc benchmark ] with-result ] each
+          [ execute( -- ) ] each _ execute( quot -- quot ) gc
+            benchmark ] with-result ] each
        print-separator ] ; 
 
 : run-serialization-bench ( doc-word-seq feat-seq -- )
@@ -282,7 +283,7 @@ CONSTANT: DOC-LARGE H{ { "base_url" "http://www.example.com/test-me" }
 
     
 : run-benchmarks ( -- )
-    "db" "db" get* "host" "127.0.0.1" get* "port" 27020 get* ensure-number <mdb>
+    "db" "db" get* "host" "127.0.0.1" get* "port" 27017 get* ensure-number <mdb>
     [ print-header
       ! serialization
       { small-doc-prepare medium-doc-prepare

extra/mongodb/cmd/cmd.factor

@@ -0,0 +1,132 @@
+USING: accessors assocs hashtables kernel linked-assocs strings ;
+IN: mongodb.cmd
+
+<PRIVATE
+
+TUPLE: mongodb-cmd 
+    { name string }
+    { const? boolean }
+    { admin? boolean }
+    { auth? boolean }
+    { assoc assoc }
+    { norep? boolean } ;
+
+PRIVATE>
+
+CONSTANT: buildinfo-cmd 
+    T{ mongodb-cmd f "buildinfo" t t f H{ { "buildinfo" 1 } } }
+
+CONSTANT: list-databases-cmd
+    T{ mongodb-cmd f "listDatabases" t t f H{ { "listDatabases" 1 } } }
+
+! Options: { "async" t }
+CONSTANT: fsync-cmd
+    T{ mongodb-cmd f "fsync" f t f H{ { "fsync" 1 } } }
+
+! Value: { "clone" from_host }
+CONSTANT: clone-db-cmd
+    T{ mongodb-cmd f "clone" f f t H{ { "clone" f } } }
+
+! Options { { "fromdb" db } { "todb" db } { fromhost host } }
+CONSTANT: copy-db-cmd
+    T{ mongodb-cmd f "copydb" f f f H{ { "copydb" 1 } } }
+
+CONSTANT: shutdown-cmd
+    T{ mongodb-cmd f "shutdown" t t t H{ { "shutdown" 1 } } t }
+
+CONSTANT: reseterror-cmd
+    T{ mongodb-cmd f "reseterror" t f f H{ { "reseterror" 1 } } }
+
+CONSTANT: getlasterror-cmd
+    T{ mongodb-cmd f "getlasterror" t f f H{ { "getlasterror" 1 } } }
+
+CONSTANT: getpreverror-cmd
+    T{ mongodb-cmd f "getpreverror" t f f H{ { "getpreverror" 1 } } }
+
+CONSTANT: forceerror-cmd
+    T{ mongodb-cmd f "forceerror" t f f H{ { "forceerror" 1 } } }
+
+CONSTANT: drop-db-cmd
+    T{ mongodb-cmd f "dropDatabase" t f f H{ { "dropDatabase" 1 } } }
+
+! Options { { "preserveClonedFilesOnFailure" t/f } { "backupOriginalFiles" t/f } }
+CONSTANT: repair-db-cmd
+    T{ mongodb-cmd f "repairDatabase" f f f H{ { "repairDatabase" 1 } } }
+
+! Options: -1 gets the current profile level; 0-2 set the profile level
+CONSTANT: profile-cmd 
+    T{ mongodb-cmd f "profile" f f f H{ { "profile" 0 } } }
+
+CONSTANT: server-status-cmd
+    T{ mongodb-cmd f "serverStatus" t f f H{ { "serverStatus" 1 } } }
+
+CONSTANT: assertinfo-cmd
+    T{ mongodb-cmd f "assertinfo" t f f H{ { "assertinfo" 1 } } }
+
+CONSTANT: getoptime-cmd
+    T{ mongodb-cmd f "getoptime" t f f H{ { "getoptime" 1 } } }
+
+CONSTANT: oplog-cmd
+    T{ mongodb-cmd f "opLogging" t f f H{ { "opLogging" 1 } } }
+
+! Value: { "deleteIndexes" collection-name }
+! Options: { "index" index_name or "*" }
+CONSTANT: delete-index-cmd
+    T{ mongodb-cmd f "deleteIndexes" f f f H{ { "deleteIndexes" f } } }
+
+! Value: { "create" collection-name }
+! Options: { { "capped" t } { "size" size_in_bytes } { "max" max_number_of_objects } { "autoIndexId" t/f } }
+CONSTANT: create-cmd
+    T{ mongodb-cmd f "drop" f f f H{ { "create" f } } }
+
+! Value { "drop" collection-name }
+CONSTANT: drop-cmd
+    T{ mongodb-cmd f "drop" f f f H{ { "drop" f } } }
+
+! Value { "count" collection-name }
+! Options: { "query" query-object }
+CONSTANT: count-cmd
+    T{ mongodb-cmd f "count" f f f H{ { "count" f } } }
+
+! Value { "validate" collection-name }
+CONSTANT: validate-cmd
+    T{ mongodb-cmd f "validate" f f f H{ { "validate" f } } }
+
+! Value { "collstats" collection-name }
+CONSTANT: collstats-cmd
+    T{ mongodb-cmd f "collstats" f f f H{ { "collstats" f } } }
+
+! Value: { "distinct" collection-name }
+! Options: { "key" key-name }
+CONSTANT: distinct-cmd
+    T{ mongodb-cmd f "distinct" f f f H{ { "distinct" f } } }
+
+! Value: { "filemd5" oid }
+! Options: { "root" bucket-name }
+CONSTANT: filemd5-cmd
+    T{ mongodb-cmd f "filemd5" f f f H{ { "filemd5" f } } }
+
+CONSTANT: getnonce-cmd
+    T{ mongodb-cmd f "getnonce" t f f H{ { "getnonce" 1 } } }
+
+! Options: { { "user" username } { "nonce" nonce } { "key" digest } }
+CONSTANT: authenticate-cmd
+    T{ mongodb-cmd f "authenticate" f f f H{ { "authenticate" 1 } } }
+
+CONSTANT: logout-cmd
+    T{ mongodb-cmd f "logout" t f f H{ { "logout" 1 } } }
+
+! Value: { "findandmodify" collection-name }
+! Options: { { "query" selector } { "sort" sort-spec } 
+!            { "remove" t/f } { "update" modified-object } 
+!            { "new" t/f } }
+CONSTANT: findandmodify-cmd
+    T{ mongodb-cmd f "findandmodify" f f f H{ { "findandmodify" f } } }
+
+: make-cmd ( cmd-stub -- cmd-assoc )
+    dup const?>> [  ] [  
+        clone [ clone <linked-assoc> ] change-assoc
+    ] if ; inline
+
+: set-cmd-opt ( cmd value key -- cmd )
+    pick assoc>> set-at ; inline

extra/mongodb/connection/connection.factor

@@ -1,9 +1,9 @@
-USING: accessors assocs fry io.encodings.binary io.sockets kernel math
+USING: accessors arrays assocs byte-vectors checksums
-math.parser mongodb.msg mongodb.operations namespaces destructors
+checksums.md5 constructors destructors fry hashtables
-constructors sequences splitting checksums checksums.md5 
+io.encodings.binary io.encodings.string io.encodings.utf8
-io.streams.duplex io.encodings.utf8 io.encodings.string combinators.smart
+io.sockets io.streams.duplex kernel locals math math.parser
-arrays hashtables sequences.deep vectors locals ;
+mongodb.cmd mongodb.msg namespaces sequences
-
+splitting ;
 IN: mongodb.connection
 
 : md5-checksum ( string -- digest )
@@ -15,13 +15,18 @@ TUPLE: mdb-node master? { address inet } remote ;
 
 CONSTRUCTOR: mdb-node ( address master? -- mdb-node ) ;
 
-TUPLE: mdb-connection instance node handle remote local ;
+TUPLE: mdb-connection instance node handle remote local buffer ;
+
+: connection-buffer ( -- buffer )
+    mdb-connection get buffer>> 0 >>length ; inline
+
+USE: mongodb.operations
 
 CONSTRUCTOR: mdb-connection ( instance -- mdb-connection ) ;
 
 : check-ok ( result -- errmsg ? )
     [ [ "errmsg" ] dip at ] 
-    [ [ "ok" ] dip at >integer 1 = ] bi ; inline 
+    [ [ "ok" ] dip at ] bi ; inline 
 
 : <mdb-db> ( name nodes -- mdb-db )
     mdb-db new swap >>nodes swap >>name H{ } clone >>collections ;
@@ -33,7 +38,7 @@ CONSTRUCTOR: mdb-connection ( instance -- mdb-connection ) ;
     nodes>> f swap at ;
 
 : with-connection ( connection quot -- * )
-    [ mdb-connection set ] prepose with-scope ; inline
+    [ mdb-connection ] dip with-variable ; inline
     
 : mdb-instance ( -- mdb )
     mdb-connection get instance>> ; inline
@@ -44,8 +49,9 @@ CONSTRUCTOR: mdb-connection ( instance -- mdb-connection ) ;
 : namespaces-collection ( -- ns )
     mdb-instance name>> "system.namespaces" "." glue ; inline
 
-: cmd-collection ( -- ns )
+: cmd-collection ( cmd -- ns )
-    mdb-instance name>> "$cmd" "." glue ; inline
+    admin?>> [ "admin"  ] [ mdb-instance name>> ] if
+    "$cmd" "." glue ; inline
 
 : index-ns ( colname -- index-ns )
     [ mdb-instance name>> ] dip "." glue ; inline
@@ -58,15 +64,16 @@ CONSTRUCTOR: mdb-connection ( instance -- mdb-connection ) ;
     '[ _ write-message read-message ] with-stream* ;
 
 : send-query-1result ( collection assoc -- result )
-    <mdb-query-msg>
+    <mdb-query-msg> -1 >>return# send-query-plain
-        1 >>return#
+    objects>> [ f ] [ first ] if-empty ;
-    send-query-plain objects>>
+
-    [ f ] [ first ] if-empty ;
+: send-cmd ( cmd -- result )
+    [ cmd-collection ] [ assoc>> ] bi send-query-1result ; inline
 
 <PRIVATE
 
 : get-nonce ( -- nonce )
-    cmd-collection H{ { "getnonce" 1 } } send-query-1result 
+    getnonce-cmd make-cmd send-cmd
     [ "nonce" swap at ] [ f ] if* ;
 
 : auth? ( mdb -- ? )
@@ -78,16 +85,14 @@ CONSTRUCTOR: mdb-connection ( instance -- mdb-connection ) ;
     [ pwd-digest>> ] bi
     3array concat md5-checksum ; inline
 
-: build-auth-query ( -- query-assoc )
+: build-auth-cmd ( cmd -- cmd )
-    { "authenticate" 1 }
+    mdb-instance username>> "user" set-cmd-opt
-    "user"  mdb-instance username>> 2array
+    get-nonce [ "nonce" set-cmd-opt ] [ ] bi
-    "nonce" get-nonce 2array
+    calculate-key-digest "key" set-cmd-opt ; inline
-    3array >hashtable
-    [ [ "nonce" ] dip at calculate-key-digest "key" ] keep
-    [ set-at ] keep ; 
     
 : perform-authentication ( --  )
-    cmd-collection build-auth-query send-query-1result
+    authenticate-cmd make-cmd
+    build-auth-cmd send-cmd
     check-ok [ drop ] [ throw ] if ; inline
 
 : authenticate-connection ( mdb-connection -- )
@@ -98,7 +103,7 @@ CONSTRUCTOR: mdb-connection ( instance -- mdb-connection ) ;
 : open-connection ( mdb-connection node -- mdb-connection )
    [ >>node ] [ address>> ] bi
    [ >>remote ] keep binary <client>
-   [ >>handle ] dip >>local ;
+   [ >>handle ] dip >>local 4096 <byte-vector> >>buffer ;
 
 : get-ismaster ( -- result )
     "admin.$cmd" H{ { "ismaster" 1 } } send-query-1result ; 

extra/mongodb/driver/driver.factor

@@ -1,10 +1,10 @@
 USING: accessors arrays assocs bson.constants combinators
-combinators.smart constructors destructors formatting fry hashtables
+combinators.smart constructors destructors fry hashtables io
-io io.pools io.sockets kernel linked-assocs math mongodb.connection
+io.pools io.sockets kernel linked-assocs locals math
-mongodb.msg parser prettyprint prettyprint.custom prettyprint.sections
+mongodb.cmd mongodb.connection mongodb.msg namespaces parser
-sequences sets splitting strings
+prettyprint prettyprint.custom prettyprint.sections sequences
-tools.continuations uuid memoize locals ;
+sets splitting strings ;
-
+FROM: ascii => ascii? ;
 IN: mongodb.driver
 
 TUPLE: mdb-pool < pool mdb ;
@@ -13,9 +13,9 @@ TUPLE: mdb-cursor id query ;
 
 TUPLE: mdb-collection
 { name string }
-{ capped boolean initial: f }
+{ capped boolean }
-{ size integer initial: -1 }
+{ size integer }
-{ max integer initial: -1 } ;
+{ max integer } ;
 
 CONSTRUCTOR: mdb-collection ( name -- collection ) ;
 
@@ -84,23 +84,23 @@ M: mdb-getmore-msg verify-query-result
     [ make-cursor ] 2tri
     swap objects>> ;
 
-: make-collection-assoc ( collection assoc -- )
-    [ [ name>> "create" ] dip set-at ]
-    [ [ [ capped>> ] keep ] dip
-      '[ _ _
-         [ [ drop t "capped" ] dip set-at ]
-         [ [ size>> "size" ] dip set-at ]
-         [ [ max>> "max" ] dip set-at ] 2tri ] when
-    ] 2bi ; 
 
 PRIVATE>
 
 SYNTAX: r/ ( token -- mdbregexp )
     \ / [ >mdbregexp ] parse-literal ; 
 
-: with-db ( mdb quot -- * )
+: with-db ( mdb quot -- )
     '[ _ mdb-open &dispose _ with-connection ] with-destructors ; inline
 
+: with-mdb ( mdb quot -- )
+    [ <mdb-pool> ] dip
+    [ mdb-pool swap with-variable ] curry with-disposal ; inline
+
+: with-mdb-connection ( quot -- )
+    [ mdb-pool get ] dip 
+    '[ _ with-connection ] with-pooled-connection ; inline
+
 : >id-selector ( assoc -- selector )
     [ MDB_OID_FIELD swap at ] keep
     H{ } clone [ set-at ] keep ;
@@ -115,11 +115,16 @@ GENERIC: create-collection ( name/collection -- )
 M: string create-collection
     <mdb-collection> create-collection ;
 
-M: mdb-collection create-collection
+M: mdb-collection create-collection ( collection -- )
-    [ [ cmd-collection ] dip
+    create-cmd make-cmd over
-      <linked-hash> [ make-collection-assoc ] keep
+    {
-      <mdb-query-msg> 1 >>return# send-query-plain drop ] keep
+        [ name>> "create" set-cmd-opt ]
-      [ ] [ name>> ] bi mdb-instance collections>> set-at ;
+        [ capped>> [ "capped" set-cmd-opt ] when* ]
+        [ max>> [ "max" set-cmd-opt ] when* ]
+        [ size>> [ "size" set-cmd-opt ] when* ]
+    } cleave send-cmd check-ok
+    [ drop [ ] [ name>> ] bi mdb-instance collections>> set-at ]
+    [ throw ] if ;
   
 : load-collection-list ( -- collection-list )
     namespaces-collection
@@ -128,8 +133,12 @@ M: mdb-collection create-collection
 <PRIVATE
 
 : ensure-valid-collection-name ( collection -- )
+    [
         [ ";$." intersect length 0 > ] keep
-    '[ _ "contains invalid characters ( . $ ; )" "." glue throw ] when ; inline
+        '[ _ "contains invalid characters ( . $ ; )" ":" glue throw ] when
+    ] [
+        [ ascii? ] all? [ "collection names must only contain ascii characters" throw ] unless
+    ] bi ; inline
 
 : build-collection-map ( -- assoc )
     H{ } clone load-collection-list      
@@ -215,21 +224,21 @@ M: mdb-cursor find
     dup empty? [ drop f ] [ first ] if ;
 
 : count ( mdb-query-msg -- result )
-    [ collection>> "count" H{ } clone [ set-at ] keep ] keep
+    [ count-cmd make-cmd ] dip
-    query>> [ over [ "query" ] dip set-at ] when*
+    [ collection>> "count" set-cmd-opt ]
-    [ cmd-collection ] dip <mdb-query-msg> find-one 
+    [ query>> "query" set-cmd-opt ] bi send-cmd 
     [ check-ok nip ] keep '[ "n" _ at >fixnum ] [ f ] if ;
 
 : lasterror ( -- error )
-    cmd-collection H{ { "getlasterror" 1 } } <mdb-query-msg>
+    getlasterror-cmd make-cmd send-cmd
-    find-one [ "err" ] dip at ;
+    [ "err" ] dip at ;
 
 GENERIC: validate. ( collection -- )
 
 M: string validate.
-    [ cmd-collection ] dip
+    [ validate-cmd make-cmd ] dip
-    "validate" H{ } clone [ set-at ] keep
+    "validate" set-cmd-opt send-cmd
-    <mdb-query-msg> find-one [ check-ok nip ] keep
+    [ check-ok nip ] keep
     '[ "result" _ at print ] [  ] if ;
 
 M: mdb-collection validate.
@@ -251,7 +260,7 @@ PRIVATE>
     <mdb-insert-msg> send-message ;
 
 : ensure-index ( index-spec -- )
-    <linked-hash> [ [ uuid1 "_id" ] dip set-at ] keep
+    <linked-hash> [ [ <oid> "_id" ] dip set-at ] keep
     [ { [ [ name>> "name" ] dip set-at ]
         [ [ ns>> index-ns "ns" ] dip set-at ]
         [ [ key>> "key" ] dip set-at ]
@@ -261,11 +270,9 @@ PRIVATE>
     [ index-collection ] dip save ;
 
 : drop-index ( collection name -- )
-    H{ } clone
+    [ delete-index-cmd make-cmd ] 2dip
-    [ [ "index" ] dip set-at ] keep
+    [ "deleteIndexes" set-cmd-opt ]
-    [ [ "deleteIndexes" ] dip set-at ] keep
+    [ "index" set-cmd-opt ] bi* send-cmd drop ;
-    [ cmd-collection ] dip <mdb-query-msg>
-    find-one drop ;
 
 : <update> ( collection selector object -- mdb-update-msg )
     [ check-collection ] 2dip <mdb-update-msg> ;
@@ -279,6 +286,15 @@ PRIVATE>
 : update-unsafe ( mdb-update-msg -- )
     send-message ;
 
+: find-and-modify ( collection selector modifier -- mongodb-cmd )
+    [ findandmodify-cmd make-cmd ] 3dip
+    [ "findandmodify" set-cmd-opt ]
+    [ "query" set-cmd-opt ]
+    [ "update" set-cmd-opt ] tri* ; inline
+
+: run-cmd ( cmd -- result )
+    send-cmd ; inline
+
 : delete ( collection selector -- )
     [ check-collection ] dip
     <mdb-delete-msg> send-message-check-error ;
@@ -298,8 +314,7 @@ PRIVATE>
     check-collection drop ;
 
 : drop-collection ( name -- )
-    [ cmd-collection ] dip
+    [ drop-cmd make-cmd ] dip
-    "drop" H{ } clone [ set-at ] keep
+    "drop" set-cmd-opt send-cmd drop ;
-    <mdb-query-msg> find-one drop ;
 
 

extra/mongodb/gridfs/gridfs.factor

@@ -0,0 +1,285 @@
+USING: accessors arrays assocs base64 bson.constants
+byte-arrays byte-vectors calendar combinators
+combinators.short-circuit destructors formatting fry hashtables
+io kernel linked-assocs locals math math.parser mongodb.cmd
+mongodb.connection mongodb.driver mongodb.msg namespaces
+sequences splitting strings ;
+FROM: mongodb.driver => update ;
+IN: mongodb.gridfs
+
+CONSTANT: default-chunk-size 262144
+
+TUPLE: gridfs 
+    { bucket string } 
+    { files string }
+    { chunks string } ;
+
+
+<PRIVATE
+
+: gridfs> ( -- gridfs )
+    gridfs get ; inline
+
+: files-collection ( -- str ) gridfs> files>> ; inline
+: chunks-collection ( -- str ) gridfs> chunks>> ; inline
+
+
+: init-gridfs ( gridfs -- )
+    chunks>> "ChunkIdx" H{ { "files_id" 1 } { "n" 1 } } 
+    <index-spec> ensure-index ; inline
+
+PRIVATE>
+
+: <gridfs> ( bucket -- gridfs )
+    [  ] 
+    [ "files" "%s.%s" sprintf  ] 
+    [ "chunks" "%s.%s" sprintf ] tri
+    gridfs boa [ init-gridfs ] keep ;
+
+: with-gridfs ( gridfs quot -- * )
+    [ gridfs ] dip with-variable ; inline
+
+TUPLE: entry 
+    { id oid }
+    { filename string }
+    { content-type string }
+    { length integer }
+    { chunk-size integer }
+    { created timestamp }
+    { aliases array }
+    { metadata hashtable }
+    { md5 string } ;
+
+<PRIVATE
+
+: id>base64 ( id -- str )
+    [ a>> >hex ] [ b>> >hex ] bi 
+    2array "#" join >base64 >string ; inline
+
+: base64>id ( str -- objid )
+    base64> >string "#" split 
+    [ first ] [ second ] bi 
+    [ hex> ] bi@ oid boa ; inline
+    
+PRIVATE>
+
+: <entry> ( name content-type -- entry )
+    entry new 
+    swap >>content-type swap >>filename 
+    <oid> >>id 0 >>length default-chunk-size >>chunk-size 
+    now >>created ; inline
+
+<PRIVATE 
+
+TUPLE: chunk 
+    { id oid }
+    { fileid oid }
+    { n integer }
+    { data byte-array } ;
+
+: at> ( assoc key -- value/f )
+    swap at ; inline
+
+:: >set-at ( assoc value key -- )
+    value key assoc set-at ; inline
+
+: (update-file) ( entry assoc -- entry )
+    { 
+        [ "_id" at> >>id ]
+        [ "filename" at> >>filename ]
+        [ "contentType" at> >>content-type ]
+        [ "length" at> >>length ]
+        [ "chunkSize" at> >>chunk-size ]
+        [ "uploadDate" at> >>created ]
+        [ "aliases" at> >>aliases ]
+        [ "metadata" at> >>metadata ]
+        [ "md5" at> >>md5 ]
+    } cleave ; inline
+
+: assoc>chunk ( assoc -- chunk )
+    [ chunk new ] dip
+    {  
+        [ "_id" at> >>id ]
+        [ "files_id" at> >>fileid ]
+        [ "n" at> >>n ]
+        [ "data" at> >>data ]
+    } cleave ;
+
+: assoc>entry ( assoc -- entry )
+    [ entry new ] dip (update-file) ;
+    
+: entry>assoc ( entry -- assoc )
+    [ H{  } clone ] dip
+    {
+        [ id>> "_id" >set-at ]
+        [ filename>> "filename" >set-at ]
+        [ content-type>> "contentType" >set-at ]
+        [ length>> "length" >set-at ]
+        [ chunk-size>> "chunkSize" >set-at ]
+        [ created>> "uploadDate" >set-at ]
+        [ aliases>> "aliases" >set-at ]
+        [ metadata>> "metadata" >set-at ]
+        [ md5>> "md5" >set-at ]
+        [ drop ]
+    } 2cleave ; inline
+
+: create-entry ( entry -- entry )
+    [ [ files-collection ] dip entry>assoc save ] [ ] bi ;
+
+TUPLE: state bytes count ;
+
+: <state> ( -- state )
+    0 0 state boa ; inline
+
+: get-state ( -- n )
+    state get ; inline
+
+: with-state ( quot -- state )
+    [ <state> state ] dip 
+    [ get-state ] compose 
+    with-variable ; inline
+
+: update-state ( bytes -- )
+    [ get-state ] dip
+    '[ _ + ] change-bytes 
+    [ 1 + ] change-count drop ; inline
+
+:: store-chunk ( chunk entry n -- ) 
+    entry id>> :> id
+    H{ { "files_id" id }
+       { "n" n } { "data" chunk } }
+    [ chunks-collection ] dip save ; inline
+
+:: write-chunks ( stream entry -- length )
+    entry chunk-size>> :> chunk-size
+    [
+        [ 
+            chunk-size stream stream-read dup [
+                [ entry get-state count>> store-chunk ]
+                [ length update-state ] bi 
+            ] when*
+        ] loop
+    ] with-state bytes>> ;
+
+: (entry-selector) ( entry -- selector )
+    id>> "_id" associate ; inline
+
+:: file-md5 ( id -- md5-str )
+    filemd5-cmd make-cmd
+    id "filemd5" set-cmd-opt
+    gridfs> bucket>> "root" set-cmd-opt
+    send-cmd "md5" at> ; inline
+
+: update-entry ( bytes entry -- entry )
+    [ swap >>length dup id>> file-md5 >>md5  ]
+    [ nip [ (entry-selector) ] [  ] bi
+        [ length>> "length" associate "$set" associate 
+          [ files-collection ] 2dip <update> update ]
+        [ md5>> "md5" associate "$set" associate 
+          [ files-collection ] 2dip <update> update ] 2bi 
+    ] 2bi ;
+
+TUPLE: gridfs-input-stream entry chunk n offset cpos ;
+
+: <gridfs-input-stream> ( entry -- stream )
+    [ gridfs-input-stream new ] dip
+    >>entry 0 >>offset 0 >>cpos -1 >>n ;
+
+PRIVATE>
+
+: write-entry ( input-stream entry -- entry )
+    create-entry [ write-chunks ] keep update-entry  ;
+
+: get-entry ( id -- entry )
+    [ files-collection ] dip
+    "_id" associate <query> find-one assoc>entry ;
+
+: open-entry ( entry -- input-stream )
+    <gridfs-input-stream> ;
+
+: entry-contents ( entry -- bytearray )
+    <gridfs-input-stream> stream-contents ;
+
+<PRIVATE
+
+: load-chunk ( stream -- chunk/f )
+    [ entry>> id>> "files_id" associate ]
+    [ n>> "n" associate ] bi assoc-union
+    [ chunks-collection ] dip 
+    <query> find-one dup [ assoc>chunk ] when ;
+
+: exhausted? ( stream -- boolean )
+    [ offset>> ] [ entry>> length>> ] bi = ; inline
+
+: fresh? ( stream -- boolean )
+    [ offset>> 0 = ] [ chunk>> f = ] bi and ; inline
+
+: data-available ( stream -- int/f )
+    [ cpos>> ] [ chunk>> data>> length ] bi 
+    2dup < [ swap - ] [ 2drop f ] if ; inline
+
+: next-chunk ( stream -- available chunk/f )
+    0 >>cpos [ 1 + ] change-n
+    [  ] [ load-chunk ] bi >>chunk
+    [ data-available ] [ chunk>> ] bi ; inline
+
+: ?chunk ( stream -- available chunk/f )
+    dup fresh? [ next-chunk ] [ 
+        dup exhausted? [ drop 0 f ] [  
+            dup data-available [ swap chunk>> ] [ next-chunk ] if*
+        ] if
+    ] if ; inline
+
+: set-stream ( n stream -- )
+    swap { 
+        [ >>offset drop ]
+        [ over entry>> chunk-size>> /mod [ >>n ] [ >>cpos ] bi* drop ]
+        [ drop dup load-chunk >>chunk drop ]
+    } 2cleave ; inline
+
+:: advance-stream ( n stream -- )
+    stream [ n + ] change-cpos [ n + ] change-offset drop ; inline
+
+: read-part ( n stream chunk -- seq/f )
+    [ [ cpos>> swap [ drop ] [ + ] 2bi ] [ data>> ] bi* <slice> ]
+    [ drop advance-stream ] 3bi ; inline
+
+:: (stream-read-partial) ( n stream -- seq/f )
+    stream ?chunk :> chunk :> available
+    chunk [
+        n available < 
+        [ n ] [ available ] if 
+        stream chunk read-part 
+    ] [ f ] if ; inline
+
+:: (stream-read) ( n stream acc -- )
+    n stream (stream-read-partial)
+    {
+        { [ dup not ] [ drop ] }
+        { [ dup length n = ] [ acc push-all ] }
+        { [ dup length n < ] [
+            [ acc push-all ] [ length ] bi
+            n swap - stream acc (stream-read) ]
+        }
+    } cond ; inline recursive 
+
+PRIVATE>
+
+M: gridfs-input-stream stream-element-type drop +byte+ ;
+
+M: gridfs-input-stream stream-read ( n stream -- seq/f )
+    over <byte-vector> [ (stream-read) ] [ ] bi
+    dup empty? [ drop f ] [ >byte-array ] if ;
+
+M: gridfs-input-stream stream-read-partial ( n stream -- seq/f )
+    (stream-read-partial) ;
+
+M: gridfs-input-stream stream-tell ( stream -- n ) 
+    offset>> ;
+
+M: gridfs-input-stream stream-seek ( n seek-type stream -- )
+    swap seek-absolute = 
+    [ set-stream ] 
+    [ "seek-type not supported" throw ] if ;
+
+M: gridfs-input-stream dispose drop ;

extra/mongodb/mongodb-docs.factor

@@ -9,7 +9,7 @@ ARTICLE: "mongodb" "MongoDB factor integration"
   "USING: mongodb.driver ;"
   "\"db\" \"127.0.0.1\" 27017 <mdb>"
   "[ \"mycollection\" [ H{ { \"name\" \"Alfred\" } { \"age\" 57 } } save ] "
-  "                 [ ageIdx [ \"age\" asc ] key-spec <index-spec> ensure-index ]"
+  "                 [ \"ageIdx\" [ \"age\" asc ] key-spec <index-spec> ensure-index ]"
   "                 [ H{ { \"age\" H{ { \"$gt\" 50 } } } } <query> find-one ] tri ] with-db "
   "" }
 { $heading "Highlevel tuple integration" }

extra/mongodb/operations/operations.factor

@@ -1,11 +1,15 @@
 USING: accessors assocs bson.reader bson.writer byte-arrays
-byte-vectors combinators formatting fry io io.binary
+byte-vectors combinators formatting fry io io.binary io.encodings.private
-io.encodings.private io.encodings.binary io.encodings.string
+io.encodings.binary io.encodings.string io.encodings.utf8 io.encodings.utf8.private io.files
-io.encodings.utf8 io.encodings.utf8.private io.files kernel
+kernel locals math mongodb.msg namespaces sequences uuid bson.writer.private ;
-locals math mongodb.msg namespaces sequences uuid
+
-bson.writer.private ;
+FROM: mongodb.connection => connection-buffer ;
+FROM: alien => byte-length ;
+
 IN: mongodb.operations
 
+M: byte-vector byte-length length ;
+
 <PRIVATE
 
 PREDICATE: mdb-reply-op < integer OP_Reply = ;
@@ -16,12 +20,6 @@ PREDICATE: mdb-delete-op < integer OP_Delete = ;
 PREDICATE: mdb-getmore-op < integer OP_GetMore = ;
 PREDICATE: mdb-killcursors-op < integer OP_KillCursors = ;
 
-PRIVATE>
-
-GENERIC: write-message ( message -- )
-
-<PRIVATE
-
 CONSTANT: MSG-HEADER-SIZE 16
 
 SYMBOL: msg-bytes-read 
@@ -40,34 +38,26 @@ SYMBOL: msg-bytes-read
 : read-byte-raw ( -- byte-raw ) 1 [ read le> ] [ change-bytes-read ] bi ; inline
 : read-byte ( -- byte ) read-byte-raw first ; inline
 
-: (read-cstring) ( acc -- )
-    [ read-byte ] dip ! b acc
-    2dup push             ! b acc
-    [ 0 = ] dip      ! bool acc
-    '[ _ (read-cstring) ] unless ; inline recursive
-
-: read-cstring ( -- string )
-    BV{ } clone
-    [ (read-cstring) ] keep
-    [ zero? ] trim-tail
-    >byte-array utf8 decode ; inline
-
-GENERIC: (read-message) ( message opcode -- message )
-
 : copy-header ( message msg-stub -- message )
-    [ length>> ] keep [ >>length ] dip
+    {
-    [ req-id>> ] keep [ >>req-id ] dip
+        [ length>> >>length ]
-    [ resp-id>> ] keep [ >>resp-id ] dip
+        [ req-id>> >>req-id ]
-    [ opcode>> ] keep [ >>opcode ] dip
+        [ resp-id>> >>resp-id ]
-    flags>> >>flags ;
+        [ opcode>> >>opcode ]
+        [ flags>> >>flags ]
+    } cleave ; inline
 
-M: mdb-reply-op (read-message) ( msg-stub opcode -- message )
+: reply-read-message ( msg-stub -- message )
-    drop
     [ <mdb-reply-msg> ] dip copy-header
     read-longlong >>cursor
     read-int32 >>start#
     read-int32 [ >>returned# ] keep
-    [ H{ } stream>assoc ] collector [ times ] dip >>objects ;    
+    [ H{ } clone stream>assoc ] collector [ times ] dip >>objects ;    
+
+: (read-message) ( message opcode -- message )
+    OP_Reply = 
+    [ reply-read-message ]
+    [ "unknown message type" throw ] if ; inline
 
 : read-header ( message -- message )
     read-int32 >>length
@@ -77,94 +67,97 @@ M: mdb-reply-op (read-message) ( msg-stub opcode -- message )
     read-int32 >>flags ; inline
 
 : write-header ( message -- )
-    [ req-id>> write-int32 ] keep
+    [ req-id>> write-int32 ]
-    [ resp-id>> write-int32 ] keep 
+    [ resp-id>> write-int32 ]
-    opcode>> write-int32 ; inline
+    [ opcode>> write-int32 ] tri ; inline
 
 PRIVATE>
 
 : read-message ( -- message )
-    mdb-msg new
+    [
-    0 >bytes-read
+        mdb-msg new 0 >bytes-read read-header
-    read-header
+        [ ] [ opcode>> ] bi (read-message)
-    [ ] [ opcode>> ] bi (read-message) ;
+    ] with-scope ;
 
 <PRIVATE
 
-USE: tools.walker
-
-: dump-to-file ( array -- )
-    [ uuid1 "/tmp/mfb/%s.dump" sprintf binary ] dip
-    '[ _ write ] with-file-writer ;
-
 : (write-message) ( message quot -- )
-    '[ [ [ _ write-header ] dip _ call ] with-length-prefix ] with-buffer
+    [ connection-buffer dup ] 2dip
-    ! [ dump-to-file ] keep
+    '[
-    write flush ; inline
+        [ _ [ write-header ] [ @ ] bi ] with-length-prefix
+    ] with-output-stream* write flush ; inline
 
 :: build-query-object ( query -- selector )
     H{ } clone :> selector
-    query { [ orderby>> [ "$orderby" selector set-at ] when* ]
+    query {
+        [ orderby>> [ "$orderby" selector set-at ] when* ]
         [ explain>> [ "$explain" selector set-at ] when* ]
         [ hint>> [ "$hint" selector set-at ] when* ]
         [ query>> "query" selector set-at ]
+    } cleave selector ; inline
+
+: write-query-message ( message -- )
+    [
+        {
+            [ flags>> write-int32 ]
+            [ collection>> write-cstring ]
+            [ skip#>> write-int32 ]
+            [ return#>> write-int32 ]
+            [ build-query-object assoc>stream ]
+            [ returnfields>> [ assoc>stream ] when* ]
         } cleave
-    selector ;
+    ] (write-message) ; inline
+
+: write-insert-message ( message -- )
+    [ 
+       [ flags>> write-int32 ]
+       [ collection>> write-cstring ]
+       [ objects>> [ assoc>stream ] each ] tri
+    ] (write-message) ; inline
+
+: write-update-message ( message -- )
+    [
+        { 
+            [ flags>> write-int32 ]
+            [ collection>> write-cstring ]
+            [ upsert?>> write-int32 ]
+            [ selector>> assoc>stream ]
+            [ object>> assoc>stream ]
+        } cleave
+    ] (write-message) ; inline
+
+: write-delete-message ( message -- )
+    [
+       [ flags>> write-int32 ]
+       [ collection>> write-cstring ]
+       [ 0 write-int32 selector>> assoc>stream ] tri
+    ] (write-message) ; inline
+
+: write-getmore-message ( message -- )
+    [
+        {
+           [ flags>> write-int32 ]
+           [ collection>> write-cstring ]
+           [ return#>> write-int32 ]
+           [ cursor>> write-longlong ]
+        } cleave
+    ] (write-message) ; inline
+
+: write-killcursors-message ( message -- )
+    [
+       [ flags>> write-int32 ]
+       [ cursors#>> write-int32 ]
+       [ cursors>> [ write-longlong ] each ] tri
+    ] (write-message) ; inline
 
 PRIVATE>
 
-M: mdb-query-msg write-message ( message -- )
+: write-message ( message -- )
-     dup
+    {  
-     '[ _ 
+        { [ dup mdb-query-msg? ] [ write-query-message ] }
-        [ flags>> write-int32 ] keep 
+        { [ dup mdb-insert-msg? ] [ write-insert-message ] }
-        [ collection>> write-cstring ] keep
+        { [ dup mdb-update-msg? ] [ write-update-message ] }
-        [ skip#>> write-int32 ] keep
+        { [ dup mdb-delete-msg? ] [ write-delete-message ] }
-        [ return#>> write-int32 ] keep
+        { [ dup mdb-getmore-msg? ] [ write-getmore-message ] }
-        [ build-query-object assoc>stream ] keep
+        { [ dup mdb-killcursors-msg? ] [ write-killcursors-message ] }
-        returnfields>> [ assoc>stream ] when* 
+    } cond ;
-     ] (write-message) ;
- 
-M: mdb-insert-msg write-message ( message -- )
-    dup
-    '[ _
-       [ flags>> write-int32 ] keep
-       [ collection>> write-cstring ] keep
-       objects>> [ assoc>stream ] each
-    ] (write-message) ;
-
-M: mdb-update-msg write-message ( message -- )
-    dup
-    '[ _
-       [ flags>> write-int32 ] keep
-       [ collection>> write-cstring ] keep
-       [ upsert?>> write-int32 ] keep
-       [ selector>> assoc>stream ] keep
-       object>> assoc>stream
-    ] (write-message) ;
-
-M: mdb-delete-msg write-message ( message -- )
-    dup
-    '[ _
-       [ flags>> write-int32 ] keep
-       [ collection>> write-cstring ] keep
-       0 write-int32
-       selector>> assoc>stream
-    ] (write-message) ;
-
-M: mdb-getmore-msg write-message ( message -- )
-    dup
-    '[ _
-       [ flags>> write-int32 ] keep
-       [ collection>> write-cstring ] keep
-       [ return#>> write-int32 ] keep
-       cursor>> write-longlong
-    ] (write-message) ;
-
-M: mdb-killcursors-msg write-message ( message -- )
-    dup
-    '[ _
-       [ flags>> write-int32 ] keep
-       [ cursors#>> write-int32 ] keep
-       cursors>> [ write-longlong ] each
-    ] (write-message) ;
-

extra/mongodb/tuple/persistent/persistent.factor

@@ -54,7 +54,7 @@ CONSTRUCTOR: cond-value ( value quot -- cond-value ) ;
    over [ call( tuple -- assoc ) ] dip 
    [ [ tuple-collection name>> ] [ >toid ] bi ] keep
    [ add-storable ] dip
-   [ tuple-collection name>> ] [ id>> ] bi <objref> ;
+   [ tuple-collection name>> ] [ id>> ] bi <dbref> ;
 
 : write-field ( value quot -- value' )
    <cond-value> {
@@ -78,9 +78,6 @@ CONSTRUCTOR: cond-value ( value quot -- cond-value ) ;
 : prepare-assoc ( tuple -- assoc mirror tuple assoc )
    H{ } clone swap [ <mirror> ] keep pick ; inline
 
-: ensure-mdb-info ( tuple -- tuple )    
-   dup id>> [ <objid> >>id ] unless ; inline
-
 : with-object-map ( quot: ( -- ) -- store-assoc )
    [ H{ } clone dup object-map ] dip with-variable ; inline
 
@@ -92,11 +89,14 @@ PRIVATE>
 
 GENERIC: tuple>storable ( tuple -- storable )
 
+: ensure-oid ( tuple -- tuple )
+   dup id>> [ <oid> >>id ] unless ; inline
+
 M: mdb-persistent tuple>storable ( mdb-persistent -- object-map )
    '[ _ [ tuple>assoc ] write-mdb-persistent drop ] with-object-map ; inline
 
 M: mdb-persistent tuple>assoc ( tuple -- assoc )
-   ensure-mdb-info (tuple>assoc) ;
+   ensure-oid (tuple>assoc) ;
 
 M: tuple tuple>assoc ( tuple -- assoc )
    (tuple>assoc) ;

extra/mongodb/tuple/tuple.factor

@@ -61,9 +61,9 @@ PRIVATE>
  
 : update-tuple ( tuple -- )
     [ tuple-collection name>> ]
-    [ id-selector ]
+    [ ensure-oid id-selector ]
     [ tuple>assoc ] tri
-    <update> update ;
+    <update> >upsert update ;
 
 : save-tuple ( tuple -- )
     update-tuple ;

extra/nehe/2/2.factor

@@ -1,5 +1,6 @@
 USING: arrays kernel math opengl opengl.gl opengl.glu
-opengl.demo-support ui ui.gadgets ui.render literals accessors ;
+opengl.demo-support ui ui.gadgets ui.render ui.pixel-formats
+literals accessors ;
 IN: nehe.2
 
 TUPLE: nehe2-gadget < gadget ;
@@ -39,5 +40,14 @@ M: nehe2-gadget draw-gadget* ( gadget -- )
         -1.0 -1.0 0.0 glVertex3f
     ] do-state ;
 
-MAIN-WINDOW: run2 { { title "NeHe Tutorial 2" } { pref-dim { $ width $ height } } }
+MAIN-WINDOW: run2
+    {
+        { title "NeHe Tutorial 2" }
+        { pref-dim { $ width $ height } }
+        { pixel-format-attributes {
+            windowed
+            double-buffered
+            T{ depth-bits { value 16 } }
+        } }
+    }
     <nehe2-gadget> >>gadgets ;

extra/nehe/4/4.factor

@@ -1,6 +1,6 @@
 USING: arrays kernel math opengl opengl.gl opengl.glu
-opengl.demo-support ui ui.gadgets ui.render threads accessors
+opengl.demo-support ui ui.gadgets ui.render ui.pixel-formats
-calendar literals ;
+threads accessors calendar literals ;
 IN: nehe.4
 
 TUPLE: nehe4-gadget < gadget rtri rquad thread quit? ;
@@ -68,5 +68,14 @@ M: nehe4-gadget graft* ( gadget -- )
 M: nehe4-gadget ungraft* ( gadget -- )
     t >>quit? drop ;
 
-MAIN-WINDOW: run4 { { title "NeHe Tutorial 4" } { pref-dim { $ width $ height } } }
+MAIN-WINDOW: run4
+    {
+        { title "NeHe Tutorial 4" }
+        { pref-dim { $ width $ height } }
+        { pixel-format-attributes {
+            windowed
+            double-buffered
+            T{ depth-bits { value 16 } }
+        } }
+    }
     <nehe4-gadget> >>gadgets ;

extra/nehe/5/5.factor

@@ -1,6 +1,6 @@
 USING: arrays kernel math opengl opengl.gl opengl.glu
-opengl.demo-support ui ui.gadgets ui.render threads accessors
+opengl.demo-support ui ui.gadgets ui.render ui.pixel-formats
-calendar literals ;
+threads accessors calendar literals ;
 IN: nehe.5
 
 TUPLE: nehe5-gadget < gadget rtri rquad thread quit? ;
@@ -120,5 +120,14 @@ M: nehe5-gadget graft* ( gadget -- )
 M: nehe5-gadget ungraft* ( gadget -- )
     t >>quit? drop ;
 
-MAIN-WINDOW: run5 { { title "NeHe Tutorial 5" } { pref-dim { $ width $ height } } }
+MAIN-WINDOW: run5
+    {
+        { title "NeHe Tutorial 5" }
+        { pref-dim { $ width $ height } }
+        { pixel-format-attributes {
+            windowed
+            double-buffered
+            T{ depth-bits { value 16 } }
+        } }
+    }
     <nehe5-gadget> >>gadgets ;