Paste: Underload interpreter

! Copyright (C) 2012 Your name.
! See http://factorcode.org/license.txt for BSD license.
USING: kernel continuations sequences accessors io strings combinators math assocs vectors ;
IN: underload

TUPLE: underload-world program stack ;

: <underload-world> ( code -- world ) V{ } clone underload-world boa ;

: drop-first-instruction ( world -- world ) [ rest ] change-program ;

: with-ul-datastack ( world quot -- world ) [ with-datastack >vector ] curry change-stack ;

: ul~ ( world -- world )
    drop-first-instruction [ swap ] with-ul-datastack ;

: ul: ( world -- world ) drop-first-instruction [ dup ] with-ul-datastack ;

: ul! ( world -- world ) drop-first-instruction [ drop ] with-ul-datastack ;

: ul* ( world -- world ) drop-first-instruction [ append ] with-ul-datastack ;

: transfer-char ( sofar todo -- sofar todo ) [ first 1string append ] keep rest >string ;

ERROR: unbalanced-parens ;

! (parse-parens) should not receive the "(" that triggered it
: (parse-parens) ( sofar todo -- sofar todo )
     dup length zero? [ unbalanced-parens throw ] 
        [ dup first 1string {
         { "(" [ transfer-char (parse-parens) (parse-parens) ] }
         { ")" [ transfer-char ] }
         [ drop transfer-char (parse-parens) ] } case 
        ] if ;

: parse-parens ( todo -- parsed remainder ) "" swap (parse-parens) ;

: ul( ( world -- world )
     drop-first-instruction dup program>> parse-parens [ [ 1 head* >string suffix ] curry change-stack ] dip >>program ; 

: ula ( world -- world ) drop-first-instruction [ "(" ")" surround ] with-ul-datastack ;

: ul^ ( world -- world ) drop-first-instruction dup stack>> pop [ prepend ] curry change-program ;

: ulS ( world -- world ) drop-first-instruction [ write ] with-ul-datastack ;

CONSTANT: hash-char>quot H{
    { "~" [ ul~ ] }
    { ":" [ ul: ] }
    { "!" [ ul! ] }
    { "*" [ ul* ] }
    { "(" [ ul( ] }
    { "a" [ ula ] }
    { "^" [ ul^ ] }
    { "S" [ ulS ] } }

: char->quot ( char -- quot ) hash-char>quot at ;

: interp ( code -- ) <underload-world> [ dup program>> length zero? not ] [ dup program>> first 1string char->quot call( world -- world ) ] while drop ;