! Copyright (C) 2004, 2005 Slava Pestov.
! See http://factor.sf.net/license.txt for BSD license.
IN: interpreter
USING: errors generic io kernel kernel-internals lists math
namespaces prettyprint sequences strings vectors words ;

! A Factor interpreter written in Factor. Used by compiler for
! partial evaluation, also by the walker.

! Meta-stacks
SYMBOL: meta-r
: push-r meta-r get push ;
: pop-r meta-r get pop ;
SYMBOL: meta-d
: push-d meta-d get push ;
: pop-d meta-d get pop ;
SYMBOL: meta-n
SYMBOL: meta-c

! Call frame
SYMBOL: meta-cf

! Currently executing word.
SYMBOL: meta-executing

: init-interpreter ( -- )
    { } clone meta-r set
    { } clone meta-d set
    namestack meta-n set
    catchstack meta-c set
    f meta-cf set
    f meta-executing set ;

: copy-interpreter ( -- )
    #! Copy interpreter state from containing namespaces.
    meta-r [ clone ] change
    meta-d [ clone ] change
    meta-n [ ] change
    meta-c [ ] change ;

! Callframe.
: up ( -- ) pop-r meta-cf set  pop-r drop ;

: next ( -- obj )
    meta-cf get [ meta-cf [ uncons ] change ] [ up next ] ifte ;

: meta-interp ( -- interp )
    meta-d get meta-r get meta-n get meta-c get <interp> ;

: set-meta-interp ( interp -- )
    >interp< meta-c set meta-n set meta-r set meta-d set ;

: host-word ( word -- )
    [
        \ call push-r  interp [
            interp over interp-data push
            [ ] set-interp
        ] cons cons push-r  meta-interp [ ] set-interp
    ] call  set-meta-interp  pop-d 2drop ;

: meta-call ( quot -- )
    #! Note we do tail call optimization here.
    meta-cf [
        [ meta-executing get push-r  push-r ] when*
    ] change ;

GENERIC: do ( obj -- )

M: word do ( word -- )
    dup "meta-word" word-prop [
        call
    ] [
        dup compound? [
            dup word-def meta-call  meta-executing set
        ] [
            host-word
        ] ifte
    ] ?ifte ;

M: wrapper do ( wrapper -- ) wrapped push-d ;

M: object do ( object -- ) push-d ;

GENERIC: do-1 ( object -- )

M: word do-1 ( word -- )
    dup "meta-word" word-prop [ call ] [ host-word ] ?ifte ;

M: wrapper do-1 ( wrapper -- ) wrapped push-d ;

M: object do-1 ( object -- ) push-d ;

: set-meta-word ( word quot -- ) "meta-word" set-word-prop ;

\ datastack [ meta-d get clone push-d ] set-meta-word
\ set-datastack [ pop-d clone meta-d set ] set-meta-word
\ >r [ pop-d push-r ] set-meta-word
\ r> [ pop-r push-d ] set-meta-word
\ callstack [ meta-r get clone push-d ] set-meta-word
\ set-callstack [ pop-d clone meta-r set ] set-meta-word
\ call [ pop-d meta-call ] set-meta-word
\ execute [ pop-d do ] set-meta-word
\ ifte [ pop-d pop-d pop-d [ nip ] [ drop ] ifte meta-call ] set-meta-word
\ dispatch [ pop-d pop-d swap nth meta-call ] set-meta-word

\ set-meta-word forget