First class compose, curry is now a tuple class

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/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/inference/known-words/known-words.factor

@@ -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,460 @@ 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 -- )
+    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/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,8 +17,7 @@ IN: kernel
 : clear ( -- ) { } set-datastack ;
 
 ! Combinators
-
+GENERIC: call ( callable -- )
-: call ( callable -- ) uncurry (call) ;
 
 DEFER: if
 
@@ -71,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
@@ -82,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
 
@@ -156,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/known-words/known-words.factor

@@ -19,6 +19,11 @@ float-arrays sequences.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) } [
     [

core/prettyprint/backend/backend.factor

@@ -135,6 +135,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 +157,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.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/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.factor

@@ -71,7 +71,8 @@ M: vocab-link vocab-root
 
 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" ;
 

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/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

@@ -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) ] }

vm/alien.c

@@ -59,7 +59,16 @@ CELL allot_alien(CELL delegate, CELL displacement)
 	REGISTER_ROOT(delegate);
 	F_ALIEN *alien = allot_object(ALIEN_TYPE,sizeof(F_ALIEN));
 	UNREGISTER_ROOT(delegate);
-	alien->alien = delegate;
+
+	if(type_of(delegate) == ALIEN_TYPE)
+	{
+		F_ALIEN *delegate_alien = untag_object(delegate);
+		displacement += delegate_alien->displacement;
+		alien->alien = F;
+	}
+	else
+		alien->alien = delegate;
+
 	alien->displacement = displacement;
 	alien->expired = F;
 	return tag_object(alien);

vm/data_gc.c

@@ -189,8 +189,6 @@ CELL unaligned_object_size(CELL pointer)
 		return sizeof(F_ALIEN);
 	case WRAPPER_TYPE:
 		return sizeof(F_WRAPPER);
-	case CURRY_TYPE:
-		return sizeof(F_CURRY);
 	case CALLSTACK_TYPE:
 		return callstack_size(
 			untag_fixnum_fast(((F_CALLSTACK *)pointer)->length));

vm/errors.c

@@ -137,12 +137,11 @@ void misc_signal_handler_impl(void)
 
 DEFINE_PRIMITIVE(throw)
 {
-	uncurry(dpop());
+	dpop();
 	throw_impl(dpop(),stack_chain->callstack_top);
 }
 
 DEFINE_PRIMITIVE(call_clear)
 {
-	uncurry(dpop());
 	throw_impl(dpop(),stack_chain->callstack_bottom);
 }

vm/layouts.h

@@ -52,15 +52,14 @@ typedef signed long long s64;
 #define FLOAT_ARRAY_TYPE 10
 #define CALLSTACK_TYPE 11
 #define STRING_TYPE 12
-#define CURRY_TYPE 13
+#define BIT_ARRAY_TYPE 13
 #define QUOTATION_TYPE 14
 #define DLL_TYPE 15
 #define ALIEN_TYPE 16
 #define WORD_TYPE 17
 #define BYTE_ARRAY_TYPE 18
-#define BIT_ARRAY_TYPE 19
 
-#define TYPE_COUNT 20
+#define TYPE_COUNT 19
 
 INLINE bool immediate_p(CELL obj)
 {

vm/primitives.c

@@ -3,7 +3,6 @@
 void *primitives[] = {
 	primitive_execute,
 	primitive_call,
-	primitive_uncurry,
 	primitive_bignum_to_fixnum,
 	primitive_float_to_fixnum,
 	primitive_fixnum_to_bignum,
@@ -178,7 +177,6 @@ void *primitives[] = {
 	primitive_become,
 	primitive_sleep,
 	primitive_float_array,
-	primitive_curry,
 	primitive_tuple_boa,
 	primitive_class_hash,
 	primitive_callstack_to_array,

vm/quotations.c

@@ -350,50 +350,6 @@ F_FASTCALL CELL primitive_jit_compile(CELL quot, F_STACK_FRAME *stack)
 	return quot;
 }
 
-DEFINE_PRIMITIVE(curry)
-{
-	F_CURRY *curry;
-
-	switch(type_of(dpeek()))
-	{
-	case QUOTATION_TYPE:
-	case CURRY_TYPE:
-		curry = allot_object(CURRY_TYPE,sizeof(F_CURRY));
-		curry->quot = dpop();
-		curry->obj = dpop();
-		dpush(tag_object(curry));
-		break;
-	default:
-		type_error(QUOTATION_TYPE,dpeek());
-		break;
-	}
-}
-
-void uncurry(CELL obj)
-{
-	F_CURRY *curry;
-
-	switch(type_of(obj))
-	{
-	case QUOTATION_TYPE:
-		dpush(obj);
-		break;
-	case CURRY_TYPE:
-		curry = untag_object(obj);
-		dpush(curry->obj);
-		uncurry(curry->quot);
-		break;
-	default:
-		type_error(QUOTATION_TYPE,obj);
-		break;
-	}
-}
-
-DEFINE_PRIMITIVE(uncurry)
-{
-	uncurry(dpop());
-}
-
 /* push a new quotation on the stack */
 DEFINE_PRIMITIVE(array_to_quotation)
 {

vm/quotations.h

@@ -2,8 +2,5 @@ void set_quot_xt(F_QUOTATION *quot, F_COMPILED *code);
 void jit_compile(CELL quot, bool relocate);
 F_FASTCALL CELL primitive_jit_compile(CELL quot, F_STACK_FRAME *stack);
 F_FIXNUM quot_code_offset_to_scan(CELL quot, F_FIXNUM offset);
-void uncurry(CELL obj);
-DECLARE_PRIMITIVE(curry);
 DECLARE_PRIMITIVE(array_to_quotation);
 DECLARE_PRIMITIVE(quotation_xt);
-DECLARE_PRIMITIVE(uncurry);