phorth---（その1.2）Evaluator

評価器（Evaluator）

ASTが作れるようになったので，評価器の番です．harrorth--では省いた「新しいオペレータの定義」があるので，その部分を作らないといけません．

新しいオペレータは「名前」，「内容」そしてその間の「対応関係」であり，また定義したらそれを覚えておかないといけません．HarrorthそのままでData.Mapを使います．こういうのは連想配列で扱うのが楽なので，Haskellでの連想配列Data.Mapの出番です．

Liblary Documentによると``Since many function names (but not the type name) clash with Prelude names, this module is usually imported qualified,''とのことなので，qualified-asで使うことにします．

import qualified Data.Map as Map

type Stack = [Literal]
type Dict  = Map.Map Name AST

harrorth--ではInterpのフィールドはstack::[Literal]だけでしたが，これをsack::Stackと書き換えます．またユーザ定義のオペレータを記録するための辞書のフィールドdict::Dictを追加します．

data Interp = Interp{ stack::Stack,
                      dict ::Dict } deriving Show -- interpreter

そしてharrorth--から，インタープリタの更新関数interpとASTの各要素を処理するprocExpをもってきておきます．ただし，今回はオリジナルのharrorthと同じくIOモナドにしてdo記法にします．

interp:: Interp -> AST -> IO Interp
interp i (x:xs) = do i' <- procExp i x
                     interp i' xs
interp i [] = return i

procExp:: Interp -> Exp -> IO Interp
procExp i@Interp {stack=xs}   (Push lit)     = return i{stack=lit:xs}
procExp i@Interp {stack=x:xs} (Invoke "pop") = return i{stack=xs}

なお，最低限のpopとpushもいれておきます．procExpでパターンマッチの仕方を変えてます．Interpのフィールドを増やしたので，procExp Interp{stack=xs}の形ではエラーになってしまいます．「dictはどうした！？」というわけです．そこで，iでうけとめてアズパターンで欲しい部分だけうけとります．

ASTの要素の一つNewWord Name ASTに対するprocExpを考えます．これはNameというキーで内容がASTであるような辞書のエントリを作ることなので，

procExp i@Interp {dict = dict}  (NewWord name ast)
     = return i{dict = Map.insert name ast dict }

となります．ここで，insertは

insert :: Ord k => k -> a -> Map k a -> Map k a

であり，insert name ast dictはキーがname，内容がastのエントリをdictに挿入するしてできあがったものを返します．

そして，これで登録された新しいオペレータを実行するのもやはりprocExpです．「組み込まれたオペレータ」に対するマッチでマッチしなければ，次は新しく定義されたものを辞書から探す必要があります．名前をキーに辞書から探すには(Map.!)を使います

procExp i@Interp{dict=dict} (Invoke name) = interp i (dict Map.! name)

main

コンパイルできるようにmain関数を作ります．ほとんどharrorth--と同じですが，インタープリータの中身を変えた（辞書を追加した）ので，辞書の初期状態を与える必要があります．Data.Mapの関数emptyを使って空の辞書を与えることにします．

また，printInerpはdo記法にしました．これはinterpの型をInterp -> AST -> IO Interpとしたため，直接printさせることができない（IO InterpはShowクラスのインスタンスではない）ので，IOを外してprintにおくるためです．

main = do src <- getLine
          case (parse phorthProg "" src) of
              Left err -> do putStr "parse Error ar"
                             print err
              Right x -> printInterp x

printInterp:: AST -> IO ()
printInterp ast = do fin <- interp Interp{ stack=[], dict=Map.empty} ast 
                     print fin

コンパイルしてみます．

ghc --make -o phorth phorth.hs
[1 of 1] Compiling Main             ( phorth.hs, phorth.o )
Linking phorth.exe ...

実行してみます．

phorth
1 2 /a {10 20} def a a a
Interp {stack = [20,10,20,10,20,10,2,1], dict = fromList [("a",[Push 10,Push 20])]}

phorth
1 2 /a {10 20 /b {100 200} def   } def a b
Interp {stack = [200,100,20,10,2,1], dict = fromList [("a",[Push 10,Push 20,NewWord "b" [Push 100,Push 200]]),("b",[Push 100,Push 200])]}

期待したうごきになっています．

次はもうちょっといろいろできるように追加・改造してみます．

この段階の全ソースは以下の通りです．

import Text.ParserCombinators.Parsec
import qualified Data.Map as Map

-- AST
type AST = [Exp]
data Exp =   Push Literal
           | Invoke Word 
           | NewWord Name AST
           deriving Show
type Literal = Integer
type Word = String
type Name = String

type Stack = [Literal]
type Dict  = Map.Map Name AST

-- Parser
phorthProg::Parser AST
phorthProg = do -- skipMany space
                ast <- phorth
                eof
                return ast

phorth::Parser AST
phorth = do skipMany space
            sepEndBy1 phorthExp (skipMany1 space)

phorthExp::Parser Exp
phorthExp = literal <|> word <|> newWord

literal::Parser Exp
literal = (many1 digit) >>= \x ->return (Push (read x))

word::Parser Exp
word = many1 letter >>= \x ->return (Invoke x)

newWord::Parser Exp
newWord =do char '/'
            name <- many1 letter
            skipMany space
            char '{'
            ast <- phorth
            char '}'
            skipMany space
            string "def"
            return $ NewWord name ast

-- Evaluator

data Interp = Interp{  stack::Stack
                      ,dict ::Dict
  } deriving (Show) -- interpreter

interp:: Interp -> AST -> IO Interp
interp i (x:xs) = do i' <- procExp i x
                     interp i' xs
interp i [] = return i

procExp:: Interp -> Exp -> IO Interp
procExp i@Interp {stack=xs}    (Push lit)     = return i{stack=lit:xs}
procExp i@Interp {stack=x:xs}  (Invoke "pop") = return i{stack=xs}
procExp i@Interp {dict = dict} (NewWord name ast) 
        = return  i{dict = Map.insert name ast dict }
procExp i@Interp{dict=dict} (Invoke name) = interp i (dict Map.! name)

-- main

main = do src <- getLine
          case (parse phorthProg "" src) of
              Left err -> do putStr "parse Error ar"
                             print err
              Right x -> printInterp x

printInterp:: AST -> IO ()
printInterp ast = do fin <- interp Interp{ stack=[], dict=Map.empty} ast 
                     print fin