Walker cleanup

library/compiler/inference/branches.factor

@@ -1,7 +1,7 @@
 ! Copyright (C) 2004, 2006 Slava Pestov.
 ! See http://factorcode.org/license.txt for BSD license.
 IN: inference
-USING: arrays errors generic hashtables interpreter kernel math
+USING: arrays errors generic hashtables kernel math
 namespaces parser prettyprint sequences strings vectors words ;
 
 : unify-lengths ( seq -- newseq )

library/compiler/inference/dataflow.factor

@@ -1,9 +1,21 @@
 ! Copyright (C) 2004, 2006 Slava Pestov.
 ! See http://factorcode.org/license.txt for BSD license.
 IN: inference
-USING: arrays generic hashtables interpreter kernel math
+USING: arrays generic hashtables kernel math
 namespaces parser sequences words ;
 
+SYMBOL: d-in
+SYMBOL: meta-d
+SYMBOL: meta-r
+
+: push-d meta-d get push ;
+: pop-d meta-d get pop ;
+: peek-d meta-d get peek ;
+
+: push-r meta-r get push ;
+: pop-r meta-r get pop ;
+: peek-r meta-r get peek ;
+
 TUPLE: node param shuffle
        classes literals history
        successor children ;

library/compiler/inference/dataflow.facts

@@ -14,3 +14,6 @@ HELP: current-node
 HELP: remember-node
 { $values { "word" "a word" } { "node" "a dataflow node" } }
 { $description "Annotates all nodes starting from " { $snippet "node" } " with the fact that they were inlined from " { $snippet "word" } ". This prevents infinite loops when the optimizer inlines words." } ;
+
+HELP: d-in
+{ $var-description "During inference, holds the number of inputs which the quotation has been inferred to require so far." } ;

library/compiler/inference/inference.factor

@@ -1,7 +1,7 @@
 ! Copyright (C) 2004, 2006 Slava Pestov.
 ! See http://factorcode.org/license.txt for BSD license.
 IN: inference
-USING: arrays errors generic inspector interpreter io kernel
+USING: arrays errors generic inspector io kernel
 math namespaces parser prettyprint sequences strings
 vectors words ;
 
@@ -19,8 +19,6 @@ TUPLE: literal-expected ;
 M: object value-literal
     <literal-expected> inference-error ;
 
-SYMBOL: d-in
-
 : pop-literal ( -- rstate obj )
     1 #drop node,
     pop-d dup value-recursion swap value-literal ;

library/compiler/inference/inference.facts

@@ -22,9 +22,6 @@ HELP: literal-expected
 { $error-description "Thrown when inference encounters a " { $link call } " or " { $link if } " being applied to a value which is not known to be a literal. Such a form can have an arbitrary stack effect, and does not compile." }
 { $notes "This error will be thrown when compiling any combinator, such as " { $link each } ". However, words calling combinators can compile of the combinator is declared " { $link POSTPONE: inline } " and the quotation being passed in is a literal." } ;
 
-HELP: d-in
-{ $var-description "During inference, holds the number of inputs which the quotation has been inferred to require so far." } ;
-
 HELP: terminated?
 { $var-description "During inference, a flag set to " { $link t } " if the current control flow path unconditionally throws an error." } ;
 

library/compiler/inference/known-words.factor

@@ -1,6 +1,6 @@
 IN: inference
 USING: arrays alien assembler errors generic hashtables
-hashtables-internals interpreter io io-internals kernel
+hashtables-internals io io-internals kernel
 kernel-internals math math-internals memory parser
 sequences strings vectors words prettyprint ;
 

library/compiler/inference/stack.factor

@@ -1,5 +1,5 @@
 IN: inference
-USING: arrays generic interpreter kernel math namespaces
+USING: arrays generic kernel math namespaces
 sequences words parser ;
 
 : infer-shuffle-inputs ( shuffle node -- )

library/compiler/inference/words.factor

@@ -1,6 +1,6 @@
 ! Copyright (C) 2004, 2006 Slava Pestov.
 ! See http://factorcode.org/license.txt for BSD license.
-USING: arrays errors generic hashtables interpreter kernel
+USING: arrays errors generic hashtables kernel
 math math-internals namespaces parser prettyprint sequences
 strings vectors words ;
 IN: inference

library/test/interpreter.factor

@@ -5,14 +5,11 @@ namespaces prettyprint sequences test ;
 : run ( -- ) done? [ step-in run ] unless ;
 
 : init-interpreter ( -- )
-    V{ } clone meta-d set
-    V{ } clone meta-r set
-    V{ } clone meta-c set
-    namestack meta-name set
-    catchstack meta-catch set ;
+    V{ } clone V{ } clone V{ } clone namestack catchstack
+    <continuation> meta-interp set ;
 
 : test-interpreter
-    init-interpreter (meta-call) run meta-d get ;
+    init-interpreter (meta-call) run meta-d ;
 
 [ V{ } ] [
     [ ] test-interpreter
@@ -42,6 +39,36 @@ namespaces prettyprint sequences test ;
     [ 2 2 fixnum+ ] test-interpreter
 ] unit-test
 
+: foo 2 2 fixnum+ ;
+
+[ V{ 8 } ] [
+    [ foo 4 fixnum+ ] test-interpreter
+] unit-test
+
+[ V{ C{ 1 1.5 } { } C{ 1 1.5 } { } } ] [
+    [ C{ 1 1.5 } { } 2dup ] test-interpreter
+] unit-test
+
+[ V{ 3 4 1 2 } ] [
+    [ 1 2 3 4 2swap ] test-interpreter
+] unit-test
+
+[ V{ t } ] [
+    [ 5 5 number= ] test-interpreter
+] unit-test
+
+[ V{ f } ] [
+    [ 5 6 number= ] test-interpreter
+] unit-test
+
+[ V{ -1 } ] [
+    [ "XYZ" "XYZ" 3 (mismatch) ] test-interpreter
+] unit-test
+
+[ V{ t } ] [
+    [ "XYZ" "XYZ" sequence= ] test-interpreter
+] unit-test
+
 [ V{ t } ] [
     [ "XYZ" "XYZ" = ] test-interpreter
 ] unit-test
@@ -50,10 +77,6 @@ namespaces prettyprint sequences test ;
     [ "XYZ" "XuZ" = ] test-interpreter
 ] unit-test
 
-[ V{ C{ 1 1.5 } { } C{ 1 1.5 } { } } ] [
-    [ C{ 1 1.5 } { } 2dup ] test-interpreter
-] unit-test
-
 [ V{ 4 } ] [
     [ 2 2 + ] test-interpreter
 ] unit-test

library/tools/interpreter.factor

@@ -8,21 +8,23 @@ namespaces prettyprint sequences strings threads vectors words ;
 ! continuation to and from the primary interpreter. Used by
 ! compiler for partial evaluation, also by the walker.
 
+SYMBOL: meta-interp
+
 ! Meta-stacks;
-SYMBOL: meta-d
-: push-d meta-d get push ;
-: pop-d meta-d get pop ;
-: peek-d meta-d get peek ;
-SYMBOL: meta-r
-: push-r meta-r get push ;
-: pop-r meta-r get pop ;
-: peek-r meta-r get peek ;
-SYMBOL: meta-c
-: push-c meta-c get push ;
-: pop-c meta-c get pop ;
-: peek-c meta-c get peek ;
-SYMBOL: meta-name
-SYMBOL: meta-catch
+: meta-d meta-interp get continuation-data ;
+: push-d meta-d push ;
+: pop-d meta-d pop ;
+: peek-d meta-d peek ;
+
+: meta-r meta-interp get continuation-retain ;
+: push-r meta-r push ;
+: pop-r meta-r pop ;
+: peek-r meta-r peek ;
+
+: meta-c meta-interp get continuation-call ;
+: push-c meta-c push ;
+: pop-c meta-c pop ;
+: peek-c meta-c peek ;
 
 ! Call frame
 SYMBOL: callframe
@@ -45,7 +47,7 @@ SYMBOL: callframe-end
 
 : done-cf? ( -- ? ) callframe-scan get callframe-end get >= ;
 
-: done? ( -- ? ) done-cf? meta-c get empty? and ;
+: done? ( -- ? ) done-cf? meta-c empty? and ;
 
 : (next)
     callframe-scan get callframe get nth callframe-scan inc ;
@@ -57,24 +59,8 @@ SYMBOL: callframe-end
         { [ t ] [ >r (next) r> call ] }
     } cond ; inline
 
-: meta-interp ( -- interp )
-    meta-d get meta-r get meta-c get
-    meta-name get meta-catch get <continuation> ;
-
 : init-meta-interp ( -- )
-    V{ } clone meta-catch set
-    V{ } clone meta-name set
-    V{ } clone meta-c set
-    V{ } clone meta-r set
-    V{ } clone meta-d set ;
-
-: set-meta-interp ( interp -- )
-    >continuation<
-    meta-catch set
-    meta-name set
-    meta-c set
-    meta-r set
-    meta-d set ;
+    <empty-continuation> meta-interp set ;
 
 : save-callframe ( -- )
     done-cf? [
@@ -103,17 +89,18 @@ SYMBOL: callframe-end
     ] [ ] make ;
 
 : restore-harness ( obj -- )
+    #! Error handler
     dup array? [
         init-meta-interp [ ] (meta-call)
         first2 schedule-thread-with
     ] [
-        set-meta-interp
+        meta-interp set
     ] if ;
 
 : host-quot ( quot -- )
     [
-        host-harness <callframe> meta-c get swap nappend
-        meta-interp continue
+        host-harness <callframe> meta-c swap nappend
+        meta-interp get continue
     ] callcc1 restore-harness drop ;
 
 : host-word ( word -- ) unit host-quot ;
@@ -162,6 +149,6 @@ M: object do do-1 ;
 : step-all ( -- )
     save-callframe
     meta-c [ V{ [ stop ] 0 1 } swap append ] change
-    meta-interp schedule-thread yield
+    meta-interp get schedule-thread yield
     V{ } clone meta-c set
     [ ] (meta-call) ;

library/ui/tools/walker.factor

@@ -41,9 +41,9 @@ TUPLE: walker-gadget track ds rs cs quot ns ;
 : walker-gadget-input walker-gadget-track walker-track-input ;
 
 : update-stacks ( walker -- )
-    meta-d get over walker-gadget-ds set-model
-    meta-r get over walker-gadget-rs set-model
-    meta-c get over walker-gadget-cs set-model
+    meta-d over walker-gadget-ds set-model
+    meta-r over walker-gadget-rs set-model
+    meta-c over walker-gadget-cs set-model
     meta-callframe swap walker-gadget-quot set-model ;
 
 : with-walker ( walker quot -- )
@@ -98,7 +98,7 @@ M: walker-gadget focusable-child*
 : init-walker ( walker -- )
     H{ } clone over set-walker-gadget-ns
     walker-continuation swap [
-        set-meta-interp
+        meta-interp set
         [ ] (meta-call)
     ] with-walker ;