Paste: Underload interpreter
Author: | Sgeo |
Mode: | factor |
Date: | Sun, 16 Dec 2012 01:10:51 |
Plain Text |
USING: kernel continuations sequences accessors io strings combinators math assocs vectors ;
IN: underload
TUPLE: underload-world program stack ;
: <underload-world> V{ } clone underload-world boa ;
: drop-first-instruction [ rest ] change-program ;
: with-ul-datastack [ with-datastack >vector ] curry change-stack ;
: ul~
drop-first-instruction [ swap ] with-ul-datastack ;
: ul: drop-first-instruction [ dup ] with-ul-datastack ;
: ul! drop-first-instruction [ drop ] with-ul-datastack ;
: ul* drop-first-instruction [ append ] with-ul-datastack ;
: transfer-char [ first 1string append ] keep rest >string ;
ERROR: unbalanced-parens ;
: (parse-parens)
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 "" swap (parse-parens) ;
: ul(
drop-first-instruction dup program>> parse-parens [ [ 1 head* >string suffix ] curry change-stack ] dip >>program ;
: ula drop-first-instruction [ "(" ")" surround ] with-ul-datastack ;
: ul^ drop-first-instruction dup stack>> pop [ prepend ] curry change-program ;
: ulS drop-first-instruction [ write ] with-ul-datastack ;
CONSTANT: hash-char>quot H{
{ "~" [ ul~ ] }
{ ":" [ ul: ] }
{ "!" [ ul! ] }
{ "*" [ ul* ] }
{ "(" [ ul
{ "a" [ ula ] }
{ "^" [ ul^ ] }
{ "S" [ ulS ] } }
: char->quot hash-char>quot at ;
: interp <underload-world> [ dup program>> length zero? not ] [ dup program>> first 1string char->quot call ] while drop ;
New Annotation