Chapter 17

# Code から Instruction への変換 (5)

Nobuo Yamashita
2021.12.15に更新
このチャプターの目次

## `iGoto`、`iIfzero`、`iIfpos` の実装 (toy16)

まず、無条件ジャンプ `iGoto` を実装しましょう。

``````iGoto :: Operand -> Instruction
iGoto oprd state = case state of
(flg,(sz,mem),acc,ins,_) -> -> case oprd of
Lab lab -> case break ((lab ==) . fst) (take sz mem) of
(_,[])  -> error \$ "no instruction labeled " ++ show lab
(xs,ys) -> (flg, (sz, cycle \$ ys ++ xs), acc, ins, Nothing)
_       -> error "iGoto: not a label"
``````

``````iIfzero :: Operand -> Instruction
iIfzero = condJump (0 ==)

iIfpos :: Operand -> Instruction
iIfpos  = condJump (0 <=)

condJump :: (Acc -> Bool) -> Operand -> Instruction
condJump p oprd state = case state of
(flg,mem,acc,ins,_)
| p acc     -> iGoto oprd state
| otherwise -> (flg, next mem, acc, ins, Nothing)
``````

テストプログラムは以下のとおり

``````{- |
0 が入力されるまで、入力された数値を加算する
>>> test prog02 ["1","2","3","4","0"]
10
stopped
-}
prog02 :: String
prog02 = unlines
[ "top get"
, "    ifzero bot"
, "    store sum"
, "    goto top"
, "    print"
, "    stop"
, "sum 0"
]
``````

テストしましょう。

``````% doctest src/Toy.hs
Examples: 3  Tried: 3  Errors: 0  Failures: 0
``````

よさそうですね。

ここまでの 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

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

readsPrec _ content = case words content of
[(num,"")] -> [(Data num, "")]
_          -> [(Code (read cnt, None), "")]
[op, arg]

type Code = (Operator, Operand)

data Operator
= STOP
| GET
| PRINT
| STORE
| SUB
| GOTO
| IFZERO
| IFPOS

data Operand
= None
| Num Int
| Lab Label
deriving Show

readsPrec _ s = case words s 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
; STORE  -> iStore
; 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

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 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
None -> error "invalid operand"

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 oprd state = case state of
(flg,mem,acc,ins,_) -> (flg, next mem, acc + value oprd mem, ins, Nothing)

iSub :: Operand -> Instruction
iSub oprd state = case state of
(flg,mem,acc,ins,_) -> (flg, next mem, acc - value oprd mem, ins, Nothing)

iGoto :: Operand -> Instruction
iGoto oprd state = case state of
(flg,(sz,mem),acc,ins,_) -> case oprd of
Lab lab -> case break ((lab ==) . fst) (take sz mem) of
(_,[])  -> error \$ "no instruction labeled " ++ show lab
(xs,ys) -> (flg, (sz, cycle \$ ys ++ xs), acc, ins, Nothing)
_       -> error "iGoto: not a label"

iIfzero :: Operand -> Instruction
iIfzero = condJump (0 ==)

iIfpos :: Operand -> Instruction
iIfpos  = condJump (0 <=)

condJump :: (Acc -> Bool) -> Operand -> Instruction
condJump p oprd state = case state of
(flg,mem,acc,ins,_)
| p acc     -> iGoto oprd state
| otherwise -> (flg, next mem, acc, ins, Nothing)

--

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"
]

{- |
2つの入力値の和と差
>>> test prog01 ["4","7"]
11
-3
0
stopped
-}
prog01 :: SourceCode
prog01 = unlines
[ "  get"
, "  store x"
, "  get"
, "  store y"
, "  print"
, "  sub y"
, "  print"
, "  print"
, "  stop"
, "x 0"
, "y 0"
]

{- |
0 が入力されるまで、入力された数値を加算する
>>> test prog02 ["1","2","3","4","0"]
10
stopped
-}
prog02 :: String
prog02 = unlines
[ "top get"
, "    ifzero bot"