このチャプターの目次
iLoad と iStore の実装
iLoad のオペランドは、数値かラベルかのどちらかです。
オペランドが数値である場合は、
- オペランドの数値をアキュムレータに設定する
- メモリの先頭を次にずらす
- 出力は、なし
Nothingに設定する
ような Instruction を生成します。
また、オペランドがデータがあるメモリ位置を示すラベルである場合は、
- オペランドのラベル位置の値を検索し、
- その値をアキュムレータに設定する
- メモリの先頭位置を次にずらす
- 出力は、なし
Nothingに設定する
ような Instruction を生成します。
いずれの場合も、iLoad では、オペランドが何らかの値を表していると考えてよいでしょう。
このようなオペランドの見かたは、iAdd や iSub にも適用できます。
したがって、オペランドが表す値を求める補助関数 value :: Operand -> Memory -> Int を定義すると便利です。
iLoad oprd state = case state of
(flg,mem,_,ins,_) -> (flg, next mem, value oprd mem, ins, Nothing)
value oprd mem = case oprd of
Num num -> num
Lab lab -> case lookup lab mem of
Just (Data num) -> num
_ -> error $ "no data labeled " ++ show lab
iStore はオペランドで指定された位置にあるデータをアキュムレータの値で上書きすることになります。
このとき、メモリのリングを指定された位置直前で切り離して、先頭を交換してから、リングを繋ぎ直すので、メモリはサイズ情報を保持している必要があります。
そこで、Memory の実装を変更します。
type Memory = (Int, [(Label,Content)])
iStore oprd state = case state of
(flg,mem,acc,ins,_) -> (flg, next mem', acc, ins, Nothing)
where
mem' = update oprd acc mem
update :: Operand -> Int -> Memory -> Memory
update oprd num (sz, mem) = case oprd of
Lab lab -> case break ((lab ==) . fst) (take sz mem) of
(xs,(_,Data _):ys) -> (sz, cycle $ xs ++ (lab, Data num) : ys)
_ -> error $ "no data labeled " ++ show lab
_ -> error $ "not a label"
Memory の実装変更にともない、load、fetch、next、value はパターン照合の部分に変更が必要になります。
load prog = (size, mem)
where
size = length proglines
mem = cycle (map trans proglines)
proglines = lines prog
fetch state = case state of
(_,(_,top:_),_,_,_) -> case top of
(_,Code code) -> code
_ -> error "not a code"
_ -> error "empty memory"
next (sz,mem) = (sz, tail mem)
value oprd (sz,mem) = case oprd of
Num num -> num
Lab lab -> case lookup lab (take sz mem) of
Just (Data num) -> num
_ -> error $ "no data labeled " ++ show lab
ここまでの Toy モジュール
src/Toy.hs
module Toy where
import Data.Char
import Data.Maybe
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 = mapMaybe output . eval . initState (load prog)
output :: ToyState -> Maybe Output
output (_,_,_,_,out) = out
load :: SourceCode -> Memory
load prog = (size, mem)
where
size = length proglines
mem = cycle $ map trans proglines
proglines = lines prog
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, Nothing)
type Memory = (Int, [(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], Maybe 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, Just "stopped")
iGet, iPrint :: Operand -> Instruction
iGet _ state = case state of
(flg,mem,_,ins,_) -> (flg, next mem, read (head ins), tail ins, Nothing)
iPrint _ state = case state of
(flg,mem,acc,ins,_) -> (flg, next mem, acc, ins, Just $ show acc)
next :: Memory -> Memory
next (sz,mem) = (sz, tail mem)
iLoad :: Operand -> Instruction
iLoad oprd state = case state of
(flg,mem,_,ins,_) -> (flg, next mem, value oprd mem, ins, Nothing)
value :: Operand -> Memory -> Int
value oprd (sz, mem) = case oprd of
Num num -> num
Lab lab -> case lookup lab (take sz mem) of
Just (Data num) -> num
_ -> error $ "no data labeled " ++ show lab
iStore :: Operand -> Instruction
iStore oprd state = case state of
(flg,mem,acc,ins,_) -> (flg, next mem' , acc, ins, Nothing)
where
mem' = update oprd acc mem
update :: Operand -> Int -> Memory -> Memory
update oprd num (sz, mem) = case oprd of
Lab lab -> case break ((lab ==) . fst) (take sz mem) of
(xs,(_,Data _):ys) -> (sz, cycle $ xs ++ (lab, Data num) : ys)
_ -> error $ "no data labeled " ++ show lab
_ -> error "not a label"
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"
]