Merge branch 'master' into semantic-db

core/alien/alien.factor

@@ -53,18 +53,11 @@ TUPLE: library path abi dll ;
 
 : library ( name -- library ) libraries get at ;
 
-: <library> ( path abi -- library ) f \ library construct-boa ;
+: <library> ( path abi -- library )
+    over dup [ dlopen ] when \ library construct-boa ;
 
 : load-library ( name -- dll )
-    library dup [
+    library library-dll ;
-        dup library-dll [ ] [
-            dup library-path dup [
-                dlopen dup rot set-library-dll
-            ] [
-                2drop f
-            ] if
-        ] ?if
-    ] when ;
 
 : add-library ( name path abi -- )
     <library> swap libraries get set-at ;

core/alien/compiler/compiler-tests.factor

@@ -315,7 +315,7 @@ FUNCTION: double ffi_test_36 ( test-struct-12 x ) ;
     data-gc ;
 
 [ "Hello world" ] [ 
-    [ callback-4 callback_test_1 ] string-out
+    [ callback-4 callback_test_1 ] with-string-writer
 ] unit-test
 
 : callback-5

core/alien/compiler/compiler.factor

@@ -213,30 +213,37 @@ TUPLE: no-such-library name ;
 M: no-such-library summary
     drop "Library not found" ;
 
+M: no-such-library compiler-error-type
+    drop +linkage+ ;
+
 : no-such-library ( name -- )
-    \ no-such-library +linkage+ (inference-error) ;
+    \ no-such-library construct-boa
+    compiling-word get compiler-error ;
 
-: (alien-invoke-dlsym) ( node -- symbol dll )
+TUPLE: no-such-symbol name ;
-    dup alien-invoke-function
-    swap alien-invoke-library [
-        load-library
-    ] [
-        2drop no-such-library
-    ] recover ;
-
-TUPLE: no-such-symbol ;
 
 M: no-such-symbol summary
     drop "Symbol not found" ;
 
-: no-such-symbol ( -- )
+M: no-such-symbol compiler-error-type
-    \ no-such-symbol +linkage+ (inference-error) ;
+    drop +linkage+ ;
 
-: alien-invoke-dlsym ( node -- symbol dll )
+: no-such-symbol ( name -- )
-    dup (alien-invoke-dlsym) 2dup dlsym [
+    \ no-such-symbol construct-boa
-        >r over stdcall-mangle r> 2dup dlsym
+    compiling-word get compiler-error ;
-        [ no-such-symbol ] unless
+
-    ] unless rot drop ;
+: check-dlsym ( symbols dll -- )
+    dup dll-valid? [
+        dupd [ dlsym ] curry contains?
+        [ drop ] [ no-such-symbol ] if
+    ] [
+        dll-path no-such-library drop
+    ] if ;
+
+: alien-invoke-dlsym ( node -- symbols dll )
+    dup alien-invoke-function dup pick stdcall-mangle 2array
+    swap alien-invoke-library library dup [ library-dll ] when
+    2dup check-dlsym ;
 
 \ alien-invoke [
     ! Four literals
@@ -247,8 +254,6 @@ M: no-such-symbol summary
     pop-literal nip over set-alien-invoke-function
     pop-literal nip over set-alien-invoke-library
     pop-literal nip over set-alien-invoke-return
-    ! If symbol doesn't resolve, no stack effect, no compile
-    dup alien-invoke-dlsym 2drop
     ! Quotation which coerces parameters to required types
     dup make-prep-quot recursive-state get infer-quot
     ! Add node to IR

core/assocs/assocs-docs.factor

@@ -59,6 +59,7 @@ ARTICLE: "assocs-sets" "Set-theoretic operations on assocs"
 { $subsection diff }
 { $subsection remove-all }
 { $subsection substitute }
+{ $subsection substitute-here }
 { $see-also key? } ;
 
 ARTICLE: "assocs-mutation" "Storing keys and values in assocs"
@@ -266,12 +267,16 @@ HELP: remove-all
 { $notes "The values of the keys in the assoc are disregarded, so this word is usually used for set-theoretic calculations where the assoc in question either has dummy sentinels as values, or the values equal the keys." }
 { $side-effects "assoc" } ;
 
-HELP: substitute
+HELP: substitute-here
-{ $values { "assoc" assoc } { "seq" "a mutable sequence" } }
+{ $values { "seq" "a mutable sequence" } { "assoc" assoc } }
-{ $description "Replaces elements of " { $snippet "seq" } " which appear in as keys in " { $snippet "assoc" } " with the corresponding values, acting as the identity on all other elements." }
+{ $description "Replaces elements of " { $snippet "seq" } " which appear as keys in " { $snippet "assoc" } " with the corresponding values, acting as the identity on all other elements." }
 { $errors "Throws an error if " { $snippet "assoc" } " contains values whose types are not permissible in " { $snippet "seq" } "." }
 { $side-effects "seq" } ;
 
+HELP: substitute
+{ $values { "seq" sequence } { "assoc" assoc } { "newseq" sequence } }
+{ $description "Creates a new sequence where elements of " { $snippet "seq" } " which appear as keys in " { $snippet "assoc" } " are replaced by the corresponding values, and all other elements are unchanged." } ;
+
 HELP: cache
 { $values { "key" "a key" } { "assoc" assoc } { "quot" "a quotation with stack effect " { $snippet "( key -- value )" } } { "value" "a previously-retained or freshly-computed value" } }
 { $description "If the key is present in the assoc, outputs the associated value, otherwise calls the quotation to produce a value and stores the key/value pair into the assoc." }

core/assocs/assocs.factor

@@ -124,8 +124,14 @@ M: assoc assoc-clone-like ( assoc exemplar -- newassoc )
 : remove-all ( assoc seq -- subseq )
     swap [ key? not ] curry subset ;
 
-: substitute ( assoc seq -- )
+: (substitute)
-    swap [ dupd at* [ nip ] [ drop ] if ] curry change-each ;
+    [ dupd at* [ nip ] [ drop ] if ] curry ; inline
+
+: substitute-here ( seq assoc -- )
+    (substitute) change-each ;
+
+: substitute ( seq assoc -- newseq )
+    (substitute) map ;
 
 : cache ( key assoc quot -- value )
     2over at [

core/bootstrap/compiler/compiler.factor

@@ -78,7 +78,7 @@ nl
     [ compiled-usages recompile ] recompile-hook set-global ;
 
 : disable-compiler ( -- )
-    [ [ f ] { } map>assoc modify-code-heap ] recompile-hook set-global ;
+    [ default-recompile-hook ] recompile-hook set-global ;
 
 enable-compiler
 

core/bootstrap/image/image.factor

@@ -416,7 +416,7 @@ M: curry '
     "Writing image to " write
     architecture get boot-image-name resource-path
     dup write "..." print flush
-    <file-writer> [ (write-image) ] with-stream ;
+    [ (write-image) ] with-file-writer ;
 
 PRIVATE>
 

core/bootstrap/primitives.factor

@@ -98,7 +98,7 @@ H{ } clone update-map set
     [
         over "type" word-prop dup
         \ tag-mask get < \ tag \ type ? , , \ eq? ,
-    ] [ ] make define-predicate ;
+    ] [ ] make define-predicate* ;
 
 : register-builtin ( class -- )
     dup "type" word-prop builtins get set-nth ;
@@ -646,6 +646,7 @@ builtins get num-tags get tail f union-class define-class
     { "resize-byte-array" "byte-arrays" }
     { "resize-bit-array" "bit-arrays" }
     { "resize-float-array" "float-arrays" }
+    { "dll-valid?" "alien" }
 }
 dup length [ >r first2 r> make-primitive ] 2each
 

core/bootstrap/stage2.factor

@@ -59,7 +59,7 @@ SYMBOL: bootstrap-time
 
     default-image-name "output-image" set-global
 
-    "math help compiler tools ui ui.tools io" "include" set-global
+    "math help handbook compiler tools ui ui.tools io" "include" set-global
     "" "exclude" set-global
 
     parse-command-line

core/classes/classes-docs.factor

@@ -119,7 +119,7 @@ HELP: predicate-word
 { $values { "word" "a word" } { "predicate" "a predicate word" } }
 { $description "Suffixes the word's name with \"?\" and creates a word with that name in the same vocabulary as the word itself." } ;
 
-HELP: define-predicate
+HELP: define-predicate*
 { $values { "class" class } { "predicate" "a predicate word" } { "quot" "a quotation" } }
 { $description
     "Defines a predicate word. This is identical to a word definition associating " { $snippet "quot" } " with " { $snippet "predicate" } " with the added perk that three word properties are set:"
@@ -132,6 +132,13 @@ HELP: define-predicate
 }
 $low-level-note ;
 
+HELP: define-predicate
+{ $values { "class" class } { "quot" "a quotation" } }
+{ $description
+    "Defines a predicate word named " { $snippet "class?" } " with " { $link define-predicate* } "."
+}
+$low-level-note ;
+
 HELP: superclass
 { $values { "class" class } { "super" class } }
 { $description "Outputs the superclass of a class. All instances of this class are also instances of the superclass." }

core/classes/classes-tests.factor

@@ -63,7 +63,7 @@ UNION: bah fixnum alien ;
 
 ! Test generic see and parsing
 [ "USING: alien math ;\nIN: temporary\nUNION: bah fixnum alien ;\n" ]
-[ [ \ bah see ] string-out ] unit-test
+[ [ \ bah see ] with-string-writer ] unit-test
 
 ! Test redefinition of classes
 UNION: union-1 fixnum float ;

core/classes/classes.factor

@@ -31,13 +31,16 @@ PREDICATE: class tuple-class
 
 PREDICATE: word predicate "predicating" word-prop >boolean ;
 
-: define-predicate ( class predicate quot -- )
+: define-predicate* ( class predicate quot -- )
     over [
         dupd predicate-effect define-declared
         2dup 1quotation "predicate" set-word-prop
         swap "predicating" set-word-prop
-    ] [
+    ] [ 3drop ] if ;
-        3drop
+
+: define-predicate ( class quot -- )
+    over "forgotten" word-prop [ 2drop ] [
+        >r dup predicate-word r> define-predicate*
     ] if ;
 
 : superclass ( class -- super )

core/classes/predicate/predicate.factor

@@ -16,7 +16,7 @@ PREDICATE: class predicate-class
 : define-predicate-class ( superclass class definition -- )
     >r dup f roll predicate-class define-class r>
     dupd "predicate-definition" set-word-prop
-    dup predicate-word over predicate-quot define-predicate ;
+    dup predicate-quot define-predicate ;
 
 M: predicate-class reset-class
     {

core/classes/union/union.factor

@@ -31,9 +31,7 @@ PREDICATE: class union-class
     ] if ;
 
 : define-union-predicate ( class -- )
-    dup predicate-word
+    dup members union-predicate-quot define-predicate ;
-    over members union-predicate-quot
-    define-predicate ;
 
 M: union-class update-predicate define-union-predicate ;
 

core/compiler/compiler.factor

@@ -24,7 +24,6 @@ IN: compiler
 
 : finish-compile ( word effect dependencies -- )
     >r dupd save-effect r>
-    f pick compiler-error
     over compiled-unxref
     over crossref? [ compiled-xref ] [ 2drop ] if ;
 
@@ -38,6 +37,7 @@ IN: compiler
     swap compiler-error ;
 
 : (compile) ( word -- )
+    f over compiler-error
     [ dup compile-succeeded finish-compile ]
     [ dupd compile-failed f save-effect ]
     recover ;
@@ -55,7 +55,9 @@ IN: compiler
         H{ } clone compiled set
         [ queue-compile ] each
         compile-queue get compile-loop
-        compiled get >alist modify-code-heap
+        compiled get >alist
+        dup [ drop crossref? ] assoc-contains?
+        modify-code-heap
     ] with-scope ; inline
 
 : compile ( words -- )
@@ -70,4 +72,4 @@ IN: compiler
     [ all-words recompile ] with-compiler-errors ;
 
 : decompile ( word -- )
-    f 2array 1array modify-code-heap ;
+    f 2array 1array t modify-code-heap ;

core/compiler/units/units.factor

@@ -77,6 +77,11 @@ GENERIC: definitions-changed ( assoc obj -- )
         [ ] cleanup
     ] with-scope ; inline
 
+: default-recompile-hook
+    [ f ] { } map>assoc
+    dup [ drop crossref? ] assoc-contains?
+    modify-code-heap ;
+
 recompile-hook global
-[ [ [ f ] { } map>assoc modify-code-heap ] or ]
+[ [ default-recompile-hook ] or ]
 change-at

core/cpu/architecture/architecture.factor

@@ -128,7 +128,7 @@ HOOK: %prepare-var-args compiler-backend ( -- )
 
 M: object %prepare-var-args ;
 
-HOOK: %alien-invoke compiler-backend ( library function -- )
+HOOK: %alien-invoke compiler-backend ( function library -- )
 
 HOOK: %cleanup compiler-backend ( alien-node -- )
 

core/debugger/debugger-tests.factor

@@ -0,0 +1,4 @@
+IN: temporary
+USING: debugger kernel continuations tools.test ;
+
+[ ] [ [ drop ] [ error. ] recover ] unit-test

core/debugger/debugger.factor

@@ -1,11 +1,11 @@
-! Copyright (C) 2004, 2007 Slava Pestov.
+! Copyright (C) 2004, 2008 Slava Pestov.
 ! See http://factorcode.org/license.txt for BSD license.
 USING: arrays definitions generic hashtables inspector io kernel
 math namespaces prettyprint sequences assocs sequences.private
 strings io.styles vectors words system splitting math.parser
 tuples continuations continuations.private combinators
 generic.math io.streams.duplex classes compiler.units
-generic.standard ;
+generic.standard vocabs ;
 IN: debugger
 
 GENERIC: error. ( error -- )
@@ -254,3 +254,6 @@ M: no-compilation-unit error.
     "Attempting to define " write
     no-compilation-unit-definition pprint
     " outside of a compilation unit" print ;
+
+M: no-vocab summary
+    drop "Vocabulary does not exist" ;

core/generator/fixup/fixup.factor

@@ -111,7 +111,8 @@ SYMBOL: literal-table
 : add-literal ( obj -- n ) literal-table get push-new* ;
 
 : string>symbol ( str -- alien )
-    wince? [ string>u16-alien ] [ string>char-alien ] if ;
+    [ wince? [ string>u16-alien ] [ string>char-alien ] if ]
+    over string? [ call ] [ map ] if ;
 
 : add-dlsym-literals ( symbol dll -- )
     >r string>symbol r> 2array literal-table get push-all ;

core/generator/generator.factor

@@ -26,7 +26,7 @@ SYMBOL: compiling-word
 
 SYMBOL: compiling-label
 
-SYMBOL: compiling-loop?
+SYMBOL: compiling-loops
 
 ! Label of current word, after prologue, makes recursion faster
 SYMBOL: current-label-start
@@ -34,7 +34,7 @@ SYMBOL: current-label-start
 : compiled-stack-traces? ( -- ? ) 36 getenv ;
 
 : begin-compiling ( word label -- )
-    compiling-loop? off
+    H{ } clone compiling-loops set
     compiling-label set
     compiling-word set
     compiled-stack-traces?
@@ -94,8 +94,8 @@ M: node generate-node drop iterate-next ;
 : generate-call ( label -- next )
     dup maybe-compile
     end-basic-block
-    dup compiling-label get eq? compiling-loop? get and [
+    dup compiling-loops get at [
-        drop current-label-start get %jump-label f
+        %jump-label f
     ] [
         tail-call? [
             %jump f
@@ -104,7 +104,7 @@ M: node generate-node drop iterate-next ;
             %call
             iterate-next
         ] if
-    ] if ;
+    ] ?if ;
 
 ! #label
 M: #label generate-node
@@ -113,17 +113,13 @@ M: #label generate-node
     r> ;
 
 ! #loop
+: compiling-loop ( word -- )
+    <label> dup resolve-label swap compiling-loops get set-at ;
+
 M: #loop generate-node
     end-basic-block
-    [
+    dup node-param compiling-loop
-        dup node-param compiling-label set
+    node-child generate-nodes
-        current-label-start define-label
-        current-label-start resolve-label
-        compiling-loop? on
-        node-child generate-nodes
-        end-basic-block
-    ] with-scope
-    init-templates
     iterate-next ;
 
 ! #if
@@ -269,5 +265,6 @@ M: #r> generate-node
 
 ! #return
 M: #return generate-node
-    node-param compiling-label get eq? compiling-loop? get and
+    end-basic-block
-    [ end-basic-block %return ] unless f ;
+    node-param compiling-loops get key?
+    [ %return ] unless f ;

core/generator/registers/registers.factor

@@ -504,7 +504,7 @@ M: loc lazy-store
 : substitute-vregs ( values vregs -- )
     [ vreg-substitution ] 2map
     [ substitute-vreg? ] assoc-subset >hashtable
-    [ swap substitute ] curry each-phantom ;
+    [ substitute-here ] curry each-phantom ;
 
 : set-operand ( value var -- )
     >r dup constant? [ constant-value ] when r> set ;

core/generic/generic.factor

@@ -30,6 +30,7 @@ M: generic definer drop f f ;
 M: generic definition drop f ;
 
 : make-generic ( word -- )
+    dup { "unannotated-def" } reset-props
     dup dup "combination" word-prop perform-combination define ;
 
 TUPLE: method word def specializer generic loc ;
@@ -81,10 +82,19 @@ M: method-body stack-effect
     [ <method-word> ] 3keep f \ method construct-boa
     dup method-word over "method" set-word-prop ;
 
+: redefine-method ( quot class generic -- )
+    [ method set-method-def ] 3keep
+    [ make-method-def ] 2keep
+    method method-word swap define ;
+
 : define-method ( quot class generic -- )
     >r bootstrap-word r>
-    [ <method> ] 2keep
+    2dup method [
-    [ set-at ] with-methods ;
+        redefine-method
+    ] [
+        [ <method> ] 2keep
+        [ set-at ] with-methods
+    ] if ;
 
 : define-default-method ( generic combination -- )
     dupd make-default-method object bootstrap-word pick <method>

core/generic/standard/standard.factor

@@ -1,4 +1,4 @@
-! Copyright (C) 2005, 2007 Slava Pestov.
+! Copyright (C) 2005, 2008 Slava Pestov.
 ! See http://factorcode.org/license.txt for BSD license.
 USING: arrays assocs kernel kernel.private slots.private math
 namespaces sequences vectors words quotations definitions
@@ -77,7 +77,6 @@ TUPLE: no-method object generic ;
     class-predicates alist>quot ;
 
 : small-generic ( methods -- def )
-    [ 1quotation ] assoc-map
     object method-alist>quot ;
 
 : hash-methods ( methods -- buckets )
@@ -110,7 +109,7 @@ TUPLE: no-method object generic ;
 : build-type-vtable ( alist-seq -- alist-seq )
     dup length [
         vtable-class
-        swap [ word-def ] assoc-map simplify-alist
+        swap simplify-alist
         class-predicates alist>quot
     ] 2map ;
 
@@ -145,7 +144,8 @@ TUPLE: no-method object generic ;
     ] if ;
 
 : standard-methods ( word -- alist )
-    dup methods swap default-method add* ;
+    dup methods swap default-method add*
+    [ 1quotation ] assoc-map ;
 
 M: standard-combination make-default-method
     standard-combination-# (dispatch#)
@@ -161,9 +161,6 @@ TUPLE: hook-combination var ;
 
 C: <hook-combination> hook-combination
 
-M: hook-combination method-prologue
-    2drop [ drop ] ;
-
 : with-hook ( combination quot -- quot' )
     0 (dispatch#) [
         swap slip
@@ -175,7 +172,11 @@ M: hook-combination make-default-method
     [ error-method ] with-hook ;
 
 M: hook-combination perform-combination
-    [ standard-methods single-combination ] with-hook ;
+    [
+        standard-methods
+        [ [ drop ] swap append ] assoc-map
+        single-combination
+    ] with-hook ;
 
 : define-simple-generic ( word -- )
     T{ standard-combination f 0 } define-generic ;

core/hashtables/hashtables-tests.factor

@@ -157,8 +157,12 @@ H{ } "x" set
 ] unit-test
 
 [ { "one" "two" 3 } ] [
-    H{ { 1 "one" } { 2 "two" } }
+    { 1 2 3 } clone dup
-    { 1 2 3 } clone [ substitute ] keep
+    H{ { 1 "one" } { 2 "two" } } substitute-here
+] unit-test
+
+[ { "one" "two" 3 } ] [
+    { 1 2 3 } H{ { 1 "one" } { 2 "two" } } substitute
 ] unit-test
 
 [ f ] [ { 0 1 1 2 3 5 } all-unique? ] unit-test

core/inference/class/class-tests.factor

@@ -283,3 +283,8 @@ cell-bits 32 = [
     [ B{ 1 0 } *short dup number? [ 0 number= ] [ drop f ] if ]
     \ number= inlined?
 ] unit-test
+
+[ t ] [
+    [ HEX: ff bitand 0 HEX: ff between? ]
+    \ >= inlined?
+] unit-test

core/inference/known-words/known-words.factor

@@ -10,7 +10,7 @@ namespaces.private parser prettyprint quotations
 quotations.private sbufs sbufs.private sequences
 sequences.private slots.private strings strings.private system
 threads.private tuples tuples.private vectors vectors.private
-words words.private assocs inspector ;
+words words.private assocs inspector compiler.units ;
 IN: inference.known-words
 
 ! Shuffle words
@@ -596,3 +596,7 @@ set-primitive-effect
 \ (os-envs) { } { array } <effect> set-primitive-effect
 
 \ do-primitive [ \ do-primitive no-effect ] "infer" set-word-prop
+
+\ dll-valid? { object } { object } <effect> set-primitive-effect
+
+\ modify-code-heap { array object } { } <effect> set-primitive-effect

core/inspector/inspector-tests.factor

@@ -8,4 +8,4 @@ f describe
 H{ } describe
 H{ } describe
 
-[ "fixnum instance\n" ] [ [ 3 describe ] string-out ] unit-test
+[ "fixnum instance\n" ] [ [ 3 describe ] with-string-writer ] unit-test

core/io/encodings/binary/binary.factor

@@ -1,6 +1,3 @@
 USING: kernel io.encodings ;
 
 TUPLE: binary ;
-
-M: binary init-decoding drop ;
-M: binary init-encoding drop ;

core/io/encodings/encodings.factor

@@ -1,7 +1,7 @@
 ! Copyright (C) 2006, 2007 Daniel Ehrenberg.
 ! See http://factorcode.org/license.txt for BSD license.
 USING: math kernel sequences sbufs vectors io.streams.lines io.streams.plain
-namespaces unicode.syntax growable strings io classes io.streams.c
+namespaces unicode growable strings io classes io.streams.c
 continuations ;
 IN: io.encodings
 
@@ -19,7 +19,7 @@ SYMBOL: begin
     over push 0 begin ;
 
 : push-replacement ( buf -- buf ch state )
-    UNICHAR: replacement-character decoded ;
+    CHAR: replacement-character decoded ;
 
 : finish-decoding ( buf ch state -- str )
     begin eq? [ decode-error ] unless drop "" like ;
@@ -53,27 +53,17 @@ GENERIC: decode-step ( buf byte ch state encoding -- buf ch state )
     >r swap start-decoding r>
     decode-read-loop ;
 
-GENERIC: init-decoding ( stream encoding -- decoded-stream )
-
 : <decoding> ( stream decoding-class -- decoded-stream )
-    construct-empty init-decoding <line-reader> ;
+    construct-delegate <line-reader> ;
-
-GENERIC: init-encoding ( stream encoding -- encoded-stream )
 
 : <encoding> ( stream encoding-class -- encoded-stream )
-    construct-empty init-encoding <plain-writer> ;
+    construct-delegate <plain-writer> ;
 
 GENERIC: encode-string ( string encoding -- byte-array )
 M: tuple-class encode-string construct-empty encode-string ;
 
 MIXIN: encoding-stream
 
-M: encoding-stream init-decoding ( stream encoding-stream -- encoding-stream )
-    tuck set-delegate ;
-
-M: encoding-stream init-encoding ( stream encoding-stream -- encoding-stream )
-    tuck set-delegate ;
-
 M: encoding-stream stream-read1 1 swap stream-read ;
 
 M: encoding-stream stream-read
@@ -93,3 +83,13 @@ M: encoding-stream stream-write
     [ encode-string ] keep delegate stream-write ;
 
 M: encoding-stream dispose delegate dispose ;
+
+GENERIC: underlying-stream ( encoded-stream -- delegate )
+M: encoding-stream underlying-stream delegate ;
+
+GENERIC: set-underlying-stream ( new-underlying stream -- )
+M: encoding-stream set-underlying-stream set-delegate ;
+
+: set-encoding ( encoding stream -- ) ! This doesn't work now
+    [ underlying-stream swap construct-delegate ] keep
+    set-underlying-stream ;

core/io/encodings/latin1/latin1.factor

@@ -1,19 +1,10 @@
 USING: io io.encodings strings kernel ;
 IN: io.encodings.latin1
 
-TUPLE: latin1 stream ;
+TUPLE: latin1 ;
 
-M: latin1 init-decoding tuck set-latin1-stream ;
+M: latin1 stream-read delegate stream-read >string ;
-M: latin1 init-encoding drop ;
 
-M: latin1 stream-read1
+M: latin1 stream-read-until delegate stream-read-until >string ;
-    latin1-stream stream-read1 ;
 
-M: latin1 stream-read
+M: latin1 stream-read-partial delegate stream-read-partial >string ;
-    latin1-stream stream-read >string ;
-
-M: latin1 stream-read-until
-    latin1-stream stream-read-until >string ;
-
-M: latin1 stream-readln
-    latin1-stream stream-readln >string ;

core/io/encodings/utf16/utf16-tests.factor

@@ -1,15 +1,28 @@
-USING: tools.test io.utf16 arrays unicode.syntax ;
+USING: kernel tools.test io.encodings.utf16 arrays sbufs sequences io.encodings
+io unicode ;
 
-[ { CHAR: x } ] [ { 0 CHAR: x } decode-utf16be >array ] unit-test
+: decode-w/stream ( array encoding -- newarray )
-[ { HEX: 1D11E } ] [ { HEX: D8 HEX: 34 HEX: DD HEX: 1E } decode-utf16be >array ] unit-test
+    >r >sbuf dup reverse-here r> <decoding> contents >array ;
-[ { UNICHAR: replacement-character } ] [ { BIN: 11011111 CHAR: q } decode-utf16be >array ] unit-test
-[ { UNICHAR: replacement-character } ] [ { BIN: 11011011 CHAR: x BIN: 11011011 CHAR: x } decode-utf16be >array ] unit-test
 
-[ B{ 0 120 216 52 221 30 } ] [ { CHAR: x HEX: 1d11e } encode-utf16be ] unit-test
+: encode-w/stream ( array encoding -- newarray )
+    >r SBUF" " clone tuck r> <encoding> stream-write >array ;
 
-[ { CHAR: x } ] [ { CHAR: x 0 } decode-utf16le >array ] unit-test
+[ { CHAR: x } ] [ { 0 CHAR: x } utf16be decode-w/stream ] unit-test
-[ { 119070 } ] [ { HEX: 34 HEX: D8 HEX: 1E HEX: DD } decode-utf16le >array ] unit-test
+[ { HEX: 1D11E } ] [ { HEX: D8 HEX: 34 HEX: DD HEX: 1E } utf16be decode-w/stream ] unit-test
-[ { UNICHAR: replacement-character } ] [ { 0 BIN: 11011111 } decode-utf16le >array ] unit-test
+[ { CHAR: replacement-character } ] [ { BIN: 11011111 CHAR: q } utf16be decode-w/stream ] unit-test
-[ { UNICHAR: replacement-character } ] [ { 0 BIN: 11011011 0 0 } decode-utf16le >array ] unit-test
+[ { CHAR: replacement-character } ] [ { BIN: 11011011 CHAR: x BIN: 11011011 CHAR: x } utf16be decode-w/stream ] unit-test
 
-[ B{ 120 0 52 216 30 221 } ] [ { CHAR: x HEX: 1d11e } encode-utf16le ] unit-test
+[ { 0 120 216 52 221 30 } ] [ { CHAR: x HEX: 1d11e } utf16be encode-w/stream ] unit-test
+
+[ { CHAR: x } ] [ { CHAR: x 0 } utf16le decode-w/stream ] unit-test
+[ { 119070 } ] [ { HEX: 34 HEX: D8 HEX: 1E HEX: DD } utf16le decode-w/stream ] unit-test
+[ { CHAR: replacement-character } ] [ { 0 BIN: 11011111 } utf16le decode-w/stream ] unit-test
+[ { CHAR: replacement-character } ] [ { 0 BIN: 11011011 0 0 } utf16le decode-w/stream ] unit-test
+[ { 119070 } ] [ { HEX: 34 HEX: D8 HEX: 1E HEX: DD } utf16le decode-w/stream ] unit-test
+
+[ { 120 0 52 216 30 221 } ] [ { CHAR: x HEX: 1d11e } utf16le encode-w/stream ] unit-test
+
+[ { CHAR: x } ] [ { HEX: ff HEX: fe CHAR: x 0 } utf16 decode-w/stream ] unit-test
+[ { CHAR: x } ] [ { HEX: fe HEX: ff 0 CHAR: x } utf16 decode-w/stream ] unit-test
+
+[ { HEX: ff HEX: fe 120 0 52 216 30 221 } ] [ { CHAR: x HEX: 1d11e } utf16 encode-w/stream ] unit-test

core/io/encodings/utf16/utf16.factor

@@ -1,7 +1,7 @@
 ! Copyright (C) 2006, 2007 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.encodings combinators splitting io byte-arrays ;
 IN: io.encodings.utf16
 
 SYMBOL: double
@@ -104,23 +104,49 @@ SYMBOL: ignore
 : encode-utf16 ( str -- seq )
     encode-utf16le bom-le swap append ;
 
+: start-utf16le? ( seq1 -- seq2 ? ) bom-le ?head ;
+
+: start-utf16be? ( seq1 -- seq2 ? ) bom-be ?head ;
+
 : decode-utf16 ( seq -- str )
     {
-        { [ bom-le ?head ] [ decode-utf16le ] }
+        { [ start-utf16le? ] [ decode-utf16le ] }
-        { [ bom-be ?head ] [ decode-utf16be ] }
+        { [ start-utf16be? ] [ decode-utf16be ] }
         { [ t ] [ decode-error ] }
     } cond ;
 
 TUPLE: utf16le ;
-: <utf16le> utf16le construct-delegate ;
 INSTANCE: utf16le encoding-stream 
 
 M: utf16le encode-string drop encode-utf16le ;
 M: utf16le decode-step drop decode-utf16le-step ;
 
 TUPLE: utf16be ;
-: <utf16be> utf16be construct-delegate ;
 INSTANCE: utf16be encoding-stream 
 
 M: utf16be encode-string drop encode-utf16be ;
 M: utf16be decode-step drop decode-utf16be-step ;
+
+TUPLE: utf16 encoding ;
+INSTANCE: utf16 encoding-stream
+M: utf16 underlying-stream delegate dup delegate [ ] [ ] ?if ; ! necessary? 
+M: utf16 set-underlying-stream delegate set-delegate ; ! necessary? 
+
+M: utf16 encode-string
+    >r encode-utf16le r>
+    dup utf16-encoding [ drop ]
+    [ t swap set-utf16-encoding bom-le swap append ] if ;
+
+: bom>le/be ( bom -- le/be )
+    dup bom-le sequence= [ drop utf16le ] [
+        bom-be sequence= [ utf16be ] [ decode-error ] if
+    ] if ;
+
+: read-bom ( utf16 -- encoding )
+    2 over delegate stream-read bom>le/be construct-empty
+    [ swap set-utf16-encoding ] keep ;
+
+M: utf16 decode-step
+    ! inefficient: checks if bom is done many times
+    ! This should transform itself into utf16be or utf16le after reading BOM
+    dup utf16-encoding [ ] [ read-bom ] ?if decode-step ;

core/io/encodings/utf8/utf8-tests.factor

@@ -1,13 +1,13 @@
-USING: io.encodings.utf8 tools.test sbufs kernel io
+USING: io.encodings.utf8 tools.test sbufs kernel io io.encodings
-sequences strings arrays unicode.syntax ;
+sequences strings arrays unicode ;
 
 : decode-utf8-w/stream ( array -- newarray )
-    >sbuf dup reverse-here <utf8> contents >array ;
+    >sbuf dup reverse-here utf8 <decoding> contents ;
 
 : encode-utf8-w/stream ( array -- newarray )
-    SBUF" " clone tuck <utf8> write >array ;
+    SBUF" " clone tuck utf8 <encoding> stream-write >array ;
 
-[ { UNICHAR: replacement-character } ] [ { BIN: 11110101 BIN: 10111111 BIN: 10000000 BIN: 11111111 } decode-utf8-w/stream >array ] unit-test
+[ { CHAR: replacement-character } ] [ { BIN: 11110101 BIN: 10111111 BIN: 10000000 BIN: 11111111 } decode-utf8-w/stream >array ] unit-test
 
 [ { BIN: 101111111000000111111 } ] [ { BIN: 11110101 BIN: 10111111 BIN: 10000000 BIN: 10111111 } decode-utf8-w/stream >array ] unit-test
 
@@ -15,9 +15,9 @@ sequences strings arrays unicode.syntax ;
 
 [ { BIN: 11111000000 } ] [ { BIN: 11011111 BIN: 10000000 } decode-utf8-w/stream >array ] unit-test
 
-[ { UNICHAR: replacement-character } ] [ { BIN: 10000000 } decode-utf8-w/stream >array ] unit-test
+[ { CHAR: replacement-character } ] [ { BIN: 10000000 } decode-utf8-w/stream >array ] unit-test
 
 [ { BIN: 1111000000111111 } ] [ { BIN: 11101111 BIN: 10000000 BIN: 10111111 } decode-utf8-w/stream >array ] unit-test
 
-[ B{ BIN: 11110101 BIN: 10111111 BIN: 10000000 BIN: 10111111 BIN: 11101111 BIN: 10000000 BIN: 10111111 BIN: 11011111 BIN: 10000000 CHAR: x } ]
+[ { BIN: 11110101 BIN: 10111111 BIN: 10000000 BIN: 10111111 BIN: 11101111 BIN: 10000000 BIN: 10111111 BIN: 11011111 BIN: 10000000 CHAR: x } ]
-[ { BIN: 101111111000000111111 BIN: 1111000000111111 BIN: 11111000000 CHAR: x } encode-utf8 ] unit-test
+[ { BIN: 101111111000000111111 BIN: 1111000000111111 BIN: 11111000000 CHAR: x } encode-utf8-w/stream ] unit-test

core/io/encodings/utf8/utf8.factor

@@ -78,7 +78,6 @@ SYMBOL: quad3
 ! Interface for streams
 
 TUPLE: utf8 ;
-: <utf8> utf8 construct-delegate ;
 INSTANCE: utf8 encoding-stream 
 
 M: utf8 encode-string drop encode-utf8 ;

core/io/files/files-docs.factor

@@ -52,12 +52,12 @@ HELP: <file-appender>
 { $description "Outputs an output stream for writing to the specified pathname. The stream begins writing at the end of the file." }
 { $errors "Throws an error if the file cannot be opened for writing." } ;
 
-HELP: with-file-in
+HELP: with-file-reader
 { $values { "path" "a pathname string" } { "quot" "a quotation" } }
 { $description "Opens a file for reading and calls the quotation using " { $link with-stream } "." }
 { $errors "Throws an error if the file is unreadable." } ;
 
-HELP: with-file-out
+HELP: with-file-writer
 { $values { "path" "a pathname string" } { "quot" "a quotation" } }
 { $description "Opens a file for writing and calls the quotation using " { $link with-stream } "." }
 { $errors "Throws an error if the file cannot be opened for writing." } ;

core/io/files/files-tests.factor

@@ -6,9 +6,9 @@ USING: tools.test io.files io threads kernel continuations ;
 [ "awk" ] [ "/usr/libexec/awk///" file-name ] unit-test
 
 [ ] [
-    "test-foo.txt" resource-path <file-writer> [
+    "test-foo.txt" resource-path [
         "Hello world." print
-    ] with-stream
+    ] with-file-writer
 ] unit-test
 
 [ ] [
@@ -55,11 +55,11 @@ USING: tools.test io.files io threads kernel continuations ;
 
 [ f ] [ "test-blah" resource-path exists? ] unit-test
 
-[ ] [ "test-quux.txt" resource-path <file-writer> [ [ yield "Hi" write ] in-thread ] with-stream ] unit-test
+[ ] [ "test-quux.txt" resource-path [ [ yield "Hi" write ] in-thread ] with-file-writer ] unit-test
 
 [ ] [ "test-quux.txt" resource-path delete-file ] unit-test
 
-[ ] [ "test-quux.txt" resource-path <file-writer> [ [ yield "Hi" write ] in-thread ] with-stream ] unit-test
+[ ] [ "test-quux.txt" resource-path [ [ yield "Hi" write ] in-thread ] with-file-writer ] unit-test
 
 [ ] [ "test-quux.txt" "quux-test.txt" [ resource-path ] 2apply rename-file ] unit-test
 [ t ] [ "quux-test.txt" resource-path exists? ] unit-test

core/io/files/files.factor

@@ -3,7 +3,7 @@
 IN: io.files
 USING: io.backend io.files.private io hashtables kernel math
 memory namespaces sequences strings assocs arrays definitions
-system combinators splitting sbufs ;
+system combinators splitting sbufs continuations ;
 
 HOOK: cd io-backend ( path -- )
 
@@ -116,11 +116,10 @@ HOOK: copy-file io-backend ( from to -- )
 M: object copy-file
     dup parent-directory make-directories
     <file-writer> [
-        stdio get swap
+        swap <file-reader> [
-        <file-reader> [
+            swap stream-copy
-            stdio get swap stream-copy
+        ] with-disposal
-        ] with-stream
+    ] with-disposal ;
-    ] with-stream ;
 
 : copy-directory ( from to -- )
     dup make-directories
@@ -144,12 +143,13 @@ M: pathname <=> [ pathname-string ] compare ;
 : file-lines ( path -- seq ) <file-reader> lines ;
 
 : file-contents ( path -- str )
-    dup <file-reader> swap file-length <sbuf> [ stream-copy ] keep >string ;
+    dup <file-reader> swap file-length <sbuf>
+    [ stream-copy ] keep >string ;
 
-: with-file-in ( path quot -- )
+: with-file-reader ( path quot -- )
     >r <file-reader> r> with-stream ; inline
 
-: with-file-out ( path quot -- )
+: with-file-writer ( path quot -- )
     >r <file-writer> r> with-stream ; inline
 
 : with-file-appender ( path quot -- )

core/io/io-tests.factor

@@ -53,7 +53,7 @@ IN: temporary
 ] unit-test
 
 [ ] [
-    image <file-reader> [
+    image [
         10 [ 65536 read drop ] times
-    ] with-stream
+    ] with-file-reader
 ] unit-test

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

@@ -0,0 +1,9 @@
+USING: tools.test io.streams.byte-array io.encodings.binary
+io.encodings.utf8 io kernel arrays strings ;
+
+[ B{ 1 2 3 } ] [ binary [ { 1 2 3 } write ] with-byte-writer ] unit-test
+[ B{ 1 2 3 } ] [ { 1 2 3 } binary [ 3 read ] with-byte-reader ] unit-test
+
+[ B{ BIN: 11110101 BIN: 10111111 BIN: 10000000 BIN: 10111111 BIN: 11101111 BIN: 10000000 BIN: 10111111 BIN: 11011111 BIN: 10000000 CHAR: x } ]
+[ { BIN: 101111111000000111111 BIN: 1111000000111111 BIN: 11111000000 CHAR: x } utf8 [ write ] with-byte-writer ] unit-test
+[ { BIN: 101111111000000111111 } t ] [ { BIN: 11110101 BIN: 10111111 BIN: 10000000 BIN: 10111111 } utf8 <byte-reader> contents dup >array swap string? ] unit-test

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

@@ -0,0 +1,16 @@
+USING: byte-arrays byte-vectors kernel io.encodings io.streams.string
+sequences io namespaces ;
+IN: io.streams.byte-array
+
+: <byte-writer> ( encoding -- stream )
+    512 <byte-vector> swap <encoding> ;
+
+: with-byte-writer ( encoding quot -- byte-array )
+    >r <byte-writer> r> [ stdio get ] compose with-stream*
+    >byte-array ; inline
+
+: <byte-reader> ( byte-array encoding -- stream )
+    >r >byte-vector dup reverse-here r> <decoding> ;
+
+: with-byte-reader ( byte-array encoding quot -- )
+    >r <byte-reader> r> with-stream ; inline

core/io/streams/c/c-tests.factor

@@ -2,9 +2,9 @@ USING: tools.test io.files io io.streams.c ;
 IN: temporary
 
 [ "hello world" ] [
-    "test.txt" resource-path <file-writer> [
+    "test.txt" resource-path [
         "hello world" write
-    ] with-stream
+    ] with-file-writer
 
     "test.txt" resource-path "rb" fopen <c-reader> contents
 ] unit-test

core/io/streams/string/string-docs.factor

@@ -6,8 +6,8 @@ ARTICLE: "io.streams.string" "String streams"
 { $subsection <string-reader> }
 { $subsection <string-writer> }
 "Utility combinators:"
-{ $subsection string-in }
+{ $subsection with-string-reader }
-{ $subsection string-out } ;
+{ $subsection with-string-writer } ;
 
 ABOUT: "io.streams.string"
 
@@ -15,7 +15,7 @@ HELP: <string-writer>
 { $values { "stream" "an output stream" } }
 { $description "Creates an output stream that collects text into a delegate string buffer. The contents of the buffer can be recovered by executing " { $link >string } ", and indeed all other sequence operations are permitted by virtue of the delegation." } ;
 
-HELP: string-out
+HELP: with-string-writer
 { $values { "quot" quotation } { "str" string } }
 { $description "Calls the quotation in a new dynamic scope with " { $link stdio } " rebound to a new string writer. The accumulated string is output when the quotation returns." } ;
 
@@ -24,6 +24,6 @@ HELP: <string-reader>
 { $description "Creates a new stream for reading " { $snippet "str" } " from beginning to end." }
 { $notes "The implementation exploits the ability of string buffers to respond to the input stream protocol by reading characters from the end of the buffer." } ;
 
-HELP: string-in
+HELP: with-string-reader
 { $values { "str" string } { "quot" quotation } }
 { $description "Calls the quotation in a new dynamic scope with " { $link stdio } " rebound to an input stream reading " { $snippet "str" } " from beginning to end. The accumulated string is output when the quotation returns." } ;

core/io/streams/string/string-tests.factor

@@ -12,7 +12,7 @@ unit-test
 [ "" <string-reader> stream-readln ]
 unit-test
 
-[ "xyzzy" ] [ [ "xyzzy" write ] string-out ] unit-test
+[ "xyzzy" ] [ [ "xyzzy" write ] with-string-writer ] unit-test
 
 [ "a" ] [ 1 SBUF" cba" stream-read ] unit-test
 [ "ab" ] [ 2 SBUF" cba" stream-read ] unit-test

core/io/streams/string/string.factor

@@ -2,21 +2,21 @@
 ! See http://factorcode.org/license.txt for BSD license.
 IN: io.streams.string
 USING: io kernel math namespaces sequences sbufs strings
-generic splitting io.streams.plain io.streams.lines
+generic splitting io.streams.plain io.streams.lines growable
 continuations ;
 
-M: sbuf dispose drop ;
+M: growable dispose drop ;
 
-M: sbuf stream-write1 push ;
+M: growable stream-write1 push ;
-M: sbuf stream-write push-all ;
+M: growable stream-write push-all ;
-M: sbuf stream-flush drop ;
+M: growable stream-flush drop ;
 
 : <string-writer> ( -- stream )
     512 <sbuf> <plain-writer> ;
 
-: string-out ( quot -- str )
+: with-string-writer ( quot -- str )
-    <string-writer> [ call stdio get >string ] with-stream* ;
+    <string-writer> swap [ stdio get ] compose with-stream*
-    inline
+    >string ; inline
 
 : format-column ( seq ? -- seq )
     [
@@ -37,36 +37,39 @@ M: plain-writer stream-write-table
 
 M: plain-writer make-cell-stream 2drop <string-writer> ;
 
-M: sbuf stream-read1 dup empty? [ drop f ] [ pop ] if ;
+M: growable stream-read1 dup empty? [ drop f ] [ pop ] if ;
 
-: sbuf-read-until ( sbuf n -- str )
+: harden-as ( seq growble-exemplar -- newseq )
-    tail-slice >string dup reverse-here ;
+    underlying like ;
+
+: growable-read-until ( growable n -- str )
+    dupd tail-slice swap harden-as dup reverse-here ;
 
 : find-last-sep swap [ memq? ] curry find-last drop ;
 
-M: sbuf stream-read-until
+M: growable stream-read-until
     [ find-last-sep ] keep over [
-        [ swap 1+ sbuf-read-until ] 2keep [ nth ] 2keep
+        [ swap 1+ growable-read-until ] 2keep [ nth ] 2keep
         set-length
     ] [
-        [ swap drop 0 sbuf-read-until f like f ] keep
+        [ swap drop 0 growable-read-until f like f ] keep
         delete-all
     ] if ;
 
-M: sbuf stream-read
+M: growable stream-read
     dup empty? [
         2drop f
     ] [
         [ length swap - 0 max ] keep
-        [ swap sbuf-read-until ] 2keep
+        [ swap growable-read-until ] 2keep
         set-length
     ] if ;
 
-M: sbuf stream-read-partial
+M: growable stream-read-partial
     stream-read ;
 
 : <string-reader> ( str -- stream )
     >sbuf dup reverse-here <line-reader> ;
 
-: string-in ( str quot -- )
+: with-string-reader ( str quot -- )
     >r <string-reader> r> with-stream ; inline

core/kernel/kernel-tests.factor

@@ -32,7 +32,7 @@ IN: temporary
 
 [ overflow-d-alt ] [ { "kernel-error" 12 f f } = ] must-fail-with
 
-[ ] [ [ :c ] string-out drop ] unit-test
+[ ] [ [ :c ] with-string-writer drop ] unit-test
 
 : overflow-r 3 >r overflow-r ;
 
@@ -80,8 +80,8 @@ IN: temporary
 [ 0 ] [ f [ 0 ] unless* ] unit-test
 [ t ] [ t [ "Hello" ] unless* ] unit-test
 
-[ "2\n" ] [ [ 1 2 [ . ] [ sq . ] ?if ] string-out ] unit-test
+[ "2\n" ] [ [ 1 2 [ . ] [ sq . ] ?if ] with-string-writer ] unit-test
-[ "9\n" ] [ [ 3 f [ . ] [ sq . ] ?if ] string-out ] unit-test
+[ "9\n" ] [ [ 3 f [ . ] [ sq . ] ?if ] with-string-writer ] unit-test
 
 [ f ] [ f (clone) ] unit-test
 [ -123 ] [ -123 (clone) ] unit-test

core/listener/listener.factor

@@ -48,7 +48,14 @@ M: duplex-stream stream-read-quot
 
 : listen ( -- )
     listener-hook get call prompt.
-    [ read-quot [ call ] [ bye ] if* ] try ;
+    [ read-quot [ try ] [ bye ] if* ]
+    [
+        dup parse-error? [
+            error-hook get call
+        ] [
+            rethrow
+        ] if
+    ] recover ;
 
 : until-quit ( -- )
     quit-flag get

core/optimizer/backend/backend.factor

@@ -37,10 +37,10 @@ GENERIC: optimize-node* ( node -- node/t changed? )
     over assoc-empty? [
         2drop
     ] [
-        2dup node-in-d substitute
+        2dup node-in-d swap substitute-here
-        2dup node-in-r substitute
+        2dup node-in-r swap substitute-here
-        2dup node-out-d substitute
+        2dup node-out-d swap substitute-here
-        node-out-r substitute
+        node-out-r swap substitute-here
     ] if ;
 
 : perform-substitutions ( node -- )

core/optimizer/control/control-tests.factor

@@ -113,7 +113,7 @@ optimizer ;
 ] unit-test
 
 [ f ] [
-    [ [ [ ] map ] map ] dataflow optimize
+    [ [ [ ] map ] map ] dataflow dup detect-loops
     [ dup #label? swap #loop? not and ] node-exists?
 ] unit-test
 
@@ -146,3 +146,36 @@ DEFER: a
     [ a ] dataflow dup detect-loops
     \ b label-is-loop?
 ] unit-test
+
+DEFER: a'
+
+: b' ( -- )
+    blah [ b' b' ] [ a' ] if ; inline
+
+: a' ( -- )
+    blah [ b' ] [ a' ] if ; inline
+
+[ f ] [
+    [ a' ] dataflow dup detect-loops
+    \ a' label-is-loop?
+] unit-test
+
+[ f ] [
+    [ b' ] dataflow dup detect-loops
+    \ b' label-is-loop?
+] unit-test
+
+! I used to think this should be f, but doing this on pen and
+! paper almost convinced me that a loop conversion here is
+! sound. The loop analysis algorithm looks pretty solid -- its
+! a standard iterative dataflow problem after all -- so I'm
+! tempted to believe the computer here
+[ t ] [
+    [ b' ] dataflow dup detect-loops
+    \ a' label-is-loop?
+] unit-test
+
+[ f ] [
+    [ a' ] dataflow dup detect-loops
+    \ b' label-is-loop?
+] unit-test

core/optimizer/control/control.factor

@@ -7,7 +7,7 @@ combinators classes generic.math continuations optimizer.def-use
 optimizer.backend generic.standard ;
 IN: optimizer.control
 
-! ! ! Loop detection
+! ! ! Rudimentary CFA
 
 ! A LOOP
 !
@@ -36,7 +36,8 @@ IN: optimizer.control
 !       |
 !    #values
 !
-! NOT A LOOP (call to A nested inside another label/loop):
+! NOT A LOOP (call to A nested inside another label which is
+! not a loop):
 !
 !
 !          #label A
@@ -53,38 +54,70 @@ IN: optimizer.control
 !               |       |
 !         #call-label A |
 !               |       |
-!              ...     ...
+!           #values     |
+!                 #call-label B
+!                       |
+!                      ...
 
-GENERIC: detect-loops* ( node -- )
+! Mapping word => { node { nesting tail? }+ height }
+! We record all calls to a label, their control nesting and
+! whether it is a tail call or not
+SYMBOL: label-info
 
-M: node detect-loops* drop ;
+GENERIC: collect-label-info* ( node -- )
 
-M: #label detect-loops* t swap set-#label-loop? ;
+M: #label collect-label-info*
+    [ V{ } clone node-stack get length 3array ] keep
+    node-param label-info get set-at ;
 
-: not-a-loop ( #label -- )
+USE: prettyprint
-    f swap set-#label-loop? ;
 
-: tail-call? ( -- ? )
+M: #call-label collect-label-info*
-    node-stack get
+    node-param label-info get at
-    dup [ #label? ] find-last drop [ 1+ ] [ 0 ] if* tail
+    node-stack get over third tail
-    [ node-successor #tail? ] all? ;
+    [ [ #label? ] subset [ node-param ] map ] keep
-USE: io
+    [ node-successor #tail? ] all? 2array
-: detect-loop ( seen-other? label node -- seen-other? continue? )
+    swap second push ;
-    #! seen-other?: have we seen another label?
-    {
-        { [ dup #label? not ] [ 2drop t ] }
-        { [ 2dup node-param eq? not ] [ 3drop t t ] }
-        { [ tail-call? not ] [ not-a-loop drop f ] }
-        { [ pick ] [ not-a-loop drop f ] }
-        { [ t ] [ 2drop f ] }
-    } cond ;
 
-M: #call-label detect-loops*
+M: node collect-label-info*
-    f swap node-param node-stack get <reversed>
+    drop ;
-    [ detect-loop ] with all? 2drop ;
 
-: detect-loops ( node -- )
+: collect-label-info ( node -- )
-    [ detect-loops* ] each-node ;
+    H{ } clone label-info set
+    [ collect-label-info* ] each-node ;
+
+! Mapping word => label
+SYMBOL: potential-loops
+
+: remove-non-tail-calls ( -- )
+    label-info get
+    [ nip second [ second ] all? ] assoc-subset
+    [ first ] assoc-map
+    potential-loops set ;
+
+: remove-non-loop-calls ( -- )
+    ! Boolean is set to t if something changed.
+    !  We recurse until a fixed point is reached.
+    f label-info get [
+        ! If label X is called from within a label Y that is
+        ! no longer a potential loop, then X is no longer a
+        ! potential loop either.
+        over potential-loops get key? [
+            second [ first ] map concat
+            potential-loops get [ key? ] curry all?
+            [ drop ] [ potential-loops get delete-at t or ] if
+        ] [ 2drop ] if
+    ] assoc-each [ remove-non-loop-calls ] when ;
+
+: detect-loops ( nodes -- )
+    [
+        collect-label-info
+        remove-non-tail-calls
+        remove-non-loop-calls
+        potential-loops get [
+            nip t swap set-#label-loop?
+        ] assoc-each
+    ] with-scope ;
 
 ! ! ! Constant branch folding
 !
@@ -204,7 +237,7 @@ M: #if optimize-node*
 
 !   #label -> C -> #return 1
 !     |
-!     -> #if -> #merge -> #return 2
+!     -> #if -> #merge (*) -> #return 2
 !         |
 !     --------
 !     |      |
@@ -218,19 +251,19 @@ M: #if optimize-node*
 
 ! AFTER:
 
-!    #label -> #terminate
+!        #label -> #return 1
-!     |
-!     -> #if -> #terminate
 !         |
-!     --------
+!         -> #if -------> #merge (*) -> #return 2
-!     |      |
+!             |           \-------------------/
-!     A      B
+!     ----------------              |
-!     |      |
+!     |              |              |
-!  #values   |
+!     A              B     unreacachable code needed to
-!     |  #call-label
+!     |              |         preserve invariants
-!  #merge    |
+!  #values           |
-!     |      |
+!     |          #call-label
-!     C   #values
+!  #merge (*)        |
+!     |              |
+!     C           #values
 !     |
 !  #return 1
 
@@ -282,14 +315,22 @@ M: node add-loop-exit*
         ] [ 2drop f ] if
     ] [ drop f ] if ;
 
-! M: #loop optimize-node*
+M: #loop optimize-node*
-!     dup lift-loop-tail? dup [
+    dup lift-loop-tail? dup [
-!         last-node >r
+        last-node "values" set
-!         dup detach-node-successor
+
-!         over node-child find-final-if detach-node-successor
+        dup node-successor "tail" set
-!         [ set-node-successor ] keep
+        dup node-successor last-node "return" set
-!         r> set-node-successor
+        dup node-child find-final-if node-successor "merge" set
-!         t
+
-!     ] [
+        ! #label -> #return
-!         2drop t f
+        "return" get clone-node over set-node-successor
-!     ] if ;
+        ! #merge -> C
+        "merge" get clone-node "tail" get over set-node-successor
+        ! #values -> #merge ->C
+        "values" get set-node-successor
+
+        t
+    ] [
+        2drop t f
+    ] if ;

core/optimizer/inlining/inlining.factor

@@ -6,62 +6,38 @@ math namespaces sequences vectors words quotations hashtables
 combinators classes generic.math continuations optimizer.def-use
 optimizer.backend generic.standard optimizer.specializers
 optimizer.def-use optimizer.pattern-match generic.standard
-optimizer.control ;
+optimizer.control kernel.private ;
 IN: optimizer.inlining
 
-GENERIC: remember-method* ( method-spec node -- )
+: remember-inlining ( node history -- )
+    [ swap set-node-history ] curry each-node ;
 
-M: #call remember-method*
+: inlining-quot ( node quot -- node )
-    [ node-history ?push ] keep set-node-history ;
-
-M: node remember-method*
-    2drop ;
-
-: remember-method ( method-spec node -- )
-    swap dup second +inlined+ depends-on
-    [ swap remember-method* ] curry each-node ;
-
-: (splice-method) ( #call method-spec quot -- node )
-    #! Must remember the method before splicing in, otherwise
-    #! the rest of the IR will also remember the method
-    pick node-in-d dataflow-with
-    [ remember-method ] keep
-    [ swap infer-classes/node ] 2keep
-    [ splice-node ] keep ;
-
-: splice-quot ( #call quot -- node )
     over node-in-d dataflow-with
-    [ swap infer-classes/node ] 2keep
+    dup rot infer-classes/node ;
-    [ splice-node ] keep ;
 
-! #call
+: splice-quot ( #call quot history -- node )
-: splice-method ( #call method-spec/t quot/t -- node/t )
+    #! Must add history *before* splicing in, otherwise
-    #! t indicates failure
+    #! the rest of the IR will also remember the history
-    {
+    pick node-history append
-        { [ dup t eq? ] [ 3drop t ] }
+    >r dupd inlining-quot dup r> remember-inlining
-        { [ 2over swap node-history member? ] [ 3drop t ] }
+    tuck splice-node ;
-        { [ t ] [ (splice-method) ] }
-    } cond ;
-
-! Single dispatch method inlining optimization
-: already-inlined? ( node -- ? )
-    #! Was this node inlined from definition of 'word'?
-    dup node-param swap node-history memq? ;
-
-: specific-method ( class word -- class ) order min-class ;
-
-: node-class# ( node n -- class )
-    over node-in-d <reversed> ?nth node-class ;
-
-: dispatching-class ( node word -- class )
-    [ dispatch# node-class# ] keep specific-method ;
 
 ! A heuristic to avoid excessive inlining
 DEFER: (flat-length)
 
 : word-flat-length ( word -- n )
-    dup get over inline? not or
+    {
-    [ drop 1 ] [ dup dup set word-def (flat-length) ] if ;
+        ! heuristic: { ... } declare comes up in method bodies
+        ! and we don't care about it
+        { [ dup \ declare eq? ] [ drop -2 ] }
+        ! recursive
+        { [ dup get ] [ drop 1 ] }
+        ! not inline
+        { [ dup inline? not ] [ drop 1 ] }
+        ! inline
+        { [ t ] [ dup dup set word-def (flat-length) ] }
+    } cond ;
 
 : (flat-length) ( seq -- n )
     [
@@ -76,32 +52,30 @@ DEFER: (flat-length)
 : flat-length ( seq -- n )
     [ word-def (flat-length) ] with-scope ;
 
-: will-inline-method ( node word -- method-spec/t quot/t )
+! Single dispatch method inlining optimization
-    #! t indicates failure
+: specific-method ( class word -- class ) order min-class ;
-    tuck dispatching-class dup [
+
-        swap [ 2array ] 2keep
+: node-class# ( node n -- class )
-        method method-word
+    over node-in-d <reversed> ?nth node-class ;
-        dup flat-length 10 >=
+
-        [ 1quotation ] [ word-def ] if
+: dispatching-class ( node word -- class )
-    ] [
+    [ dispatch# node-class# ] keep specific-method ;
-        2drop t t
-    ] if ;
 
 : inline-standard-method ( node word -- node )
-    dupd will-inline-method splice-method ;
+    2dup dispatching-class dup [
+        over +inlined+ depends-on
+        swap method method-word 1quotation f splice-quot
+    ] [
+        3drop t
+    ] if ;
 
 ! Partial dispatch of math-generic words
 : math-both-known? ( word left right -- ? )
     math-class-max swap specific-method ;
 
-: will-inline-math-method ( word left right -- method-spec/t quot/t )
-    #! t indicates failure
-    3dup math-both-known?
-    [ [ 3array ] 3keep math-method ] [ 3drop t t ] if ;
-
 : inline-math-method ( #call word -- node )
-    over node-input-classes first2
+    over node-input-classes first2 3dup math-both-known?
-    will-inline-math-method splice-method ;
+    [ math-method f splice-quot ] [ 2drop 2drop t ] if ;
 
 : inline-method ( #call -- node )
     dup node-param {
@@ -131,7 +105,7 @@ DEFER: (flat-length)
 
 : inline-literals ( node literals -- node )
     #! Make #shuffle -> #push -> #return -> successor
-    dupd literal-quot splice-quot ;
+    dupd literal-quot f splice-quot ;
 
 : evaluate-predicate ( #call -- ? )
     dup node-param "predicating" word-prop >r
@@ -196,7 +170,7 @@ DEFER: (flat-length)
     nip dup [ second ] when ;
 
 : apply-identities ( node -- node/f )
-    dup find-identity dup [ splice-quot ] [ 2drop f ] if ;
+    dup find-identity dup [ f splice-quot ] [ 2drop f ] if ;
 
 : optimistic-inline? ( #call -- ? )
     dup node-param "specializer" word-prop dup [
@@ -206,13 +180,20 @@ DEFER: (flat-length)
         2drop f
     ] if ;
 
+: splice-word-def ( #call word -- node )
+    dup +inlined+ depends-on
+    dup word-def swap 1array splice-quot ;
+
 : optimistic-inline ( #call -- node )
-    dup node-param dup +inlined+ depends-on
+    dup node-param over node-history memq? [
-    word-def splice-quot ;
+        drop t
+    ] [
+        dup node-param splice-word-def
+    ] if ;
 
 : method-body-inline? ( #call -- ? )
     node-param dup method-body?
-    [ flat-length 8 <= ] [ drop f ] if ;
+    [ flat-length 10 <= ] [ drop f ] if ;
 
 M: #call optimize-node*
     {

core/optimizer/known-words/known-words.factor

@@ -40,7 +40,7 @@ optimizer.inlining float-arrays sequences.private combinators ;
 : flip-branches ( #call -- #if )
     #! If a not is followed by an #if, flip branches and
     #! remove the not.
-    dup sole-consumer (flip-branches) [ ] splice-quot ;
+    dup sole-consumer (flip-branches) [ ] f splice-quot ;
 
 \ not {
     { [ dup flip-branches? ] [ flip-branches ] }
@@ -63,7 +63,7 @@ optimizer.inlining float-arrays sequences.private combinators ;
     [ [ t ] ] { } map>assoc [ drop f ] add [ nip case ] curry ;
 
 : expand-member ( #call -- )
-    dup node-in-d peek value-literal member-quot splice-quot ;
+    dup node-in-d peek value-literal member-quot f splice-quot ;
 
 \ member? {
     { [ dup literal-member? ] [ expand-member ] }

core/optimizer/math/math.factor

@@ -366,7 +366,7 @@ most-negative-fixnum most-positive-fixnum [a,b]
 } [
     [
         [ dup remove-overflow-check? ] ,
-        [ splice-quot ] curry ,
+        [ f splice-quot ] curry ,
     ] { } make 1array define-optimizers
 ] assoc-each
 
@@ -436,7 +436,7 @@ most-negative-fixnum most-positive-fixnum [a,b]
             dup remove-overflow-check?
             over coereced-to-fixnum? or
         ] ,
-        [ splice-quot ] curry ,
+        [ f splice-quot ] curry ,
     ] { } make 1array define-optimizers
 ] assoc-each
 
@@ -461,6 +461,6 @@ most-negative-fixnum most-positive-fixnum [a,b]
 \ fixnum-shift {
     {
         [ dup fixnum-shift-fast? ]
-        [ [ fixnum-shift-fast ] splice-quot ]
+        [ [ fixnum-shift-fast ] f splice-quot ]
     }
 } define-optimizers

core/optimizer/optimizer-tests.factor

@@ -2,7 +2,7 @@ USING: arrays compiler generic hashtables inference kernel
 kernel.private math optimizer prettyprint sequences sbufs
 strings tools.test vectors words sequences.private quotations
 optimizer.backend classes inference.dataflow tuples.private
-continuations growable optimizer.inlining namespaces ;
+continuations growable optimizer.inlining namespaces hints ;
 IN: temporary
 
 [ H{ { 1 5 } { 3 4 } { 2 5 } } ] [
@@ -351,3 +351,28 @@ M: integer generic-inline-test ;
     \ generic-inline-test-1 word-def dataflow
     [ optimize-1 , optimize-1 , drop ] { } make
 ] unit-test
+
+! Forgot a recursive inline check
+: recursive-inline-hang ( a -- a )
+    dup array? [ recursive-inline-hang ] when ;
+
+HINTS: recursive-inline-hang array ;
+
+: recursive-inline-hang-1
+    { } recursive-inline-hang ;
+
+[ t ] [ \ recursive-inline-hang-1 compiled? ] unit-test
+
+DEFER: recursive-inline-hang-3
+
+: recursive-inline-hang-2 ( a -- a )
+    dup array? [ recursive-inline-hang-3 ] when ;
+
+HINTS: recursive-inline-hang-2 array ;
+
+: recursive-inline-hang-3 ( a -- a )
+    dup array? [ recursive-inline-hang-2 ] when ;
+
+HINTS: recursive-inline-hang-3 array ;
+
+

core/parser/parser-docs.factor

@@ -266,19 +266,10 @@ HELP: escape
 { $description "Converts from a single-character escape code and the corresponding character." }
 { $examples { $example "CHAR: n escape CHAR: \\n = ." "t" } } ;
 
-HELP: next-escape
-{ $values { "m" "an index into " { $snippet "str" } } { "str" string } { "n" "an index into " { $snippet "str" } } { "ch" "a character" } }
-{ $description "Helper word for " { $link parse-string } " which parses an escape sequence starting at the " { $snippet "m" } "th index of " { $snippet "str" } "." }
-{ $errors "Throws a " { $link bad-escape } " if the string contains an invalid escape sequence." } ;
-
-HELP: next-char
-{ $values { "m" "an index into " { $snippet "str" } } { "str" string } { "n" "an index into " { $snippet "str" } } { "ch" "a character" } }
-{ $description "Helper word for " { $link parse-string } " which parses a character starting at the " { $snippet "m" } "th index of " { $snippet "str" } "." } ;
-
 HELP: parse-string
 { $values { "str" "a new " { $link string } } }
 { $description "Parses the line until a quote (\"), interpreting escape codes along the way." }
-{ $errors "Throws an " { $link bad-escape } " if the string contains an invalid escape sequence." }
+{ $errors "Throws an error if the string contains an invalid escape sequence." }
 $parsing-note ;
 
 HELP: still-parsing?

core/parser/parser-tests.factor

@@ -5,18 +5,6 @@ sorting tuples compiler.units ;
 IN: temporary
 
 [
-    [ 1 CHAR: a ]
-    [ 0 "abcd" next-char ] unit-test
-
-    [ 8 CHAR: \s ]
-    [ 1 "\\u000020hello" next-escape ] unit-test
-
-    [ 2 CHAR: \n ]
-    [ 1 "\\nhello" next-escape ] unit-test
-
-    [ 8 CHAR: \s ]
-    [ 0 "\\u000020hello" next-char ] unit-test
-
     [ 1 [ 2 [ 3 ] 4 ] 5 ]
     [ "1\n[\n2\n[\n3\n]\n4\n]\n5" eval ]
     unit-test

core/parser/parser.factor

@@ -119,22 +119,43 @@ M: bad-escape summary drop "Bad escape code" ;
         { CHAR: \" CHAR: \" }
     } at [ bad-escape ] unless* ;
 
-: next-escape ( m str -- n ch )
+SYMBOL: name>char-hook
-    2dup nth CHAR: u =
-    [ >r 1+ dup 6 + tuck r> subseq hex> ]
-    [ over 1+ -rot nth escape ] if ;
 
-: next-char ( m str -- n ch )
+name>char-hook global [
-    2dup nth CHAR: \\ =
+    [ "Unicode support not available" throw ] or
-    [ >r 1+ r> next-escape ] [ over 1+ -rot nth ] if ;
+] change-at
 
-: (parse-string) ( m str -- n )
+: unicode-escape ( str -- ch str' )
-    2dup nth CHAR: " =
+    "{" ?head-slice [
-    [ drop 1+ ] [ [ next-char , ] keep (parse-string) ] if ;
+        CHAR: } over index cut-slice
+        >r >string name>char-hook get call r>
+        1 tail-slice
+    ] [
+        6 cut-slice >r hex> r>
+    ] if ;
+
+: next-escape ( str -- ch str' )
+    "u" ?head-slice [
+        unicode-escape
+    ] [
+        unclip-slice escape swap
+    ] if ;
+
+: (parse-string) ( str -- m )
+    dup [ "\"\\" member? ] find dup [
+        >r cut-slice >r % r> 1 tail-slice r>
+        dup CHAR: " = [
+            drop slice-from
+        ] [
+            drop next-escape >r , r> (parse-string)
+        ] if
+    ] [
+        "Unterminated string" throw
+    ] if ;
 
 : parse-string ( -- str )
     lexer get [
-        [ (parse-string) ] "" make swap
+        [ swap tail-slice (parse-string) ] "" make swap
     ] change-column ;
 
 TUPLE: parse-error file line col text ;
@@ -492,4 +513,4 @@ SYMBOL: interactive-vocabs
     [
         parser-notes off
         [ [ eval ] keep ] try drop
-    ] string-out ;
+    ] with-string-writer ;

core/prettyprint/prettyprint-tests.factor

@@ -67,19 +67,19 @@ unit-test
 [ "[ \\ [ ]" ] [ [ \ [ ] unparse ] unit-test
     
 [ t ] [
-    100 \ dup <array> [ pprint-short ] string-out
+    100 \ dup <array> [ pprint-short ] with-string-writer
     "{" head?
 ] unit-test
 
 : foo ( a -- b ) dup * ; inline
 
 [ "USING: kernel math ;\nIN: temporary\n: foo ( a -- b ) dup * ; inline\n" ]
-[ [ \ foo see ] string-out ] unit-test
+[ [ \ foo see ] with-string-writer ] unit-test
 
 : bar ( x -- y ) 2 + ;
 
 [ "USING: math ;\nIN: temporary\n: bar ( x -- y ) 2 + ;\n" ]
-[ [ \ bar see ] string-out ] unit-test
+[ [ \ bar see ] with-string-writer ] unit-test
 
 : blah 
     drop
@@ -105,7 +105,7 @@ unit-test
 
 [ "drop ;" ] [
     \ blah f "inferred-effect" set-word-prop
-    [ \ blah see ] string-out "\n" ?tail drop 6 tail*
+    [ \ blah see ] with-string-writer "\n" ?tail drop 6 tail*
 ] unit-test
 
 : check-see ( expect name -- )
@@ -116,7 +116,7 @@ unit-test
             [ parse-fresh drop ] with-compilation-unit
             [
                 "temporary" lookup see
-            ] string-out "\n" split 1 head*
+            ] with-string-writer "\n" split 1 head*
         ] keep =
     ] with-scope ;
 
@@ -295,7 +295,7 @@ unit-test
     "IN: temporary\nGENERIC: generic-decl-test ( a -- b ) flushable\n"
     dup eval
     "generic-decl-test" "temporary" lookup
-    [ see ] string-out =
+    [ see ] with-string-writer =
 ] unit-test
 
 [ [ + ] ] [

core/prettyprint/prettyprint.factor

@@ -63,9 +63,9 @@ combinators quotations ;
 
 : pprint-use ( obj -- ) [ pprint* ] with-use ;
 
-: unparse ( obj -- str ) [ pprint ] string-out ;
+: unparse ( obj -- str ) [ pprint ] with-string-writer ;
 
-: unparse-use ( obj -- str ) [ pprint-use ] string-out ;
+: unparse-use ( obj -- str ) [ pprint-use ] with-string-writer ;
 
 : pprint-short ( obj -- )
     H{
@@ -192,7 +192,7 @@ M: pathname synopsis* pprint* ;
         0 margin set
         1 line-limit set
         [ synopsis* ] with-in
-    ] string-out ;
+    ] with-string-writer ;
 
 GENERIC: declarations. ( obj -- )
 

core/syntax/syntax-docs.factor

@@ -100,13 +100,9 @@ ARTICLE: "escape" "Character escape codes"
     { { $snippet "\\0" } "a null byte (ASCII 0)" }
     { { $snippet "\\e" } "escape (ASCII 27)" }
     { { $snippet "\\\"" } { $snippet "\"" } }
-}
+    { { $snippet "\\u" { $emphasis "xxxxxx" } } { "The Unicode code point with hexadecimal number " { $snippet { $emphasis "xxxxxx" } } } }
-"A Unicode character can be specified by its code number by writing " { $snippet "\\u" } " followed by a six-digit hexadecimal number. That is, the following two expressions are equivalent:"
+    { { $snippet "\\u{" { $emphasis "name" } "}" } { "The Unicode code point named " { $snippet { $emphasis "name" } } } }
-{ $code
+} ;
-    "CHAR: \\u000078"
-    "78"
-}
-"While not useful for single characters, this syntax is also permitted inside strings." ;
 
 ARTICLE: "syntax-strings" "Character and string syntax"
 "Factor has no distinct character type, however Unicode character value integers can be read by specifying a literal character, or an escaped representation thereof."
@@ -412,8 +408,17 @@ HELP: IN:
 
 HELP: CHAR:
 { $syntax "CHAR: token" }
-{ $values { "token" "a literal character or escape code" } }
+{ $values { "token" "a literal character, escape code, or Unicode character name" } }
-{ $description "Adds the Unicode code point of the character represented by the token to the parse tree." } ;
+{ $description "Adds a Unicode code point to the parse tree." }
+{ $examples
+    { $code
+        "CHAR: x"
+        "CHAR: \\u000032"
+        "CHAR: \\u{exclamation-mark}"
+        "CHAR: exclamation-mark"
+        "CHAR: ugaritic-letter-samka"
+    }
+} ;
 
 HELP: "
 { $syntax "\"string...\"" }

core/syntax/syntax.factor

@@ -5,7 +5,8 @@ byte-vectors definitions generic hashtables kernel math
 namespaces parser sequences strings sbufs vectors words
 quotations io assocs splitting tuples generic.standard
 generic.math classes io.files vocabs float-arrays float-vectors
-classes.union classes.mixin classes.predicate compiler.units ;
+classes.union classes.mixin classes.predicate compiler.units
+combinators ;
 IN: bootstrap.syntax
 
 ! These words are defined as a top-level form, instead of with
@@ -56,7 +57,14 @@ IN: bootstrap.syntax
     "f" [ f parsed ] define-syntax
     "t" "syntax" lookup define-symbol
 
-    "CHAR:" [ 0 scan next-char nip parsed ] define-syntax
+    "CHAR:" [
+        scan {
+            { [ dup length 1 = ] [ first ] }
+            { [ "\\" ?head ] [ next-escape drop ] }
+            { [ t ] [ name>char-hook get call ] }
+        } cond parsed
+    ] define-syntax
+
     "\"" [ parse-string parsed ] define-syntax
 
     "SBUF\"" [

core/tuples/tuples.factor

@@ -66,9 +66,7 @@ M: tuple-class tuple-size "slot-names" word-prop length 2 + ;
 PRIVATE>
 
 : define-tuple-predicate ( class -- )
-    dup predicate-word
+    dup [ tuple-class-eq? ] curry define-predicate ;
-    over [ tuple-class-eq? ] curry
-    define-predicate ;
 
 : delegate-slot-spec
     T{ slot-spec f

core/vocabs/loader/loader.factor

@@ -1,10 +1,10 @@
 ! Copyright (C) 2007, 2008 Eduardo Cavazos, Slava Pestov.
 ! See http://factorcode.org/license.txt for BSD license.
-USING: namespaces splitting sequences io.files kernel assocs
+USING: namespaces sequences io.files kernel assocs words vocabs
-words vocabs definitions parser continuations inspector debugger
+definitions parser continuations inspector debugger io io.styles
-io io.styles io.streams.lines hashtables sorting prettyprint
+io.streams.lines hashtables sorting prettyprint source-files
-source-files arrays combinators strings system math.parser
+arrays combinators strings system math.parser compiler.errors
-compiler.errors ;
+splitting ;
 IN: vocabs.loader
 
 SYMBOL: vocab-roots
@@ -16,7 +16,7 @@ V{
 } clone vocab-roots set-global
 
 : vocab-dir ( vocab -- dir )
-    vocab-name "." split "/" join ;
+    vocab-name { { CHAR: . CHAR: / } } substitute ;
 
 : vocab-dir+ ( vocab str/f -- path )
     >r vocab-name "." split r>
@@ -69,13 +69,6 @@ M: vocab-link vocab-root
         vocab-tests %
     ] { } make ;
 
-TUPLE: no-vocab name ;
-
-: no-vocab ( name -- * )
-    vocab-name \ no-vocab construct-boa throw ;
-
-M: no-vocab summary drop "Vocabulary does not exist" ;
-
 SYMBOL: load-help?
 
 : source-was-loaded t swap set-vocab-source-loaded? ;

core/vocabs/vocabs.factor

@@ -1,4 +1,4 @@
-! Copyright (C) 2007 Eduardo Cavazos, Slava Pestov.
+! Copyright (C) 2007, 2008 Eduardo Cavazos, Slava Pestov.
 ! See http://factorcode.org/license.txt for BSD license.
 USING: assocs strings kernel sorting namespaces sequences
 definitions ;
@@ -113,3 +113,8 @@ UNION: vocab-spec vocab vocab-link ;
     vocab-name dictionary get delete-at ;
 
 M: vocab-spec forget* forget-vocab ;
+
+TUPLE: no-vocab name ;
+
+: no-vocab ( name -- * )
+    vocab-name \ no-vocab construct-boa throw ;

core/words/words.factor

@@ -172,7 +172,9 @@ SYMBOL: changed-words
     gensym dup rot define ;
 
 : reveal ( word -- )
-    dup word-name over word-vocabulary vocab-words set-at ;
+    dup word-name over word-vocabulary dup vocab-words
+    [ ] [ no-vocab ] ?if
+    set-at ;
 
 TUPLE: check-create name vocab ;
 

extra/asn1/asn1.factor

@@ -112,7 +112,7 @@ SYMBOL: end
         { "boolean" [ "\0" = not ] }
         { "string" [ "" or ] }
         { "integer" [ be> ] }
-        { "array" [ "" or [ read-array ] string-in ] }
+        { "array" [ "" or [ read-array ] with-string-reader ] }
     } case ;
 
 : read-ber ( syntax -- object )

extra/benchmark/benchmark.factor

@@ -6,15 +6,11 @@ continuations debugger ;
 IN: benchmark
 
 : run-benchmark ( vocab -- result )
-    "=== Benchmark " write dup print flush
+  [ dup require [ run ] benchmark ] [ error. drop f f ] recover 2array ;
-    dup require
-    [ [ run ] benchmark ] [ error. drop f f ] recover 2array
-    dup . ;
 
 : run-benchmarks ( -- assoc )
-    "benchmark" load-children
+  "benchmark" all-child-vocabs values concat [ vocab-name ] map
-    "benchmark" dup child-vocabs remove
+  [ dup run-benchmark ] { } map>assoc ;
-    [ dup run-benchmark ] { } map>assoc ;
 
 : benchmarks. ( assoc -- )
     standard-table-style [

extra/benchmark/fasta/fasta.factor

@@ -101,7 +101,7 @@ HINTS: random fixnum ;
             n 3 * homo-sapiens-chars homo-sapiens-floats "IUB ambiguity codes" "TWO" write-random-fasta
             n 5 * IUB-chars IUB-floats "Homo sapiens frequency" "THREE" write-random-fasta
             drop
-        ] with-file-out
+        ] with-file-writer
 
     ] with-locals ;
 

extra/benchmark/knucleotide/knucleotide.factor

@@ -57,8 +57,7 @@ IN: benchmark.knucleotide
 
 : knucleotide ( -- )
     "extra/benchmark/knucleotide/knucleotide-input.txt" resource-path
-    <file-reader>
+    [ read-input ] with-file-reader
-    [ read-input ] with-stream
     process-input ;
 
 MAIN: knucleotide

extra/benchmark/mandel/mandel.factor

@@ -65,7 +65,7 @@ SYMBOL: cols
     ] with-scope ;
 
 : mandel-main ( -- )
-    "mandel.ppm" resource-path <file-writer>
+    "mandel.ppm" resource-path
-    [ mandel write ] with-stream ;
+    [ mandel write ] with-file-writer ;
 
 MAIN: mandel-main

extra/benchmark/nsieve/nsieve.factor

@@ -6,7 +6,7 @@ arrays namespaces io ;
     2dup length >= [
         3drop
     ] [
-        f pick pick set-nth-unsafe >r over + r> clear-flags
+        f 2over set-nth-unsafe >r over + r> clear-flags
     ] if ; inline
 
 : (nsieve) ( count i seq -- count )

extra/benchmark/raytracer/raytracer.factor

@@ -171,6 +171,6 @@ DEFER: create ( level c r -- scene )
 
 : raytracer-main
     "raytracer.pnm" resource-path
-    <file-writer> [ run write ] with-stream ;
+    [ run write ] with-file-writer ;
 
 MAIN: raytracer-main

extra/benchmark/recursive/recursive.factor

@@ -16,7 +16,7 @@ USING: math kernel hints prettyprint io ;
     ] if ;
 
 : tak ( x y z -- t )
-    pick pick swap < [
+    2over swap < [
         [ rot 1- -rot tak ] 3keep
         [ -rot 1- -rot tak ] 3keep
         1- -rot tak

extra/benchmark/reverse-complement/reverse-complement.factor

@@ -1,6 +1,6 @@
 USING: io io.files io.streams.duplex kernel sequences
 sequences.private strings vectors words memoize splitting
-hints unicode.case ;
+hints unicode.case continuations ;
 IN: benchmark.reverse-complement
 
 MEMO: trans-map ( -- str )
@@ -32,9 +32,13 @@ HINTS: do-line vector string ;
     readln [ do-line (reverse-complement) ] [ show-seq ] if* ;
 
 : reverse-complement ( infile outfile -- )
-    <file-writer> >r <file-reader> r> <duplex-stream> [
+    <file-writer> [
-        500000 <vector> (reverse-complement)
+        swap <file-reader> [
-    ] with-stream ;
+            swap <duplex-stream> [
+                500000 <vector> (reverse-complement)
+            ] with-stream
+        ] with-disposal
+    ] with-disposal ;
 
 : reverse-complement-in
     "extra/benchmark/reverse-complement/reverse-complement-in.txt"

extra/benchmark/sockets/sockets.factor

@@ -23,10 +23,9 @@ IN: benchmark.sockets
     ] with-stream ;
 
 : clients ( n -- )
-    dup pprint " clients: " write
+    dup pprint " clients: " write [
-        [
         [ simple-server ] in-thread
-        100 sleep
+        yield yield
         [ drop simple-client ] parallel-each
         stop-server
         yield yield

extra/benchmark/sum-file/sum-file.factor

@@ -5,7 +5,7 @@ IN: benchmark.sum-file
     readln [ string>number + sum-file-loop ] when* ;
 
 : sum-file ( file -- )
-    <file-reader> [ 0 sum-file-loop ] with-stream . ;
+    [ 0 sum-file-loop ] with-file-reader . ;
 
 : sum-file-main ( -- )
     home "sum-file-in.txt" path+ sum-file ;

extra/bootstrap/handbook/handbook.factor

@@ -0,0 +1,3 @@
+USING: vocabs.loader vocabs kernel ;
+
+"bootstrap.help" vocab [ "help.handbook" require ] when

extra/bootstrap/help/help.factor

@@ -14,8 +14,6 @@ IN: bootstrap.help
         [ vocab-root ] subset
         [ vocab-source-loaded? ] subset
         [ dup vocab-docs-loaded? [ drop ] [ load-docs ] if ] each
-    ] with-variable
+    ] with-variable ;
-
-    "help.handbook" require ;
 
 load-help

extra/bootstrap/image/upload/upload.factor

@@ -11,7 +11,7 @@ bootstrap.image sequences io namespaces io.launcher math ;
 : compute-checksums ( -- )
     "checksums.txt" [
         boot-image-names [ dup write bl file>md5str print ] each
-    ] with-file-out ;
+    ] with-file-writer ;
 
 : upload-images ( -- )
     [

extra/bootstrap/tools/tools.factor

@@ -4,10 +4,11 @@ USING: vocabs.loader sequences ;
     "bootstrap.image"
     "tools.annotations"
     "tools.crossref"
-    ! "tools.deploy"
+    "tools.deploy"
     "tools.memory"
     "tools.profiler"
     "tools.test"
     "tools.time"
+    "tools.disassembler"
     "editors"
 } [ require ] each

extra/builder/builder.factor

@@ -1,16 +1,32 @@
 
-USING: kernel parser io io.files io.launcher io.sockets hashtables math threads
+USING: kernel namespaces sequences splitting system combinators continuations
-       arrays system continuations namespaces sequences splitting math.parser
+       parser io io.files io.launcher io.sockets prettyprint threads
-       prettyprint tools.time calendar bake vars http.client
+       bootstrap.image benchmark vars bake smtp builder.util accessors ;
-       combinators bootstrap.image bootstrap.image.download
-       combinators.cleave benchmark
-       classes strings quotations words parser-combinators new-slots accessors
-       assocs.lib smtp builder.util ;
 
 IN: builder
 
 ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
 
+SYMBOL: builds-dir
+
+: builds ( -- path )
+  builds-dir get
+  home "/builds" append
+  or ;
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+: prepare-build-machine ( -- )
+  builds make-directory
+  builds cd
+  { "git" "clone" "git://factorcode.org/git/factor.git" } run-process drop ;
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+: builds-check ( -- ) builds exists? not [ prepare-build-machine ] when ;
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
 : git-clone ( -- desc ) { "git" "clone" "../factor" } ;
 
 ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
@@ -19,7 +35,7 @@ VAR: stamp
 
 : enter-build-dir ( -- )
   datestamp >stamp
-  "/builds" cd
+  builds cd
   stamp> make-directory
   stamp> cd ;
 
@@ -28,7 +44,7 @@ VAR: stamp
 : git-id ( -- id )
   { "git" "show" } <process-stream> [ readln ] with-stream " " split second ;
 
-: record-git-id ( -- ) git-id "../git-id" [ . ] with-file-out ;
+: record-git-id ( -- ) git-id "../git-id" [ . ] with-file-writer ;
 
 : make-clean ( -- desc ) { "make" "clean" } ;
 
@@ -69,14 +85,22 @@ VAR: stamp
   
 ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
 
+SYMBOL: build-status
+
 : (build) ( -- )
 
+  builds-check  
+
+  build-status off
+
   enter-build-dir
 
   "report" [
 
     "Build machine:   " write host-name print
-    "Build directory: " write cwd       print
+    "CPU:             " write cpu       print
+    "OS:              " write os        print
+    "Build directory: " write cwd       print nl
 
     git-clone [ "git clone failed" print ] run-or-bail
 
@@ -88,7 +112,7 @@ VAR: stamp
 
     make-vm [ "vm compile error" print "../compile-log" cat ] run-or-bail
 
-    [ my-arch download-image ] [ "Image download error" print throw ] recover
+    [ retrieve-image ] [ "Image download error" print throw ] recover
 
     bootstrap [ "Bootstrap error" print "../boot-log" cat ] run-or-bail
 
@@ -98,31 +122,40 @@ VAR: stamp
 
     "Boot time: " write "../boot-time" eval-file milli-seconds>time print
     "Load time: " write "../load-time" eval-file milli-seconds>time print
-    "Test time: " write "../test-time" eval-file milli-seconds>time print
+    "Test time: " write "../test-time" eval-file milli-seconds>time print nl
 
     "Did not pass load-everything: " print "../load-everything-vocabs" cat
     "Did not pass test-all: "        print "../test-all-vocabs"        cat
 
     "Benchmarks: " print
-    "../benchmarks" [ stdio get contents eval ] with-file-in benchmarks.
+    "../benchmarks" [ stdio get contents eval ] with-file-reader benchmarks.
 
-  ] with-file-out ;
+  ] with-file-writer
+
+  build-status on ;
 
 ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
 
+SYMBOL: builder-from
+
 SYMBOL: builder-recipients
 
 : tag-subject ( str -- str ) { "builder@" host-name* ": " , } bake to-string ;
 
-: build ( -- )
+: subject ( -- str ) build-status get [ "report" ] [ "error" ] if tag-subject ;
-  [ (build) ] [ drop ] recover
+
+: send-builder-email ( -- )
   <email>
-    "ed@factorcode.org"     >>from
+    builder-from get        >>from
     builder-recipients get  >>to
-    "report" tag-subject    >>subject
+    subject                 >>subject
     "../report" file>string >>body
   send ;
 
+: build ( -- )
+  [ (build) ] [ drop ] recover
+  [ send-builder-email ] [ drop "not sending mail" . ] recover ;
+
 ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
 
 : git-pull ( -- desc )
@@ -141,8 +174,9 @@ SYMBOL: builder-recipients
   = not ;
 
 : build-loop ( -- )
+  builds-check
   [
-    "/builds/factor" cd
+    builds "/factor" append cd
     updates-available?
       [ build ]
     when

extra/builder/test/test.factor

@@ -11,17 +11,17 @@ USING: kernel namespaces sequences assocs builder continuations
 IN: builder.test
 
 : do-load ( -- )
-  try-everything keys "../load-everything-vocabs" [ . ] with-file-out ;
+  try-everything keys "../load-everything-vocabs" [ . ] with-file-writer ;
 
 : do-tests ( -- )
-  run-all-tests keys "../test-all-vocabs" [ . ] with-file-out ;
+  run-all-tests keys "../test-all-vocabs" [ . ] with-file-writer ;
 
-: do-benchmarks ( -- ) run-benchmarks "../benchmarks" [ . ] with-file-out ;
+: do-benchmarks ( -- ) run-benchmarks "../benchmarks" [ . ] with-file-writer ;
 
 : do-all ( -- )
-  bootstrap-time get   "../boot-time" [ . ] with-file-out
+  bootstrap-time get   "../boot-time" [ . ] with-file-writer
-  [ do-load  ] runtime "../load-time" [ . ] with-file-out
+  [ do-load  ] runtime "../load-time" [ . ] with-file-writer
-  [ do-tests ] runtime "../test-time" [ . ] with-file-out
+  [ do-tests ] runtime "../test-time" [ . ] with-file-writer
   do-benchmarks ;
 
 MAIN: do-all

extra/builder/util/util.factor

@@ -3,8 +3,8 @@ USING: kernel words namespaces classes parser continuations
        io io.files io.launcher io.sockets
        math math.parser
        combinators sequences splitting quotations arrays strings tools.time
-       parser-combinators accessors assocs.lib
+       parser-combinators new-slots accessors assocs.lib
-       combinators.cleave bake calendar new-slots ;
+       combinators.cleave bake calendar  ;
 
 IN: builder.util
 
@@ -14,7 +14,7 @@ IN: builder.util
 
 : minutes>ms ( min -- ms ) 60 * 1000 * ;
 
-: file>string ( file -- string ) [ stdio get contents ] with-file-in ;
+: file>string ( file -- string ) [ stdio get contents ] with-file-reader ;
 
 ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
 
@@ -69,9 +69,9 @@ TUPLE: process* arguments stdin stdout stderr timeout ;
 : milli-seconds>time ( n -- string )
   1000 /i 60 /mod >r 60 /mod r> 3array [ pad-00 ] map ":" join ;
 
-: eval-file ( file -- obj ) <file-reader> contents eval ;
+: eval-file ( file -- obj ) file-contents eval ;
 
-: cat ( file -- ) <file-reader> contents print ;
+: cat ( file -- ) file-contents print ;
 
 : run-or-bail ( desc quot -- )
   [ [ try-process ] curry   ]
@@ -81,3 +81,6 @@ TUPLE: process* arguments stdin stdout stderr timeout ;
 
 ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
 
+USING: bootstrap.image bootstrap.image.download io.streams.null ;
+
+: retrieve-image ( -- ) [ my-arch download-image ] with-null-stream ;

extra/bunny/model/model.factor

@@ -18,13 +18,7 @@ IN: bunny.model
     ] when* ;
 
 : parse-model ( stream -- vs is )
-    [
+    100000 <vector> 100000 <vector> (parse-model) ;
-        100000 <vector> 100000 <vector> (parse-model)
-    ] with-stream
-    [
-        over length # " vertices, " %
-        dup length # " triangles" %
-    ] "" make print ;
 
 : n ( vs triple -- n )
     swap [ nth ] curry map
@@ -41,7 +35,8 @@ IN: bunny.model
 
 : read-model ( stream -- model )
     "Reading model" print flush [
-        <file-reader> parse-model [ normals ] 2keep 3array
+        [ parse-model ] with-file-reader
+        [ normals ] 2keep 3array
     ] time ;
 
 : model-path "bun_zipper.ply" ;

extra/calendar/calendar-tests.factor

@@ -1,5 +1,5 @@
 USING: arrays calendar kernel math sequences tools.test
-continuations system ;
+continuations system io.streams.string ;
 
 [ 2004 12 32 0   0  0 0 make-timestamp ] [ "invalid timestamp" = ] must-fail-with
 [ 2004  2 30 0   0  0 0 make-timestamp ] [ "invalid timestamp" = ] must-fail-with
@@ -141,3 +141,23 @@ continuations system ;
 [ t ] [ 0 unix-time>timestamp unix-1970 = ] unit-test
 [ t ] [ 123456789 [ unix-time>timestamp timestamp>unix-time ] keep = ] unit-test
 [ t ] [ 123456789123456789 [ unix-time>timestamp timestamp>unix-time ] keep = ] unit-test
+
+[ 0 ] [
+    "Z" [ read-rfc3339-gmt-offset ] with-string-reader
+] unit-test
+
+[ 1 ] [
+    "+01" [ read-rfc3339-gmt-offset ] with-string-reader
+] unit-test
+
+[ -1 ] [
+    "-01" [ read-rfc3339-gmt-offset ] with-string-reader
+] unit-test
+
+[ -1-1/2 ] [
+    "-01:30" [ read-rfc3339-gmt-offset ] with-string-reader
+] unit-test
+
+[ 1+1/2 ] [
+    "+01:30" [ read-rfc3339-gmt-offset ] with-string-reader
+] unit-test

extra/calendar/calendar.factor

@@ -347,7 +347,7 @@ M: timestamp year. ( timestamp -- )
     timestamp-second >fixnum write-00 ;
 
 : timestamp>string ( timestamp -- str )
-    [ (timestamp>string) ] string-out ;
+    [ (timestamp>string) ] with-string-writer ;
 
 : (write-gmt-offset) ( ratio -- )
     1 /mod swap write-00 60 * write-00 ;
@@ -366,42 +366,63 @@ M: timestamp year. ( timestamp -- )
         dup (timestamp>string)
         " " write
         timestamp-gmt-offset write-gmt-offset
-    ] string-out ;
+    ] with-string-writer ;
 
 : timestamp>http-string ( timestamp -- str )
     #! http timestamp format
     #! Example: Tue, 15 Nov 1994 08:12:31 GMT
     >gmt timestamp>rfc822-string ;
 
+: write-rfc3339-gmt-offset ( n -- )
+    dup zero? [ drop "Z" write ] [
+        dup 0 < [ CHAR: - write1 neg ] [ CHAR: + write1 ] if
+        60 * 60 /mod swap write-00 CHAR: : write1 write-00
+    ] if ;
+
 : (timestamp>rfc3339) ( timestamp -- )
     dup timestamp-year number>string write CHAR: - write1
     dup timestamp-month write-00 CHAR: - write1
     dup timestamp-day write-00 CHAR: T write1
     dup timestamp-hour write-00 CHAR: : write1
     dup timestamp-minute write-00 CHAR: : write1
-    timestamp-second >fixnum write-00 CHAR: Z write1 ;
+    dup timestamp-second >fixnum write-00
+    timestamp-gmt-offset write-rfc3339-gmt-offset ;
 
 : timestamp>rfc3339 ( timestamp -- str )
-    >gmt [ (timestamp>rfc3339) ] string-out ;
+    [ (timestamp>rfc3339) ] with-string-writer ;
 
-: expect read1 assert= ;
+: expect ( str -- )
+    read1 swap member? [ "Parse error" throw ] unless ;
+
+: read-00 2 read string>number ;
+
+: read-0000 4 read string>number ;
+
+: read-rfc3339-gmt-offset ( -- n )
+    read1 dup CHAR: Z = [ drop 0 ] [
+        { { CHAR: + [ 1 ] } { CHAR: - [ -1 ] } } case
+        read-00
+        read1 { { CHAR: : [ read-00 ] } { f [ 0 ] } } case
+        60 / + *
+    ] if ;
 
 : (rfc3339>timestamp) ( -- timestamp )
-    4 read string>number ! year
+    read-0000 ! year
-    CHAR: - expect
+    "-" expect
-    2 read string>number ! month
+    read-00 ! month
-    CHAR: - expect
+    "-" expect
-    2 read string>number ! day
+    read-00 ! day
-    CHAR: T expect
+    "Tt" expect
-    2 read string>number ! hour
+    read-00 ! hour
-    CHAR: : expect
+    ":" expect
-    2 read string>number ! minute
+    read-00 ! minute
-    CHAR: : expect
+    ":" expect
-    2 read string>number ! second
+    read-00 ! second
-    0 <timestamp> ;
+    read-rfc3339-gmt-offset ! timezone
+    <timestamp> ;
 
 : rfc3339>timestamp ( str -- timestamp )
-    [ (rfc3339>timestamp) ] string-in ;
+    [ (rfc3339>timestamp) ] with-string-reader ;
 
 : file-time-string ( timestamp -- string )
     [
@@ -413,7 +434,7 @@ M: timestamp year. ( timestamp -- )
         ] [
             timestamp-year number>string 5 32 pad-left write
         ] if
-    ] string-out ;
+    ] with-string-writer ;
 
 : day-offset ( timestamp m -- timestamp n )
     over day-of-week - ; inline

extra/channels/examples/examples.factor

@@ -24,7 +24,7 @@ IN: channels.examples
         from swap dupd mod zero? not [ swap to ] [ 2drop ] if     
     ] 3keep filter ;
 
-:: (sieve) | prime c |
+:: (sieve) | prime c | ( prime c -- )
     [let | p [ c from ] 
            newc [ <channel> ] |
         p prime to

extra/concurrency/concurrency.factor

@@ -145,12 +145,12 @@ M: process send ( message process -- )
 
 : receive ( -- message )
     self process-mailbox mailbox-get dup linked-exception? [
-        linked-exception-error throw
+        linked-exception-error rethrow
     ] when ;
 
 : receive-if ( pred -- message )
     self process-mailbox mailbox-get? dup linked-exception? [
-        linked-exception-error throw
+        linked-exception-error rethrow
     ] when ; inline
 
 : rethrow-linked ( error -- )
@@ -285,7 +285,7 @@ TUPLE: future value processes ;
     #! place the result on the stack. Return the result
     #! immediately if the future has completed.
     dup future-value [
-        first2 [ throw ] unless
+        first2 [ rethrow ] unless
     ] [
         dup [ future-processes push stop ] curry callcc0 ?future
     ] ?if ;

extra/cpu/8080/8080.factor

@@ -249,32 +249,3 @@ INSTRUCTION: EI           ; opcode FB cycles 04
 INSTRUCTION: CALL M,nn    ; opcode FC cycles 11 
 INSTRUCTION: CP   n       ; opcode FE cycles 07 
 INSTRUCTION: RST  38H     ; opcode FF cycles 11 
-
-! : each-8bit ( n quot -- )
-!   8 [ ! n quot bit
-!    pick over -1 * shift 1 bitand pick call 
-!   ] repeat 2drop ;
-! 
-! : >ppm ( cpu filename -- cpu )
-!   #! Dump the current screen image to a ppm image file with the given name.
-!   <file-writer> [
-!     "P3" print
-!     "256 224" print
-!     "1" print
-!     224 [
-!       32 [
-!         over 32 * over +  HEX: 2400 + ! cpu h w addr
-!         >r pick r> swap cpu-ram nth [
-!           0 = [
-!             " 0 0 0" write
-!           ] [
-!             " 1 1 1" write
-!           ] if
-!         ] each-8bit
-!       ] repeat nl
-!     ] repeat
-!   ] with-stream ;
-
-: time-test ( -- )
-  test-cpu [ 1000000 run-n ] time ;
-

extra/cpu/8080/emulator/emulator.factor

@@ -1,10 +1,9 @@
 ! Copyright (C) 2006 Chris Double.
 ! See http://factorcode.org/license.txt for BSD license.
 !
-USING: kernel math sequences words arrays io 
+USING: kernel math sequences words arrays io io.files namespaces
-       io.files namespaces math.parser kernel.private
+math.parser assocs quotations parser parser-combinators
-       assocs quotations parser parser-combinators tools.time
+tools.time ;
-       sequences.private compiler.units ;
 IN: cpu.8080.emulator
 
 TUPLE: cpu b c d e f h l a pc sp halted? last-interrupt cycles ram ;
@@ -396,39 +395,18 @@ M: cpu write-port ( value port cpu -- )
 : instruction-cycles ( -- vector )
   #! Return a 256 element vector containing the cycles for
   #! each opcode in the 8080 instruction set.
-  { 
+  << 256 f <array> parsed >> ;
-    f f f f f f f f f f f f f f f f f f f f f f f f f f f f f f f f 
-    f f f f f f f f f f f f f f f f f f f f f f f f f f f f f f f f 
-    f f f f f f f f f f f f f f f f f f f f f f f f f f f f f f f f 
-    f f f f f f f f f f f f f f f f f f f f f f f f f f f f f f f f 
-    f f f f f f f f f f f f f f f f f f f f f f f f f f f f f f f f 
-    f f f f f f f f f f f f f f f f f f f f f f f f f f f f f f f f 
-    f f f f f f f f f f f f f f f f f f f f f f f f f f f f f f f f 
-    f f f f f f f f f f f f f f f f f f f f f f f f f f f f f f f f } ;
-
-: instructions ( -- vector )
-  #! Return a 256 element vector containing the emulation words for
-  #! each opcode in the 8080 instruction set.
-  { 
-    f f f f f f f f f f f f f f f f f f f f f f f f f f f f f f f f 
-    f f f f f f f f f f f f f f f f f f f f f f f f f f f f f f f f 
-    f f f f f f f f f f f f f f f f f f f f f f f f f f f f f f f f 
-    f f f f f f f f f f f f f f f f f f f f f f f f f f f f f f f f 
-    f f f f f f f f f f f f f f f f f f f f f f f f f f f f f f f f 
-    f f f f f f f f f f f f f f f f f f f f f f f f f f f f f f f f 
-    f f f f f f f f f f f f f f f f f f f f f f f f f f f f f f f f 
-    f f f f f f f f f f f f f f f f f f f f f f f f f f f f f f f f } ; 
 
 : not-implemented ( <cpu> -- )
   drop ;
 
-instructions length [ 
+: instructions ( -- vector )
-  dup instructions nth [
+  #! Return a 256 element vector containing the emulation words for
-    drop
+  #! each opcode in the 8080 instruction set.
-  ] [
+  << 256 [ [ not-implemented ] 2array ] map parsed >> ; inline
-    [ not-implemented ] swap instructions set-nth 
+
-  ] if
+: set-instruction ( quot n -- )
-] each
+  tuck >r 2array r> instructions set-nth ;
 
 M: cpu reset ( cpu -- )
   #! Reset the CPU to its poweron state
@@ -461,9 +439,9 @@ M: cpu reset ( cpu -- )
 : load-rom ( filename cpu -- )
   #! Load the contents of the file into ROM.
   #! (address 0x0000-0x1FFF).
-  cpu-ram swap <file-reader> [ 
+  cpu-ram swap [ 
     0 swap (load-rom)
-  ] with-stream ;
+  ] with-file-reader ;
 
 SYMBOL: rom-root
 
@@ -477,9 +455,9 @@ SYMBOL: rom-root
   #! file path shoul dbe relative to the '/roms' resource path.
   rom-dir [
     cpu-ram [
-      swap first2 rom-dir swap path+ <file-reader> [      
+      swap first2 rom-dir swap path+ [      
         swap (load-rom)
-      ] with-stream
+      ] with-file-reader
     ] curry each 
   ] [
     ! 
@@ -517,15 +495,6 @@ SYMBOL: rom-root
     ] if     
   ] if ;
 
-: step ( cpu -- )
-  #! Run a single 8080 instruction
-  [ read-instruction ] keep ! n cpu
-  over get-cycles over inc-cycles
-  [ swap instructions dispatch ] keep
-  [ cpu-pc HEX: FFFF bitand ] keep 
-  [ set-cpu-pc ] keep 
-  process-interrupts ;
-
 : peek-instruction ( cpu -- word )
   #! Return the next instruction from the cpu's program
   #! counter, but don't increment the counter.
@@ -560,18 +529,6 @@ SYMBOL: rom-root
   [ " cycles: " write cpu-cycles number>string 5 CHAR: \s pad-left write ] keep 
   nl drop ;
 
-: test-step ( cpu -- cpu )
-  [ step ] keep dup cpu. ;
-
-: test-cpu ( -- cpu )
-  <cpu> "invaders.rom" over load-rom dup cpu. ;
-
-: test-n ( n -- )
-  test-cpu swap [ test-step ] times ;
-
-: run-n ( cpu n -- cpu )
-  [ dup step ] times ;
-
 : register-lookup ( string -- vector )
   #! Given a string containing a register name, return a vector
   #! where the 1st item is the getter and the 2nd is the setter
@@ -1337,11 +1294,9 @@ SYMBOL: last-opcode
   #! Process the list of strings, which should make
   #! up an 8080 instruction, and output a quotation
   #! that would implement that instruction.
-  [
+  dup " " join instruction-quotations
-    dup " " join instruction-quotations
+  >r "_" join [ "emulate-" % % ] "" make create-in dup last-instruction global set-at  
-    >r "_" join [ "emulate-" % % ] "" make create-in dup last-instruction global set-at  
+  r> define ;
-    r> define
-  ] with-compilation-unit ;
 
 : INSTRUCTION: ";" parse-tokens parse-instructions ; parsing
 
@@ -1352,5 +1307,5 @@ SYMBOL: last-opcode
 : opcode ( -- )
   #! Set the opcode number for the last instruction that was defined.
   last-instruction global at 1quotation scan 16 base>
-  dup last-opcode global set-at instructions set-nth ; parsing
+  dup last-opcode global set-at set-instruction ; parsing
 

extra/cpu/8080/test/test.factor

@@ -0,0 +1,51 @@
+USING: kernel cpu.8080 cpu.8080.emulator math math io
+tools.time combinators sequences io.files ;
+IN: cpu.8080.test
+
+: step ( cpu -- )
+  #! Run a single 8080 instruction
+  [ read-instruction ] keep ! n cpu
+  over get-cycles over inc-cycles
+  [ swap instructions case ] keep
+  [ cpu-pc HEX: FFFF bitand ] keep 
+  [ set-cpu-pc ] keep 
+  process-interrupts ;
+
+
+: test-step ( cpu -- cpu )
+  [ step ] keep dup cpu. ;
+
+: test-cpu ( -- cpu )
+  <cpu> "invaders.rom" over load-rom dup cpu. ;
+
+: test-n ( n -- )
+  test-cpu swap [ test-step ] times drop ;
+
+: run-n ( cpu n -- cpu )
+  [ dup step ] times ;
+
+: each-8bit ( n quot -- )
+  8 -rot [ >r bit? r> call ] 2curry each ; inline
+
+: >ppm ( cpu filename -- cpu )
+  #! Dump the current screen image to a ppm image file with the given name.
+  <file-writer> [
+    "P3" print
+    "256 224" print
+    "1" print
+    224 [
+      32 [
+        over 32 * over +  HEX: 2400 + ! cpu h w addr
+        >r pick r> swap cpu-ram nth [
+          0 = [
+            " 0 0 0" write
+          ] [
+            " 1 1 1" write
+          ] if
+        ] each-8bit drop
+      ] each drop nl
+    ] each
+  ] with-stream ;
+
+: time-test ( -- )
+  test-cpu [ 1000000 run-n drop ] time ;

extra/cryptlib/streams/streams.factor

@@ -23,10 +23,10 @@ TUPLE: crypt-stream handle eof? ;
     CRYPT_SESSINFO_ACTIVE 1 set-attribute ;
 
 : <crypt-stream> ( handle -- stream )
-    crypt-stream construct-empty
+    dup init-crypt-stream
-    over init-crypt-stream
+    default-buffer-size <buffer>
-    default-buffer-size <buffer> over set-delegate
+    { set-crypt-stream-handle set-delegate }
-    tuck set-crypt-stream-handle 
+    crypt-stream construct
     dup <line-reader> swap <plain-writer> <duplex-stream> ;
 
 : check-read ( err -- eof? )

extra/db/db.factor

@@ -4,12 +4,9 @@ USING: arrays assocs classes continuations kernel math
 namespaces sequences sequences.lib tuples words strings ;
 IN: db
 
-TUPLE: db handle insert-statements update-statements delete-statements select-statements ;
+TUPLE: db handle insert-statements update-statements delete-statements ;
 : <db> ( handle -- obj )
-    H{ } clone
+    H{ } clone H{ } clone H{ } clone
-    H{ } clone
-    H{ } clone
-    H{ } clone
     db construct-boa ;
 
 GENERIC: db-open ( db -- )
@@ -23,11 +20,10 @@ HOOK: db-close db ( handle -- )
         dup db-insert-statements dispose-statements
         dup db-update-statements dispose-statements
         dup db-delete-statements dispose-statements
-        dup db-select-statements dispose-statements
         db-handle db-close
     ] with-variable ;
 
-TUPLE: statement sql params handle bound? ;
+TUPLE: statement sql params handle bound? slot-names ;
 TUPLE: simple-statement ;
 TUPLE: prepared-statement ;
 
@@ -115,5 +111,7 @@ HOOK: rollback-transaction db ( -- )
     dup string? [
         <simple-statement> [ execute-statement ] with-disposal
     ] [
-        [ [ sql-command ] each ] with-transaction
+        ! [
+            [ sql-command ] each
+        ! ] with-transaction
     ] if ;

extra/db/mysql/mysql.factor

@@ -26,12 +26,6 @@ M: mysql-statement prepare-statement ( statement -- )
 M: mysql-statement bind-statement* ( statement -- )
     ;
 
-M: mysql-statement rebind-statement ( statement -- )
-    ;
-
-M: mysql-statement execute-statement ( statement -- )
-    ;
-
 M: mysql-statement query-results ( query -- result-set )
     ;
 

extra/db/postgresql/postgresql.factor

@@ -3,7 +3,8 @@
 USING: arrays assocs alien alien.syntax continuations io
 kernel math math.parser namespaces prettyprint quotations
 sequences debugger db db.postgresql.lib db.postgresql.ffi
-db.tuples db.types tools.annotations math.ranges ;
+db.tuples db.types tools.annotations math.ranges
+combinators ;
 IN: db.postgresql
 
 TUPLE: postgresql-db host port pgopts pgtty db user pass ;
@@ -52,8 +53,19 @@ M: postgresql-result-set #columns ( result-set -- n )
 M: postgresql-result-set row-column ( result-set n -- obj )
     >r dup result-set-handle swap result-set-n r> PQgetvalue ;
 
+M: postgresql-result-set row-column-typed ( result-set n type -- obj )
+    >r row-column r> sql-type>factor-type ;
+
+M: postgresql-result-set sql-type>factor-type ( obj type -- newobj )
+    {
+        { INTEGER [ string>number ] }
+        { BIG_INTEGER [ string>number ] }
+        { DOUBLE [ string>number ] }
+        [ drop ]
+    } case ;
+
 M: postgresql-statement insert-statement ( statement -- id )
-    query-results [ break 0 row-column ] with-disposal ;
+    query-results [ 0 row-column ] with-disposal string>number ;
 
 M: postgresql-statement query-results ( query -- result-set )
     dup statement-params [
@@ -199,7 +211,7 @@ M: postgresql-db drop-sql ( columns table -- seq )
         over native-id? [ drop-function , ] [ 2drop ] if
     ] { } make ;
 
-M: postgresql-db insert-sql* ( columns table -- sql )
+M: postgresql-db insert-sql* ( columns table -- slot-names sql )
     [
         "select add_" % %
         "(" %
@@ -207,7 +219,7 @@ M: postgresql-db insert-sql* ( columns table -- sql )
         ")" %
     ] "" make ;
 
-M: postgresql-db update-sql* ( columns table -- sql )
+M: postgresql-db update-sql* ( columns table -- slot-names sql )
     [
         "update " %
         %
@@ -219,7 +231,7 @@ M: postgresql-db update-sql* ( columns table -- sql )
         [ primary-key? ] find nip second dup % " = $" % length 2 + #
     ] "" make ;
 
-M: postgresql-db delete-sql* ( columns table -- sql )
+M: postgresql-db delete-sql* ( columns table -- slot-names sql )
     [
         "delete from " %
         %
@@ -227,16 +239,13 @@ M: postgresql-db delete-sql* ( columns table -- sql )
         first second % " = $1" %
     ] "" make ;
 
-M: postgresql-db select-sql* ( columns table -- sql )
+M: postgresql-db select-sql ( columns table -- slot-names sql )
     drop ;
 
 M: postgresql-db tuple>params ( columns tuple -- obj )
     [ >r dup third swap first r> get-slot-named swap ]
     curry { } map>assoc ;
     
-M: postgresql-db last-id ( res -- id )
-    drop f ;
-
 : postgresql-db-modifiers ( -- hashtable )
     H{
         { +native-id+ "not null primary key" }

extra/db/sqlite/ffi/ffi.factor

@@ -125,6 +125,8 @@ FUNCTION: void* sqlite3_column_blob ( sqlite3_stmt* pStmt, int col ) ;
 FUNCTION: int sqlite3_column_bytes ( sqlite3_stmt* pStmt, int col ) ;
 FUNCTION: char* sqlite3_column_decltype ( sqlite3_stmt* pStmt, int col ) ;
 FUNCTION: int sqlite3_column_int ( sqlite3_stmt* pStmt, int col ) ;
+FUNCTION: sqlite3_int64 sqlite3_column_int64 ( sqlite3_stmt* pStmt, int col ) ;
+FUNCTION: double sqlite3_column_double ( sqlite3_stmt* pStmt, int col ) ;
 FUNCTION: int sqlite3_column_name ( sqlite3_stmt* pStmt, int col ) ;
 FUNCTION: char* sqlite3_column_text ( sqlite3_stmt* pStmt, int col ) ;
 FUNCTION: int sqlite3_column_type ( sqlite3_stmt* pStmt, int col ) ;

extra/db/sqlite/lib/lib.factor

@@ -96,6 +96,14 @@ IN: db.sqlite.lib
 : sqlite-column ( handle index -- string )
     sqlite3_column_text ;
 
+: sqlite-column-typed ( handle index type -- obj )
+    {
+        { INTEGER [ sqlite3_column_int ] }
+        { BIG_INTEGER [ sqlite3_column_int64 ] }
+        { TEXT [ sqlite3_column_text ] }
+        { DOUBLE [ sqlite3_column_double ] }
+    } case ;
+
 ! TODO
 : sqlite-row ( handle -- seq )
     dup sqlite-#columns [ sqlite-column ] with map ;

extra/db/sqlite/sqlite.factor

@@ -63,6 +63,9 @@ M: sqlite-result-set #columns ( result-set -- n )
 M: sqlite-result-set row-column ( result-set n -- obj )
     >r result-set-handle r> sqlite-column ;
 
+M: sqlite-result-set row-column-typed ( result-set n type -- obj )
+    >r result-set-handle r> sqlite-column-typed ;
+
 M: sqlite-result-set advance-row ( result-set -- )
     [ result-set-handle sqlite-next ] keep
     set-sqlite-result-set-has-more? ;
@@ -111,6 +114,10 @@ M: sqlite-db insert-sql* ( columns table -- sql )
         ")" %
     ] "" make ;
 
+: where-primary-key% ( columns -- )
+    " where " %
+    [ primary-key? ] find nip second dup % " = :" % % ;
+
 M: sqlite-db update-sql* ( columns table -- sql )
     [
         "update " %
@@ -118,8 +125,7 @@ M: sqlite-db update-sql* ( columns table -- sql )
         " set " %
         dup remove-id
         [ ", " % ] [ second dup % " = :" % % ] interleave
-        " where " %
+        where-primary-key%
-        [ primary-key? ] find nip second dup % " = :" % %
     ] "" make ;
 
 M: sqlite-db delete-sql* ( columns table -- sql )
@@ -130,13 +136,18 @@ M: sqlite-db delete-sql* ( columns table -- sql )
         first second dup % " = :" % %
     ] "" make ;
 
-M: sqlite-db select-sql* ( columns table -- sql )
+: select-interval ( interval name -- )
+    ;
+
+: select-sequence ( seq name -- )
+    ;
+
+M: sqlite-db select-sql ( columns table -- sql )
     [
         "select ROWID, " %
-        swap [ ", " % ] [ second % ] interleave
+        over [ ", " % ] [ second % ] interleave
-        " from " %
+        " from " % %
-        %
+        " where " %
-        " where ROWID = :ID" %
     ] "" make ;
 
 M: sqlite-db tuple>params ( columns tuple -- obj )

extra/db/tuples/tuples-tests.factor

@@ -31,7 +31,7 @@ SYMBOL: the-person
     [ ] [ the-person get update-tuple ] unit-test
 
     [ ] [ the-person get delete-tuple ] unit-test
-    [ ] [ person drop-table ] unit-test ;
+    ; ! 1 [ ] [ person drop-table ] unit-test ;
 
 : test-sqlite ( -- )
     "tuples-test.db" resource-path <sqlite-db> [
@@ -54,17 +54,17 @@ person "PERSON"
 "billy" 10 3.14 <person> the-person set
 
 ! test-sqlite
-test-postgresql
+ test-postgresql
 
-person "PERSON"
+! person "PERSON"
-{
+! {
-    { "the-id" "ID" INTEGER +assigned-id+ }
+    ! { "the-id" "ID" INTEGER +assigned-id+ }
-    { "the-name" "NAME" { VARCHAR 256 } +not-null+ }
+    ! { "the-name" "NAME" { VARCHAR 256 } +not-null+ }
-    { "the-number" "AGE" INTEGER { +default+ 0 } }
+    ! { "the-number" "AGE" INTEGER { +default+ 0 } }
-    { "real" "REAL" DOUBLE { +default+ 0.3 } }
+    ! { "real" "REAL" DOUBLE { +default+ 0.3 } }
-} define-persistent
+! } define-persistent
 
-1 "billy" 20 6.28 <assigned-person> the-person set
+! 1 "billy" 20 6.28 <assigned-person> the-person set
 
 ! test-sqlite
 ! test-postgresql

extra/db/tuples/tuples.factor

@@ -41,10 +41,25 @@ TUPLE: no-slot-named ;
 HOOK: create-sql db ( columns table -- seq )
 HOOK: drop-sql db ( columns table -- seq )
 
-HOOK: insert-sql* db ( columns table -- sql )
+HOOK: insert-sql* db ( columns table -- slot-names sql )
-HOOK: update-sql* db ( columns table -- sql )
+HOOK: update-sql* db ( columns table -- slot-names sql )
-HOOK: delete-sql* db ( columns table -- sql )
+HOOK: delete-sql* db ( columns table -- slot-names sql )
-HOOK: select-sql* db ( columns table -- sql )
+HOOK: select-sql db ( tuple -- statement )
+
+HOOK: row-column-typed db ( result-set n type -- sql )
+HOOK: sql-type>factor-type db ( obj type -- obj )
+HOOK: tuple>params db ( columns tuple -- obj )
+
+
+HOOK: make-slot-names* db ( quot -- seq )
+HOOK: column-slot-name% db ( spec -- )
+HOOK: column-bind-name% db ( spec -- )
+
+: make-slots-names ( quot -- seq str )
+    [ make-slot-names* ] "" make ; inline
+: slot-name% ( seq -- ) first % ;
+: column-name% ( seq -- ) second % ;
+: column-type% ( seq -- ) third % ;
 
 : insert-sql ( columns class -- statement )
     db get db-insert-statements [ insert-sql* ] cache-statement ;
@@ -55,10 +70,6 @@ HOOK: select-sql* db ( columns table -- sql )
 : delete-sql ( columns class -- statement )
     db get db-delete-statements [ delete-sql* ] cache-statement ;
 
-: select-sql ( columns class -- statement )
-    db get db-select-statements [ select-sql* ] cache-statement ;
-
-HOOK: tuple>params db ( columns tuple -- obj )
 
 : tuple-statement ( columns tuple quot -- statement )
     >r [ tuple>params ] 2keep class r> call
@@ -90,8 +101,8 @@ HOOK: tuple>params db ( columns tuple -- obj )
 : delete-tuple ( tuple -- )
     [ [ primary-key? ] subset ] [ delete-sql ] do-tuple-statement ;
 
-! : select-tuple ( tuple -- )
+: select-tuple ( tuple -- )
-  !  [ select-sql ] bind-tuple do-query ;
+    [ select-sql ] keep do-query ;
 
 : persist ( tuple -- )
     dup primary-key [ update-tuple ] [ insert-tuple ] if ;