Hi everybody,
I have implemented a reflective Factor interpreter in Factor, along with
a basic trace and stepper tool. This code should work with Factor 0.67.
---->8-------------
USE: vectors
USE: namespaces
USE: logic
USE: kernel
USE: combinators
USE: lists
USE: words
USE: stack
USE: errors
USE: continuations
USE: strings
USE: prettyprint
USE: stdio
! A Factor interpreter written in Factor. Used by compiler for
! partial evaluation, also for trace and step.
! Meta-stacks
SYMBOL: meta-rs
: >R meta-rs get vector-push ;
: R> meta-rs get vector-pop ;
SYMBOL: meta-ds
: >D meta-ds get vector-push ;
: D> meta-ds get vector-pop ;
SYMBOL: meta-ns
SYMBOL: meta-cs
! Call frame
SYMBOL: meta-cf
: init-interpreter ( -- )
10 <vector> meta-rs set
10 <vector> meta-ds set
10 <vector> meta-ns set
10 <vector> meta-cs set
f meta-cf set ;
: done? ( -- ? )
meta-cf get not meta-rs get vector-empty? and ;
! Callframe.
: next ( -- obj )
meta-cf get [
uncons meta-cf set
] [
R> meta-cf set next
] ifte* ;
: host-word ( word -- )
#! Swap in the meta-interpreter's stacks, execute the word,
#! swap in the old stacks. This is so messy.
>D datastack >D
meta-ds get set-datastack
>r execute datastack r> tuck vector-push
set-datastack meta-ds set ;
: meta-call ( quot -- )
#! Note we do tail call optimization here.
meta-cf get [ >R ] when* meta-cf set ;
: meta-word ( word -- )
dup "metaword" word-property dup [
nip call
] [
drop dup compound? [
word-parameter meta-call
] [
host-word
] ifte
] ifte ;
: do ( obj -- )
dup word? [ meta-word ] [ >D ] ifte ;
: interpret ( quot -- )
#! The quotation is called with each word as its executed.
done? [ drop ] [ [ next swap call ] keep interpret ] ifte ;
: (run) ( -- )
[ do ] interpret ;
: set-metaword ( word quot -- )
"metaword" set-word-property ;
\ >r [ D> >R ] set-metaword
\ r> [ R> >D ] set-metaword
\ >n [ D> meta-ns get vector-push ] set-metaword
\ n> [ meta-ns get vector-pop >D ] set-metaword
\ namestack* [ meta-ns get >D ] set-metaword
\ set-namestack* [ D> meta-ns set ] set-metaword
\ >c [ D> meta-cs get vector-push ] set-metaword
\ c> [ meta-cs get vector-pop >D ] set-metaword
\ call [ D> meta-call ] set-metaword
\ execute [ D> meta-word ] set-metaword
\ ifte [ D> D> D> [ nip ] [ drop ] ifte meta-call ] set-metaword
\ datastack [ meta-ds get vector-clone >D ] set-metaword
\ callstack [ meta-rs get vector-clone >D ] set-metaword
\ set-datastack [ D> vector-clone meta-ds set ] set-metaword
\ set-callstack [ D> vector-clone meta-rs set ] set-metaword
! Some useful tools
: report ( obj -- )
meta-rs get vector-length " " fill write . flush ;
: (trace) ( -- )
[ dup report do ] interpret ;
: trace ( quot -- )
#! Trace execution of a quotation by printing each word as
#! its executed, and each literal as its pushed. Each line
#! is indented by the call stack height.
[
init-interpreter
meta-cf set
(trace)
meta-ds get set-datastack
] with-scope ;
: step-banner ( -- )
"The following words control the single-stepper:" print
"&s -- print stepper data stack" print
"&r -- print stepper call stack" print
"&n -- print stepper name stack" print
"&c -- print stepper catch stack" print
"&* -- single step" print
"(trace) -- trace until end" print
"(run) -- run until end" print ;
: step ( quot -- )
#! Single-step through execution of a quotation.
init-interpreter
meta-cf set
step-banner ;
: &s
#! Print stepper data stack.
meta-ds get [ . ] vector-each ;
: &r
#! Print stepper call stack.
meta-rs get [ . ] vector-each meta-cf get . ;
: &n
#! Print stepper name stack.
meta-ns get [ . ] vector-each ;
: &c
#! Print stepper catch stack.
meta-cs get [ . ] vector-each ;
: not-done ( quot -- )
done? [ "Stepper is done." print drop ] [ call ] ifte ;
: &*
#! Step into current word.
[ next dup report do ] not-done ;