Fixing some more bugs

basis/bootstrap/compiler/compiler.factor

@@ -5,8 +5,9 @@ sequences namespaces parser kernel kernel.private classes
 classes.private arrays hashtables vectors classes.tuple sbufs
 hashtables.private sequences.private math classes.tuple.private
 growable namespaces.private assocs words command-line vocabs io
-io.encodings.string prettyprint libc compiler.units math.order
-compiler.tree.builder compiler.tree.optimizer ;
+io.encodings.string prettyprint libc splitting math.parser
+compiler.units math.order compiler.tree.builder
+compiler.tree.optimizer ;
 IN: bootstrap.compiler
 
 ! Don't bring this in when deploying, since it will store a
@@ -71,13 +72,21 @@ nl
 "." write flush
 
 {
-    . lines
+    memq? split harvest sift cut cut-slice start index clone
+    set-at reverse push-all class number>string string>number
 } compile-uncompiled
 
 "." write flush
 
 {
-    malloc calloc free memcpy
+    lines prefix suffix unclip new-assoc update
+    word-prop set-word-prop 1array 2array 3array ?nth
+} compile-uncompiled
+
+"." write flush
+
+{
+    . malloc calloc free memcpy
 } compile-uncompiled
 
 { build-tree } compile-uncompiled

basis/cocoa/messages/messages.factor

@@ -4,7 +4,7 @@ USING: alien alien.c-types alien.strings
 arrays assocs combinators compiler kernel
 math namespaces parser prettyprint prettyprint.sections
 quotations sequences strings words cocoa.runtime io macros
-memoize debugger io.encodings.ascii effects ;
+memoize debugger io.encodings.ascii effects compiler.generator ;
 IN: cocoa.messages
 
 : make-sender ( method function -- quot )

basis/columns/columns-docs.factor

@@ -6,7 +6,7 @@ ARTICLE: "columns" "Column sequences"
 { $subsection column }
 { $subsection <column> }
 "A utility word:"
-{ $subsection flipped } ;
+{ $subsection <flipped> } ;
 
 HELP: column
 { $class-description "A virtual sequence which presents a fixed column of a matrix represented as a sequence of rows. New instances can be created by calling " { $link <column> } "." } ;

basis/compiler/compiler.factor

@@ -46,7 +46,6 @@ SYMBOL: +failed+
     ] tri ;
 
 : (compile) ( word -- )
-    USE: prettyprint dup .
     '[
         H{ } clone dependencies set
 

basis/compiler/generator/fixup/fixup-docs.factor

@@ -1,5 +1,5 @@
 USING: help.syntax help.markup math kernel
-words strings alien ;
+words strings alien compiler.generator ;
 IN: compiler.generator.fixup
 
 HELP: frame-required
@@ -14,3 +14,6 @@ HELP: rel-dlsym
 { $values { "name" string } { "dll" "a " { $link dll } " or " { $link f } } { "class" "a relocation class" } }
 { $description "Records that the most recently assembled instruction contains a reference to the " { $snippet "name" } " symbol from " { $snippet "dll" } ". The correct " { $snippet "class" } " to use depends on instruction formats."
 } ;
+
+HELP: literal-table
+{ $var-description "Holds a vector of literal objects referenced from the currently compiling word. If " { $link compiled-stack-traces? } " is on, " { $link begin-compiling } " ensures that the first entry is the word being compiled." } ;

basis/compiler/generator/generator-docs.factor

@@ -1,6 +1,6 @@
-USING: help.markup help.syntax words debugger generator.fixup
-generator.registers quotations kernel vectors arrays effects
-sequences ;
+USING: help.markup help.syntax words debugger
+compiler.generator.fixup compiler.generator.registers quotations
+kernel vectors arrays effects sequences ;
 IN: compiler.generator
 
 ARTICLE: "generator" "Compiled code generator"
@@ -31,9 +31,6 @@ HELP: compiled-stack-traces?
 { $values { "?" "a boolean" } }
 { $description "Iftrue, compiled code blocks will retain what word they were compiled from. This information is used by " { $link :c } " to display call stack traces after an error is thrown from compiled code. This is on by default; the deployment tool switches it off to save some space in the deployed image." } ;
 
-HELP: literal-table
-{ $var-description "Holds a vector of literal objects referenced from the currently compiling word. If " { $link compiled-stack-traces? } " is on, " { $link begin-compiling } " ensures that the first entry is the word being compiled." } ;
-
 HELP: begin-compiling
 { $values { "word" word } { "label" word } }
 { $description "Prepares to generate machine code for a word." } ;

basis/compiler/generator/generator.factor

@@ -92,7 +92,7 @@ M: node generate-node drop iterate-next ;
     %jump-label ;
 
 : generate-call ( label -- next )
-    ! dup maybe-compile
+    dup maybe-compile
     end-basic-block
     dup compiling-loops get at [
         %jump-label f
@@ -255,13 +255,13 @@ M: #shuffle generate-node
     shuffle-effect phantom-shuffle iterate-next ;
 
 M: #>r generate-node
-    in-d>> length
-    phantom->r
+    [ in-d>> length ] [ out-r>> empty? ] bi
+    [ phantom-drop ] [ phantom->r ] if
     iterate-next ;
 
 M: #r> generate-node
-    out-d>> length
-    phantom-r>
+    [ in-r>> length ] [ out-d>> empty? ] bi
+    [ phantom-rdrop ] [ phantom-r> ] if
     iterate-next ;
 
 ! #return

basis/compiler/generator/registers/registers.factor

@@ -658,3 +658,9 @@ UNION: immediate fixnum POSTPONE: f ;
 : phantom-r> ( n -- )
     phantom-retainstack get phantom-input
     phantom-datastack get phantom-append ;
+
+: phantom-drop ( n -- )
+    phantom-datastack get phantom-input drop ;
+
+: phantom-rdrop ( n -- )
+    phantom-retainstack get phantom-input drop ;

basis/compiler/tree/checker/checker.factor

@@ -31,9 +31,12 @@ M: #shuffle check-node*
 
 M: #copy check-node* inputs/outputs 2array check-lengths ;
 
-M: #>r check-node* inputs/outputs 2array check-lengths ;
+: check->r/r> ( node -- )
+    inputs/outputs dup empty? [ 2drop ] [ 2array check-lengths ] if ;
 
-M: #r> check-node* inputs/outputs 2array check-lengths ;
+M: #>r check-node* check->r/r> ;
+
+M: #r> check-node* check->r/r> ;
 
 M: #return-recursive check-node* inputs/outputs 2array check-lengths ;
 
@@ -43,9 +46,10 @@ M: #phi check-node*
     bi ;
 
 M: #enter-recursive check-node*
+    [ [ label>> enter-out>> ] [ out-d>> ] bi assert= ]
     [ [ in-d>> ] [ out-d>> ] bi 2array check-lengths ]
     [ recursive-phi-in check-lengths ]
-    bi ;
+    tri ;
 
 M: #push check-node*
     out-d>> length 1 = [ "Bad #push" throw ] unless ;
@@ -72,7 +76,7 @@ SYMBOL: terminated?
 GENERIC: check-stack-flow* ( node -- )
 
 : (check-stack-flow) ( nodes -- )
-    [ check-stack-flow* ] each ;
+    [ check-stack-flow* terminated? get not ] all? drop ;
 
 : init-stack-flow ( -- )
     V{ } clone datastack set
@@ -164,31 +168,27 @@ M: #branch check-stack-flow*
 
 : check-phi-in ( #phi -- )
     phi-in-d>> branch-out get [
-        over [ +bottom+ eq? ] all? [
-            2drop
-        ] [
+        dup [
             over length tail* sequence= [
                 "Branch outputs don't match phi inputs"
                 throw
             ] unless
+        ] [
+            2drop
         ] if
     ] 2each ;
 
 : set-phi-datastack ( #phi -- )
     phi-in-d>> first length
-    branch-out get [ ] find nip
-    dup [ swap head* >vector ] [ 2drop V{ } clone ] if datastack set ;
+    branch-out get [ ] find nip swap head* >vector datastack set ;
 
 M: #phi check-stack-flow*
-    [ check-phi-in ] [ set-phi-datastack ] [ check-out-d ] tri ;
+    branch-out get [ ] contains? [
+        [ check-phi-in ] [ set-phi-datastack ] [ check-out-d ] tri
+    ] [ drop terminated? on ] if ;
 
 M: #recursive check-stack-flow*
-    [
-        init-stack-flow
-        child>> (check-stack-flow)
-        datastack get
-    ] with-scope
-    datastack set ;
+    [ check-in-d ] [ child>> (check-stack-flow) ] bi ;
 
 M: #copy check-stack-flow* [ check-in-d ] [ check-out-d ] bi ;
 

basis/compiler/tree/cleanup/cleanup-tests.factor

@@ -443,3 +443,11 @@ cell-bits 32 = [
 [ ] [
     [ { merge } declare accum>> 0 >>length ] cleaned-up-tree drop
 ] unit-test
+
+[ ] [
+    [
+        [ "X" throw ]
+        [ dupd dup -1 < [ 0 >= [ ] [ "X" throw ] if ] [ drop ] if ]
+        if
+    ] cleaned-up-tree drop
+] unit-test

basis/compiler/tree/dead-code/dead-code-tests.factor

@@ -5,7 +5,7 @@ compiler.tree.cleanup compiler.tree.escape-analysis
 compiler.tree.tuple-unboxing compiler.tree.debugger
 compiler.tree.normalization compiler.tree.checker tools.test
 kernel math stack-checker.state accessors combinators io
-prettyprint ;
+prettyprint words sequences.deep sequences.private ;
 IN: compiler.tree.dead-code.tests
 
 \ remove-dead-code must-infer
@@ -106,3 +106,70 @@ IN: compiler.tree.dead-code.tests
 : boo ( a b -- c ) 2drop f ;
 
 [ [ dup 4 eq? [ nip ] [ boo ] if ] ] [ [ dup dup 4 eq? [ drop nip ] [ drop boo ] if ] optimize-quot ] unit-test
+
+: squish ( quot -- quot' )
+    [
+        {
+            { [ dup word? ] [ dup vocabulary>> [ drop "REC" ] unless ] }
+            { [ dup wrapper? ] [ dup wrapped>> vocabulary>> [ drop "WRAP" ] unless ] }
+            [ ]
+        } cond
+    ] deep-map ;
+
+: call-recursive-dce-1 ( a -- b )
+    [ call-recursive-dce-1 drop ] [ call-recursive-dce-1 ] bi ; inline recursive
+
+[ [ "WRAP" [ dup >r "REC" drop r> "REC" ] label ] ] [
+    [ call-recursive-dce-1 ] optimize-quot squish
+] unit-test
+
+: produce-a-value ( -- a ) f ;
+
+: call-recursive-dce-2 ( a -- b )
+    drop
+    produce-a-value dup . call-recursive-dce-2 ; inline recursive
+
+[ [ "WRAP" [ produce-a-value . "REC" ] label ] ] [
+    [ f call-recursive-dce-2 drop ] optimize-quot squish
+] unit-test
+
+[ [ "WRAP" [ produce-a-value dup . drop "REC" ] label ] ] [
+    [ f call-recursive-dce-2 ] optimize-quot squish
+] unit-test
+
+: call-recursive-dce-3 ( a -- )
+    call-recursive-dce-3 ; inline recursive
+
+[ [ [ drop "WRAP" [ "REC" ] label ] [ . ] if ] ] [
+    [ [ call-recursive-dce-3 ] [ . ] if ] optimize-quot squish
+] unit-test
+
+[ [ drop "WRAP" [ "REC" ] label ] ] [
+    [ call-recursive-dce-3 ] optimize-quot squish
+] unit-test
+
+: call-recursive-dce-4 ( a -- b )
+    call-recursive-dce-4 ; inline recursive
+
+[ [ "WRAP" [ "REC" ] label ] ] [
+    [ call-recursive-dce-4 ] optimize-quot squish
+] unit-test
+
+[ [ drop "WRAP" [ "REC" ] label ] ] [
+    [ call-recursive-dce-4 drop ] optimize-quot squish
+] unit-test
+
+[ ] [ [ f call-recursive-dce-3 swap ] optimize-quot drop ] unit-test
+
+: call-recursive-dce-5 ( -- ) call-recursive-dce-5 ; inline recursive
+
+[ ] [ [ call-recursive-dce-5 swap ] optimize-quot drop ] unit-test
+
+[ ] [ [ [ 0 -rot set-nth-unsafe ] curry (each-integer) ] optimize-quot drop ] unit-test
+
+: call-recursive-dce-6 ( i quot: ( i -- ? ) -- i )
+    dup call [ drop ] [ call-recursive-dce-6 ] if ; inline recursive
+
+[ ] [ [ [ ] curry [ ] swap compose call-recursive-dce-6 ] optimize-quot drop ] unit-test
+
+[ ] [ [ [ ] rot [ . ] curry pick [ roll 2drop call ] [ 2nip call ] if ] optimize-quot drop ] unit-test

basis/compiler/tree/dead-code/recursive/recursive.factor

@@ -1,12 +1,16 @@
 ! Copyright (C) 2008 Slava Pestov.
 ! See http://factorcode.org/license.txt for BSD license.
-USING: accessors sequences kernel
-compiler.tree compiler.tree.dead-code.branches
+USING: accessors arrays assocs sequences kernel locals fry
+combinators stack-checker.backend
+compiler.tree
+compiler.tree.dead-code.branches
 compiler.tree.dead-code.liveness
 compiler.tree.dead-code.simple ;
 IN: compiler.tree.dead-code.recursive
 
 M: #enter-recursive compute-live-values*
+    #! If the output of an #enter-recursive is live, then the
+    #! corresponding inputs to the #call-recursive are live also.
     [ out-d>> ] [ recursive-phi-in ] bi look-at-phi ;
 
 : return-recursive-phi-in ( #return-recursive -- phi-in )
@@ -16,22 +20,60 @@ M: #return-recursive compute-live-values*
     [ out-d>> ] [ return-recursive-phi-in ] bi look-at-phi ;
 
 M: #call-recursive compute-live-values*
-    #! If the output of a copy is live, then the corresponding
-    #! inputs to #return nodes are live also.
+    #! If the output of a #call-recursive is live, then the
+    #! corresponding inputs to #return nodes are live also.
     [ out-d>> ] [ label>> return>> in-d>> ] bi look-at-mapping ;
 
-M: #recursive remove-dead-code*
-    [ filter-live ] change-in-d
-    [ (remove-dead-code) ] change-child ;
+:: drop-dead-inputs ( inputs outputs -- #shuffle )
+    [let* | new-inputs [ inputs make-values ]
+            live-inputs [ outputs inputs filter-corresponding ]
+            new-live-inputs [ outputs new-inputs filter-corresponding ]
+            mapping [ new-live-inputs live-inputs zip ] |
+        inputs filter-live
+        new-live-inputs
+        mapping
+        #shuffle
+    ] ;
 
-M: #call-recursive remove-dead-code*
-    [ filter-live ] change-in-d
-    [ filter-live ] change-out-d ;
+M: #recursive remove-dead-code* ( node -- nodes )
+    dup [ in-d>> ] [ label>> enter-out>> ] bi drop-dead-inputs
+    {
+        [ [ dup label>> enter-recursive>> ] [ out-d>> ] bi* '[ , >>in-d drop ] bi@ ]
+        [ drop [ (remove-dead-code) ] change-child drop ]
+        [ drop label>> [ filter-live ] change-enter-out drop ]
+        [ swap 2array ]
+    } 2cleave ;
 
 M: #enter-recursive remove-dead-code*
-    [ filter-live ] change-in-d
     [ filter-live ] change-out-d ;
 
-M: #return-recursive remove-dead-code*
-    [ filter-live ] change-in-d
-    [ filter-live ] change-out-d ;
+: drop-call-recursive-inputs ( node -- #shuffle )
+    dup [ in-d>> ] [ label>> enter-out>> ] bi drop-dead-inputs
+    [ out-d>> >>in-d drop ]
+    [ nip ]
+    2bi ;
+
+:: drop-call-recursive-outputs ( node -- #shuffle )
+    [let* | node-out [ node out-d>> ]
+            return-in [ node label>> return>> in-d>> ]
+            node-out-live [ return-in node-out filter-corresponding ]
+            new-node-out-live [ node-out-live make-values ]
+            node-out-dropped [ node-out filter-live ]
+            new-node-out-dropped [ node-out-dropped new-node-out-live filter-corresponding ]
+            mapping [ node-out-dropped new-node-out-dropped zip ] |
+        node new-node-out-live >>out-d drop
+        new-node-out-live node-out-dropped mapping #shuffle
+    ] ;
+
+M: #call-recursive remove-dead-code*
+    [ drop-call-recursive-inputs ]
+    [ ]
+    [ drop-call-recursive-outputs ]
+    tri 3array ;
+
+M: #return-recursive remove-dead-code* ( node -- nodes )
+    dup [ in-d>> ] [ out-d>> ] bi drop-dead-inputs
+    [ drop [ filter-live ] change-out-d drop ]
+    [ out-d>> >>in-d drop ]
+    [ swap 2array ]
+    2tri ;

basis/compiler/tree/dead-code/simple/simple.factor

@@ -41,12 +41,17 @@ M: #alien-indirect compute-live-values* nip look-at-inputs ;
 : filter-mapping ( assoc -- assoc' )
     live-values get '[ drop , key? ] assoc-filter ;
 
-: filter-corresponding ( new old -- new' )
+: filter-corresponding ( new old -- old' )
+    #! Remove elements from 'old' if the element with the same
+    #! index in 'new' is dead.
     zip filter-mapping values ;
 
 : filter-live ( values -- values' )
     [ live-value? ] filter ;
 
+: drop-dead-values ( in out -- #shuffle )
+    [ make-values dup ] keep zip #shuffle ;
+
 :: drop-dead-outputs ( node -- nodes )
     [let* | old-outputs [ node out-d>> ]
             new-outputs [ old-outputs make-values ]

basis/compiler/tree/normalization/normalization-tests.factor

@@ -1,6 +1,7 @@
 IN: compiler.tree.normalization.tests
 USING: compiler.tree.builder compiler.tree.normalization
-compiler.tree sequences accessors tools.test kernel math ;
+compiler.tree compiler.tree.checker
+sequences accessors tools.test kernel math ;
 
 \ count-introductions must-infer
 \ normalize must-infer
@@ -24,20 +25,24 @@ compiler.tree sequences accessors tools.test kernel math ;
     [ normalize recursive-inputs ] bi
 ] unit-test
 
-[ ] [ [ [ 1 ] [ 2 ] if + * ] build-tree normalize drop ] unit-test
+[ ] [ [ [ 1 ] [ 2 ] if + * ] build-tree normalize check-nodes ] unit-test
 
 DEFER: bbb
 : aaa ( x -- ) dup [ dup >r bbb r> aaa ] [ drop ] if ; inline recursive
 : bbb ( x -- ) >r drop 0 r> aaa ; inline recursive
 
-[ ] [ [ bbb ] build-tree normalize drop ] unit-test
+[ ] [ [ bbb ] build-tree normalize check-nodes ] unit-test
 
 : ccc ( -- ) ccc drop 1 ; inline recursive
 
-[ ] [ [ ccc ] build-tree normalize drop ] unit-test
+[ ] [ [ ccc ] build-tree normalize check-nodes ] unit-test
 
 DEFER: eee
 : ddd ( -- ) eee ; inline recursive
 : eee ( -- ) swap ddd ; inline recursive
 
-[ ] [ [ eee ] build-tree normalize drop ] unit-test
+[ ] [ [ eee ] build-tree normalize check-nodes ] unit-test
+
+: call-recursive-5 ( -- ) call-recursive-5 ; inline recursive
+
+[ ] [ [ call-recursive-5 swap ] build-tree normalize check-nodes ] unit-test

basis/compiler/tree/optimizer/optimizer.factor

@@ -26,5 +26,4 @@ IN: compiler.tree.optimizer
     compute-def-use
     remove-dead-code
     ! strength-reduce
-    compute-def-use USE: kernel
-    dup check-nodes ;
+    ;

basis/compiler/tree/propagation/propagation-tests.factor

@@ -567,3 +567,7 @@ M: integer infinite-loop infinite-loop ;
 [ ] [ [ instance? ] final-classes drop ] unit-test
 
 [ f ] [ [ V{ } clone ] final-info first literal?>> ] unit-test
+
+: fold-throw-test ( a -- b ) "A" throw ; foldable
+
+[ ] [ [ 0 fold-throw-test ] final-info drop ] unit-test

basis/compiler/tree/propagation/simple/simple.factor

@@ -62,10 +62,10 @@ M: #declare propagate-before
     [ in-d>> [ value-info literal?>> ] all? ] [ drop f ] if ;
 
 : fold-call ( #call word -- infos )
-    [ in-d>> [ value-info literal>> ] map ]
-    [ [ execute ] curry ]
-    bi* with-datastack
-    [ <literal-info> ] map ;
+    [ [ out-d>> ] [ in-d>> [ value-info literal>> ] map ] bi ] [ '[ , execute ] ] bi*
+    '[ , , with-datastack [ <literal-info> ] map nip ]
+    [ drop [ object-info ] replicate ]
+    recover ;
 
 : predicate-output-infos ( info class -- info )
     [ class>> ] dip {

basis/compiler/tree/tree.factor

@@ -2,7 +2,8 @@
 ! See http://factorcode.org/license.txt for BSD license.
 USING: fry arrays generic assocs kernel math namespaces parser
 sequences words vectors math.intervals effects classes
-accessors combinators stack-checker.state stack-checker.visitor ;
+accessors combinators stack-checker.state stack-checker.visitor
+stack-checker.inlining ;
 IN: compiler.tree
 
 ! High-level tree SSA form.

basis/compiler/tree/tuple-unboxing/tuple-unboxing.factor

@@ -103,7 +103,9 @@ M: #phi unbox-tuples*
     [ flatten-values ] change-out-d ;
 
 M: #recursive unbox-tuples*
-    [ flatten-values ] change-in-d ;
+    [ label>> [ flatten-values ] change-enter-out drop ]
+    [ [ flatten-values ] change-in-d ]
+    bi ;
 
 M: #enter-recursive unbox-tuples*
     [ flatten-values ] change-in-d

basis/cpu/architecture/architecture.factor

@@ -163,8 +163,8 @@ PREDICATE: small-slot < integer cells small-enough? ;
 PREDICATE: small-tagged < integer v>operand small-enough? ;
 
 : if-small-struct ( n size true false -- ? )
-    >r >r over not over struct-small-enough? and
-    [ nip r> call r> drop ] [ r> drop r> call ] if ;
+    [ over not over struct-small-enough? and ] 2dip
+    [ [ nip ] prepose ] dip if ;
     inline
 
 : %unbox-struct ( n size -- )

basis/cpu/x86/architecture/architecture.factor

@@ -2,7 +2,7 @@
 ! See http://factorcode.org/license.txt for BSD license.
 USING: alien alien.c-types arrays cpu.x86.assembler
 cpu.x86.assembler.private cpu.architecture kernel kernel.private
-math memory namespaces sequences words generator
+math memory namespaces sequences words compiler.generator
 compiler.generator.registers compiler.generator.fixup system
 layouts combinators compiler.constants math.order ;
 IN: cpu.x86.architecture

basis/help/cookbook/cookbook.factor

@@ -1,5 +1,5 @@
 USING: help.markup help.syntax io kernel math namespaces parser
-prettyprint sequences vocabs.loader namespaces inference ;
+prettyprint sequences vocabs.loader namespaces stack-checker ;
 IN: help.cookbook
 
 ARTICLE: "cookbook-syntax" "Basic syntax cookbook"

core/bootstrap/primitives.factor

@@ -72,7 +72,6 @@ bootstrapping? on
     "classes.predicate"
     "compiler.units"
     "continuations.private"
-    "generator"
     "growable"
     "hashtables"
     "hashtables.private"

core/classes/tuple/tuple.factor

@@ -164,8 +164,8 @@ ERROR: bad-superclass class ;
 
 : update-slot ( old-values n class initial -- value )
     pick [
-        >r >r swap nth dup r> instance?
-        [ r> drop ] [ drop r> ] if
+        >r >r swap nth dup r> instance? r> swap
+        [ drop ] [ nip ] if
     ] [ >r 3drop r> ] if ;
 
 : apply-slot-permutation ( old-values triples -- new-values )

core/continuations/continuations.factor

@@ -19,12 +19,9 @@ SYMBOL: restarts
 
 : c> ( -- continuation ) catchstack* pop ;
 
-: dummy ( -- obj )
-    #! Optimizing compiler assumes stack won't be messed with
-    #! in-transit. To ensure that a value is actually reified
-    #! on the stack, we put it in a non-inline word together
-    #! with a declaration.
-    f { object } declare ;
+! We have to defeat some optimizations to make continuations work
+: dummy-1 ( -- obj ) f ;
+: dummy-2 ( obj -- obj ) dup drop ;
 
 : init-catchstack ( -- ) V{ } clone 1 setenv ;
 
@@ -68,7 +65,7 @@ C: <continuation> continuation
     #! ( value f r:capture r:restore )
     #! Execution begins right after the call to 'continuation'.
     #! The 'restore' branch is taken.
-    >r >r dummy continuation r> r> ?if ; inline
+    >r >r dummy-1 continuation r> r> [ dummy-2 ] prepose ?if ; inline
 
 : callcc0 ( quot -- ) [ drop ] ifcc ; inline
 

core/lexer/lexer.factor

@@ -23,9 +23,9 @@ TUPLE: lexer text line line-text line-length column ;
     lexer new-lexer ;
 
 : skip ( i seq ? -- n )
-    over >r
+    >r tuck r>
     [ swap CHAR: \s eq? xor ] curry find-from drop
-    [ r> drop ] [ r> length ] if* ;
+    [ ] [ length ] ?if ;
 
 : change-lexer-column ( lexer quot -- )
     swap