このチャプターの目次
いよいよ、実装の詳細です。すでに Operator でディスパッチが済んでいるので、Operand から Instruction への変換になります。
iStop、iGet、iPrint の実装
iStop は、
- 終了状態のフラッグを
Trueにする - 出力を "\nstoped" にする
ような Instruction を生成します。
iStop :: Operand -> Instruction
iStop _ state@(_,mem,acc,ins,out) = (True,mem,acc,ins,out)
iGet は、
- 入力列の先頭を消費して、アキュムレータに数値として設定する
- メモリの先頭を次にずらす
- 出力は空文字列とする
ような Instruction を生成します。
iGet :: Operand -> Instruction
iGet _ state@(flg,mem,_,i:ins,_) = (flg,next mem,read i,ins,"")
next はメモリの先頭を次にずらします。
next :: Memory -> Memory
next = tail
iPrint は、
- メモリの先頭を次にずらす
- 出力をアキュムレータの値も文字列に変換してものにする
ような Instruction を生成します。
iPrint :: Operand -> Instruction
iPrint _ state@(flg,mem,acc,ins,_) = (flg,next mem,acc,ins,show acc)
単純なプログラム prog00 で動作確認してみましょう。
prog00 :: SourceCode
prog00 = unlines
[ " get"
, " print"
, " stop"
]
テスト用関数
{- |
>>> test prog00 ["3"]
3
stopped
-}
test :: SourceCode -> String -> IO ()
test prog = putStr . drive (toy prog) . unlines
テストしてみる
% doctest src/Toy.hs
src/Toy.hs:153: failure in expression `test prog00 ["3"]'
expected: 3
stopped
but got: *** Exception: Prelude.undefined
^
CallStack (from HasCallStack):
error, called at libraries/base/GHC/Err.hs:79:14 in base:GHC.Err
undefined, called at src/Toy.hs:20:10 in main:Toy
Examples: 1 Tried: 1 Errors: 0 Failures: 1
output を未定義でしたね。
output state = case state of
(_,_,_,_,out) -> out
再度テストします。
% doctest src/Toy.hs
src/Toy.hs:154: failure in expression `test prog00 ["3"]'
expected: 3
stopped
but got:
^
3
stopped
Examples: 1 Tried: 1 Errors: 0 Failures: 1
なにか期待したものと違う出力になっていますね。これの修正は次回にしましょう。
コード
ここまでの Toy モジュール
src/Toy.hs
module Toy where
import Data.Char
import Numeric
type SourceCode = String
type Interactive = [Input] -> [Output]
type Input = String
type Output = String
drive :: Interactive -> (String -> String)
drive f = unlines . f . lines
toy :: SourceCode -> Interactive
toy prog = map output . eval . initState (load prog)
output :: ToyState -> Output
output (_,_,_,_,out) = out
load :: SourceCode -> Memory
load = cycle . map trans . lines
trans :: String -> (Label, Content)
trans s = case break isSpace s' of
([], []) -> error "empty line"
(lab, content) -> (lab, read content)
where
s' = toUpper <$> s
initState :: Memory -> [Input] -> ToyState
initState mem inputs = (False, mem, 0, inputs, "")
type Memory = [(Label, Content)]
type Label = String
data Content
= Code Code
| Data Int
deriving Show
instance Read Content where
readsPrec _ content = case words content of
[cnt] -> case readSigned readDec cnt of
[(num,"")] -> [(Data num, "")]
_ -> [(Code (read cnt, None), "")]
[op, arg]
-> [(Code (read op, read arg), "")]
type Code = (Operator, Operand)
data Operator
= STOP
| GET
| PRINT
| LOAD
| STORE
| ADD
| SUB
| GOTO
| IFZERO
| IFPOS
deriving (Show, Read)
data Operand
= None
| Num Int
| Lab Label
deriving Show
instance Read Operand where
readsPrec _ s = case words s of
[oprd] -> case readSigned readDec oprd of
[(num,"")] -> [(Num num, "")]
_ -> [(Lab oprd, "")]
_ -> []
type ToyState = (Final, Memory, Acc, [Input], Output)
type Final = Bool
type Acc = Int
eval :: ToyState -> [ToyState]
eval state = state : rests
where
rests | isFinal state = []
| otherwise = eval (step state)
isFinal :: ToyState -> Bool
isFinal (flg,_,_,_,_) = flg
type Instruction = ToyState -> ToyState
step :: ToyState -> ToyState
step state = execute (decode (fetch state)) state
--
fetch :: ToyState -> Code
fetch state = case state of
(_,top:_,_,_,_) -> case top of
(_,Code code) -> code
_ -> error "not a code"
_ -> error "empty memory"
--
decode :: Code -> Instruction
decode (op,oprd) = case op of
{ STOP -> iStop
; GET -> iGet
; PRINT -> iPrint
; LOAD -> iLoad
; STORE -> iStore
; ADD -> iAdd
; SUB -> iSub
; GOTO -> iGoto
; IFZERO -> iIfzero
; IFPOS -> iIfpos
} $ oprd
iStop :: Operand -> Instruction
iStop _ state = case state of
(_,mem,acc,ins,_) -> (True,mem,acc,ins,"stopped")
iGet, iPrint :: Operand -> Instruction
iGet _ state = case state of
(flg,mem,_,ins,_) -> (flg,next mem,read (head ins),tail ins,"")
iPrint _ state = case state of
(flg,mem,acc,ins,_) -> (flg,next mem,acc,ins,show acc)
next :: Memory -> Memory
next = tail
iLoad, iStore :: Operand -> Instruction
iLoad _ = undefined
iStore _ = undefined
iAdd, iSub :: Operand -> Instruction
iAdd oprd = undefined
iSub oprd = undefined
iGoto, iIfzero, iIfpos :: Operand -> Instruction
iGoto oprd = undefined
iIfzero oprd = undefined
iIfpos oprd = undefined
--
execute :: Instruction -> Instruction
execute = id
--
{- |
>>> test prog00 ["3"]
3
stopped
-}
test :: SourceCode -> [Input] -> IO ()
test prog = putStr . drive (toy prog) . unlines
prog00 :: SourceCode
prog00 = unlines
[ " get"
, " print"
, " stop"
]