changes to continuation words

examples/numbers-game.factor

@@ -1,7 +1,7 @@
 IN: numbers-game
 USING: kernel math parser random io ;
 
-: read-number ( -- n ) readln str>number ;
+: read-number ( -- n ) readln string>number ;
 
 : guess-banner
     "I'm thinking of a number between 0 and 100." print ;

library/alien/compiler.factor

@@ -47,16 +47,11 @@ C: alien-node make-node ;
 
 : set-alien-return ( return node -- )
     2dup set-alien-node-return
-    swap "void" = [
-        drop
-    ] [
-        [ object ] produce-d 1 0 rot node-outputs
-    ] ifte ;
+    swap "void" = [ 1 over produce-values ] unless drop ;
 
 : set-alien-parameters ( parameters node -- )
     2dup set-alien-node-parameters
-    >r [ drop object ] map dup dup ensure-d
-    length 0 r> node-inputs consume-d ;
+    >r length r> consume-values ;
 
 : ensure-dlsym ( symbol library -- ) load-library dlsym drop ;
 

library/collections/lists.factor

@@ -39,11 +39,6 @@ M: cons map ( cons quot -- cons )
 M: general-list find ( list quot -- i elt )
     0 (list-find) ;
 
-: unique ( elem list -- list )
-    #! Prepend an element to a list if it does not occur in the
-    #! list.
-    2dup member? [ nip ] [ cons ] ifte ;
-
 M: general-list reverse-slice ( list -- list )
     [ ] [ swons ] reduce ;
 

library/collections/sequences-epilogue.factor

@@ -36,6 +36,20 @@ M: object >list ( seq -- list ) dup length 0 rot (>list) ;
 : memq?   ( obj seq -- ? )     [ eq? ] contains-with? ; flushable
 : remove  ( obj list -- list ) [ = not ] subset-with ; flushable
 
+: move ( to from seq -- )
+    pick pick number=
+    [ 3drop ] [ [ nth swap ] keep set-nth ] ifte ; inline
+
+: (delete) ( elt store scan seq -- )
+    2dup length < [
+        3dup move
+        >r pick over r> dup >r nth = r> swap
+        [ >r >r 1 + r> r> ] unless >r 1 + r> (delete)
+    ] when ;
+
+: delete ( elt seq -- )
+    0 0 rot (delete) nip set-length drop ;
+
 : copy-into-check ( start to from -- )
     rot rot length + swap length < [
         "Cannot copy beyond end of sequence" throw
@@ -74,27 +88,29 @@ M: object peek ( sequence -- element )
     #! Get value at end of sequence.
     dup length 1 - swap nth ;
 
+: pop* ( sequence -- )
+    #! Shorten the sequence by one element.
+    dup length 1 - swap set-length ;
+
 : pop ( sequence -- element )
     #! Get value at end of sequence and remove it.
-    dup peek >r dup length 1 - swap set-length r> ;
+    dup peek swap pop* ;
 
-: push-new ( elt seq -- )
+: adjoin ( elt seq -- )
     2dup member? [ 2drop ] [ push ] ifte ;
 
 : prune ( seq -- seq )
     [
-        dup length <vector> swap [ over push-new ] each
+        dup length <vector> swap [ over adjoin ] each
     ] keep like ; flushable
 
-: >pop> ( stack -- stack ) dup pop drop ;
-
 : join ( seq glue -- seq )
     #! The new sequence is of the same type as glue.
     swap dup empty? [
         swap like
     ] [
         dup length <vector> swap
-        [ over push 2dup push ] each nip >pop>
+        [ over push 2dup push ] each nip dup pop*
         concat
     ] ifte ; flushable
 

library/compiler/basic-blocks.factor

@@ -58,7 +58,7 @@ M: %replace-r simplify-stack* ( vop -- ) 0 vop-out update-cs ;
     #! continuation with 'f'.
     @{
         @{ [ 2dup vop-inputs member? ] [ 3drop t ] }@
-        @{ [ 2dup vop-outputs member? ] [ 2drop f swap call ] }@
+        @{ [ 2dup vop-outputs member? ] [ 2drop f swap continue-with ] }@
         @{ [ t ] [ 3drop f ] }@
     }@ cond ;
 
@@ -76,7 +76,7 @@ M: cs-loc live@end? cs-loc-n r-height get + 0 >= ;
     [
         -rot [ >r 2dup r> preserves-location? ] contains?
         [ dup live@end? ] unless*
-    ] callcc1 2nip ;
+    ] with-continuation 2nip ;
 
 ! Used for elimination of dead loads from the stack:
 ! we keep a map of vregs to ds-loc/cs-loc/f.

library/compiler/compiler.factor

@@ -15,9 +15,8 @@ words ;
     "Compiling " write dup . dup word-def precompile generate ;
 
 : compile-postponed ( -- )
-    compile-words get [
-        uncons compile-words set (compile) compile-postponed
-    ] when* ;
+    compile-words get dup empty?
+    [ dup pop (compile) compile-postponed ] unless drop ;
 
 : compile ( word -- )
     [ postpone-word compile-postponed ] with-compiler ;
@@ -40,3 +39,15 @@ words ;
     ] [
         call
     ] ifte ;
+
+\ dataflow profile
+\ optimize profile
+\ linearize profile
+\ split-blocks profile
+\ simplify profile
+\ keep-optimizing profile
+\ kill-set profile
+\ kill-node profile
+\ infer-classes profile
+\ solve-recursion profile
+\ split-node profile

library/compiler/xt.factor

@@ -27,10 +27,9 @@ SYMBOL: compiled-xts
 : compiled-xt ( word -- xt )
     dup compiled-xts get assoc [ ] [ word-xt ] ?ifte ;
 
-! Words being compiled are consed onto this list. When a word
-! is encountered that has not been previously compiled, it is
-! consed onto this list. Compilation stops when the list is
-! empty.
+! When a word is encountered that has not been previously
+! compiled, it is pushed onto this vector. Compilation stops
+! when the vector is empty.
 
 SYMBOL: compile-words
 
@@ -135,14 +134,12 @@ M: absolute-16/16 fixup ( absolute -- ) >absolute fixup-16/16 ;
     [
         deferred-xts off
         compiled-xts off
+        { } clone compile-words set
         call
         fixup-xts
         commit-xts
     ] with-scope ;
 
 : postpone-word ( word -- )
-    dup compiling? over compound? not or [
-        drop
-    ] [
-        compile-words [ unique ] change
-    ] ifte ;
+    dup compiling? not over compound? and
+    [ dup compile-words get push ] when drop ;

library/continuations.factor

@@ -1,31 +1,47 @@
 ! Copyright (C) 2003, 2005 Slava Pestov.
 ! See http://factor.sf.net/license.txt for BSD license.
-IN: kernel USING: errors lists namespaces sequences words ;
+IN: kernel
+USING: errors lists namespaces sequences words vectors ;
 
 TUPLE: interp data call name catch ;
 
-: interp ( -- interp )
-    datastack callstack >pop> >pop>
+: continuation ( -- interp )
+    #! The continuation is reified from after the *caller* of
+    #! this word returns.
+    datastack callstack dup pop* dup pop*
     namestack catchstack <interp> ;
 
-: continuation ( interp -- )
-    interp dup interp-call >pop> >pop> drop
-    dup interp-data >pop> drop ;
-
 : >interp< ( interp -- data call name catch )
     [ interp-data ] keep
     [ interp-call ] keep
     [ interp-name ] keep
     interp-catch ;
 
-: set-interp ( interp quot -- )
-    >r >interp< set-catchstack set-namestack
-    >r set-datastack r> r> swap set-callstack call ;
+: quot>interp ( quot -- continuation )
+    #! Make a continuation that executes the quotation.
+    #! The quotation should not return, or a call stack
+    #! underflow will be signalled.
+    { } swap 1 <vector> [ push ] keep f f <interp> ;
+
+: continue ( continuation -- )
+    #! Restore a continuation.
+    >interp<
+    set-catchstack set-namestack set-callstack set-datastack ;
+
+: continue-with ( object continuation -- object )
+    #! Restore a continuation, and place the object in the
+    #! restored data stack.
+    >interp< set-catchstack set-namestack
+    >r swap >r set-datastack r> r> set-callstack ;
+
+: with-continuation ( quot -- | quot: continuation -- )
+    #! Call a quotation with the current continuation, which may
+    #! be restored using continue or continue-with.
+    >r continuation dup interp-call dup pop* drop
+    r> call ; inline
 
 : callcc0 ( quot ++ | quot: cont -- | cont: ++ )
-    continuation
-    [ [ ] set-interp ] cons swap call ;
+    "use with-continuation instead" throw ;
 
 : callcc1 ( quot ++ obj | quot: cont -- | cont: obj ++ obj )
-    continuation
-    [ swap literalize unit set-interp ] cons swap call ;
+    "use with-continuation instead" throw ;

library/errors.factor

@@ -1,9 +1,11 @@
 ! Copyright (C) 2004, 2005 Slava Pestov.
 ! See http://factor.sf.net/license.txt for BSD license.
 IN: kernel
-USING: kernel-internals lists ;
-DEFER: callcc1
+DEFER: with-continuation
+DEFER: continue-with
+
 IN: errors
+USING: kernel-internals lists ;
 
 ! This is a very lightweight exception handling system.
 
@@ -17,15 +19,18 @@ TUPLE: no-method object generic ;
 : >c ( catch -- ) catchstack cons set-catchstack ;
 : c> ( catch -- ) catchstack uncons set-catchstack ;
 
+: (catch) ( try -- exception/f )
+    [ >c call f c> drop f ] with-continuation nip ;
+
 : catch ( try catch -- )
     #! Call the try quotation. If an error occurs restore the
     #! datastack, push the error, and call the catch block.
     #! If no error occurs, push f and call the catch block.
-    [ >c >r call c> drop f r> f ] callcc1 rot drop swap call ;
+    >r (catch) r> call ;
 
 : rethrow ( error -- )
     #! Use rethrow when passing an error on from a catch block.
     #! For convinience, this word is a no-op if error is f.
-    [ c> call ] when* ;
+    [ c> continue-with ] when* ;
 
 GENERIC: error. ( error -- )

library/generic/standard-combination.factor

@@ -23,9 +23,8 @@ namespaces sequences vectors words ;
 : sort-methods ( assoc -- vtable )
     #! Input is a predicate -> method association.
     num-types [
-        type>class dup
-        [ swap [ car classes-intersect? ] subset-with ]
-        [ 2drop f ] ifte
+        type>class [ object ] unless*
+        swap [ car classes-intersect? ] subset-with
     ] map-with ;
 
 : simplify-alist ( class alist -- default alist )

library/inference/branches.factor

@@ -79,7 +79,7 @@ namespaces parser prettyprint sequences strings vectors words ;
             dup literal-value infer-quot
             active? [ #values node, ] when
             f
-        ] callcc1 [ terminate ] when drop
+        ] with-continuation [ terminate ] when drop
     ] make-hash ;
 
 : (infer-branches) ( branchlist -- list )

library/inference/class-infer.factor

@@ -2,7 +2,7 @@
 ! See http://factor.sf.net/license.txt for BSD license.
 IN: optimizer
 USING: arrays generic hashtables inference kernel
-kernel-internals namespaces sequences words ;
+kernel-internals math namespaces sequences words ;
 
 ! Infer possible classes of values in a dataflow IR.
 
@@ -114,15 +114,15 @@ M: node child-ties ( node -- seq )
         call
     ] [
         node-param "infer-effect" word-prop second
+        dup integer? [ drop f ] when
     ] ?ifte ;
 
 M: #call infer-classes* ( node -- )
     dup node-param [
         dup create-ties
-        dup output-classes swap node-out-d intersect-classes
-    ] [
-        drop
-    ] ifte ;
+        dup output-classes
+        [ over node-out-d intersect-classes ] when*
+    ] when drop ;
 
 M: #shuffle infer-classes* ( node -- )
     node-out-d [ literal? ] subset

library/inference/inference.factor

@@ -1,7 +1,7 @@
 ! Copyright (C) 2004, 2005 Slava Pestov.
 ! See http://factor.sf.net/license.txt for BSD license.
 IN: inference
-USING: errors generic interpreter io kernel lists math
+USING: arrays errors generic interpreter io kernel lists math
 namespaces parser prettyprint sequences strings vectors words ;
 
 ! This variable takes a boolean value.
@@ -50,22 +50,13 @@ SYMBOL: d-in
 : required-inputs ( n stack -- values )
     length - 0 max computed-value-vector ;
 
-: ensure-d ( typelist -- )
+: ensure-values ( n -- )
     length meta-d get required-inputs dup
-    meta-d [ append ] change
-    d-in [ append ] change ;
+    meta-d [ append ] change d-in [ append ] change ;
 
-: effect ( -- [[ in# out# ]] )
+: effect
     #! After inference is finished, collect information.
-    d-in get length object <repeated> >list
-    meta-d get length object <repeated> >list 2list ;
-
-: no-base-case ( word -- )
-    {
-        "The base case of a recursive word could not be inferred.\n"
-        "This means the word calls itself in every control flow path.\n"
-        "See the handbook for details."
-    } concat inference-error ;
+    d-in get length meta-d get length 2array ;
 
 : init-inference ( recursive-state -- )
     init-interpreter
@@ -113,7 +104,7 @@ M: wrapper apply-object wrapped apply-literal ;
 : with-infer ( quot -- )
     [
         inferring-base-case off
-        [ no-base-case ] base-case-continuation set
+        base-case-continuation off
         f init-inference
         call
         check-return

library/inference/optimizer.factor

@@ -29,11 +29,14 @@ DEFER: optimize-node
         over set-node-successor r> r> r> or or
     ] [ r> ] ifte ;
 
-: optimize-loop ( dataflow -- dataflow )
+: optimize-1 ( dataflow -- dataflow ? )
     recursive-state off
     dup kill-set over kill-node
     dup infer-classes
-    optimize-node [ optimize-loop ] when ;
+    optimize-node ;
+
+: optimize-loop ( dataflow -- dataflow )
+    optimize-1 [ optimize-loop ] when ;
 
 : optimize ( dataflow -- dataflow )
     [

library/inference/words.factor

@@ -5,26 +5,20 @@ USING: errors generic interpreter kernel lists math
 math-internals namespaces sequences strings vectors words
 hashtables parser prettyprint ;
 
-: consume-d ( typelist -- )
-    [ pop-d 2drop ] each ;
+: consume-values ( n node -- )
+    over ensure-values
+    over 0 rot node-inputs [ pop-d 2drop ] each ;
 
-: produce-d ( typelist -- )
-    [ drop <computed> push-d ] each ;
-
-: hairy-node ( node effect quot -- quot: -- )
-    over car ensure-d
-    -rot 2dup car length 0 rot node-inputs
-    2slip
-    second length 0 rot node-outputs ; inline
+: produce-values ( n node -- )
+    over [ drop <computed> push-d ] each 0 swap node-outputs ;
 
 : consume/produce ( word effect -- )
     #! Add a node to the dataflow graph that consumes and
     #! produces a number of values.
-    swap #call [
-        over [
-            first2 swap consume-d produce-d
-        ] hairy-node
-    ] keep node, ;
+    swap #call
+    over first length over consume-values
+    swap second length over produce-values
+    node, ;
 
 : no-effect ( word -- )
     "Stack effect inference of the word " swap word-name
@@ -77,7 +71,7 @@ M: compound apply-word ( word -- )
     ] [
         dup "infer-effect" word-prop [
             over "infer" word-prop [
-                swap car ensure-d call drop
+                swap first length ensure-values call drop
             ] [
                 consume/produce
             ] ifte*
@@ -111,6 +105,17 @@ M: symbol apply-object ( word -- )
         rethrow
     ] catch ;
 
+: no-base-case ( word -- )
+    {
+        "The base case of a recursive word could not be inferred.\n"
+        "This means the word calls itself in every control flow path.\n"
+        "See the handbook for details."
+    } concat inference-error ;
+
+: notify-base-case ( -- )
+    base-case-continuation get
+    [ t swap continue-with ] [ no-base-case ] ifte* ;
+
 : recursive-word ( word [[ label quot ]] -- )
     #! Handle a recursive call, by either applying a previously
     #! inferred base case, or raising an error. If the recursive
@@ -122,7 +127,7 @@ M: symbol apply-object ( word -- )
             nip consume/produce
         ] [
             inferring-base-case get [
-                t base-case-continuation get call
+                notify-base-case
             ] [
                 car base-case
             ] ifte

library/io/files.factor

@@ -21,9 +21,9 @@ USING: kernel lists namespaces sequences strings ;
 
 DEFER: <file-reader>
 
-: resource-path ( -- path )
-    "resource-path" get [ "." ] unless* ;
+: resource-path ( path -- path )
+    "resource-path" get [ "." ] unless* swap path+ ;
 
 : <resource-stream> ( path -- stream )
     #! Open a file path relative to the Factor source code root.
-    resource-path swap path+ <file-reader> ;
+    resource-path <file-reader> ;

library/syntax/parse-stream.factor

@@ -7,22 +7,18 @@ USING: kernel lists namespaces sequences io words ;
     "scratchpad" "in" set
     [ "syntax" "scratchpad" ] "use" set ;
 
-: (parse-stream) ( stream -- quot )
+: parse-lines ( lines -- quot )
     [
-        lines dup length [ ]
+        dup length [ ]
         [ line-number set (parse) ] 2reduce
         reverse
     ] with-parser ;
 
-: parse-stream ( name stream -- quot )
-    [
-        swap file set file-vocabs
-        (parse-stream)
-        file off line-number off
-    ] with-scope ;
+: parse-stream ( stream name -- quot )
+    [ file set file-vocabs lines parse-lines ] with-scope ;
 
 : parse-file ( file -- quot )
-    dup <file-reader> parse-stream ;
+    [ <file-reader> ] keep parse-stream ;
 
 : run-file ( file -- )
     parse-file call ;
@@ -34,15 +30,14 @@ USING: kernel lists namespaces sequences io words ;
     #! resource:. This allows words that operate on source
     #! files, like "jedit", to use a different resource path
     #! at run time than was used at parse time.
-    "resource:" over append swap <resource-stream> parse-stream ;
+    [ <resource-stream> "resource:" ] keep append parse-stream ;
 
 : run-resource ( file -- )
     parse-resource call ;
 
 : word-file ( word -- file )
-    "file" word-prop dup [
-        "resource:/" ?head [ resource-path swap path+ ] when
-    ] when ;
+    "file" word-prop dup
+    [ "resource:/" ?head [ resource-path ] when ] when ;
 
 : reload ( word -- )
     #! Reload the source file the word originated from.

library/syntax/prettyprint.factor

@@ -58,7 +58,7 @@ C: section ( length -- section )
     ] [
         last-newline set
         line-count inc
-        line-limit? [ "..." write end-printing get call ] when
+        line-limit? [ "..." write end-printing get continue ] when
         "\n" write do-indent
     ] ifte ;
 
@@ -161,7 +161,7 @@ C: pprinter ( -- stream )
     [
         end-printing set
         dup pprinter-block pprint-section
-    ] callcc0 drop ;
+    ] with-continuation drop ;
 
 GENERIC: pprint* ( obj -- )
 
@@ -264,7 +264,7 @@ M: dll pprint* ( obj -- str ) dll-path "DLL\" " pprint-string ;
 : pprint-elements ( seq -- )
     length-limit? >r
     [ pprint-element ] each
-    r> [ "... " f text ] when ;
+    r> [ "..." f text ] when ;
 
 : pprint-sequence ( seq start end -- )
     swap pprint* swap pprint-elements pprint* ;

library/syntax/see.factor

@@ -1,8 +1,8 @@
 ! Copyright (C) 2003, 2005 Slava Pestov.
 ! See http://factor.sf.net/license.txt for BSD license.
 IN: prettyprint
-USING: generic hashtables io kernel lists namespaces sequences
-styles words ;
+USING: generic hashtables io kernel lists math namespaces
+sequences styles words ;
 
 : declaration. ( word prop -- )
     tuck word-name word-prop [ pprint-word ] [ drop ] ifte ;
@@ -19,6 +19,7 @@ styles words ;
     [ [[ font-style italic ]] ] text ;
 
 : stack-picture% ( seq -- string )
+    dup integer? [ object <repeated> ] when
     [ word-name % " " % ] each ;
 
 : effect>string ( effect -- string )

library/test/benchmark/continuations.factor

@@ -1,7 +1,4 @@
 IN: temporary
-USE: kernel
-USE: math
-USE: test
+USING: kernel sequences test ;
 
-! This caused the Java Factor to run out of memory
-[ ] [ 100000 [ [ call ] callcc0 ] times ] unit-test
+[ ] [ 100000 [ drop [ continue ] with-continuation ] each ] unit-test

library/test/collections/sequences.factor

@@ -153,3 +153,9 @@ unit-test
 [ @{ "" "a" "aa" "aaa" }@ ]
 [ 4 [ CHAR: a fill ] map ]
 unit-test
+
+[ { } ] [ "f" { } clone [ delete ] keep ] unit-test
+[ { } ] [ "f" { "f" } clone [ delete ] keep ] unit-test
+[ { } ] [ "f" { "f" "f" } clone [ delete ] keep ] unit-test
+[ { "x" } ] [ "f" { "f" "x" "f" } clone [ delete ] keep ] unit-test
+[ { "y" "x" } ] [ "f" { "y" "f" "x" "f" } clone [ delete ] keep ] unit-test

library/test/continuations.factor

@@ -8,27 +8,29 @@ USE: test
 
 : (callcc1-test)
     swap 1 - tuck swons
-    over 0 = [ "test-cc" get call ] when
+    over 0 = [ "test-cc" get continue-with ] when
     (callcc1-test) ;
 
 : callcc1-test ( x -- list )
     [
         "test-cc" set [ ] (callcc1-test)
-    ] callcc1 nip ;
+    ] with-continuation nip ;
 
 : callcc-namespace-test ( -- ? )
     [
         "test-cc" set
         5 "x" set
         [
-            6 "x" set "test-cc" get call
+            6 "x" set "test-cc" get continue
         ] with-scope
-    ] callcc0 "x" get 5 = ;
+    ] with-continuation "x" get 5 = ;
 
 [ t ] [ 10 callcc1-test 10 >list = ] unit-test
 [ t ] [ callcc-namespace-test ] unit-test
 
 : multishot-test ( -- stack )
-    [ dup "cc" set 5 swap call ] callcc1 "cc" get car interp-data ;
+    [
+        dup "cc" set 5 swap continue-with
+    ] with-continuation "cc" get interp-data ;
 
 [ 5 { } ] [ multishot-test ] unit-test

library/test/inference.factor

@@ -18,21 +18,19 @@ namespaces parser sequences test vectors ;
     compose-shuffle
 ] unit-test
 
-: simple-effect first2 >r length r> length 2array ;
+[ @{ 0 2 }@ ] [ [ 2 "Hello" ] infer ] unit-test
+[ @{ 1 2 }@ ] [ [ dup ] infer ] unit-test
 
-[ @{ 0 2 }@ ] [ [ 2 "Hello" ] infer simple-effect ] unit-test
-[ @{ 1 2 }@ ] [ [ dup ] infer simple-effect ] unit-test
+[ @{ 1 2 }@ ] [ [ [ dup ] call ] infer ] unit-test
+[ [ call ] infer ] unit-test-fails
 
-[ @{ 1 2 }@ ] [ [ [ dup ] call ] infer simple-effect ] unit-test
-[ [ call ] infer simple-effect ] unit-test-fails
+[ @{ 2 4 }@ ] [ [ 2dup ] infer ] unit-test
 
-[ @{ 2 4 }@ ] [ [ 2dup ] infer simple-effect ] unit-test
-
-[ @{ 1 0 }@ ] [ [ [ ] [ ] ifte ] infer simple-effect ] unit-test
-[ [ ifte ] infer simple-effect ] unit-test-fails
-[ [ [ ] ifte ] infer simple-effect ] unit-test-fails
-[ [ [ 2 ] [ ] ifte ] infer simple-effect ] unit-test-fails
-[ @{ 4 3 }@ ] [ [ [ rot ] [ -rot ] ifte ] infer simple-effect ] unit-test
+[ @{ 1 0 }@ ] [ [ [ ] [ ] ifte ] infer ] unit-test
+[ [ ifte ] infer ] unit-test-fails
+[ [ [ ] ifte ] infer ] unit-test-fails
+[ [ [ 2 ] [ ] ifte ] infer ] unit-test-fails
+[ @{ 4 3 }@ ] [ [ [ rot ] [ -rot ] ifte ] infer ] unit-test
 
 [ @{ 4 3 }@ ] [
     [
@@ -41,18 +39,18 @@ namespaces parser sequences test vectors ;
         ] [
             -rot
         ] ifte
-    ] infer simple-effect
+    ] infer
 ] unit-test
 
-[ @{ 1 1 }@ ] [ [ dup [ ] when ] infer simple-effect ] unit-test
-[ @{ 1 1 }@ ] [ [ dup [ dup fixnum* ] when ] infer simple-effect ] unit-test
-[ @{ 2 1 }@ ] [ [ [ dup fixnum* ] when ] infer simple-effect ] unit-test
+[ @{ 1 1 }@ ] [ [ dup [ ] when ] infer ] unit-test
+[ @{ 1 1 }@ ] [ [ dup [ dup fixnum* ] when ] infer ] unit-test
+[ @{ 2 1 }@ ] [ [ [ dup fixnum* ] when ] infer ] unit-test
 
-[ @{ 1 0 }@ ] [ [ [ drop ] when* ] infer simple-effect ] unit-test
-[ @{ 1 1 }@ ] [ [ [ { { [ ] } } ] unless* ] infer simple-effect ] unit-test
+[ @{ 1 0 }@ ] [ [ [ drop ] when* ] infer ] unit-test
+[ @{ 1 1 }@ ] [ [ [ { { [ ] } } ] unless* ] infer ] unit-test
 
 [ @{ 0 1 }@ ] [
-    [ [ 2 2 fixnum+ ] dup [ ] when call ] infer simple-effect
+    [ [ 2 2 fixnum+ ] dup [ ] when call ] infer
 ] unit-test
 
 [
@@ -64,27 +62,27 @@ namespaces parser sequences test vectors ;
 : simple-recursion-1
     dup [ simple-recursion-1 ] [ ] ifte ;
 
-[ @{ 1 1 }@ ] [ [ simple-recursion-1 ] infer simple-effect ] unit-test
+[ @{ 1 1 }@ ] [ [ simple-recursion-1 ] infer ] unit-test
 
 : simple-recursion-2
     dup [ ] [ simple-recursion-2 ] ifte ;
 
-[ @{ 1 1 }@ ] [ [ simple-recursion-2 ] infer simple-effect ] unit-test
+[ @{ 1 1 }@ ] [ [ simple-recursion-2 ] infer ] unit-test
 
 : bad-recursion-2
     dup [ uncons bad-recursion-2 ] [ ] ifte ;
 
-[ [ bad-recursion-2 ] infer simple-effect ] unit-test-fails
+[ [ bad-recursion-2 ] infer ] unit-test-fails
 
 ! Not sure how to fix this one
 
 : funny-recursion
     dup [ funny-recursion 1 ] [ 2 ] ifte drop ;
 
-[ @{ 1 1 }@ ] [ [ funny-recursion ] infer simple-effect ] unit-test
+[ @{ 1 1 }@ ] [ [ funny-recursion ] infer ] unit-test
 
 ! Simple combinators
-[ @{ 1 2 }@ ] [ [ [ car ] keep cdr ] infer simple-effect ] unit-test
+[ @{ 1 2 }@ ] [ [ [ car ] keep cdr ] infer ] unit-test
 
 ! Mutual recursion
 DEFER: foe
@@ -107,8 +105,8 @@ DEFER: foe
         2drop f
     ] ifte ;
 
-[ @{ 2 1 }@ ] [ [ fie ] infer simple-effect ] unit-test
-[ @{ 2 1 }@ ] [ [ foe ] infer simple-effect ] unit-test
+[ @{ 2 1 }@ ] [ [ fie ] infer ] unit-test
+[ @{ 2 1 }@ ] [ [ foe ] infer ] unit-test
 
 : nested-when ( -- )
     t [
@@ -117,7 +115,7 @@ DEFER: foe
         ] when
     ] when ;
 
-[ @{ 0 0 }@ ] [ [ nested-when ] infer simple-effect ] unit-test
+[ @{ 0 0 }@ ] [ [ nested-when ] infer ] unit-test
 
 : nested-when* ( -- )
     [
@@ -126,11 +124,11 @@ DEFER: foe
         ] when*
     ] when* ;
 
-[ @{ 1 0 }@ ] [ [ nested-when* ] infer simple-effect ] unit-test
+[ @{ 1 0 }@ ] [ [ nested-when* ] infer ] unit-test
 
 SYMBOL: sym-test
 
-[ @{ 0 1 }@ ] [ [ sym-test ] infer simple-effect ] unit-test
+[ @{ 0 1 }@ ] [ [ sym-test ] infer ] unit-test
 
 : terminator-branch
     dup [
@@ -139,7 +137,7 @@ SYMBOL: sym-test
         not-a-number
     ] ifte ;
 
-[ @{ 1 1 }@ ] [ [ terminator-branch ] infer simple-effect ] unit-test
+[ @{ 1 1 }@ ] [ [ terminator-branch ] infer ] unit-test
 
 : recursive-terminator
     dup [
@@ -148,7 +146,7 @@ SYMBOL: sym-test
         not-a-number
     ] ifte ;
 
-[ @{ 1 1 }@ ] [ [ recursive-terminator ] infer simple-effect ] unit-test
+[ @{ 1 1 }@ ] [ [ recursive-terminator ] infer ] unit-test
 
 GENERIC: potential-hang
 M: fixnum potential-hang dup [ potential-hang ] when ;
@@ -161,14 +159,14 @@ M: funny-cons iterate funny-cons-cdr iterate ;
 M: f iterate drop ;
 M: real iterate drop ;
 
-[ @{ 1 0 }@ ] [ [ iterate ] infer simple-effect ] unit-test
+[ @{ 1 0 }@ ] [ [ iterate ] infer ] unit-test
 
-[ [ callstack ] infer simple-effect ] unit-test-fails
+[ [ callstack ] infer ] unit-test-fails
 
 DEFER: agent
 : smith 1 + agent ; inline
 : agent dup 0 = [ [ swap call ] 2keep smith ] when ; inline
-[ [ [ ] [ object object ] ] ]
+[ @{ 0 2 }@ ]
 [ [ [ drop ] 0 agent ] infer ] unit-test
 
 ! : no-base-case-1 dup [ no-base-case-1 ] [ no-base-case-1 ] ifte ;
@@ -177,62 +175,62 @@ DEFER: agent
 : no-base-case-2 no-base-case-2 ;
 [ [ no-base-case-2 ] infer ] unit-test-fails
 
-[ @{ 2 1 }@ ] [ [ swons ] infer simple-effect ] unit-test
-[ @{ 1 2 }@ ] [ [ uncons ] infer simple-effect ] unit-test
-[ @{ 1 1 }@ ] [ [ unit ] infer simple-effect ] unit-test
-[ @{ 1 2 }@ ] [ [ unswons ] infer simple-effect ] unit-test
-[ @{ 1 1 }@ ] [ [ last ] infer simple-effect ] unit-test
-[ @{ 1 1 }@ ] [ [ list? ] infer simple-effect ] unit-test
+[ @{ 2 1 }@ ] [ [ swons ] infer ] unit-test
+[ @{ 1 2 }@ ] [ [ uncons ] infer ] unit-test
+[ @{ 1 1 }@ ] [ [ unit ] infer ] unit-test
+[ @{ 1 2 }@ ] [ [ unswons ] infer ] unit-test
+[ @{ 1 1 }@ ] [ [ last ] infer ] unit-test
+[ @{ 1 1 }@ ] [ [ list? ] infer ] unit-test
 
-[ @{ 1 0 }@ ] [ [ >n ] infer simple-effect ] unit-test
-[ @{ 0 1 }@ ] [ [ n> ] infer simple-effect ] unit-test
+[ @{ 1 0 }@ ] [ [ >n ] infer ] unit-test
+[ @{ 0 1 }@ ] [ [ n> ] infer ] unit-test
 
-[ @{ 2 1 }@ ] [ [ bitor ] infer simple-effect ] unit-test
-[ @{ 2 1 }@ ] [ [ bitand ] infer simple-effect ] unit-test
-[ @{ 2 1 }@ ] [ [ bitxor ] infer simple-effect ] unit-test
-[ @{ 2 1 }@ ] [ [ mod ] infer simple-effect ] unit-test
-[ @{ 2 1 }@ ] [ [ /i ] infer simple-effect ] unit-test
-[ @{ 2 1 }@ ] [ [ /f ] infer simple-effect ] unit-test
-[ @{ 2 2 }@ ] [ [ /mod ] infer simple-effect ] unit-test
-[ @{ 2 1 }@ ] [ [ + ] infer simple-effect ] unit-test
-[ @{ 2 1 }@ ] [ [ - ] infer simple-effect ] unit-test
-[ @{ 2 1 }@ ] [ [ * ] infer simple-effect ] unit-test
-[ @{ 2 1 }@ ] [ [ / ] infer simple-effect ] unit-test
-[ @{ 2 1 }@ ] [ [ < ] infer simple-effect ] unit-test
-[ @{ 2 1 }@ ] [ [ <= ] infer simple-effect ] unit-test
-[ @{ 2 1 }@ ] [ [ > ] infer simple-effect ] unit-test
-[ @{ 2 1 }@ ] [ [ >= ] infer simple-effect ] unit-test
-[ @{ 2 1 }@ ] [ [ number= ] infer simple-effect ] unit-test
+[ @{ 2 1 }@ ] [ [ bitor ] infer ] unit-test
+[ @{ 2 1 }@ ] [ [ bitand ] infer ] unit-test
+[ @{ 2 1 }@ ] [ [ bitxor ] infer ] unit-test
+[ @{ 2 1 }@ ] [ [ mod ] infer ] unit-test
+[ @{ 2 1 }@ ] [ [ /i ] infer ] unit-test
+[ @{ 2 1 }@ ] [ [ /f ] infer ] unit-test
+[ @{ 2 2 }@ ] [ [ /mod ] infer ] unit-test
+[ @{ 2 1 }@ ] [ [ + ] infer ] unit-test
+[ @{ 2 1 }@ ] [ [ - ] infer ] unit-test
+[ @{ 2 1 }@ ] [ [ * ] infer ] unit-test
+[ @{ 2 1 }@ ] [ [ / ] infer ] unit-test
+[ @{ 2 1 }@ ] [ [ < ] infer ] unit-test
+[ @{ 2 1 }@ ] [ [ <= ] infer ] unit-test
+[ @{ 2 1 }@ ] [ [ > ] infer ] unit-test
+[ @{ 2 1 }@ ] [ [ >= ] infer ] unit-test
+[ @{ 2 1 }@ ] [ [ number= ] infer ] unit-test
 
-[ @{ 1 1 }@ ] [ [ string>number ] infer simple-effect ] unit-test
-[ @{ 2 1 }@ ] [ [ = ] infer simple-effect ] unit-test
-[ @{ 1 1 }@ ] [ [ get ] infer simple-effect ] unit-test
+[ @{ 1 1 }@ ] [ [ string>number ] infer ] unit-test
+[ @{ 2 1 }@ ] [ [ = ] infer ] unit-test
+[ @{ 1 1 }@ ] [ [ get ] infer ] unit-test
 
-[ @{ 2 0 }@ ] [ [ push ] infer simple-effect ] unit-test
-[ @{ 2 0 }@ ] [ [ set-length ] infer simple-effect ] unit-test
-[ @{ 2 1 }@ ] [ [ append ] infer simple-effect ] unit-test
-[ @{ 1 1 }@ ] [ [ peek ] infer simple-effect ] unit-test
+[ @{ 2 0 }@ ] [ [ push ] infer ] unit-test
+[ @{ 2 0 }@ ] [ [ set-length ] infer ] unit-test
+[ @{ 2 1 }@ ] [ [ append ] infer ] unit-test
+[ @{ 1 1 }@ ] [ [ peek ] infer ] unit-test
 
-[ @{ 1 1 }@ ] [ [ length ] infer simple-effect ] unit-test
-[ @{ 1 1 }@ ] [ [ reverse ] infer simple-effect ] unit-test
-[ @{ 2 1 }@ ] [ [ member? ] infer simple-effect ] unit-test
-[ @{ 2 1 }@ ] [ [ remove ] infer simple-effect ] unit-test
-[ @{ 1 1 }@ ] [ [ prune ] infer simple-effect ] unit-test
+[ @{ 1 1 }@ ] [ [ length ] infer ] unit-test
+[ @{ 1 1 }@ ] [ [ reverse ] infer ] unit-test
+[ @{ 2 1 }@ ] [ [ member? ] infer ] unit-test
+[ @{ 2 1 }@ ] [ [ remove ] infer ] unit-test
+[ @{ 1 1 }@ ] [ [ prune ] infer ] unit-test
 
 : bad-code "1234" car ;
 
-[ @{ 0 1 }@ ] [ [ bad-code ] infer simple-effect ] unit-test
+[ @{ 0 1 }@ ] [ [ bad-code ] infer ] unit-test
 
 ! This form should not have a stack effect
 ! : bad-bin 5 [ 5 bad-bin bad-bin 5 ] [ 2drop ] ifte ;
-! [ [ bad-bin ] infer simple-effect ] unit-test-fails
+! [ [ bad-bin ] infer ] unit-test-fails
 
-! [ [ infinite-loop ] infer simple-effect ] unit-test-fails
+! [ [ infinite-loop ] infer ] unit-test-fails
 
 ! : bad-recursion-1
 !     dup [ drop bad-recursion-1 5 ] [ ] ifte ;
 ! 
-! [ [ bad-recursion-1 ] infer simple-effect ] unit-test-fails
+! [ [ bad-recursion-1 ] infer ] unit-test-fails
 
 ! This hangs
 

library/test/lists/lists.factor

@@ -17,9 +17,5 @@ USING: kernel lists sequences test ;
 [ t ] [ [ 1 2 ]   list? ] unit-test
 [ f ] [ [[ 1 2 ]] list? ] unit-test
 
-[ [ 1 2 3 ] ] [ 1 [ 2 3 ]   unique ] unit-test
-[ [ 1 2 3 ] ] [ 1 [ 1 2 3 ] unique ] unit-test
-[ [ 1 2 3 ] ] [ 2 [ 1 2 3 ] unique ] unit-test
-
 [ [ ]         ] [ 0   >list ] unit-test
 [ [ 0 1 2 3 ] ] [ 4   >list ] unit-test

library/test/lists/namespaces.factor

@@ -5,7 +5,6 @@ USE: test
 USE: sequences
 
 : cons@ [ cons ] change ;
-: unique@ [ unique ] change ;
 
 [ [ 1 ] ] [ 1 f "x" set "x" cons@ "x" get ] unit-test
 [ [[ 1 2 ]] ] [ 1 2 "x" set "x" cons@ "x" get ] unit-test
@@ -20,15 +19,3 @@ USE: sequences
     2 "x" [ remove ] change
     "x" get
 ] unit-test
-
-[ [ "hello" f ] ] [
-    "x" off
-    f "x" unique@
-    "hello" "x" unique@
-    f "x" unique@
-    5 "x" unique@
-    f "x" unique@
-    5 "x" [ remove ] change
-    "hello" "x" unique@
-    "x" get
-] unit-test

library/test/redefine.factor

@@ -6,7 +6,7 @@ IN: temporary
 : foo 1 2 3 ;
 
 [ 1 2 3 1 2 3 ] [ bar ] unit-test
-[ [ [ ] [ object object object ] ] ] [ [ foo ] infer ] unit-test
+[ @{ 0 3 }@ ] [ [ foo ] infer ] unit-test
 
 [ ] [
     "IN: temporary : foo ; : bar foo ; : baz foo ; : foo ;" eval

library/test/tuple.factor

@@ -1,5 +1,5 @@
-IN: temporary
 USING: errors generic kernel math parser sequences test words ;
+IN: temporary
 
 TUPLE: rect x y w h ;
 C: rect

library/threads.factor

@@ -28,19 +28,20 @@ DEFER: next-thread
 : next-thread ( -- quot )
     run-queue dup queue-empty? [ drop do-sleep ] [ deque ] ifte ;
 
-: stop ( -- ) next-thread call ;
+: stop ( -- ) next-thread continue ;
 
-: yield ( -- ) [ schedule-thread stop ] callcc0 ;
+: yield ( -- ) [ schedule-thread stop ] with-continuation ;
 
 : sleep ( ms -- )
-    millis + [ cons sleep-queue push stop ] callcc0 drop ;
+    millis +
+    [ cons sleep-queue push stop ] with-continuation drop ;
 
 : in-thread ( quot -- )
     [
         schedule-thread
         [ ] set-catchstack { } set-callstack
         try stop
-    ] callcc0 drop ;
+    ] with-continuation drop ;
 
 TUPLE: timer object delay last ;
 

library/tools/annotations.factor

@@ -11,13 +11,14 @@ sequences strings test ;
     over >r >r dup word-def r> call r> swap define-compound ;
     inline
 
+: watch-msg ( word prefix -- ) write word-name print .s ;
+
 : (watch) ( word def -- def )
     [
-        "===> Entering: " pick word-name append ,
-        [ print .s ] %
-        %
-        "===> Leaving:  " swap word-name append ,
-        [ print .s ] %
+        swap literalize
+        dup , "===> Entering: " , \ watch-msg ,
+        swap %
+        , "===> Leaving:  " , \ watch-msg ,
     ] [ ] make ;
 
 : watch ( word -- )

library/tools/debugger.factor

@@ -131,8 +131,8 @@ M: object error. ( error -- ) . ;
     ] bind ;
 
 : init-error-handler ( -- )
-    [ die ] >c ( last resort )
-    [ print-error die ] >c
+    [ die ] quot>interp >c ( last resort )
+    [ print-error die ] quot>interp >c
     ( kernel calls on error )
     [
         datastack dupd callstack namestack catchstack

library/tools/inspector.factor

@@ -87,7 +87,6 @@ SYMBOL: inspector-stack
     "inspecting ( -- obj ) push current object" print
     "go ( n -- ) inspect nth slot" print
     "up -- return to previous object" print
-    "refs -- inspect references to current object" print
     "bye -- exit inspector" print ;
 
 : inspector ( obj -- )
@@ -107,6 +106,4 @@ SYMBOL: inspector-stack
 
 : go ( n -- ) inspector-slots get nth (inspect) ;
 
-: up ( -- ) inspector-stack get >pop> pop (inspect) ;
-
-: refs ( -- ) inspecting references (inspect) ;
+: up ( -- ) inspector-stack get dup pop* pop (inspect) ;

library/tools/interpreter.factor

@@ -52,10 +52,9 @@ SYMBOL: meta-executing
 
 : host-word ( word -- )
     [
-        \ call push-r  interp [
-            interp over interp-data push
-            [ ] set-interp
-        ] cons cons push-r  meta-interp [ ] set-interp
+        \ call push-r  continuation [
+            continuation over interp-data push continue
+        ] cons cons push-r  meta-interp continue
     ] call  set-meta-interp  pop-d 2drop ;
 
 : meta-call ( quot -- )

library/tools/jedit.factor

@@ -7,12 +7,8 @@ prettyprint sequences strings unparser words ;
 ! Some words to send requests to a running jEdit instance to
 ! edit files and position the cursor on a specific line number.
 
-: jedit-server-file ( -- path )
-    "jedit-server-file" get
-    [ "~" get "/.jedit/server" append ] unless* ;
-
 : jedit-server-info ( -- port auth )
-    jedit-server-file <file-reader> [
+    "~" get "/.jedit/server" append <file-reader> [
         readln drop
         readln string>number
         readln string>number
@@ -30,7 +26,7 @@ prettyprint sequences strings unparser words ;
     jedit-server-info swap "localhost" swap <client> [
         4 >be write
         dup length 2 >be write
-        write flush
+        write
     ] with-stream ;
 
 : jedit-line/file ( file line -- )
@@ -42,11 +38,7 @@ prettyprint sequences strings unparser words ;
 
 : jedit ( word -- )
     #! Note that line numbers here start from 1
-    dup word-file dup [
-        swap "line" word-prop jedit-line/file
-    ] [
-        2drop "Unknown source" print
-    ] ifte ;
+    dup word-file swap "line" word-prop jedit-line/file ;
 
 ! Wire protocol for jEdit to evaluate Factor code.
 ! Packets are of the form:

library/tools/memory.factor

@@ -39,16 +39,13 @@ sequences strings unparser vectors words ;
 ! Some words for iterating through the heap.
 
 : (each-object) ( quot -- )
-    next-object [ swap [ call ] keep (each-object) ] when* ;
-    inline
+    next-object dup
+    [ swap [ call ] keep (each-object) ] [ 2drop ] ifte ; inline
 
 : each-object ( quot -- )
-    #! Applies the quotation to each object in the image. We
-    #! use the lower-level >c and c> words here to avoid
-    #! copying the stacks.
-    [ end-scan rethrow ] >c
-    begin-scan (each-object) drop
-    f c> call ; inline
+    #! Applies the quotation to each object in the image.
+    [ begin-scan (each-object) ]
+    [ end-scan rethrow ] catch ; inline
 
 : instances ( quot -- list )
     #! Return a list of all object that return true when the
@@ -86,19 +83,13 @@ M: object each-slot ( obj quot -- )
     num-types zero-array num-types zero-array
     [ >r 2dup r> heap-stat-step ] each-object ;
 
-: heap-stat. ( type instances bytes -- )
-    dup 0 = [
-        3drop
-    ] [
-        rot type>class word-name write ": " write
-        pprint " bytes, " write
-        pprint " instances" print
-    ] ifte ;
+: heap-stat. ( { instances bytes type } -- )
+    dup first 0 = [
+        dup third type>class pprint ": " write
+        dup second pprint " bytes, " write
+        dup first pprint " instances" print
+    ] unless drop ;
 
 : heap-stats. ( -- )
     #! Print heap allocation breakdown.
-    0 heap-stats [ >r >r dup r> r> heap-stat. 1 + ] 2each drop ;
-
-: orphans ( word -- list )
-    #! Orphans are forgotten but still referenced.
-    [ word? ] instances [ interned? not ] subset ;
+    heap-stats dup length 3array flip [ heap-stat. ] each ;

library/ui/fonts.factor

@@ -21,7 +21,7 @@ sequences styles ;
     }} hash ;
 
 : ttf-path ( name -- string )
-    [ resource-path % "/fonts/" % % ".ttf" % ] "" make ;
+    [ "/fonts/" % % ".ttf" % ] "" make resource-path ;
 
 : open-font ( [ font style ptsize ] -- alien )
     first3 >r ttf-name ttf-path r> TTF_OpenFont ;

library/ui/hand.factor

@@ -15,6 +15,7 @@ TUPLE: hand click-loc click-rel clicked buttons gadget focus ;
 
 C: hand ( world -- hand )
     <gadget> over set-delegate
+    { } clone over set-hand-buttons
     [ set-gadget-parent ] 2keep
     [ set-hand-gadget ] keep ;
 
@@ -24,22 +25,22 @@ C: hand ( world -- hand )
     dup hand-gadget over set-hand-clicked
     dup screen-loc over set-hand-click-loc
     dup hand-gadget over relative over set-hand-click-rel
-    [ hand-buttons unique ] keep set-hand-buttons ;
+    hand-buttons adjoin ;
 
 : button\ ( n hand -- )
-    [ hand-buttons remove ] keep set-hand-buttons ;
+    hand-buttons delete ;
 
 : drag-gesture ( hand gadget gesture -- )
     #! Send a gesture like [ drag 2 ].
-    rot hand-buttons car add swap handle-gesture drop ;
+    rot hand-buttons first add swap handle-gesture drop ;
 
 : fire-motion ( hand -- )
     #! Fire a motion gesture to the gadget underneath the hand,
     #! and if a mouse button is down, fire a drag gesture to the
     #! gadget that was clicked.
     [ motion ] over hand-gadget handle-gesture drop
-    dup hand-buttons
-    [ dup hand-clicked [ drag ] drag-gesture ] [ drop ] ifte ;
+    dup hand-buttons empty?
+    [ dup dup hand-clicked [ drag ] drag-gesture ] unless drop ;
 
 : drop-prefix ( l1 l2 -- l1 l2 )
     2dup and [ 2dup 2car eq? [ 2cdr drop-prefix ] when ] when ;

library/ui/hierarchy.factor

@@ -5,13 +5,14 @@ USING: gadgets-layouts generic hashtables kernel lists math
 namespaces sequences vectors ;
 
 : remove-gadget ( gadget parent -- )
-    2dup gadget-children remove over set-gadget-children
-    relayout f swap set-gadget-parent ;
+    f pick set-gadget-parent
+    [ gadget-children delete ] keep
+    relayout ;
 
 : unparent ( gadget -- )
     [
         dup gadget-parent dup
-        [ remove-gadget ] [ 2drop ] ifte
+        [ 2dup remove-gadget ] when 2drop
     ] when* ;
 
 : (clear-gadget) ( gadget -- )

library/ui/panes.factor

@@ -32,7 +32,7 @@ TUPLE: pane output active current input continuation ;
     dup pane-continuation f rot set-pane-continuation ;
 
 : pane-eval ( string pane -- )
-    pop-continuation in-thread drop ;
+    pop-continuation [ continue-with ] in-thread 2drop ;
 
 SYMBOL: structured-input
 
@@ -112,7 +112,7 @@ M: pane stream-flush ( pane -- ) drop ;
 M: pane stream-finish ( pane -- ) drop ;
 
 M: pane stream-readln ( pane -- line )
-    [ over set-pane-continuation stop ] callcc1 nip ;
+    [ over set-pane-continuation stop ] with-continuation nip ;
 
 M: pane stream-write1 ( char pane -- )
     [ >r ch>string <label> r> pane-current add-gadget ] keep

library/unix/io.factor

@@ -114,7 +114,7 @@ GENERIC: task-container ( task -- vector )
 
 : handle-fd ( task -- )
     dup do-io-task [
-        dup io-task-port touch-port pop-callback call
+        dup io-task-port touch-port pop-callback continue
     ] [
         drop
     ] ifte ;
@@ -126,7 +126,7 @@ GENERIC: task-container ( task -- vector )
     [
         cdr dup io-task-port timeout? [
             dup io-task-port "Timeout" swap report-error
-            nip pop-callback call
+            nip pop-callback continue
         ] [
             tuck io-task-fd swap bit-nth
             [ handle-fd ] [ drop ] ifte
@@ -208,7 +208,7 @@ M: read-task task-container drop read-tasks get ;
 
 : wait-to-read ( count port -- )
     2dup can-read-count? [
-        [ -rot <read-task> add-io-task stop ] callcc0 
+        [ -rot <read-task> add-io-task stop ] with-continuation
     ] unless 2drop ;
 
 M: port stream-read ( count stream -- string )
@@ -273,7 +273,9 @@ M: write-task task-container drop write-tasks get ;
 
 M: port stream-flush ( stream -- )
     dup port-output? [
-        [ swap <write-task> add-write-io-task stop ] callcc0
+        [
+            swap <write-task> add-write-io-task stop
+        ] with-continuation
     ] when drop ;
 
 M: port stream-finish ( stream -- ) drop ;

library/unix/sockets.factor

@@ -106,7 +106,9 @@ M: accept-task do-io-task ( task -- ? )
 M: accept-task task-container drop read-tasks get ;
 
 : wait-to-accept ( server -- )
-    [ swap <accept-task> add-io-task stop ] callcc0 drop ;
+    [
+        swap <accept-task> add-io-task stop
+    ] with-continuation drop ;
 
 : timeout-opt ( fd level opt value -- )
     "timeval" c-size setsockopt io-error ;

native/run.c

@@ -2,7 +2,7 @@
 
 INLINE void execute(F_WORD* word)
 {
-	((XT)(word->xt))(word);
+	call_into_factor((XT)word->xt,word);
 }
 
 void run(void)

native/run.h

@@ -85,11 +85,12 @@ INLINE void call(CELL quot)
 	callframe = quot;
 }
 
+void call_into_factor(F_WORD *word, XT xt);
 void run(void);
 void platform_run(void);
-void undefined(F_WORD* word);
-void docol(F_WORD* word);
-void dosym(F_WORD* word);
+void undefined(F_WORD *word);
+void docol(F_WORD *word);
+void dosym(F_WORD *word);
 void primitive_execute(void);
 void primitive_call(void);
 void primitive_ifte(void);