From 3636a4f05fa500bfe553612047621ab7944af76e Mon Sep 17 00:00:00 2001
From: Joe Groff <arcata@gmail.com>
Date: Sat, 28 Feb 2009 16:16:09 -0600
Subject: [PATCH 01/15] chess960 buddy
---
extra/chess960/chess960.factor | 43 ++++++++++++++++++++++++++++++++++
1 file changed, 43 insertions(+)
create mode 100644 extra/chess960/chess960.factor
diff --git a/extra/chess960/chess960.factor b/extra/chess960/chess960.factor
new file mode 100644
index 0000000000..6535cc1925
--- /dev/null
+++ b/extra/chess960/chess960.factor
@@ -0,0 +1,43 @@
+USING: math.ranges kernel random sequences arrays combinators ;
+IN: chess960
+
+SYMBOLS: pawn rook knight bishop queen king ;
+
+: all-positions ( -- range ) 0 8 [a,b) ;
+
+: black-bishop-positions ( -- range ) 0 6 2 <range> ;
+: white-bishop-positions ( -- range ) 1 7 2 <range> ;
+
+: frisk ( position positions -- position positions' )
+ [ drop ] [ remove ] 2bi ;
+
+: white-bishop ( positions -- position positions' )
+ [ white-bishop-positions random ] dip frisk ;
+: black-bishop ( positions -- position positions' )
+ [ black-bishop-positions random ] dip frisk ;
+
+: random-position ( positions -- position positions' )
+ [ random ] keep frisk ;
+
+: make-position ( white-bishop black-bishop knight knight queen {r,k,r} -- position )
+ first3
+ 8 f <array> {
+ [ [ rook ] 2dip set-nth ]
+ [ [ king ] 2dip set-nth ]
+ [ [ rook ] 2dip set-nth ]
+ [ [ queen ] 2dip set-nth ]
+ [ [ knight ] 2dip set-nth ]
+ [ [ knight ] 2dip set-nth ]
+ [ [ bishop ] 2dip set-nth ]
+ [ [ bishop ] 2dip set-nth ]
+ [ ]
+ } cleave ;
+
+: chess960-position ( -- position )
+ all-positions
+ white-bishop
+ black-bishop
+ random-position
+ random-position
+ random-position
+ make-position ;
From 4f156348d37f4e1ff13426ecb320fff71af6fe7e Mon Sep 17 00:00:00 2001
From: Joe Groff <arcata@gmail.com>
Date: Wed, 4 Mar 2009 11:44:24 -0600
Subject: [PATCH 02/15] inline quadtrees:swizzle. add axes word to
math.affine-transforms to remove translation from transform
---
extra/math/affine-transforms/affine-transforms.factor | 3 +++
extra/quadtrees/quadtrees.factor | 2 +-
2 files changed, 4 insertions(+), 1 deletion(-)
diff --git a/extra/math/affine-transforms/affine-transforms.factor b/extra/math/affine-transforms/affine-transforms.factor
index 822af51614..132082fdba 100644
--- a/extra/math/affine-transforms/affine-transforms.factor
+++ b/extra/math/affine-transforms/affine-transforms.factor
@@ -8,6 +8,9 @@ C: <affine-transform> affine-transform
CONSTANT: identity-transform T{ affine-transform f { 1.0 0.0 } { 0.0 1.0 } { 0.0 0.0 } }
+: axes ( a -- a' )
+ clone { 0.0 0.0 } >>origin ;
+
: a.v ( a v -- v )
[ [ x>> ] [ first ] bi* v*n ]
[ [ y>> ] [ second ] bi* v*n ]
diff --git a/extra/quadtrees/quadtrees.factor b/extra/quadtrees/quadtrees.factor
index d9bdbe4aeb..9ce8003736 100644
--- a/extra/quadtrees/quadtrees.factor
+++ b/extra/quadtrees/quadtrees.factor
@@ -195,5 +195,5 @@ M: quadtree clear-assoc ( assoc -- )
: swizzle ( sequence quot -- sequence' )
[ dup ] dip map
[ zip ] [ rect-containing <quadtree> ] bi
- [ '[ first2 _ set-at ] each ] [ values ] bi ;
+ [ '[ first2 _ set-at ] each ] [ values ] bi ; inline
From 1559b7464000d16aa20b398adc1bd9b08ffa416d Mon Sep 17 00:00:00 2001
From: Slava Pestov <slava@slava-pestovs-macbook-pro.local>
Date: Mon, 16 Mar 2009 06:16:51 -0500
Subject: [PATCH 03/15] Add new check-datastack primitive and re-implement
call( with it, instead of using with-datastack. call( is now 5x faster
---
basis/call/call-tests.factor | 2 +-
basis/call/call.factor | 42 ++++++++++++-------
.../known-words/known-words.factor | 23 ++++++----
core/bootstrap/primitives.factor | 1 +
core/effects/effects.factor | 3 ++
vm/callstack.h | 2 -
vm/primitives.c | 1 +
vm/run.c | 26 ++++++++++++
vm/run.h | 3 ++
9 files changed, 79 insertions(+), 24 deletions(-)
diff --git a/basis/call/call-tests.factor b/basis/call/call-tests.factor
index 4e45c3cf8f..bc6f9a5d4c 100644
--- a/basis/call/call-tests.factor
+++ b/basis/call/call-tests.factor
@@ -6,7 +6,7 @@ IN: call.tests
[ 3 ] [ 1 2 [ + ] call( x y -- z ) ] unit-test
[ 1 2 [ + ] call( -- z ) ] must-fail
[ 1 2 [ + ] call( x y -- z a ) ] must-fail
-[ 1 2 3 { 4 } ] [ 1 2 3 4 [ datastack nip ] call( x -- y ) ] unit-test
+[ 1 2 3 { 1 2 3 4 } ] [ 1 2 3 4 [ datastack nip ] call( x -- y ) ] unit-test
[ [ + ] call( x y -- z ) ] must-infer
[ 3 ] [ 1 2 \ + execute( x y -- z ) ] unit-test
diff --git a/basis/call/call.factor b/basis/call/call.factor
index 0c1b5bbfbf..e4803c36f9 100644
--- a/basis/call/call.factor
+++ b/basis/call/call.factor
@@ -1,28 +1,39 @@
! Copyright (C) 2009 Daniel Ehrenberg, Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
-USING: kernel macros fry summary sequences sequences.private
-generalizations accessors continuations effects effects.parser
-parser words ;
+USING: kernel kernel.private macros fry summary sequences
+sequences.private accessors effects effects.parser parser words
+make ;
IN: call
-ERROR: wrong-values values quot length-required ;
+ERROR: wrong-values effect ;
-M: wrong-values summary
- drop "Wrong number of values returned from quotation" ;
+M: wrong-values summary drop "Quotation called with stack effect" ;
<PRIVATE
-: firstn-safe ( array quot n -- ... )
- 3dup nip swap length = [ nip firstn ] [ wrong-values ] if ; inline
-
: parse-call( ( accum word -- accum )
[ ")" parse-effect parsed ] dip parsed ;
+: call-effect-unsafe ( quot effect -- )
+ drop call ;
+
+: call-unsafe( \ call-effect-unsafe parse-call( ; parsing
+
PRIVATE>
+: (call-effect>quot) ( in out effect -- quot )
+ [
+ [ [ datastack ] dip dip ] %
+ [ [ , ] bi@ \ check-datastack , ] dip [ wrong-values ] curry , \ unless ,
+ ] [ ] make ;
+
+: call-effect>quot ( effect -- quot )
+ [ in>> length ] [ out>> length ] [ ] tri
+ [ (call-effect>quot) ] keep add-effect-input
+ [ call-effect-unsafe ] 2curry ;
+
MACRO: call-effect ( effect -- quot )
- [ in>> length ] [ out>> length ] bi
- '[ [ _ narray ] dip [ with-datastack ] keep _ firstn-safe ] ;
+ call-effect>quot ;
: call( \ call-effect parse-call( ; parsing
@@ -44,17 +55,20 @@ MACRO: call-effect ( effect -- quot )
over optimized>> [ [ stack-effect ] dip effect<= ] [ 2drop f ] if ; inline
: cache-miss ( word effect ic -- )
- [ 2dup execute-effect-unsafe? ] dip
- '[ [ drop _ set-first ] [ execute-effect-unsafe ] 2bi ]
+ 2over execute-effect-unsafe?
+ [ [ nip set-first ] [ drop execute-effect-unsafe ] 3bi ]
[ execute-effect-slow ] if ; inline
: execute-effect-ic ( word effect ic -- )
#! ic is a mutable cell { effect }
3dup nip cache-hit? [ cache-hit ] [ cache-miss ] if ; inline
+: execute-effect>quot ( effect -- quot )
+ { f } clone [ execute-effect-ic ] 2curry ;
+
PRIVATE>
MACRO: execute-effect ( effect -- )
- { f } clone '[ _ _ execute-effect-ic ] ;
+ execute-effect>quot ;
: execute( \ execute-effect parse-call( ; parsing
diff --git a/basis/stack-checker/known-words/known-words.factor b/basis/stack-checker/known-words/known-words.factor
index e366073326..392cea62d6 100644
--- a/basis/stack-checker/known-words/known-words.factor
+++ b/basis/stack-checker/known-words/known-words.factor
@@ -140,13 +140,17 @@ M: object infer-call*
peek-d literal value>> 2 + { "*" } <effect>
apply-word/effect ;
-: infer-execute-effect-unsafe ( -- )
- \ execute
+: infer-effect-unsafe ( word -- )
pop-literal nip
- [ in>> "word" suffix ] [ out>> ] [ terminated?>> ] tri
- effect boa
+ add-effect-input
apply-word/effect ;
+: infer-execute-effect-unsafe ( -- )
+ \ execute infer-effect-unsafe ;
+
+: infer-call-effect-unsafe ( -- )
+ \ call infer-effect-unsafe ;
+
: infer-exit ( -- )
\ exit (( n -- * )) apply-word/effect ;
@@ -186,6 +190,7 @@ M: object infer-call*
{ \ execute [ infer-execute ] }
{ \ (execute) [ infer-execute ] }
{ \ execute-effect-unsafe [ infer-execute-effect-unsafe ] }
+ { \ call-effect-unsafe [ infer-call-effect-unsafe ] }
{ \ if [ infer-if ] }
{ \ dispatch [ infer-dispatch ] }
{ \ <tuple-boa> [ infer-<tuple-boa> ] }
@@ -212,9 +217,10 @@ M: object infer-call*
{
declare call (call) slip 2slip 3slip dip 2dip 3dip curry compose
- execute (execute) execute-effect-unsafe if dispatch <tuple-boa>
- (throw) exit load-local load-locals get-local drop-locals
- do-primitive alien-invoke alien-indirect alien-callback
+ execute (execute) call-effect-unsafe execute-effect-unsafe if
+ dispatch <tuple-boa> (throw) exit load-local load-locals get-local
+ drop-locals do-primitive alien-invoke alien-indirect
+ alien-callback
} [ t "special" set-word-prop ] each
{ call execute dispatch load-locals get-local drop-locals }
@@ -627,6 +633,9 @@ M: object infer-call*
\ datastack { } { array } define-primitive
\ datastack make-flushable
+\ check-datastack { array integer integer } { object } define-primitive
+\ check-datastack make-flushable
+
\ retainstack { } { array } define-primitive
\ retainstack make-flushable
diff --git a/core/bootstrap/primitives.factor b/core/bootstrap/primitives.factor
index 083059cec5..f04a42f493 100644
--- a/core/bootstrap/primitives.factor
+++ b/core/bootstrap/primitives.factor
@@ -533,6 +533,7 @@ tuple
{ "gc-reset" "memory" }
{ "jit-compile" "quotations" }
{ "load-locals" "locals.backend" }
+ { "check-datastack" "kernel.private" }
}
[ [ first2 ] dip make-primitive ] each-index
diff --git a/core/effects/effects.factor b/core/effects/effects.factor
index d21132aebb..142b9120a8 100644
--- a/core/effects/effects.factor
+++ b/core/effects/effects.factor
@@ -63,3 +63,6 @@ M: effect clone
: shuffle ( stack shuffle -- newstack )
shuffle-mapping swap nths ;
+
+: add-effect-input ( effect -- effect' )
+ [ in>> "obj" suffix ] [ out>> ] [ terminated?>> ] tri effect boa ;
diff --git a/vm/callstack.h b/vm/callstack.h
index 68937980f6..3c13e7b1cd 100755
--- a/vm/callstack.h
+++ b/vm/callstack.h
@@ -14,8 +14,6 @@ CELL frame_scan(F_STACK_FRAME *frame);
CELL frame_type(F_STACK_FRAME *frame);
void primitive_callstack(void);
-void primitive_set_datastack(void);
-void primitive_set_retainstack(void);
void primitive_set_callstack(void);
void primitive_callstack_to_array(void);
void primitive_innermost_stack_frame_quot(void);
diff --git a/vm/primitives.c b/vm/primitives.c
index 2bce9eedb7..82b0555894 100755
--- a/vm/primitives.c
+++ b/vm/primitives.c
@@ -144,4 +144,5 @@ void *primitives[] = {
primitive_clear_gc_stats,
primitive_jit_compile,
primitive_load_locals,
+ primitive_check_datastack
};
diff --git a/vm/run.c b/vm/run.c
index c7002eb0ec..e55eb904a7 100755
--- a/vm/run.c
+++ b/vm/run.c
@@ -155,6 +155,32 @@ void primitive_set_retainstack(void)
rs = array_to_stack(untag_array(dpop()),rs_bot);
}
+/* Used to implement call( */
+void primitive_check_datastack(void)
+{
+ F_FIXNUM out = to_fixnum(dpop());
+ F_FIXNUM in = to_fixnum(dpop());
+ F_FIXNUM height = out - in;
+ F_ARRAY *array = untag_array(dpop());
+ F_FIXNUM length = array_capacity(array);
+ F_FIXNUM depth = (ds - ds_bot + CELLS) / CELLS;
+ if(depth - height != length)
+ dpush(F);
+ else
+ {
+ F_FIXNUM i;
+ for(i = 0; i < length - in; i++)
+ {
+ if(get(ds_bot + i * CELLS) != array_nth(array,i))
+ {
+ dpush(F);
+ return;
+ }
+ }
+ dpush(T);
+ }
+}
+
void primitive_getenv(void)
{
F_FIXNUM e = untag_fixnum_fast(dpeek());
diff --git a/vm/run.h b/vm/run.h
index 06b6317015..2acff2cd5a 100755
--- a/vm/run.h
+++ b/vm/run.h
@@ -236,6 +236,9 @@ void init_stacks(CELL ds_size, CELL rs_size);
void primitive_datastack(void);
void primitive_retainstack(void);
+void primitive_set_datastack(void);
+void primitive_set_retainstack(void);
+void primitive_check_datastack(void);
void primitive_getenv(void);
void primitive_setenv(void);
void primitive_exit(void);
From 38c6be94d4cf4cf1c9a73b48dee159d2dfdedc94 Mon Sep 17 00:00:00 2001
From: Slava Pestov <slava@slava-pestovs-macbook-pro.local>
Date: Mon, 16 Mar 2009 06:17:18 -0500
Subject: [PATCH 04/15] Fixing some stack comments
---
basis/compiler/codegen/codegen.factor | 4 ++--
basis/io/pipes/pipes.factor | 9 +++++----
core/classes/tuple/parser/parser.factor | 8 ++++----
core/generic/parser/parser.factor | 2 +-
core/parser/parser.factor | 2 +-
5 files changed, 13 insertions(+), 12 deletions(-)
diff --git a/basis/compiler/codegen/codegen.factor b/basis/compiler/codegen/codegen.factor
index d915b29ae5..486675ec26 100755
--- a/basis/compiler/codegen/codegen.factor
+++ b/basis/compiler/codegen/codegen.factor
@@ -3,7 +3,7 @@
USING: namespaces make math math.order math.parser sequences accessors
kernel kernel.private layouts assocs words summary arrays
combinators classes.algebra alien alien.c-types alien.structs
-alien.strings alien.arrays alien.complex sets libc
+alien.strings alien.arrays alien.complex sets libc call
continuations.private fry cpu.architecture
compiler.errors
compiler.alien
@@ -464,7 +464,7 @@ TUPLE: callback-context ;
dup current-callback eq? [
drop
] [
- yield-hook get call wait-to-return
+ yield-hook get call( -- ) wait-to-return
] if ;
: do-callback ( quot token -- )
diff --git a/basis/io/pipes/pipes.factor b/basis/io/pipes/pipes.factor
index 9cadb3f6cc..ad59cbc632 100644
--- a/basis/io/pipes/pipes.factor
+++ b/basis/io/pipes/pipes.factor
@@ -1,8 +1,8 @@
-! Copyright (C) 2008 Slava Pestov.
+! Copyright (C) 2008, 2009 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: io.encodings io.backend io.ports io.streams.duplex
io splitting grouping sequences namespaces kernel
-destructors math concurrency.combinators accessors
+destructors math concurrency.combinators accessors call fry
arrays continuations quotations system vocabs.loader combinators ;
IN: io.pipes
@@ -29,11 +29,12 @@ HOOK: (pipe) io-backend ( -- pipe )
: ?writer ( handle/f -- stream )
[ <output-port> &dispose ] [ output-stream get ] if* ;
-GENERIC: run-pipeline-element ( input-fd output-fd obj -- quot )
+GENERIC: run-pipeline-element ( input-fd output-fd obj -- result )
M: callable run-pipeline-element
[
- [ [ ?reader ] [ ?writer ] bi* ] dip with-streams*
+ [ [ ?reader ] [ ?writer ] bi* ] dip
+ '[ _ call( -- result ) ] with-streams*
] with-destructors ;
: <pipes> ( n -- pipes )
diff --git a/core/classes/tuple/parser/parser.factor b/core/classes/tuple/parser/parser.factor
index 659195edbf..5e12322a48 100644
--- a/core/classes/tuple/parser/parser.factor
+++ b/core/classes/tuple/parser/parser.factor
@@ -30,7 +30,7 @@ ERROR: duplicate-slot-names names ;
ERROR: invalid-slot-name name ;
-: parse-long-slot-name ( -- )
+: parse-long-slot-name ( -- spec )
[ scan , \ } parse-until % ] { } make ;
: parse-slot-name ( string/f -- ? )
@@ -64,7 +64,7 @@ ERROR: bad-literal-tuple ;
: parse-slot-value ( -- )
scan scan-object 2array , scan {
- { f [ unexpected-eof ] }
+ { f [ \ } unexpected-eof ] }
{ "}" [ ] }
[ bad-literal-tuple ]
} case ;
@@ -72,13 +72,13 @@ ERROR: bad-literal-tuple ;
: (parse-slot-values) ( -- )
parse-slot-value
scan {
- { f [ unexpected-eof ] }
+ { f [ \ } unexpected-eof ] }
{ "{" [ (parse-slot-values) ] }
{ "}" [ ] }
[ bad-literal-tuple ]
} case ;
-: parse-slot-values ( -- )
+: parse-slot-values ( -- values )
[ (parse-slot-values) ] { } make ;
: boa>tuple ( class slots -- tuple )
diff --git a/core/generic/parser/parser.factor b/core/generic/parser/parser.factor
index 0852459c34..bf9cdb19f5 100644
--- a/core/generic/parser/parser.factor
+++ b/core/generic/parser/parser.factor
@@ -18,6 +18,6 @@ SYMBOL: current-method
: with-method-definition ( method quot -- )
over current-method set call current-method off ; inline
-: (M:) ( method def -- )
+: (M:) ( -- method def )
CREATE-METHOD [ parse-definition ] with-method-definition ;
diff --git a/core/parser/parser.factor b/core/parser/parser.factor
index c68d453b15..dddea09db9 100644
--- a/core/parser/parser.factor
+++ b/core/parser/parser.factor
@@ -214,7 +214,7 @@ print-use-hook [ [ ] ] initialize
[
V{ } clone amended-use set
parse-lines
- amended-use get empty? [ print-use-hook get call ] unless
+ amended-use get empty? [ print-use-hook get assert-depth ] unless
] with-file-vocabs ;
: parsing-file ( file -- )
From 0c77a3b3be9704be91603d27ecc19179c940383f Mon Sep 17 00:00:00 2001
From: Slava Pestov <slava@slava-pestovs-macbook-pro.local>
Date: Mon, 16 Mar 2009 06:27:01 -0500
Subject: [PATCH 05/15] compiler: use call( instead of assert-depth
---
basis/compiler/compiler.factor | 4 ++--
1 file changed, 2 insertions(+), 2 deletions(-)
diff --git a/basis/compiler/compiler.factor b/basis/compiler/compiler.factor
index 349d50fe35..f9627752e7 100644
--- a/basis/compiler/compiler.factor
+++ b/basis/compiler/compiler.factor
@@ -2,7 +2,7 @@
! See http://factorcode.org/license.txt for BSD license.
USING: accessors kernel namespaces arrays sequences io words fry
continuations vocabs assocs dlists definitions math graphs generic
-combinators deques search-deques macros io stack-checker
+combinators deques search-deques macros io stack-checker call
stack-checker.state stack-checker.inlining combinators.short-circuit
compiler.errors compiler.units compiler.tree.builder
compiler.tree.optimizer compiler.cfg.builder compiler.cfg.optimizer
@@ -111,7 +111,7 @@ t compile-dependencies? set-global
] with-return ;
: compile-loop ( deque -- )
- [ (compile) yield-hook get assert-depth ] slurp-deque ;
+ [ (compile) yield-hook get call( -- ) ] slurp-deque ;
: decompile ( word -- )
f 2array 1array modify-code-heap ;
From 3a611f41c7ec70d71955456b6a5f744aac53117e Mon Sep 17 00:00:00 2001
From: Slava Pestov <slava@slava-pestovs-macbook-pro.local>
Date: Mon, 16 Mar 2009 06:27:19 -0500
Subject: [PATCH 06/15] ui.gadgets.editors: remove unnecessary workaround, make
another word infer
---
basis/ui/gadgets/editors/editors.factor | 7 +++----
1 file changed, 3 insertions(+), 4 deletions(-)
diff --git a/basis/ui/gadgets/editors/editors.factor b/basis/ui/gadgets/editors/editors.factor
index 9adb33a164..4398b0ce70 100755
--- a/basis/ui/gadgets/editors/editors.factor
+++ b/basis/ui/gadgets/editors/editors.factor
@@ -8,7 +8,7 @@ continuations ui.clipboards ui.commands ui.gadgets ui.gadgets.borders
ui.gadgets.buttons ui.gadgets.labels ui.gadgets.scrollers
ui.gadgets.menus ui.gadgets.wrappers ui.render ui.pens.solid
ui.gadgets.line-support ui.text ui.gestures ui.baseline-alignment
-math.rectangles splitting unicode.categories fonts grouping ;
+math.rectangles splitting unicode.categories fonts grouping call ;
IN: ui.gadgets.editors
TUPLE: editor < line-gadget
@@ -413,8 +413,7 @@ editor "caret-motion" f {
} define-command-map
: clear-editor ( editor -- )
- #! The with-datastack is a kludge to make it infer. Stupid.
- model>> 1array [ clear-doc ] with-datastack drop ;
+ model>> clear-doc ;
: select-all ( editor -- ) doc-elt select-elt ;
@@ -619,7 +618,7 @@ TUPLE: action-field < field quot ;
[ editor>> editor-string ]
[ editor>> clear-editor ]
[ quot>> ]
- tri call ;
+ tri call( string -- ) ;
action-field H{
{ T{ key-down f f "RET" } [ invoke-action-field ] }
From be4fb1e7d9fdf9c44b24075180c50af7c6d155bf Mon Sep 17 00:00:00 2001
From: Slava Pestov <slava@slava-pestovs-macbook-pro.local>
Date: Mon, 16 Mar 2009 20:11:36 -0500
Subject: [PATCH 07/15] Move call( and execute( to core
---
basis/alien/c-types/c-types.factor | 2 +-
basis/bootstrap/image/image.factor | 2 +
basis/call/authors.txt | 2 -
basis/call/call-docs.factor | 47 ------------
basis/call/call-tests.factor | 33 ---------
basis/call/call.factor | 74 -------------------
basis/call/summary.txt | 1 -
basis/call/tags.txt | 1 -
basis/cocoa/messages/messages.factor | 2 +-
basis/compiler/codegen/codegen.factor | 2 +-
basis/compiler/compiler.factor | 2 +-
basis/compiler/constants/constants.factor | 2 +-
.../tree/propagation/inlining/inlining.factor | 4 +-
basis/debugger/debugger.factor | 2 +
basis/eval/eval.factor | 2 +-
basis/furnace/actions/actions.factor | 2 +-
basis/furnace/boilerplate/boilerplate.factor | 2 +-
basis/furnace/referrer/referrer.factor | 2 +-
basis/help/help.factor | 2 +-
basis/help/lint/lint.factor | 2 +-
basis/help/markup/markup.factor | 2 +-
basis/html/forms/forms.factor | 2 +-
basis/html/templates/chloe/chloe.factor | 2 +-
.../templates/chloe/compiler/compiler.factor | 2 +-
basis/html/templates/fhtml/fhtml.factor | 4 +-
basis/html/templates/templates.factor | 2 +-
basis/http/server/static/static.factor | 2 +-
basis/inverse/inverse.factor | 2 +-
basis/io/pipes/pipes.factor | 2 +-
basis/io/servers/connection/connection.factor | 2 +-
basis/listener/listener.factor | 2 +-
basis/lists/lazy/lazy.factor | 2 +-
basis/models/arrow/arrow.factor | 2 +-
basis/peg/ebnf/ebnf.factor | 2 +-
basis/peg/peg.factor | 2 +-
basis/regexp/regexp.factor | 6 +-
.../known-words/known-words.factor | 10 +--
basis/stack-checker/transforms/authors.txt | 1 +
.../transforms/transforms-tests.factor | 7 +-
.../transforms/transforms.factor | 64 +++++++++++++---
basis/threads/threads.factor | 8 +-
basis/tools/deploy/deploy-docs.factor | 2 +-
basis/tools/deploy/test/12/12.factor | 6 +-
basis/tools/walker/walker.factor | 1 -
basis/ui/backend/cocoa/cocoa.factor | 2 +-
basis/ui/commands/commands.factor | 3 +-
basis/ui/gadgets/buttons/buttons.factor | 2 +-
basis/ui/gadgets/editors/editors.factor | 2 +-
basis/ui/gadgets/panes/panes.factor | 2 +-
basis/ui/gadgets/worlds/worlds.factor | 8 +-
basis/ui/gestures/gestures.factor | 2 +-
basis/ui/operations/operations.factor | 2 +-
basis/ui/ui.factor | 2 +-
basis/wrap/wrap.factor | 2 +-
basis/xmode/loader/syntax/syntax.factor | 2 +-
core/bootstrap/primitives.factor | 3 +-
core/bootstrap/syntax.factor | 2 +
core/combinators/authors.txt | 1 +
core/combinators/combinators-docs.factor | 32 +++++++-
core/combinators/combinators-tests.factor | 24 ++++++
core/combinators/combinators.factor | 26 ++++++-
core/continuations/continuations-docs.factor | 5 --
core/continuations/continuations.factor | 32 ++++----
core/effects/parser/parser.factor | 5 +-
core/kernel/kernel.factor | 4 +-
core/parser/parser-tests.factor | 4 +-
core/parser/parser.factor | 21 +++---
core/strings/parser/parser.factor | 12 +--
core/syntax/syntax-docs.factor | 10 +++
core/syntax/syntax.factor | 6 +-
core/vocabs/loader/loader.factor | 2 +-
core/vocabs/vocabs.factor | 2 +-
core/words/words.factor | 4 +-
extra/4DNav/4DNav.factor | 1 -
extra/monads/monads-tests.factor | 2 +-
extra/monads/monads.factor | 22 +++---
extra/promises/promises.factor | 2 +-
extra/ui/gadgets/lists/lists.factor | 2 +-
vm/cpu-x86.32.S | 2 +-
vm/cpu-x86.64.S | 2 +-
vm/errors.c | 6 --
vm/errors.h | 1 -
vm/layouts.h | 4 +
vm/primitives.c | 1 -
vm/quotations.c | 2 +
85 files changed, 286 insertions(+), 310 deletions(-)
delete mode 100644 basis/call/authors.txt
delete mode 100644 basis/call/call-docs.factor
delete mode 100644 basis/call/call-tests.factor
delete mode 100644 basis/call/call.factor
delete mode 100644 basis/call/summary.txt
delete mode 100644 basis/call/tags.txt
diff --git a/basis/alien/c-types/c-types.factor b/basis/alien/c-types/c-types.factor
index c3fd41e689..dc35f8bbb0 100755
--- a/basis/alien/c-types/c-types.factor
+++ b/basis/alien/c-types/c-types.factor
@@ -4,7 +4,7 @@ USING: byte-arrays arrays assocs kernel kernel.private libc math
namespaces make parser sequences strings words assocs splitting
math.parser cpu.architecture alien alien.accessors quotations
layouts system compiler.units io.files io.encodings.binary
-accessors combinators effects continuations fry call classes ;
+accessors combinators effects continuations fry classes ;
IN: alien.c-types
DEFER: <int>
diff --git a/basis/bootstrap/image/image.factor b/basis/bootstrap/image/image.factor
index aeedef39bd..a2621f4c32 100644
--- a/basis/bootstrap/image/image.factor
+++ b/basis/bootstrap/image/image.factor
@@ -446,6 +446,8 @@ M: quotation '
quotation type-number object tag-number [
emit ! array
f ' emit ! compiled
+ f ' emit ! cached-effect
+ f ' emit ! cache-counter
0 emit ! xt
0 emit ! code
] emit-object
diff --git a/basis/call/authors.txt b/basis/call/authors.txt
deleted file mode 100644
index 33616a2d6a..0000000000
--- a/basis/call/authors.txt
+++ /dev/null
@@ -1,2 +0,0 @@
-Daniel Ehrenberg
-Slava Pestov
diff --git a/basis/call/call-docs.factor b/basis/call/call-docs.factor
deleted file mode 100644
index 5f76f53fac..0000000000
--- a/basis/call/call-docs.factor
+++ /dev/null
@@ -1,47 +0,0 @@
-! Copyright (C) 2009 Daniel Ehrenberg.
-! See http://factorcode.org/license.txt for BSD license.
-USING: help.markup help.syntax quotations effects words call.private ;
-IN: call
-
-ABOUT: "call"
-
-ARTICLE: "call" "Calling code with known stack effects"
-"The " { $vocab-link "call" } " vocabulary allows for arbitrary quotations to be called from code accepted by the optimizing compiler. This is done by specifying the stack effect of the quotation literally. It is checked at runtime that the stack effect is accurate."
-$nl
-"Quotations:"
-{ $subsection POSTPONE: call( }
-{ $subsection call-effect }
-"Words:"
-{ $subsection POSTPONE: execute( }
-{ $subsection execute-effect }
-"Unsafe calls:"
-{ $subsection POSTPONE: execute-unsafe( }
-{ $subsection execute-effect-unsafe } ;
-
-HELP: call(
-{ $syntax "call( stack -- effect )" }
-{ $description "Calls the quotation on the top of the stack, asserting that it has the given stack effect. The quotation does not need to be known at compile time." } ;
-
-HELP: call-effect
-{ $values { "quot" quotation } { "effect" effect } }
-{ $description "Given a quotation and a stack effect, calls the quotation, asserting at runtime that it has the given stack effect. This is a macro which expands given a literal effect parameter, and an arbitrary quotation which is not required at compile time." } ;
-
-HELP: execute(
-{ $syntax "execute( stack -- effect )" }
-{ $description "Calls the word on the top of the stack, asserting that it has the given stack effect. The word does not need to be known at compile time." } ;
-
-HELP: execute-effect
-{ $values { "word" word } { "effect" effect } }
-{ $description "Given a word and a stack effect, executes the word, asserting at runtime that it has the given stack effect. This is a macro which expands given a literal effect parameter, and an arbitrary word which is not required at compile time." } ;
-
-HELP: execute-unsafe(
-{ $syntax "execute-unsafe( stack -- effect )" }
-{ $description "Calls the word on the top of the stack, blindly declaring that it has the given stack effect. The word does not need to be known at compile time." }
-{ $warning "If the word being executed has an incorrect stack effect, undefined behavior will result. User code should use " { $link POSTPONE: execute( } " instead." } ;
-HELP: execute-effect-unsafe
-{ $values { "word" word } { "effect" effect } }
-{ $description "Given a word and a stack effect, executes the word, blindly declaring at runtime that it has the given stack effect. This is a macro which expands given a literal effect parameter, and an arbitrary word which is not required at compile time." }
-{ $warning "If the word being executed has an incorrect stack effect, undefined behavior will result. User code should use " { $link execute-effect-unsafe } " instead." } ;
-
-{ call-effect execute-effect execute-effect-unsafe } related-words
-{ POSTPONE: call( POSTPONE: execute( POSTPONE: execute-unsafe( } related-words
\ No newline at end of file
diff --git a/basis/call/call-tests.factor b/basis/call/call-tests.factor
deleted file mode 100644
index bc6f9a5d4c..0000000000
--- a/basis/call/call-tests.factor
+++ /dev/null
@@ -1,33 +0,0 @@
-! Copyright (C) 2009 Daniel Ehrenberg.
-! See http://factorcode.org/license.txt for BSD license.
-USING: math tools.test call call.private kernel accessors ;
-IN: call.tests
-
-[ 3 ] [ 1 2 [ + ] call( x y -- z ) ] unit-test
-[ 1 2 [ + ] call( -- z ) ] must-fail
-[ 1 2 [ + ] call( x y -- z a ) ] must-fail
-[ 1 2 3 { 1 2 3 4 } ] [ 1 2 3 4 [ datastack nip ] call( x -- y ) ] unit-test
-[ [ + ] call( x y -- z ) ] must-infer
-
-[ 3 ] [ 1 2 \ + execute( x y -- z ) ] unit-test
-[ 1 2 \ + execute( -- z ) ] must-fail
-[ 1 2 \ + execute( x y -- z a ) ] must-fail
-[ \ + execute( x y -- z ) ] must-infer
-
-: compile-execute(-test-1 ( a b -- c ) \ + execute( a b -- c ) ;
-
-[ t ] [ \ compile-execute(-test-1 optimized>> ] unit-test
-[ 4 ] [ 1 3 compile-execute(-test-1 ] unit-test
-
-: compile-execute(-test-2 ( a b w -- c ) execute( a b -- c ) ;
-
-[ t ] [ \ compile-execute(-test-2 optimized>> ] unit-test
-[ 4 ] [ 1 3 \ + compile-execute(-test-2 ] unit-test
-[ 5 ] [ 1 4 \ + compile-execute(-test-2 ] unit-test
-[ -3 ] [ 1 4 \ - compile-execute(-test-2 ] unit-test
-[ 5 ] [ 1 4 \ + compile-execute(-test-2 ] unit-test
-
-[ t ] [ \ + (( a b -- c )) execute-effect-unsafe? ] unit-test
-[ t ] [ \ + (( a b c -- d e )) execute-effect-unsafe? ] unit-test
-[ f ] [ \ + (( a b c -- d )) execute-effect-unsafe? ] unit-test
-[ f ] [ \ call (( x -- )) execute-effect-unsafe? ] unit-test
diff --git a/basis/call/call.factor b/basis/call/call.factor
deleted file mode 100644
index e4803c36f9..0000000000
--- a/basis/call/call.factor
+++ /dev/null
@@ -1,74 +0,0 @@
-! Copyright (C) 2009 Daniel Ehrenberg, Slava Pestov.
-! See http://factorcode.org/license.txt for BSD license.
-USING: kernel kernel.private macros fry summary sequences
-sequences.private accessors effects effects.parser parser words
-make ;
-IN: call
-
-ERROR: wrong-values effect ;
-
-M: wrong-values summary drop "Quotation called with stack effect" ;
-
-<PRIVATE
-
-: parse-call( ( accum word -- accum )
- [ ")" parse-effect parsed ] dip parsed ;
-
-: call-effect-unsafe ( quot effect -- )
- drop call ;
-
-: call-unsafe( \ call-effect-unsafe parse-call( ; parsing
-
-PRIVATE>
-
-: (call-effect>quot) ( in out effect -- quot )
- [
- [ [ datastack ] dip dip ] %
- [ [ , ] bi@ \ check-datastack , ] dip [ wrong-values ] curry , \ unless ,
- ] [ ] make ;
-
-: call-effect>quot ( effect -- quot )
- [ in>> length ] [ out>> length ] [ ] tri
- [ (call-effect>quot) ] keep add-effect-input
- [ call-effect-unsafe ] 2curry ;
-
-MACRO: call-effect ( effect -- quot )
- call-effect>quot ;
-
-: call( \ call-effect parse-call( ; parsing
-
-<PRIVATE
-
-: execute-effect-unsafe ( word effect -- )
- drop execute ;
-
-: execute-unsafe( \ execute-effect-unsafe parse-call( ; parsing
-
-: execute-effect-slow ( word effect -- )
- [ [ execute ] curry ] dip call-effect ; inline
-
-: cache-hit? ( word ic -- ? ) first-unsafe eq? ; inline
-
-: cache-hit ( word effect ic -- ) drop execute-effect-unsafe ; inline
-
-: execute-effect-unsafe? ( word effect -- ? )
- over optimized>> [ [ stack-effect ] dip effect<= ] [ 2drop f ] if ; inline
-
-: cache-miss ( word effect ic -- )
- 2over execute-effect-unsafe?
- [ [ nip set-first ] [ drop execute-effect-unsafe ] 3bi ]
- [ execute-effect-slow ] if ; inline
-
-: execute-effect-ic ( word effect ic -- )
- #! ic is a mutable cell { effect }
- 3dup nip cache-hit? [ cache-hit ] [ cache-miss ] if ; inline
-
-: execute-effect>quot ( effect -- quot )
- { f } clone [ execute-effect-ic ] 2curry ;
-
-PRIVATE>
-
-MACRO: execute-effect ( effect -- )
- execute-effect>quot ;
-
-: execute( \ execute-effect parse-call( ; parsing
diff --git a/basis/call/summary.txt b/basis/call/summary.txt
deleted file mode 100644
index d449497971..0000000000
--- a/basis/call/summary.txt
+++ /dev/null
@@ -1 +0,0 @@
-Calling arbitrary quotations and executing arbitrary words with a static stack effect
diff --git a/basis/call/tags.txt b/basis/call/tags.txt
deleted file mode 100644
index f4274299b1..0000000000
--- a/basis/call/tags.txt
+++ /dev/null
@@ -1 +0,0 @@
-extensions
diff --git a/basis/cocoa/messages/messages.factor b/basis/cocoa/messages/messages.factor
index 8818c9a217..f71b9f3f56 100644
--- a/basis/cocoa/messages/messages.factor
+++ b/basis/cocoa/messages/messages.factor
@@ -5,7 +5,7 @@ continuations combinators compiler compiler.alien stack-checker kernel
math namespaces make parser quotations sequences strings words
cocoa.runtime io macros memoize io.encodings.utf8 effects libc
libc.private parser lexer init core-foundation fry generalizations
-specialized-arrays.direct.alien call ;
+specialized-arrays.direct.alien ;
IN: cocoa.messages
: make-sender ( method function -- quot )
diff --git a/basis/compiler/codegen/codegen.factor b/basis/compiler/codegen/codegen.factor
index 486675ec26..40b1f56f8b 100755
--- a/basis/compiler/codegen/codegen.factor
+++ b/basis/compiler/codegen/codegen.factor
@@ -3,7 +3,7 @@
USING: namespaces make math math.order math.parser sequences accessors
kernel kernel.private layouts assocs words summary arrays
combinators classes.algebra alien alien.c-types alien.structs
-alien.strings alien.arrays alien.complex sets libc call
+alien.strings alien.arrays alien.complex sets libc
continuations.private fry cpu.architecture
compiler.errors
compiler.alien
diff --git a/basis/compiler/compiler.factor b/basis/compiler/compiler.factor
index f9627752e7..c8e1e5fd0f 100644
--- a/basis/compiler/compiler.factor
+++ b/basis/compiler/compiler.factor
@@ -2,7 +2,7 @@
! See http://factorcode.org/license.txt for BSD license.
USING: accessors kernel namespaces arrays sequences io words fry
continuations vocabs assocs dlists definitions math graphs generic
-combinators deques search-deques macros io stack-checker call
+combinators deques search-deques macros io stack-checker
stack-checker.state stack-checker.inlining combinators.short-circuit
compiler.errors compiler.units compiler.tree.builder
compiler.tree.optimizer compiler.cfg.builder compiler.cfg.optimizer
diff --git a/basis/compiler/constants/constants.factor b/basis/compiler/constants/constants.factor
index e03c062e9e..f82b6d479f 100644
--- a/basis/compiler/constants/constants.factor
+++ b/basis/compiler/constants/constants.factor
@@ -20,7 +20,7 @@ CONSTANT: deck-bits 18
: tuple-class-offset ( -- n ) bootstrap-cell tuple tag-number - ; inline
: class-hash-offset ( -- n ) bootstrap-cell object tag-number - ; inline
: word-xt-offset ( -- n ) 9 bootstrap-cells object tag-number - ; inline
-: quot-xt-offset ( -- n ) 3 bootstrap-cells object tag-number - ; inline
+: quot-xt-offset ( -- n ) 5 bootstrap-cells object tag-number - ; inline
: word-code-offset ( -- n ) 10 bootstrap-cells object tag-number - ; inline
: array-start-offset ( -- n ) 2 bootstrap-cells object tag-number - ; inline
: compiled-header-size ( -- n ) 4 bootstrap-cells ; inline
diff --git a/basis/compiler/tree/propagation/inlining/inlining.factor b/basis/compiler/tree/propagation/inlining/inlining.factor
index 953956c3bd..f18cfcd3a3 100755
--- a/basis/compiler/tree/propagation/inlining/inlining.factor
+++ b/basis/compiler/tree/propagation/inlining/inlining.factor
@@ -1,6 +1,6 @@
-! Copyright (C) 2008 Slava Pestov.
+! Copyright (C) 2008, 2009 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
-USING: accessors kernel arrays sequences math math.order call
+USING: accessors kernel arrays sequences math math.order
math.partial-dispatch generic generic.standard generic.math
classes.algebra classes.union sets quotations assocs combinators
words namespaces continuations classes fry combinators.smart
diff --git a/basis/debugger/debugger.factor b/basis/debugger/debugger.factor
index 627fd95384..efd35ab280 100644
--- a/basis/debugger/debugger.factor
+++ b/basis/debugger/debugger.factor
@@ -325,3 +325,5 @@ M: bad-literal-tuple summary drop "Bad literal tuple" ;
M: check-mixin-class summary drop "Not a mixin class" ;
M: not-found-in-roots summary drop "Cannot resolve vocab: path" ;
+
+M: wrong-values summary drop "Quotation called with wrong stack effect" ;
\ No newline at end of file
diff --git a/basis/eval/eval.factor b/basis/eval/eval.factor
index dfa9baf418..3672337a58 100644
--- a/basis/eval/eval.factor
+++ b/basis/eval/eval.factor
@@ -4,7 +4,7 @@ USING: splitting parser compiler.units kernel namespaces
debugger io.streams.string fry ;
IN: eval
-: parse-string ( str -- )
+: parse-string ( str -- quot )
[ string-lines parse-lines ] with-compilation-unit ;
: (eval) ( str -- )
diff --git a/basis/furnace/actions/actions.factor b/basis/furnace/actions/actions.factor
index b0814db4dd..a582755dc4 100644
--- a/basis/furnace/actions/actions.factor
+++ b/basis/furnace/actions/actions.factor
@@ -2,7 +2,7 @@
! See http://factorcode.org/license.txt for BSD license.
USING: accessors sequences kernel assocs combinators
validators http hashtables namespaces fry continuations locals
-io arrays math boxes splitting urls call
+io arrays math boxes splitting urls
xml.entities
http.server
http.server.responses
diff --git a/basis/furnace/boilerplate/boilerplate.factor b/basis/furnace/boilerplate/boilerplate.factor
index 84b29bf831..b4bc574ae2 100644
--- a/basis/furnace/boilerplate/boilerplate.factor
+++ b/basis/furnace/boilerplate/boilerplate.factor
@@ -1,6 +1,6 @@
! Copyright (c) 2008, 2009 Slava Pestov
! See http://factorcode.org/license.txt for BSD license.
-USING: accessors kernel math.order namespaces combinators.short-circuit call
+USING: accessors kernel math.order namespaces combinators.short-circuit
html.forms
html.templates
html.templates.chloe
diff --git a/basis/furnace/referrer/referrer.factor b/basis/furnace/referrer/referrer.factor
index acd4563cd6..0eb00bac27 100644
--- a/basis/furnace/referrer/referrer.factor
+++ b/basis/furnace/referrer/referrer.factor
@@ -1,7 +1,7 @@
! Copyright (C) 2008, 2009 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: accessors kernel http.server http.server.filters
-http.server.responses furnace.utilities call ;
+http.server.responses furnace.utilities ;
IN: furnace.referrer
TUPLE: referrer-check < filter-responder quot ;
diff --git a/basis/help/help.factor b/basis/help/help.factor
index 27a81f9948..d8629008d2 100644
--- a/basis/help/help.factor
+++ b/basis/help/help.factor
@@ -5,7 +5,7 @@ parser prettyprint sequences words words.symbol assocs
definitions generic quotations effects slots continuations
classes.tuple debugger combinators vocabs help.stylesheet
help.topics help.crossref help.markup sorting classes
-vocabs.loader call ;
+vocabs.loader ;
IN: help
GENERIC: word-help* ( word -- content )
diff --git a/basis/help/lint/lint.factor b/basis/help/lint/lint.factor
index 2281c295c3..7942f90e0a 100755
--- a/basis/help/lint/lint.factor
+++ b/basis/help/lint/lint.factor
@@ -7,7 +7,7 @@ combinators combinators.short-circuit splitting debugger
hashtables sorting effects vocabs vocabs.loader assocs editors
continuations classes.predicate macros math sets eval
vocabs.parser words.symbol values grouping unicode.categories
-sequences.deep call ;
+sequences.deep ;
IN: help.lint
SYMBOL: vocabs-quot
diff --git a/basis/help/markup/markup.factor b/basis/help/markup/markup.factor
index ea64def751..8ea36d62fb 100644
--- a/basis/help/markup/markup.factor
+++ b/basis/help/markup/markup.factor
@@ -4,7 +4,7 @@ USING: accessors arrays definitions generic io kernel assocs
hashtables namespaces make parser prettyprint sequences strings
io.styles vectors words math sorting splitting classes slots fry
sets vocabs help.stylesheet help.topics vocabs.loader quotations
-combinators call see ;
+combinators see ;
IN: help.markup
PREDICATE: simple-element < array
diff --git a/basis/html/forms/forms.factor b/basis/html/forms/forms.factor
index 4cab87acfa..cc8b4f0a15 100644
--- a/basis/html/forms/forms.factor
+++ b/basis/html/forms/forms.factor
@@ -1,6 +1,6 @@
! Copyright (C) 2008, 2009 Slava Pestov
! See http://factorcode.org/license.txt for BSD license.
-USING: kernel accessors strings namespaces assocs hashtables io call
+USING: kernel accessors strings namespaces assocs hashtables io
mirrors math fry sequences words continuations
xml.entities xml.writer xml.syntax ;
IN: html.forms
diff --git a/basis/html/templates/chloe/chloe.factor b/basis/html/templates/chloe/chloe.factor
index da0d45a9d4..1fe90b08d3 100644
--- a/basis/html/templates/chloe/chloe.factor
+++ b/basis/html/templates/chloe/chloe.factor
@@ -4,7 +4,7 @@ USING: accessors kernel sequences combinators kernel fry
namespaces make classes.tuple assocs splitting words arrays io
io.files io.files.info io.encodings.utf8 io.streams.string
unicode.case mirrors math urls present multiline quotations xml
-logging call
+logging
xml.data xml.writer xml.syntax strings
html.forms
html
diff --git a/basis/html/templates/chloe/compiler/compiler.factor b/basis/html/templates/chloe/compiler/compiler.factor
index 3cb7523bdc..92e4a8dc49 100644
--- a/basis/html/templates/chloe/compiler/compiler.factor
+++ b/basis/html/templates/chloe/compiler/compiler.factor
@@ -2,7 +2,7 @@
! See http://factorcode.org/license.txt for BSD license.
USING: assocs namespaces make kernel sequences accessors
combinators strings splitting io io.streams.string present
-xml.writer xml.data xml.entities html.forms call
+xml.writer xml.data xml.entities html.forms
html.templates html.templates.chloe.syntax ;
IN: html.templates.chloe.compiler
diff --git a/basis/html/templates/fhtml/fhtml.factor b/basis/html/templates/fhtml/fhtml.factor
index 78202d6460..f3539f6a0f 100644
--- a/basis/html/templates/fhtml/fhtml.factor
+++ b/basis/html/templates/fhtml/fhtml.factor
@@ -3,7 +3,7 @@
! See http://factorcode.org/license.txt for BSD license.
USING: continuations sequences kernel namespaces debugger
combinators math quotations generic strings splitting accessors
-assocs fry vocabs.parser parser lexer io io.files call
+assocs fry vocabs.parser parser lexer io io.files
io.streams.string io.encodings.utf8 html.templates ;
IN: html.templates.fhtml
@@ -65,7 +65,7 @@ DEFER: <% delimiter
] with-file-vocabs ;
: eval-template ( string -- )
- parse-template call ;
+ parse-template call( -- ) ;
TUPLE: fhtml path ;
diff --git a/basis/html/templates/templates.factor b/basis/html/templates/templates.factor
index fcb1b28b1a..aebae701ed 100644
--- a/basis/html/templates/templates.factor
+++ b/basis/html/templates/templates.factor
@@ -2,7 +2,7 @@
! See http://factorcode.org/license.txt for BSD license.
USING: accessors kernel fry io io.encodings.utf8 io.files
debugger prettyprint continuations namespaces boxes sequences
-arrays strings html io.streams.string assocs call
+arrays strings html io.streams.string assocs
quotations xml.data xml.writer xml.syntax ;
IN: html.templates
diff --git a/basis/http/server/static/static.factor b/basis/http/server/static/static.factor
index 13b9efc86d..bbca70d845 100644
--- a/basis/http/server/static/static.factor
+++ b/basis/http/server/static/static.factor
@@ -6,7 +6,7 @@ sorting logging calendar.format accessors splitting io io.files
io.files.info io.directories io.pathnames io.encodings.binary
fry xml.entities destructors urls html xml.syntax
html.templates.fhtml http http.server http.server.responses
-http.server.redirection xml.writer call ;
+http.server.redirection xml.writer ;
IN: http.server.static
TUPLE: file-responder root hook special allow-listings ;
diff --git a/basis/inverse/inverse.factor b/basis/inverse/inverse.factor
index 9dc79e91b5..3a86703caf 100755
--- a/basis/inverse/inverse.factor
+++ b/basis/inverse/inverse.factor
@@ -5,7 +5,7 @@ sequences assocs math arrays stack-checker effects generalizations
continuations debugger classes.tuple namespaces make vectors
bit-arrays byte-arrays strings sbufs math.functions macros
sequences.private combinators mirrors splitting
-combinators.short-circuit fry words.symbol generalizations call ;
+combinators.short-circuit fry words.symbol generalizations ;
RENAME: _ fry => __
IN: inverse
diff --git a/basis/io/pipes/pipes.factor b/basis/io/pipes/pipes.factor
index ad59cbc632..c15663b031 100644
--- a/basis/io/pipes/pipes.factor
+++ b/basis/io/pipes/pipes.factor
@@ -2,7 +2,7 @@
! See http://factorcode.org/license.txt for BSD license.
USING: io.encodings io.backend io.ports io.streams.duplex
io splitting grouping sequences namespaces kernel
-destructors math concurrency.combinators accessors call fry
+destructors math concurrency.combinators accessors fry
arrays continuations quotations system vocabs.loader combinators ;
IN: io.pipes
diff --git a/basis/io/servers/connection/connection.factor b/basis/io/servers/connection/connection.factor
index 5a3233afa9..8eafe1b5bf 100644
--- a/basis/io/servers/connection/connection.factor
+++ b/basis/io/servers/connection/connection.factor
@@ -7,7 +7,7 @@ fry accessors arrays io io.sockets io.encodings.ascii
io.sockets.secure io.files io.streams.duplex io.timeouts
io.encodings threads make concurrency.combinators
concurrency.semaphores concurrency.flags
-combinators.short-circuit call ;
+combinators.short-circuit ;
IN: io.servers.connection
TUPLE: threaded-server
diff --git a/basis/listener/listener.factor b/basis/listener/listener.factor
index 78a9c03d20..4f7ccf227e 100644
--- a/basis/listener/listener.factor
+++ b/basis/listener/listener.factor
@@ -4,7 +4,7 @@ USING: arrays hashtables io kernel math math.parser memory
namespaces parser lexer sequences strings io.styles
vectors words generic system combinators continuations debugger
definitions compiler.units accessors colors prettyprint fry
-sets vocabs.parser call ;
+sets vocabs.parser ;
IN: listener
GENERIC: stream-read-quot ( stream -- quot/f )
diff --git a/basis/lists/lazy/lazy.factor b/basis/lists/lazy/lazy.factor
index d3b08a11fb..139f6726e8 100644
--- a/basis/lists/lazy/lazy.factor
+++ b/basis/lists/lazy/lazy.factor
@@ -1,7 +1,7 @@
! Copyright (C) 2004, 2008 Chris Double, Matthew Willis, James Cash.
! See http://factorcode.org/license.txt for BSD license.
USING: kernel sequences math vectors arrays namespaces make
-quotations promises combinators io lists accessors call ;
+quotations promises combinators io lists accessors ;
IN: lists.lazy
M: promise car ( promise -- car )
diff --git a/basis/models/arrow/arrow.factor b/basis/models/arrow/arrow.factor
index fcdfd166c5..e0cf73c7f1 100644
--- a/basis/models/arrow/arrow.factor
+++ b/basis/models/arrow/arrow.factor
@@ -1,6 +1,6 @@
! Copyright (C) 2008, 2009 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
-USING: accessors models kernel call ;
+USING: accessors models kernel ;
IN: models.arrow
TUPLE: arrow < model model quot ;
diff --git a/basis/peg/ebnf/ebnf.factor b/basis/peg/ebnf/ebnf.factor
index db29ce1ee7..1f526d47f2 100644
--- a/basis/peg/ebnf/ebnf.factor
+++ b/basis/peg/ebnf/ebnf.factor
@@ -5,7 +5,7 @@ sequences quotations vectors namespaces make math assocs
continuations peg peg.parsers unicode.categories multiline
splitting accessors effects sequences.deep peg.search
combinators.short-circuit lexer io.streams.string stack-checker
-io combinators parser call ;
+io combinators parser ;
IN: peg.ebnf
: rule ( name word -- parser )
diff --git a/basis/peg/peg.factor b/basis/peg/peg.factor
index 01891a1da1..6c0772aacc 100644
--- a/basis/peg/peg.factor
+++ b/basis/peg/peg.factor
@@ -4,7 +4,7 @@ USING: kernel sequences strings fry namespaces make math assocs
io vectors arrays math.parser math.order vectors combinators
classes sets unicode.categories compiler.units parser words
quotations effects memoize accessors locals effects splitting
-combinators.short-circuit generalizations call ;
+combinators.short-circuit generalizations ;
IN: peg
TUPLE: parse-result remaining ast ;
diff --git a/basis/regexp/regexp.factor b/basis/regexp/regexp.factor
index 63a2f25885..5889b19e47 100644
--- a/basis/regexp/regexp.factor
+++ b/basis/regexp/regexp.factor
@@ -4,7 +4,7 @@ USING: accessors combinators kernel kernel.private math sequences
sequences.private strings sets assocs prettyprint.backend
prettyprint.custom make lexer namespaces parser arrays fry locals
regexp.parser splitting sorting regexp.ast regexp.negation
-regexp.compiler compiler.units words call call.private math.ranges ;
+regexp.compiler compiler.units words math.ranges ;
IN: regexp
TUPLE: regexp
@@ -35,7 +35,7 @@ M: lookbehind question>quot ! Returns ( index string -- ? )
: match-index-from ( i string regexp -- index/f )
! This word is unsafe. It assumes that i is a fixnum
! and that string is a string.
- dup dfa>> execute-unsafe( index string regexp -- i/f ) ; inline
+ dup dfa>> execute( index string regexp -- i/f ) ; inline
GENERIC: end/start ( string regexp -- end start )
M: regexp end/start drop length 0 ;
@@ -68,7 +68,7 @@ PRIVATE>
: do-next-match ( i string regexp -- i start end ? )
dup next-match>>
- execute-unsafe( i string regexp -- i start end ? ) ; inline
+ execute( i string regexp -- i start end ? ) ; inline
:: (each-match) ( i string regexp quot: ( start end string -- ) -- )
i string regexp do-next-match [| i' start end |
diff --git a/basis/stack-checker/known-words/known-words.factor b/basis/stack-checker/known-words/known-words.factor
index 392cea62d6..a7f348d36b 100644
--- a/basis/stack-checker/known-words/known-words.factor
+++ b/basis/stack-checker/known-words/known-words.factor
@@ -11,7 +11,7 @@ strings.private system threads.private classes.tuple
classes.tuple.private vectors vectors.private words definitions
words.private assocs summary compiler.units system.private
combinators locals locals.backend locals.types words.private
-quotations.private call call.private stack-checker.values
+quotations.private combinators.private stack-checker.values
stack-checker.alien
stack-checker.state
stack-checker.errors
@@ -135,11 +135,6 @@ M: object infer-call*
peek-d literal value>> second 1+ { tuple } <effect>
apply-word/effect ;
-: infer-(throw) ( -- )
- \ (throw)
- peek-d literal value>> 2 + { "*" } <effect>
- apply-word/effect ;
-
: infer-effect-unsafe ( word -- )
pop-literal nip
add-effect-input
@@ -194,7 +189,6 @@ M: object infer-call*
{ \ if [ infer-if ] }
{ \ dispatch [ infer-dispatch ] }
{ \ <tuple-boa> [ infer-<tuple-boa> ] }
- { \ (throw) [ infer-(throw) ] }
{ \ exit [ infer-exit ] }
{ \ load-local [ 1 infer->r ] }
{ \ load-locals [ infer-load-locals ] }
@@ -218,7 +212,7 @@ M: object infer-call*
{
declare call (call) slip 2slip 3slip dip 2dip 3dip curry compose
execute (execute) call-effect-unsafe execute-effect-unsafe if
- dispatch <tuple-boa> (throw) exit load-local load-locals get-local
+ dispatch <tuple-boa> exit load-local load-locals get-local
drop-locals do-primitive alien-invoke alien-indirect
alien-callback
} [ t "special" set-word-prop ] each
diff --git a/basis/stack-checker/transforms/authors.txt b/basis/stack-checker/transforms/authors.txt
index 1901f27a24..a44f8d7f8d 100644
--- a/basis/stack-checker/transforms/authors.txt
+++ b/basis/stack-checker/transforms/authors.txt
@@ -1 +1,2 @@
Slava Pestov
+Daniel Ehrenberg
diff --git a/basis/stack-checker/transforms/transforms-tests.factor b/basis/stack-checker/transforms/transforms-tests.factor
index fe580084c0..751e589c28 100644
--- a/basis/stack-checker/transforms/transforms-tests.factor
+++ b/basis/stack-checker/transforms/transforms-tests.factor
@@ -65,4 +65,9 @@ DEFER: curry-folding-test ( quot -- )
{ 3 0 } [ [ 1 2 3 ] curry-folding-test ] must-infer-as
{ 3 0 } [ 1 [ 2 3 ] curry curry-folding-test ] must-infer-as
-{ 3 0 } [ [ 1 2 ] 3 [ ] curry compose curry-folding-test ] must-infer-as
\ No newline at end of file
+{ 3 0 } [ [ 1 2 ] 3 [ ] curry compose curry-folding-test ] must-infer-as
+
+[ t ] [ \ + (( a b -- c )) execute-effect-unsafe? ] unit-test
+[ t ] [ \ + (( a b c -- d e )) execute-effect-unsafe? ] unit-test
+[ f ] [ \ + (( a b c -- d )) execute-effect-unsafe? ] unit-test
+[ f ] [ \ call (( x -- )) execute-effect-unsafe? ] unit-test
\ No newline at end of file
diff --git a/basis/stack-checker/transforms/transforms.factor b/basis/stack-checker/transforms/transforms.factor
index ecc2365cf9..6c1d391490 100755
--- a/basis/stack-checker/transforms/transforms.factor
+++ b/basis/stack-checker/transforms/transforms.factor
@@ -1,11 +1,12 @@
-! Copyright (C) 2007, 2009 Slava Pestov.
+! Copyright (C) 2007, 2009 Slava Pestov, Daniel Ehrenberg.
! See http://factorcode.org/license.txt for BSD license.
-USING: fry accessors arrays kernel words sequences generic math
-namespaces make quotations assocs combinators classes.tuple
-classes.tuple.private effects summary hashtables classes generic
-sets definitions generic.standard slots.private continuations locals
-generalizations stack-checker.backend stack-checker.state
-stack-checker.visitor stack-checker.errors stack-checker.values
+USING: fry accessors arrays kernel kernel.private combinators.private
+words sequences generic math namespaces make quotations assocs
+combinators classes.tuple classes.tuple.private effects summary
+hashtables classes generic sets definitions generic.standard
+slots.private continuations locals generalizations
+stack-checker.backend stack-checker.state stack-checker.visitor
+stack-checker.errors stack-checker.values
stack-checker.recursive-state ;
IN: stack-checker.transforms
@@ -50,6 +51,47 @@ IN: stack-checker.transforms
[ nip "transform-n" set-word-prop ]
3bi ;
+! call( and execute(
+: (call-effect>quot) ( in out effect -- quot )
+ [
+ [ [ datastack ] dip dip ] %
+ [ [ , ] bi@ \ check-datastack , ] dip
+ '[ _ wrong-values ] , \ unless ,
+ ] [ ] make ;
+
+: call-effect>quot ( effect -- quot )
+ [ in>> length ] [ out>> length ] [ ] tri
+ [ (call-effect>quot) ] keep add-effect-input
+ [ call-effect-unsafe ] 2curry ;
+
+\ call-effect [ call-effect>quot ] 1 define-transform
+
+: execute-effect-slow ( word effect -- )
+ [ '[ _ execute ] ] dip call-effect ; inline
+
+TUPLE: inline-cache value ;
+
+: cache-hit? ( word ic -- ? ) value>> eq? ; inline
+
+: cache-hit ( word effect ic -- ) drop execute-effect-unsafe ; inline
+
+: execute-effect-unsafe? ( word effect -- ? )
+ over optimized>> [ [ stack-effect ] dip effect<= ] [ 2drop f ] if ; inline
+
+: cache-miss ( word effect ic -- )
+ 2over execute-effect-unsafe?
+ [ [ nip (>>value) ] [ drop execute-effect-unsafe ] 3bi ]
+ [ drop execute-effect-slow ] if ; inline
+
+: execute-effect-ic ( word effect ic -- )
+ #! ic is a mutable cell { effect }
+ 3dup nip cache-hit? [ cache-hit ] [ cache-miss ] if ; inline
+
+: execute-effect>quot ( effect -- quot )
+ inline-cache new '[ _ _ execute-effect-ic ] ;
+
+\ execute-effect [ execute-effect>quot ] 1 define-transform
+
! Combinators
\ cond [ cond>quot ] 1 define-transform
@@ -141,8 +183,12 @@ CONSTANT: bit-member-n 256
dup bit-member? [
bit-member-quot
] [
- [ literalize [ t ] ] { } map>assoc
- [ drop f ] suffix [ case ] curry
+ dup length 4 <= [
+ [ drop f ] swap
+ [ literalize [ t ] ] { } map>assoc linear-case-quot
+ ] [
+ unique [ key? ] curry
+ ] if
] if ;
\ member? [
diff --git a/basis/threads/threads.factor b/basis/threads/threads.factor
index 3f4267df15..1f25c0e031 100644
--- a/basis/threads/threads.factor
+++ b/basis/threads/threads.factor
@@ -1,10 +1,10 @@
-! Copyright (C) 2004, 2008 Slava Pestov.
+! Copyright (C) 2004, 2009 Slava Pestov.
! Copyright (C) 2005 Mackenzie Straight.
! See http://factorcode.org/license.txt for BSD license.
USING: arrays hashtables heaps kernel kernel.private math
namespaces sequences vectors continuations continuations.private
-dlists assocs system combinators init boxes accessors
-math.order deques strings quotations fry ;
+dlists assocs system combinators combinators.private init boxes
+accessors math.order deques strings quotations fry ;
IN: threads
SYMBOL: initial-thread
@@ -126,7 +126,7 @@ DEFER: stop
{ } set-retainstack
{ } set-datastack
self quot>> [ call stop ] call-clear
- ] 2 (throw) ;
+ ] (( namestack thread -- * )) call-effect-unsafe ;
DEFER: next
diff --git a/basis/tools/deploy/deploy-docs.factor b/basis/tools/deploy/deploy-docs.factor
index a47b3dca32..2db53f2292 100644
--- a/basis/tools/deploy/deploy-docs.factor
+++ b/basis/tools/deploy/deploy-docs.factor
@@ -1,5 +1,5 @@
USING: help.markup help.syntax words alien.c-types assocs
-kernel call call.private tools.deploy.config ;
+kernel combinators combinators.private tools.deploy.config ;
IN: tools.deploy
ARTICLE: "prepare-deploy" "Preparing to deploy an application"
diff --git a/basis/tools/deploy/test/12/12.factor b/basis/tools/deploy/test/12/12.factor
index 3ee0643c38..3bc2af3da4 100644
--- a/basis/tools/deploy/test/12/12.factor
+++ b/basis/tools/deploy/test/12/12.factor
@@ -1,10 +1,12 @@
! Copyright (C) 2009 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
-USING: call math.parser io math ;
+USING: math.parser io math ;
IN: tools.deploy.test.12
: execute-test ( a b w -- c ) execute( a b -- c ) ;
-: foo ( -- ) 1 2 \ + execute-test number>string print ;
+: call-test ( a b q -- c ) call( a b -- c ) ;
+
+: foo ( -- ) 1 2 \ + execute-test 4 [ * ] call-test number>string print ;
MAIN: foo
\ No newline at end of file
diff --git a/basis/tools/walker/walker.factor b/basis/tools/walker/walker.factor
index f0d9a084b1..b4ace6b770 100644
--- a/basis/tools/walker/walker.factor
+++ b/basis/tools/walker/walker.factor
@@ -139,7 +139,6 @@ SYMBOL: +stopped+
{ dip [ (step-into-dip) ] }
{ 2dip [ (step-into-2dip) ] }
{ 3dip [ (step-into-3dip) ] }
- { (throw) [ drop (step-into-quot) ] }
{ execute [ (step-into-execute) ] }
{ if [ (step-into-if) ] }
{ dispatch [ (step-into-dispatch) ] }
diff --git a/basis/ui/backend/cocoa/cocoa.factor b/basis/ui/backend/cocoa/cocoa.factor
index 5cb02f5ad6..fc392c595d 100755
--- a/basis/ui/backend/cocoa/cocoa.factor
+++ b/basis/ui/backend/cocoa/cocoa.factor
@@ -8,7 +8,7 @@ ui.backend ui.clipboards ui.gadgets ui.gadgets.worlds
ui.backend.cocoa.views core-foundation core-foundation.run-loop
core-graphics.types threads math.rectangles fry libc
generalizations alien.c-types cocoa.views
-combinators io.thread locals call ;
+combinators io.thread locals ;
IN: ui.backend.cocoa
TUPLE: handle ;
diff --git a/basis/ui/commands/commands.factor b/basis/ui/commands/commands.factor
index d6c7c7905b..28529b013b 100644
--- a/basis/ui/commands/commands.factor
+++ b/basis/ui/commands/commands.factor
@@ -2,8 +2,7 @@
! See http://factorcode.org/license.txt for BSD license.
USING: accessors arrays definitions kernel sequences strings
math assocs words generic namespaces make assocs quotations
-splitting ui.gestures unicode.case unicode.categories tr fry
-call ;
+splitting ui.gestures unicode.case unicode.categories tr fry ;
IN: ui.commands
SYMBOL: +nullary+
diff --git a/basis/ui/gadgets/buttons/buttons.factor b/basis/ui/gadgets/buttons/buttons.factor
index ebac290f4b..0504231972 100644
--- a/basis/ui/gadgets/buttons/buttons.factor
+++ b/basis/ui/gadgets/buttons/buttons.factor
@@ -6,7 +6,7 @@ classes.tuple opengl opengl.gl math.vectors ui.commands ui.gadgets
ui.gadgets.borders ui.gadgets.labels ui.gadgets.tracks
ui.gadgets.packs ui.gadgets.worlds ui.gestures ui.pens ui.pens.solid
ui.pens.image ui.pens.tile math.rectangles locals fry
-combinators.smart call ;
+combinators.smart ;
IN: ui.gadgets.buttons
TUPLE: button < border pressed? selected? quot ;
diff --git a/basis/ui/gadgets/editors/editors.factor b/basis/ui/gadgets/editors/editors.factor
index 4398b0ce70..bda9938f8a 100755
--- a/basis/ui/gadgets/editors/editors.factor
+++ b/basis/ui/gadgets/editors/editors.factor
@@ -8,7 +8,7 @@ continuations ui.clipboards ui.commands ui.gadgets ui.gadgets.borders
ui.gadgets.buttons ui.gadgets.labels ui.gadgets.scrollers
ui.gadgets.menus ui.gadgets.wrappers ui.render ui.pens.solid
ui.gadgets.line-support ui.text ui.gestures ui.baseline-alignment
-math.rectangles splitting unicode.categories fonts grouping call ;
+math.rectangles splitting unicode.categories fonts grouping ;
IN: ui.gadgets.editors
TUPLE: editor < line-gadget
diff --git a/basis/ui/gadgets/panes/panes.factor b/basis/ui/gadgets/panes/panes.factor
index 6019d6a954..44da013f2c 100644
--- a/basis/ui/gadgets/panes/panes.factor
+++ b/basis/ui/gadgets/panes/panes.factor
@@ -10,7 +10,7 @@ ui.gadgets.paragraphs ui.gadgets.incremental ui.gadgets.packs
ui.gadgets.menus ui.clipboards ui.gestures ui.traverse ui.render
ui.text ui.gadgets.presentations ui.gadgets.grids ui.gadgets.tracks
ui.gadgets.icons ui.gadgets.grid-lines ui.baseline-alignment
-colors call io.styles ;
+colors io.styles ;
IN: ui.gadgets.panes
TUPLE: pane < track
diff --git a/basis/ui/gadgets/worlds/worlds.factor b/basis/ui/gadgets/worlds/worlds.factor
index ccfa83334b..163dbff514 100644
--- a/basis/ui/gadgets/worlds/worlds.factor
+++ b/basis/ui/gadgets/worlds/worlds.factor
@@ -1,10 +1,10 @@
! Copyright (C) 2005, 2009 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: accessors arrays assocs continuations kernel math models
-call namespaces opengl sequences io combinators
-combinators.short-circuit fry math.vectors math.rectangles cache
-ui.gadgets ui.gestures ui.render ui.text ui.text.private
-ui.backend ui.gadgets.tracks ui.commands ;
+namespaces opengl sequences io combinators combinators.short-circuit
+fry math.vectors math.rectangles cache ui.gadgets ui.gestures
+ui.render ui.text ui.text.private ui.backend ui.gadgets.tracks
+ui.commands ;
IN: ui.gadgets.worlds
TUPLE: world < track
diff --git a/basis/ui/gestures/gestures.factor b/basis/ui/gestures/gestures.factor
index 2e52a2fe1e..c7db0839d7 100644
--- a/basis/ui/gestures/gestures.factor
+++ b/basis/ui/gestures/gestures.factor
@@ -4,7 +4,7 @@ USING: accessors arrays assocs kernel math math.order models
namespaces make sequences words strings system hashtables math.parser
math.vectors classes.tuple classes boxes calendar alarms combinators
sets columns fry deques ui.gadgets ui.gadgets.private unicode.case
-unicode.categories combinators.short-circuit call ;
+unicode.categories combinators.short-circuit ;
IN: ui.gestures
GENERIC: handle-gesture ( gesture gadget -- ? )
diff --git a/basis/ui/operations/operations.factor b/basis/ui/operations/operations.factor
index 2f9cfba961..db6048061e 100644
--- a/basis/ui/operations/operations.factor
+++ b/basis/ui/operations/operations.factor
@@ -2,7 +2,7 @@
! See http://factorcode.org/license.txt for BSD license.
USING: accessors arrays definitions kernel ui.commands
ui.gestures sequences strings math words generic namespaces
-hashtables help.markup quotations assocs fry call linked-assocs ;
+hashtables help.markup quotations assocs fry linked-assocs ;
IN: ui.operations
SYMBOL: +keyboard+
diff --git a/basis/ui/ui.factor b/basis/ui/ui.factor
index fe318101ee..8ce8f57cf0 100644
--- a/basis/ui/ui.factor
+++ b/basis/ui/ui.factor
@@ -1,7 +1,7 @@
! Copyright (C) 2006, 2009 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: arrays assocs io kernel math models namespaces make dlists
-deques sequences threads sequences words continuations init call
+deques sequences threads sequences words continuations init
combinators hashtables concurrency.flags sets accessors calendar fry
destructors ui.gadgets ui.gadgets.private ui.gadgets.worlds
ui.gadgets.tracks ui.gestures ui.backend ui.render ui.text
diff --git a/basis/wrap/wrap.factor b/basis/wrap/wrap.factor
index 0b7f869141..58957ba8e7 100644
--- a/basis/wrap/wrap.factor
+++ b/basis/wrap/wrap.factor
@@ -1,7 +1,7 @@
! Copyright (C) 2009 Daniel Ehrenberg
! See http://factorcode.org/license.txt for BSD license.
USING: kernel sequences math arrays locals fry accessors
-lists splitting call make combinators.short-circuit namespaces
+lists splitting make combinators.short-circuit namespaces
grouping splitting.monotonic ;
IN: wrap
diff --git a/basis/xmode/loader/syntax/syntax.factor b/basis/xmode/loader/syntax/syntax.factor
index 60318e669e..4cbf58c8aa 100644
--- a/basis/xmode/loader/syntax/syntax.factor
+++ b/basis/xmode/loader/syntax/syntax.factor
@@ -12,7 +12,7 @@ IN: xmode.loader.syntax
: RULE:
scan scan-word scan-word [
- parse-definition { } make
+ [ parse-definition call( -- ) ] { } make
swap [ (parse-rule-tag) ] 2curry
] dip swap define-tag ; parsing
diff --git a/core/bootstrap/primitives.factor b/core/bootstrap/primitives.factor
index f04a42f493..5ad693bc86 100644
--- a/core/bootstrap/primitives.factor
+++ b/core/bootstrap/primitives.factor
@@ -243,6 +243,8 @@ bi
"quotation" "quotations" create {
{ "array" { "array" "arrays" } read-only }
{ "compiled" read-only }
+ "cached-effect"
+ "cache-counter"
} define-builtin
"dll" "alien" create {
@@ -491,7 +493,6 @@ tuple
{ "set-alien-double" "alien.accessors" }
{ "alien-cell" "alien.accessors" }
{ "set-alien-cell" "alien.accessors" }
- { "(throw)" "kernel.private" }
{ "alien-address" "alien" }
{ "set-slot" "slots.private" }
{ "string-nth" "strings.private" }
diff --git a/core/bootstrap/syntax.factor b/core/bootstrap/syntax.factor
index 654a8f5f34..1c97ee5a50 100644
--- a/core/bootstrap/syntax.factor
+++ b/core/bootstrap/syntax.factor
@@ -78,6 +78,8 @@ IN: bootstrap.syntax
"call-next-method"
"initial:"
"read-only"
+ "call("
+ "execute("
} [ "syntax" create drop ] each
"t" "syntax" lookup define-symbol
diff --git a/core/combinators/authors.txt b/core/combinators/authors.txt
index 1901f27a24..a44f8d7f8d 100644
--- a/core/combinators/authors.txt
+++ b/core/combinators/authors.txt
@@ -1 +1,2 @@
Slava Pestov
+Daniel Ehrenberg
diff --git a/core/combinators/combinators-docs.factor b/core/combinators/combinators-docs.factor
index a26c2fbe5d..cc502140ad 100644
--- a/core/combinators/combinators-docs.factor
+++ b/core/combinators/combinators-docs.factor
@@ -1,6 +1,7 @@
USING: arrays help.markup help.syntax strings sbufs vectors
kernel quotations generic generic.standard classes
-math assocs sequences sequences.private ;
+math assocs sequences sequences.private combinators.private
+effects words ;
IN: combinators
ARTICLE: "combinators-quot" "Quotation construction utilities"
@@ -9,6 +10,19 @@ ARTICLE: "combinators-quot" "Quotation construction utilities"
{ $subsection case>quot }
{ $subsection alist>quot } ;
+ARTICLE: "call" "Calling code with known stack effects"
+"Arbitrary quotations and words can be called from code accepted by the optimizing compiler. This is done by specifying the stack effect of the quotation literally. It is checked at runtime that the stack effect is accurate."
+$nl
+"Quotations:"
+{ $subsection POSTPONE: call( }
+{ $subsection call-effect }
+"Words:"
+{ $subsection POSTPONE: execute( }
+{ $subsection execute-effect }
+"Unsafe calls:"
+{ $subsection call-effect-unsafe }
+{ $subsection execute-effect-unsafe } ;
+
ARTICLE: "combinators" "Additional combinators"
"The " { $vocab-link "combinators" } " vocabulary provides a few useful combinators."
$nl
@@ -27,11 +41,27 @@ $nl
$nl
"A combinator which can help with implementing methods on " { $link hashcode* } ":"
{ $subsection recursive-hashcode }
+{ $subsection "call" }
{ $subsection "combinators-quot" }
{ $see-also "quotations" "dataflow" } ;
ABOUT: "combinators"
+HELP: call-effect
+{ $values { "quot" quotation } { "effect" effect } }
+{ $description "Given a quotation and a stack effect, calls the quotation, asserting at runtime that it has the given stack effect. This is a macro which expands given a literal effect parameter, and an arbitrary quotation which is not required at compile time." } ;
+
+HELP: execute-effect
+{ $values { "word" word } { "effect" effect } }
+{ $description "Given a word and a stack effect, executes the word, asserting at runtime that it has the given stack effect. This is a macro which expands given a literal effect parameter, and an arbitrary word which is not required at compile time." } ;
+
+HELP: execute-effect-unsafe
+{ $values { "word" word } { "effect" effect } }
+{ $description "Given a word and a stack effect, executes the word, blindly declaring at runtime that it has the given stack effect. This is a macro which expands given a literal effect parameter, and an arbitrary word which is not required at compile time." }
+{ $warning "If the word being executed has an incorrect stack effect, undefined behavior will result. User code should use " { $link POSTPONE: execute( } " instead." } ;
+
+{ call-effect call-effect-unsafe execute-effect execute-effect-unsafe } related-words
+
HELP: cleave
{ $values { "x" object } { "seq" "a sequence of quotations with stack effect " { $snippet "( x -- ... )" } } }
{ $description "Applies each quotation to the object in turn." }
diff --git a/core/combinators/combinators-tests.factor b/core/combinators/combinators-tests.factor
index 1ee3a4e3ed..1a4ee34fa2 100644
--- a/core/combinators/combinators-tests.factor
+++ b/core/combinators/combinators-tests.factor
@@ -3,6 +3,30 @@ namespaces combinators words classes sequences accessors
math.functions arrays ;
IN: combinators.tests
+[ 3 ] [ 1 2 [ + ] call( x y -- z ) ] unit-test
+[ 1 2 [ + ] call( -- z ) ] must-fail
+[ 1 2 [ + ] call( x y -- z a ) ] must-fail
+[ 1 2 3 { 1 2 3 4 } ] [ 1 2 3 4 [ datastack nip ] call( x -- y ) ] unit-test
+[ [ + ] call( x y -- z ) ] must-infer
+
+[ 3 ] [ 1 2 \ + execute( x y -- z ) ] unit-test
+[ 1 2 \ + execute( -- z ) ] must-fail
+[ 1 2 \ + execute( x y -- z a ) ] must-fail
+[ \ + execute( x y -- z ) ] must-infer
+
+: compile-execute(-test-1 ( a b -- c ) \ + execute( a b -- c ) ;
+
+[ t ] [ \ compile-execute(-test-1 optimized>> ] unit-test
+[ 4 ] [ 1 3 compile-execute(-test-1 ] unit-test
+
+: compile-execute(-test-2 ( a b w -- c ) execute( a b -- c ) ;
+
+[ t ] [ \ compile-execute(-test-2 optimized>> ] unit-test
+[ 4 ] [ 1 3 \ + compile-execute(-test-2 ] unit-test
+[ 5 ] [ 1 4 \ + compile-execute(-test-2 ] unit-test
+[ -3 ] [ 1 4 \ - compile-execute(-test-2 ] unit-test
+[ 5 ] [ 1 4 \ + compile-execute(-test-2 ] unit-test
+
! Compiled
: cond-test-1 ( obj -- str )
{
diff --git a/core/combinators/combinators.factor b/core/combinators/combinators.factor
index daf247d678..4c600e06ca 100755
--- a/core/combinators/combinators.factor
+++ b/core/combinators/combinators.factor
@@ -1,10 +1,34 @@
-! Copyright (C) 2006, 2008 Slava Pestov.
+! Copyright (C) 2006, 2009 Slava Pestov, Daniel Ehrenberg.
! See http://factorcode.org/license.txt for BSD license.
USING: accessors arrays sequences sequences.private math.private
kernel kernel.private math assocs quotations vectors
hashtables sorting words sets math.order make ;
IN: combinators
+<PRIVATE
+
+: call-effect-unsafe ( quot effect -- ) drop call ;
+
+: execute-effect-unsafe ( word effect -- ) drop execute ;
+
+M: object throw 5 getenv [ die ] or (( error -- * )) call-effect-unsafe ;
+
+PRIVATE>
+
+ERROR: wrong-values effect ;
+
+! We can't USE: effects here so we forward reference slots instead
+SLOT: in
+SLOT: out
+
+: call-effect ( quot effect -- )
+ [ [ datastack ] dip dip ] dip
+ [ in>> length ] [ out>> length ] [ ] tri [ check-datastack ] dip
+ [ wrong-values ] curry unless ;
+
+: execute-effect ( word effect -- )
+ [ [ execute ] curry ] dip call-effect ;
+
! cleave
: cleave ( x seq -- )
[ call ] with each ;
diff --git a/core/continuations/continuations-docs.factor b/core/continuations/continuations-docs.factor
index 0d66829898..0627ed5265 100644
--- a/core/continuations/continuations-docs.factor
+++ b/core/continuations/continuations-docs.factor
@@ -83,7 +83,6 @@ $nl
{ $subsection with-return }
"Reflecting the datastack:"
{ $subsection with-datastack }
-{ $subsection assert-depth }
"Continuations serve as the building block for a number of higher-level abstractions, such as " { $link "errors" } " and " { $link "threads" } "."
{ $subsection "continuations.private" } ;
@@ -217,10 +216,6 @@ HELP: with-datastack
{ $example "USING: continuations math prettyprint ;" "{ 3 7 } [ + ] with-datastack ." "{ 10 }" }
} ;
-HELP: assert-depth
-{ $values { "quot" "a quotation" } }
-{ $description "Runs a quotation. Throws an error if the quotation attempts to take input values from the stack, or leave outputs on the stack." } ;
-
HELP: attempt-all
{ $values
{ "seq" sequence } { "quot" quotation }
diff --git a/core/continuations/continuations.factor b/core/continuations/continuations.factor
index 37418b85f5..051d28d8c2 100644
--- a/core/continuations/continuations.factor
+++ b/core/continuations/continuations.factor
@@ -1,8 +1,8 @@
-! Copyright (C) 2003, 2008 Slava Pestov.
+! Copyright (C) 2003, 2009 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: arrays vectors kernel kernel.private sequences
namespaces make math splitting sorting quotations assocs
-combinators accessors ;
+combinators combinators.private accessors ;
IN: continuations
SYMBOL: error
@@ -73,7 +73,7 @@ C: <continuation> continuation
<PRIVATE
-: (continue) ( continuation -- )
+: (continue) ( continuation -- * )
>continuation<
set-catchstack
set-namestack
@@ -81,19 +81,18 @@ C: <continuation> continuation
[ set-datastack ] dip
set-callstack ;
-: (continue-with) ( obj continuation -- )
- swap 4 setenv
- >continuation<
- set-catchstack
- set-namestack
- set-retainstack
- [ set-datastack drop 4 getenv f 4 setenv f ] dip
- set-callstack ;
-
PRIVATE>
: continue-with ( obj continuation -- * )
- [ (continue-with) ] 2 (throw) ;
+ [
+ swap 4 setenv
+ >continuation<
+ set-catchstack
+ set-namestack
+ set-retainstack
+ [ set-datastack drop 4 getenv f 4 setenv f ] dip
+ set-callstack
+ ] (( obj continuation -- * )) call-effect-unsafe ;
: continue ( continuation -- * )
f swap continue-with ;
@@ -111,12 +110,9 @@ SYMBOL: return-continuation
[
[ [ { } like set-datastack ] dip call datastack ] dip
continue-with
- ] 3 (throw)
+ ] (( stack quot continuation -- * )) call-effect-unsafe
] callcc1 2nip ;
-: assert-depth ( quot -- )
- { } swap with-datastack { } assert= ; inline
-
GENERIC: compute-restarts ( error -- seq )
<PRIVATE
@@ -133,7 +129,7 @@ SYMBOL: thread-error-hook
dup save-error
catchstack* empty? [
thread-error-hook get-global
- [ 1 (throw) ] [ die ] if*
+ [ (( error -- * )) call-effect-unsafe ] [ die ] if*
] when
c> continue-with ;
diff --git a/core/effects/parser/parser.factor b/core/effects/parser/parser.factor
index a009db76b1..04dc42712c 100644
--- a/core/effects/parser/parser.factor
+++ b/core/effects/parser/parser.factor
@@ -1,4 +1,4 @@
-! Copyright (C) 2008 Slava Pestov.
+! Copyright (C) 2008, 2009 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: lexer sets sequences kernel splitting effects
combinators arrays parser ;
@@ -26,3 +26,6 @@ ERROR: bad-effect ;
: parse-effect ( end -- effect )
parse-effect-tokens { "--" } split1 dup
[ <effect> ] [ "Stack effect declaration must contain --" throw ] if ;
+
+: parse-call( ( accum word -- accum )
+ [ ")" parse-effect parsed ] dip parsed ;
\ No newline at end of file
diff --git a/core/kernel/kernel.factor b/core/kernel/kernel.factor
index cf4bf95db9..52529892f4 100644
--- a/core/kernel/kernel.factor
+++ b/core/kernel/kernel.factor
@@ -22,6 +22,8 @@ DEFER: 3dip
! Combinators
GENERIC: call ( callable -- )
+GENERIC: execute ( word -- )
+
DEFER: if
: ? ( ? true false -- true/false )
@@ -235,7 +237,7 @@ GENERIC: boa ( ... class -- tuple )
! Error handling -- defined early so that other files can
! throw errors before continuations are loaded
-: throw ( error -- * ) 5 getenv [ die ] or 1 (throw) ;
+GENERIC: throw ( error -- * )
ERROR: assert got expect ;
diff --git a/core/parser/parser-tests.factor b/core/parser/parser-tests.factor
index 6b90abeced..adf1c8adcf 100644
--- a/core/parser/parser-tests.factor
+++ b/core/parser/parser-tests.factor
@@ -402,9 +402,7 @@ IN: parser.tests
[ t ] [ "foo" "parser.tests" lookup symbol? ] unit-test
] times
-[ "vocab:parser/test/assert-depth.factor" run-file ]
-[ got>> { 1 2 3 } sequence= ]
-must-fail-with
+[ "vocab:parser/test/assert-depth.factor" run-file ] must-fail
2 [
[ ] [
diff --git a/core/parser/parser.factor b/core/parser/parser.factor
index dddea09db9..1f4d377b27 100644
--- a/core/parser/parser.factor
+++ b/core/parser/parser.factor
@@ -1,11 +1,10 @@
-! Copyright (C) 2005, 2008 Slava Pestov.
+! Copyright (C) 2005, 2009 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: arrays definitions generic assocs kernel math namespaces
-sequences strings vectors words words.symbol quotations io
-combinators sorting splitting math.parser effects continuations
-io.files vocabs io.encodings.utf8 source-files
-classes hashtables compiler.errors compiler.units accessors sets
-lexer vocabs.parser slots ;
+sequences strings vectors words words.symbol quotations io combinators
+sorting splitting math.parser effects continuations io.files vocabs
+io.encodings.utf8 source-files classes hashtables compiler.errors
+compiler.units accessors sets lexer vocabs.parser slots ;
IN: parser
: location ( -- loc )
@@ -90,9 +89,9 @@ SYMBOL: auto-use?
ERROR: staging-violation word ;
-: execute-parsing ( word -- )
+: execute-parsing ( accum word -- accum )
dup changed-definitions get key? [ staging-violation ] when
- execute ;
+ execute( accum -- accum ) ;
: scan-object ( -- object )
scan-word dup parsing-word?
@@ -125,7 +124,7 @@ M: f parse-quotation \ ] parse-until >quotation ;
[ f parse-until >quotation ] with-lexer ;
: parse-lines ( lines -- quot )
- lexer-factory get call (parse-lines) ;
+ lexer-factory get call( lines -- lexer ) (parse-lines) ;
: parse-literal ( accum end quot -- accum )
[ parse-until ] dip call parsed ; inline
@@ -214,7 +213,7 @@ print-use-hook [ [ ] ] initialize
[
V{ } clone amended-use set
parse-lines
- amended-use get empty? [ print-use-hook get assert-depth ] unless
+ amended-use get empty? [ print-use-hook get call( -- ) ] unless
] with-file-vocabs ;
: parsing-file ( file -- )
@@ -288,7 +287,7 @@ print-use-hook [ [ ] ] initialize
] recover ;
: run-file ( file -- )
- [ parse-file call ] curry assert-depth ;
+ parse-file call( -- ) ;
: ?run-file ( path -- )
dup exists? [ run-file ] [ drop ] if ;
diff --git a/core/strings/parser/parser.factor b/core/strings/parser/parser.factor
index 8c9d0b5557..c6e58f659a 100644
--- a/core/strings/parser/parser.factor
+++ b/core/strings/parser/parser.factor
@@ -29,7 +29,7 @@ name>char-hook [
: unicode-escape ( str -- ch str' )
"{" ?head-slice [
CHAR: } over index cut-slice
- [ >string name>char-hook get call ] dip
+ [ >string name>char-hook get call( name -- char ) ] dip
rest-slice
] [
6 cut-slice [ hex> ] dip
@@ -45,10 +45,10 @@ name>char-hook [
: (parse-string) ( str -- m )
dup [ "\"\\" member? ] find dup [
[ cut-slice [ % ] dip rest-slice ] dip
- dup CHAR: " = [
- drop from>>
+ CHAR: " = [
+ from>>
] [
- drop next-escape [ , ] dip (parse-string)
+ next-escape [ , ] dip (parse-string)
] if
] [
"Unterminated string" throw
@@ -59,8 +59,8 @@ name>char-hook [
[ swap tail-slice (parse-string) ] "" make swap
] change-lexer-column ;
-: (unescape-string) ( str -- str' )
- dup [ CHAR: \\ = ] find [
+: (unescape-string) ( str -- )
+ CHAR: \\ over index dup [
cut-slice [ % ] dip rest-slice
next-escape [ , ] dip
(unescape-string)
diff --git a/core/syntax/syntax-docs.factor b/core/syntax/syntax-docs.factor
index 25b963c574..1a61845fd1 100644
--- a/core/syntax/syntax-docs.factor
+++ b/core/syntax/syntax-docs.factor
@@ -770,3 +770,13 @@ HELP: call-next-method
{ POSTPONE: call-next-method (call-next-method) next-method } related-words
{ POSTPONE: << POSTPONE: >> } related-words
+
+HELP: call(
+{ $syntax "call( stack -- effect )" }
+{ $description "Calls the quotation on the top of the stack, asserting that it has the given stack effect. The quotation does not need to be known at compile time." } ;
+
+HELP: execute(
+{ $syntax "execute( stack -- effect )" }
+{ $description "Calls the word on the top of the stack, asserting that it has the given stack effect. The word does not need to be known at compile time." } ;
+
+{ POSTPONE: call( POSTPONE: execute( } related-words
\ No newline at end of file
diff --git a/core/syntax/syntax.factor b/core/syntax/syntax.factor
index de3be98ceb..f6d124d8da 100644
--- a/core/syntax/syntax.factor
+++ b/core/syntax/syntax.factor
@@ -1,4 +1,4 @@
-! Copyright (C) 2004, 2008 Slava Pestov.
+! Copyright (C) 2004, 2009 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: accessors alien arrays byte-arrays definitions generic
hashtables kernel math namespaces parser lexer sequences strings
@@ -246,4 +246,8 @@ IN: bootstrap.syntax
"initial:" "syntax" lookup define-symbol
"read-only" "syntax" lookup define-symbol
+
+ "call(" [ \ call-effect parse-call( ] define-syntax
+
+ "execute(" [ \ execute-effect parse-call( ] define-syntax
] with-compilation-unit
diff --git a/core/vocabs/loader/loader.factor b/core/vocabs/loader/loader.factor
index 00c4df92a6..df6d2d02a7 100644
--- a/core/vocabs/loader/loader.factor
+++ b/core/vocabs/loader/loader.factor
@@ -64,7 +64,7 @@ SYMBOL: load-help?
+parsing+ >>source-loaded?
dup vocab-source-path [ parse-file ] [ [ ] ] if*
[ +parsing+ >>source-loaded? ] dip
- [ % ] [ assert-depth ] if-bootstrapping
+ [ % ] [ call( -- ) ] if-bootstrapping
+done+ >>source-loaded? drop
] [ ] [ f >>source-loaded? ] cleanup ;
diff --git a/core/vocabs/vocabs.factor b/core/vocabs/vocabs.factor
index 977eac2b35..b9f38dfef3 100644
--- a/core/vocabs/vocabs.factor
+++ b/core/vocabs/vocabs.factor
@@ -105,4 +105,4 @@ M: vocab-spec forget* forget-vocab ;
SYMBOL: load-vocab-hook ! ( name -- vocab )
-: load-vocab ( name -- vocab ) load-vocab-hook get call ;
\ No newline at end of file
+: load-vocab ( name -- vocab ) load-vocab-hook get call( name -- vocab ) ;
\ No newline at end of file
diff --git a/core/words/words.factor b/core/words/words.factor
index cd11fb2db1..c4a94f0a4c 100755
--- a/core/words/words.factor
+++ b/core/words/words.factor
@@ -1,4 +1,4 @@
-! Copyright (C) 2004, 2008 Slava Pestov.
+! Copyright (C) 2004, 2009 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: accessors arrays definitions graphs assocs kernel
kernel.private slots.private math namespaces sequences strings
@@ -10,8 +10,6 @@ IN: words
: set-word ( word -- ) \ word set-global ;
-GENERIC: execute ( word -- )
-
M: word execute (execute) ;
M: word <=>
diff --git a/extra/4DNav/4DNav.factor b/extra/4DNav/4DNav.factor
index f6c00154bb..ee37b33fbf 100755
--- a/extra/4DNav/4DNav.factor
+++ b/extra/4DNav/4DNav.factor
@@ -17,7 +17,6 @@ colors
colors.constants
prettyprint
vars
-call
quotations
io
io.directories
diff --git a/extra/monads/monads-tests.factor b/extra/monads/monads-tests.factor
index 44234bc4bc..ee63b14f3c 100644
--- a/extra/monads/monads-tests.factor
+++ b/extra/monads/monads-tests.factor
@@ -79,7 +79,7 @@ IN: monads.tests
LAZY: nats-from ( n -- list )
dup 1+ nats-from cons ;
-: nats 0 nats-from ;
+: nats ( -- list ) 0 nats-from ;
[ 3 ] [
{
diff --git a/extra/monads/monads.factor b/extra/monads/monads.factor
index e9ae167532..6b35772596 100644
--- a/extra/monads/monads.factor
+++ b/extra/monads/monads.factor
@@ -6,7 +6,7 @@ shuffle ;
IN: monads
! Functors
-GENERIC# fmap 1 ( functor quot -- functor' ) inline
+GENERIC# fmap 1 ( functor quot -- functor' )
! Monads
@@ -21,7 +21,7 @@ GENERIC: >>= ( mvalue -- quot )
M: monad return monad-of return ;
M: monad fail monad-of fail ;
-: bind ( mvalue quot -- mvalue' ) swap >>= call ;
+: bind ( mvalue quot -- mvalue' ) swap >>= call( quot -- mvalue ) ;
: >> ( mvalue k -- mvalue' ) '[ drop _ ] bind ;
:: lift-m2 ( m1 m2 f monad -- m3 )
@@ -30,14 +30,14 @@ M: monad fail monad-of fail ;
:: apply ( mvalue mquot monad -- result )
mvalue [| value |
mquot [| quot |
- value quot call monad return
+ value quot call( value -- mvalue ) monad return
] bind
] bind ;
M: monad fmap over '[ @ _ return ] bind ;
! 'do' notation
-: do ( quots -- result ) unclip dip [ bind ] each ;
+: do ( quots -- result ) unclip [ call( -- mvalue ) ] curry dip [ bind ] each ;
! Identity
SINGLETON: identity-monad
@@ -51,7 +51,7 @@ M: identity monad-of drop identity-monad ;
M: identity-monad return drop identity boa ;
M: identity-monad fail "Fail" throw ;
-M: identity >>= value>> '[ _ swap call ] ;
+M: identity >>= value>> '[ _ swap call( x -- y ) ] ;
: run-identity ( identity -- value ) value>> ;
@@ -73,7 +73,7 @@ M: maybe-monad return drop just ;
M: maybe-monad fail 2drop nothing ;
M: nothing >>= '[ drop _ ] ;
-M: just >>= value>> '[ _ swap call ] ;
+M: just >>= value>> '[ _ swap call( x -- y ) ] ;
: if-maybe ( maybe just-quot nothing-quot -- )
pick nothing? [ 2nip call ] [ drop [ value>> ] dip call ] if ; inline
@@ -97,7 +97,7 @@ M: either-monad return drop right ;
M: either-monad fail drop left ;
M: left >>= '[ drop _ ] ;
-M: right >>= value>> '[ _ swap call ] ;
+M: right >>= value>> '[ _ swap call( x -- y ) ] ;
: if-either ( value left-quot right-quot -- )
[ [ value>> ] [ left? ] bi ] 2dip if ; inline
@@ -140,14 +140,14 @@ M: state monad-of drop state-monad ;
M: state-monad return drop '[ _ 2array ] state ;
M: state-monad fail "Fail" throw ;
-: mcall ( state -- ) quot>> call ;
+: mcall ( x state -- y ) quot>> call( x -- y ) ;
M: state >>= '[ _ swap '[ _ mcall first2 @ mcall ] state ] ;
: get-st ( -- state ) [ dup 2array ] state ;
: put-st ( value -- state ) '[ drop _ f 2array ] state ;
-: run-st ( state initial -- ) swap mcall second ;
+: run-st ( state initial -- value ) swap mcall second ;
: return-st ( value -- mvalue ) state-monad return ;
@@ -166,7 +166,7 @@ M: reader-monad fail "Fail" throw ;
M: reader >>= '[ _ swap '[ dup _ mcall @ mcall ] reader ] ;
-: run-reader ( reader env -- ) swap mcall ;
+: run-reader ( reader env -- value ) swap quot>> call( env -- value ) ;
: ask ( -- reader ) [ ] reader ;
: local ( reader quot -- reader' ) swap '[ @ _ mcall ] reader ;
@@ -187,6 +187,6 @@ M: writer-monad fail "Fail" throw ;
M: writer >>= '[ [ _ run-writer ] dip '[ @ run-writer ] dip append writer ] ;
-: pass ( writer -- writer' ) run-writer [ first2 ] dip swap call writer ;
+: pass ( writer -- writer' ) run-writer [ first2 ] dip swap call( x -- y ) writer ;
: listen ( writer -- writer' ) run-writer [ 2array ] keep writer ;
: tell ( seq -- writer ) f swap writer ;
diff --git a/extra/promises/promises.factor b/extra/promises/promises.factor
index bec2761e53..0e193741eb 100755
--- a/extra/promises/promises.factor
+++ b/extra/promises/promises.factor
@@ -1,6 +1,6 @@
! Copyright (C) 2004, 2006 Chris Double, Matthew Willis.
! See http://factorcode.org/license.txt for BSD license.
-USING: arrays kernel sequences math vectors arrays namespaces call
+USING: arrays kernel sequences math vectors arrays namespaces
make quotations parser effects stack-checker words accessors ;
IN: promises
diff --git a/extra/ui/gadgets/lists/lists.factor b/extra/ui/gadgets/lists/lists.factor
index 982aabe2e8..d7301ca042 100644
--- a/extra/ui/gadgets/lists/lists.factor
+++ b/extra/ui/gadgets/lists/lists.factor
@@ -1,7 +1,7 @@
! Copyright (C) 2006, 2009 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: accessors math.vectors classes.tuple math.rectangles colors
-kernel sequences models opengl math math.order namespaces call
+kernel sequences models opengl math math.order namespaces
ui.commands ui.gestures ui.render ui.gadgets ui.gadgets.labels
ui.gadgets.scrollers ui.gadgets.presentations ui.gadgets.viewports
ui.gadgets.packs ;
diff --git a/vm/cpu-x86.32.S b/vm/cpu-x86.32.S
index 36db5d6c80..7a8e579c62 100755
--- a/vm/cpu-x86.32.S
+++ b/vm/cpu-x86.32.S
@@ -29,7 +29,7 @@ and the callstack top is passed in EDX */
pop %ebp ; \
pop %ebx
-#define QUOT_XT_OFFSET 9
+#define QUOT_XT_OFFSET 17
/* We pass a function pointer to memcpy to work around a Mac OS X
ABI limitation which would otherwise require us to do a bizzaro PC-relative
diff --git a/vm/cpu-x86.64.S b/vm/cpu-x86.64.S
index 7b5b5f3167..8cf8fb9ae7 100644
--- a/vm/cpu-x86.64.S
+++ b/vm/cpu-x86.64.S
@@ -61,7 +61,7 @@
#endif
-#define QUOT_XT_OFFSET 21
+#define QUOT_XT_OFFSET 37
/* We pass a function pointer to memcpy to work around a Mac OS X
ABI limitation which would otherwise require us to do a bizzaro PC-relative
diff --git a/vm/errors.c b/vm/errors.c
index 7c06ec1310..9b7b7843d2 100755
--- a/vm/errors.c
+++ b/vm/errors.c
@@ -144,12 +144,6 @@ void misc_signal_handler_impl(void)
signal_error(signal_number,signal_callstack_top);
}
-void primitive_throw(void)
-{
- dpop();
- throw_impl(dpop(),stack_chain->callstack_top);
-}
-
void primitive_call_clear(void)
{
throw_impl(dpop(),stack_chain->callstack_bottom);
diff --git a/vm/errors.h b/vm/errors.h
index c7f8bc8712..da3ee8bbe0 100755
--- a/vm/errors.h
+++ b/vm/errors.h
@@ -32,7 +32,6 @@ void signal_error(int signal, F_STACK_FRAME *native_stack);
void type_error(CELL type, CELL tagged);
void not_implemented_error(void);
-void primitive_throw(void);
void primitive_call_clear(void);
INLINE void type_check(CELL type, CELL tagged)
diff --git a/vm/layouts.h b/vm/layouts.h
index 94e2f623a3..5b417f92dd 100755
--- a/vm/layouts.h
+++ b/vm/layouts.h
@@ -172,6 +172,10 @@ typedef struct {
CELL array;
/* tagged */
CELL compiledp;
+ /* tagged */
+ CELL cached_effect;
+ /* tagged */
+ CELL cache_counter;
/* UNTAGGED */
XT xt;
/* UNTAGGED compiled code block */
diff --git a/vm/primitives.c b/vm/primitives.c
index 82b0555894..00103ac047 100755
--- a/vm/primitives.c
+++ b/vm/primitives.c
@@ -102,7 +102,6 @@ void *primitives[] = {
primitive_set_alien_double,
primitive_alien_cell,
primitive_set_alien_cell,
- primitive_throw,
primitive_alien_address,
primitive_set_slot,
primitive_string_nth,
diff --git a/vm/quotations.c b/vm/quotations.c
index ca1a8bb3b5..8ea2d5839b 100755
--- a/vm/quotations.c
+++ b/vm/quotations.c
@@ -514,6 +514,8 @@ void primitive_array_to_quotation(void)
quot->array = dpeek();
quot->xt = lazy_jit_compile;
quot->compiledp = F;
+ quot->cached_effect = F;
+ quot->cache_counter = F;
drepl(tag_object(quot));
}
From 135f3bfc7f3eb4d252a3cdcc26cfdff96437548f Mon Sep 17 00:00:00 2001
From: Slava Pestov <slava@slava-pestovs-macbook-pro.local>
Date: Mon, 16 Mar 2009 20:48:56 -0500
Subject: [PATCH 08/15] Fix bootstrap
---
basis/tools/deploy/deploy-docs.factor | 2 +-
1 file changed, 1 insertion(+), 1 deletion(-)
diff --git a/basis/tools/deploy/deploy-docs.factor b/basis/tools/deploy/deploy-docs.factor
index 2db53f2292..4c03047eb8 100644
--- a/basis/tools/deploy/deploy-docs.factor
+++ b/basis/tools/deploy/deploy-docs.factor
@@ -28,7 +28,7 @@ ARTICLE: "tools.deploy.caveats" "Deploy tool caveats"
{ $heading "Behavior of " { $link boa } }
"In deployed applications, the " { $link boa } " word does not verify that the parameters on the stack satisfy the tuple's slot declarations, if any. This reduces deploy image size but can make bugs harder to track down. Make sure your program is fully debugged before deployment."
{ $heading "Behavior of " { $link POSTPONE: execute( } }
-"Similarly, the " { $link POSTPONE: execute( } " word does not check word stack effects in deployed applications, since stack effects are stripped out, and so it behaves exactly like " { $link POSTPONE: execute-unsafe( } "."
+"Similarly, the " { $link POSTPONE: execute( } " word does not check word stack effects in deployed applications, since stack effects are stripped out, and so it behaves exactly like " { $link POSTPONE: execute-effect-unsafe } "."
{ $heading "Error reporting" }
"If the " { $link deploy-reflection } " level in the configuration is low enough, the debugger is stripped out, and error messages can be rather cryptic. Increase the reflection level to get readable error messages."
{ $heading "Choosing the right deploy flags" }
From ead345295702f81f7d6fc70e567f0a6d37570b33 Mon Sep 17 00:00:00 2001
From: Slava Pestov <slava@slava-pestovs-macbook-pro.local>
Date: Mon, 16 Mar 2009 20:49:09 -0500
Subject: [PATCH 09/15] Fix walker
---
basis/ui/tools/walker/walker.factor | 2 +-
1 file changed, 1 insertion(+), 1 deletion(-)
diff --git a/basis/ui/tools/walker/walker.factor b/basis/ui/tools/walker/walker.factor
index 1f427d9405..6728fb8338 100644
--- a/basis/ui/tools/walker/walker.factor
+++ b/basis/ui/tools/walker/walker.factor
@@ -105,5 +105,5 @@ walker-gadget "multitouch" f {
[
dup find-walker-window dup
- [ raise-window 3drop ] [ drop [ walker-window ] with-ui ] if
+ [ raise-window 3drop ] [ drop '[ _ _ _ walker-window ] with-ui ] if
] show-walker-hook set-global
From bdec3951307141084479dc2596b430d775f89f33 Mon Sep 17 00:00:00 2001
From: Slava Pestov <slava@slava-pestovs-macbook-pro.local>
Date: Mon, 16 Mar 2009 20:49:19 -0500
Subject: [PATCH 10/15] Remove predicate-instance? hack; use call( instead
---
core/bootstrap/primitives.factor | 3 --
core/classes/predicate/predicate-tests.factor | 8 +----
core/classes/predicate/predicate.factor | 29 ++++---------------
3 files changed, 7 insertions(+), 33 deletions(-)
diff --git a/core/bootstrap/primitives.factor b/core/bootstrap/primitives.factor
index 5ad693bc86..48aae3667e 100644
--- a/core/bootstrap/primitives.factor
+++ b/core/bootstrap/primitives.factor
@@ -140,9 +140,6 @@ bootstrapping? on
"word" "words" create register-builtin
"byte-array" "byte-arrays" create register-builtin
-! For predicate classes
-"predicate-instance?" "classes.predicate" create drop
-
! We need this before defining c-ptr below
"f" "syntax" lookup { } define-builtin
diff --git a/core/classes/predicate/predicate-tests.factor b/core/classes/predicate/predicate-tests.factor
index d4c929a69b..a947b9ddc0 100644
--- a/core/classes/predicate/predicate-tests.factor
+++ b/core/classes/predicate/predicate-tests.factor
@@ -18,10 +18,4 @@ M: positive abs ;
[ 10 ] [ -10 abs ] unit-test
[ 10 ] [ 10 abs ] unit-test
-[ 0 ] [ 0 abs ] unit-test
-
-PREDICATE: blah < word blah eq? ;
-
-[ f ] [ \ predicate-instance? "compiled-uses" word-prop keys \ blah swap memq? ] unit-test
-
-FORGET: blah
\ No newline at end of file
+[ 0 ] [ 0 abs ] unit-test
\ No newline at end of file
diff --git a/core/classes/predicate/predicate.factor b/core/classes/predicate/predicate.factor
index 7d757772f4..188a2ed794 100644
--- a/core/classes/predicate/predicate.factor
+++ b/core/classes/predicate/predicate.factor
@@ -1,4 +1,4 @@
-! Copyright (C) 2004, 2008 Slava Pestov.
+! Copyright (C) 2004, 2009 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: classes classes.algebra kernel namespaces make words
sequences quotations arrays kernel.private assocs combinators ;
@@ -7,21 +7,6 @@ IN: classes.predicate
PREDICATE: predicate-class < class
"metaclass" word-prop predicate-class eq? ;
-DEFER: predicate-instance? ( object class -- ? )
-
-: update-predicate-instance ( -- )
- \ predicate-instance? bootstrap-word
- classes [ predicate-class? ] filter [
- [ literalize ]
- [
- [ superclass 1array [ declare ] curry ]
- [ "predicate-definition" word-prop ]
- bi compose
- ]
- bi
- ] { } map>assoc [ case ] curry
- define ;
-
: predicate-quot ( class -- quot )
[
\ dup ,
@@ -38,19 +23,17 @@ DEFER: predicate-instance? ( object class -- ? )
[ dup predicate-quot define-predicate ]
[ update-classes ]
bi
- ]
- 3tri
- update-predicate-instance ;
+ ] 3tri ;
M: predicate-class reset-class
- [ call-next-method ] [ { "predicate-definition" } reset-props ] bi
- update-predicate-instance ;
+ [ call-next-method ] [ { "predicate-definition" } reset-props ] bi ;
M: predicate-class rank-class drop 1 ;
M: predicate-class instance?
- 2dup superclass instance?
- [ predicate-instance? ] [ 2drop f ] if ;
+ 2dup superclass instance? [
+ "predicate-definition" word-prop call( object -- ? )
+ ] [ 2drop f ] if ;
M: predicate-class (flatten-class)
superclass (flatten-class) ;
From e981090045615814716f8e3fae78c864c6a0726f Mon Sep 17 00:00:00 2001
From: Slava Pestov <slava@slava-pestovs-macbook-pro.local>
Date: Mon, 16 Mar 2009 23:02:55 -0500
Subject: [PATCH 11/15] Inline caching for call(
---
basis/stack-checker/call-effect/authors.txt | 1 +
.../call-effect/call-effect.factor | 91 +++++++++++++++++++
basis/stack-checker/stack-checker.factor | 6 +-
.../transforms/transforms.factor | 41 ---------
4 files changed, 96 insertions(+), 43 deletions(-)
create mode 100644 basis/stack-checker/call-effect/authors.txt
create mode 100644 basis/stack-checker/call-effect/call-effect.factor
diff --git a/basis/stack-checker/call-effect/authors.txt b/basis/stack-checker/call-effect/authors.txt
new file mode 100644
index 0000000000..d4f5d6b3ae
--- /dev/null
+++ b/basis/stack-checker/call-effect/authors.txt
@@ -0,0 +1 @@
+Slava Pestov
\ No newline at end of file
diff --git a/basis/stack-checker/call-effect/call-effect.factor b/basis/stack-checker/call-effect/call-effect.factor
new file mode 100644
index 0000000000..ef9a0305f6
--- /dev/null
+++ b/basis/stack-checker/call-effect/call-effect.factor
@@ -0,0 +1,91 @@
+! Copyright (C) 2009 Slava Pestov.
+! See http://factorcode.org/license.txt for BSD license.
+USING: accessors combinators combinators.private effects fry
+kernel kernel.private make sequences continuations
+stack-checker stack-checker.transforms ;
+IN: stack-checker.call-effect
+
+! call( and execute( have complex expansions.
+
+! call( uses the following strategy:
+! - Inline caching. If the quotation is the same as last time, just call it unsafely
+! - Effect inference. Infer quotation's effect, caching it in the cached-effect slot,
+! and compare it with declaration. If matches, call it unsafely.
+! - Fallback. If the above doesn't work, call it and compare the datastack before
+! and after to make sure it didn't mess anything up.
+
+! execute( uses a similar strategy.
+
+TUPLE: inline-cache value ;
+
+: cache-hit? ( word/quot ic -- ? ) value>> eq? ; inline
+
+SYMBOL: +failed+
+
+: cached-effect ( quot -- effect )
+ dup cached-effect>>
+ [ ] [
+ [ [ infer ] [ 2drop +failed+ ] recover dup ] keep
+ (>>cached-effect)
+ ] ?if ;
+
+: call-effect-unsafe? ( quot effect -- ? )
+ [ cached-effect ] dip
+ over +failed+ eq?
+ [ 2drop f ] [ effect<= ] if ; inline
+
+: (call-effect-slow>quot) ( in out effect -- quot )
+ [
+ [ [ datastack ] dip dip ] %
+ [ [ , ] bi@ \ check-datastack , ] dip
+ '[ _ wrong-values ] , \ unless ,
+ ] [ ] make ;
+
+: call-effect-slow>quot ( effect -- quot )
+ [ in>> length ] [ out>> length ] [ ] tri
+ [ (call-effect-slow>quot) ] keep add-effect-input
+ [ call-effect-unsafe ] 2curry ;
+
+: call-effect-slow ( quot effect -- ) drop call ;
+
+\ call-effect-slow [ call-effect-slow>quot ] 1 define-transform
+
+: call-effect-fast ( quot effect inline-cache -- )
+ 2over call-effect-unsafe?
+ [ [ nip (>>value) ] [ drop call-effect-unsafe ] 3bi ]
+ [ drop call-effect-slow ]
+ if ; inline
+
+\ call-effect [
+ inline-cache new '[
+ _
+ 3dup nip cache-hit? [
+ drop call-effect-unsafe
+ ] [
+ call-effect-fast
+ ] if
+ ]
+] 0 define-transform
+
+: execute-effect-slow ( word effect -- )
+ [ '[ _ execute ] ] dip call-effect-slow ; inline
+
+: execute-effect-unsafe? ( word effect -- ? )
+ over optimized>> [ [ stack-effect ] dip effect<= ] [ 2drop f ] if ; inline
+
+: execute-effect-fast ( word effect inline-cache -- )
+ 2over execute-effect-unsafe?
+ [ [ nip (>>value) ] [ drop execute-effect-unsafe ] 3bi ]
+ [ drop execute-effect-slow ]
+ if ; inline
+
+: execute-effect-ic ( word effect inline-cache -- )
+ 3dup nip cache-hit?
+ [ drop execute-effect-unsafe ]
+ [ execute-effect-fast ]
+ if ; inline
+
+: execute-effect>quot ( effect -- quot )
+ inline-cache new '[ _ _ execute-effect-ic ] ;
+
+\ execute-effect [ execute-effect>quot ] 1 define-transform
diff --git a/basis/stack-checker/stack-checker.factor b/basis/stack-checker/stack-checker.factor
index ff283ce9ca..e18a6f0840 100644
--- a/basis/stack-checker/stack-checker.factor
+++ b/basis/stack-checker/stack-checker.factor
@@ -1,7 +1,7 @@
-! Copyright (C) 2004, 2008 Slava Pestov.
+! Copyright (C) 2004, 2009 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: kernel io effects namespaces sequences quotations vocabs
-generic words stack-checker.backend stack-checker.state
+vocabs.loader generic words stack-checker.backend stack-checker.state
stack-checker.known-words stack-checker.transforms
stack-checker.errors stack-checker.inlining
stack-checker.visitor.dummy ;
@@ -28,3 +28,5 @@ M: callable infer ( quot -- effect )
dup subwords [ f "inferred-effect" set-word-prop ] each
f "inferred-effect" set-word-prop
] each ;
+
+"stack-checker.call-effect" require
\ No newline at end of file
diff --git a/basis/stack-checker/transforms/transforms.factor b/basis/stack-checker/transforms/transforms.factor
index 6c1d391490..3b783ce467 100755
--- a/basis/stack-checker/transforms/transforms.factor
+++ b/basis/stack-checker/transforms/transforms.factor
@@ -51,47 +51,6 @@ IN: stack-checker.transforms
[ nip "transform-n" set-word-prop ]
3bi ;
-! call( and execute(
-: (call-effect>quot) ( in out effect -- quot )
- [
- [ [ datastack ] dip dip ] %
- [ [ , ] bi@ \ check-datastack , ] dip
- '[ _ wrong-values ] , \ unless ,
- ] [ ] make ;
-
-: call-effect>quot ( effect -- quot )
- [ in>> length ] [ out>> length ] [ ] tri
- [ (call-effect>quot) ] keep add-effect-input
- [ call-effect-unsafe ] 2curry ;
-
-\ call-effect [ call-effect>quot ] 1 define-transform
-
-: execute-effect-slow ( word effect -- )
- [ '[ _ execute ] ] dip call-effect ; inline
-
-TUPLE: inline-cache value ;
-
-: cache-hit? ( word ic -- ? ) value>> eq? ; inline
-
-: cache-hit ( word effect ic -- ) drop execute-effect-unsafe ; inline
-
-: execute-effect-unsafe? ( word effect -- ? )
- over optimized>> [ [ stack-effect ] dip effect<= ] [ 2drop f ] if ; inline
-
-: cache-miss ( word effect ic -- )
- 2over execute-effect-unsafe?
- [ [ nip (>>value) ] [ drop execute-effect-unsafe ] 3bi ]
- [ drop execute-effect-slow ] if ; inline
-
-: execute-effect-ic ( word effect ic -- )
- #! ic is a mutable cell { effect }
- 3dup nip cache-hit? [ cache-hit ] [ cache-miss ] if ; inline
-
-: execute-effect>quot ( effect -- quot )
- inline-cache new '[ _ _ execute-effect-ic ] ;
-
-\ execute-effect [ execute-effect>quot ] 1 define-transform
-
! Combinators
\ cond [ cond>quot ] 1 define-transform
From 786475102d9767b810760f14df1265da802c9c07 Mon Sep 17 00:00:00 2001
From: Slava Pestov <slava@slava-pestovs-macbook-pro.local>
Date: Tue, 17 Mar 2009 02:19:50 -0500
Subject: [PATCH 12/15] Make more code infer
---
basis/bootstrap/stage2.factor | 2 +-
basis/cocoa/subclassing/subclassing.factor | 2 +-
basis/command-line/command-line.factor | 2 +-
basis/editors/editors.factor | 2 +-
basis/functors/functors.factor | 2 +-
basis/help/help.factor | 2 +-
basis/help/lint/lint.factor | 6 +++---
.../call-effect/call-effect-tests.factor | 7 +++++++
.../stack-checker/transforms/transforms-tests.factor | 11 +++--------
basis/threads/threads.factor | 2 +-
basis/tools/annotations/annotations.factor | 4 ++--
basis/tools/deploy/deploy-tests.factor | 9 ++++-----
basis/tools/test/test.factor | 2 +-
basis/tools/vocabs/browser/browser.factor | 6 +-----
basis/tr/tr.factor | 3 ++-
core/init/init.factor | 6 +++---
core/io/backend/backend.factor | 2 +-
core/syntax/syntax.factor | 4 ++--
core/vocabs/loader/loader.factor | 2 +-
19 files changed, 37 insertions(+), 39 deletions(-)
create mode 100644 basis/stack-checker/call-effect/call-effect-tests.factor
diff --git a/basis/bootstrap/stage2.factor b/basis/bootstrap/stage2.factor
index 070618ebb4..6c824b6155 100644
--- a/basis/bootstrap/stage2.factor
+++ b/basis/bootstrap/stage2.factor
@@ -30,7 +30,7 @@ SYMBOL: bootstrap-time
[ "bootstrap." prepend require ] each ;
: count-words ( pred -- )
- all-words swap count number>string write ;
+ all-words swap count number>string write ; inline
: print-time ( ms -- )
1000 /i
diff --git a/basis/cocoa/subclassing/subclassing.factor b/basis/cocoa/subclassing/subclassing.factor
index 394f45bef3..c3f1b471e0 100644
--- a/basis/cocoa/subclassing/subclassing.factor
+++ b/basis/cocoa/subclassing/subclassing.factor
@@ -8,7 +8,7 @@ IN: cocoa.subclassing
: init-method ( method -- sel imp types )
first3 swap
- [ sel_registerName ] [ execute ] [ utf8 string>alien ]
+ [ sel_registerName ] [ execute( -- xt ) ] [ utf8 string>alien ]
tri* ;
: throw-if-false ( obj what -- )
diff --git a/basis/command-line/command-line.factor b/basis/command-line/command-line.factor
index 38d40d8482..73a01aa352 100644
--- a/basis/command-line/command-line.factor
+++ b/basis/command-line/command-line.factor
@@ -54,7 +54,7 @@ SYMBOL: main-vocab-hook
embedded? [
"alien.remote-control"
] [
- main-vocab-hook get [ call ] [ "listener" ] if*
+ main-vocab-hook get [ call( -- vocab ) ] [ "listener" ] if*
] if ;
: default-cli-args ( -- )
diff --git a/basis/editors/editors.factor b/basis/editors/editors.factor
index d060a3dfe6..0003b508fb 100644
--- a/basis/editors/editors.factor
+++ b/basis/editors/editors.factor
@@ -28,7 +28,7 @@ SYMBOL: edit-hook
: edit-location ( file line -- )
[ (normalize-path) ] dip edit-hook get-global
- [ call ] [ no-edit-hook edit-location ] if* ;
+ [ call( file line -- ) ] [ no-edit-hook edit-location ] if* ;
ERROR: cannot-find-source definition ;
diff --git a/basis/functors/functors.factor b/basis/functors/functors.factor
index 6592a3c4f2..caa41d6c29 100644
--- a/basis/functors/functors.factor
+++ b/basis/functors/functors.factor
@@ -36,7 +36,7 @@ M: array fake-quotations> [ fake-quotations> ] map ;
M: object fake-quotations> ;
-: parse-definition* ( -- )
+: parse-definition* ( accum -- accum )
parse-definition >fake-quotations parsed \ fake-quotations> parsed ;
: DEFINE* ( accum -- accum ) effect get parsed \ define* parsed ;
diff --git a/basis/help/help.factor b/basis/help/help.factor
index d8629008d2..6fa4473d97 100644
--- a/basis/help/help.factor
+++ b/basis/help/help.factor
@@ -140,7 +140,7 @@ help-hook [ [ print-topic ] ] initialize
sort-articles [ \ $subsection swap 2array ] map print-element ;
: $index ( element -- )
- first call [ ($index) ] unless-empty ;
+ first call( -- seq ) [ ($index) ] unless-empty ;
: $about ( element -- )
first vocab-help [ 1array $subsection ] when* ;
diff --git a/basis/help/lint/lint.factor b/basis/help/lint/lint.factor
index 7942f90e0a..7ec8c59ba6 100755
--- a/basis/help/lint/lint.factor
+++ b/basis/help/lint/lint.factor
@@ -13,14 +13,14 @@ IN: help.lint
SYMBOL: vocabs-quot
: check-example ( element -- )
- [
- rest [
+ '[
+ _ rest [
but-last "\n" join
[ (eval>string) ] call( code -- output )
"\n" ?tail drop
] keep
peek assert=
- ] vocabs-quot get call ;
+ ] vocabs-quot get call( quot -- ) ;
: check-examples ( element -- )
\ $example swap elements [ check-example ] each ;
diff --git a/basis/stack-checker/call-effect/call-effect-tests.factor b/basis/stack-checker/call-effect/call-effect-tests.factor
new file mode 100644
index 0000000000..e5c0f23b30
--- /dev/null
+++ b/basis/stack-checker/call-effect/call-effect-tests.factor
@@ -0,0 +1,7 @@
+USING: stack-checker.call-effect tools.test math kernel ;
+IN: stack-checker.call-effect.tests
+
+[ t ] [ \ + (( a b -- c )) execute-effect-unsafe? ] unit-test
+[ t ] [ \ + (( a b c -- d e )) execute-effect-unsafe? ] unit-test
+[ f ] [ \ + (( a b c -- d )) execute-effect-unsafe? ] unit-test
+[ f ] [ \ call (( x -- )) execute-effect-unsafe? ] unit-test
\ No newline at end of file
diff --git a/basis/stack-checker/transforms/transforms-tests.factor b/basis/stack-checker/transforms/transforms-tests.factor
index 751e589c28..521cf9fcb7 100644
--- a/basis/stack-checker/transforms/transforms-tests.factor
+++ b/basis/stack-checker/transforms/transforms-tests.factor
@@ -3,8 +3,8 @@ USING: sequences stack-checker.transforms tools.test math kernel
quotations stack-checker accessors combinators words arrays
classes classes.tuple ;
-: compose-n-quot ( word -- quot' ) <repetition> >quotation ;
-: compose-n ( quot -- ) compose-n-quot call ;
+: compose-n-quot ( word n -- quot' ) <repetition> >quotation ;
+: compose-n ( quot n -- ) compose-n-quot call ;
\ compose-n [ compose-n-quot ] 2 define-transform
: compose-n-test ( a b c -- x ) 2 \ + compose-n ;
@@ -65,9 +65,4 @@ DEFER: curry-folding-test ( quot -- )
{ 3 0 } [ [ 1 2 3 ] curry-folding-test ] must-infer-as
{ 3 0 } [ 1 [ 2 3 ] curry curry-folding-test ] must-infer-as
-{ 3 0 } [ [ 1 2 ] 3 [ ] curry compose curry-folding-test ] must-infer-as
-
-[ t ] [ \ + (( a b -- c )) execute-effect-unsafe? ] unit-test
-[ t ] [ \ + (( a b c -- d e )) execute-effect-unsafe? ] unit-test
-[ f ] [ \ + (( a b c -- d )) execute-effect-unsafe? ] unit-test
-[ f ] [ \ call (( x -- )) execute-effect-unsafe? ] unit-test
\ No newline at end of file
+{ 3 0 } [ [ 1 2 ] 3 [ ] curry compose curry-folding-test ] must-infer-as
\ No newline at end of file
diff --git a/basis/threads/threads.factor b/basis/threads/threads.factor
index 1f25c0e031..cacc628e2a 100644
--- a/basis/threads/threads.factor
+++ b/basis/threads/threads.factor
@@ -160,7 +160,7 @@ DEFER: next
PRIVATE>
: stop ( -- )
- self [ exit-handler>> call ] [ unregister-thread ] bi next ;
+ self [ exit-handler>> call( -- ) ] [ unregister-thread ] bi next ;
: suspend ( quot state -- obj )
[
diff --git a/basis/tools/annotations/annotations.factor b/basis/tools/annotations/annotations.factor
index 293a22d2bb..8c3d95f2b8 100644
--- a/basis/tools/annotations/annotations.factor
+++ b/basis/tools/annotations/annotations.factor
@@ -39,13 +39,13 @@ ERROR: cannot-annotate-twice word ;
dup def>> "unannotated-def" set-word-prop ;
: (annotate) ( word quot -- )
- [ dup def>> ] dip call define ; inline
+ [ dup def>> ] dip call( old -- new ) define ;
PRIVATE>
: annotate ( word quot -- )
[ method-spec>word check-annotate-twice ] dip
- [ over save-unannotated-def (annotate) ] with-compilation-unit ; inline
+ [ over save-unannotated-def (annotate) ] with-compilation-unit ;
<PRIVATE
diff --git a/basis/tools/deploy/deploy-tests.factor b/basis/tools/deploy/deploy-tests.factor
index 40c4ae5721..3a2f960fc9 100644
--- a/basis/tools/deploy/deploy-tests.factor
+++ b/basis/tools/deploy/deploy-tests.factor
@@ -1,10 +1,9 @@
IN: tools.deploy.tests
USING: tools.test system io.pathnames io.files io.files.info
-io.files.temp kernel tools.deploy.config
-tools.deploy.config.editor tools.deploy.backend math sequences
-io.launcher arrays namespaces continuations layouts accessors
-io.encodings.ascii urls math.parser io.directories
-tools.deploy.test ;
+io.files.temp kernel tools.deploy.config tools.deploy.config.editor
+tools.deploy.backend math sequences io.launcher arrays namespaces
+continuations layouts accessors io.encodings.ascii urls math.parser
+io.directories tools.deploy.test ;
[ t ] [ "hello-world" shake-and-bake 500000 small-enough? ] unit-test
diff --git a/basis/tools/test/test.factor b/basis/tools/test/test.factor
index 704a7f1bd5..c6dea08d18 100644
--- a/basis/tools/test/test.factor
+++ b/basis/tools/test/test.factor
@@ -23,7 +23,7 @@ SYMBOL: this-test
[ this-test get failure ] recover
] [
call
- ] if ;
+ ] if ; inline
: unit-test ( output input -- )
[ 2array ] 2keep '[
diff --git a/basis/tools/vocabs/browser/browser.factor b/basis/tools/vocabs/browser/browser.factor
index 6a3f2df8a3..c9ade7aae2 100644
--- a/basis/tools/vocabs/browser/browser.factor
+++ b/basis/tools/vocabs/browser/browser.factor
@@ -244,11 +244,7 @@ C: <vocab-author> vocab-author
} cleave ;
: keyed-vocabs ( str quot -- seq )
- all-vocabs [
- swap [
- [ [ 2dup ] dip swap call member? ] filter
- ] dip swap
- ] assoc-map 2nip ; inline
+ [ all-vocabs ] 2dip '[ [ _ swap @ member? ] filter ] assoc-map ; inline
: tagged ( tag -- assoc )
[ vocab-tags ] keyed-vocabs ;
diff --git a/basis/tr/tr.factor b/basis/tr/tr.factor
index ce535f335a..66c0276055 100644
--- a/basis/tr/tr.factor
+++ b/basis/tr/tr.factor
@@ -17,7 +17,8 @@ M: bad-tr summary
[ [ ascii? ] all? ] both? [ bad-tr ] unless ;
: compute-tr ( quot from to -- mapping )
- zip [ 128 ] 2dip '[ [ @ _ at ] keep or ] B{ } map-as ; inline
+ [ 128 ] 3dip zip
+ '[ [ _ call( x -- y ) _ at ] keep or ] B{ } map-as ; inline
: tr-hints ( word -- )
{ { byte-array } { string } } "specializer" set-word-prop ;
diff --git a/core/init/init.factor b/core/init/init.factor
index 953340b985..5d8e88b85f 100644
--- a/core/init/init.factor
+++ b/core/init/init.factor
@@ -1,4 +1,4 @@
-! Copyright (C) 2004, 2008 Slava Pestov.
+! Copyright (C) 2004, 2009 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: continuations continuations.private kernel
kernel.private sequences assocs namespaces namespaces.private ;
@@ -9,10 +9,10 @@ SYMBOL: init-hooks
init-hooks global [ drop V{ } clone ] cache drop
: do-init-hooks ( -- )
- init-hooks get [ nip call ] assoc-each ;
+ init-hooks get [ nip call( -- ) ] assoc-each ;
: add-init-hook ( quot name -- )
- dup init-hooks get at [ over call ] unless
+ dup init-hooks get at [ over call( -- ) ] unless
init-hooks get set-at ;
: boot ( -- ) init-namespaces init-catchstack init-error-handler ;
diff --git a/core/io/backend/backend.factor b/core/io/backend/backend.factor
index 2f0bb1063f..4c91a519c6 100644
--- a/core/io/backend/backend.factor
+++ b/core/io/backend/backend.factor
@@ -39,7 +39,7 @@ M: object normalize-directory normalize-path ;
: set-io-backend ( io-backend -- )
io-backend set-global init-io init-stdio
- "io.files" init-hooks get at call ;
+ "io.files" init-hooks get at call( -- ) ;
! Note that we have 'alien' in our using list so that the alien
! init hook runs before this one.
diff --git a/core/syntax/syntax.factor b/core/syntax/syntax.factor
index f6d124d8da..d01a9ebb2c 100644
--- a/core/syntax/syntax.factor
+++ b/core/syntax/syntax.factor
@@ -80,7 +80,7 @@ IN: bootstrap.syntax
scan {
{ [ dup length 1 = ] [ first ] }
{ [ "\\" ?head ] [ next-escape >string "" assert= ] }
- [ name>char-hook get call ]
+ [ name>char-hook get call( name -- char ) ]
} cond parsed
] define-syntax
@@ -231,7 +231,7 @@ IN: bootstrap.syntax
"<<" [
[
\ >> parse-until >quotation
- ] with-nested-compilation-unit call
+ ] with-nested-compilation-unit call( -- )
] define-syntax
"call-next-method" [
diff --git a/core/vocabs/loader/loader.factor b/core/vocabs/loader/loader.factor
index df6d2d02a7..4f9005e110 100644
--- a/core/vocabs/loader/loader.factor
+++ b/core/vocabs/loader/loader.factor
@@ -90,7 +90,7 @@ PRIVATE>
: run ( vocab -- )
dup load-vocab vocab-main [
- execute
+ execute( -- )
] [
"The " write vocab-name write
" vocabulary does not define an entry point." print
From 0820734749df5b383d4dd4ea58ca542e291bf326 Mon Sep 17 00:00:00 2001
From: Doug Coleman <doug.coleman@gmail.com>
Date: Tue, 17 Mar 2009 15:03:01 -0500
Subject: [PATCH 13/15] serial library works with the null modem -- add some
standard ports for future reference
---
extra/io/serial/unix/unix-tests.factor | 5 ++++-
1 file changed, 4 insertions(+), 1 deletion(-)
diff --git a/extra/io/serial/unix/unix-tests.factor b/extra/io/serial/unix/unix-tests.factor
index e9b8d78e4b..f4c0c6b45a 100644
--- a/extra/io/serial/unix/unix-tests.factor
+++ b/extra/io/serial/unix/unix-tests.factor
@@ -5,7 +5,10 @@ IN: io.serial.unix
: serial-obj ( -- obj )
serial new
- "/dev/ttyS0" >>path
+ "/dev/ttyS0" >>path ! linux
+ ! "/dev/dty00" >>path ! netbsd
+ ! "/dev/ttyd0" >>path ! freebsd
+ ! "/dev/ttyU0" >>path ! openbsd
19200 >>baud
{ IGNPAR ICRNL } flags >>iflag
{ } flags >>oflag
From 2b458476493495eaed21fe4a99d47ef0c7c1ce05 Mon Sep 17 00:00:00 2001
From: Joe Groff <arcata@gmail.com>
Date: Tue, 17 Mar 2009 16:18:56 -0500
Subject: [PATCH 14/15] linear algebra fail
---
.../affine-transforms-tests.factor | 6 ++++++
.../affine-transforms.factor | 20 +++++++++----------
extra/svg/svg-tests.factor | 17 ++++++++++------
3 files changed, 27 insertions(+), 16 deletions(-)
diff --git a/extra/math/affine-transforms/affine-transforms-tests.factor b/extra/math/affine-transforms/affine-transforms-tests.factor
index 1d10e07cea..cdbd5eef39 100644
--- a/extra/math/affine-transforms/affine-transforms-tests.factor
+++ b/extra/math/affine-transforms/affine-transforms-tests.factor
@@ -33,6 +33,12 @@ IN: math.affine-transforms.tests
dup inverse-transform a.
] unit-test
+{ 2.0 -1.0 } { -1.0 -2.0 } { 5.0 -6.0 } <affine-transform> 1array [
+ { 1.0 0.0 } { 0.0 -1.0 } { 0.0 0.0 } <affine-transform>
+ { 2.0 1.0 } { -1.0 2.0 } { 5.0 6.0 } <affine-transform>
+ a.
+] unit-test
+
[ t ] [
{ 0.01 0.02 } { 0.03 0.04 } { 0.05 0.06 } <affine-transform>
{ 0.011 0.021 } { 0.031 0.041 } { 0.051 0.061 } <affine-transform> 0.01 a~
diff --git a/extra/math/affine-transforms/affine-transforms.factor b/extra/math/affine-transforms/affine-transforms.factor
index 132082fdba..20b73ba678 100644
--- a/extra/math/affine-transforms/affine-transforms.factor
+++ b/extra/math/affine-transforms/affine-transforms.factor
@@ -3,13 +3,13 @@ USING: accessors arrays combinators combinators.short-circuit kernel math math.v
math.functions sequences ;
IN: math.affine-transforms
-TUPLE: affine-transform x y origin ;
+TUPLE: affine-transform { x read-only } { y read-only } { origin read-only } ;
C: <affine-transform> affine-transform
CONSTANT: identity-transform T{ affine-transform f { 1.0 0.0 } { 0.0 1.0 } { 0.0 0.0 } }
: axes ( a -- a' )
- clone { 0.0 0.0 } >>origin ;
+ [ x>> ] [ y>> ] bi { 0.0 0.0 } <affine-transform> ;
: a.v ( a v -- v )
[ [ x>> ] [ first ] bi* v*n ]
@@ -26,7 +26,7 @@ CONSTANT: identity-transform T{ affine-transform f { 1.0 0.0 } { 0.0 1.0 } { 0.0
[ 0.0 2array ] [ 0.0 swap 2array ] bi* { 0.0 0.0 } <affine-transform> ;
: center-rotation ( transform center -- transform )
- [ clone dup ] dip [ vneg a.v ] [ v+ ] bi >>origin ;
+ [ [ x>> ] [ y>> ] [ ] tri ] dip [ vneg a.v ] [ v+ ] bi <affine-transform> ;
: flatten-transform ( transform -- array )
[ x>> ] [ y>> ] [ origin>> ] tri 3append ;
@@ -45,8 +45,8 @@ CONSTANT: identity-transform T{ affine-transform f { 1.0 0.0 } { 0.0 1.0 } { 0.0
(inverted-axes) { 0.0 0.0 } <affine-transform> ;
: inverse-transform ( a -- a^-1 )
- [ inverse-axes dup ] [ origin>> ] bi
- a.v vneg >>origin ;
+ [ inverse-axes [ x>> ] [ y>> ] [ ] tri ] [ origin>> ] bi
+ a.v vneg <affine-transform> ;
: transpose-axes ( a -- a^T )
[ [ x>> first ] [ y>> first ] bi 2array ]
@@ -54,11 +54,11 @@ CONSTANT: identity-transform T{ affine-transform f { 1.0 0.0 } { 0.0 1.0 } { 0.0
[ origin>> ] tri <affine-transform> ;
: a. ( a a -- a )
- transpose-axes {
- [ [ x>> ] [ x>> ] bi* v. ]
- [ [ x>> ] [ y>> ] bi* v. ]
- [ [ y>> ] [ x>> ] bi* v. ]
- [ [ y>> ] [ y>> ] bi* v. ]
+ {
+ [ [ transpose-axes x>> ] [ x>> ] bi* v. ]
+ [ [ transpose-axes y>> ] [ x>> ] bi* v. ]
+ [ [ transpose-axes x>> ] [ y>> ] bi* v. ]
+ [ [ transpose-axes y>> ] [ y>> ] bi* v. ]
[ origin>> a.v ]
} 2cleave
[ [ 2array ] 2bi@ ] dip <affine-transform> ;
diff --git a/extra/svg/svg-tests.factor b/extra/svg/svg-tests.factor
index 0f0c349b8e..932904eff4 100644
--- a/extra/svg/svg-tests.factor
+++ b/extra/svg/svg-tests.factor
@@ -3,8 +3,8 @@ USING: accessors arrays literals math math.affine-transforms
math.functions multiline sequences svg tools.test xml xml.traversal ;
IN: svg.tests
-{ 1.0 2.25 } { -3.0 4.0 } { 5.5 0.000001 } <affine-transform> 1array [
- "matrix ( 1 +2.25 -3 , 0.4e+1 ,5.5, 1e-6 )" svg-transform>affine-transform
+{ 1.0 2.25 } { -3.0 4.0 } { 5.5 0.5 } <affine-transform> 1array [
+ "matrix ( 1 +2.25 -3 , 0.4e+1 ,5.5, 5e-1 )" svg-transform>affine-transform
] unit-test
{ 1.0 0.0 } { 0.0 1.0 } { 5.0 10.0 } <affine-transform> 1array [
@@ -27,17 +27,22 @@ IN: svg.tests
"scale(2.0 4.0)" svg-transform>affine-transform
] unit-test
-{ 1.0 0.0 } { $[ 45 degrees tan ] 1.0 } { 0.0 0.0 } <affine-transform> 1array [
+[ t ] [
"skewX(45)" svg-transform>affine-transform
+ { 1.0 0.0 } { 1.0 1.0 } { 0.0 0.0 } <affine-transform> 0.001 a~
] unit-test
-{ 1.0 $[ -45 degrees tan ] } { 0.0 1.0 } { 0.0 0.0 } <affine-transform> 1array [
+[ t ] [
"skewY(-4.5e1)" svg-transform>affine-transform
+ { 1.0 -1.0 } { 0.0 1.0 } { 0.0 0.0 } <affine-transform> 0.001 a~
] unit-test
-{ $[ 30 degrees cos ] $[ 30 degrees sin ] }
-{ $[ -30 degrees sin ] $[ 30 degrees cos ] } { 0.0 0.0 } <affine-transform> 1array [
+[ t ] [
"rotate(30)" svg-transform>affine-transform
+ { $[ 0.75 sqrt ] 0.5 }
+ { -0.5 $[ 0.75 sqrt ] }
+ { 0.0 0.0 } <affine-transform>
+ 0.001 a~
] unit-test
[ t ] [
From 2ed97f5a24a294e242e30df631005ac4d14f002e Mon Sep 17 00:00:00 2001
From: Slava Pestov <slava@slava-pestovs-macbook-pro.local>
Date: Tue, 17 Mar 2009 18:53:44 -0500
Subject: [PATCH 15/15] Various fixes for call(
---
basis/core-foundation/fsevents/fsevents.factor | 2 +-
basis/stack-checker/call-effect/call-effect.factor | 14 +++++++++-----
basis/tools/deploy/shaker/shaker.factor | 4 +++-
basis/tools/deploy/shaker/strip-call.factor | 2 ++
core/combinators/combinators-tests.factor | 8 ++++++++
5 files changed, 23 insertions(+), 7 deletions(-)
diff --git a/basis/core-foundation/fsevents/fsevents.factor b/basis/core-foundation/fsevents/fsevents.factor
index 06b9c6407b..46f6639ab8 100644
--- a/basis/core-foundation/fsevents/fsevents.factor
+++ b/basis/core-foundation/fsevents/fsevents.factor
@@ -167,7 +167,7 @@ SYMBOL: event-stream-callbacks
eventFlags numEvents <direct-int-array>
eventIds numEvents <direct-longlong-array>
3array flip
- info event-stream-callbacks get at [ drop ] or call ;
+ info event-stream-callbacks get at [ drop ] or call( changes -- ) ;
: master-event-source-callback ( -- alien )
"void"
diff --git a/basis/stack-checker/call-effect/call-effect.factor b/basis/stack-checker/call-effect/call-effect.factor
index ef9a0305f6..bd1f7c73c3 100644
--- a/basis/stack-checker/call-effect/call-effect.factor
+++ b/basis/stack-checker/call-effect/call-effect.factor
@@ -1,7 +1,7 @@
! Copyright (C) 2009 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: accessors combinators combinators.private effects fry
-kernel kernel.private make sequences continuations
+kernel kernel.private make sequences continuations quotations
stack-checker stack-checker.transforms ;
IN: stack-checker.call-effect
@@ -20,18 +20,22 @@ TUPLE: inline-cache value ;
: cache-hit? ( word/quot ic -- ? ) value>> eq? ; inline
-SYMBOL: +failed+
+SYMBOL: +unknown+
-: cached-effect ( quot -- effect )
+GENERIC: cached-effect ( quot -- effect )
+
+M: object cached-effect drop +unknown+ ;
+
+M: quotation cached-effect
dup cached-effect>>
[ ] [
- [ [ infer ] [ 2drop +failed+ ] recover dup ] keep
+ [ [ infer ] [ 2drop +unknown+ ] recover dup ] keep
(>>cached-effect)
] ?if ;
: call-effect-unsafe? ( quot effect -- ? )
[ cached-effect ] dip
- over +failed+ eq?
+ over +unknown+ eq?
[ 2drop f ] [ effect<= ] if ; inline
: (call-effect-slow>quot) ( in out effect -- quot )
diff --git a/basis/tools/deploy/shaker/shaker.factor b/basis/tools/deploy/shaker/shaker.factor
index 98fc06a989..239d34b864 100755
--- a/basis/tools/deploy/shaker/shaker.factor
+++ b/basis/tools/deploy/shaker/shaker.factor
@@ -122,6 +122,7 @@ IN: tools.deploy.shaker
"inline"
"inlined-block"
"input-classes"
+ "instances"
"interval"
"intrinsics"
"lambda"
@@ -344,7 +345,8 @@ IN: tools.deploy.shaker
] 2each ;
: compress-quotations ( -- )
- [ quotation? ] [ remain-compiled ] "quotations" compress ;
+ [ quotation? ] [ remain-compiled ] "quotations" compress
+ [ quotation? ] instances [ f >>cached-effect f >>cache-counter drop ] each ;
: compress-strings ( -- )
[ string? ] [ ] "strings" compress ;
diff --git a/basis/tools/deploy/shaker/strip-call.factor b/basis/tools/deploy/shaker/strip-call.factor
index 4259895936..860a0f3849 100644
--- a/basis/tools/deploy/shaker/strip-call.factor
+++ b/basis/tools/deploy/shaker/strip-call.factor
@@ -5,4 +5,6 @@ IN: tools.deploy.shaker.call
IN: call
USE: call.private
+: call-effect ( word effect -- ) call-effect-unsafe ; inline
+
: execute-effect ( word effect -- ) execute-effect-unsafe ; inline
\ No newline at end of file
diff --git a/core/combinators/combinators-tests.factor b/core/combinators/combinators-tests.factor
index 1a4ee34fa2..be7d93873e 100644
--- a/core/combinators/combinators-tests.factor
+++ b/core/combinators/combinators-tests.factor
@@ -27,6 +27,14 @@ IN: combinators.tests
[ -3 ] [ 1 4 \ - compile-execute(-test-2 ] unit-test
[ 5 ] [ 1 4 \ + compile-execute(-test-2 ] unit-test
+: compile-call(-test-1 ( a b q -- c ) call( a b -- c ) ;
+
+[ t ] [ \ compile-call(-test-1 optimized>> ] unit-test
+[ 4 ] [ 1 3 [ + ] compile-call(-test-1 ] unit-test
+[ 7 ] [ 1 3 2 [ * + ] curry compile-call(-test-1 ] unit-test
+[ 7 ] [ 1 3 [ 2 * ] [ + ] compose compile-call(-test-1 ] unit-test
+[ 4 ] [ 1 3 [ { + } [ ] like call ] compile-call(-test-1 ] unit-test
+
! Compiled
: cond-test-1 ( obj -- str )
{