From 98d8621ac1997b104809cabb66b4b3effe9ea2d4 Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Mon, 11 Feb 2008 13:50:29 -0600 Subject: [PATCH] First class compose, curry is now a tuple class --- core/bootstrap/layouts/layouts.factor | 7 +- core/bootstrap/primitives.factor | 52 ++- core/continuations/continuations.factor | 2 +- core/inference/known-words/known-words.factor | 345 +++++++++--------- core/inference/transforms/transforms.factor | 2 - core/kernel/kernel-docs.factor | 2 +- core/kernel/kernel.factor | 15 +- core/optimizer/known-words/known-words.factor | 5 + core/prettyprint/backend/backend.factor | 3 + core/quotations/quotations.factor | 30 +- core/threads/threads.factor | 2 +- core/vocabs/loader/loader.factor | 3 +- core/words/words.factor | 2 +- .../interpreter/interpreter-tests.factor | 3 + extra/tools/interpreter/interpreter.factor | 2 +- vm/alien.c | 11 +- vm/data_gc.c | 2 - vm/errors.c | 3 +- vm/layouts.h | 5 +- vm/primitives.c | 2 - vm/quotations.c | 44 --- vm/quotations.h | 3 - 22 files changed, 270 insertions(+), 275 deletions(-) mode change 100644 => 100755 core/threads/threads.factor mode change 100644 => 100755 extra/tools/interpreter/interpreter-tests.factor diff --git a/core/bootstrap/layouts/layouts.factor b/core/bootstrap/layouts/layouts.factor index 9c0d6b9838..e15a7b4d7c 100755 --- a/core/bootstrap/layouts/layouts.factor +++ b/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 diff --git a/core/bootstrap/primitives.factor b/core/bootstrap/primitives.factor index 967840a3dc..66ede8b054 100755 --- a/core/bootstrap/primitives.factor +++ b/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-arrays" } - { "curry" "kernel" } { "" "tuples.private" } { "class-hash" "kernel.private" } { "callstack>array" "kernel" } diff --git a/core/continuations/continuations.factor b/core/continuations/continuations.factor index b6ca056691..81f78f491d 100755 --- a/core/continuations/continuations.factor +++ b/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 ; diff --git a/core/inference/known-words/known-words.factor b/core/inference/known-words/known-words.factor index a1887e206b..f92987f15f 100755 --- a/core/inference/known-words/known-words.factor +++ b/core/inference/known-words/known-words.factor @@ -126,15 +126,11 @@ M: object infer-call pop-d pop-d swap push-d ] "infer" set-word-prop -\ curry { object object } { curry } "inferred-effect" set-word-prop - \ compose [ 2 ensure-values pop-d pop-d swap push-d ] "infer" set-word-prop -\ compose { object object } { curry } "inferred-effect" set-word-prop - ! Variadic tuple constructor \ [ \ @@ -142,457 +138,460 @@ M: object infer-call make-call-node ] "infer" set-word-prop -! We need this for default-output-classes -\ 2 { tuple } "inferred-effect" set-word-prop - ! Non-standard control flow -\ (throw) { callable } { } -t over set-effect-terminated? -"inferred-effect" set-word-prop +\ (throw) [ + \ (throw) + peek-d value-literal 2 + { } + 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 } "inferred-effect" set-word-prop +\ fixnum< { fixnum fixnum } { object } set-primitive-effect \ fixnum< make-foldable -\ fixnum<= { fixnum fixnum } { object } "inferred-effect" set-word-prop +\ fixnum<= { fixnum fixnum } { object } set-primitive-effect \ fixnum<= make-foldable -\ fixnum> { fixnum fixnum } { object } "inferred-effect" set-word-prop +\ fixnum> { fixnum fixnum } { object } set-primitive-effect \ fixnum> make-foldable -\ fixnum>= { fixnum fixnum } { object } "inferred-effect" set-word-prop +\ fixnum>= { fixnum fixnum } { object } set-primitive-effect \ fixnum>= make-foldable -\ eq? { object object } { object } "inferred-effect" set-word-prop +\ eq? { object object } { object } set-primitive-effect \ eq? make-foldable -\ rehash-string { string } { } "inferred-effect" set-word-prop +\ rehash-string { string } { } set-primitive-effect -\ bignum>fixnum { bignum } { fixnum } "inferred-effect" set-word-prop +\ bignum>fixnum { bignum } { fixnum } set-primitive-effect \ bignum>fixnum make-foldable -\ float>fixnum { float } { fixnum } "inferred-effect" set-word-prop +\ float>fixnum { float } { fixnum } set-primitive-effect \ bignum>fixnum make-foldable -\ fixnum>bignum { fixnum } { bignum } "inferred-effect" set-word-prop +\ fixnum>bignum { fixnum } { bignum } set-primitive-effect \ fixnum>bignum make-foldable -\ float>bignum { float } { bignum } "inferred-effect" set-word-prop +\ float>bignum { float } { bignum } set-primitive-effect \ float>bignum make-foldable -\ fixnum>float { fixnum } { float } "inferred-effect" set-word-prop +\ fixnum>float { fixnum } { float } set-primitive-effect \ fixnum>float make-foldable -\ bignum>float { bignum } { float } "inferred-effect" set-word-prop +\ bignum>float { bignum } { float } set-primitive-effect \ bignum>float make-foldable -\ { integer integer } { ratio } "inferred-effect" set-word-prop +\ { integer integer } { ratio } set-primitive-effect \ make-foldable -\ string>float { string } { float } "inferred-effect" set-word-prop +\ string>float { string } { float } set-primitive-effect \ string>float make-foldable -\ float>string { float } { string } "inferred-effect" set-word-prop +\ float>string { float } { string } set-primitive-effect \ float>string make-foldable -\ float>bits { real } { integer } "inferred-effect" set-word-prop +\ float>bits { real } { integer } set-primitive-effect \ float>bits make-foldable -\ double>bits { real } { integer } "inferred-effect" set-word-prop +\ double>bits { real } { integer } set-primitive-effect \ double>bits make-foldable -\ bits>float { integer } { float } "inferred-effect" set-word-prop +\ bits>float { integer } { float } set-primitive-effect \ bits>float make-foldable -\ bits>double { integer } { float } "inferred-effect" set-word-prop +\ bits>double { integer } { float } set-primitive-effect \ bits>double make-foldable -\ { real real } { complex } "inferred-effect" set-word-prop +\ { real real } { complex } set-primitive-effect \ make-foldable -\ fixnum+ { fixnum fixnum } { integer } "inferred-effect" set-word-prop +\ fixnum+ { fixnum fixnum } { integer } set-primitive-effect \ fixnum+ make-foldable -\ fixnum+fast { fixnum fixnum } { fixnum } "inferred-effect" set-word-prop +\ fixnum+fast { fixnum fixnum } { fixnum } set-primitive-effect \ fixnum+fast make-foldable -\ fixnum- { fixnum fixnum } { integer } "inferred-effect" set-word-prop +\ fixnum- { fixnum fixnum } { integer } set-primitive-effect \ fixnum- make-foldable -\ fixnum-fast { fixnum fixnum } { fixnum } "inferred-effect" set-word-prop +\ fixnum-fast { fixnum fixnum } { fixnum } set-primitive-effect \ fixnum-fast make-foldable -\ fixnum* { fixnum fixnum } { integer } "inferred-effect" set-word-prop +\ fixnum* { fixnum fixnum } { integer } set-primitive-effect \ fixnum* make-foldable -\ fixnum*fast { fixnum fixnum } { fixnum } "inferred-effect" set-word-prop +\ fixnum*fast { fixnum fixnum } { fixnum } set-primitive-effect \ fixnum*fast make-foldable -\ fixnum/i { fixnum fixnum } { integer } "inferred-effect" set-word-prop +\ fixnum/i { fixnum fixnum } { integer } set-primitive-effect \ fixnum/i make-foldable -\ fixnum-mod { fixnum fixnum } { fixnum } "inferred-effect" set-word-prop +\ fixnum-mod { fixnum fixnum } { fixnum } set-primitive-effect \ fixnum-mod make-foldable -\ fixnum/mod { fixnum fixnum } { integer fixnum } "inferred-effect" set-word-prop +\ fixnum/mod { fixnum fixnum } { integer fixnum } set-primitive-effect \ fixnum/mod make-foldable -\ fixnum-bitand { fixnum fixnum } { fixnum } "inferred-effect" set-word-prop +\ fixnum-bitand { fixnum fixnum } { fixnum } set-primitive-effect \ fixnum-bitand make-foldable -\ fixnum-bitor { fixnum fixnum } { fixnum } "inferred-effect" set-word-prop +\ fixnum-bitor { fixnum fixnum } { fixnum } set-primitive-effect \ fixnum-bitor make-foldable -\ fixnum-bitxor { fixnum fixnum } { fixnum } "inferred-effect" set-word-prop +\ fixnum-bitxor { fixnum fixnum } { fixnum } set-primitive-effect \ fixnum-bitxor make-foldable -\ fixnum-bitnot { fixnum } { fixnum } "inferred-effect" set-word-prop +\ fixnum-bitnot { fixnum } { fixnum } set-primitive-effect \ fixnum-bitnot make-foldable -\ fixnum-shift { fixnum fixnum } { integer } "inferred-effect" set-word-prop +\ fixnum-shift { fixnum fixnum } { integer } set-primitive-effect \ fixnum-shift make-foldable -\ fixnum-shift-fast { fixnum fixnum } { fixnum } "inferred-effect" set-word-prop +\ fixnum-shift-fast { fixnum fixnum } { fixnum } set-primitive-effect \ fixnum-shift-fast make-foldable -\ bignum= { bignum bignum } { object } "inferred-effect" set-word-prop +\ bignum= { bignum bignum } { object } set-primitive-effect \ bignum= make-foldable -\ bignum+ { bignum bignum } { bignum } "inferred-effect" set-word-prop +\ bignum+ { bignum bignum } { bignum } set-primitive-effect \ bignum+ make-foldable -\ bignum- { bignum bignum } { bignum } "inferred-effect" set-word-prop +\ bignum- { bignum bignum } { bignum } set-primitive-effect \ bignum- make-foldable -\ bignum* { bignum bignum } { bignum } "inferred-effect" set-word-prop +\ bignum* { bignum bignum } { bignum } set-primitive-effect \ bignum* make-foldable -\ bignum/i { bignum bignum } { bignum } "inferred-effect" set-word-prop +\ bignum/i { bignum bignum } { bignum } set-primitive-effect \ bignum/i make-foldable -\ bignum-mod { bignum bignum } { bignum } "inferred-effect" set-word-prop +\ bignum-mod { bignum bignum } { bignum } set-primitive-effect \ bignum-mod make-foldable -\ bignum/mod { bignum bignum } { bignum bignum } "inferred-effect" set-word-prop +\ bignum/mod { bignum bignum } { bignum bignum } set-primitive-effect \ bignum/mod make-foldable -\ bignum-bitand { bignum bignum } { bignum } "inferred-effect" set-word-prop +\ bignum-bitand { bignum bignum } { bignum } set-primitive-effect \ bignum-bitand make-foldable -\ bignum-bitor { bignum bignum } { bignum } "inferred-effect" set-word-prop +\ bignum-bitor { bignum bignum } { bignum } set-primitive-effect \ bignum-bitor make-foldable -\ bignum-bitxor { bignum bignum } { bignum } "inferred-effect" set-word-prop +\ bignum-bitxor { bignum bignum } { bignum } set-primitive-effect \ bignum-bitxor make-foldable -\ bignum-bitnot { bignum } { bignum } "inferred-effect" set-word-prop +\ bignum-bitnot { bignum } { bignum } set-primitive-effect \ bignum-bitnot make-foldable -\ bignum-shift { bignum bignum } { bignum } "inferred-effect" set-word-prop +\ bignum-shift { bignum bignum } { bignum } set-primitive-effect \ bignum-shift make-foldable -\ bignum< { bignum bignum } { object } "inferred-effect" set-word-prop +\ bignum< { bignum bignum } { object } set-primitive-effect \ bignum< make-foldable -\ bignum<= { bignum bignum } { object } "inferred-effect" set-word-prop +\ bignum<= { bignum bignum } { object } set-primitive-effect \ bignum<= make-foldable -\ bignum> { bignum bignum } { object } "inferred-effect" set-word-prop +\ bignum> { bignum bignum } { object } set-primitive-effect \ bignum> make-foldable -\ bignum>= { bignum bignum } { object } "inferred-effect" set-word-prop +\ bignum>= { bignum bignum } { object } set-primitive-effect \ bignum>= make-foldable -\ bignum-bit? { bignum integer } { object } "inferred-effect" set-word-prop +\ bignum-bit? { bignum integer } { object } set-primitive-effect \ bignum-bit? make-foldable -\ bignum-log2 { bignum } { bignum } "inferred-effect" set-word-prop +\ bignum-log2 { bignum } { bignum } set-primitive-effect \ bignum-log2 make-foldable -\ byte-array>bignum { byte-array } { bignum } "inferred-effect" set-word-prop +\ byte-array>bignum { byte-array } { bignum } set-primitive-effect \ byte-array>bignum make-foldable -\ float= { float float } { object } "inferred-effect" set-word-prop +\ float= { float float } { object } set-primitive-effect \ float= make-foldable -\ float+ { float float } { float } "inferred-effect" set-word-prop +\ float+ { float float } { float } set-primitive-effect \ float+ make-foldable -\ float- { float float } { float } "inferred-effect" set-word-prop +\ float- { float float } { float } set-primitive-effect \ float- make-foldable -\ float* { float float } { float } "inferred-effect" set-word-prop +\ float* { float float } { float } set-primitive-effect \ float* make-foldable -\ float/f { float float } { float } "inferred-effect" set-word-prop +\ float/f { float float } { float } set-primitive-effect \ float/f make-foldable -\ float< { float float } { object } "inferred-effect" set-word-prop +\ float< { float float } { object } set-primitive-effect \ float< make-foldable -\ float-mod { float float } { float } "inferred-effect" set-word-prop +\ float-mod { float float } { float } set-primitive-effect \ float-mod make-foldable -\ float<= { float float } { object } "inferred-effect" set-word-prop +\ float<= { float float } { object } set-primitive-effect \ float<= make-foldable -\ float> { float float } { object } "inferred-effect" set-word-prop +\ float> { float float } { object } set-primitive-effect \ float> make-foldable -\ float>= { float float } { object } "inferred-effect" set-word-prop +\ float>= { float float } { object } set-primitive-effect \ float>= make-foldable -\ { object object } { word } "inferred-effect" set-word-prop +\ { object object } { word } set-primitive-effect \ make-flushable -\ word-xt { word } { integer } "inferred-effect" set-word-prop +\ word-xt { word } { integer } set-primitive-effect \ word-xt make-flushable -\ getenv { fixnum } { object } "inferred-effect" set-word-prop +\ getenv { fixnum } { object } set-primitive-effect \ getenv make-flushable -\ setenv { object fixnum } { } "inferred-effect" set-word-prop +\ setenv { object fixnum } { } set-primitive-effect -\ (stat) { string } { object object object object } "inferred-effect" set-word-prop +\ (stat) { string } { object object object object } set-primitive-effect -\ (directory) { string } { array } "inferred-effect" set-word-prop +\ (directory) { string } { array } set-primitive-effect -\ data-gc { } { } "inferred-effect" set-word-prop +\ data-gc { } { } set-primitive-effect -\ code-gc { } { } "inferred-effect" set-word-prop +\ code-gc { } { } set-primitive-effect -\ gc-time { } { integer } "inferred-effect" set-word-prop +\ gc-time { } { integer } set-primitive-effect -\ save-image { string } { } "inferred-effect" set-word-prop +\ save-image { string } { } set-primitive-effect -\ save-image-and-exit { string } { } "inferred-effect" set-word-prop +\ save-image-and-exit { string } { } set-primitive-effect \ exit { integer } { } t over set-effect-terminated? -"inferred-effect" set-word-prop +set-primitive-effect -\ data-room { } { integer array } "inferred-effect" set-word-prop +\ data-room { } { integer array } set-primitive-effect \ data-room make-flushable -\ code-room { } { integer integer } "inferred-effect" set-word-prop +\ code-room { } { integer integer } set-primitive-effect \ code-room make-flushable -\ os-env { string } { object } "inferred-effect" set-word-prop +\ os-env { string } { object } set-primitive-effect -\ millis { } { integer } "inferred-effect" set-word-prop +\ millis { } { integer } set-primitive-effect \ millis make-flushable -\ type { object } { fixnum } "inferred-effect" set-word-prop +\ type { object } { fixnum } set-primitive-effect \ type make-foldable -\ tag { object } { fixnum } "inferred-effect" set-word-prop +\ tag { object } { fixnum } set-primitive-effect \ tag make-foldable -\ class-hash { object } { fixnum } "inferred-effect" set-word-prop +\ class-hash { object } { fixnum } set-primitive-effect \ class-hash make-foldable -\ cwd { } { string } "inferred-effect" set-word-prop +\ cwd { } { string } set-primitive-effect -\ cd { string } { } "inferred-effect" set-word-prop +\ cd { string } { } set-primitive-effect -\ dlopen { string } { dll } "inferred-effect" set-word-prop +\ dlopen { string } { dll } set-primitive-effect -\ dlsym { string object } { c-ptr } "inferred-effect" set-word-prop +\ dlsym { string object } { c-ptr } set-primitive-effect -\ dlclose { dll } { } "inferred-effect" set-word-prop +\ dlclose { dll } { } set-primitive-effect -\ { integer } { byte-array } "inferred-effect" set-word-prop +\ { integer } { byte-array } set-primitive-effect \ make-flushable -\ { integer } { bit-array } "inferred-effect" set-word-prop +\ { integer } { bit-array } set-primitive-effect \ make-flushable -\ { integer float } { float-array } "inferred-effect" set-word-prop +\ { integer float } { float-array } set-primitive-effect \ make-flushable -\ { integer c-ptr } { c-ptr } "inferred-effect" set-word-prop +\ { integer c-ptr } { c-ptr } set-primitive-effect \ make-flushable -\ alien-signed-cell { c-ptr integer } { integer } "inferred-effect" set-word-prop +\ alien-signed-cell { c-ptr integer } { integer } set-primitive-effect \ alien-signed-cell make-flushable -\ set-alien-signed-cell { integer c-ptr integer } { } "inferred-effect" set-word-prop +\ set-alien-signed-cell { integer c-ptr integer } { } set-primitive-effect -\ alien-unsigned-cell { c-ptr integer } { integer } "inferred-effect" set-word-prop +\ alien-unsigned-cell { c-ptr integer } { integer } set-primitive-effect \ alien-unsigned-cell make-flushable -\ set-alien-unsigned-cell { integer c-ptr integer } { } "inferred-effect" set-word-prop +\ set-alien-unsigned-cell { integer c-ptr integer } { } set-primitive-effect -\ alien-signed-8 { c-ptr integer } { integer } "inferred-effect" set-word-prop +\ alien-signed-8 { c-ptr integer } { integer } set-primitive-effect \ alien-signed-8 make-flushable -\ set-alien-signed-8 { integer c-ptr integer } { } "inferred-effect" set-word-prop +\ set-alien-signed-8 { integer c-ptr integer } { } set-primitive-effect -\ alien-unsigned-8 { c-ptr integer } { integer } "inferred-effect" set-word-prop +\ alien-unsigned-8 { c-ptr integer } { integer } set-primitive-effect \ alien-unsigned-8 make-flushable -\ set-alien-unsigned-8 { integer c-ptr integer } { } "inferred-effect" set-word-prop +\ set-alien-unsigned-8 { integer c-ptr integer } { } set-primitive-effect -\ alien-signed-4 { c-ptr integer } { integer } "inferred-effect" set-word-prop +\ alien-signed-4 { c-ptr integer } { integer } set-primitive-effect \ alien-signed-4 make-flushable -\ set-alien-signed-4 { integer c-ptr integer } { } "inferred-effect" set-word-prop +\ set-alien-signed-4 { integer c-ptr integer } { } set-primitive-effect -\ alien-unsigned-4 { c-ptr integer } { integer } "inferred-effect" set-word-prop +\ alien-unsigned-4 { c-ptr integer } { integer } set-primitive-effect \ alien-unsigned-4 make-flushable -\ set-alien-unsigned-4 { integer c-ptr integer } { } "inferred-effect" set-word-prop +\ set-alien-unsigned-4 { integer c-ptr integer } { } set-primitive-effect -\ alien-signed-2 { c-ptr integer } { fixnum } "inferred-effect" set-word-prop +\ alien-signed-2 { c-ptr integer } { fixnum } set-primitive-effect \ alien-signed-2 make-flushable -\ set-alien-signed-2 { integer c-ptr integer } { } "inferred-effect" set-word-prop +\ set-alien-signed-2 { integer c-ptr integer } { } set-primitive-effect -\ alien-unsigned-2 { c-ptr integer } { fixnum } "inferred-effect" set-word-prop +\ alien-unsigned-2 { c-ptr integer } { fixnum } set-primitive-effect \ alien-unsigned-2 make-flushable -\ set-alien-unsigned-2 { integer c-ptr integer } { } "inferred-effect" set-word-prop +\ set-alien-unsigned-2 { integer c-ptr integer } { } set-primitive-effect -\ alien-signed-1 { c-ptr integer } { fixnum } "inferred-effect" set-word-prop +\ alien-signed-1 { c-ptr integer } { fixnum } set-primitive-effect \ alien-signed-1 make-flushable -\ set-alien-signed-1 { integer c-ptr integer } { } "inferred-effect" set-word-prop +\ set-alien-signed-1 { integer c-ptr integer } { } set-primitive-effect -\ alien-unsigned-1 { c-ptr integer } { fixnum } "inferred-effect" set-word-prop +\ alien-unsigned-1 { c-ptr integer } { fixnum } set-primitive-effect \ alien-unsigned-1 make-flushable -\ set-alien-unsigned-1 { integer c-ptr integer } { } "inferred-effect" set-word-prop +\ set-alien-unsigned-1 { integer c-ptr integer } { } set-primitive-effect -\ alien-float { c-ptr integer } { float } "inferred-effect" set-word-prop +\ alien-float { c-ptr integer } { float } set-primitive-effect \ alien-float make-flushable -\ set-alien-float { float c-ptr integer } { } "inferred-effect" set-word-prop +\ set-alien-float { float c-ptr integer } { } set-primitive-effect -\ alien-double { c-ptr integer } { float } "inferred-effect" set-word-prop +\ alien-double { c-ptr integer } { float } set-primitive-effect \ alien-double make-flushable -\ set-alien-double { float c-ptr integer } { } "inferred-effect" set-word-prop +\ set-alien-double { float c-ptr integer } { } set-primitive-effect -\ alien-cell { c-ptr integer } { simple-c-ptr } "inferred-effect" set-word-prop +\ alien-cell { c-ptr integer } { simple-c-ptr } set-primitive-effect \ alien-cell make-flushable -\ set-alien-cell { c-ptr c-ptr integer } { } "inferred-effect" set-word-prop +\ set-alien-cell { c-ptr c-ptr integer } { } set-primitive-effect -\ alien>char-string { c-ptr } { string } "inferred-effect" set-word-prop +\ alien>char-string { c-ptr } { string } set-primitive-effect \ alien>char-string make-flushable -\ string>char-alien { string } { byte-array } "inferred-effect" set-word-prop +\ string>char-alien { string } { byte-array } set-primitive-effect \ string>char-alien make-flushable -\ alien>u16-string { c-ptr } { string } "inferred-effect" set-word-prop +\ alien>u16-string { c-ptr } { string } set-primitive-effect \ alien>u16-string make-flushable -\ string>u16-alien { string } { byte-array } "inferred-effect" set-word-prop +\ string>u16-alien { string } { byte-array } set-primitive-effect \ string>u16-alien make-flushable -\ alien-address { alien } { integer } "inferred-effect" set-word-prop +\ alien-address { alien } { integer } set-primitive-effect \ alien-address make-flushable -\ slot { object fixnum } { object } "inferred-effect" set-word-prop +\ slot { object fixnum } { object } set-primitive-effect \ slot make-flushable -\ set-slot { object object fixnum } { } "inferred-effect" set-word-prop +\ set-slot { object object fixnum } { } set-primitive-effect -\ string-nth { fixnum string } { fixnum } "inferred-effect" set-word-prop +\ string-nth { fixnum string } { fixnum } set-primitive-effect \ string-nth make-flushable -\ set-string-nth { fixnum fixnum string } { } "inferred-effect" set-word-prop +\ set-string-nth { fixnum fixnum string } { } set-primitive-effect -\ resize-array { integer array } { array } "inferred-effect" set-word-prop +\ resize-array { integer array } { array } set-primitive-effect \ resize-array make-flushable -\ resize-byte-array { integer byte-array } { byte-array } "inferred-effect" set-word-prop +\ resize-byte-array { integer byte-array } { byte-array } set-primitive-effect \ resize-byte-array make-flushable -\ resize-bit-array { integer bit-array } { bit-array } "inferred-effect" set-word-prop +\ resize-bit-array { integer bit-array } { bit-array } set-primitive-effect \ resize-bit-array make-flushable -\ resize-float-array { integer float-array } { float-array } "inferred-effect" set-word-prop +\ resize-float-array { integer float-array } { float-array } set-primitive-effect \ resize-float-array make-flushable -\ resize-string { integer string } { string } "inferred-effect" set-word-prop +\ resize-string { integer string } { string } set-primitive-effect \ resize-string make-flushable -\ { integer object } { array } "inferred-effect" set-word-prop +\ { integer object } { array } set-primitive-effect \ make-flushable -\ begin-scan { } { } "inferred-effect" set-word-prop +\ begin-scan { } { } set-primitive-effect -\ next-object { } { object } "inferred-effect" set-word-prop +\ next-object { } { object } set-primitive-effect -\ end-scan { } { } "inferred-effect" set-word-prop +\ end-scan { } { } set-primitive-effect -\ size { object } { fixnum } "inferred-effect" set-word-prop +\ size { object } { fixnum } set-primitive-effect \ size make-flushable -\ die { } { } "inferred-effect" set-word-prop +\ die { } { } set-primitive-effect -\ fopen { string string } { alien } "inferred-effect" set-word-prop +\ fopen { string string } { alien } set-primitive-effect -\ fgetc { alien } { object } "inferred-effect" set-word-prop +\ fgetc { alien } { object } set-primitive-effect -\ fwrite { string alien } { } "inferred-effect" set-word-prop +\ fwrite { string alien } { } set-primitive-effect -\ fread { integer string } { object } "inferred-effect" set-word-prop +\ fread { integer string } { object } set-primitive-effect -\ fflush { alien } { } "inferred-effect" set-word-prop +\ fflush { alien } { } set-primitive-effect -\ fclose { alien } { } "inferred-effect" set-word-prop +\ fclose { alien } { } set-primitive-effect -\ expired? { object } { object } "inferred-effect" set-word-prop +\ expired? { object } { object } set-primitive-effect \ expired? make-flushable -\ { object } { wrapper } "inferred-effect" set-word-prop +\ { object } { wrapper } set-primitive-effect \ make-foldable -\ (clone) { object } { object } "inferred-effect" set-word-prop +\ (clone) { object } { object } set-primitive-effect \ (clone) make-flushable -\ { integer integer } { string } "inferred-effect" set-word-prop +\ { integer integer } { string } set-primitive-effect \ make-flushable -\ array>quotation { array } { quotation } "inferred-effect" set-word-prop +\ array>quotation { array } { quotation } set-primitive-effect \ array>quotation make-flushable -\ quotation-xt { quotation } { integer } "inferred-effect" set-word-prop +\ quotation-xt { quotation } { integer } set-primitive-effect \ quotation-xt make-flushable -\ { word integer } { quotation } "inferred-effect" set-word-prop +\ { word integer } { quotation } set-primitive-effect \ make-flushable -\ (>tuple) { array } { tuple } "inferred-effect" set-word-prop +\ (>tuple) { array } { tuple } set-primitive-effect \ (>tuple) make-flushable -\ tuple>array { tuple } { array } "inferred-effect" set-word-prop +\ tuple>array { tuple } { array } set-primitive-effect \ tuple>array make-flushable -\ datastack { } { array } "inferred-effect" set-word-prop +\ datastack { } { array } set-primitive-effect \ datastack make-flushable -\ retainstack { } { array } "inferred-effect" set-word-prop +\ retainstack { } { array } set-primitive-effect \ retainstack make-flushable -\ callstack { } { callstack } "inferred-effect" set-word-prop +\ callstack { } { callstack } set-primitive-effect \ callstack make-flushable -\ callstack>array { callstack } { array } "inferred-effect" set-word-prop +\ callstack>array { callstack } { array } set-primitive-effect \ callstack>array make-flushable -\ (sleep) { integer } { } "inferred-effect" set-word-prop +\ (sleep) { integer } { } set-primitive-effect -\ become { array array } { } "inferred-effect" set-word-prop +\ become { array array } { } set-primitive-effect -\ innermost-frame-quot { callstack } { quotation } "inferred-effect" set-word-prop +\ innermost-frame-quot { callstack } { quotation } set-primitive-effect -\ innermost-frame-scan { callstack } { fixnum } "inferred-effect" set-word-prop +\ innermost-frame-scan { callstack } { fixnum } set-primitive-effect -\ set-innermost-frame-quot { quotation callstack } { } "inferred-effect" set-word-prop +\ set-innermost-frame-quot { quotation callstack } { } set-primitive-effect -\ (os-envs) { } { array } "inferred-effect" set-word-prop +\ (os-envs) { } { array } set-primitive-effect \ do-primitive [ \ do-primitive no-effect ] "infer" set-word-prop diff --git a/core/inference/transforms/transforms.factor b/core/inference/transforms/transforms.factor index b1b56ca1a1..7faeefc3d6 100755 --- a/core/inference/transforms/transforms.factor +++ b/core/inference/transforms/transforms.factor @@ -93,5 +93,3 @@ M: duplicated-slots-error summary \ construct-empty 1 1 make-call-node ] if ] "infer" set-word-prop - -\ construct-empty 1 1 "inferred-effect" set-word-prop diff --git a/core/kernel/kernel-docs.factor b/core/kernel/kernel-docs.factor index 2920122ec2..c828fcb0e9 100755 --- a/core/kernel/kernel-docs.factor +++ b/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 diff --git a/core/kernel/kernel.factor b/core/kernel/kernel.factor index 8d639aff78..d1f3af4779 100755 --- a/core/kernel/kernel.factor +++ b/core/kernel/kernel.factor @@ -17,8 +17,7 @@ IN: kernel : clear ( -- ) { } set-datastack ; ! Combinators - -: call ( callable -- ) uncurry (call) ; +GENERIC: call ( callable -- ) DEFER: if @@ -71,6 +70,10 @@ DEFER: if [ 2nip call ] if ; inline ! Quotation building +USE: tuples.private + +: curry ( obj quot -- curry ) + \ curry 4 ; : 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 - ! the compiler - [ slip call ] 2curry ; + \ compose 4 ; : 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) ; 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 ; diff --git a/core/quotations/quotations.factor b/core/quotations/quotations.factor index 64bf472704..65c6da2b06 100755 --- a/core/quotations/quotations.factor +++ b/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 diff --git a/core/threads/threads.factor b/core/threads/threads.factor old mode 100644 new mode 100755 index ee136654df..c4e159742a --- a/core/threads/threads.factor +++ b/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 ; 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); diff --git a/vm/data_gc.c b/vm/data_gc.c index 601a677920..342bbb6af4 100755 --- a/vm/data_gc.c +++ b/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)); diff --git a/vm/errors.c b/vm/errors.c index 966fbe353d..27158cbf44 100755 --- a/vm/errors.c +++ b/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); } diff --git a/vm/layouts.h b/vm/layouts.h index ef6fb3d4ac..5ed7c83df2 100755 --- a/vm/layouts.h +++ b/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) { diff --git a/vm/primitives.c b/vm/primitives.c index dc7333c667..5699f90fda 100755 --- a/vm/primitives.c +++ b/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, diff --git a/vm/quotations.c b/vm/quotations.c index 536d5d7d5a..c3b50dbd47 100755 --- a/vm/quotations.c +++ b/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) { diff --git a/vm/quotations.h b/vm/quotations.h index d975d9e0f5..0845957c0b 100755 --- a/vm/quotations.h +++ b/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);