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

core/alien/alien-docs.factor

@@ -210,8 +210,9 @@ $nl
 ARTICLE: "alien-callback" "Calling Factor from C"
 "Callbacks can be defined and passed to C code as function pointers; the C code can then invoke the callback and run Factor code:"
 { $subsection alien-callback }
-"There are some details concerning the conversion of Factor objects to C values, and vice versa. See " { $link "c-data" } "."
+"There are some caveats concerning the conversion of Factor objects to C values, and vice versa. See " { $link "c-data" } "."
-{ $subsection "alien-callback-gc" } ;
+{ $subsection "alien-callback-gc" }
+{ $see-also "byte-arrays-gc" } ;
 
 ARTICLE: "dll.private" "DLL handles"
 "DLL handles are a built-in class of objects which represent loaded native libraries. DLL handles are instances of the " { $link dll } " class, and have a literal syntax used for debugging prinouts; see " { $link "syntax-aliens" } "."
@@ -290,7 +291,7 @@ $nl
 "The C library interface is entirely self-contained; there is no C code which one must write in order to wrap a library."
 $nl
 "C library interface words are found in the " { $vocab-link "alien" } " vocabulary."
-{ $warning "Since C does not retain runtime type information or do any kind of runtime type checking, any C library interface is not pointer safe. Improper use of C functions can crash the runtime or corrupt memory in unpredictible ways." }
+{ $warning "C does not perform runtime type checking, automatic memory management or array bounds checks. Incorrect usage of C library functions can lead to crashes, data corruption, and security exploits." }
 { $subsection "loading-libs" }
 { $subsection "alien-invoke" }
 { $subsection "alien-callback" }

core/alien/alien.factor

@@ -1,7 +1,8 @@
 ! Copyright (C) 2004, 2008 Slava Pestov.
 ! See http://factorcode.org/license.txt for BSD license.
 USING: assocs kernel math namespaces sequences system
-kernel.private tuples bit-arrays byte-arrays float-arrays ;
+kernel.private tuples bit-arrays byte-arrays float-arrays 
+arrays ;
 IN: alien
 
 ! Some predicate classes used by the compiler for optimization

core/alien/c-types/c-types-docs.factor

@@ -158,6 +158,19 @@ HELP: define-out
 { $description "Defines a word " { $snippet "<" { $emphasis "name" } ">" } " with stack effect " { $snippet "( value -- array )" } ". This word allocates a byte array large enough to hold a value with C type " { $snippet "name" } ", and writes the value at the top of the stack to the array." }
 { $notes "This is an internal word called when defining C types, there is no need to call it on your own." } ;
 
+ARTICLE: "byte-arrays-gc" "Byte arrays and the garbage collector"
+"The Factor garbage collector can move byte arrays around, and it is only safe to pass byte arrays to C functions if the garbage collector will not run while C code still has a reference to the data."
+$nl
+"In particular, a byte array can only be passed as a parameter if the the C function does not use the parameter after one of the following occurs:"
+{ $list
+    "the C function returns"
+    "the C function calls Factor code via a callback"
+}
+"Returning from C to Factor, as well as invoking Factor code via a callback, may trigger garbage collection, and if the function had stored a pointer to the byte array somewhere, this pointer may cease to be valid."
+$nl
+"If this condition is not satisfied, " { $link "malloc" } " must be used instead."
+{ $warning "Failure to comply with these requirements can lead to crashes, data corruption, and security exploits." } ;
+
 ARTICLE: "c-out-params" "Output parameters in C"
 "A frequently-occurring idiom in C code is the \"out parameter\". If a C function returns more than one value, the caller passes pointers of the correct type, and the C function writes its return values to those locations."
 $nl
@@ -229,13 +242,11 @@ $nl
 { $subsection <c-object> }
 { $subsection <c-array> }
 { $warning
-"The Factor garbage collector can move byte arrays around, and it is only safe to pass byte arrays to C functions if the function does not store a pointer to the byte array in some global structure, or retain it in any way after returning."
+"The Factor garbage collector can move byte arrays around, and code passing byte arrays to C must obey important guidelines. See " { $link "byte-arrays-gc" } "." }
-$nl
-"Long-lived data for use by C libraries can be allocated manually, just as when programming in C. See " { $link "malloc" } "." }
 { $see-also "c-arrays" } ;
 
 ARTICLE: "malloc" "Manual memory management"
-"Sometimes data passed to C functions must be allocated at a fixed address, and so garbage collector managed byte arrays cannot be used. See the warning at the bottom of " { $link "c-byte-arrays" } " for a description of when this is the case."
+"Sometimes data passed to C functions must be allocated at a fixed address. See " { $link "byte-arrays-gc" } " for an explanation of when this is the case."
 $nl
 "Allocating a C datum with a fixed address:"
 { $subsection malloc-object }
@@ -245,8 +256,6 @@ $nl
 { $subsection malloc }
 { $subsection calloc }
 { $subsection realloc }
-"The return value of the above three words must always be checked for a memory allocation failure:"
-{ $subsection check-ptr }
 "You must always free pointers returned by any of the above words when the block of memory is no longer in use:"
 { $subsection free }
 "You can unsafely copy a range of bytes from one memory location to another:"
@@ -271,20 +280,25 @@ ARTICLE: "c-strings" "C strings"
 { $subsection string>u16-alien }
 { $subsection malloc-char-string }
 { $subsection malloc-u16-string }
-"The first two allocate " { $link byte-array } "s, and the latter allocates manually-managed memory which is not moved by the garbage collector and has to be explicitly freed by calling " { $link free } "."
+"The first two allocate " { $link byte-array } "s, and the latter allocates manually-managed memory which is not moved by the garbage collector and has to be explicitly freed by calling " { $link free } ". See " { $link "byte-arrays-gc" } " for a discussion of the two approaches."
 $nl
 "Finally, a set of words can be used to read and write " { $snippet "char*" } " and " { $snippet "ushort*" } " strings at arbitrary addresses:"
 { $subsection alien>char-string }
-{ $subsection alien>u16-string } ;
+{ $subsection alien>u16-string }
+"For example, if a C function returns a " { $snippet "char*" } " but stipulates that the caller must deallocate the memory afterward, you must define the function as returning " { $snippet "void*" } ", and call one of the above words before passing the pointer to " { $link free } "." ;
 
 ARTICLE: "c-data" "Passing data between Factor and C"
-"Two defining characteristics of Factor are dynamic typing and automatic memory management, which are somewhat incompatible with the machine-level data model exposed by C. Factor's C library interface defines its own set of C data types, distinct from Factor language types, together with automatic conversion between Factor values and C types. For example, C integer types must be declared and are fixed-width, whereas Factor supports arbitrary-precision integers. Also Factor's garbage collector can move objects in memory, which means that special support has to be provided for passing blocks of memory to C code."
+"Two defining characteristics of Factor are dynamic typing and automatic memory management, which are somewhat incompatible with the machine-level data model exposed by C. Factor's C library interface defines its own set of C data types, distinct from Factor language types, together with automatic conversion between Factor values and C types. For example, C integer types must be declared and are fixed-width, whereas Factor supports arbitrary-precision integers."
+$nl
+"Furthermore, Factor's garbage collector can move objects in memory; for a discussion of the consequences, see " { $link "byte-arrays-gc" } "."
 { $subsection "c-types-specs" }
 { $subsection "c-byte-arrays" }
 { $subsection "malloc" }
 { $subsection "c-strings" }
 { $subsection "c-arrays" }
 { $subsection "c-out-params" }
+"Important guidelines for passing data in byte arrays:"
+{ $subsection "byte-arrays-gc" }
 "C-style enumerated types are supported:"
 { $subsection POSTPONE: C-ENUM: }
 "C types can be aliased for convenience and consitency with native library documentation:"

core/alien/compiler/compiler-tests.factor

@@ -330,11 +330,11 @@ FUNCTION: double ffi_test_36 ( test-struct-12 x ) ;
 
 ! Hack; if we're on ARM, we probably don't have much RAM, so
 ! skip this test.
-cpu "arm" = [
+! cpu "arm" = [
-    [ "testing" ] [
+!     [ "testing" ] [
-        "testing" callback-5a callback_test_1
+!         "testing" callback-5a callback_test_1
-    ] unit-test
+!     ] unit-test
-] unless
+! ] unless
 
 : callback-6
     "void" { } "cdecl" [ [ continue ] callcc0 ] alien-callback ;

core/bootstrap/primitives.factor

@@ -30,6 +30,7 @@ crossref off
 "syntax" vocab vocab-words bootstrap-syntax set
 H{ } clone dictionary set
 H{ } clone changed-words set
+H{ } clone root-cache set
 
 ! Trivial recompile hook. We don't want to touch the code heap
 ! during stage1 bootstrap, it would just waste time.

core/classes/classes-tests.factor

@@ -1,6 +1,6 @@
 USING: alien arrays definitions generic assocs hashtables io
 kernel math namespaces parser prettyprint sequences strings
-tools.test vectors words quotations classes io.streams.string
+tools.test vectors words quotations classes
 classes.private classes.union classes.mixin classes.predicate
 vectors definitions source-files compiler.units ;
 IN: classes.tests
@@ -63,10 +63,6 @@ UNION: c a b ;
 UNION: bah fixnum alien ;
 [ bah ] [ \ bah? "predicating" word-prop ] unit-test
 
-! Test generic see and parsing
-[ "USING: alien math ;\nIN: classes.tests\nUNION: bah fixnum alien ;\n" ]
-[ [ \ bah see ] with-string-writer ] unit-test
-
 ! Test redefinition of classes
 UNION: union-1 fixnum float ;
 
@@ -180,6 +176,8 @@ UNION: forget-class-bug-2 forget-class-bug-1 dll ;
 
 [ f ] [ forget-class-bug-2 typemap get values [ memq? ] with contains? ] unit-test
 
+USE: io.streams.string
+
 2 [
     [ "mixin-forget-test" forget-source ] with-compilation-unit
     
@@ -224,3 +222,7 @@ MIXIN: flat-mx-2     INSTANCE: flat-mx-2 flat-mx-1
 TUPLE: flat-mx-2-1 ; INSTANCE: flat-mx-2-1 flat-mx-2
 
 [ t ] [ T{ flat-mx-2-1 } flat-mx-1? ] unit-test
+
+! Test generic see and parsing
+[ "USING: alien math ;\nIN: classes.tests\nUNION: bah fixnum alien ;\n" ]
+[ [ \ bah see ] with-string-writer ] unit-test

core/io/encodings/binary/binary.factor

@@ -1,3 +1,8 @@
 ! Copyright (C) 2008 Daniel Ehrenberg.
 ! See http://factorcode.org/license.txt for BSD license.
-IN: io.encodings.binary SYMBOL: binary
+USING: io.encodings kernel ;
+IN: io.encodings.binary
+
+TUPLE: binary ;
+M: binary <encoder> drop ;
+M: binary <decoder> drop ;

core/io/encodings/encodings-docs.factor

@@ -44,25 +44,21 @@ $nl { $vocab-link "io.encodings.utf16" } ;
 
 ARTICLE: "encodings-protocol" "Encoding protocol"
 "An encoding descriptor must implement the following methods. The methods are implemented on tuple classes by instantiating the class and calling the method again."
-{ $subsection decode-step }
+{ $subsection decode-char }
-{ $subsection init-decoder }
+{ $subsection encode-char }
-{ $subsection stream-write-encoded } ;
+"The following methods are optional:"
+{ $subsection <encoder> }
+{ $subsection <decoder> } ;
 
-HELP: decode-step ( buf char encoding -- )
+HELP: decode-char ( stream encoding -- char/f )
-{ $values { "buf" "A string buffer which characters can be pushed to" }
+{ $values { "stream" "an underlying input stream" }
-    { "char" "An octet which is read from a stream" }
     { "encoding" "An encoding descriptor tuple" } }
-{ $description "A single step in the decoding process must be defined for the decoding descriptor. When each octet is read, this word is called, and depending on the decoder's internal state, something may be pushed to the buffer or the state may change. This should not be used directly." } ;
+{ $description "Reads a single code point from the underlying stream, interpreting it by the encoding. This should not be used directly." } ;
 
-HELP: stream-write-encoded ( string stream encoding -- )
+HELP: encode-char ( char stream encoding -- )
-{ $values { "string" "a string" }
+{ $values { "char" "a character" }
-    { "stream" "an output stream" }
+    { "stream" "an underlying output stream" }
     { "encoding" "an encoding descriptor" } }
-{ $description "Encodes the string with the given encoding descriptor, outputing the result to the given stream. This should not be used directly." } ;
+{ $description "Writes the code point in the encoding to the underlying stream given. This should not be used directly." } ;
 
-HELP: init-decoder ( stream encoding -- encoding )
+{ encode-char decode-char } related-words
-{ $values { "stream" "an input stream" }
-    { "encoding" "an encoding descriptor" } }
-{ $description "Initializes the decoder tuple's state. The stream is exposed so that it can be read, eg for a BOM. This should not be used directly." } ;
-
-{ init-decoder decode-step stream-write-encoded } related-words

core/io/encodings/encodings.factor

@@ -2,62 +2,43 @@
 ! See http://factorcode.org/license.txt for BSD license.
 USING: math kernel sequences sbufs vectors namespaces
 growable strings io classes continuations combinators
-io.styles io.streams.plain io.encodings.binary splitting
+io.styles io.streams.plain splitting
-io.streams.duplex byte-arrays ;
+io.streams.duplex byte-arrays sequences.private ;
 IN: io.encodings
 
 ! The encoding descriptor protocol
 
-GENERIC: decode-step ( buf char encoding -- )
+GENERIC: decode-char ( stream encoding -- char/f )
-M: object decode-step drop swap push ;
 
-GENERIC: init-decoder ( stream encoding -- encoding )
+GENERIC: encode-char ( char stream encoding -- )
-M: tuple-class init-decoder construct-empty init-decoder ;
-M: object init-decoder nip ;
 
-GENERIC: stream-write-encoded ( string stream encoding -- byte-array )
+GENERIC: <decoder> ( stream decoding -- newstream )
-M: object stream-write-encoded drop stream-write ;
 
-! Decoding
+: replacement-char HEX: fffd ;
+
+TUPLE: decoder stream code cr ;
 
 TUPLE: decode-error ;
 
 : decode-error ( -- * ) \ decode-error construct-empty throw ;
 
-SYMBOL: begin
+GENERIC: <encoder> ( stream encoding -- newstream )
 
-: push-decoded ( buf ch -- buf ch state )
+TUPLE: encoder stream code ;
-    over push 0 begin ;
 
-: push-replacement ( buf -- buf ch state )
+TUPLE: encode-error ;
-    ! This is the replacement character
-    HEX: fffd push-decoded ;
 
-: space ( resizable -- room-left )
+: encode-error ( -- * ) \ encode-error construct-empty throw ;
-    dup underlying swap [ length ] 2apply - ;
 
-: full? ( resizable -- ? ) space zero? ;
+! Decoding
 
-: end-read-loop ( buf ch state stream quot -- string/f )
+<PRIVATE
-    2drop 2drop >string f like ;
 
-: decode-read-loop ( buf stream encoding -- string/f )
+M: tuple-class <decoder> construct-empty <decoder> ;
-    pick full? [ 2drop >string ] [
+M: tuple <decoder> f decoder construct-boa ;
-        over stream-read1 [
-            -rot tuck >r >r >r dupd r> decode-step r> r>
-            decode-read-loop
-        ] [ 2drop >string f like ] if*
-    ] if ;
 
-: decode-read ( length stream encoding -- string )
+: >decoder< ( decoder -- stream encoding )
-    rot <sbuf> -rot decode-read-loop ;
+    { decoder-stream decoder-code } get-slots ;
-
-TUPLE: decoder code cr ;
-: <decoder> ( stream encoding -- newstream )
-    dup binary eq? [ drop ] [
-        dupd init-decoder { set-delegate set-decoder-code }
-        decoder construct
-    ] if ;
 
 : cr+ t swap set-decoder-cr ; inline
 
@@ -82,72 +63,78 @@ TUPLE: decoder code cr ;
     over decoder-cr [
         over cr-
         "\n" ?head [
-            swap stream-read1 [ add ] when*
+            over stream-read1 [ add ] when*
-        ] [ nip ] if
+        ] when
-    ] [ nip ] if ;
+    ] when nip ;
+
+: read-loop ( n stream -- string )
+    SBUF" " clone [
+        [
+            >r nip stream-read1 dup
+            [ r> push f ] [ r> 2drop t ] if
+        ] 2curry find-integer drop
+    ] keep "" like f like ;
 
 M: decoder stream-read
-    tuck { delegate decoder-code } get-slots decode-read fix-read ;
+    tuck read-loop fix-read ;
 
 M: decoder stream-read-partial stream-read ;
 
-: decoder-read-until ( stream delim -- ch )
+: (read-until) ( buf quot -- string/f sep/f )
-    ! Copied from { c-reader stream-read-until }!!!
+    ! quot: -- char stop?
-    over stream-read1 dup [
+    dup call
-        dup pick memq? [ 2nip ] [ , decoder-read-until ] if
+    [ >r drop "" like r> ]
-    ] [
+    [ pick push (read-until) ] if ; inline
-        2nip
-    ] if ;
 
 M: decoder stream-read-until
-    ! Copied from { c-reader stream-read-until }!!!
+    SBUF" " clone -rot >decoder<
-    [ swap decoder-read-until ] "" make
+    [ decode-char [ dup rot memq? ] [ drop f t ] if* ] 3curry
-    swap over empty? over not and [ 2drop f f ] when ;
+    (read-until) ;
 
 : fix-read1 ( stream char -- char )
     over decoder-cr [
         over cr-
         dup CHAR: \n = [
-            drop stream-read1
+            drop dup stream-read1
-        ] [ nip ] if
+        ] when
-    ] [ nip ] if ;
+    ] when nip ;
 
 M: decoder stream-read1
-    1 swap stream-read f like [ first ] [ f ] if* ;
+    dup >decoder< decode-char fix-read1 ;
 
 M: decoder stream-readln ( stream -- str )
     "\r\n" over stream-read-until handle-readln ;
 
+M: decoder dispose decoder-stream dispose ;
+
 ! Encoding
+M: tuple-class <encoder> construct-empty <encoder> ;
+M: tuple <encoder> encoder construct-boa ;
 
-TUPLE: encode-error ;
+: >encoder< ( encoder -- stream encoding )
-
+    { encoder-stream encoder-code } get-slots ;
-: encode-error ( -- * ) \ encode-error construct-empty throw ;
-
-TUPLE: encoder code ;
-: <encoder> ( stream encoding -- newstream )
-    dup binary eq? [ drop ] [
-        construct-empty { set-delegate set-encoder-code }
-        encoder construct
-    ] if ;
 
 M: encoder stream-write1
-    >r 1string r> stream-write ;
+    >encoder< encode-char ;
 
 M: encoder stream-write
-    { delegate encoder-code } get-slots stream-write-encoded ;
+    >encoder< [ encode-char ] 2curry each ;
 
-M: encoder dispose delegate dispose ;
+M: encoder dispose encoder-stream dispose ;
+
+M: encoder stream-flush encoder-stream stream-flush ;
 
 INSTANCE: encoder plain-writer
 
 ! Rebinding duplex streams which have not read anything yet
 
 : reencode ( stream encoding -- newstream )
-    over encoder? [ >r delegate r> ] when <encoder> ;
+    over encoder? [ >r encoder-stream r> ] when <encoder> ;
 
 : redecode ( stream encoding -- newstream )
-    over decoder? [ >r delegate r> ] when <decoder> ;
+    over decoder? [ >r decoder-stream r> ] when <decoder> ;
+
+PRIVATE>
 
 : <encoder-duplex> ( stream-in stream-out encoding -- duplex )
     tuck reencode >r redecode r> <duplex-stream> ;

core/io/encodings/utf8/utf8.factor

@@ -6,82 +6,68 @@ IN: io.encodings.utf8
 
 ! Decoding UTF-8
 
-TUPLE: utf8 ch state ;
+TUPLE: utf8 ;
 
-SYMBOL: double
+<PRIVATE 
-SYMBOL: triple
-SYMBOL: triple2
-SYMBOL: quad
-SYMBOL: quad2
-SYMBOL: quad3
 
 : starts-2? ( char -- ? )
-    -6 shift BIN: 10 number= ;
+    dup [ -6 shift BIN: 10 number= ] when ;
 
-: append-nums ( buf bottom top state-out -- buf num state )
+: append-nums ( stream byte -- stream char )
-    >r over starts-2?
+    over stream-read1 dup starts-2?
-    [ 6 shift swap BIN: 111111 bitand bitor r> ]
+    [ swap 6 shift swap BIN: 111111 bitand bitor ]
-    [ r> 3drop push-replacement ] if ;
+    [ 2drop replacement-char ] if ;
 
-: begin-utf8 ( buf byte -- buf ch state )
+: double ( stream byte -- stream char )
+    BIN: 11111 bitand append-nums ;
+
+: triple ( stream byte -- stream char )
+    BIN: 1111 bitand append-nums append-nums ;
+
+: quad ( stream byte -- stream char )
+    BIN: 111 bitand append-nums append-nums append-nums ;
+
+: begin-utf8 ( stream byte -- stream char )
     {
-        { [ dup -7 shift zero? ] [ push-decoded ] }
+        { [ dup -7 shift zero? ] [ ] }
-        { [ dup -5 shift BIN: 110 number= ] [ BIN: 11111 bitand double ] }
+        { [ dup -5 shift BIN: 110 number= ] [ double ] }
-        { [ dup -4 shift BIN: 1110 number= ] [ BIN: 1111 bitand triple ] }
+        { [ dup -4 shift BIN: 1110 number= ] [ triple ] }
-        { [ dup -3 shift BIN: 11110 number= ] [ BIN: 111 bitand quad ] }
+        { [ dup -3 shift BIN: 11110 number= ] [ quad ] }
-        { [ t ] [ drop push-replacement ] }
+        { [ t ] [ drop replacement-char ] }
     } cond ;
 
-: end-multibyte ( buf byte ch -- buf ch state )
+: decode-utf8 ( stream -- char/f )
-    f append-nums [ push-decoded ] unless* ;
+    dup stream-read1 dup [ begin-utf8 ] when nip ;
 
-: decode-utf8-step ( buf byte ch state -- buf ch state )
+M: utf8 decode-char
-    {
+    drop decode-utf8 ;
-        { begin [ drop begin-utf8 ] }
-        { double [ end-multibyte ] }
-        { triple [ triple2 append-nums ] }
-        { triple2 [ end-multibyte ] }
-        { quad [ quad2 append-nums ] }
-        { quad2 [ quad3 append-nums ] }
-        { quad3 [ end-multibyte ] }
-    } case ;
-
-: unpack-state ( encoding -- ch state )
-    { utf8-ch utf8-state } get-slots ;
-
-: pack-state ( ch state encoding -- )
-    { set-utf8-ch set-utf8-state } set-slots ;
-
-M: utf8 decode-step ( buf char encoding -- )
-    [ unpack-state decode-utf8-step ] keep pack-state drop ;
-
-M: utf8 init-decoder nip begin over set-utf8-state ;
 
 ! Encoding UTF-8
 
-: encoded ( char -- )
+: encoded ( stream char -- )
-    BIN: 111111 bitand BIN: 10000000 bitor write1 ;
+    BIN: 111111 bitand BIN: 10000000 bitor swap stream-write1 ;
 
-: char>utf8 ( char -- )
+: char>utf8 ( stream char -- )
     {
-        { [ dup -7 shift zero? ] [ write1 ] }
+        { [ dup -7 shift zero? ] [ swap stream-write1 ] }
         { [ dup -11 shift zero? ] [
-            dup -6 shift BIN: 11000000 bitor write1
+            2dup -6 shift BIN: 11000000 bitor swap stream-write1
             encoded
         ] }
         { [ dup -16 shift zero? ] [
-            dup -12 shift BIN: 11100000 bitor write1
+            2dup -12 shift BIN: 11100000 bitor swap stream-write1
-            dup -6 shift encoded
+            2dup -6 shift encoded
             encoded
         ] }
         { [ t ] [
-            dup -18 shift BIN: 11110000 bitor write1
+            2dup -18 shift BIN: 11110000 bitor swap stream-write1
-            dup -12 shift encoded
+            2dup -12 shift encoded
-            dup -6 shift encoded
+            2dup -6 shift encoded
             encoded
         ] }
     } cond ;
 
-M: utf8 stream-write-encoded
+M: utf8 encode-char
-    ! For efficiency, this should be modified to avoid variable reads
+    drop swap char>utf8 ;
-    drop [ [ char>utf8 ] each ] with-stream* ;
+
+PRIVATE>

core/io/streams/byte-array/byte-array.factor

@@ -1,5 +1,5 @@
 USING: byte-arrays byte-vectors kernel io.encodings io.streams.string
-sequences io namespaces ;
+sequences io namespaces io.encodings.private ;
 IN: io.streams.byte-array
 
 : <byte-writer> ( encoding -- stream )
@@ -7,7 +7,7 @@ IN: io.streams.byte-array
 
 : with-byte-writer ( encoding quot -- byte-array )
     >r <byte-writer> r> [ stdio get ] compose with-stream*
-    >byte-array ; inline
+    dup encoder? [ encoder-stream ] when >byte-array ; inline
 
 : <byte-reader> ( byte-array encoding -- stream )
     >r >byte-vector dup reverse-here r> <decoder> ;

core/io/streams/string/string.factor

@@ -1,9 +1,9 @@
 ! Copyright (C) 2003, 2007 Slava Pestov.
 ! See http://factorcode.org/license.txt for BSD license.
-IN: io.streams.string
 USING: io kernel math namespaces sequences sbufs strings
 generic splitting growable continuations io.streams.plain
-io.encodings ;
+io.encodings io.encodings.private ;
+IN: io.streams.string
 
 M: growable dispose drop ;
 
@@ -49,8 +49,11 @@ M: growable stream-read
 M: growable stream-read-partial
     stream-read ;
 
+TUPLE: null ;
+M: null decode-char drop stream-read1 ;
+
 : <string-reader> ( str -- stream )
-    >sbuf dup reverse-here f <decoder> ;
+    >sbuf dup reverse-here null <decoder> ;
 
 : with-string-reader ( str quot -- )
     >r <string-reader> r> with-stream ; inline

core/vocabs/loader/loader-docs.factor

@@ -43,8 +43,6 @@ HELP: find-vocab-root
 { $values { "vocab" "a vocabulary specifier" } { "path/f" "a pathname string" } }
 { $description "Searches for a vocabulary in the vocabulary roots." } ;
 
-{ vocab-root find-vocab-root } related-words
-
 HELP: no-vocab
 { $values { "name" "a vocabulary name" } } 
 { $description "Throws a " { $link no-vocab } "." }

core/vocabs/loader/loader-tests.factor

@@ -13,15 +13,15 @@ debugger compiler.units tools.vocabs ;
 ] unit-test
 
 [ T{ vocab-link f "vocabs.loader.test" } ]
-[ "vocabs.loader.test" f >vocab-link ] unit-test
+[ "vocabs.loader.test" >vocab-link ] unit-test
 
 [ t ]
-[ "kernel" f >vocab-link "kernel" vocab = ] unit-test
+[ "kernel" >vocab-link "kernel" vocab = ] unit-test
 
 [ t ] [
     "kernel" vocab-files
     "kernel" vocab vocab-files
-    "kernel" f <vocab-link> vocab-files
+    "kernel" <vocab-link> vocab-files
     3array all-equal?
 ] unit-test
 
@@ -36,7 +36,7 @@ IN: vocabs.loader.tests
 [ { 3 3 3 } ] [
     "vocabs.loader.test.2" run
     "vocabs.loader.test.2" vocab run
-    "vocabs.loader.test.2" f <vocab-link> run
+    "vocabs.loader.test.2" <vocab-link> run
     3array
 ] unit-test
 
@@ -115,7 +115,7 @@ IN: vocabs.loader.tests
 [ 3 ] [ "count-me" get-global ] unit-test
 
 [ { "resource:core/kernel/kernel.factor" 1 } ]
-[ "kernel" f <vocab-link> where ] unit-test
+[ "kernel" <vocab-link> where ] unit-test
 
 [ { "resource:core/kernel/kernel.factor" 1 } ]
 [ "kernel" vocab where ] unit-test

core/vocabs/loader/loader.factor

@@ -23,15 +23,6 @@ V{
     [ >r dup peek r> append add ] when*
     "/" join ;
 
-: vocab-path+ ( vocab path -- newpath )
-    swap vocab-root dup [ swap path+ ] [ 2drop f ] if ;
-
-: vocab-source-path ( vocab -- path/f )
-    dup ".factor" vocab-dir+ vocab-path+ ;
-
-: vocab-docs-path ( vocab -- path/f )
-    dup "-docs.factor" vocab-dir+ vocab-path+ ;
-
 : vocab-dir? ( root name -- ? )
     over [
         ".factor" vocab-dir+ path+ resource-exists?
@@ -39,14 +30,23 @@ V{
         2drop f
     ] if ;
 
+SYMBOL: root-cache
+
+H{ } clone root-cache set-global
+
 : find-vocab-root ( vocab -- path/f )
-    vocab-roots get swap [ vocab-dir? ] curry find nip ;
+    vocab-name root-cache get [
+        vocab-roots get swap [ vocab-dir? ] curry find nip
+    ] cache ;
 
-M: string vocab-root
+: vocab-path+ ( vocab path -- newpath )
-    vocab dup [ vocab-root ] when ;
+    swap find-vocab-root dup [ swap path+ ] [ 2drop f ] if ;
 
-M: vocab-link vocab-root
+: vocab-source-path ( vocab -- path/f )
-    vocab-link-root ;
+    dup ".factor" vocab-dir+ vocab-path+ ;
+
+: vocab-docs-path ( vocab -- path/f )
+    dup "-docs.factor" vocab-dir+ vocab-path+ ;
 
 SYMBOL: load-help?
 
@@ -56,7 +56,7 @@ SYMBOL: load-help?
 
 : load-source ( vocab -- )
     [ source-wasn't-loaded ] keep
-    [ vocab-source-path bootstrap-file ] keep
+    [ vocab-source-path [ bootstrap-file ] when* ] keep
     source-was-loaded ;
 
 : docs-were-loaded t swap set-vocab-docs-loaded? ;
@@ -70,18 +70,9 @@ SYMBOL: load-help?
         docs-were-loaded
     ] [ drop ] if ;
 
-: create-vocab-with-root ( name root -- vocab )
-    swap create-vocab [ set-vocab-root ] keep ;
-
-: update-root ( vocab -- )
-    dup vocab-root
-    [ drop ] [ dup find-vocab-root swap set-vocab-root ] if ;
-
 : reload ( name -- )
     [
-        dup vocab [
+        dup vocab [ dup load-source load-docs ] [ no-vocab ] ?if
-            dup update-root dup load-source load-docs
-        ] [ no-vocab ] ?if
     ] with-compiler-errors ;
 
 : require ( vocab -- )
@@ -104,22 +95,17 @@ SYMBOL: blacklist
 GENERIC: (load-vocab) ( name -- )
 
 M: vocab (load-vocab)
-    dup update-root
+    [
-
+        dup vocab-source-loaded? [ dup load-source ] unless
-    dup vocab-root [
+        dup vocab-docs-loaded? [ dup load-docs ] unless
-        [
+        drop
-            dup vocab-source-loaded? [ dup load-source ] unless
+    ] [ [ swap add-to-blacklist ] keep rethrow ] recover ;
-            dup vocab-docs-loaded? [ dup load-docs ] unless
-        ] [ [ swap add-to-blacklist ] keep rethrow ] recover
-    ] when drop ;
-
-M: string (load-vocab)
-    ! ".private" ?tail drop
-    dup find-vocab-root >vocab-link (load-vocab) ;
 
 M: vocab-link (load-vocab)
-    dup vocab-name swap vocab-root dup
+    vocab-name create-vocab (load-vocab) ;
-    [ create-vocab-with-root (load-vocab) ] [ 2drop ] if ;
+
+M: string (load-vocab)
+    create-vocab (load-vocab) ;
 
 [
     [

core/vocabs/vocabs-docs.factor

@@ -16,7 +16,6 @@ $nl
 { $subsection vocab }
 "Accessors for various vocabulary attributes:"
 { $subsection vocab-name }
-{ $subsection vocab-root }
 { $subsection vocab-main }
 { $subsection vocab-help }
 "Looking up existing vocabularies and creating new vocabularies:"
@@ -50,10 +49,6 @@ HELP: vocab-name
 { $values { "vocab" "a vocabulary specifier" } { "name" string } }
 { $description "Outputs the name of a vocabulary." } ;
 
-HELP: vocab-root
-{ $values { "vocab" "a vocabulary specifier" } { "root" "a pathname string or " { $link f } } }
-{ $description "Outputs the vocabulary root where the source code for a vocabulary is located, or " { $link f } " if the vocabulary is not defined in source files." } ;
-
 HELP: vocab-words
 { $values { "vocab" "a vocabulary specifier" } { "words" "an assoc mapping strings to words" } }
 { $description "Outputs the words defined in a vocabulary." } ;
@@ -101,11 +96,11 @@ HELP: child-vocabs
 } ;
 
 HELP: vocab-link
-{ $class-description "Instances of this class identify vocabularies which are potentially not loaded. The " { $link vocab-name } " slot is the vocabulary name, and " { $link vocab-root } " is a pathname string identifying the vocabulary root where the sources to this vocabulary are located, or " { $link f } " if the root is not known."
+{ $class-description "Instances of this class identify vocabularies which are potentially not loaded. The " { $link vocab-name } " slot is the vocabulary name."
 $nl
 "Vocabulary links are created by calling " { $link >vocab-link } "."
 } ;
 
 HELP: >vocab-link
-{ $values { "name" string } { "root" "a pathname string or " { $link f } } { "vocab" "a vocabulary specifier" } }
+{ $values { "name" string } { "vocab" "a vocabulary specifier" } }
 { $description "If the vocabulary is loaded, outputs the corresponding " { $link vocab } " instance, otherwise creates a new " { $link vocab-link } "." } ;

core/vocabs/vocabs.factor

@@ -92,10 +92,10 @@ SYMBOL: load-vocab-hook ! ( name -- )
 : child-vocabs ( vocab -- seq )
     vocab-name vocabs [ child-vocab? ] with subset ;
 
-TUPLE: vocab-link name root ;
+TUPLE: vocab-link name ;
 
-: <vocab-link> ( name root -- vocab-link )
+: <vocab-link> ( name -- vocab-link )
-    [ dup vocab-root ] unless* vocab-link construct-boa ;
+    vocab-link construct-boa ;
 
 M: vocab-link equal?
     over vocab-link?
@@ -106,17 +106,14 @@ M: vocab-link hashcode*
 
 M: vocab-link vocab-name vocab-link-name ;
 
-GENERIC# >vocab-link 1 ( name root -- vocab )
-
-M: vocab >vocab-link drop ;
-
-M: vocab-link >vocab-link drop ;
-
-M: string >vocab-link
-    over vocab dup [ 2nip ] [ drop <vocab-link> ] if ;
-
 UNION: vocab-spec vocab vocab-link ;
 
+GENERIC: >vocab-link ( name -- vocab )
+
+M: vocab-spec >vocab-link ;
+
+M: string >vocab-link dup vocab [ ] [ <vocab-link> ] ?if ;
+
 : forget-vocab ( vocab -- )
     dup words forget-all
     vocab-name dictionary get delete-at ;

extra/bunny/outlined/outlined.factor

@@ -1,5 +1,5 @@
 USING: arrays bunny.model bunny.cel-shaded
-combinators.lib continuations kernel math multiline
+combinators.cleave continuations kernel math multiline
 opengl opengl.shaders opengl.framebuffers opengl.gl
 opengl.capabilities sequences ui.gadgets combinators.cleave ;
 IN: bunny.outlined

extra/cocoa/windows/windows.factor

@@ -30,7 +30,8 @@ IN: cocoa.windows
 : <ViewWindow> ( view rect -- window )
     <NSWindow> [ swap -> setContentView: ] keep
     dup dup -> contentView -> setInitialFirstResponder:
-    dup 1 -> setAcceptsMouseMovedEvents: ;
+    dup 1 -> setAcceptsMouseMovedEvents:
+    dup 0 -> setReleasedWhenClosed: ;
 
 : window-content-rect ( window -- rect )
     NSWindow over -> frame rot -> styleMask

extra/combinators/lib/lib.factor

@@ -134,7 +134,10 @@ MACRO: map-call-with ( quots -- )
     [ 2drop ] append ;
 
 MACRO: map-call-with2 ( quots -- )
-    [ (make-call-with2) ] keep length [ narray ] curry append ;
+    [
+        [ [ 2dup >r >r ] swap append [ r> r> ] append ] map concat
+        [ 2drop ] append    
+    ] keep length [ narray ] curry append ;
 
 MACRO: map-exec-with ( words -- )
     [ 1quotation ] map [ map-call-with ] curry ;
@@ -156,6 +159,13 @@ MACRO: construct-slots ( assoc tuple-class -- tuple )
 : and? ( obj quot1 quot2 -- ? )
     >r keep r> rot [ call ] [ 2drop f ] if ; inline
 
+MACRO: multikeep ( word out-indexes -- ... )
+    [
+        dup >r [ \ npick \ >r 3array % ] each
+        %
+        r> [ drop \ r> , ] each
+    ] [ ] make ;
+
 : retry ( quot n -- )
     [ drop ] rot compose attempt-all ; inline
 

extra/help/markup/markup.factor

@@ -159,7 +159,7 @@ M: f print-element drop ;
     [ first ($long-link) ] ($subsection) ;
 
 : ($vocab-link) ( text vocab -- )
-    dup vocab-root >vocab-link write-link ;
+    >vocab-link write-link ;
 
 : $vocab-subsection ( element -- )
     [

extra/io/encodings/ascii/ascii.factor

@@ -1,18 +1,22 @@
 ! Copyright (C) 2008 Daniel Ehrenberg.
 ! See http://factorcode.org/license.txt for BSD license.
-USING: io io.encodings strings kernel math sequences byte-arrays io.encodings ;
+USING: io io.encodings kernel math io.encodings.private ;
 IN: io.encodings.ascii
 
-: encode-check< ( string stream max -- )
+<PRIVATE
-    [ pick <= [ encode-error ] [ stream-write1 ] if ] 2curry each ;
+: encode-if< ( char stream encoding max -- )
+    nip 1- pick < [ encode-error ] [ stream-write1 ] if ;
 
-: push-if< ( sbuf character max -- )
+: decode-if< ( stream encoding max -- character )
-    over <= [ drop HEX: fffd ] when swap push ;
+    nip swap stream-read1
+    [ tuck > [ drop replacement-char ] unless ]
+    [ drop f ] if* ;
+PRIVATE>
 
 TUPLE: ascii ;
 
-M: ascii stream-write-encoded ( string stream encoding -- )
+M: ascii encode-char
-    drop 128 encode-check< ;
+    128 encode-if< ;
 
-M: ascii decode-step
+M: ascii decode-char
-    drop 128 push-if< ;
+    128 decode-if< ;

extra/io/encodings/latin1/latin1.factor

@@ -1,12 +1,12 @@
 ! Copyright (C) 2008 Daniel Ehrenberg.
 ! See http://factorcode.org/license.txt for BSD license.
-USING: io io.encodings strings kernel io.encodings.ascii sequences math ;
+USING: io io.encodings kernel io.encodings.ascii.private ;
 IN: io.encodings.latin1
 
 TUPLE: latin1 ;
 
-M: latin1 stream-write-encoded 
+M: latin1 encode-char 
-    drop 256 encode-check< ;
+    256 encode-if< ;
 
-M: latin1 decode-step
+M: latin1 decode-char
-    drop swap push ;
+    drop stream-read1 ;

extra/io/encodings/utf16/utf16.factor

@@ -1,133 +1,101 @@
 ! Copyright (C) 2006, 2008 Daniel Ehrenberg.
 ! See http://factorcode.org/license.txt for BSD license.
 USING: math kernel sequences sbufs vectors namespaces io.binary
-io.encodings combinators splitting io byte-arrays ;
+io.encodings combinators splitting io byte-arrays inspector ;
 IN: io.encodings.utf16
 
+TUPLE: utf16be ;
+
+TUPLE: utf16le ;
+
+TUPLE: utf16 ;
+
+<PRIVATE
+
 ! UTF-16BE decoding
 
-TUPLE: utf16be ch state ;
-
-SYMBOL: double
-SYMBOL: quad1
-SYMBOL: quad2
-SYMBOL: quad3
-SYMBOL: ignore
-
-: do-ignore ( -- ch state ) 0 ignore ;
-
 : append-nums ( byte ch -- ch )
-    8 shift bitor ;
+    over [ 8 shift bitor ] [ 2drop replacement-char ] if ;
 
-: end-multibyte ( buf byte ch -- buf ch state )
+: double-be ( stream byte -- stream char )
-    append-nums push-decoded ;
+    over stream-read1 swap append-nums ;
 
-: begin-utf16be ( buf byte -- buf ch state )
+: quad-be ( stream byte -- stream char )
+    double-be over stream-read1 [
+        dup -2 shift BIN: 110111 number= [
+            >r 2 shift r> BIN: 11 bitand bitor
+            over stream-read1 swap append-nums HEX: 10000 +
+        ] [ 2drop dup stream-read1 drop replacement-char ] if
+    ] when* ;
+
+: ignore ( stream -- stream char )
+    dup stream-read1 drop replacement-char ;
+
+: begin-utf16be ( stream byte -- stream char )
     dup -3 shift BIN: 11011 number= [
         dup BIN: 00000100 bitand zero?
-        [ BIN: 11 bitand quad1 ]
+        [ BIN: 11 bitand quad-be ]
-        [ drop do-ignore ] if
+        [ drop ignore ] if
-    ] [ double ] if ;
+    ] [ double-be ] if ;
-
+    
-: handle-quad2be ( byte ch -- ch state )
+M: utf16be decode-char
-    swap dup -2 shift BIN: 110111 number= [
+    drop dup stream-read1 dup [ begin-utf16be ] when nip ;
-        >r 2 shift r> BIN: 11 bitand bitor quad3
-    ] [ 2drop do-ignore ] if ;
-
-: decode-utf16be-step ( buf byte ch state -- buf ch state )
-    {
-        { begin [ drop begin-utf16be ] }
-        { double [ end-multibyte ] }
-        { quad1 [ append-nums quad2 ] }
-        { quad2 [ handle-quad2be ] }
-        { quad3 [ append-nums HEX: 10000 + push-decoded ] }
-        { ignore [ 2drop push-replacement ] }
-    } case ;
-
-: unpack-state-be ( encoding -- ch state )
-    { utf16be-ch utf16be-state } get-slots ;
-
-: pack-state-be ( ch state encoding -- )
-    { set-utf16be-ch set-utf16be-state } set-slots ;
-
-M: utf16be decode-step
-    [ unpack-state-be decode-utf16be-step ] keep pack-state-be drop ;
-
-M: utf16be init-decoder nip begin over set-utf16be-state ;
 
 ! UTF-16LE decoding
 
-TUPLE: utf16le ch state ;
+: quad-le ( stream ch -- stream char )
+    over stream-read1 swap 10 shift bitor
+    over stream-read1 dup -2 shift BIN: 110111 = [
+        BIN: 11 bitand append-nums HEX: 10000 +
+    ] [ 2drop replacement-char ] if ;
 
-: handle-double ( buf byte ch -- buf ch state )
+: double-le ( stream byte1 byte2 -- stream char )
-    swap dup -3 shift BIN: 11011 = [
+    dup -3 shift BIN: 11011 = [
         dup BIN: 100 bitand 0 number=
-        [ BIN: 11 bitand 8 shift bitor quad2 ]
+        [ BIN: 11 bitand 8 shift bitor quad-le ]
-        [ 2drop push-replacement ] if
+        [ 2drop replacement-char ] if
-    ] [ end-multibyte ] if ;
+    ] [ append-nums ] if ;
 
-: handle-quad3le ( buf byte ch -- buf ch state )
+: begin-utf16le ( stream byte -- stream char )
-    swap dup -2 shift BIN: 110111 = [
+    over stream-read1 [ double-le ] [ drop replacement-char ] if* ;
-        BIN: 11 bitand append-nums HEX: 10000 + push-decoded
-    ] [ 2drop push-replacement ] if ;
 
-: decode-utf16le-step ( buf byte ch state -- buf ch state )
+M: utf16le decode-char
-    {
+    drop dup stream-read1 dup [ begin-utf16le ] when nip ;
-        { begin [ drop double ] }
-        { double [ handle-double ] }
-        { quad1 [ append-nums quad2 ] }
-        { quad2 [ 10 shift bitor quad3 ] }
-        { quad3 [ handle-quad3le ] }
-    } case ;
-
-: unpack-state-le ( encoding -- ch state )
-    { utf16le-ch utf16le-state } get-slots ;
-
-: pack-state-le ( ch state encoding -- )
-    { set-utf16le-ch set-utf16le-state } set-slots ;
-
-M: utf16le decode-step
-    [ unpack-state-le decode-utf16le-step ] keep pack-state-le drop ;
-
-M: utf16le init-decoder nip begin over set-utf16le-state ;
 
 ! UTF-16LE/BE encoding
 
-: encode-first
+: encode-first ( char -- byte1 byte2 )
     -10 shift
     dup -8 shift BIN: 11011000 bitor
     swap HEX: FF bitand ;
 
-: encode-second
+: encode-second ( char -- byte3 byte4 )
     BIN: 1111111111 bitand
     dup -8 shift BIN: 11011100 bitor
     swap BIN: 11111111 bitand ;
 
-: char>utf16be ( char -- )
+: stream-write2 ( stream char1 char2 -- )
+    rot [ stream-write1 ] curry 2apply ;
+
+: char>utf16be ( stream char -- )
     dup HEX: FFFF > [
         HEX: 10000 -
-        dup encode-first swap write1 write1
+        2dup encode-first stream-write2
-        encode-second swap write1 write1
+        encode-second stream-write2
-    ] [ h>b/b write1 write1 ] if ;
+    ] [ h>b/b swap stream-write2 ] if ;
 
-: stream-write-utf16be ( string stream -- )
+M: utf16be encode-char ( char stream encoding -- )
-    [ [ char>utf16be ] each ] with-stream* ;
+    drop swap char>utf16be ;
 
-M: utf16be stream-write-encoded ( string stream encoding -- )
+: char>utf16le ( char stream -- )
-    drop stream-write-utf16be ;
-
-: char>utf16le ( char -- )
     dup HEX: FFFF > [
         HEX: 10000 -
-        dup encode-first write1 write1
+        2dup encode-first swap stream-write2
-        encode-second write1 write1
+        encode-second swap stream-write2
-    ] [ h>b/b swap write1 write1 ] if ; 
+    ] [ h>b/b stream-write2 ] if ; 
 
-: stream-write-utf16le ( string stream -- )
+M: utf16le encode-char ( char stream encoding -- )
-    [ [ char>utf16le ] each ] with-stream* ;
+    drop swap char>utf16le ;
-
-M: utf16le stream-write-encoded ( string stream encoding -- )
-    drop stream-write-utf16le ;
 
 ! UTF-16
 
@@ -139,17 +107,18 @@ M: utf16le stream-write-encoded ( string stream encoding -- )
 
 : start-utf16be? ( seq1 -- seq2 ? ) bom-be ?head ;
 
-TUPLE: utf16 started? ;
+TUPLE: missing-bom ;
-
+M: missing-bom summary drop "The BOM for a UTF-16 stream was missing" ;
-M: utf16 stream-write-encoded
-    dup utf16-started? [ drop ]
-    [ t swap set-utf16-started? bom-le over stream-write ] if
-    stream-write-utf16le ;
 
 : bom>le/be ( bom -- le/be )
     dup bom-le sequence= [ drop utf16le ] [
-        bom-be sequence= [ utf16be ] [ decode-error ] if
+        bom-be sequence= [ utf16be ] [ missing-bom ] if
     ] if ;
 
-M: utf16 init-decoder ( stream encoding -- newencoding )
+M: utf16 <decoder> ( stream utf16 -- decoder )
-    2 rot stream-read bom>le/be construct-empty init-decoder ;
+    drop 2 over stream-read bom>le/be <decoder> ;
+
+M: utf16 <encoder> ( stream utf16 -- encoder )
+    drop bom-le over stream-write utf16le <encoder> ;
+
+PRIVATE>

extra/io/timeouts/timeouts.factor

@@ -1,6 +1,6 @@
 ! Copyright (C) 2008 Slava Pestov, Doug Coleman
 ! See http://factorcode.org/license.txt for BSD license.
-USING: kernel calendar alarms io.streams.duplex ;
+USING: kernel calendar alarms io.streams.duplex io.encodings ;
 IN: io.timeouts
 
 ! Won't need this with new slot accessors
@@ -12,6 +12,10 @@ M: duplex-stream set-timeout
     duplex-stream-in set-timeout
     duplex-stream-out set-timeout ;
 
+M: decoder set-timeout decoder-stream set-timeout ;
+
+M: encoder set-timeout encoder-stream set-timeout ;
+
 GENERIC: timed-out ( obj -- )
 
 M: object timed-out drop ;

extra/io/unix/launcher/launcher-tests.factor

@@ -1,6 +1,6 @@
 IN: io.unix.launcher.tests
 USING: io.files tools.test io.launcher arrays io namespaces
-continuations math io.encodings.ascii io.encodings.latin1
+continuations math io.encodings.binary io.encodings.ascii
 accessors kernel sequences ;
 
 [ ] [
@@ -64,7 +64,7 @@ accessors kernel sequences ;
 
 [ ] [
     2 [
-        "launcher-test-1" temp-file ascii <file-appender> [
+        "launcher-test-1" temp-file binary <file-appender> [
             <process>
                 swap >>stdout
                 "echo Hello" >>command
@@ -84,7 +84,7 @@ accessors kernel sequences ;
     <process>
         "env" >>command
         { { "A" "B" } } >>environment
-    latin1 <process-stream> lines
+    ascii <process-stream> lines
     "A=B" swap member?
 ] unit-test
 
@@ -93,5 +93,5 @@ accessors kernel sequences ;
         "env" >>command
         { { "A" "B" } } >>environment
         +replace-environment+ >>environment-mode
-    latin1 <process-stream> lines
+    ascii <process-stream> lines
 ] unit-test

extra/opengl/gl/macosx/macosx.factor

@@ -2,5 +2,5 @@ USING: kernel alien ;
 IN: opengl.gl.macosx
 
 : gl-function-context ( -- context ) 0 ; inline
-: gl-function-address ( name -- address ) "gl" load-library dlsym ; inline
+: gl-function-address ( name -- address ) f dlsym ; inline
 : gl-function-calling-convention ( -- str ) "cdecl" ; inline

extra/opengl/shaders/shaders.factor

@@ -2,7 +2,7 @@
 ! See http://factorcode.org/license.txt for BSD license.
 USING: kernel opengl.gl alien.c-types continuations namespaces
 assocs alien libc opengl math sequences combinators.lib 
-macros arrays combinators.cleave ;
+combinators.cleave macros arrays ;
 IN: opengl.shaders
 
 : with-gl-shader-source-ptr ( string quot -- )
@@ -92,10 +92,11 @@ PREDICATE: gl-shader fragment-shader (fragment-shader?) ;
     GL_ATTACHED_SHADERS gl-program-get-int ; inline
 
 : gl-program-shaders ( program -- shaders )
-    dup gl-program-shaders-length [
+    dup gl-program-shaders-length
-        dup "GLuint" <c-array>
+    dup "GLuint" <c-array>
-        [ 0 <int> swap glGetAttachedShaders ] keep
+    0 <int> swap
-    ] keep c-uint-array> ;
+    [ glGetAttachedShaders ] { 3 1 } multikeep
+    c-uint-array> ;
 
 : delete-gl-program-only ( program -- )
     glDeleteProgram ; inline

extra/peg/ebnf/ebnf-tests.factor

@@ -1,7 +1,7 @@
 ! Copyright (C) 2007 Chris Double.
 ! See http://factorcode.org/license.txt for BSD license.
 !
-USING: kernel tools.test peg peg.ebnf ;
+USING: kernel tools.test peg peg.ebnf compiler.units ;
 IN: peg.ebnf.tests
 
 { T{ ebnf-non-terminal f "abc" } } [
@@ -15,11 +15,8 @@ IN: peg.ebnf.tests
 {
   T{ ebnf-rule f 
      "digit"
-     V{ 
+     T{ ebnf-choice f
-       T{ ebnf-choice f
+        V{ T{ ebnf-terminal f "1" } T{ ebnf-terminal f "2" } }
-          V{ T{ ebnf-terminal f "1" } T{ ebnf-terminal f "2" } }
-       }
-       f
      }
   } 
 } [
@@ -29,11 +26,8 @@ IN: peg.ebnf.tests
 {
   T{ ebnf-rule f 
      "digit" 
-     V{
+     T{ ebnf-sequence f
-       T{ ebnf-sequence f
+        V{ T{ ebnf-terminal f "1" } T{ ebnf-terminal f "2" } }
-          V{ T{ ebnf-terminal f "1" } T{ ebnf-terminal f "2" } }
-       }
-       f
      }
   }   
 } [
@@ -83,7 +77,7 @@ IN: peg.ebnf.tests
      }
   } 
 } [
-  "one {(two | three) four}" 'choice' parse parse-result-ast
+  "one ((two | three) four)*" 'choice' parse parse-result-ast
 ] unit-test
 
 {
@@ -95,5 +89,33 @@ IN: peg.ebnf.tests
      }
   } 
 } [
-  "one [ two ] three" 'choice' parse parse-result-ast
+  "one ( two )? three" 'choice' parse parse-result-ast
 ] unit-test
+
+{ "foo" } [
+  "\"foo\"" 'identifier' parse parse-result-ast
+] unit-test
+
+{ "foo" } [
+  "'foo'" 'identifier' parse parse-result-ast
+] unit-test
+
+{ "foo" } [
+  "foo" 'non-terminal' parse parse-result-ast ebnf-non-terminal-symbol
+] unit-test
+
+{ "foo" } [
+  "foo]" 'non-terminal' parse parse-result-ast ebnf-non-terminal-symbol
+] unit-test
+
+{ V{ "a" "b" } } [
+  "foo='a' 'b'" ebnf>quot with-compilation-unit "ab" foo parse parse-result-ast 
+] unit-test
+
+{ V{ 1 "b" } } [
+  "foo=('a')[[ drop 1 ]] 'b'" ebnf>quot with-compilation-unit "ab" foo parse parse-result-ast 
+] unit-test
+
+{ V{ 1 2 } } [
+  "foo=('a') [[ drop 1 ]] ('b') [[ drop 2 ]]" ebnf>quot with-compilation-unit "ab" foo parse parse-result-ast 
+] unit-test

extra/peg/ebnf/ebnf.factor

@@ -2,24 +2,31 @@
 ! See http://factorcode.org/license.txt for BSD license.
 USING: kernel parser words arrays strings math.parser sequences 
        quotations vectors namespaces math assocs continuations peg
-       peg.parsers unicode.categories ;
+       peg.parsers unicode.categories multiline combinators.lib 
+       splitting ;
 IN: peg.ebnf
 
 TUPLE: ebnf-non-terminal symbol ;
 TUPLE: ebnf-terminal symbol ;
+TUPLE: ebnf-any-character ;
+TUPLE: ebnf-ensure-not group ;
 TUPLE: ebnf-choice options ;
 TUPLE: ebnf-sequence elements ;
 TUPLE: ebnf-repeat0 group ;
+TUPLE: ebnf-repeat1 group ;
 TUPLE: ebnf-optional elements ;
 TUPLE: ebnf-rule symbol elements ;
-TUPLE: ebnf-action word ;
+TUPLE: ebnf-action parser code ;
 TUPLE: ebnf rules ;
 
 C: <ebnf-non-terminal> ebnf-non-terminal
 C: <ebnf-terminal> ebnf-terminal
+C: <ebnf-any-character> ebnf-any-character
+C: <ebnf-ensure-not> ebnf-ensure-not
 C: <ebnf-choice> ebnf-choice
 C: <ebnf-sequence> ebnf-sequence
 C: <ebnf-repeat0> ebnf-repeat0
+C: <ebnf-repeat1> ebnf-repeat1
 C: <ebnf-optional> ebnf-optional
 C: <ebnf-rule> ebnf-rule
 C: <ebnf-action> ebnf-action
@@ -27,12 +34,10 @@ C: <ebnf> ebnf
 
 SYMBOL: parsers
 SYMBOL: non-terminals
-SYMBOL: last-parser
 
 : reset-parser-generation ( -- ) 
   V{ } clone parsers set 
-  H{ } clone non-terminals set 
+  H{ } clone non-terminals set ;
-  f last-parser set ;
 
 : store-parser ( parser -- number )
   parsers get [ push ] keep length 1- ;
@@ -50,7 +55,7 @@ SYMBOL: last-parser
 GENERIC: (generate-parser) ( ast -- id )
 
 : generate-parser ( ast -- id )
-  (generate-parser) dup last-parser set ;
+  (generate-parser) ;
 
 M: ebnf-terminal (generate-parser) ( ast -- id )
   ebnf-terminal-symbol token sp store-parser ;
@@ -61,6 +66,9 @@ M: ebnf-non-terminal (generate-parser) ( ast -- id )
     parsers get , \ nth , [ search ] [ 2drop f ] recover , \ or ,
   ] [ ] make delay sp store-parser ;
 
+M: ebnf-any-character (generate-parser) ( ast -- id )
+  drop [ drop t ] satisfy store-parser ;
+
 M: ebnf-choice (generate-parser) ( ast -- id )
   ebnf-choice-options [
     generate-parser get-parser 
@@ -71,9 +79,15 @@ M: ebnf-sequence (generate-parser) ( ast -- id )
     generate-parser get-parser
   ] map seq store-parser ;
 
+M: ebnf-ensure-not (generate-parser) ( ast -- id )
+  ebnf-ensure-not-group generate-parser get-parser ensure-not store-parser ;
+
 M: ebnf-repeat0 (generate-parser) ( ast -- id )
   ebnf-repeat0-group generate-parser get-parser repeat0 store-parser ;
 
+M: ebnf-repeat1 (generate-parser) ( ast -- id )
+  ebnf-repeat1-group generate-parser get-parser repeat1 store-parser ;
+
 M: ebnf-optional (generate-parser) ( ast -- id )
   ebnf-optional-elements generate-parser get-parser optional store-parser ;
 
@@ -83,15 +97,12 @@ M: ebnf-rule (generate-parser) ( ast -- id )
   swap [ parsers get set-nth ] keep ;
 
 M: ebnf-action (generate-parser) ( ast -- id )
-  ebnf-action-word search 1quotation 
+  [ ebnf-action-parser generate-parser get-parser ] keep
-  last-parser get get-parser swap action store-parser ;
+  ebnf-action-code string-lines parse-lines action store-parser ;
 
 M: vector (generate-parser) ( ast -- id )
   [ generate-parser ] map peek ;
 
-M: f (generate-parser) ( ast -- id )
-  drop last-parser get ;
-
 M: ebnf (generate-parser) ( ast -- id )
   ebnf-rules [
     generate-parser 
@@ -99,67 +110,153 @@ M: ebnf (generate-parser) ( ast -- id )
 
 DEFER: 'rhs'
 
+: syntax ( string -- parser )
+  #! Parses the string, ignoring white space, and
+  #! does not put the result in the AST.
+  token sp hide ;
+
+: syntax-pack ( begin parser end -- parser )
+  #! Parse 'parser' surrounded by syntax elements
+  #! begin and end.
+  [ syntax ] dipd syntax pack ;
+
+: 'identifier' ( -- parser )
+  #! Return a parser that parses an identifer delimited by
+  #! a quotation character. The quotation can be single
+  #! or double quotes. The AST produced is the identifier
+  #! between the quotes.
+  [
+    [ CHAR: " = not ] satisfy repeat1 "\"" "\"" surrounded-by ,
+    [ CHAR: ' = not ] satisfy repeat1 "'" "'" surrounded-by ,
+  ] choice* [ >string ] action ;
+  
 : 'non-terminal' ( -- parser )
-  CHAR: a CHAR: z range "-" token [ first ] action  2array choice repeat1 [ >string <ebnf-non-terminal> ] action ;
+  #! A non-terminal is the name of another rule. It can
+  #! be any non-blank character except for characters used
+  #! in the EBNF syntax itself.
+  [
+    {
+      [ dup blank?    ]
+      [ dup CHAR: " = ]
+      [ dup CHAR: ' = ]
+      [ dup CHAR: | = ]
+      [ dup CHAR: { = ]
+      [ dup CHAR: } = ]
+      [ dup CHAR: = = ]
+      [ dup CHAR: ) = ]
+      [ dup CHAR: ( = ]
+      [ dup CHAR: ] = ]
+      [ dup CHAR: [ = ]
+      [ dup CHAR: . = ]
+      [ dup CHAR: ! = ]
+      [ dup CHAR: * = ]
+      [ dup CHAR: + = ]
+      [ dup CHAR: ? = ]
+    } || not nip    
+  ] satisfy repeat1 [ >string <ebnf-non-terminal> ] action ;
 
 : 'terminal' ( -- parser )
-  "'" token hide [ CHAR: ' = not ] satisfy repeat1 "'" token hide 3array seq [ first >string <ebnf-terminal> ] action ;
+  #! A terminal is an identifier enclosed in quotations
+  #! and it represents the literal value of the identifier.
+  'identifier' [ <ebnf-terminal> ] action ;
 
+: 'any-character' ( -- parser )
+  #! A parser to match the symbol for any character match.
+  [ CHAR: . = ] satisfy [ drop <ebnf-any-character> ] action ;
+ 
 : 'element' ( -- parser )
-  'non-terminal' 'terminal' 2array choice ;
+  #! An element of a rule. It can be a terminal or a 
+  #! non-terminal but must not be followed by a "=". 
+  #! The latter indicates that it is the beginning of a
+  #! new rule.
+  [
+    [ 
+      'non-terminal' ,
+      'terminal' ,
+      'any-character' ,
+    ] choice* ,
+    "=" syntax ensure-not ,
+  ] seq* [ first ] action ;
 
 DEFER: 'choice'
 
+: grouped ( quot suffix  -- parser )
+  #! Parse a group of choices, with a suffix indicating
+  #! the type of group (repeat0, repeat1, etc) and
+  #! an quot that is the action that produces the AST.
+  "(" [ 'choice' sp ] delay ")" syntax-pack 
+  swap 2seq  
+  [ first ] rot compose action ;
+  
 : 'group' ( -- parser )
-  "(" token sp hide
+  #! A grouping with no suffix. Used for precedence.
-  [ 'choice' sp ] delay
+  [ ] [
-  ")" token sp hide 
+    "*" token sp ensure-not ,
-  3array seq [ first ] action ;
+    "+" token sp ensure-not ,
+    "?" token sp ensure-not ,
+    "[[" token sp ensure-not ,
+  ] seq* hide grouped ; 
 
 : 'repeat0' ( -- parser )
-  "{" token sp hide
+  [ <ebnf-repeat0> ] "*" syntax grouped ;
-  [ 'choice' sp ] delay
+
-  "}" token sp hide 
+: 'repeat1' ( -- parser )
-  3array seq [ first <ebnf-repeat0> ] action ;
+  [ <ebnf-repeat1> ] "+" syntax grouped ;
 
 : 'optional' ( -- parser )
-  "[" token sp hide
+  [ <ebnf-optional> ] "?" syntax grouped ;
-  [ 'choice' sp ] delay
+
-  "]" token sp hide 
+: 'factor-code' ( -- parser )
-  3array seq [ first <ebnf-optional> ] action ;
+  [
+    "]]" token ensure-not ,
+    [ drop t ] satisfy ,
+  ] seq* [ first ] action repeat0 [ >string ] action ;
+
+: 'action' ( -- parser )
+  [
+    "(" [ 'choice' sp ] delay ")" syntax-pack ,
+    "[[" 'factor-code' "]]" syntax-pack ,
+  ] seq* [ first2 <ebnf-action> ] action ;
+   
+
+: 'ensure-not' ( -- parser )
+  #! Parses the '!' syntax to ensure that 
+  #! something that matches the following elements do
+  #! not exist in the parse stream.
+  [
+    "!" syntax ,
+    'group' sp ,
+  ] seq* [ first <ebnf-ensure-not> ] action ;
 
 : 'sequence' ( -- parser )
+  #! A sequence of terminals and non-terminals, including
+  #! groupings of those. 
   [ 
+    'ensure-not' sp ,
     'element' sp ,
     'group' sp , 
     'repeat0' sp ,
+    'repeat1' sp ,
     'optional' sp , 
-   ] { } make  choice  
+    'action' sp , 
-   repeat1 [ 
+  ] choice* repeat1 [ 
      dup length 1 = [ first ] [ <ebnf-sequence> ] if
-   ] action ;  
+  ] action ;  
 
 : 'choice' ( -- parser )
   'sequence' sp "|" token sp list-of [ 
     dup length 1 = [ first ] [ <ebnf-choice> ] if
-   ] action ;
+  ] action ;
-
-: 'action' ( -- parser )
-  "=>" token hide
-  [ blank? ] satisfy ensure-not [ drop t ] satisfy 2array seq [ first ] action repeat1 [ >string ] action sp
-  2array seq [ first <ebnf-action> ] action ;
-  
-: 'rhs' ( -- parser )
-  'choice' 'action' sp optional 2array seq ;
  
 : 'rule' ( -- parser )
-  'non-terminal' [ ebnf-non-terminal-symbol ] action 
+  [
-  "=" token sp hide 
+    'non-terminal' [ ebnf-non-terminal-symbol ] action  ,
-  'rhs' 
+    "=" syntax  ,
-  3array seq [ first2 <ebnf-rule> ] action ;
+    'choice'  ,
+  ] seq* [ first2 <ebnf-rule> ] action ;
 
 : 'ebnf' ( -- parser )
-  'rule' sp "." token sp hide list-of [ <ebnf> ] action ;
+  'rule' sp repeat1 [ <ebnf> ] action ;
 
 : ebnf>quot ( string -- quot )
   'ebnf' parse [
@@ -182,4 +279,4 @@ DEFER: 'choice'
     f
    ] if* ;
 
-: <EBNF "EBNF>" parse-tokens " " join ebnf>quot call ; parsing
+: <EBNF "EBNF>" parse-multiline-string ebnf>quot call ; parsing

extra/peg/expr/authors.txt

@@ -0,0 +1 @@
+Chris Double

extra/peg/expr/expr.factor

@@ -0,0 +1,30 @@
+! Copyright (C) 2008 Chris Double.
+! See http://factorcode.org/license.txt for BSD license.
+USING: kernel arrays strings math.parser sequences
+peg peg.ebnf peg.parsers memoize math ;
+IN: peg.expr
+
+: operator-fold ( lhs seq -- value )
+ #! Perform a fold of a lhs, followed by a sequence of pairs being
+ #! { operator rhs } in to a tree structure of the correct precedence.
+ swap [ first2 swap call ] reduce ;
+
+<EBNF
+
+times    = ("*") [[ drop [ * ] ]]
+divide   = ("/") [[ drop [ / ] ]]
+add      = ("+") [[ drop [ + ] ]]
+subtract = ("-") [[ drop [ - ] ]]
+
+digit    = "0" | "1" | "2" | "3" | "4" |
+           "5" | "6" | "7" | "8" | "9" 
+number   = ((digit)+) [[ concat string>number ]]
+
+value    = number | ("(" expr ")") [[ second ]] 
+product = (value ((times | divide) value)*) [[ first2 operator-fold ]]
+sum = (product ((add | subtract) product)*) [[ first2 operator-fold ]]
+expr = sum
+EBNF>
+
+: eval-expr ( string -- number )
+  expr parse parse-result-ast ;

extra/peg/expr/summary.txt

@@ -0,0 +1 @@
+Simple expression evaluator using EBNF

extra/peg/expr/tags.txt

@@ -0,0 +1 @@
+parsing

extra/peg/pl0/pl0-tests.factor

@@ -1,7 +1,7 @@
 ! Copyright (C) 2007 Chris Double.
 ! See http://factorcode.org/license.txt for BSD license.
 !
-USING: kernel tools.test peg peg.pl0 ;
+USING: kernel tools.test peg peg.pl0 multiline sequences ;
 IN: peg.pl0.tests
 
 { "abc" } [
@@ -11,3 +11,89 @@ IN: peg.pl0.tests
 { 55 } [
   "55abc" number parse parse-result-ast 
 ] unit-test
+
+{ t } [
+  <"
+VAR x, squ;
+
+PROCEDURE square;
+BEGIN
+   squ := x * x
+END;
+
+BEGIN
+   x := 1;
+   WHILE x <= 10 DO
+   BEGIN
+      CALL square;
+      x := x + 1;
+   END
+END.
+"> program parse parse-result-remaining empty?
+] unit-test
+
+{ f } [
+  <"
+CONST
+  m =  7,
+  n = 85;
+
+VAR
+  x, y, z, q, r;
+
+PROCEDURE multiply;
+VAR a, b;
+
+BEGIN
+  a := x;
+  b := y;
+  z := 0;
+  WHILE b > 0 DO BEGIN
+    IF ODD b THEN z := z + a;
+    a := 2 * a;
+    b := b / 2;
+  END
+END;
+
+PROCEDURE divide;
+VAR w;
+BEGIN
+  r := x;
+  q := 0;
+  w := y;
+  WHILE w <= r DO w := 2 * w;
+  WHILE w > y DO BEGIN
+    q := 2 * q;
+    w := w / 2;
+    IF w <= r THEN BEGIN
+      r := r - w;
+      q := q + 1
+    END
+  END
+END;
+
+PROCEDURE gcd;
+VAR f, g;
+BEGIN
+  f := x;
+  g := y;
+  WHILE f # g DO BEGIN
+    IF f < g THEN g := g - f;
+    IF g < f THEN f := f - g;
+  END;
+  z := f
+END;
+
+BEGIN
+  x := m;
+  y := n;
+  CALL multiply;
+  x := 25;
+  y :=  3;
+  CALL divide;
+  x := 84;
+  y := 36;
+  CALL gcd;
+END.
+  "> program parse parse-result-remaining empty?
+] unit-test

extra/peg/pl0/pl0.factor

@@ -1,30 +1,31 @@
 ! Copyright (C) 2007 Chris Double.
 ! See http://factorcode.org/license.txt for BSD license.
 USING: kernel arrays strings math.parser sequences
-peg peg.ebnf peg.parsers memoize ;
+peg peg.ebnf peg.parsers memoize namespaces ;
 IN: peg.pl0
 
 #! Grammar for PL/0 based on http://en.wikipedia.org/wiki/PL/0
 MEMO: ident ( -- parser )
-  CHAR: a CHAR: z range 
+  [
-  CHAR: A CHAR: Z range 2array choice repeat1 
+    CHAR: a CHAR: z range ,
-  [ >string ] action ;
+    CHAR: A CHAR: Z range ,
+  ] choice* repeat1 [ >string ] action ;
 
 MEMO: number ( -- parser )
   CHAR: 0 CHAR: 9 range repeat1 [ string>number ] action ;
 
 <EBNF
-program = block '.' .
+program = block "." 
-block = [ 'const' ident '=' number { ',' ident '=' number } ';' ]
+block = [ "CONST" ident "=" number { "," ident "=" number } ";" ]
-        [ 'var' ident { ',' ident } ';' ]
+        [ "VAR" ident { "," ident } ";" ]
-        { 'procedure' ident ';' [ block ';' ] } statement .
+        { "PROCEDURE" ident ";" [ block ";" ] } statement 
-statement = [ ident ':=' expression | 'call' ident |
+statement = [ ident ":=" expression | "CALL" ident |
-              'begin' statement {';' statement } 'end' |
+              "BEGIN" statement {";" statement } "END" |
-              'if' condition 'then' statement |
+              "IF" condition "THEN" statement |
-              'while' condition 'do' statement ] .
+              "WHILE" condition "DO" statement ] 
-condition = 'odd' expression |
+condition = "ODD" expression |
-            expression ('=' | '#' | '<=' | '<' | '>=' | '>') expression .
+            expression ("=" | "#" | "<=" | "<" | ">=" | ">") expression 
-expression = ['+' | '-'] term {('+' | '-') term } .
+expression = ["+" | "-"] term {("+" | "-") term } 
-term = factor {('*' | '/') factor } .
+term = factor {("*" | "/") factor } 
-factor = ident | number | '(' expression ')'
+factor = ident | number | "(" expression ")"
 EBNF>

extra/tools/deploy/deploy-tests.factor

@@ -1,6 +1,7 @@
 IN: tools.deploy.tests
 USING: tools.test system io.files kernel tools.deploy.config
-tools.deploy.backend math sequences io.launcher arrays ;
+tools.deploy.backend math sequences io.launcher arrays
+namespaces ;
 
 : shake-and-bake ( vocab -- )
     "." resource-path [
@@ -26,6 +27,10 @@ tools.deploy.backend math sequences io.launcher arrays ;
 
 [ ] [ "hello-ui" shake-and-bake ] unit-test
 
+[ "staging.math-compiler-ui-strip.image" ] [
+    "hello-ui" deploy-config [ staging-image-name ] bind
+] unit-test
+
 [ t ] [
     2000000 small-enough?
 ] unit-test

extra/tools/deploy/shaker/strip-libc.factor

@@ -1,10 +1,10 @@
 USING: libc.private ;
 IN: libc
 
-: malloc (malloc) ;
+: malloc (malloc) check-ptr ;
+
+: realloc (realloc) check-ptr ;
+
+: calloc (calloc) check-ptr ;
 
 : free (free) ;
-
-: realloc (realloc) ;
-
-: calloc (calloc) ;

extra/tools/vocabs/browser/browser.factor

@@ -127,7 +127,7 @@ C: <vocab-author> vocab-author
 : $describe-vocab ( element -- )
     first
     dup describe-children
-    dup vocab-root over vocab-dir? [
+    dup find-vocab-root [
         dup describe-summary
         dup describe-tags
         dup describe-authors

extra/tools/vocabs/vocabs.factor

@@ -6,29 +6,27 @@ memoize inspector sorting splitting combinators source-files
 io debugger continuations compiler.errors init io.crc32 ;
 IN: tools.vocabs
 
-: vocab-tests-file, ( vocab -- )
+: vocab-tests-file ( vocab -- path )
-    dup "-tests.factor" vocab-dir+ vocab-path+
+    dup "-tests.factor" vocab-dir+ vocab-path+ dup
-    dup resource-exists? [ , ] [ drop ] if ;
+    [ dup resource-exists? [ drop f ] unless ] [ drop f ] if ;
 
-: vocab-tests-dir, ( vocab -- )
+: vocab-tests-dir ( vocab -- paths )
-    dup vocab-dir "tests" path+ vocab-path+
+    dup vocab-dir "tests" path+ vocab-path+ dup [
-    dup resource-exists? [
+        dup resource-exists? [
-        dup ?resource-path directory keys
+            dup ?resource-path directory keys
-        [ ".factor" tail? ] subset
+            [ ".factor" tail? ] subset
-        [ path+ , ] with each
+            [ path+ ] with map
-    ] [ drop ] if ;
+        ] [ drop f ] if
+    ] [ drop f ] if ;
 
 : vocab-tests ( vocab -- tests )
-    dup vocab-root dup [
+    [
-        [
+        dup vocab-tests-file [ , ] when*
-            >vocab-link dup
+        vocab-tests-dir [ % ] when*
-            vocab-tests-file,
+    ] { } make ;
-            vocab-tests-dir,
-        ] { } make
-    ] [ 2drop f ] if ;
 
 : vocab-files ( vocab -- seq )
-    dup find-vocab-root >vocab-link [
+    [
         dup vocab-source-path [ , ] when*
         dup vocab-docs-path [ , ] when*
         vocab-tests %
@@ -53,12 +51,8 @@ IN: tools.vocabs
 : modified-docs ( vocabs -- seq )
     [ vocab-docs-path ] modified ;
 
-: update-roots ( vocabs -- )
-    [ dup find-vocab-root swap vocab set-vocab-root ] each ;
-
 : to-refresh ( prefix -- modified-sources modified-docs )
     child-vocabs
-    dup update-roots
     dup modified-sources swap modified-docs ;
 
 : vocab-heading. ( vocab -- )
@@ -180,7 +174,7 @@ M: vocab-link summary vocab-summary ;
 
 : vocabs-in-dir ( root name -- )
     dupd (all-child-vocabs) [
-        2dup vocab-dir? [ 2dup swap >vocab-link , ] when
+        2dup vocab-dir? [ dup >vocab-link , ] when
         vocabs-in-dir
     ] with each ;
 
@@ -233,7 +227,7 @@ MEMO: all-vocabs-seq ( -- seq )
 : unrooted-child-vocabs ( prefix -- seq )
     dup empty? [ CHAR: . add ] unless
     vocabs
-    [ vocab-root not ] subset
+    [ find-vocab-root not ] subset
     [
         vocab-name swap ?head CHAR: . rot member? not and
     ] with subset
@@ -241,10 +235,9 @@ MEMO: all-vocabs-seq ( -- seq )
 
 : all-child-vocabs ( prefix -- assoc )
     vocab-roots get [
-        over dupd dupd (all-child-vocabs)
+        dup pick (all-child-vocabs) [ >vocab-link ] map
-        swap [ >vocab-link ] curry map
     ] { } map>assoc
-    f rot unrooted-child-vocabs 2array add ;
+    swap unrooted-child-vocabs f swap 2array add ;
 
 : all-child-vocabs-seq ( prefix -- assoc )
     vocab-roots get swap [
@@ -262,6 +255,7 @@ MEMO: all-authors ( -- seq )
     all-vocabs-seq [ vocab-authors ] map>set ;
 
 : reset-cache ( -- )
+    root-cache get-global clear-assoc
     \ (vocab-file-contents) reset-memoized
     \ all-vocabs-seq reset-memoized
     \ all-authors reset-memoized

extra/tools/walker/walker.factor

@@ -30,8 +30,6 @@ DEFER: start-walker-thread
         2dup start-walker-thread
     ] if* ;
 
-USING: io.streams.c prettyprint ;
-
 : show-walker ( -- thread )
     get-walker-thread
     [ show-walker-hook get call ] keep ;
@@ -40,7 +38,7 @@ USING: io.streams.c prettyprint ;
     {
         { [ dup continuation? ] [ (continue) ] }
         { [ dup quotation? ] [ call ] }
-        { [ dup not ] [ "Single stepping abandoned" throw ] }
+        { [ dup not ] [ "Single stepping abandoned" rethrow ] }
     } cond ;
 
 : break ( -- )

extra/ui/cocoa/cocoa.factor

@@ -1,4 +1,4 @@
-! Copyright (C) 2006, 2007 Slava Pestov.
+! Copyright (C) 2006, 2008 Slava Pestov.
 ! See http://factorcode.org/license.txt for BSD license.
 USING: math arrays cocoa cocoa.application command-line
 kernel memory namespaces cocoa.messages cocoa.runtime
@@ -8,6 +8,10 @@ ui.clipboards ui.gadgets ui.gadgets.worlds ui.cocoa.views
 core-foundation threads ;
 IN: ui.cocoa
 
+TUPLE: handle view window ;
+
+C: <handle> handle
+
 TUPLE: cocoa-ui-backend ;
 
 SYMBOL: stop-after-last-window?
@@ -47,27 +51,30 @@ M: pasteboard set-clipboard-contents
         dup rot world>NSRect <ViewWindow>
         dup install-window-delegate
         over -> release
-        2array
+        <handle>
     ] keep set-world-handle ;
 
 M: cocoa-ui-backend set-title ( string world -- )
-    world-handle second swap <NSString> -> setTitle: ;
+    world-handle handle-window swap <NSString> -> setTitle: ;
 
 : enter-fullscreen ( world -- )
-    world-handle first NSScreen -> mainScreen f -> enterFullScreenMode:withOptions: drop ;
+    world-handle handle-view
+    NSScreen -> mainScreen
+    f -> enterFullScreenMode:withOptions:
+    drop ;
 
 : exit-fullscreen ( world -- )
-    world-handle first f -> exitFullScreenModeWithOptions: ;
+    world-handle handle-view f -> exitFullScreenModeWithOptions: ;
 
 M: cocoa-ui-backend set-fullscreen* ( ? world -- )
     swap [ enter-fullscreen ] [ exit-fullscreen ] if ;
 
 M: cocoa-ui-backend fullscreen* ( world -- ? )
-    world-handle first -> isInFullScreenMode zero? not ;
+    world-handle handle-view -> isInFullScreenMode zero? not ;
 
 : auto-position ( world -- )
     dup world-loc { 0 0 } = [
-        world-handle second -> center
+        world-handle handle-window -> center
     ] [
         drop
     ] if ;
@@ -75,27 +82,29 @@ M: cocoa-ui-backend fullscreen* ( world -- ? )
 M: cocoa-ui-backend (open-window) ( world -- )
     dup gadget-window
     dup auto-position
-    world-handle second f -> makeKeyAndOrderFront: ;
+    world-handle handle-window f -> makeKeyAndOrderFront: ;
 
 M: cocoa-ui-backend (close-window) ( handle -- )
-    first unregister-window ;
+    handle-window -> release ;
 
 M: cocoa-ui-backend close-window ( gadget -- )
     find-world [
-        world-handle second f -> performClose:
+        world-handle [
+            handle-window f -> performClose:
+        ] when*
     ] when* ;
 
 M: cocoa-ui-backend raise-window* ( world -- )
     world-handle [
-        second dup f -> orderFront: -> makeKeyWindow
+        handle-window dup f -> orderFront: -> makeKeyWindow
         NSApp 1 -> activateIgnoringOtherApps:
     ] when* ;
 
 M: cocoa-ui-backend select-gl-context ( handle -- )
-    first -> openGLContext -> makeCurrentContext ;
+    handle-view -> openGLContext -> makeCurrentContext ;
 
 M: cocoa-ui-backend flush-gl-context ( handle -- )
-    first -> openGLContext -> flushBuffer ;
+    handle-view -> openGLContext -> flushBuffer ;
 
 SYMBOL: cocoa-init-hook
 

extra/ui/cocoa/views/views.factor

@@ -313,6 +313,7 @@ CLASS: {
 { "dealloc" "void" { "id" "SEL" }
     [
         drop
+        dup unregister-window
         dup remove-observer
         SUPER-> dealloc
     ]
@@ -349,7 +350,13 @@ CLASS: {
 
 { "windowShouldClose:" "bool" { "id" "SEL" "id" }
     [
-        2nip -> contentView window ungraft t
+        3drop t
+    ]
+}
+
+{ "windowWillClose:" "void" { "id" "SEL" "id" }
+    [
+        2nip -> object -> contentView window ungraft
     ]
 } ;
 

extra/ui/windows/windows.factor

@@ -376,22 +376,6 @@ SYMBOL: trace-messages?
 
 : peek-message? ( msg -- ? ) f 0 0 PM_REMOVE PeekMessage zero? ;
 
-! ! ! !
-: set-world-dim ( dim world -- )
-    swap >r world-handle win-hWnd HWND_TOP 20 20 r> first2 0
-    SetWindowPos drop ;
-USE: random
-USE: arrays
-
-: twiddle
-    100 500 random +
-    100 500 random +
-    2array
-    "x" get-global find-world
-    set-world-dim
-    yield ;
-! ! ! !
-
 : event-loop ( msg -- )
     {
         { [ windows get empty? ] [ drop ] }

extra/windows/ce/ce.factor

@@ -11,4 +11,5 @@ USING: alien sequences ;
     ! { "gl"       "libGLES_CM.dll"         "stdcall" }
     ! { "glu"      "libGLES_CM.dll"         "stdcall" }
     ! { "freetype" "libfreetype-6.dll"      "stdcall" }
+    { "ole32"    "ole32.dll"    "stdcall" }
 } [ first3 add-library ] each

extra/windows/com/authors.txt

@@ -0,0 +1 @@
+Joe Groff

extra/windows/com/com-docs.factor

@@ -0,0 +1,15 @@
+USING: help.markup help.syntax io kernel math quotations
+multiline ;
+IN: windows.com
+
+HELP: com-query-interface
+{ $values { "interface" "Pointer to a COM interface implementing " { $snippet "IUnknown" } } { "iid" "An interface GUID (IID)" } { "interface'" "Pointer to a COM interface implementing the interface indicated by " { $snippet "iid" } } }
+{ $description "A small wrapper around " { $link IUnknown::QueryInterface } ". Queries " { $snippet "interface" } " to see if it implements the interface indicated by " { $snippet "iid" } ". Returns a pointer to the " { $snippet "iid" } " interface if implemented, or raises an error if the object does not implement the interface.\n\nCOM memory management conventions state that the returned pointer must be immediately retained using " { $link com-add-ref } ". The pointer must then be released using " { $link com-release } " when it is no longer needed." } ;
+
+HELP: com-add-ref
+{ $values { "interface" "Pointer to a COM interface implementing " { $snippet "IUnknown" } } }
+{ $description "A small wrapper around " { $link IUnknown::AddRef } ". Increments the reference count on " { $snippet "interface" } ", keeping it on the stack. The reference count must be decremented with " { $link com-release } " when the reference is no longer held." } ;
+
+HELP: com-release
+{ $values { "interface" "Pointer to a COM interface implementing " { $snippet "IUnknown" } } }
+{ $description "A small wrapper around " { $link IUnknown::Release } ". Decrements the reference count on " { $snippet "interface" } ", releasing the underlying object if the reference count has reached zero." } ;

extra/windows/com/com-tests.factor

@@ -0,0 +1,93 @@
+USING: kernel windows.com windows.com.syntax windows.ole32
+alien alien.syntax tools.test libc alien.c-types arrays.lib 
+namespaces arrays continuations ;
+IN: windows.com.tests
+
+! Create some test COM interfaces
+
+COM-INTERFACE: ISimple IUnknown {216fb341-0eb2-44b1-8edb-60b76e353abc}
+    HRESULT returnOK ( )
+    HRESULT returnError ( ) ;
+
+COM-INTERFACE: IInherited ISimple {9620ecec-8438-423b-bb14-86f835aa40dd}
+    int getX ( )
+    void setX ( int newX ) ;
+
+! Implement the IInherited interface in factor using alien-callbacks
+
+C-STRUCT: test-implementation
+    { "void*" "vtbl" }
+    { "int" "x" } ;
+
+: QueryInterface-callback
+    "HRESULT" { "void*" "REFGUID" "void**" } "stdcall" [ nip 0 swap set-void*-nth S_OK ]
+    alien-callback ;
+: AddRef-callback
+    "ULONG" { "void*" } "stdcall" [ drop 2 ]
+    alien-callback ;
+: Release-callback
+    "ULONG" { "void*" } "stdcall" [ drop 1 ]
+    alien-callback ;
+: returnOK-callback
+    "HRESULT" { "void*" } "stdcall" [ drop S_OK ]
+    alien-callback ;
+: returnError-callback
+    "HRESULT" { "void*" } "stdcall" [ drop E_FAIL ]
+    alien-callback ;
+: getX-callback
+    "int" { "void*" } "stdcall" [ test-implementation-x ]
+    alien-callback ;
+: setX-callback
+    "void" { "void*" "int" } "stdcall" [ swap set-test-implementation-x ]
+    alien-callback ;
+
+SYMBOL: +test-implementation-vtbl+
+SYMBOL: +guinea-pig-implementation+
+
+: (make-test-implementation) ( x imp -- imp )
+    [ set-test-implementation-x ] keep
+    +test-implementation-vtbl+ get over set-test-implementation-vtbl ;
+
+: <test-implementation> ( x -- imp )
+    "test-implementation" <c-object> (make-test-implementation) ;
+
+: <malloced-test-implementation> ( x -- imp )
+    "test-implementation" heap-size malloc (make-test-implementation) ;
+
+QueryInterface-callback
+AddRef-callback
+Release-callback
+returnOK-callback
+returnError-callback
+getX-callback
+setX-callback
+7 narray >c-void*-array
+dup byte-length [
+    [ byte-array>memory ] keep
+    +test-implementation-vtbl+ set
+
+    ! Test that the words defined by COM-INTERFACE: do their magic
+
+    "{216fb341-0eb2-44b1-8edb-60b76e353abc}" string>guid 1array [ ISimple-iid ] unit-test
+    "{9620ecec-8438-423b-bb14-86f835aa40dd}" string>guid 1array [ IInherited-iid ] unit-test
+    "{00000000-0000-0000-C000-000000000046}" string>guid 1array [ IUnknown-iid ] unit-test
+    S_OK 1array [ 0 <test-implementation> ISimple::returnOK ] unit-test
+    E_FAIL <long> *long 1array [ 0 <test-implementation> ISimple::returnError ] unit-test
+    1984 1array [ 0 <test-implementation> dup 1984 IInherited::setX IInherited::getX ] unit-test
+
+    ! Test that the helper functions for QueryInterface, AddRef, Release work
+
+    0 <malloced-test-implementation> +guinea-pig-implementation+ set
+    [
+        +guinea-pig-implementation+ get 1array [
+            +guinea-pig-implementation+ get com-add-ref
+        ] unit-test
+
+        { } [ +guinea-pig-implementation+ get com-release ] unit-test
+
+        +guinea-pig-implementation+ get 1array [
+            +guinea-pig-implementation+ get IUnknown-iid com-query-interface
+        ] unit-test
+
+    ] [ +guinea-pig-implementation+ get free ] [ ] cleanup
+] with-malloc

extra/windows/com/com.factor

@@ -0,0 +1,22 @@
+USING: alien alien.c-types windows.com.syntax windows.ole32
+windows.types continuations kernel ;
+IN: windows.com
+
+COM-INTERFACE: IUnknown f {00000000-0000-0000-C000-000000000046}
+    HRESULT QueryInterface ( REFGUID iid, void** ppvObject )
+    ULONG AddRef ( )
+    ULONG Release ( ) ;
+
+: com-query-interface ( interface iid -- interface' )
+    f <void*>
+    [ IUnknown::QueryInterface ole32-error ] keep
+    *void* ;
+
+: com-add-ref ( interface -- interface )
+     [ IUnknown::AddRef drop ] keep ; inline
+
+: com-release ( interface -- )
+    IUnknown::Release drop ; inline
+
+: with-com-interface ( interface quot -- )
+    [ keep ] [ com-release ] [ ] cleanup ; inline

extra/windows/com/summary.txt

@@ -0,0 +1 @@
+COM interface

extra/windows/com/syntax/authors.txt

@@ -0,0 +1 @@
+Joe Groff

extra/windows/com/syntax/summary.txt

@@ -0,0 +1 @@
+Parsing words for defining COM interfaces

extra/windows/com/syntax/syntax-docs.factor

@@ -0,0 +1,26 @@
+USING: help.markup help.syntax io kernel math quotations
+multiline ;
+IN: windows.com.syntax
+
+HELP: COM-INTERFACE:
+{ $syntax <"
+COM-INTERFACE: <interface> <parent> <iid>
+    <function-1> ( <params1> )
+    <function-2> ( <params2> )
+    ... ;
+"> }
+{ $description "\nFor the interface " { $snippet "<interface>" } ", a word " { $snippet "<interface>-iid ( -- iid )" } " is defined to push the interface GUID (IID) onto the stack. Words of the form " { $snippet "<interface>::<function>" } " are also defined to invoke each method, as well as the methods inherited from " { $snippet "<parent>" } ". A " { $snippet "<parent>" } " of " { $snippet "f" } " indicates that the interface is a root interface. (Note that COM conventions demand that all interfaces at least inherit from " { $snippet "IUnknown" } ".)\n\nExample:" }
+{ $code <"
+COM-INTERFACE: IUnknown f {00000000-0000-0000-C000-000000000046}
+    HRESULT QueryInterface ( REFGUID iid, void** ppvObject )
+    ULONG AddRef ( )
+    ULONG Release ( ) ;
+
+COM-INTERFACE: ISimple IUnknown {216fb341-0eb2-44b1-8edb-60b76e353abc}
+    HRESULT returnOK ( )
+    HRESULT returnError ( ) ;
+
+COM-INTERFACE: IInherited ISimple {9620ecec-8438-423b-bb14-86f835aa40dd}
+    int getX ( )
+    void setX ( int newX ) ;
+"> } ;

extra/windows/com/syntax/syntax.factor

@@ -0,0 +1,90 @@
+USING: alien alien.c-types kernel windows.ole32
+combinators.lib parser splitting sequences.lib
+sequences namespaces new-slots combinators.cleave
+assocs quotations shuffle accessors words macros
+alien.syntax fry ;
+IN: windows.com.syntax
+
+<PRIVATE
+
+C-STRUCT: com-interface
+    { "void*" "vtbl" } ;
+
+MACRO: com-invoke ( n return parameters -- )
+    dup length -roll
+    '[
+        , npick com-interface-vtbl , swap void*-nth , ,
+        "stdcall" alien-indirect
+    ] ;
+
+TUPLE: com-interface-definition name parent iid functions ;
+C: <com-interface-definition> com-interface-definition
+
+TUPLE: com-function-definition name return parameters ;
+C: <com-function-definition> com-function-definition
+
+SYMBOL: +com-interface-definitions+
++com-interface-definitions+ get-global
+[ H{ } +com-interface-definitions+ set-global ]
+unless
+
+: find-com-interface-definition ( name -- definition )
+    dup "f" = [ drop f ] [
+        dup +com-interface-definitions+ get-global at*
+        [ nip ]
+        [ swap " COM interface hasn't been defined" append throw ]
+        if
+    ] if ;
+
+: save-com-interface-definition ( definition -- )
+    dup name>> +com-interface-definitions+ get-global set-at ;
+
+: (parse-com-function) ( tokens -- definition )
+    [ second ]
+    [ first ]
+    [ 3 tail 2 group [ first ] map "void*" add* ]
+    tri
+    <com-function-definition> ;
+
+: parse-com-functions ( -- functions )
+    ";" parse-tokens { ")" } split
+    [ empty? not ] subset
+    [ (parse-com-function) ] map ;
+
+: (iid-word) ( definition -- word )
+    name>> "-iid" append create-in ;
+
+: (function-word) ( function interface -- word )
+    name>> "::" rot name>> 3append create-in ;
+
+: all-functions ( definition -- functions )
+    dup parent>> [ all-functions ] [ { } ] if*
+    swap functions>> append ;
+
+: (define-word-for-function) ( function interface n -- )
+    -rot [ (function-word) swap ] 2keep drop
+    { return>> parameters>> } get-slots
+    [ com-invoke ] 3curry
+    define ;
+
+: define-words-for-com-interface ( definition -- )
+    [ [ (iid-word) ] [ iid>> 1quotation ] bi define ]
+    [ name>> "com-interface" swap typedef ]
+    [
+        dup all-functions
+        [ (define-word-for-function) ] with each-index
+    ]
+    tri ;
+
+PRIVATE>
+
+: COM-INTERFACE:
+    scan
+    scan find-com-interface-definition
+    scan string>guid
+    parse-com-functions
+    <com-interface-definition>
+    dup save-com-interface-definition
+    define-words-for-com-interface
+    ; parsing
+

extra/windows/com/syntax/tags.txt

@@ -0,0 +1,3 @@
+windows
+com
+bindings

extra/windows/com/tags.txt

@@ -0,0 +1,3 @@
+windows
+com
+bindings

extra/windows/nt/nt.factor

@@ -12,4 +12,5 @@ USING: alien sequences ;
     { "gl"       "opengl32.dll" "stdcall" }
     { "glu"      "glu32.dll"    "stdcall" }
     { "freetype" "freetype6.dll" "cdecl"  }
+    { "ole32"    "ole32.dll"    "stdcall" }
 } [ first3 add-library ] each

extra/windows/ole32/authors.txt

@@ -0,0 +1 @@
+Joe Groff

extra/windows/ole32/ole32.factor

@@ -0,0 +1,59 @@
+USING: alien alien.syntax alien.c-types math kernel sequences
+windows windows.types combinators.lib ;
+IN: windows.ole32
+
+LIBRARY: ole32
+
+C-STRUCT: GUID
+    { "DWORD" "part1" }
+    { "DWORD" "part2" }
+    { "DWORD" "part3" }
+    { "DWORD" "part4" } ;
+
+TYPEDEF: void* REFGUID
+TYPEDEF: void* LPUNKNOWN
+TYPEDEF: ushort* LPOLESTR
+TYPEDEF: ushort* LPCOLESTR
+
+TYPEDEF: REFGUID REFIID
+TYPEDEF: REFGUID REFCLSID
+
+FUNCTION: HRESULT CoCreateInstance ( REFGUID rclsid, LPUNKNOWN pUnkOuter, DWORD dwClsContext, REFGUID riid, LPUNKNOWN out_ppv ) ;
+FUNCTION: BOOL IsEqualGUID ( REFGUID rguid1, REFGUID rguid2 ) ;
+FUNCTION: int StringFromGUID2 ( REFGUID rguid, LPOLESTR lpsz, int cchMax ) ;
+FUNCTION: HRESULT CLSIDFromString ( LPOLESTR lpsz, REFGUID out_rguid ) ;
+
+: S_OK 0 ; inline
+: S_FALSE 1 ; inline
+: E_FAIL HEX: 80004005 ; inline
+: E_INVALIDARG HEX: 80070057 ; inline
+
+: MK_ALT HEX: 20 ; inline
+: DROPEFFECT_NONE 0 ; inline
+: DROPEFFECT_COPY 1 ; inline
+: DROPEFFECT_MOVE 2 ; inline
+: DROPEFFECT_LINK 4 ; inline
+: DROPEFFECT_SCROLL HEX: 80000000 ; inline
+: DD_DEFSCROLLINSET 11 ; inline
+: DD_DEFSCROLLDELAY 50 ; inline
+: DD_DEFSCROLLINTERVAL 50 ; inline
+: DD_DEFDRAGDELAY 200 ; inline
+: DD_DEFDRAGMINDIST 2 ; inline
+
+: ole32-error ( n -- )
+    dup S_OK = [
+        drop
+    ] [ (win32-error-string) throw ] if ;
+
+: guid= ( a b -- ? )
+    IsEqualGUID c-bool> ;
+
+: GUID-STRING-LENGTH
+    "{01234567-89ab-cdef-0123-456789abcdef}" length ; inline
+
+: string>guid ( string -- guid )
+    string>u16-alien "GUID" <c-object> [ CLSIDFromString ole32-error ] keep ;
+: guid>string ( guid -- string )
+    GUID-STRING-LENGTH 1+ [ "ushort" <c-array> ] keep
+    [ StringFromGUID2 drop ] { 2 } multikeep alien>u16-string ;
+

extra/windows/shell32/shell32.factor

@@ -1,5 +1,6 @@
 USING: alien alien.c-types alien.syntax combinators
-kernel windows windows.user32 ;
+kernel windows windows.user32 windows.ole32
+windows.com windows.com.syntax ;
 IN: windows.shell32
 
 : CSIDL_DESKTOP HEX: 00 ; inline
@@ -68,10 +69,6 @@ IN: windows.shell32
 : CSIDL_FLAG_MASK HEX: ff00 ; inline
 
 
-: S_OK 0 ; inline
-: S_FALSE 1 ; inline
-: E_FAIL HEX: 80004005 ; inline
-: E_INVALIDARG HEX: 80070057 ; inline
 : ERROR_FILE_NOT_FOUND 2 ; inline
 
 : SHGFP_TYPE_CURRENT 0 ; inline
@@ -89,15 +86,7 @@ FUNCTION: HINSTANCE ShellExecuteW ( HWND hwnd, LPCTSTR lpOperation, LPCTSTR lpFi
     f "open" rot f f SW_SHOWNORMAL ShellExecute drop ;
 
 : shell32-error ( n -- )
-    dup S_OK = [
+    ole32-error ; inline
-        drop
-    ] [
-        {
-            ! { ERROR_FILE_NOT_FOUND [ "file not found" throw ] }
-            ! { E_INVALIDARG [ "invalid arg" throw ] }
-            [ (win32-error-string) throw ]
-        } case
-    ] if ;
 
 : shell32-directory ( n -- str )
     f swap f SHGFP_TYPE_DEFAULT
@@ -130,3 +119,96 @@ FUNCTION: HINSTANCE ShellExecuteW ( HWND hwnd, LPCTSTR lpOperation, LPCTSTR lpFi
 
 : program-files-common-x86 ( -- str )
     CSIDL_PROGRAM_FILES_COMMONX86 shell32-directory ;
+
+: SHCONTF_FOLDERS 32 ; inline
+: SHCONTF_NONFOLDERS 64 ; inline
+: SHCONTF_INCLUDEHIDDEN 128 ; inline
+: SHCONTF_INIT_ON_FIRST_NEXT 256 ; inline
+: SHCONTF_NETPRINTERSRCH 512 ; inline
+: SHCONTF_SHAREABLE 1024 ; inline
+: SHCONTF_STORAGE 2048 ; inline
+
+TYPEDEF: DWORD SHCONTF
+
+: SHGDN_NORMAL 0 ; inline
+: SHGDN_INFOLDER 1 ; inline
+: SHGDN_FOREDITING HEX: 1000 ; inline
+: SHGDN_INCLUDE_NONFILESYS HEX: 2000 ; inline
+: SHGDN_FORADDRESSBAR HEX: 4000 ; inline
+: SHGDN_FORPARSING HEX: 8000 ; inline
+
+TYPEDEF: DWORD SHGDNF
+
+: SFGAO_CANCOPY           DROPEFFECT_COPY ; inline
+: SFGAO_CANMOVE           DROPEFFECT_MOVE ; inline
+: SFGAO_CANLINK           DROPEFFECT_LINK ; inline
+: SFGAO_CANRENAME         HEX: 00000010 ; inline
+: SFGAO_CANDELETE         HEX: 00000020 ; inline
+: SFGAO_HASPROPSHEET      HEX: 00000040 ; inline
+: SFGAO_DROPTARGET        HEX: 00000100 ; inline
+: SFGAO_CAPABILITYMASK    HEX: 00000177 ; inline
+: SFGAO_LINK              HEX: 00010000 ; inline
+: SFGAO_SHARE             HEX: 00020000 ; inline
+: SFGAO_READONLY          HEX: 00040000 ; inline
+: SFGAO_GHOSTED           HEX: 00080000 ; inline
+: SFGAO_HIDDEN            HEX: 00080000 ; inline
+: SFGAO_DISPLAYATTRMASK   HEX: 000F0000 ; inline
+: SFGAO_FILESYSANCESTOR   HEX: 10000000 ; inline
+: SFGAO_FOLDER            HEX: 20000000 ; inline
+: SFGAO_FILESYSTEM        HEX: 40000000 ; inline
+: SFGAO_HASSUBFOLDER      HEX: 80000000 ; inline
+: SFGAO_CONTENTSMASK      HEX: 80000000 ; inline
+: SFGAO_VALIDATE          HEX: 01000000 ; inline
+: SFGAO_REMOVABLE         HEX: 02000000 ; inline
+: SFGAO_COMPRESSED        HEX: 04000000 ; inline
+: SFGAO_BROWSABLE         HEX: 08000000 ; inline
+: SFGAO_NONENUMERATED     HEX: 00100000 ; inline
+: SFGAO_NEWCONTENT        HEX: 00200000 ; inline
+
+TYPEDEF: ULONG SFGAOF
+
+C-STRUCT: SHITEMID
+    { "USHORT" "cb" }
+    { "BYTE[1]" "abID" } ;
+TYPEDEF: SHITEMID* LPSHITEMID
+TYPEDEF: SHITEMID* LPCSHITEMID
+
+C-STRUCT: ITEMIDLIST
+    { "SHITEMID" "mkid" } ;
+TYPEDEF: ITEMIDLIST* LPITEMIDLIST
+TYPEDEF: ITEMIDLIST* LPCITEMIDLIST
+TYPEDEF: ITEMIDLIST ITEMID_CHILD
+TYPEDEF: ITEMID_CHILD* PITEMID_CHILD
+TYPEDEF: ITEMID_CHILD* PCUITEMID_CHILD
+
+: STRRET_WSTR 0 ; inline
+: STRRET_OFFSET 1 ; inline
+: STRRET_CSTR 2 ; inline
+
+C-UNION: STRRET-union "LPWSTR" "LPSTR" "UINT" "char[260]" ;
+C-STRUCT: STRRET
+    { "int" "uType" }
+    { "STRRET-union" "union" } ;
+
+COM-INTERFACE: IEnumIDList IUnknown {000214F2-0000-0000-C000-000000000046}
+    HRESULT Next ( ULONG celt, LPITEMIDLIST* rgelt, ULONG* pceltFetched )
+    HRESULT Skip ( ULONG celt )
+    HRESULT Reset ( )
+    HRESULT Clone ( IEnumIDList** ppenum ) ;
+
+COM-INTERFACE: IShellFolder IUnknown {000214E6-0000-0000-C000-000000000046}
+    HRESULT ParseDisplayName ( HWND hwndOwner, void* pbcReserved, LPOLESTR lpszDisplayName, ULONG* pchEaten, LPITEMIDLIST* ppidl, ULONG* pdwAttributes )
+    HRESULT EnumObjects ( HWND hwndOwner, SHCONTF grfFlags, IEnumIDList** ppenumIDList )
+    HRESULT BindToObject ( LPCITEMIDLIST pidl, void* pbcReserved, REFGUID riid, void** ppvOut )
+    HRESULT BindToStorage ( LPCITEMIDLIST pidl, void* pbcReserved, REFGUID riid, void** ppvObj )
+    HRESULT CompareIDs ( LPARAM lParam, LPCITEMIDLIST pidl1, LPCITEMIDLIST pidl2 )
+    HRESULT CreateViewObject ( HWND hwndOwner, REFGUID riid, void** ppvOut )
+    HRESULT GetAttributesOf ( UINT cidl, LPCITEMIDLIST* apidl, SFGAOF* rgfInOut )
+    HRESULT GetUIObjectOf ( HWND hwndOwner, UINT cidl, LPCITEMIDLIST* apidl, REFGUID riid, UINT* prgfInOut, void** ppvOut )
+    HRESULT GetDisplayNameOf ( LPCITEMIDLIST pidl, SHGDNF uFlags, STRRET* lpName )
+    HRESULT SetNameOf ( HWND hwnd, LPCITEMIDLIST pidl, LPCOLESTR lpszName, SHGDNF uFlags, LPITEMIDLIST* ppidlOut ) ;
+
+FUNCTION: HRESULT SHGetDesktopFolder ( IShellFolder** ppshf ) ;
+
+FUNCTION: HRESULT StrRetToBufW ( STRRET *pstr, PCUITEMID_CHILD pidl, LPWSTR pszBuf, UINT cchBuf ) ;
+: StrRetToBuf StrRetToBufW ; inline