Merge git://factorcode.org/git/factor

core/alien/compiler/compiler.factor

@@ -5,7 +5,8 @@ hashtables kernel math namespaces sequences words
 inference.state inference.backend inference.dataflow system
 math.parser classes alien.arrays alien.c-types alien.structs
 alien.syntax cpu.architecture alien inspector quotations assocs
-kernel.private threads continuations.private libc combinators ;
+kernel.private threads continuations.private libc combinators
+compiler.errors continuations ;
 IN: alien.compiler
 
 ! Common protocol for alien-invoke/alien-callback/alien-indirect
@@ -207,9 +208,21 @@ M: alien-invoke-error summary
     swap alien-node-parameters parameter-sizes drop
     number>string 3append ;
 
+TUPLE: no-such-library name ;
+
+M: no-such-library summary
+    drop "Library not found" ;
+
+: no-such-library ( name -- )
+    \ no-such-library +linkage+ (inference-error) ;
+
 : (alien-invoke-dlsym) ( node -- symbol dll )
     dup alien-invoke-function
-    swap alien-invoke-library load-library ;
+    swap alien-invoke-library [
+        load-library
+    ] [
+        2drop no-such-library
+    ] recover ;
 
 TUPLE: no-such-symbol ;
 
@@ -217,7 +230,7 @@ M: no-such-symbol summary
     drop "Symbol not found" ;
 
 : no-such-symbol ( -- )
-    \ no-such-symbol inference-error ;
+    \ no-such-symbol +linkage+ (inference-error) ;
 
 : alien-invoke-dlsym ( node -- symbol dll )
     dup (alien-invoke-dlsym) 2dup dlsym [

core/bootstrap/compiler/compiler.factor

@@ -77,14 +77,3 @@ nl
 [ compiled-usages recompile ] recompile-hook set-global
 
 " done" print flush
-
-! Load empty test vocabs
-USE: compiler.test.curry
-USE: compiler.test.float
-USE: compiler.test.intrinsics
-USE: compiler.test.redefine
-USE: compiler.test.simple
-USE: compiler.test.stack-trace
-USE: compiler.test.templates
-USE: compiler.test.templates-early
-USE: compiler.test.tuples

core/bootstrap/image/image.factor

@@ -7,7 +7,7 @@ strings sbufs vectors words quotations assocs system layouts
 splitting growable classes tuples words.private
 io.binary io.files vocabs vocabs.loader source-files
 definitions debugger float-arrays quotations.private
-combinators.private combinators ;
+sequences.private combinators ;
 IN: bootstrap.image
 
 : my-arch ( -- arch )

core/bootstrap/layouts/layouts.factor

@@ -1,4 +1,4 @@
-! Copyright (C) 2007 Slava Pestov.
+! Copyright (C) 2007, 2008 Slava Pestov.
 ! See http://factorcode.org/license.txt for BSD license.
 USING: namespaces math words kernel alien byte-arrays
 hashtables vectors strings sbufs arrays bit-arrays
@@ -8,7 +8,7 @@ BIN: 111 tag-mask set
 8 num-tags set
 3 tag-bits set
 
-20 num-types set
+19 num-types set
 
 H{
     { fixnum      BIN: 000 }
@@ -27,11 +27,10 @@ tag-numbers get H{
     { float-array 10 }
     { callstack 11 }
     { string 12 }
-    { curry 13 }
+    { bit-array 13 }
     { quotation 14 }
     { dll 15 }
     { alien 16 }
     { word 17 }
     { byte-array 18 }
-    { bit-array 19 }
 } union type-numbers set

core/bootstrap/primitives.factor

@@ -295,23 +295,6 @@ define-builtin
 "float-array?" "float-arrays" create
 { } define-builtin
 
-"curry" "kernel" create
-"curry?" "kernel" create
-{
-    {
-        { "object" "kernel" }
-        "obj"
-        { "curry-obj" "kernel" }
-        f
-    }
-    {
-        { "object" "kernel" }
-        "obj"
-        { "curry-quot" "kernel" }
-        f
-    }
-} define-builtin
-
 "callstack" "kernel" create "callstack?" "kernel" create
 { } define-builtin
 
@@ -440,14 +423,44 @@ builtins get num-tags get tail f union-class define-class
     }
 } define-tuple-class
 
+"curry" "kernel" create
+{
+    {
+        { "object" "kernel" }
+        "obj"
+        { "curry-obj" "kernel" }
+        f
+    } {
+        { "object" "kernel" }
+        "quot"
+        { "curry-quot" "kernel" }
+        f
+    }
+} define-tuple-class
+
+"compose" "kernel" create
+{
+    {
+        { "object" "kernel" }
+        "first"
+        { "compose-first" "kernel" }
+        f
+    } {
+        { "object" "kernel" }
+        "second"
+        { "compose-second" "kernel" }
+        f
+    }
+} define-tuple-class
+
 ! Primitive words
 : make-primitive ( word vocab n -- )
-    >r create dup reset-word r> [ do-primitive ] curry [ ] like define ;
+    >r create dup reset-word r>
+    [ do-primitive ] curry [ ] like define ;
 
 {
     { "(execute)" "words.private" }
     { "(call)" "kernel.private" }
-    { "uncurry" "kernel.private" }
     { "bignum>fixnum" "math.private" }
     { "float>fixnum" "math.private" }
     { "fixnum>bignum" "math.private" }
@@ -622,7 +635,6 @@ builtins get num-tags get tail f union-class define-class
     { "become" "kernel.private" }
     { "(sleep)" "threads.private" }
     { "<float-array>" "float-arrays" }
-    { "curry" "kernel" }
     { "<tuple-boa>" "tuples.private" }
     { "class-hash" "kernel.private" }
     { "callstack>array" "kernel" }

core/bootstrap/stage1.factor

@@ -38,7 +38,7 @@ vocabs.loader system ;
 
     [
         "resource:core/bootstrap/stage2.factor"
-        dup ?resource-path exists? [
+        dup resource-exists? [
             run-file
         ] [
             "Cannot find " write write "." print

core/combinators/combinators-docs.factor

@@ -1,6 +1,6 @@
 USING: arrays help.markup help.syntax strings sbufs vectors
 kernel quotations generic generic.standard classes
-math assocs sequences combinators.private ;
+math assocs sequences sequences.private ;
 IN: combinators
 
 ARTICLE: "combinators-quot" "Quotation construction utilities"

core/combinators/combinators.factor

@@ -4,12 +4,6 @@ IN: combinators
 USING: arrays sequences sequences.private math.private
 kernel kernel.private math assocs quotations vectors ;
 
-<PRIVATE
-
-: dispatch ( n array -- ) array-nth (call) ;
-
-PRIVATE>
-
 TUPLE: no-cond ;
 
 : no-cond ( -- * ) \ no-cond construct-empty throw ;

core/compiler/errors/errors-docs.factor

@@ -1,14 +1,15 @@
 IN: compiler.errors
 USING: help.markup help.syntax vocabs.loader words io
-quotations ;
+quotations compiler.errors.private ;
 
 ARTICLE: "compiler-errors" "Compiler warnings and errors"
-"The compiler saves compile warnings and errors in a global variable:"
+"The compiler saves various notifications in a global variable:"
 { $subsection compiler-errors }
-"The warnings and errors can be viewed later:"
+"These notifications can be viewed later:"
-{ $subsection :warnings }
 { $subsection :errors }
-"Normally, all warnings and errors are displayed at the end of a batch compilation, such as a call to " { $link require } " or " { $link refresh-all } ". This can be controlled with a combinator:"
+{ $subsection :warnings }
+{ $subsection :linkage }
+"Words such as " { $link require } " and " { $link refresh-all } " use a combinator which counts errors and prints a report at the end:"
 { $link with-compiler-errors } ;
 
 HELP: compiler-errors
@@ -16,7 +17,7 @@ HELP: compiler-errors
 
 HELP: compiler-error
 { $values { "error" "an error" } { "word" word } }
-{ $description "If inside a " { $link with-compiler-errors } ", saves the error for future persual via " { $link :errors } " and " { $link :warnings } ", otherwise ignores the error." } ;
+{ $description "If inside a " { $link with-compiler-errors } ", saves the error for future persual via " { $link :errors } ", " { $link :warnings } " and " { $link :linkage } ". If not inside a " { $link with-compiler-errors } ", ignores the error." } ;
 
 HELP: compiler-error.
 { $values { "error" "an error" } { "word" word } }
@@ -25,24 +26,18 @@ HELP: compiler-error.
 HELP: compiler-errors.
 { $values { "errors" "an assoc mapping words to errors" } }
 { $description "Prints a set of compiler errors to the " { $link stdio } " stream." } ;
-
-HELP: (:errors)
-{ $values { "seq" "an alist" } }
-{ $description "Outputs all serious compiler errors from the most recent compile."  } ;
-
 HELP: :errors
 { $description "Prints all serious compiler errors from the most recent compile to the " { $link stdio } " stream." } ;
 
-HELP: (:warnings)
-{ $values { "seq" "an alist" } }
-{ $description "Outputs all ignorable compiler warnings from the most recent compile."  } ;
-
 HELP: :warnings
 { $description "Prints all ignorable compiler warnings from the most recent compile to the " { $link stdio } " stream." } ;
 
-{ :errors (:errors) :warnings (:warnings) } related-words
+HELP: :linkage
+{ $description "Prints all C library interface linkage errors from the most recent compile to the " { $link stdio } " stream." } ;
+
+{ :errors :warnings } related-words
 
 HELP: with-compiler-errors
 { $values { "quot" quotation } }
-{ $description "Calls the quotation and collects any compiler warnings and errors. Compiler warnings and errors are summarized at the end and can be viewed with " { $link :warnings } " and " { $link :errors } "." }
+{ $description "Calls the quotation and collects any compiler warnings and errors. Compiler warnings and errors are summarized at the end and can be viewed with " { $link :errors } ", " { $link :warnings } ", and " { $link :linkage } "." }
 { $notes "Nested calls to " { $link with-compiler-errors } " are ignored, and only the outermost call collects warnings and errors." } ;

core/compiler/errors/errors.factor

@@ -4,51 +4,66 @@ USING: kernel namespaces assocs prettyprint io sequences
 sorting continuations debugger math math.parser ;
 IN: compiler.errors
 
+SYMBOL: +error+
+SYMBOL: +warning+
+SYMBOL: +linkage+
+
+GENERIC: compiler-error-type ( error -- ? )
+
+M: object compiler-error-type drop +error+ ;
+
+<PRIVATE
+
 SYMBOL: compiler-errors
 
 SYMBOL: with-compiler-errors?
 
-: compiler-error ( error word -- )
-    with-compiler-errors? get [
-        compiler-errors get pick
-        [ set-at ] [ delete-at drop ] if
-    ] [ 2drop ] if ;
-
 : compiler-error. ( error word -- )
     nl
     "While compiling " write pprint ": " print
     nl
     print-error ;
 
-: compiler-errors. ( assoc -- )
+: errors-of-type ( type -- assoc )
-    >alist sort-keys [ swap compiler-error. ] assoc-each ;
-
-GENERIC: compiler-warning? ( error -- ? )
-
-M: object compiler-warning? drop f ;
-
-: (:errors) ( -- assoc )
     compiler-errors get-global
-    [ nip compiler-warning? not ] assoc-subset ;
+    swap [ >r nip compiler-error-type r> eq? ] curry
+    assoc-subset ;
 
-: :errors (:errors) compiler-errors. ;
+: compiler-errors. ( type -- )
+    errors-of-type >alist sort-keys
+    [ swap compiler-error. ] assoc-each ;
 
-: (:warnings) ( -- seq )
+: (compiler-report) ( what type word -- )
-    compiler-errors get-global
+    over errors-of-type assoc-empty? [ 3drop ] [
-    [ nip compiler-warning? ] assoc-subset ;
-
-: :warnings (:warnings) compiler-errors. ;
-
-: (compiler-report) ( what assoc -- )
-    length dup zero? [ 2drop ] [
         [
-            ":" % over % " - print " % # " compiler " % % "." %
+            ":" %
+            %
+            " - print " %
+            errors-of-type assoc-size #
+            " " %
+            %
+            "." %
         ] "" make print
     ] if ;
 
 : compiler-report ( -- )
-    "errors" (:errors) (compiler-report)
+    "semantic errors" +error+ "errors" (compiler-report)
-    "warnings" (:warnings) (compiler-report) ;
+    "semantic warnings" +warning+ "warnings" (compiler-report)
+    "linkage errors" +linkage+ "linkage" (compiler-report) ;
+
+PRIVATE>
+
+: compiler-error ( error word -- )
+    with-compiler-errors? get [
+        compiler-errors get pick
+        [ set-at ] [ delete-at drop ] if
+    ] [ 2drop ] if ;
+
+: :errors +error+ compiler-errors. ;
+
+: :warnings +warning+ compiler-errors. ;
+
+: :linkage +linkage+ compiler-errors. ;
 
 : with-compiler-errors ( quot -- )
     with-compiler-errors? get "quiet" get or [ call ] [

core/compiler/test/redefine/redefine-tests.factor

@@ -1,287 +0,0 @@
-USING: compiler definitions generic assocs inference math
-namespaces parser tools.test words kernel sequences arrays io
-effects tools.test compiler.units inference.state ;
-IN: temporary
-
-DEFER: x-1
-DEFER: x-2
-
-[ [ f ] { } map>assoc modify-code-heap ] recompile-hook [
-    "IN: temporary USE: math GENERIC: x-1 ( x -- y ) M: integer x-1 ;" eval
-    "IN: temporary : x-2 3 x-1 ;" eval
-
-    [ t ] [
-        { x-2 } compile
-
-        \ x-2 word-xt
-
-        { x-1 } compile
-
-        \ x-2 word-xt =
-    ] unit-test
-] with-variable
-
-DEFER: b
-DEFER: c
-
-[ ] [ "IN: temporary : a 1 2 ; : b a a ;" eval ] unit-test
-
-[ 1 2 1 2 ] [ "USE: temporary b" eval ] unit-test
-
-{ 0 4 } [ b ] must-infer-as
-
-[ ] [ "IN: temporary : a 1 2 3 ;" eval ] unit-test
-
-[ 1 2 3 1 2 3 ] [ "USE: temporary b" eval ] unit-test
-
-{ 0 6 } [ b ] must-infer-as
-
-\ b word-xt "b-xt" set
-
-[ ] [ "IN: temporary : c b ;" eval ] unit-test
-
-[ t ] [ "b-xt" get \ b word-xt = ] unit-test
-
-\ c word-xt "c-xt" set
-
-[ ] [ "IN: temporary : a 1 2 4 ;" eval ] unit-test
-
-[ t ] [ "c-xt" get \ c word-xt = ] unit-test
-
-[ 1 2 4 1 2 4 ] [ "USE: temporary c" eval ] unit-test
-
-[ ] [ "IN: temporary : a 1 2 ;" eval ] unit-test
-
-{ 0 4 } [ c ] must-infer-as
-
-[ f ] [ "c-xt" get \ c word-xt = ] unit-test
-
-[ 1 2 1 2 ] [ "USE: temporary c" eval ] unit-test
-
-[ ] [ "IN: temporary : d 3 ; inline" eval ] unit-test
-
-[ ] [ "IN: temporary : e d d ;" eval ] unit-test
-
-[ 3 3 ] [ "USE: temporary e" eval ] unit-test
-
-[ ] [ "IN: temporary : d 4 ; inline" eval ] unit-test
-
-[ 4 4 ] [ "USE: temporary e" eval ] unit-test
-
-DEFER: x-3
-
-[ ] [ "IN: temporary : x-3 3 ;" eval ] unit-test
-
-DEFER: x-4
-
-[ ] [ "IN: temporary : x-4 x-3 ;" eval ] unit-test
-
-[ t ] [ \ x-4 compiled? ] unit-test
-
-[ ] [ "IN: temporary USE: sequences : x-3 { } [ ] each ;" eval ] unit-test
-
-[ f ] [ \ x-3 compiled? ] unit-test
-
-[ f ] [ \ x-4 compiled? ] unit-test
-
-[ ] [ "IN: temporary USING: kernel sequences ; : x-3 { } [ drop ] each ;" eval ] unit-test
-
-[ t ] [ \ x-3 compiled? ] unit-test
-
-[ t ] [ \ x-4 compiled? ] unit-test
-
-[ t ] [ \ x-3 "compiled-uses" word-prop >boolean ] unit-test
-
-DEFER: g-test-1
-
-DEFER: g-test-3
-
-[ ] [ "IN: temporary USE: math GENERIC: g-test-1 ( x -- y ) M: integer g-test-1 sq ;" eval ] unit-test
-
-[ ] [ "IN: temporary : g-test-2 ( -- y ) 3 g-test-1 ;" eval ] unit-test
-
-[ ] [ "IN: temporary : g-test-3 ( -- y ) g-test-2 ;" eval ] unit-test
-
-[ 25 ] [ 5 g-test-1 ] unit-test
-
-[ ] [ "IN: temporary USE: math GENERIC: g-test-1 ( x -- y ) M: integer g-test-1 ;" eval ] unit-test
-
-[ 5 ] [ 5 g-test-1 ] unit-test
-
-[ t ] [
-    \ g-test-3 word-xt
-
-    "IN: temporary USE: math GENERIC: g-test-1 ( x -- y ) M: integer g-test-1 3 + ;" eval
-
-    \ g-test-3 word-xt =
-] unit-test
-
-DEFER: g-test-5
-
-[ ] [ "IN: temporary : g-test-4 ( -- y ) 3 g-test-1 ; inline" eval ] unit-test
-
-[ ] [ "IN: temporary : g-test-5 ( -- y ) g-test-4 ;" eval ] unit-test
-
-[ 6 ] [ g-test-5 ] unit-test
-
-[ ] [ "IN: temporary USE: math GENERIC: g-test-1 ( x -- y ) M: integer g-test-1 10 + ;" eval ] unit-test
-
-[ 13 ] [ g-test-5 ] unit-test
-
-DEFER: g-test-6
-
-[ ] [ "IN: temporary USING: arrays kernel ; GENERIC: g-test-6 ( x -- y ) M: array g-test-6 drop 123 g-test-1 ;" eval ] unit-test
-
-DEFER: g-test-7
-
-[ ] [ "IN: temporary : g-test-7 { } g-test-6 ;" eval ] unit-test
-
-[ 133 ] [ g-test-7 ] unit-test
-
-[ ] [ "IN: temporary USE: math GENERIC: g-test-1 ( x -- y ) M: integer g-test-1 15 + ;" eval ] unit-test
-
-[ 138 ] [ g-test-7 ] unit-test
-
-USE: macros
-
-DEFER: macro-test-3
-
-[ ] [ "IN: temporary USING: macros math ; : macro-test-1 sq ;" eval ] unit-test
-
-[ ] [ "IN: temporary USING: macros arrays quotations ; MACRO: macro-test-2 ( n word -- quot ) <array> >quotation ;" eval ] unit-test
-
-[ ] [ "IN: temporary : macro-test-3 2 \\ macro-test-1 macro-test-2 ;" eval ] unit-test
-
-[ 625 ] [ 5 macro-test-3 ] unit-test
-
-[ ] [ "IN: temporary USING: macros arrays quotations kernel math ; MACRO: macro-test-2 ( n word -- quot ) 2drop [ 3 + ] ;" eval ] unit-test
-
-[ 8 ] [ 5 macro-test-3 ] unit-test
-
-USE: hints
-
-DEFER: hints-test-2
-
-[ ] [ "IN: temporary USING: math hints ; : hints-test-1 3 + ; HINTS: hints-test-1 fixnum ;" eval ] unit-test
-
-[ ] [ "IN: temporary : hints-test-2 5 hints-test-1 ;" eval ] unit-test
-
-[ 8 ] [ hints-test-2 ] unit-test
-
-[ ] [ "IN: temporary USE: math : hints-test-1 5 + ;" eval ] unit-test
-
-[ 10 ] [ hints-test-2 ] unit-test
-
-DEFER: inline-then-not-inline-test-1
-DEFER: inline-then-not-inline-test-2
-
-[ ] [ "IN: temporary : inline-then-not-inline-test-1 1 2 3 ; inline" eval ] unit-test
-
-[ ] [ "IN: temporary : inline-then-not-inline-test-2 inline-then-not-inline-test-1 ;" eval ] unit-test
-
-[ 1 2 3 ] [ inline-then-not-inline-test-2 ] unit-test
-
-\ inline-then-not-inline-test-2 word-xt "a" set
-
-[ ] [ "IN: temporary : inline-then-not-inline-test-1 6 6 9 ;" eval ] unit-test
-
-[ f ] [ \ inline-then-not-inline-test-2 word-xt "a" get = ] unit-test
-
-[ 6 6 9 ] [ inline-then-not-inline-test-2 ] unit-test
-
-DEFER: generic-then-not-generic-test-1
-DEFER: generic-then-not-generic-test-2
-
-[ ] [ "IN: temporary GENERIC: generic-then-not-generic-test-1 ( a -- b )" eval ] unit-test
-
-[ ] [ "IN: temporary USE: math M: integer generic-then-not-generic-test-1 sq ;" eval ] unit-test
-
-[ ] [ "IN: temporary : generic-then-not-generic-test-2 3 generic-then-not-generic-test-1 ;" eval ] unit-test
-
-[ 9 ] [ generic-then-not-generic-test-2 ] unit-test
-
-[ ] [ "IN: temporary USE: math : generic-then-not-generic-test-1 1 + ;" eval ] unit-test
-
-[ 4 ] [ generic-then-not-generic-test-2 ] unit-test
-
-DEFER: foldable-test-1
-DEFER: foldable-test-2
-
-[ ] [ "IN: temporary : foldable-test-1 3 ; foldable" eval ] unit-test
-
-[ ] [ "IN: temporary : foldable-test-2 foldable-test-1 ;" eval ] unit-test
-
-[ +inlined+ ] [ \ foldable-test-2 \ foldable-test-1 compiled-usage at ] unit-test
-
-[ 3 ] [ foldable-test-2 ] unit-test
-
-[ ] [ "IN: temporary : foldable-test-1 4 ; foldable" eval ] unit-test
-
-[ 4 ] [ foldable-test-2 ] unit-test
-
-DEFER: flushable-test-2
-
-[ ] [ "IN: temporary USE: kernel : flushable-test-1 drop 3 ; flushable" eval ] unit-test
-
-[ ] [ "IN: temporary USE: kernel : flushable-test-2 V{ } dup flushable-test-1 drop ;" eval ] unit-test
-
-[ V{ } ] [ flushable-test-2 ] unit-test
-
-[ ] [ "IN: temporary USING: kernel sequences ; : flushable-test-1 3 over push ;" eval ] unit-test
-
-[ V{ 3 } ] [ flushable-test-2 ] unit-test
-
-: ax ;
-: bx ax ;
-[ \ bx forget ] with-compilation-unit
-
-[ f ] [ \ bx \ ax compiled-usage key? ] unit-test
-
-DEFER: defer-redefine-test-2
-
-[ ] [ "IN: temporary DEFER: defer-redefine-test-1" eval ] unit-test
-
-[ ] [ "IN: temporary : defer-redefine-test-2 defer-redefine-test-1 1 ;" eval ] unit-test
-
-[ defer-redefine-test-2 ] must-fail
-
-[ ] [ "IN: temporary : defer-redefine-test-1 2 ;" eval ] unit-test
-
-[ 2 1 ] [ defer-redefine-test-2 ] unit-test
-
-! Cross-referencing issue
-: compiled-xref-a ;
-
-: compiled-xref-c ; inline
-
-GENERIC: compiled-xref-b ( a -- b )
-
-TUPLE: c-1 ;
-
-M: c-1 compiled-xref-b compiled-xref-a compiled-xref-c ;
-
-TUPLE: c-2 ;
-
-M: c-2 compiled-xref-b drop 3 ;
-
-[ t ] [
-    \ compiled-xref-a compiled-crossref get key?
-] unit-test
-
-[ ] [
-    [
-        \ compiled-xref-a forget
-    ] with-compilation-unit
-] unit-test
-
-[ f ] [
-    \ compiled-xref-a compiled-crossref get key?
-] unit-test
-
-[ ] [
-    "IN: temporary : compiled-xref-c ; FORGET: { c-2 compiled-xref-b }" eval
-] unit-test
-
-[ f ] [
-    \ compiled-xref-a compiled-crossref get key?
-] unit-test

core/compiler/tests/intrinsics.factor

@@ -4,7 +4,7 @@ math.private sequences strings tools.test words continuations
 sequences.private hashtables.private byte-arrays strings.private
 system random layouts vectors.private sbufs.private
 strings.private slots.private alien alien.accessors
-alien.c-types alien.syntax namespaces libc combinators.private ;
+alien.c-types alien.syntax namespaces libc sequences.private ;
 
 ! Make sure that intrinsic ops compile to correct code.
 [ ] [ 1 [ drop ] compile-call ] unit-test

core/compiler/tests/simple.factor

@@ -1,5 +1,5 @@
 USING: compiler tools.test kernel kernel.private
-combinators.private math.private math combinators strings
+sequences.private math.private math combinators strings
 alien arrays memory ;
 IN: temporary
 

core/compiler/tests/templates.factor

@@ -2,7 +2,7 @@
 USING: arrays compiler kernel kernel.private math
 hashtables.private math.private namespaces sequences
 sequences.private tools.test namespaces.private slots.private
-combinators.private byte-arrays alien alien.accessors layouts
+sequences.private byte-arrays alien alien.accessors layouts
 words definitions compiler.units ;
 IN: temporary
 

core/continuations/continuations.factor

@@ -98,7 +98,7 @@ PRIVATE>
 : continue-with ( obj continuation -- )
     [
         walker-hook [ >r 2array r> ] when* (continue-with)
-    ] 2curry (throw) ;
+    ] 2 (throw) ;
 
 : continue ( continuation -- )
     f swap continue-with ;

core/generic/math/math.factor

@@ -2,7 +2,7 @@
 ! See http://factorcode.org/license.txt for BSD license.
 USING: arrays generic hashtables kernel kernel.private
 math namespaces sequences words quotations layouts combinators
-combinators.private classes definitions ;
+sequences.private classes definitions ;
 IN: generic.math
 
 PREDICATE: class math-class ( object -- ? )

core/generic/standard/standard.factor

@@ -2,7 +2,7 @@
 ! See http://factorcode.org/license.txt for BSD license.
 USING: arrays assocs kernel kernel.private slots.private math
 namespaces sequences vectors words quotations definitions
-hashtables layouts combinators combinators.private generic
+hashtables layouts combinators sequences.private generic
 classes classes.private ;
 IN: generic.standard
 

core/inference/backend/backend-docs.factor

@@ -1,6 +1,6 @@
 USING: help.syntax help.markup words effects inference.dataflow
 inference.state inference.backend kernel sequences
-kernel.private combinators combinators.private ;
+kernel.private combinators sequences.private ;
 
 HELP: literal-expected
 { $error-description "Thrown when inference encounters a " { $link call } " or " { $link if } " being applied to a value which is not known to be a literal. Such a form can have an arbitrary stack effect, and does not compile." }

core/inference/backend/backend.factor

@@ -24,24 +24,24 @@ IN: inference.backend
 : recursive-quotation? ( quot -- ? )
     local-recursive-state [ first eq? ] with contains? ;
 
-TUPLE: inference-error rstate major? ;
+TUPLE: inference-error rstate type ;
 
-M: inference-error compiler-warning?
+M: inference-error compiler-error-type
-    inference-error-major? not ;
+    inference-error-type ;
 
-: (inference-error) ( ... class important? -- * )
+: (inference-error) ( ... class type -- * )
     >r construct-boa r>
     recursive-state get {
         set-delegate
-        set-inference-error-major?
+        set-inference-error-type
         set-inference-error-rstate
     } \ inference-error construct throw ; inline
 
 : inference-error ( ... class -- * )
-    t (inference-error) ; inline
+    +error+ (inference-error) ; inline
 
 : inference-warning ( ... class -- * )
-    f (inference-error) ; inline
+    +warning+ (inference-error) ; inline
 
 TUPLE: literal-expected ;
 

core/inference/class/class-tests.factor

@@ -269,7 +269,17 @@ cell-bits 32 = [
     \ number= inlined?
 ] unit-test
 
+[ t ] [
+    [ B{ 1 0 } *short 0 { number number } declare number= ]
+    \ number= inlined?
+] unit-test
+
 [ t ] [
     [ B{ 1 0 } *short 0 = ]
     \ number= inlined?
 ] unit-test
+
+[ t ] [
+    [ B{ 1 0 } *short dup number? [ 0 number= ] [ drop f ] if ]
+    \ number= inlined?
+] unit-test

core/inference/class/class.factor

@@ -73,17 +73,27 @@ SYMBOL: value-intervals
 ! Current value --> class mapping
 SYMBOL: value-classes
 
+: value-interval* ( value -- interval/f )
+    value-intervals get at ;
+
 : set-value-interval* ( interval value -- )
     value-intervals get set-at ;
 
+: intersect-value-interval ( interval value -- )
+    [ value-interval* interval-intersect ] keep
+    set-value-interval* ;
+
 M: interval-constraint apply-constraint
     dup interval-constraint-interval
-    swap interval-constraint-value set-value-interval* ;
+    swap interval-constraint-value intersect-value-interval ;
 
 : set-class-interval ( class value -- )
     >r "interval" word-prop dup
     [ r> set-value-interval* ] [ r> 2drop ] if ;
 
+: value-class* ( value -- class )
+    value-classes get at object or ;
+
 : set-value-class* ( class value -- )
     over [
         dup value-intervals get at [
@@ -93,9 +103,12 @@ M: interval-constraint apply-constraint
     ] when
     value-classes get set-at ;
 
+: intersect-value-class ( class value -- )
+    [ value-class* class-and ] keep set-value-class* ;
+
 M: class-constraint apply-constraint
     dup class-constraint-class
-    swap class-constraint-value set-value-class* ;
+    swap class-constraint-value intersect-value-class ;
 
 : set-value-literal* ( literal value -- )
     over class over set-value-class*
@@ -127,16 +140,10 @@ M: literal-constraint constraint-satisfied?
     dup literal-constraint-value value-literal*
     [ swap literal-constraint-literal eql? ] [ 2drop f ] if ;
 
-: value-class* ( value -- class )
-    value-classes get at object or ;
-
 M: class-constraint constraint-satisfied?
     dup class-constraint-value value-class*
     swap class-constraint-class class< ;
 
-: value-interval* ( value -- interval/f )
-    value-intervals get at ;
-
 M: pair apply-constraint
     first2 2dup constraints get set-at
     constraint-satisfied? [ apply-constraint ] [ drop ] if ;
@@ -159,13 +166,10 @@ M: pair constraint-satisfied?
     2drop ;
 
 : intersect-classes ( classes values -- )
-    [ [ value-class* class-and ] keep set-value-class* ] 2each ;
+    [ intersect-value-class ] 2each ;
 
 : intersect-intervals ( intervals values -- )
-    [
+    [ intersect-value-interval ] 2each ;
-        [ value-interval* interval-intersect ] keep
-        set-value-interval*
-    ] 2each ;
 
 : predicate-constraints ( class #call -- )
     [
@@ -181,20 +185,14 @@ M: pair constraint-satisfied?
         [ swap predicate-constraints ] [ 2drop ] if
     ] if* ;
 
-: default-output-classes ( word -- classes )
-    "inferred-effect" word-prop {
-        { [ dup not ] [ drop f ] }
-        { [ dup effect-out [ class? ] all? not ] [ drop f ] }
-        { [ t ] [ effect-out ] }
-    } cond ;
-
 : compute-output-classes ( node word -- classes intervals )
-    dup node-param "output-classes" word-prop dup
+    dup node-param "output-classes" word-prop
-    [ call ] [ 2drop f f ] if ;
+    dup [ call ] [ 2drop f f ] if ;
 
 : output-classes ( node -- classes intervals )
-    dup compute-output-classes
+    dup compute-output-classes >r
-    >r [ ] [ node-param default-output-classes ] ?if r> ;
+    [ ] [ node-param "default-output-classes" word-prop ] ?if
+    r> ;
 
 M: #call infer-classes-before
     dup compute-constraints
@@ -220,7 +218,8 @@ M: #dispatch child-constraints
     ] make-constraints ;
 
 M: #declare infer-classes-before
-    dup node-param swap node-in-d [ set-value-class* ] 2each ;
+    dup node-param swap node-in-d
+    [ intersect-value-class ] 2each ;
 
 DEFER: (infer-classes)
 

core/inference/dataflow/dataflow.factor

@@ -256,6 +256,28 @@ SYMBOL: node-stack
         ] iterate-nodes drop
     ] with-node-iterator ; inline
 
+: change-children ( node quot -- )
+    over [
+        >r dup node-children dup r>
+        [ map swap set-node-children ] curry
+        [ 2drop ] if
+    ] [
+        2drop
+    ] if ; inline
+
+: (transform-nodes) ( prev node quot -- )
+    dup >r call dup [
+        dup rot set-node-successor
+        dup node-successor r> (transform-nodes)
+    ] [
+        r> drop f swap set-node-successor drop
+    ] if ; inline
+
+: transform-nodes ( node quot -- new-node )
+    over [
+        [ call dup dup node-successor ] keep (transform-nodes)
+    ] [ drop ] if ; inline
+
 : node-literal? ( node value -- ? )
     dup value? >r swap node-literals key? r> or ;
 

core/inference/inference-tests.factor

@@ -5,7 +5,7 @@ sequences strings vectors words quotations effects tools.test
 continuations generic.standard sorting assocs definitions
 prettyprint io inspector tuples classes.union classes.predicate
 debugger threads.private io.streams.string io.timeouts
-combinators.private ;
+sequences.private ;
 IN: temporary
 
 { 0 2 } [ 2 "Hello" ] must-infer-as

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

@@ -1,7 +1,7 @@
 ! Copyright (C) 2004, 2008 Slava Pestov.
 ! See http://factorcode.org/license.txt for BSD license.
 USING: alien alien.accessors arrays bit-arrays byte-arrays
-classes combinators.private continuations.private effects
+classes sequences.private continuations.private effects
 float-arrays generic hashtables hashtables.private
 inference.state inference.backend inference.dataflow io
 io.backend io.files io.files.private io.streams.c kernel
@@ -126,15 +126,11 @@ M: object infer-call
     pop-d pop-d swap <curried> push-d
 ] "infer" set-word-prop
 
-\ curry { object object } { curry } <effect> "inferred-effect" set-word-prop
-
 \ compose [
     2 ensure-values
     pop-d pop-d swap <composed> push-d
 ] "infer" set-word-prop
 
-\ compose { object object } { curry } <effect> "inferred-effect" set-word-prop
-
 ! Variadic tuple constructor
 \ <tuple-boa> [
     \ <tuple-boa>
@@ -142,457 +138,461 @@ M: object infer-call
     make-call-node
 ] "infer" set-word-prop
 
-! We need this for default-output-classes
-\ <tuple-boa> 2 { tuple } <effect> "inferred-effect" set-word-prop
-
 ! Non-standard control flow
-\ (throw) { callable } { } <effect>
+\ (throw) [
-t over set-effect-terminated?
+    \ (throw)
-"inferred-effect" set-word-prop
+    peek-d value-literal 2 + { } <effect>
+    t over set-effect-terminated?
+    make-call-node
+] "infer" set-word-prop
+
+:  set-primitive-effect ( word effect -- )
+    2dup effect-out "default-output-classes" set-word-prop
+    dupd [ make-call-node ] 2curry "infer" set-word-prop ;
 
 ! Stack effects for all primitives
-\ fixnum< { fixnum fixnum } { object } <effect> "inferred-effect" set-word-prop
+\ fixnum< { fixnum fixnum } { object } <effect> set-primitive-effect
 \ fixnum< make-foldable
 
-\ fixnum<= { fixnum fixnum } { object } <effect> "inferred-effect" set-word-prop
+\ fixnum<= { fixnum fixnum } { object } <effect> set-primitive-effect
 \ fixnum<= make-foldable
 
-\ fixnum> { fixnum fixnum } { object } <effect> "inferred-effect" set-word-prop
+\ fixnum> { fixnum fixnum } { object } <effect> set-primitive-effect
 \ fixnum> make-foldable
 
-\ fixnum>= { fixnum fixnum } { object } <effect> "inferred-effect" set-word-prop
+\ fixnum>= { fixnum fixnum } { object } <effect> set-primitive-effect
 \ fixnum>= make-foldable
 
-\ eq? { object object } { object } <effect> "inferred-effect" set-word-prop
+\ eq? { object object } { object } <effect> set-primitive-effect
 \ eq? make-foldable
 
-\ rehash-string { string } { } <effect> "inferred-effect" set-word-prop
+\ rehash-string { string } { } <effect> set-primitive-effect
 
-\ bignum>fixnum { bignum } { fixnum } <effect> "inferred-effect" set-word-prop
+\ bignum>fixnum { bignum } { fixnum } <effect> set-primitive-effect
 \ bignum>fixnum make-foldable
 
-\ float>fixnum { float } { fixnum } <effect> "inferred-effect" set-word-prop
+\ float>fixnum { float } { fixnum } <effect> set-primitive-effect
 \ bignum>fixnum make-foldable
 
-\ fixnum>bignum { fixnum } { bignum } <effect> "inferred-effect" set-word-prop
+\ fixnum>bignum { fixnum } { bignum } <effect> set-primitive-effect
 \ fixnum>bignum make-foldable
 
-\ float>bignum { float } { bignum } <effect> "inferred-effect" set-word-prop
+\ float>bignum { float } { bignum } <effect> set-primitive-effect
 \ float>bignum make-foldable
 
-\ fixnum>float { fixnum } { float } <effect> "inferred-effect" set-word-prop
+\ fixnum>float { fixnum } { float } <effect> set-primitive-effect
 \ fixnum>float make-foldable
 
-\ bignum>float { bignum } { float } <effect> "inferred-effect" set-word-prop
+\ bignum>float { bignum } { float } <effect> set-primitive-effect
 \ bignum>float make-foldable
 
-\ <ratio> { integer integer } { ratio } <effect> "inferred-effect" set-word-prop
+\ <ratio> { integer integer } { ratio } <effect> set-primitive-effect
 \ <ratio> make-foldable
 
-\ string>float { string } { float } <effect> "inferred-effect" set-word-prop
+\ string>float { string } { float } <effect> set-primitive-effect
 \ string>float make-foldable
 
-\ float>string { float } { string } <effect> "inferred-effect" set-word-prop
+\ float>string { float } { string } <effect> set-primitive-effect
 \ float>string make-foldable
 
-\ float>bits { real } { integer } <effect> "inferred-effect" set-word-prop
+\ float>bits { real } { integer } <effect> set-primitive-effect
 \ float>bits make-foldable
 
-\ double>bits { real } { integer } <effect> "inferred-effect" set-word-prop
+\ double>bits { real } { integer } <effect> set-primitive-effect
 \ double>bits make-foldable
 
-\ bits>float { integer } { float } <effect> "inferred-effect" set-word-prop
+\ bits>float { integer } { float } <effect> set-primitive-effect
 \ bits>float make-foldable
 
-\ bits>double { integer } { float } <effect> "inferred-effect" set-word-prop
+\ bits>double { integer } { float } <effect> set-primitive-effect
 \ bits>double make-foldable
 
-\ <complex> { real real } { complex } <effect> "inferred-effect" set-word-prop
+\ <complex> { real real } { complex } <effect> set-primitive-effect
 \ <complex> make-foldable
 
-\ fixnum+ { fixnum fixnum } { integer } <effect> "inferred-effect" set-word-prop
+\ fixnum+ { fixnum fixnum } { integer } <effect> set-primitive-effect
 \ fixnum+ make-foldable
 
-\ fixnum+fast { fixnum fixnum } { fixnum } <effect> "inferred-effect" set-word-prop
+\ fixnum+fast { fixnum fixnum } { fixnum } <effect> set-primitive-effect
 \ fixnum+fast make-foldable
 
-\ fixnum- { fixnum fixnum } { integer } <effect> "inferred-effect" set-word-prop
+\ fixnum- { fixnum fixnum } { integer } <effect> set-primitive-effect
 \ fixnum- make-foldable
 
-\ fixnum-fast { fixnum fixnum } { fixnum } <effect> "inferred-effect" set-word-prop
+\ fixnum-fast { fixnum fixnum } { fixnum } <effect> set-primitive-effect
 \ fixnum-fast make-foldable
 
-\ fixnum* { fixnum fixnum } { integer } <effect> "inferred-effect" set-word-prop
+\ fixnum* { fixnum fixnum } { integer } <effect> set-primitive-effect
 \ fixnum* make-foldable
 
-\ fixnum*fast { fixnum fixnum } { fixnum } <effect> "inferred-effect" set-word-prop
+\ fixnum*fast { fixnum fixnum } { fixnum } <effect> set-primitive-effect
 \ fixnum*fast make-foldable
 
-\ fixnum/i { fixnum fixnum } { integer } <effect> "inferred-effect" set-word-prop
+\ fixnum/i { fixnum fixnum } { integer } <effect> set-primitive-effect
 \ fixnum/i make-foldable
 
-\ fixnum-mod { fixnum fixnum } { fixnum } <effect> "inferred-effect" set-word-prop
+\ fixnum-mod { fixnum fixnum } { fixnum } <effect> set-primitive-effect
 \ fixnum-mod make-foldable
 
-\ fixnum/mod { fixnum fixnum } { integer fixnum } <effect> "inferred-effect" set-word-prop
+\ fixnum/mod { fixnum fixnum } { integer fixnum } <effect> set-primitive-effect
 \ fixnum/mod make-foldable
 
-\ fixnum-bitand { fixnum fixnum } { fixnum } <effect> "inferred-effect" set-word-prop
+\ fixnum-bitand { fixnum fixnum } { fixnum } <effect> set-primitive-effect
 \ fixnum-bitand make-foldable
 
-\ fixnum-bitor { fixnum fixnum } { fixnum } <effect> "inferred-effect" set-word-prop
+\ fixnum-bitor { fixnum fixnum } { fixnum } <effect> set-primitive-effect
 \ fixnum-bitor make-foldable
 
-\ fixnum-bitxor { fixnum fixnum } { fixnum } <effect> "inferred-effect" set-word-prop
+\ fixnum-bitxor { fixnum fixnum } { fixnum } <effect> set-primitive-effect
 \ fixnum-bitxor make-foldable
 
-\ fixnum-bitnot { fixnum } { fixnum } <effect> "inferred-effect" set-word-prop
+\ fixnum-bitnot { fixnum } { fixnum } <effect> set-primitive-effect
 \ fixnum-bitnot make-foldable
 
-\ fixnum-shift { fixnum fixnum } { integer } <effect> "inferred-effect" set-word-prop
+\ fixnum-shift { fixnum fixnum } { integer } <effect> set-primitive-effect
 \ fixnum-shift make-foldable
 
-\ fixnum-shift-fast { fixnum fixnum } { fixnum } <effect> "inferred-effect" set-word-prop
+\ fixnum-shift-fast { fixnum fixnum } { fixnum } <effect> set-primitive-effect
 \ fixnum-shift-fast make-foldable
 
-\ bignum= { bignum bignum } { object } <effect> "inferred-effect" set-word-prop
+\ bignum= { bignum bignum } { object } <effect> set-primitive-effect
 \ bignum= make-foldable
 
-\ bignum+ { bignum bignum } { bignum } <effect> "inferred-effect" set-word-prop
+\ bignum+ { bignum bignum } { bignum } <effect> set-primitive-effect
 \ bignum+ make-foldable
 
-\ bignum- { bignum bignum } { bignum } <effect> "inferred-effect" set-word-prop
+\ bignum- { bignum bignum } { bignum } <effect> set-primitive-effect
 \ bignum- make-foldable
 
-\ bignum* { bignum bignum } { bignum } <effect> "inferred-effect" set-word-prop
+\ bignum* { bignum bignum } { bignum } <effect> set-primitive-effect
 \ bignum* make-foldable
 
-\ bignum/i { bignum bignum } { bignum } <effect> "inferred-effect" set-word-prop
+\ bignum/i { bignum bignum } { bignum } <effect> set-primitive-effect
 \ bignum/i make-foldable
 
-\ bignum-mod { bignum bignum } { bignum } <effect> "inferred-effect" set-word-prop
+\ bignum-mod { bignum bignum } { bignum } <effect> set-primitive-effect
 \ bignum-mod make-foldable
 
-\ bignum/mod { bignum bignum } { bignum bignum } <effect> "inferred-effect" set-word-prop
+\ bignum/mod { bignum bignum } { bignum bignum } <effect> set-primitive-effect
 \ bignum/mod make-foldable
 
-\ bignum-bitand { bignum bignum } { bignum } <effect> "inferred-effect" set-word-prop
+\ bignum-bitand { bignum bignum } { bignum } <effect> set-primitive-effect
 \ bignum-bitand make-foldable
 
-\ bignum-bitor { bignum bignum } { bignum } <effect> "inferred-effect" set-word-prop
+\ bignum-bitor { bignum bignum } { bignum } <effect> set-primitive-effect
 \ bignum-bitor make-foldable
 
-\ bignum-bitxor { bignum bignum } { bignum } <effect> "inferred-effect" set-word-prop
+\ bignum-bitxor { bignum bignum } { bignum } <effect> set-primitive-effect
 \ bignum-bitxor make-foldable
 
-\ bignum-bitnot { bignum } { bignum } <effect> "inferred-effect" set-word-prop
+\ bignum-bitnot { bignum } { bignum } <effect> set-primitive-effect
 \ bignum-bitnot make-foldable
 
-\ bignum-shift { bignum bignum } { bignum } <effect> "inferred-effect" set-word-prop
+\ bignum-shift { bignum bignum } { bignum } <effect> set-primitive-effect
 \ bignum-shift make-foldable
 
-\ bignum< { bignum bignum } { object } <effect> "inferred-effect" set-word-prop
+\ bignum< { bignum bignum } { object } <effect> set-primitive-effect
 \ bignum< make-foldable
 
-\ bignum<= { bignum bignum } { object } <effect> "inferred-effect" set-word-prop
+\ bignum<= { bignum bignum } { object } <effect> set-primitive-effect
 \ bignum<= make-foldable
 
-\ bignum> { bignum bignum } { object } <effect> "inferred-effect" set-word-prop
+\ bignum> { bignum bignum } { object } <effect> set-primitive-effect
 \ bignum> make-foldable
 
-\ bignum>= { bignum bignum } { object } <effect> "inferred-effect" set-word-prop
+\ bignum>= { bignum bignum } { object } <effect> set-primitive-effect
 \ bignum>= make-foldable
 
-\ bignum-bit? { bignum integer } { object } <effect> "inferred-effect" set-word-prop
+\ bignum-bit? { bignum integer } { object } <effect> set-primitive-effect
 \ bignum-bit? make-foldable
 
-\ bignum-log2 { bignum } { bignum } <effect> "inferred-effect" set-word-prop
+\ bignum-log2 { bignum } { bignum } <effect> set-primitive-effect
 \ bignum-log2 make-foldable
 
-\ byte-array>bignum { byte-array } { bignum } <effect> "inferred-effect" set-word-prop
+\ byte-array>bignum { byte-array } { bignum } <effect> set-primitive-effect
 \ byte-array>bignum make-foldable
 
-\ float= { float float } { object } <effect> "inferred-effect" set-word-prop
+\ float= { float float } { object } <effect> set-primitive-effect
 \ float= make-foldable
 
-\ float+ { float float } { float } <effect> "inferred-effect" set-word-prop
+\ float+ { float float } { float } <effect> set-primitive-effect
 \ float+ make-foldable
 
-\ float- { float float } { float } <effect> "inferred-effect" set-word-prop
+\ float- { float float } { float } <effect> set-primitive-effect
 \ float- make-foldable
 
-\ float* { float float } { float } <effect> "inferred-effect" set-word-prop
+\ float* { float float } { float } <effect> set-primitive-effect
 \ float* make-foldable
 
-\ float/f { float float } { float } <effect> "inferred-effect" set-word-prop
+\ float/f { float float } { float } <effect> set-primitive-effect
 \ float/f make-foldable
 
-\ float< { float float } { object } <effect> "inferred-effect" set-word-prop
+\ float< { float float } { object } <effect> set-primitive-effect
 \ float< make-foldable
 
-\ float-mod { float float } { float } <effect> "inferred-effect" set-word-prop
+\ float-mod { float float } { float } <effect> set-primitive-effect
 \ float-mod make-foldable
 
-\ float<= { float float } { object } <effect> "inferred-effect" set-word-prop
+\ float<= { float float } { object } <effect> set-primitive-effect
 \ float<= make-foldable
 
-\ float> { float float } { object } <effect> "inferred-effect" set-word-prop
+\ float> { float float } { object } <effect> set-primitive-effect
 \ float> make-foldable
 
-\ float>= { float float } { object } <effect> "inferred-effect" set-word-prop
+\ float>= { float float } { object } <effect> set-primitive-effect
 \ float>= make-foldable
 
-\ <word> { object object } { word } <effect> "inferred-effect" set-word-prop
+\ <word> { object object } { word } <effect> set-primitive-effect
 \ <word> make-flushable
 
-\ word-xt { word } { integer } <effect> "inferred-effect" set-word-prop
+\ word-xt { word } { integer } <effect> set-primitive-effect
 \ word-xt make-flushable
 
-\ getenv { fixnum } { object } <effect> "inferred-effect" set-word-prop
+\ getenv { fixnum } { object } <effect> set-primitive-effect
 \ getenv make-flushable
 
-\ setenv { object fixnum } { } <effect> "inferred-effect" set-word-prop
+\ setenv { object fixnum } { } <effect> set-primitive-effect
 
-\ (stat) { string } { object object object object } <effect> "inferred-effect" set-word-prop
+\ (stat) { string } { object object object object } <effect> set-primitive-effect
 
-\ (directory) { string } { array } <effect> "inferred-effect" set-word-prop
+\ (directory) { string } { array } <effect> set-primitive-effect
 
-\ data-gc { } { } <effect> "inferred-effect" set-word-prop
+\ data-gc { } { } <effect> set-primitive-effect
 
-\ code-gc { } { } <effect> "inferred-effect" set-word-prop
+\ code-gc { } { } <effect> set-primitive-effect
 
-\ gc-time { } { integer } <effect> "inferred-effect" set-word-prop
+\ gc-time { } { integer } <effect> set-primitive-effect
 
-\ save-image { string } { } <effect> "inferred-effect" set-word-prop
+\ save-image { string } { } <effect> set-primitive-effect
 
-\ save-image-and-exit { string } { } <effect> "inferred-effect" set-word-prop
+\ save-image-and-exit { string } { } <effect> set-primitive-effect
 
 \ exit { integer } { } <effect>
 t over set-effect-terminated?
-"inferred-effect" set-word-prop
+set-primitive-effect
 
-\ data-room { } { integer array } <effect> "inferred-effect" set-word-prop
+\ data-room { } { integer array } <effect> set-primitive-effect
 \ data-room make-flushable
 
-\ code-room { } { integer integer } <effect> "inferred-effect" set-word-prop
+\ code-room { } { integer integer } <effect> set-primitive-effect
 \ code-room  make-flushable
 
-\ os-env { string } { object } <effect> "inferred-effect" set-word-prop
+\ os-env { string } { object } <effect> set-primitive-effect
 
-\ millis { } { integer } <effect> "inferred-effect" set-word-prop
+\ millis { } { integer } <effect> set-primitive-effect
 \ millis make-flushable
 
-\ type { object } { fixnum } <effect> "inferred-effect" set-word-prop
+\ type { object } { fixnum } <effect> set-primitive-effect
 \ type make-foldable
 
-\ tag { object } { fixnum } <effect> "inferred-effect" set-word-prop
+\ tag { object } { fixnum } <effect> set-primitive-effect
 \ tag make-foldable
 
-\ class-hash { object } { fixnum } <effect> "inferred-effect" set-word-prop
+\ class-hash { object } { fixnum } <effect> set-primitive-effect
 \ class-hash make-foldable
 
-\ cwd { } { string } <effect> "inferred-effect" set-word-prop
+\ cwd { } { string } <effect> set-primitive-effect
 
-\ cd { string } { } <effect> "inferred-effect" set-word-prop
+\ cd { string } { } <effect> set-primitive-effect
 
-\ dlopen { string } { dll } <effect> "inferred-effect" set-word-prop
+\ dlopen { string } { dll } <effect> set-primitive-effect
 
-\ dlsym { string object } { c-ptr } <effect> "inferred-effect" set-word-prop
+\ dlsym { string object } { c-ptr } <effect> set-primitive-effect
 
-\ dlclose { dll } { } <effect> "inferred-effect" set-word-prop
+\ dlclose { dll } { } <effect> set-primitive-effect
 
-\ <byte-array> { integer } { byte-array } <effect> "inferred-effect" set-word-prop
+\ <byte-array> { integer } { byte-array } <effect> set-primitive-effect
 \ <byte-array> make-flushable
 
-\ <bit-array> { integer } { bit-array } <effect> "inferred-effect" set-word-prop
+\ <bit-array> { integer } { bit-array } <effect> set-primitive-effect
 \ <bit-array> make-flushable
 
-\ <float-array> { integer float } { float-array } <effect> "inferred-effect" set-word-prop
+\ <float-array> { integer float } { float-array } <effect> set-primitive-effect
 \ <float-array> make-flushable
 
-\ <displaced-alien> { integer c-ptr } { c-ptr } <effect> "inferred-effect" set-word-prop
+\ <displaced-alien> { integer c-ptr } { c-ptr } <effect> set-primitive-effect
 \ <displaced-alien> make-flushable
 
-\ alien-signed-cell { c-ptr integer } { integer } <effect> "inferred-effect" set-word-prop
+\ alien-signed-cell { c-ptr integer } { integer } <effect> set-primitive-effect
 \ alien-signed-cell make-flushable
 
-\ set-alien-signed-cell { integer c-ptr integer } { } <effect> "inferred-effect" set-word-prop
+\ set-alien-signed-cell { integer c-ptr integer } { } <effect> set-primitive-effect
 
-\ alien-unsigned-cell { c-ptr integer } { integer } <effect> "inferred-effect" set-word-prop
+\ alien-unsigned-cell { c-ptr integer } { integer } <effect> set-primitive-effect
 \ alien-unsigned-cell make-flushable
 
-\ set-alien-unsigned-cell { integer c-ptr integer } { } <effect> "inferred-effect" set-word-prop
+\ set-alien-unsigned-cell { integer c-ptr integer } { } <effect> set-primitive-effect
 
-\ alien-signed-8 { c-ptr integer } { integer } <effect> "inferred-effect" set-word-prop
+\ alien-signed-8 { c-ptr integer } { integer } <effect> set-primitive-effect
 \ alien-signed-8 make-flushable
 
-\ set-alien-signed-8 { integer c-ptr integer } { } <effect> "inferred-effect" set-word-prop
+\ set-alien-signed-8 { integer c-ptr integer } { } <effect> set-primitive-effect
 
-\ alien-unsigned-8 { c-ptr integer } { integer } <effect> "inferred-effect" set-word-prop
+\ alien-unsigned-8 { c-ptr integer } { integer } <effect> set-primitive-effect
 \ alien-unsigned-8 make-flushable
 
-\ set-alien-unsigned-8 { integer c-ptr integer } { } <effect> "inferred-effect" set-word-prop
+\ set-alien-unsigned-8 { integer c-ptr integer } { } <effect> set-primitive-effect
 
-\ alien-signed-4 { c-ptr integer } { integer } <effect> "inferred-effect" set-word-prop
+\ alien-signed-4 { c-ptr integer } { integer } <effect> set-primitive-effect
 \ alien-signed-4 make-flushable
 
-\ set-alien-signed-4 { integer c-ptr integer } { } <effect> "inferred-effect" set-word-prop
+\ set-alien-signed-4 { integer c-ptr integer } { } <effect> set-primitive-effect
 
-\ alien-unsigned-4 { c-ptr integer } { integer } <effect> "inferred-effect" set-word-prop
+\ alien-unsigned-4 { c-ptr integer } { integer } <effect> set-primitive-effect
 \ alien-unsigned-4 make-flushable
 
-\ set-alien-unsigned-4 { integer c-ptr integer } { } <effect> "inferred-effect" set-word-prop
+\ set-alien-unsigned-4 { integer c-ptr integer } { } <effect> set-primitive-effect
 
-\ alien-signed-2 { c-ptr integer } { fixnum } <effect> "inferred-effect" set-word-prop
+\ alien-signed-2 { c-ptr integer } { fixnum } <effect> set-primitive-effect
 \ alien-signed-2 make-flushable
 
-\ set-alien-signed-2 { integer c-ptr integer } { } <effect> "inferred-effect" set-word-prop
+\ set-alien-signed-2 { integer c-ptr integer } { } <effect> set-primitive-effect
 
-\ alien-unsigned-2 { c-ptr integer } { fixnum } <effect> "inferred-effect" set-word-prop
+\ alien-unsigned-2 { c-ptr integer } { fixnum } <effect> set-primitive-effect
 \ alien-unsigned-2 make-flushable
 
-\ set-alien-unsigned-2 { integer c-ptr integer } { } <effect> "inferred-effect" set-word-prop
+\ set-alien-unsigned-2 { integer c-ptr integer } { } <effect> set-primitive-effect
 
-\ alien-signed-1 { c-ptr integer } { fixnum } <effect> "inferred-effect" set-word-prop
+\ alien-signed-1 { c-ptr integer } { fixnum } <effect> set-primitive-effect
 \ alien-signed-1 make-flushable
 
-\ set-alien-signed-1 { integer c-ptr integer } { } <effect> "inferred-effect" set-word-prop
+\ set-alien-signed-1 { integer c-ptr integer } { } <effect> set-primitive-effect
 
-\ alien-unsigned-1 { c-ptr integer } { fixnum } <effect> "inferred-effect" set-word-prop
+\ alien-unsigned-1 { c-ptr integer } { fixnum } <effect> set-primitive-effect
 \ alien-unsigned-1 make-flushable
 
-\ set-alien-unsigned-1 { integer c-ptr integer } { } <effect> "inferred-effect" set-word-prop
+\ set-alien-unsigned-1 { integer c-ptr integer } { } <effect> set-primitive-effect
 
-\ alien-float { c-ptr integer } { float } <effect> "inferred-effect" set-word-prop
+\ alien-float { c-ptr integer } { float } <effect> set-primitive-effect
 \ alien-float make-flushable
 
-\ set-alien-float { float c-ptr integer } { } <effect> "inferred-effect" set-word-prop
+\ set-alien-float { float c-ptr integer } { } <effect> set-primitive-effect
 
-\ alien-double { c-ptr integer } { float } <effect> "inferred-effect" set-word-prop
+\ alien-double { c-ptr integer } { float } <effect> set-primitive-effect
 \ alien-double make-flushable
 
-\ set-alien-double { float c-ptr integer } { } <effect> "inferred-effect" set-word-prop
+\ set-alien-double { float c-ptr integer } { } <effect> set-primitive-effect
 
-\ alien-cell { c-ptr integer } { simple-c-ptr } <effect> "inferred-effect" set-word-prop
+\ alien-cell { c-ptr integer } { simple-c-ptr } <effect> set-primitive-effect
 \ alien-cell make-flushable
 
-\ set-alien-cell { c-ptr c-ptr integer } { } <effect> "inferred-effect" set-word-prop
+\ set-alien-cell { c-ptr c-ptr integer } { } <effect> set-primitive-effect
 
-\ alien>char-string { c-ptr } { string } <effect> "inferred-effect" set-word-prop
+\ alien>char-string { c-ptr } { string } <effect> set-primitive-effect
 \ alien>char-string make-flushable
 
-\ string>char-alien { string } { byte-array } <effect> "inferred-effect" set-word-prop
+\ string>char-alien { string } { byte-array } <effect> set-primitive-effect
 \ string>char-alien make-flushable
 
-\ alien>u16-string { c-ptr } { string } <effect> "inferred-effect" set-word-prop
+\ alien>u16-string { c-ptr } { string } <effect> set-primitive-effect
 \ alien>u16-string make-flushable
 
-\ string>u16-alien { string } { byte-array } <effect> "inferred-effect" set-word-prop
+\ string>u16-alien { string } { byte-array } <effect> set-primitive-effect
 \ string>u16-alien make-flushable
 
-\ alien-address { alien } { integer } <effect> "inferred-effect" set-word-prop
+\ alien-address { alien } { integer } <effect> set-primitive-effect
 \ alien-address make-flushable
 
-\ slot { object fixnum } { object } <effect> "inferred-effect" set-word-prop
+\ slot { object fixnum } { object } <effect> set-primitive-effect
 \ slot make-flushable
 
-\ set-slot { object object fixnum } { } <effect> "inferred-effect" set-word-prop
+\ set-slot { object object fixnum } { } <effect> set-primitive-effect
 
-\ string-nth { fixnum string } { fixnum } <effect> "inferred-effect" set-word-prop
+\ string-nth { fixnum string } { fixnum } <effect> set-primitive-effect
 \ string-nth make-flushable
 
-\ set-string-nth { fixnum fixnum string } { } <effect> "inferred-effect" set-word-prop
+\ set-string-nth { fixnum fixnum string } { } <effect> set-primitive-effect
 
-\ resize-array { integer array } { array } <effect> "inferred-effect" set-word-prop
+\ resize-array { integer array } { array } <effect> set-primitive-effect
 \ resize-array make-flushable
 
-\ resize-byte-array { integer byte-array } { byte-array } <effect> "inferred-effect" set-word-prop
+\ resize-byte-array { integer byte-array } { byte-array } <effect> set-primitive-effect
 \ resize-byte-array make-flushable
 
-\ resize-bit-array { integer bit-array } { bit-array } <effect> "inferred-effect" set-word-prop
+\ resize-bit-array { integer bit-array } { bit-array } <effect> set-primitive-effect
 \ resize-bit-array make-flushable
 
-\ resize-float-array { integer float-array } { float-array } <effect> "inferred-effect" set-word-prop
+\ resize-float-array { integer float-array } { float-array } <effect> set-primitive-effect
 \ resize-float-array make-flushable
 
-\ resize-string { integer string } { string } <effect> "inferred-effect" set-word-prop
+\ resize-string { integer string } { string } <effect> set-primitive-effect
 \ resize-string make-flushable
 
-\ <array> { integer object } { array } <effect> "inferred-effect" set-word-prop
+\ <array> { integer object } { array } <effect> set-primitive-effect
 \ <array> make-flushable
 
-\ begin-scan { } { } <effect> "inferred-effect" set-word-prop
+\ begin-scan { } { } <effect> set-primitive-effect
 
-\ next-object { } { object } <effect> "inferred-effect" set-word-prop
+\ next-object { } { object } <effect> set-primitive-effect
 
-\ end-scan { } { } <effect> "inferred-effect" set-word-prop
+\ end-scan { } { } <effect> set-primitive-effect
 
-\ size { object } { fixnum } <effect> "inferred-effect" set-word-prop
+\ size { object } { fixnum } <effect> set-primitive-effect
 \ size make-flushable
 
-\ die { } { } <effect> "inferred-effect" set-word-prop
+\ die { } { } <effect> set-primitive-effect
 
-\ fopen { string string } { alien } <effect> "inferred-effect" set-word-prop
+\ fopen { string string } { alien } <effect> set-primitive-effect
 
-\ fgetc { alien } { object } <effect> "inferred-effect" set-word-prop
+\ fgetc { alien } { object } <effect> set-primitive-effect
 
-\ fwrite { string alien } { } <effect> "inferred-effect" set-word-prop
+\ fwrite { string alien } { } <effect> set-primitive-effect
 
-\ fread { integer string } { object } <effect> "inferred-effect" set-word-prop
+\ fread { integer string } { object } <effect> set-primitive-effect
 
-\ fflush { alien } { } <effect> "inferred-effect" set-word-prop
+\ fflush { alien } { } <effect> set-primitive-effect
 
-\ fclose { alien } { } <effect> "inferred-effect" set-word-prop
+\ fclose { alien } { } <effect> set-primitive-effect
 
-\ expired? { object } { object } <effect> "inferred-effect" set-word-prop
+\ expired? { object } { object } <effect> set-primitive-effect
 \ expired? make-flushable
 
-\ <wrapper> { object } { wrapper } <effect> "inferred-effect" set-word-prop
+\ <wrapper> { object } { wrapper } <effect> set-primitive-effect
 \ <wrapper> make-foldable
 
-\ (clone) { object } { object } <effect> "inferred-effect" set-word-prop
+\ (clone) { object } { object } <effect> set-primitive-effect
 \ (clone) make-flushable
 
-\ <string> { integer integer } { string } <effect> "inferred-effect" set-word-prop
+\ <string> { integer integer } { string } <effect> set-primitive-effect
 \ <string> make-flushable
 
-\ array>quotation { array } { quotation } <effect> "inferred-effect" set-word-prop
+\ array>quotation { array } { quotation } <effect> set-primitive-effect
 \ array>quotation make-flushable
 
-\ quotation-xt { quotation } { integer } <effect> "inferred-effect" set-word-prop
+\ quotation-xt { quotation } { integer } <effect> set-primitive-effect
 \ quotation-xt make-flushable
 
-\ <tuple> { word integer } { quotation } <effect> "inferred-effect" set-word-prop
+\ <tuple> { word integer } { quotation } <effect> set-primitive-effect
 \ <tuple> make-flushable
 
-\ (>tuple) { array } { tuple } <effect> "inferred-effect" set-word-prop
+\ (>tuple) { array } { tuple } <effect> set-primitive-effect
 \ (>tuple) make-flushable
 
-\ tuple>array { tuple } { array } <effect> "inferred-effect" set-word-prop
+\ tuple>array { tuple } { array } <effect> set-primitive-effect
 \ tuple>array make-flushable
 
-\ datastack { } { array } <effect> "inferred-effect" set-word-prop
+\ datastack { } { array } <effect> set-primitive-effect
 \ datastack make-flushable
 
-\ retainstack { } { array } <effect> "inferred-effect" set-word-prop
+\ retainstack { } { array } <effect> set-primitive-effect
 \ retainstack make-flushable
 
-\ callstack { } { callstack } <effect> "inferred-effect" set-word-prop
+\ callstack { } { callstack } <effect> set-primitive-effect
 \ callstack make-flushable
 
-\ callstack>array { callstack } { array } <effect> "inferred-effect" set-word-prop
+\ callstack>array { callstack } { array } <effect> set-primitive-effect
 \ callstack>array make-flushable
 
-\ (sleep) { integer } { } <effect> "inferred-effect" set-word-prop
+\ (sleep) { integer } { } <effect> set-primitive-effect
 
-\ become { array array } { } <effect> "inferred-effect" set-word-prop
+\ become { array array } { } <effect> set-primitive-effect
 
-\ innermost-frame-quot { callstack } { quotation } <effect> "inferred-effect" set-word-prop
+\ innermost-frame-quot { callstack } { quotation } <effect> set-primitive-effect
 
-\ innermost-frame-scan { callstack } { fixnum } <effect> "inferred-effect" set-word-prop
+\ innermost-frame-scan { callstack } { fixnum } <effect> set-primitive-effect
 
-\ set-innermost-frame-quot { quotation callstack } { } <effect> "inferred-effect" set-word-prop
+\ set-innermost-frame-quot { quotation callstack } { } <effect> set-primitive-effect
 
-\ (os-envs) { } { array } <effect> "inferred-effect" set-word-prop
+\ (os-envs) { } { array } <effect> set-primitive-effect
 
 \ do-primitive [ \ do-primitive no-effect ] "infer" set-word-prop

core/inference/transforms/transforms.factor

@@ -93,5 +93,3 @@ M: duplicated-slots-error summary
         \ construct-empty 1 1 <effect> make-call-node
     ] if
 ] "infer" set-word-prop
-
-\ construct-empty 1 1 <effect> "inferred-effect" set-word-prop

core/io/files/files-docs.factor

@@ -52,6 +52,21 @@ 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
+{ $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
+{ $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." } ;
+
+HELP: with-file-appender
+{ $values { "path" "a pathname string" } { "quot" "a quotation" } }
+{ $description "Opens a file for appending and calls the quotation using " { $link with-stream } "." }
+{ $errors "Throws an error if the file cannot be opened for writing." } ;
+
 HELP: cwd
 { $values { "path" "a pathname string" } }
 { $description "Outputs the current working directory of the Factor process." }

core/io/files/files.factor

@@ -96,6 +96,9 @@ TUPLE: no-parent-directory path ;
 : ?resource-path ( path -- newpath )
     "resource:" ?head [ resource-path ] when ;
 
+: resource-exists? ( path -- ? )
+    ?resource-path exists? ;
+
 : make-directories ( path -- )
     normalize-pathname right-trim-separators {
         { [ dup "." = ] [ ] }

core/kernel/kernel-docs.factor

@@ -532,7 +532,7 @@ HELP: compose
         "compose call"
         "append call"
     }
-    "However, " { $link compose } " runs in constant time, and the compiler is able to compile code which calls composed quotations."
+    "However, " { $link compose } " runs in constant time, and the optimizing compiler is able to compile code which calls composed quotations."
 } ;
 
 HELP: 3compose

core/kernel/kernel.factor

@@ -17,7 +17,7 @@ IN: kernel
 : clear ( -- ) { } set-datastack ;
 
 ! Combinators
-: call ( callable -- ) uncurry (call) ;
+GENERIC: call ( callable -- )
 
 DEFER: if
 
@@ -70,6 +70,10 @@ DEFER: if
     [ 2nip call ] if ; inline
 
 ! Quotation building
+USE: tuples.private
+
+: curry ( obj quot -- curry )
+    \ curry 4 <tuple-boa> ;
 
 : 2curry ( obj1 obj2 quot -- curry )
     curry curry ; inline
@@ -81,12 +85,10 @@ DEFER: if
     swapd [ swapd call ] 2curry ; inline
 
 : compose ( quot1 quot2 -- curry )
-    ! Not inline because this is treated as a primitive by
+    \ compose 4 <tuple-boa> ;
-    ! the compiler
-    [ slip call ] 2curry ;
 
 : 3compose ( quot1 quot2 quot3 -- curry )
-    [ 2slip slip call ] 3curry ; inline
+    compose compose ; inline
 
 ! Object protocol
 
@@ -155,7 +157,7 @@ GENERIC: construct-boa ( ... class -- tuple )
 
 ! Error handling -- defined early so that other files can
 ! throw errors before continuations are loaded
-: throw ( error -- * ) 5 getenv [ die ] or curry (throw) ;
+: throw ( error -- * ) 5 getenv [ die ] or 1 (throw) ;
 
 <PRIVATE
 

core/optimizer/backend/backend.factor

@@ -52,13 +52,7 @@ GENERIC: optimize-node* ( node -- node/t changed? )
 DEFER: optimize-nodes
 
 : optimize-children ( node -- )
-    [
+    [ optimize-nodes ] change-children ;
-        dup node-children dup [
-            [ optimize-nodes ] map swap set-node-children
-        ] [
-            2drop
-        ] if
-    ] when* ;
 
 : optimize-node ( node -- node )
     dup [
@@ -76,39 +70,17 @@ DEFER: optimize-nodes
 
 M: f set-node-successor 2drop ;
 
-: (optimize-nodes) ( prev node -- )
-    optimize-node [
-        dup rot set-node-successor
-        dup node-successor (optimize-nodes)
-    ] [
-        f swap set-node-successor
-    ] if* ;
-
 : optimize-nodes ( node -- newnode )
     [
         class-substitutions [ clone ] change
         literal-substitutions [ clone ] change
-        dup [
+        [ optimize-node ] transform-nodes
-            optimize-node
+        optimizer-changed get
-            dup dup node-successor (optimize-nodes)
-        ] when optimizer-changed get
     ] with-scope optimizer-changed set ;
 
-: prune-if ( node quot -- successor/t )
-    over >r call [ r> node-successor t ] [ r> drop t f ] if ;
-    inline
-
 ! Generic nodes
 M: node optimize-node* drop t f ;
 
-M: #shuffle optimize-node* 
-    [
-        dup node-in-d empty? swap node-out-d empty? and
-    ] prune-if ;
-
-M: #push optimize-node* 
-    [ node-out-d empty? ] prune-if ;
-
 : cleanup-inlining ( node -- newnode changed? )
     node-successor [ node-successor t ] [ t f ] if* ;
 
@@ -118,12 +90,6 @@ M: #return optimize-node* cleanup-inlining ;
 ! #values
 M: #values optimize-node* cleanup-inlining ;
 
-! #>r
-M: #>r optimize-node* [ node-in-d empty? ] prune-if ;
-
-! #r>
-M: #r> optimize-node* [ node-in-r empty? ] prune-if ;
-
 ! Some utilities for splicing in dataflow IR subtrees
 : follow ( key assoc -- value )
     2dup at* [ swap follow nip ] [ 2drop ] if ;
@@ -194,10 +160,8 @@ M: node remember-method*
 
 ! Constant branch folding
 : fold-branch ( node branch# -- node )
-    over drop-inputs >r
     over node-children nth
-    swap node-successor over substitute-node
+    swap node-successor over substitute-node ;
-    r> [ set-node-successor ] keep ;
 
 ! #if
 : known-boolean-value? ( node value -- value ? )
@@ -213,12 +177,18 @@ M: node remember-method*
     ] if ;
 
 M: #if optimize-node*
-    dup dup node-in-d first known-boolean-value?
+    dup dup node-in-d first known-boolean-value? [
-    [ 0 1 ? fold-branch t ] [ 2drop t f ] if ;
+        over drop-inputs >r
+        0 1 ? fold-branch
+        r> [ set-node-successor ] keep
+        t
+    ] [ 2drop t f ] if ;
 
 M: #dispatch optimize-node*
     dup dup node-in-d first 2dup node-literal? [
-        node-literal fold-branch t
+        "Optimizing #dispatch" print
+        node-literal
+        over drop-inputs >r fold-branch r> [ set-node-successor ] keep t
     ] [
         3drop t f
     ] if ;
@@ -322,9 +292,19 @@ DEFER: (flat-length)
     #! Make #shuffle -> #push -> #return -> successor
     dupd literal-quot splice-quot ;
 
-: optimize-predicate ( #call -- node )
+: evaluate-predicate ( #call -- ? )
     dup node-param "predicating" word-prop >r
-    dup node-class-first r> class< 1array inline-literals ;
+    node-class-first r> class< ;
+
+: optimize-predicate ( #call -- node )
+    dup evaluate-predicate swap
+    dup node-successor #if? [
+        dup drop-inputs >r
+        node-successor swap 0 1 ? fold-branch
+        r> [ set-node-successor ] keep
+    ] [
+        swap 1array inline-literals
+    ] if ;
 
 : optimizer-hooks ( node -- conditions )
     node-param "optimizer-hooks" word-prop ;

core/optimizer/def-use/def-use-tests.factor

@@ -8,7 +8,7 @@ namespaces assocs kernel sequences math tools.test words ;
 ] unit-test
 
 : kill-set ( quot -- seq )
-    dataflow compute-def-use dead-literals keys
+    dataflow compute-def-use compute-dead-literals keys
     [ value-literal ] map ;
 
 : subset? [ member? ] curry all? ;

core/optimizer/def-use/def-use.factor

@@ -70,19 +70,66 @@ M: #branch node-def-use
     #! #values node.
     dup branch-def-use (node-def-use) ;
 
-: dead-literals ( -- values )
+! : dead-literals ( -- values )
+!     def-use get [ >r value? r> empty? and ] assoc-subset ;
+! 
+! : kill-node* ( node values -- )
+!     [ swap remove-all ] curry modify-values ;
+! 
+! : kill-node ( node values -- )
+!     dup assoc-empty?
+!     [ 2drop ] [ [ kill-node* ] curry each-node ] if ;
+! 
+! : kill-values ( node -- )
+!     #! Remove literals which are not actually used anywhere.
+!     dead-literals kill-node ;
+
+: compute-dead-literals ( -- values )
     def-use get [ >r value? r> empty? and ] assoc-subset ;
 
-: kill-node* ( node values -- )
+DEFER: kill-nodes
-    [ swap remove-all ] curry modify-values ;
+SYMBOL: dead-literals
 
-: kill-node ( node values -- )
+GENERIC: kill-node* ( node -- node/t )
-    dup assoc-empty?
-    [ 2drop ] [ [ kill-node* ] curry each-node ] if ;
 
-: kill-values ( node -- )
+M: node kill-node* drop t ;
+
+: prune-if ( node quot -- successor/t )
+    over >r call [ r> node-successor ] [ r> drop t ] if ;
+    inline
+
+M: #shuffle kill-node* 
+    [
+        dup node-in-d empty? swap node-out-d empty? and
+    ] prune-if ;
+
+M: #push kill-node* 
+    [ node-out-d empty? ] prune-if ;
+
+M: #>r kill-node* [ node-in-d empty? ] prune-if ;
+
+M: #r> kill-node* [ node-in-r empty? ] prune-if ;
+
+: kill-node ( node -- node )
+    dup [
+        dup [ dead-literals get swap remove-all ] modify-values
+        dup kill-node* dup t eq? [
+            drop dup [ kill-nodes ] change-children
+        ] [
+            nip kill-node
+        ] if
+    ] when ;
+
+: kill-nodes ( node -- newnode )
+    [ kill-node ] transform-nodes ;
+
+: kill-values ( node -- new-node )
     #! Remove literals which are not actually used anywhere.
-    dead-literals kill-node ;
+    compute-dead-literals dup assoc-empty? [ drop ] [
+        dead-literals [ kill-nodes ] with-variable
+    ] if ;
+
+!
 
 : sole-consumer ( #call -- node/f )
     node-out-d first used-by

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

@@ -8,7 +8,7 @@ assocs quotations sequences.private io.binary io.crc32
 io.streams.string layouts splitting math.intervals
 math.floats.private tuples tuples.private classes
 optimizer.def-use optimizer.backend optimizer.pattern-match
-float-arrays combinators.private combinators ;
+float-arrays sequences.private combinators ;
 
 ! the output of <tuple> and <tuple-boa> has the class which is
 ! its second-to-last input
@@ -19,6 +19,11 @@ float-arrays combinators.private combinators ;
     ] "output-classes" set-word-prop
 ] each
 
+\ construct-empty [
+    dup node-in-d peek node-literal
+    dup class? [ drop tuple ] unless 1array f
+] "output-classes" set-word-prop
+
 ! the output of clone has the same type as the input
 { clone (clone) } [
     [
@@ -98,7 +103,7 @@ float-arrays combinators.private combinators ;
     [
         num-types get swap [
             [
-                [ type>class 0 `input class, ] keep
+                [ type>class object or 0 `input class, ] keep
                 0 `output literal,
             ] set-constraints
         ] curry each

core/optimizer/optimizer-tests.factor

@@ -288,10 +288,10 @@ TUPLE: silly-tuple a b ;
 
 [ t ] [ \ node-successor-f-bug compiled? ] unit-test
 
-: construct-empty-bug construct-empty ;
-
 [ ] [ [ construct-empty ] dataflow optimize drop ] unit-test
 
+[ ] [ [ <tuple> ] dataflow optimize drop ] unit-test
+
 ! Make sure we have sane heuristics
 : should-inline? method method-word flat-length 10 <= ;
 

core/optimizer/optimizer.factor

@@ -10,7 +10,7 @@ IN: optimizer
         H{ } clone literal-substitutions set
         H{ } clone value-substitutions set
         dup compute-def-use
-        dup kill-values
+        kill-values
         dup infer-classes
         optimizer-changed off
         optimize-nodes

core/optimizer/specializers/specializers.factor

@@ -2,7 +2,7 @@
 ! See http://factorcode.org/license.txt for BSD license.
 USING: arrays generic hashtables kernel kernel.private math
 namespaces sequences vectors words strings layouts combinators
-combinators.private classes generic.standard assocs ;
+sequences.private classes generic.standard assocs ;
 IN: optimizer.specializers
 
 : (make-specializer) ( class picker -- quot )

core/parser/parser.factor

@@ -107,6 +107,7 @@ M: bad-escape summary drop "Bad escape code" ;
 
 : escape ( escape -- ch )
     H{
+        { CHAR: a  CHAR: \a }
         { CHAR: e  CHAR: \e }
         { CHAR: n  CHAR: \n }
         { CHAR: r  CHAR: \r }
@@ -479,7 +480,7 @@ SYMBOL: interactive-vocabs
     [ [ parse-file call ] keep ] assert-depth drop ;
 
 : ?run-file ( path -- )
-    dup ?resource-path exists? [ run-file ] [ drop ] if ;
+    dup resource-exists? [ run-file ] [ drop ] if ;
 
 : bootstrap-file ( path -- )
     [ parse-file % ] [ run-file ] if-bootstrapping ;

core/prettyprint/backend/backend.factor

@@ -58,6 +58,7 @@ M: f pprint* drop \ f pprint-word ;
 ! Strings
 : ch>ascii-escape ( ch -- str )
     H{
+        { CHAR: \a CHAR: a  }
         { CHAR: \e CHAR: e  }
         { CHAR: \n CHAR: n  }
         { CHAR: \r CHAR: r  }
@@ -135,6 +136,7 @@ GENERIC: pprint-delims ( obj -- start end )
 
 M: quotation pprint-delims drop \ [ \ ] ;
 M: curry pprint-delims drop \ [ \ ] ;
+M: compose pprint-delims drop \ [ \ ] ;
 M: array pprint-delims drop \ { \ } ;
 M: byte-array pprint-delims drop \ B{ \ } ;
 M: byte-vector pprint-delims drop \ BV{ \ } ;
@@ -156,6 +158,8 @@ M: vector >pprint-sequence ;
 M: bit-vector >pprint-sequence ;
 M: byte-vector >pprint-sequence ;
 M: float-vector >pprint-sequence ;
+M: curry >pprint-sequence ;
+M: compose >pprint-sequence ;
 M: hashtable >pprint-sequence >alist ;
 M: tuple >pprint-sequence tuple>array ;
 M: wrapper >pprint-sequence wrapped 1array ;

core/quotations/quotations-tests.factor

@@ -15,4 +15,4 @@ IN: temporary
 
 [ [ "hi" ] ] [ "hi" 1quotation ] unit-test
 
-[ 1 \ + curry ] must-fail
+! [ 1 \ + curry ] must-fail

core/quotations/quotations.factor

@@ -1,13 +1,20 @@
-! Copyright (C) 2006, 2007 Slava Pestov.
+! Copyright (C) 2006, 2008 Slava Pestov.
 ! See http://factorcode.org/license.txt for BSD license.
 USING: arrays sequences sequences.private
-kernel kernel.private math assocs quotations.private ;
+kernel kernel.private math assocs quotations.private
+slots.private ;
 IN: quotations
 
+M: quotation call (call) ;
+
+M: curry call dup 4 slot swap 5 slot call ;
+
+M: compose call dup 4 slot swap 5 slot slip call ;
+
 M: wrapper equal?
     over wrapper? [ [ wrapped ] 2apply = ] [ 2drop f ] if ;
 
-UNION: callable quotation curry ;
+UNION: callable quotation curry compose ;
 
 M: callable equal?
     over callable? [ sequence= ] [ 2drop f ] if ;
@@ -19,7 +26,7 @@ M: quotation nth-unsafe quotation-array nth-unsafe ;
 : >quotation ( seq -- quot )
     >array array>quotation ; inline
 
-M: quotation like drop dup quotation? [ >quotation ] unless ;
+M: callable like drop dup quotation? [ >quotation ] unless ;
 
 INSTANCE: quotation immutable-sequence
 
@@ -40,6 +47,17 @@ M: curry nth
         >r 1- r> curry-quot nth
     ] if ;
 
-M: curry like drop dup callable? [ >quotation ] unless ;
-
 INSTANCE: curry immutable-sequence
+
+M: compose length
+    dup compose-first length
+    swap compose-second length + ;
+
+M: compose nth
+    2dup compose-first length < [
+        compose-first
+    ] [
+        [ compose-first length - ] keep compose-second
+    ] if nth ;
+
+INSTANCE: compose immutable-sequence

core/sequences/sequences.factor

@@ -1,4 +1,4 @@
-! Copyright (C) 2005, 2007 Slava Pestov.
+! Copyright (C) 2005, 2008 Slava Pestov, Daniel Ehrenberg.
 ! See http://factorcode.org/license.txt for BSD license.
 IN: sequences
 USING: kernel kernel.private slots.private math math.private ;
@@ -77,6 +77,8 @@ PREDICATE: fixnum array-capacity
 : set-array-nth ( elt n array -- )
     swap 2 fixnum+fast set-slot ; inline
 
+: dispatch ( n array -- ) array-nth (call) ;
+
 GENERIC: resize ( n seq -- newseq ) flushable
 
 ! Unsafe sequence protocol for inner loops
@@ -606,7 +608,29 @@ M: sequence <=>
     ] if ;
 
 : cut-slice ( seq n -- before after )
-    [ head ] 2keep tail-slice ;
+    [ head-slice ] 2keep tail-slice ;
+
+: midpoint@ ( seq -- n ) length 2/ ; inline
+
+: halves ( seq -- first second )
+    dup midpoint@ cut-slice ;
+
+: binary-reduce ( seq start quot -- value )
+    #! We can't use case here since combinators depends on
+    #! sequences
+    pick length dup 0 3 between? [
+        >fixnum {
+            [ drop nip ]
+            [ 2drop first ]
+            [ >r drop first2 r> call ]
+            [ >r drop first3 r> 2apply ]
+        } dispatch
+    ] [
+        drop
+        >r >r halves r> r>
+        [ [ binary-reduce ] 2curry 2apply ] keep
+        call
+    ] if ; inline
 
 : cut ( seq n -- before after )
     [ head ] 2keep tail ;
@@ -657,8 +681,8 @@ PRIVATE>
 : trim ( seq quot -- newseq )
     [ left-trim ] keep right-trim ; inline
 
-: sum ( seq -- n ) 0 [ + ] reduce ;
+: sum ( seq -- n ) 0 [ + ] binary-reduce ;
-: product ( seq -- n ) 1 [ * ] reduce ;
+: product ( seq -- n ) 1 [ * ] binary-reduce ;
 
 : infimum ( seq -- n ) dup first [ min ] reduce ;
 : supremum ( seq -- n ) dup first [ max ] reduce ;

core/sorting/sorting.factor

@@ -4,8 +4,6 @@ USING: arrays kernel math sequences vectors
 sequences sequences.private growable ;
 IN: sorting
 
-: midpoint@ ( seq -- n ) length 2/ ; inline
-
 DEFER: sort
 
 <PRIVATE
@@ -38,9 +36,6 @@ DEFER: sort
     rot length rot length + <vector>
     [ (merge) ] keep underlying ; inline
 
-: divide ( seq -- first second )
-    dup midpoint@ [ head-slice ] 2keep tail-slice ;
-
 : conquer ( first second quot -- result )
     [ tuck >r >r sort r> r> sort ] keep merge ; inline
 
@@ -48,7 +43,7 @@ PRIVATE>
 
 : sort ( seq quot -- sortedseq )
     over length 1 <=
-    [ drop ] [ over >r >r divide r> conquer r> like ] if ;
+    [ drop ] [ over >r >r halves r> conquer r> like ] if ;
     inline
 
 : natural-sort ( seq -- sortedseq ) [ <=> ] sort ;
@@ -63,8 +58,7 @@ PRIVATE>
     [ midpoint@ ] keep nth-unsafe ; inline
 
 : partition ( seq n -- slice )
-    >r dup midpoint@ r> 1 < [ head-slice ] [ tail-slice ] if ;
+    1 < swap halves ? ; inline
-    inline
 
 : (binsearch) ( elt quot seq -- i )
     dup length 1 <= [

core/source-files/source-files.factor

@@ -26,7 +26,7 @@ uses definitions ;
         rot source-file-checksum
         (source-modified?)
     ] [
-        ?resource-path exists?
+        resource-exists?
     ] ?if ;
 
 : record-modified ( source-file -- )

core/threads/threads.factor

@@ -49,7 +49,7 @@ PRIVATE>
             V{ } set-catchstack
             { } set-retainstack
             [ [ print-error ] recover stop ] call-clear
-        ] (throw)
+        ] 1 (throw)
     ] curry callcc0 ;
 
 <PRIVATE

core/vocabs/loader/loader-docs.factor

@@ -42,23 +42,9 @@ HELP: vocab-main
 HELP: vocab-roots
 { $var-description "A sequence of pathname strings to search for vocabularies." } ;
 
-HELP: vocab-source
-{ $values { "vocab" "a vocabulary specifier" } { "path" string } }
-{ $description "Outputs a pathname relative to a vocabulary root where the source code for " { $snippet "vocab" } " might be found." } ;
-
-{ vocab-source vocab-source-path } related-words
-
-HELP: vocab-docs
-{ $values { "vocab" "a vocabulary specifier" } { "path" string } }
-{ $description "Outputs a pathname relative to a vocabulary root where the documentation for " { $snippet "vocab" } " might be found." } ;
-
-{ vocab-docs vocab-docs-path } related-words
-
 HELP: vocab-tests
-{ $values { "vocab" "a vocabulary specifier" } { "path" string } }
+{ $values { "vocab" "a vocabulary specifier" } { "tests" "a sequence of pathname strings" } }
-{ $description "Outputs a pathname relative to a vocabulary root where the unit tests for " { $snippet "vocab" } " might be found." } ;
+{ $description "Outputs a sequence of pathnames where the unit tests for " { $snippet "vocab" } " are located." } ;
-
-{ vocab-tests vocab-tests-path } related-words
 
 HELP: find-vocab-root
 { $values { "vocab" "a vocabulary specifier" } { "path/f" "a pathname string" } }
@@ -86,14 +72,6 @@ HELP: load-docs
 { $values { "root" "a pathname string" } { "name" "a vocabulary name" } }
 { $description "If " { $link load-help? } " is on, loads a vocabulary's documentation from the specified vocabulary root." } ;
 
-HELP: amend-vocab-from-root
-{ $values { "root" "a pathname string" } { "name" "a vocabulary name" } { "vocab" vocab }  }
-{ $description "Loads a vocabulary's source code and documentation if they have not already been loaded, and outputs the vocabulary." } ;
-
-HELP: load-vocab-from-root
-{ $values { "root" "a pathname string" } { "name" "a vocabulary name" } }
-{ $description "Loads a vocabulary's source code and documentation." } ;
-
 HELP: reload
 { $values { "name" "a vocabulary name" } }
 { $description "Loads it's source code and documentation." }
@@ -116,10 +94,6 @@ HELP: vocab-docs-path
 { $values { "vocab" "a vocabulary specifier" } { "path/f" "a pathname string or " { $link f } } }
 { $description "Outputs a pathname where the documentation for " { $snippet "vocab" } " might be found. Outputs " { $link f } " if the vocabulary does not have a directory on disk." } ;
 
-HELP: vocab-tests-path
-{ $values { "vocab" "a vocabulary specifier" } { "path/f" "a pathname string or " { $link f } } }
-{ $description "Outputs a pathname where the unit tests for " { $snippet "vocab" } " might be found. Outputs " { $link f } " if the vocabulary does not have a directory on disk." } ;
-
 HELP: refresh
 { $values { "prefix" string } }
 { $description "Reloads source files and documentation belonging to loaded vocabularies whose names are prefixed by " { $snippet "prefix" } " which have been modified on disk." } ;

core/vocabs/loader/loader.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: namespaces splitting sequences io.files kernel assocs
 words vocabs definitions parser continuations inspector debugger
@@ -15,49 +15,64 @@ V{
     "resource:work"
 } clone vocab-roots set-global
 
-! No such thing as current directory on Windows CE
+: vocab-dir ( vocab -- dir )
-wince? [ "." vocab-roots get push ] unless
+    vocab-name "." split "/" join ;
 
 : vocab-dir+ ( vocab str/f -- path )
     >r vocab-name "." split r>
     [ >r dup peek r> append add ] when*
     "/" join ;
 
-: vocab-dir ( vocab -- dir )
+: vocab-path+ ( vocab path -- newpath )
-    f vocab-dir+ ;
+    swap vocab-root dup [ swap path+ ] [ 2drop f ] if ;
 
-: vocab-source ( vocab -- path )
+: vocab-source-path ( vocab -- path/f )
-    ".factor" vocab-dir+ ;
+    dup ".factor" vocab-dir+ vocab-path+ ;
 
-: vocab-docs ( vocab -- path )
+: vocab-docs-path ( vocab -- path/f )
-    "-docs.factor" vocab-dir+ ;
+    dup "-docs.factor" vocab-dir+ vocab-path+ ;
 
-: vocab-tests ( vocab -- path )
+: vocab-dir? ( root name -- ? )
-    "-tests.factor" vocab-dir+ ;
+    over [
+        ".factor" vocab-dir+ path+ resource-exists?
+    ] [
+        2drop f
+    ] if ;
 
 : find-vocab-root ( vocab -- path/f )
-    vocab-dir vocab-roots get
+    vocab-roots get swap [ vocab-dir? ] curry find nip ;
-    swap [ path+ ?resource-path exists? ] curry find nip ;
 
 M: string vocab-root
     dup vocab [ vocab-root ] [ find-vocab-root ] ?if ;
 
 M: vocab-link vocab-root
-    dup vocab-link-root [ ] [ vocab-link-name vocab-root ] ?if ;
+    vocab-link-root ;
+
+: vocab-tests ( vocab -- tests )
+    dup vocab-root [
+        [
+            f >vocab-link dup
+
+            dup "-tests.factor" vocab-dir+ vocab-path+
+            dup resource-exists? [ , ] [ drop ] if
+
+            dup vocab-dir "tests" path+ vocab-path+ dup
+            ?resource-path directory keys [ ".factor" tail? ] subset
+            [ path+ , ] with each
+        ] { } make
+    ] [ drop f ] if ;
 
 : vocab-files ( vocab -- seq )
-    [
+    f >vocab-link [
-        dup vocab-root dup [
+        dup vocab-source-path [ , ] when*
-            swap
+        dup vocab-docs-path [ , ] when*
-            2dup vocab-source path+ ,
+        vocab-tests %
-            2dup vocab-docs path+ ,
+    ] { } make ;
-            2dup vocab-tests path+ ,
-        ] when 2drop
-    ] { } make [ ?resource-path exists? ] subset ;
 
 TUPLE: no-vocab name ;
 
-: no-vocab ( name -- * ) \ no-vocab construct-boa throw ;
+: no-vocab ( name -- * )
+    vocab-name \ no-vocab construct-boa throw ;
 
 M: no-vocab summary drop "Vocabulary does not exist" ;
 
@@ -67,42 +82,36 @@ SYMBOL: load-help?
 
 : source-wasn't-loaded f swap set-vocab-source-loaded? ;
 
-: load-source ( root name -- )
+: load-source ( vocab-link -- )
     [ source-wasn't-loaded ] keep
-    [ vocab-source path+ bootstrap-file ] keep
+    [ vocab-source-path bootstrap-file ] keep
     source-was-loaded ;
 
 : docs-were-loaded t swap set-vocab-docs-loaded? ;
 
 : docs-weren't-loaded f swap set-vocab-docs-loaded? ;
 
-: load-docs ( root name -- )
+: load-docs ( vocab-link -- )
     load-help? get [
         [ docs-weren't-loaded ] keep
-        [ vocab-docs path+ ?run-file ] keep
+        [ vocab-docs-path ?run-file ] keep
         docs-were-loaded
-    ] [ 2drop ] if ;
+    ] [ drop ] if ;
 
-: amend-vocab-from-root ( root name -- vocab )
+: create-vocab-with-root ( vocab-link -- vocab )
-    dup vocab-source-loaded? [ 2dup load-source ] unless
+    dup vocab-name create-vocab
-    dup vocab-docs-loaded? [ 2dup load-docs ] unless
+    swap vocab-root over set-vocab-root ;
-    nip vocab ;
-
-: load-vocab-from-root ( root name -- )
-    2dup vocab-source path+ ?resource-path exists? [
-        2dup create-vocab set-vocab-root
-        2dup load-source load-docs
-    ] [
-        nip no-vocab
-    ] if ;
 
 : reload ( name -- )
     [
-        dup find-vocab-root dup [
+        f >vocab-link
-            swap load-vocab-from-root
+        dup vocab-root [
-        ] [
+            dup vocab-source-path resource-exists? [
-            drop no-vocab
+                create-vocab-with-root
-        ] if
+                dup load-source
+                load-docs
+            ] [ no-vocab ] if
+        ] [ no-vocab ] if
     ] with-compiler-errors ;
 
 : require ( vocab -- )
@@ -122,18 +131,6 @@ SYMBOL: load-help?
     [ nip ] assoc-subset
     [ nip source-modified? ] assoc-subset keys ; inline
 
-: vocab-path+ ( vocab path -- newpath )
-    swap vocab-root dup [ swap path+ ] [ 2drop f ] if ;
-
-: vocab-source-path ( vocab -- path/f )
-    dup vocab-source vocab-path+ ;
-
-: vocab-tests-path ( vocab -- path/f )
-    dup vocab-tests vocab-path+ ;
-
-: vocab-docs-path ( vocab -- path/f )
-    dup vocab-docs vocab-path+ ;
-
 : modified-sources ( vocabs -- seq )
     [ vocab-source-path ] modified ;
 
@@ -151,7 +148,7 @@ SYMBOL: load-help?
 : vocab-heading. ( vocab -- )
     nl
     "==== " write
-    dup vocab-name swap f >vocab-link write-object ":" print
+    dup vocab-name swap vocab write-object ":" print
     nl ;
 
 : load-error. ( triple -- )
@@ -187,8 +184,10 @@ SYMBOL: load-help?
 GENERIC: (load-vocab) ( name -- vocab )
 
 M: vocab (load-vocab)
-    dup vocab-root
+    dup vocab-root [
-    [ swap vocab-name amend-vocab-from-root ] when* ;
+        dup vocab-source-loaded? [ dup load-source ] unless
+        dup vocab-docs-loaded? [ dup load-docs ] unless
+    ] when ;
 
 M: string (load-vocab)
     [ ".private" ?tail drop reload ] keep vocab ;

core/vocabs/vocabs.factor

@@ -85,7 +85,8 @@ SYMBOL: load-vocab-hook
 
 TUPLE: vocab-link name root ;
 
-C: <vocab-link> vocab-link
+: <vocab-link> ( name root -- vocab-link )
+    [ dup vocab-root ] unless* vocab-link construct-boa ;
 
 M: vocab-link equal?
     over vocab-link?
@@ -96,7 +97,13 @@ M: vocab-link hashcode*
 
 M: vocab-link vocab-name vocab-link-name ;
 
-: >vocab-link ( name root -- vocab )
+GENERIC# >vocab-link 1 ( name root -- vocab )
+
+M: vocab >vocab-link drop ;
+
+M: vocab-link >vocab-link drop ;
+
+M: string >vocab-link
     over vocab dup [ 2nip ] [ drop <vocab-link> ] if ;
 
 UNION: vocab-spec vocab vocab-link ;

core/words/words.factor

@@ -115,7 +115,7 @@ compiled-crossref global [ H{ } assoc-like ] change-at
     compiled-crossref get at ;
 
 M: word redefined* ( word -- )
-    { "inferred-effect" "base-case" "no-effect" } reset-props ;
+    { "inferred-effect" "no-effect" } reset-props ;
 
 SYMBOL: changed-words
 

extra/base64/base64-tests.factor

@@ -1,4 +1,4 @@
-USING: tools.test base64 ;
+USING: kernel tools.test base64 strings ;
 
 [ "abcdefghijklmnopqrstuvwxyz" ] [ "abcdefghijklmnopqrstuvwxyz" >base64 base64>
 ] unit-test

extra/base64/base64.factor

@@ -35,13 +35,13 @@ PRIVATE>
     #! pad string with = when not enough bits
     dup length dup 3 mod - cut swap
     [
-        3 group [ encode3 % ] each
+        3 <groups> [ encode3 % ] each
         dup empty? [ drop ] [ >base64-rem % ] if
     ] "" make ;
 
 : base64> ( base64 -- str )
     #! input length must be a multiple of 4
     [
-        [ 4 group [ decode4 % ] each ] keep [ CHAR: = = not ] count-end 
+        [ 4 <groups> [ decode4 % ] each ] keep [ CHAR: = = not ] count-end 
     ] SBUF" " make swap [ dup pop* ] times >string ;
 

extra/benchmark/dispatch4/dispatch4.factor

@@ -1,5 +1,5 @@
 USING: kernel.private kernel sequences math combinators
-combinators.private ;
+sequences.private ;
 IN: benchmark.dispatch4
 
 : foobar-1

extra/bootstrap/help/help.factor

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

extra/builder/test/test.factor

@@ -7,8 +7,10 @@ USING: kernel sequences assocs builder continuations vocabs vocabs.loader
 
 IN: builder.test
 
+: try-everything* ( -- vocabs ) try-everything [ first vocab-link-name ] map ;
+
 : do-load ( -- )
-  [ try-everything ] "../load-everything-time" log-runtime
+  [ try-everything* ] "../load-everything-time" log-runtime
   dup empty?
     [ drop ]
     [ "../load-everything-log" log-object ]

extra/combinators/lib/lib-docs.factor

@@ -47,42 +47,6 @@ HELP: nkeep
 }
 { $see-also keep nslip } ;
 
-HELP: map-withn
-{ $values { "seq" sequence } { "quot" quotation } { "n" number } { "newseq" sequence } }
-{ $description "A generalisation of " { $link map } ". The first " { $snippet "n" } " items after the quotation will be "
-"passed to the quotation given to map-withn for each element in the sequence."
-} 
-{ $examples
-  { $example "USE: combinators.lib" "1 2 3 4 { 6 7 8 9 10 } [ + + + + ] 4 map-withn .s" "{ 16 17 18 19 20 }" }
-}
-{ $see-also each-withn } ;
-
-HELP: each-withn
-{ $values { "seq" sequence } { "quot" quotation } { "n" number } }
-{ $description "A generalisation of " { $link each } ". The first " { $snippet "n" } " items after the quotation will be "
-"passed to the quotation given to each-withn for each element in the sequence."
-} 
-{ $see-also map-withn } ;
-
-HELP: sigma
-{ $values { "seq" sequence } { "quot" quotation } { "n" number } }
-{ $description "Like map sum, but without creating an intermediate sequence." }
-{ $example
-    "! Find the sum of the squares [0,99]"
-    "USING: math.ranges combinators.lib ;"
-    "100 [1,b] [ sq ] sigma ."
-    "338350"
-} ;
-
-HELP: count
-{ $values { "seq" sequence } { "quot" quotation } { "n" integer } }
-{ $description "Efficiently returns the number of elements that the predicate quotation matches." }
-{ $example
-    "USING: math.ranges combinators.lib ;"
-    "100 [1,b] [ even? ] count ."
-    "50"
-} ;
-
 HELP: &&
 { $values { "quots" "a sequence of quotations with stack effect " { $snippet "( ... -- ... ? )" } } { "?" "a boolean" } }
 { $description "Calls each quotation in turn; outputs " { $link f } " if one of the quotations output " { $link f } ", otherwise outputs " { $link t } ". As soon as a quotation outputs " { $link f } ", evaluation stops and subsequent quotations are not called." } ;

extra/combinators/lib/lib-tests.factor

@@ -4,11 +4,7 @@ IN: temporary
 
 [ 5 ] [ [ 10 random ] [ 5 = ] generate ] unit-test
 [ t ] [ [ 10 random ] [ even? ] generate even? ] unit-test
-[ 50 ] [ 100 [1,b] [ even? ] count ] unit-test
-[ 50 ] [ 100 [1,b] [ odd? ] count ] unit-test
-[ 328350 ] [ 100 [ sq ] sigma ] unit-test
 
-[ { 910 911 912 } ] [ 10 900 3 [ + + ] map-with2 ] unit-test
 { 6 2 } [ 1 2 [ 5 + ] dip ] unit-test
 { 6 2 1 } [ 1 2 1 [ 5 + ] dipd ] unit-test
 
@@ -17,11 +13,6 @@ IN: temporary
 [ 1 2 3 4 5 [ drop drop drop drop drop 2 ] 5 nkeep ] must-infer
 { 2 1 2 3 4 5 } [ 1 2 3 4 5 [ drop drop drop drop drop 2 ] 5 nkeep ] unit-test
 [ [ 1 2 3 + ] ] [ 1 2 3 [ + ] 3 ncurry ] unit-test
-[ 1 2 { 3 4 } [ + + ] 2 map-withn ] must-infer
-{ { 6 7 } } [ 1 2 { 3 4 } [ + + ] 2 map-withn ] unit-test
-{ { 16 17 18 19 20 } } [ 1 2 3 4 { 6 7 8 9 10 } [ + + + + ] 4 map-withn ] unit-test
-[ 1 2 { 3 4 } [ + + drop ] 2 each-withn  ] must-infer
-{ 13 } [ 1 2 { 3 4 } [ + + ] 2 each-withn + ] unit-test
 [ 1 1 2 2 3 3 ] [ 1 2 3 [ dup ] 3apply ] unit-test
 [ 1 4 9 ] [ 1 2 3 [ sq ] 3apply ] unit-test
 [ [ sq ] 3apply ] must-infer
@@ -55,5 +46,3 @@ IN: temporary
         [ dup array? ] [ dup vector? ] [ dup float? ]
     } || nip
 ] unit-test
-
-[ 1 2 3 4 ] [ { 1 2 3 4 } 4 nfirst ] unit-test

extra/combinators/lib/lib.factor

@@ -1,11 +1,9 @@
 ! Copyright (C) 2007 Slava Pestov, Chris Double, Doug Coleman,
 !                    Eduardo Cavazos, Daniel Ehrenberg.
-! 
 ! See http://factorcode.org/license.txt for BSD license.
-
+USING: kernel combinators namespaces quotations hashtables
-USING: kernel combinators namespaces quotations hashtables sequences assocs
+sequences assocs arrays inference effects math math.ranges
-       arrays inference effects math math.ranges arrays.lib shuffle macros
+arrays.lib shuffle macros bake combinators.cleave ;
-       bake combinators.cleave ;
 
 IN: combinators.lib
 
@@ -51,22 +49,6 @@ MACRO: napply ( n -- )
 
 : dipd ( x y quot -- y ) 2 ndip ; inline
 
-! each-with
-
-: each-withn ( seq quot n -- ) nwith each ; inline
-
-: each-with ( seq quot -- ) with each ; inline
-
-: each-with2 ( obj obj list quot -- ) 2 each-withn ; inline
-
-! map-with
-
-: map-withn ( seq quot n -- newseq ) nwith map ; inline
-
-: map-with ( seq quot -- ) with map ; inline
-
-: map-with2 ( obj obj list quot -- newseq ) 2 map-withn ; inline
-
 : 2with ( param1 param2 obj quot -- obj curry )
     with with ; inline
 
@@ -88,31 +70,15 @@ MACRO: napply ( n -- )
 : assoc-map-with ( obj assoc quot -- assoc )
     with* assoc-map ; inline
 
-
-MACRO: nfirst ( n -- )
-    [ [ swap nth ] curry [ keep ] curry ] map concat [ drop ] compose ;
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-: sigma ( seq quot -- n ) [ rot slip + ] curry 0 swap reduce ; inline
-
-: count ( seq quot -- n ) [ 1 0 ? ] compose sigma ; inline
-
 ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
 ! short circuiting words
 ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
 
-! : short-circuit ( quots quot default -- quot )
-!   >r { } map>assoc <reversed> r>
-!   1quotation swap alist>quot ;
-
 : short-circuit ( quots quot default -- quot )
   1quotation -rot { } map>assoc <reversed> alist>quot ;
 
-! : short-circuit ( quots quot default -- quot )
+MACRO: && ( quots -- ? )
-!   1quotation -rot map>alist <reversed> alist>quot ;
+    [ [ not ] append [ f ] ] t short-circuit ;
-
-MACRO: && ( quots -- ? ) [ [ not ] append [ f ] ] t short-circuit ;
 
 MACRO: <-&& ( quots -- )
     [ [ dup ] swap append [ not ] append [ f ] ] t short-circuit
@@ -159,14 +125,6 @@ MACRO: parallel-call ( quots -- )
     [ [ unclip % r> dup >r push ] bake ] map concat
     [ V{ } clone >r % drop r> >array ] bake ;
 
-! MACRO: parallel-call ( quots -- )
-!   [ [ unclip ] swap append ] map
-!   [ [ r> swap add >r ] append ] map
-!   concat
-!   [ { } >r ] swap append ! pre
-!   [ drop r> ] append ;   ! post
-
-
 ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
 ! map-call and friends
 ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
@@ -188,9 +146,10 @@ MACRO: call-with2 ( quots -- )
     (make-call-with2) ;
 
 MACRO: map-call-with2 ( quots -- )
-  dup >r (make-call-with2) r> length [ narray ] curry append ;
+    [ (make-call-with2) ] keep length [ narray ] curry append ;
 
-MACRO: map-exec-with ( words -- ) [ 1quotation ] map [ map-call-with ] curry ;
+MACRO: map-exec-with ( words -- )
+    [ 1quotation ] map [ map-call-with ] curry ;
 
 MACRO: construct-slots ( assoc tuple-class -- tuple ) 
     [ construct-empty ] curry swap [
@@ -208,14 +167,3 @@ MACRO: construct-slots ( assoc tuple-class -- tuple )
 
 : and? ( obj quot1 quot2 -- ? )
     >r keep r> rot [ call ] [ 2drop f ] if ; inline
-
-: prepare-index ( seq quot -- seq n quot )
-    >r dup length r> ; inline
-
-: each-index ( seq quot -- )
-    #! quot: ( elt index -- )
-    prepare-index 2each ; inline
-
-: map-index ( seq quot -- )
-    #! quot: ( elt index -- obj )
-    prepare-index 2map ; inline

extra/cpu/8080/emulator/emulator.factor

@@ -4,7 +4,7 @@
 USING: kernel math sequences words arrays io 
        io.files namespaces math.parser kernel.private
        assocs quotations parser parser-combinators tools.time
-       combinators.private compiler.units ;
+       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 ;

extra/crypto/md5/md5.factor

@@ -153,7 +153,7 @@ SYMBOL: old-d
     dup S44 64 9  [ I ] BCDA ;
 
 : (process-md5-block) ( block -- )
-    4 group [ le> ] map
+    4 <groups> [ le> ] map
 
     (process-md5-block-F)
     (process-md5-block-G)

extra/db/db.factor

@@ -4,12 +4,27 @@ USING: arrays assocs classes continuations kernel math
 namespaces sequences sequences.lib tuples words ;
 IN: db
 
-TUPLE: db handle ;
+TUPLE: db handle insert-statements update-statements delete-statements select-statements ;
-C: <db> db ( handle -- obj )
+: <db> ( handle -- obj )
+    H{ } clone
+    H{ } clone
+    H{ } clone
+    H{ } clone
+    db construct-boa ;
 
-! HOOK: db-create db ( str -- )
-! HOOK: db-drop db ( str -- )
 GENERIC: db-open ( db -- )
+HOOK: db-close db ( handle -- )
+
+: dispose-statements [ dispose drop ] assoc-each ;
+
+: dispose-db ( db -- ) 
+    dup db [
+        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? ;
 
@@ -43,6 +58,8 @@ GENERIC: #columns ( result-set -- n )
 GENERIC# row-column 1 ( result-set n -- obj )
 GENERIC: advance-row ( result-set -- ? )
 
+HOOK: last-id db ( -- id )
+
 : init-result-set ( result-set -- )
     dup #rows over set-result-set-max
     -1 swap set-result-set-n ;

extra/db/mysql/mysql.factor

@@ -14,7 +14,6 @@ M: mysql-db db-open ( mysql-db -- )
 M: mysql-db dispose ( mysql-db -- )
     mysql-db-handle mysql_close ;
 
-
 M: mysql-db <simple-statement> ( str -- statement )
     ;
 

extra/db/sqlite/ffi/ffi.factor

@@ -106,6 +106,8 @@ IN: db.sqlite.ffi
 
 TYPEDEF: void sqlite3
 TYPEDEF: void sqlite3_stmt
+TYPEDEF: longlong sqlite3_int64
+TYPEDEF: ulonglong sqlite3_uint64
 
 LIBRARY: sqlite
 FUNCTION: int sqlite3_open ( char* filename, void* ppDb ) ;
@@ -116,7 +118,9 @@ FUNCTION: int sqlite3_reset ( sqlite3_stmt* pStmt ) ;
 FUNCTION: int sqlite3_step ( sqlite3_stmt* pStmt ) ;
 FUNCTION: int sqlite3_last_insert_rowid ( sqlite3* pStmt ) ;
 FUNCTION: int sqlite3_bind_blob ( sqlite3_stmt* pStmt, int index, void* ptr, int len, int destructor ) ;
+FUNCTION: int sqlite3_bind_double ( sqlite3_stmt* pStmt, int index, double x ) ;
 FUNCTION: int sqlite3_bind_int ( sqlite3_stmt* pStmt, int index, int n ) ;
+FUNCTION: int sqlite3_bind_int64 ( sqlite3_stmt* pStmt, int index, sqlite3_int64 n ) ;
 FUNCTION: int sqlite3_bind_null ( sqlite3_stmt* pStmt, int n ) ;
 FUNCTION: int sqlite3_bind_text ( sqlite3_stmt* pStmt, int index, char* text, int len, int destructor ) ;
 FUNCTION: int sqlite3_bind_parameter_index ( sqlite3_stmt* pStmt, char* name ) ;

extra/db/sqlite/lib/lib.factor

@@ -21,9 +21,6 @@ TUPLE: sqlite-error n message ;
 : sqlite-close ( db -- )
     sqlite3_close sqlite-check-result ;
 
-: sqlite-last-insert-rowid ( db -- rowid )
-    sqlite3_last_insert_rowid ;
-
 : sqlite-prepare ( db sql -- statement )
     #! TODO: Support multiple statements in the SQL string.
     dup length "void*" <c-object> "void*" <c-object>

extra/db/sqlite/sqlite.factor

@@ -3,7 +3,8 @@
 USING: alien arrays assocs classes compiler db
 hashtables io.files kernel math math.parser namespaces
 prettyprint sequences strings tuples alien.c-types
-continuations db.sqlite.lib db.sqlite.ffi ;
+continuations db.sqlite.lib db.sqlite.ffi db.tuples
+words combinators.lib db.types ;
 IN: db.sqlite
 
 TUPLE: sqlite-db path ;
@@ -13,10 +14,10 @@ M: sqlite-db db-open ( db -- )
     dup sqlite-db-path sqlite-open <db>
     swap set-delegate ;
 
-M: sqlite-db dispose ( obj -- )
+M: sqlite-db db-close ( handle -- )
-    dup db-handle sqlite-close
+    sqlite-close ;
-    f over set-db-handle
+
-    f swap set-delegate ;
+M: sqlite-db dispose ( db -- ) dispose-db ;
 
 : with-sqlite ( path quot -- )
     >r <sqlite-db> r> with-db ; inline
@@ -72,3 +73,109 @@ M: sqlite-db commit-transaction ( -- )
 
 M: sqlite-db rollback-transaction ( -- )
     "ROLLBACK" sql-command ;
+
+M: sqlite-db create-sql ( columns table -- sql )
+    [
+        "create table " % %
+        " (" % [ ", " % ] [
+            dup second % " " %
+            dup third >sql-type % " " %
+            sql-modifiers " " join %
+        ] interleave ")" %
+    ] "" make ;
+
+M: sqlite-db drop-sql ( table -- sql )
+    [
+        "drop table " % %
+    ] "" make ;
+
+M: sqlite-db insert-sql* ( columns table -- sql )
+    [
+        "insert into " %
+        %
+        "(" %
+        dup [ ", " % ] [ second % ] interleave
+        ") " %
+        " values (" %
+        [ ", " % ] [ ":" % second % ] interleave
+        ")" %
+    ] "" make ;
+
+M: sqlite-db update-sql* ( columns table -- sql )
+    [
+        "update " %
+        %
+        " set " %
+        dup remove-id
+        [ ", " % ] [ second dup % " = :" % % ] interleave
+        " where " %
+        [ primary-key? ] find nip second dup % " = :" % %
+    ] "" make ;
+
+M: sqlite-db delete-sql* ( columns table -- sql )
+    [
+        "delete from " %
+        %
+        " where " %
+        first second dup % " = :" % %
+    ] "" make dup . ;
+
+M: sqlite-db select-sql* ( columns table -- sql )
+    [
+        "select ROWID, " %
+        swap [ ", " % ] [ second % ] interleave
+        " from " %
+        %
+        " where ROWID = :ID" %
+    ] "" make ;
+
+M: sqlite-db tuple>params ( columns tuple -- obj )
+    [
+        >r [ second ":" swap append ] keep first r> get-slot-named
+        number>string*
+    ] curry { } map>assoc  ;
+    
+M: sqlite-db last-id ( -- id )
+    db get db-handle sqlite3_last_insert_rowid ;
+
+
+: sqlite-db-modifiers ( -- hashtable )
+    H{
+        { +native-id+ "primary key" }
+        { +assigned-id+ "primary key" }
+        { +autoincrement+ "autoincrement" }
+        { +unique+ "unique" }
+        { +default+ "default" }
+        { +null+ "null" }
+        { +not-null+ "not null" }
+    } ;
+
+M: sqlite-db sql-modifiers* ( modifiers -- str )
+    sqlite-db-modifiers swap [
+        dup array? [
+            first2
+            >r swap at r> number>string*
+            " " swap 3append
+        ] [
+            swap at
+        ] if
+    ] with map [ ] subset ;
+
+: sqlite-type-hash ( -- assoc )
+    H{
+        { INTEGER "integer" }
+        { TEXT "text" }
+        { VARCHAR "text" }
+    } ;
+
+M: sqlite-db >sql-type ( obj -- str )
+    dup pair? [
+        first >sql-type
+    ] [
+        sqlite-type-hash at* [ T{ no-sql-type } throw ] unless
+    ] if ;
+
+! HOOK: get-column-value ( n result-set type -- )
+! M: sqlite get-column-value { { "TEXT" get-text-column } { 
+! "INTEGER" get-integer-column } ... } case ;
+

extra/db/tuples/tuples-tests.factor

@@ -0,0 +1,45 @@
+USING: io.files kernel tools.test db db.sqlite db.tuples
+db.types continuations namespaces ;
+IN: temporary
+
+TUPLE: person the-id the-name the-number ;
+: <person> ( name age -- person )
+    { set-person-the-name set-person-the-number } person construct ;
+
+person "PERSON"
+{
+    { "the-id" "ROWID" INTEGER +native-id+ }
+    { "the-name" "NAME" { VARCHAR 256 } +not-null+ } 
+    { "the-number" "AGE" INTEGER { +default+ 0 } }
+} define-persistent
+
+
+SYMBOL: the-person
+
+: test-tuples ( -- )
+    [ person drop-table ] [ ] recover
+    person create-table
+    f "billy" 100 person construct-boa
+    the-person set
+    
+    [  ] [ the-person get insert-tuple ] unit-test
+
+    [ 1 ] [ the-person get person-the-id ] unit-test
+
+    200 the-person get set-person-the-number
+
+    [ ] [ the-person get update-tuple ] unit-test
+
+    [ ] [ the-person get delete-tuple ] unit-test ;
+
+: test-sqlite ( -- )
+    "tuples-test.db" resource-path <sqlite-db> [
+        test-tuples
+    ] with-db ;
+
+test-sqlite
+
+! : test-postgres ( -- )
+    ! resource-path <postgresql-db> [
+        ! test-tuples
+    ! ] with-db ;

extra/db/tuples/tuples.factor

@@ -0,0 +1,119 @@
+USING: arrays assocs classes db kernel namespaces
+tuples words sequences slots slots.private math
+math.parser io prettyprint db.types ;
+USE: continuations
+IN: db.tuples
+
+! only take a tuple if you have to extract things from it
+! otherwise take a class
+! primary-key vs primary-key-spec
+! define-persistent should enforce a primary key
+! in sqlite, defining a new primary key makes it an alias for rowid, _rowid_, and oid
+! -sql outputs sql code
+! table - string
+! columns - seq of column specifiers
+
+: db-columns ( class -- obj )
+    "db-columns" word-prop ;
+
+: db-table ( class -- obj )
+    "db-table" word-prop ;
+
+
+: slot-spec-named ( str class -- slot-spec )
+    "slots" word-prop [ slot-spec-name = ] with find nip ;
+
+: offset-of-slot ( str obj -- n )
+    class slot-spec-named slot-spec-offset ;
+
+: get-slot-named ( str obj -- value )
+    tuck offset-of-slot slot ;
+
+: set-slot-named ( value str obj -- )
+    tuck offset-of-slot set-slot ;
+    
+
+: primary-key-spec ( class -- spec )
+    db-columns [ primary-key? ] find nip ;
+    
+: primary-key ( tuple -- obj )
+    dup class primary-key-spec get-slot-named ;
+
+: set-primary-key ( obj tuple -- )
+    [ class primary-key-spec first ] keep
+    set-slot-named ;
+
+
+: cache-statement ( columns class assoc quot -- statement )
+    [ db-table dupd ] swap
+    [ <prepared-statement> ] 3compose cache nip ; inline
+
+HOOK: create-sql db ( columns table -- sql )
+HOOK: drop-sql db ( table -- sql )
+HOOK: insert-sql* db ( columns table -- sql )
+HOOK: update-sql* db ( columns table -- sql )
+HOOK: delete-sql* db ( columns table -- sql )
+HOOK: select-sql* db ( columns table -- sql )
+
+: insert-sql ( columns class -- statement )
+    db get db-insert-statements [ insert-sql* ] cache-statement ;
+
+: update-sql ( columns class -- statement )
+    db get db-update-statements [ update-sql* ] cache-statement ;
+
+: 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
+    [ bind-statement ] keep ;
+
+: do-tuple-statement ( tuple columns-quot statement-quot -- )
+    >r [ class db-columns ] swap compose keep
+    r> tuple-statement dup . execute-statement ;
+
+: create-table ( class -- )
+    dup db-columns swap db-table create-sql sql-command ;
+    
+: drop-table ( class -- )
+    db-table drop-sql sql-command ;
+
+: insert-tuple ( tuple -- )
+    [
+        [ maybe-remove-id ] [ insert-sql ] do-tuple-statement
+        last-id
+    ] keep set-primary-key ;
+
+: update-tuple ( tuple -- )
+    [ ] [ update-sql ] do-tuple-statement ;
+
+: delete-tuple ( tuple -- )
+    [ [ primary-key? ] subset ] [ delete-sql ] do-tuple-statement ;
+
+! : select-tuple ( tuple -- )
+  !  [ select-sql ] bind-tuple do-query ;
+
+: persist ( tuple -- )
+    dup primary-key [ update-tuple ] [ insert-tuple ] if ;
+
+! PERSISTENT:
+
+: define-persistent ( class table columns -- )
+    >r dupd "db-table" set-word-prop r>
+    "db-columns" set-word-prop ;
+
+: define-relation ( spec -- )
+    drop ;
+
+
+
+
+
+
+
+

extra/db/types/types.factor

@@ -0,0 +1,70 @@
+USING: arrays assocs db kernel math math.parser
+sequences continuations ;
+IN: db.types
+
+
+! id   serial not null primary key,
+! ID is the Primary key
+SYMBOL: +native-id+
+SYMBOL: +assigned-id+
+
+: primary-key? ( spec -- ? )
+    [ { +native-id+ +assigned-id+ } member? ] contains? ;
+
+! Same concept, SQLite has autoincrement, PostgreSQL has serial
+SYMBOL: +autoincrement+
+SYMBOL: +serial+
+SYMBOL: +unique+
+
+SYMBOL: +default+
+SYMBOL: +null+
+SYMBOL: +not-null+
+SYMBOL: +has-many+
+
+! SQLite Types
+! http://www.sqlite.org/datatype3.html
+! SYMBOL: NULL
+! SYMBOL: INTEGER
+! SYMBOL: REAL
+! SYMBOL: TEXT
+! SYMBOL: BLOB
+
+SYMBOL: INTEGER
+SYMBOL: DOUBLE
+SYMBOL: BOOLEAN
+
+SYMBOL: TEXT
+SYMBOL: VARCHAR
+
+SYMBOL: TIMESTAMP
+SYMBOL: DATE
+
+SYMBOL: BIG_INTEGER
+
+! SYMBOL: LOCALE
+! SYMBOL: TIMEZONE
+! SYMBOL: CURRENCY
+
+
+! PostgreSQL Types
+! http://developer.postgresql.org/pgdocs/postgres/datatype.html
+
+
+: number>string* ( num/str -- str )
+    dup number? [ number>string ] when ;
+
+TUPLE: no-sql-type ;
+HOOK: sql-modifiers* db ( modifiers -- str )
+HOOK: >sql-type db ( obj -- str )
+
+
+
+
+: maybe-remove-id ( columns -- obj )
+    [ +native-id+ swap member? not ] subset ;
+
+: remove-id ( columns -- obj )
+    [ primary-key? not ] subset ;
+
+: sql-modifiers ( spec -- seq )
+    3 tail sql-modifiers* ;

extra/furnace/furnace.factor

@@ -189,7 +189,7 @@ SYMBOL: model
     swap [ render-template ] with-slots ;
 
 : browse-webapp-source ( vocab -- )
-    <a f >vocab-link browser-link-href =href a>
+    <a vocab browser-link-href =href a>
         "Browse source" write
     </a> ;
 

extra/http/server/server-tests.factor

@@ -1,15 +1,12 @@
 USING: webapps.file http.server.responders http
-http.server namespaces io tools.test strings io.server ;
+http.server namespaces io tools.test strings io.server
+logging ;
 IN: temporary
 
 [ ] [ f [ "404 not found" httpd-error ] with-logging ] unit-test
 
 [ "inspect/global" ] [ "/inspect/global" trim-/ ] unit-test
 
-[ ] [
-    f [ "unit/test" log-responder ] with-logging
-] unit-test
-
 [ "index.html" ]
 [ "http://www.jedit.org/index.html" url>path ] unit-test
 

extra/icfp/2006/2006.factor

@@ -1,7 +1,7 @@
 ! Copyright (C) 2007 Gavin Harrison
 ! See http://factorcode.org/license.txt for BSD license.
 USING: kernel math sequences kernel.private namespaces arrays io io.files
-    splitting io.binary math.functions vectors quotations combinators.private ;
+    splitting io.binary math.functions vectors quotations sequences.private ;
 IN: icfp.2006
 
 SYMBOL: regs

extra/inverse/inverse.factor

@@ -1,7 +1,7 @@
 USING: kernel words inspector slots quotations sequences assocs
 math arrays inference effects shuffle continuations debugger
 tuples namespaces vectors bit-arrays byte-arrays strings sbufs
-math.functions macros combinators.private combinators ;
+math.functions macros sequences.private combinators ;
 IN: inverse
 
 TUPLE: fail ;

extra/io/streams/null/null.factor

@@ -6,7 +6,7 @@ USING: kernel io io.timeouts continuations ;
 TUPLE: null-stream ;
 
 M: null-stream dispose drop ;
-M: null-stream set-timeout drop ;
+M: null-stream set-timeout 2drop ;
 M: null-stream stream-readln drop f ;
 M: null-stream stream-read1 drop f ;
 M: null-stream stream-read-until 2drop f f ;

extra/logging/parser/parser.factor

@@ -11,8 +11,10 @@ IN: logging.parser
 SYMBOL: multiline
 
 : 'date'
-    multiline-header token [ drop multiline ] <@
+    [ "]" member? not ] string-of [
-    [ CHAR: ] eq? not ] string-of [ rfc3339>timestamp ] <@ <|>
+        dup multiline-header =
+        [ drop multiline ] [ rfc3339>timestamp ] if
+    ] <@
     "[" "]" surrounded-by ;
 
 : 'log-level'

extra/new-slots/new-slots.factor

@@ -1,7 +1,7 @@
 ! Copyright (C) 2008 Slava Pestov.
 ! See http://factorcode.org/license.txt for BSD license.
 USING: effects words kernel sequences slots slots.private
-assocs parser mirrors namespaces math vocabs ;
+assocs parser mirrors namespaces math vocabs tuples ;
 IN: new-slots
 
 : create-accessor ( name effect -- word )
@@ -19,11 +19,21 @@ IN: new-slots
 : writer-effect T{ effect f { "value" "object" } { } } ; inline
 
 : writer-word ( name -- word )
-    ">>" swap append writer-effect create-accessor ;
+    "(>>" swap ")" 3append writer-effect create-accessor ;
 
 : define-writer ( class slot name -- )
     writer-word [ set-slot ] define-slot-word ;
 
+: setter-effect T{ effect f { "object" "value" } { "value" } } ; inline
+
+: setter-word ( name -- word )
+    ">>" swap append setter-effect create-accessor ;
+
+: define-setter ( name -- )
+    dup setter-word dup deferred? [
+        [ \ over , swap writer-word , ] [ ] make define-inline
+    ] [ 2drop ] if ;
+
 : changer-effect T{ effect f { "object" "quot" } } ; inline
 
 : changer-word ( name -- word )
@@ -40,12 +50,18 @@ IN: new-slots
     ] [ 2drop ] if ;
 
 : define-new-slot ( class slot name -- )
-    dup define-changer 3dup define-reader define-writer ;
+    dup define-changer
+    dup define-setter
+    3dup define-reader
+    define-writer ;
 
 : define-new-slots ( tuple-class -- )
     [ "slot-names" word-prop <enum> >alist ] keep
     [ swap first2 >r 4 + r> define-new-slot ] curry each ;
 
-: NEW-SLOTS: scan-word define-new-slots ; parsing
+: TUPLE:
+    CREATE-CLASS
+    dup ";" parse-tokens define-tuple-class
+    define-new-slots ; parsing
 
 "accessors" create-vocab drop

extra/optimizer/debugger/debugger.factor

@@ -3,7 +3,7 @@
 USING: classes inference inference.dataflow io kernel
 kernel.private math.parser namespaces optimizer prettyprint
 prettyprint.backend sequences words arrays match macros
-assocs combinators.private ;
+assocs sequences.private ;
 IN: optimizer.debugger
 
 ! A simple tool for turning dataflow IR into quotations, for

extra/sequences/lib/lib-docs.factor

@@ -0,0 +1,39 @@
+USING: help.syntax help.markup kernel prettyprint sequences
+quotations math ;
+IN: sequences.lib
+
+HELP: map-withn
+{ $values { "seq" sequence } { "quot" quotation } { "n" number } { "newseq" sequence } }
+{ $description "A generalisation of " { $link map } ". The first " { $snippet "n" } " items after the quotation will be "
+"passed to the quotation given to map-withn for each element in the sequence."
+} 
+{ $examples
+  { $example "USE: combinators.lib" "1 2 3 4 { 6 7 8 9 10 } [ + + + + ] 4 map-withn .s" "{ 16 17 18 19 20 }" }
+}
+{ $see-also each-withn } ;
+
+HELP: each-withn
+{ $values { "seq" sequence } { "quot" quotation } { "n" number } }
+{ $description "A generalisation of " { $link each } ". The first " { $snippet "n" } " items after the quotation will be "
+"passed to the quotation given to each-withn for each element in the sequence."
+} 
+{ $see-also map-withn } ;
+
+HELP: sigma
+{ $values { "seq" sequence } { "quot" quotation } { "n" number } }
+{ $description "Like map sum, but without creating an intermediate sequence." }
+{ $example
+    "! Find the sum of the squares [0,99]"
+    "USING: math.ranges combinators.lib ;"
+    "100 [1,b] [ sq ] sigma ."
+    "338350"
+} ;
+
+HELP: count
+{ $values { "seq" sequence } { "quot" quotation } { "n" integer } }
+{ $description "Efficiently returns the number of elements that the predicate quotation matches." }
+{ $example
+    "USING: math.ranges combinators.lib ;"
+    "100 [1,b] [ even? ] count ."
+    "50"
+} ;

extra/sequences/lib/lib-tests.factor

@@ -1,5 +1,5 @@
 USING: arrays kernel sequences sequences.lib math
-math.functions tools.test strings ;
+math.functions tools.test strings math.ranges ;
 
 [ 4 ] [ { 1 2 } [ sq ] [ * ] map-reduce ] unit-test
 [ 36 ] [ { 2 3 } [ sq ] [ * ] map-reduce ] unit-test
@@ -53,3 +53,16 @@ math.functions tools.test strings ;
 [ 2 ] [ { 1 2 3 } ?second ] unit-test
 [ 3 ] [ { 1 2 3 } ?third ] unit-test
 [ f ] [ { 1 2 3 } ?fourth ] unit-test
+
+[ 50 ] [ 100 [1,b] [ even? ] count ] unit-test
+[ 50 ] [ 100 [1,b] [ odd? ] count ] unit-test
+[ 328350 ] [ 100 [ sq ] sigma ] unit-test
+
+[ 1 2 { 3 4 } [ + + ] 2 map-withn ] must-infer
+{ { 6 7 } } [ 1 2 { 3 4 } [ + + ] 2 map-withn ] unit-test
+{ { 16 17 18 19 20 } } [ 1 2 3 4 { 6 7 8 9 10 } [ + + + + ] 4 map-withn ] unit-test
+[ 1 2 { 3 4 } [ + + drop ] 2 each-withn  ] must-infer
+{ 13 } [ 1 2 { 3 4 } [ + + ] 2 each-withn + ] unit-test
+[ { 910 911 912 } ] [ 10 900 3 [ + + ] map-with2 ] unit-test
+
+[ 1 2 3 4 ] [ { 1 2 3 4 } 4 nfirst ] unit-test

extra/sequences/lib/lib.factor

@@ -1,8 +1,45 @@
+! Copyright (C) 2007 Slava Pestov, Chris Double, Doug Coleman,
+!                    Eduardo Cavazos, Daniel Ehrenberg.
+! See http://factorcode.org/license.txt for BSD license.
 USING: combinators.lib kernel sequences math namespaces assocs 
 random sequences.private shuffle math.functions mirrors
-arrays math.parser sorting strings ascii ;
+arrays math.parser sorting strings ascii macros ;
 IN: sequences.lib
 
+: each-withn ( seq quot n -- ) nwith each ; inline
+
+: each-with ( seq quot -- ) with each ; inline
+
+: each-with2 ( obj obj list quot -- ) 2 each-withn ; inline
+
+: map-withn ( seq quot n -- newseq ) nwith map ; inline
+
+: map-with ( seq quot -- ) with map ; inline
+
+: map-with2 ( obj obj list quot -- newseq ) 2 map-withn ; inline
+
+MACRO: nfirst ( n -- )
+    [ [ swap nth ] curry [ keep ] curry ] map concat [ drop ] compose ;
+
+: prepare-index ( seq quot -- seq n quot )
+    >r dup length r> ; inline
+
+: each-index ( seq quot -- )
+    #! quot: ( elt index -- )
+    prepare-index 2each ; inline
+
+: map-index ( seq quot -- )
+    #! quot: ( elt index -- obj )
+    prepare-index 2map ; inline
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+: sigma ( seq quot -- n )
+    [ rot slip + ] curry 0 swap reduce ; inline
+
+: count ( seq quot -- n )
+    [ 1 0 ? ] compose sigma ; inline
+
 ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
 
 : map-reduce ( seq map-quot reduce-quot -- result )
@@ -66,7 +103,7 @@ IN: sequences.lib
 
 : split-around ( seq quot -- before elem after )
     dupd find over [ "Element not found" throw ] unless
-    >r cut-slice 1 tail r> swap ; inline
+    >r cut 1 tail r> swap ; inline
 
 : (map-until) ( quot pred -- quot )
     [ dup ] swap 3compose

extra/smtp/smtp-tests.factor

@@ -1,5 +1,5 @@
 USING: smtp tools.test io.streams.string threads
-smtp.server kernel sequences namespaces ;
+smtp.server kernel sequences namespaces logging ;
 IN: temporary
 
 { 0 0 } [ [ ] with-smtp-connection ] must-infer-as
@@ -15,34 +15,22 @@ IN: temporary
     { "hello" "world" } [ send-body ] string-out
 ] unit-test
 
-[
+[ "500 syntax error" check-response ] must-fail
-    [
-        "500 syntax error" check-response
-    ] with-log-stdio
-] must-fail
 
-[ ] [
+[ ] [ "220 success" check-response ] unit-test
-    [
-        "220 success" check-response
-    ] with-log-stdio
-] unit-test
 
 [ "220 success" ] [
     "220 success" [ receive-response ] string-in
 ] unit-test
 
 [ "220 the end" ] [
-    [
     "220-a multiline response\r\n250-another line\r\n220 the end"
     [ receive-response ] string-in
-    ] with-log-stdio
 ] unit-test
 
 [ ] [
-    [
     "220-a multiline response\r\n250-another line\r\n220 the end"
     [ get-ok ] string-in
-    ] with-log-stdio
 ] unit-test
 
 [

extra/space-invaders/space-invaders.factor

@@ -5,7 +5,7 @@ USING: cpu.8080 cpu.8080.emulator openal math alien.c-types sequences kernel
        shuffle arrays io.files combinators kernel.private
        ui.gestures ui.gadgets ui.render opengl.gl system 
        threads concurrency match ui byte-arrays combinators.lib
-       combinators.private ;
+       sequences.private ;
 IN: space-invaders
 
 TUPLE: space-invaders port1 port2i port2o port3o port4lo port4hi port5o bitmap sounds looping? ;

extra/state-machine/state-machine.factor

@@ -1,5 +1,5 @@
 USING: kernel parser strings math namespaces sequences words io
-arrays quotations debugger kernel.private combinators.private ;
+arrays quotations debugger kernel.private sequences.private ;
 IN: state-machine
 
 : STATES:

extra/tar/tar.factor

@@ -236,10 +236,9 @@ TUPLE: unimplemented-typeflag header ;
     ] when* ;
 
 : parse-tar ( path -- obj )
-    <file-reader> [
+    [
         "tar-test" resource-path base-dir set
         global [ nl nl nl "Starting to parse .tar..." print flush ] bind
         global [ "Expanding to: " write base-dir get . flush ] bind
         (parse-tar)
-    ] with-stream ;
+    ] with-file-out ;
-

extra/tools/browser/browser-tests.factor

@@ -1,6 +1,4 @@
 IN: temporary
 USING: tools.browser tools.test help.markup ;
 
-[ t ] [ "resource:core" "kernel" vocab-dir? ] unit-test
-
 [ ] [ { $describe-vocab "scratchpad" } print-content ] unit-test

extra/tools/browser/browser.factor

@@ -10,7 +10,7 @@ IN: tools.browser
 
 MEMO: (vocab-file-contents) ( path -- lines )
     ?resource-path dup exists?
-    [ <file-reader> lines ] [ drop f ] if ;
+    [ file-lines ] [ drop f ] if ;
 
 : vocab-file-contents ( vocab name -- seq )
     vocab-path+ dup [ (vocab-file-contents) ] when ;
@@ -18,7 +18,7 @@ MEMO: (vocab-file-contents) ( path -- lines )
 : set-vocab-file-contents ( seq vocab name -- )
     dupd vocab-path+ [
         ?resource-path
-        <file-writer> [ [ print ] each ] with-stream
+        [ [ print ] each ] with-file-out
     ] [
         "The " swap vocab-name
         " vocabulary was not loaded from the file system"
@@ -72,13 +72,6 @@ M: vocab-link summary vocab-summary ;
 : set-vocab-authors ( authors vocab -- )
     dup vocab-authors-path set-vocab-file-contents ;
 
-: vocab-dir? ( root name -- ? )
-    over [
-        vocab-source path+ ?resource-path exists?
-    ] [
-        2drop f
-    ] if ;
-
 : subdirs ( dir -- dirs )
     directory [ second ] subset keys natural-sort ;
 
@@ -96,10 +89,8 @@ M: vocab-link summary vocab-summary ;
         vocabs-in-dir
     ] with each ;
 
-: sane-vocab-roots "." vocab-roots get remove ;
-
 : all-vocabs ( -- assoc )
-    sane-vocab-roots [
+    vocab-roots get [
         dup [ "" vocabs-in-dir ] { } make
     ] { } map>assoc ;
 
@@ -153,9 +144,9 @@ MEMO: all-vocabs-seq ( -- seq )
     [ vocab ] map ;
 
 : all-child-vocabs ( prefix -- assoc )
-    sane-vocab-roots [
+    vocab-roots get [
-        dup pick dupd (all-child-vocabs)
+        over dupd dupd (all-child-vocabs)
-        [ swap >vocab-link ] with map
+        swap [ >vocab-link ] curry map
     ] { } map>assoc
     f rot unrooted-child-vocabs 2array add ;
 

extra/tools/interpreter/interpreter-tests.factor

@@ -98,6 +98,9 @@ IN: temporary
 [ { 6 } ]
 [ [ [ 3 swap continue-with ] callcc1 2 * ] test-interpreter ] unit-test
 
+[ { } ]
+[ [ [ ] [ ] recover ] test-interpreter ] unit-test
+
 [ { 6 } ]
 [ [ [ 3 throw ] [ 2 * ] recover ] test-interpreter ] unit-test
 

extra/tools/interpreter/interpreter.factor

@@ -1,6 +1,6 @@
 ! Copyright (C) 2004, 2007 Slava Pestov.
 ! See http://factorcode.org/license.txt for BSD license.
-USING: arrays assocs classes combinators combinators.private
+USING: arrays assocs classes combinators sequences.private
 continuations continuations.private generic hashtables io kernel
 kernel.private math namespaces namespaces.private prettyprint
 quotations sequences splitting strings threads vectors words ;
@@ -55,7 +55,7 @@ M: word (step-into) (step-into-execute) ;
 
 {
     { call [ walk ] }
-    { (throw) [ walk ] }
+    { (throw) [ drop walk ] }
     { execute [ (step-into-execute) ] }
     { if [ (step-into-if) ] }
     { dispatch [ (step-into-dispatch) ] }

extra/tools/test/test-docs.factor

@@ -36,7 +36,12 @@ ARTICLE: "tools.test" "Unit testing"
 $nl
 "For example, if you were developing a word for computing symbolic derivatives, your unit tests would apply the word to certain input functions, comparing the results against the correct values. While the passing of these tests would not guarantee the algorithm is correct, it would at least ensure that what used to work keeps working, in that as soon as something breaks due to a change in another part of your program, failing tests will let you know."
 $nl
-"Unit tests for a vocabulary are placed in test files, named " { $snippet { $emphasis "vocab" } "-tests.factor" } " alongside " { $snippet { $emphasis "vocab" } ".factor" } "; see " { $link "vocabs.loader" } " for details."
+"Unit tests for a vocabulary are placed in test files in the same directory as the vocabulary source file (see " { $link "vocabs.loader" } "). Two possibilities are supported:"
+{ $list
+    { "Tests can be placed in a file named " { $snippet { $emphasis "vocab" } "-tests.factor" } "." }
+    { "Tests can be placed in files in the " { $snippet "tests" } " subdirectory." }
+}
+"The latter is used for vocabularies with more extensive test suites."
 $nl
 "If the test harness needs to define words, they should be placed in the " { $snippet "temporary" } " vocabulary so that they can be forgotten after the tests have been run."
 { $subsection "tools.test.write" }