micro Scheme の続きです。今回は変数の値を書き換えるシンタックス形式 set! と数値の算術演算と比較演算の処理を作りましょう。最初に、Haskell の「ハッシュ表 (hash table)」について簡単に説明します。
ハッシュ表 (hash table) はデータを格納する配列と、データを整数値に変換する「ハッシュ関数 (hash function)」を用意します。この値を「ハッシュ値 (hash value)」と呼びます。ハッシュ値は配列の添字に対応し、この位置にデータを格納します。つまり、ハッシュ表はハッシュ関数によってデータを格納する位置を決める探索方法となります。
ハッシュ表のアルゴリズムに興味のある方は、拙作のページ Algorithms with Python ハッシュ法 をお読みください。
以前のバージョンではハッシュ表を扱うモジュール Data.HashTable が標準で添付されていましたが、GHC verseion 8.8.4 には用意されていません。そのかわりにパッケージ hashtables を使うようです。インストールは stack を使うと簡単です。
$ stack install hashtables
これで Data.HashTable の下にハッシュ表を操作するモジュールがインストールされます。IO モナドといっしょに使用したい場合はモジュール Data.HashTable.IO をインポートします。そして、データ型を次のように定義します。
import qualified Data.HashTable.IO as H type HashTable key val = H.BasicHashTable key val
これで以前のモジュール Data.HashTable と同様にハッシュ表を使うことができます。key がキーを表すデータ、val が値を表すデータです。ハッシュ関数はクラス Hashable に定義されている関数を使います。したがって、key はクラス Hashable のインスタンスでなければいけません。たいていのデータはモジュール Data.Hashable にあらかじめ用意されているので、それを使えばいいでしょう。
ハッシュ表の基本的な操作関数を示します。
new は新しいハッシュ表を生成します。insert はキーと値をハッシュ表に登録します。同じキーを登録した場合、値が書き換えられることに注意してください。delete はハッシュ表からキーとその値を削除します。lookup はハッシュ表からキーの値を探します。fromList は連想リストからハッシュ表を生成します。toList はハッシュ表を連想リストに変換します。
簡単な実行例を示しましょう。
Prelude> import qualified Data.HashTable.IO as H
Prelude H> type HashTable k v = H.BasicHashTable k v
Prelude H> ht <- H.new :: IO (HashTable String Int)
Prelude H> H.toList ht
[]
Prelude H> H.insert ht "foo" 10
Prelude H> H.insert ht "bar" 20
Prelude H> H.insert ht "baz" 30
Prelude H> H.toList ht
[("baz",30),("foo",10),("bar",20)]
Prelude H> H.lookup ht "foo"
Just 10
Prelude H> H.lookup ht "Foo"
Nothing
new でハッシュ表を生成し、"foo", "bar", "baz" を登録します。toList でハッシュ表を連想リストに変換すると、3 つのキーと値が登録されていることがわかります。lookup で "foo" を探すと Just 10 が返されます。"Foo" は見つからないので Nothing が返されます。
Prelude H> H.insert ht "baz" 40
Prelude H> H.toList ht
[("baz",40),("foo",10),("bar",20)]
Prelude H> H.lookup ht "baz"
Just 40
Prelude H> H.delete ht "baz"
Prelude H> H.lookup ht "baz"
Nothing
Prelude H> H.toList ht
[("foo",10),("bar",20)]
Prelude H> ht1 <- H.fromList [("foo", 100),("bar", 200),("baz", 300)] :: IO (HashTable String Int)
Prelude H> H.toList ht1
[("baz",300),("foo",100),("bar",200)]
次に、insert で "baz" と 40 を登録します。toList で変換すると、"baz" の値が書き換えられていることがわかります。lookup で検索すると値 Just 40 が返されます。delete で "baz" を削除すると、"baz" とその値は削除されます。lookup で検索すると Nothing が返されます。fromList を使うと連想リストからハッシュ表を生成することができます。
それではプログラムを作りましょう。まず最初に、変数の値を更新できるように環境の定義を修正します。次のリストを見てください。
リスト : 環境の修正 -- ローカル環境の定義 type LEnv = [(String, IORef SExpr)] -- グローバルな環境 type HashTable k v = H.BasicHashTable k v type GEnv = HashTable String SExpr -- 両方の環境を保持する type Env = (GEnv, LEnv) -- 評価器の定義 type Scm a = ExceptT String IO a
局所変数を保持する環境 LEnv の場合、変数の値は IORef に格納するように修正します。変数の値を求める、または書き換える場合、IORef の操作関数は値を IO に包んで返すので、Either モナドと IO モナドを同時に使う必要があります。このため、S 式を評価するときに使う型 Scm は、Either モナドではなくモナド変換子 ExceptT を使って、Either モナドと IO モナドを合成することにします。エラーの送出も scmError ではなく throwError を使います。
大域変数の値を格納する環境 GEnv も Data.Map から HashTable に変更します。そして、大域変数の環境と局所変数の環境をタプルにまとめたものを型 Env として定義します。
次に、環境 LEnv を操作する関数を作ります。
リスト : 環境 LEnv の操作関数
-- 新しい変数束縛の追加
pushLEnv :: String -> SExpr -> LEnv -> IO LEnv
pushLEnv s v env = do
a <- newIORef v
return ((s, a):env)
-- 変数の値を求める
lookupLEnv :: String -> LEnv -> IO (Maybe SExpr)
lookupLEnv s env =
case lookup s env of
Nothing -> return Nothing
Just v -> do a <- readIORef v
return (Just a)
-- 変数の値を更新する
updateLEnv :: String -> SExpr -> LEnv -> IO LEnv
updateLEnv s v env =
case lookup s env of
Nothing -> pushLEnv s v env
Just a -> do writeIORef a v
return env
関数 pushLEnv は変数名 s、値 v、環境 env を受け取り、新しい変数束縛を追加した環境を返します。newIORef v で v を格納した変数 a を生成し、タプル (s, a) を env に追加して返します。返り値の型は IO LEnv になります。
関数 lookupLEnv は環境 env の中から変数 s の値を探します。返り値の型は IO (Maybe SExpr) になります。lookup で env から s を探します。見つからない場合は Nothing を IO モナドに包んで返します。見つけた場合は readIORef で値 a を求め、Just a を IO モナドに包んで返します。
関数 updateLEnv は変数の値を書き換えます。lookup で変数 s を探します。見つからない場合は pushLEnv で新しい変数束縛を追加します。ただし、今回のプログラムではこの処理を使うことはありません。変数を見つけた場合は、writeIORef で変数の値を v に書き換えます。
次は S 式を評価する関数を修正します。前回のプログラムでは評価結果と大域変数の環境を返していましたが、ハッシュ表は値を破壊的に更新するので、大域変数の環境を返す必要はありません。関数の型は次のように評価結果だけを返すことになります。
eval :: Env -> SExpr -> Scm SExpr evalArguments :: Env -> SExpr -> Scm SExpr makeBindings :: LEnv -> SExpr -> SExpr -> Scm LEnv apply :: Env -> SExpr -> SExpr -> Scm SExpr
最初に関数 eval を修正します。
リスト : S 式の評価
eval :: Env -> SExpr -> Scm SExpr
eval env NIL = return NIL
eval env v@(INT _) = return v
eval env v@(REAL _) = return v
eval env v@(STR _) = return v
eval env (SYM name) = do
a <- liftIO $ lookupLEnv name $ snd env
case a of
Nothing -> do b <- liftIO $ H.lookup (fst env) name
case b of
Nothing -> throwError $ "unbound variable: " ++ name
Just v -> return v
Just v -> return v
eval env (CELL func args) = do
v <- eval env func
case v of
SYNT f -> f env args
_ -> do vs <- evalArguments env args
apply env v vs
変数の値を求める処理を修正します。局所変数の値を求めるとき、lookupLEnv を liftIO で持ち上げていることに注意してください。同様に、大域変数の値を求めるときは、H.lookup を liftIO で持ち上げます。
次は関数 makeBindings を修正します。
リスト : 変数束縛 makeBindings :: LEnv -> SExpr -> SExpr -> Scm LEnv makeBindings lenv NIL _ = return lenv makeBindings lenv (SYM name) rest = liftIO $ pushLEnv name rest lenv makeBindings lenv (CELL (SYM name) parms) (CELL v args) = do lenv' <- makeBindings lenv parms args liftIO (pushLEnv name v lenv') makeBindings lenv _ NIL = throwError errNEA makeBindings lenv _ _ = throwError "invalid arguments form"
新しい変数束縛を追加するときは pushLEnv を呼び出しますが、このとき liftIO で持ち上げることに注意してください。
Scheme の場合、シンボルに値を代入する操作は define だけではありません。Scheme には set! というシンタックス形式があり、シンボルの値を書き換えることができます。簡単な例を示しましょう。
gosh> (set! a 10) ***ERROR : symbol not defined: #<identifier user#a> Stack Trace: ・・・省略・・・ gosh> (define a 10) a gosh> a 10 gosh> (set! a 20) 20 gosh> a 20
set! は未定義のシンボルに値をセットすることはできません。define は新しい変数を束縛して値を代入することができますが、set! は値を書き換えることしかできないのです。最初に define で a に 10 をセットします。その後、set! で a の値を 20 に書き換えることができます。set! の返り値は Scheme の仕様書 (R5RS) では未定義ですが、Gauche ではセットした値を返します。micro Scheme も Gauche と同様にセットした値を返すことにします。
なお、Scheme の場合、値を書き換える関数には ! マークを付けて注意を促す習慣があります。
プログラムは次のようになります。
リスト : シンタックス形式 set!
evalSet :: Env -> SExpr -> Scm SExpr
evalSet env (CELL (SYM name) (CELL expr _)) = do
v <- eval env expr
a <- liftIO $ lookupLEnv name (snd env)
case a of
Nothing -> do b <- liftIO $ H.lookup (fst env) name
case b of
Nothing -> throwError $ "unbound variable: " ++ name
Just _ -> do liftIO $ H.insert (fst env) name v
return v
Just _ -> do liftIO $ updateLEnv name v (snd env)
return v
evalSet _ _ = throwError "invalid set! form"
関数 evalSet は第 2 引数の S 式 expr を eval で評価して値 v を求めます。それから、lookupLEnv で変数名 name の局所変数があるか調べます。見つけた場合は updateLEnv で name の値を v に変更します。lookupLEnv と updateLEnv は liftIO で持ち上げることに注意してください。
局所変数ではない場合、H.lookup で大域変数の中から変数 name を探します。name を見つけた場合、H.insert で name の値を v に更新します。見つからない場合はエラーを返します。ハッシュ表の操作関数も liftIO で持ち上げることに注意してください。
次は算術演算の処理を作りましょう。今回の micro Scheme は数の型が整数と実数しかないので、電卓プログラムと同様に整数同士の演算は整数とし、整数と実数の演算は整数を実数に変換してから行うことにします。
Lisp / Scheme の場合、算術演算を行う関数 +, -, *, / は複数の引数を受け取ることができます。簡単な例を示しましょう。
(+) => 0 (+ 1) => 1 (+ 1 2 3) => 6 (+ 1 2 3 4.5) => 10.5 (*) => 1 (* 1) => 1 (* 1 2 3) => 6 (* 1 2 3 4.5) => 27.0 (- 1) => -1 (- 10 5 4) => 1 (- 10 4.5) => 5.5 (-) => エラー ; 引数が足りない
/ は割り算を行います。Scheme の場合、整数同士の割り算で割り切れない場合は分数になりますが、micro Scheme は分数をサポートしていないので、Haskell の演算子 div と同じく結果を整数で返すことにします。簡単な例を示します。
(/ 2.0) => 0.5 ; 引数の逆数を求める (/ 8 4 2) => 1 (/) => エラー ; 引数が足りない (/ 1 0) => エラー ; 0 で除算
加算のプログラムは次のようになります。
リスト : 算術演算 (加算)
-- 畳み込み
foldCell :: (SExpr -> SExpr -> Scm SExpr) -> SExpr -> SExpr -> Scm SExpr
foldCell _ a NIL = return a
foldCell f a (CELL x rest) = do v <- f a x
foldCell f v rest
foldCell _ _ _ = throwError errCELL
-- 加算
add :: SExpr -> SExpr -> Scm SExpr
add (INT x) (INT y) = return (INT (x + y))
add (INT x) (REAL y) = return (REAL (fromIntegral x + y))
add (REAL x) (INT y) = return (REAL (x + fromIntegral y))
add (REAL x) (REAL y) = return (REAL (x + y))
add _ _ = throwError $ "+ : " ++ errNUM
adds :: SExpr -> Scm SExpr
adds xs = foldCell add (INT 0) xs
関数 foldCell はコンスセルに対して畳み込みを行う関数です。モナディック関数 foldM と同様の動作になります。foldCell を用意すると、四則演算の処理は簡単です。たとえば加算の場合、2 つの引数を加算する関数 add を作ります。あとは、foldCell に add を渡してコンスセルの要素を加算するだけです。初期値に INT 0 を渡しているので、引数が無い場合は 0 を返すことになります。
他の演算処理は簡単なので説明は割愛します。詳細は プログラムリスト をお読みください。
次は数値の比較演算処理を作りましょう。Lisp / Scheme の場合、数値の比較演算は複数の引数を受け取ることができます。
1. = N1 N2 N3 ... ==> （N1 ＝ N2 ＝ N3 ＝ .... ）
引数がすべて等しければ true を、それ以外であれば false を返す。
2. < N1 N2 N3 ... ==> （N1 ＜ N2 ＜ N3 ＜ .... ）
引数を左から見て、単調に増加していれば true を、それ以外であれば false を返す。
3. > N1 N2 N3 ... ==> （N1 ＞ N2 ＞ N3 ＞ .... ）
引数を左から見て、単調に減少していれば true を、それ以外であれば false を返す。
4. <= N1 N2 N3 ... ==> （N1 ≦ N2 ≦ N3 ≦ .... ）
引数を左から見て、単調に減少していなければ true を、それ以外であれば false を返す。
5. >= N1 N2 N3 ... ==> （N1 ≧ N2 ≧ N3 ≧ .... ）
引数を左から見て、単調に増加していなければ true を、それ以外であれば false を返す。
これらの述語は、右側に書いた数式の関係を満たせば true を返し、そうでなければ false を返します。整数と実数の比較は整数を実数に変換してから行うもとのします。
プログラムは次のようになります。
リスト : 数値の比較演算子 compareNum :: SExpr -> SExpr -> Scm Ordering compareNum (INT x) (INT y) = return $ compare x y compareNum (INT x) (REAL y) = return $ compare (fromIntegral x) y compareNum (REAL x) (INT y) = return $ compare x (fromIntegral y) compareNum (REAL x) (REAL y) = return $ compare x y compareNum _ _ = throwError errNUM compareNums :: (Ordering -> Bool) -> SExpr -> Scm SExpr compareNums _ NIL = throwError errNEA compareNums _ (CELL _ NIL) = throwError errNEA compareNums p (CELL x (CELL y NIL)) = do r <- compareNum x y if p r then return true else return false compareNums p (CELL x ys@(CELL y _)) = do r <- compareNum x y if p r then compareNums p ys else return false compareNums _ _ = throwError "invalid function form" eqNum, ltNum, gtNum, ltEq, gtEq :: SExpr -> Scm SExpr eqNum = compareNums (== EQ) ltNum = compareNums (== LT) gtNum = compareNums (== GT) ltEq = compareNums (<= EQ) gtEq = compareNums (>= EQ)
関数 compareNum は 2 つの引数を比較して Ordering (LT, EQ, GT) を返します。関数 compareNums はコンスセルに格納されている要素を順番に比較して、すべての要素が述語 p を満たしていれば true を、満たしていなければ false を返します。関数 eqNum, ltNum, gtNum, ltEq, gtEq は、それぞれ関数 =, <, >, <=, >= に対応します。
主な修正はこれだけです。あとの処理は簡単なので説明は割愛します。詳細は プログラムリスト をお読みください。
それでは実行してみましょう。最初は算術演算です。
Scm> (+) 0 Scm> (+ 1) 1 Scm> (+ 1 2) 3 Scm> (+ 1 2 3 4 5) 15 Scm> (+ 1 2 3.0 4 5) 15.0 Scm> (*) 1 Scm> (* 1) 1 Scm> (* 1 2) 2 Scm> (* 1 2 3 4 5) 120 Scm> (* 1 2 3.0 4 5) 120.0 Scm> (-) - : Not enough arguments Scm> (- 1) -1 Scm> (- 1 2) -1 Scm> (- 1 2 3) -4 Scm> (- 1 2.0 3) -4.0 Scm> (/) / : Not enough arguments Scm> (/ 2.0) 0.5 Scm> (/ 8 4) 2 Scm> (/ 8 4 2) 1 Scm> (/ 8 4 2.0) 1.0
正常に動作していますね。次は比較演算子です。
Scm> (= 1 1) true Scm> (= 1 2) false Scm> (= 1 1 1 1 1) true Scm> (= 1 1 1.0 1 1) true Scm> (= 1 1) true Scm> (= 1 2) false Scm> (= 1 1 1 1 1) true Scm> (= 1 1 1.0 1 1) true Scm> (< 1 2 3 4 5) true Scm> (> 1 2 3 4 5) false Scm> (<= 1 2 3 4 5) true Scm> (<= 1 2 3 3 4 4 5) true Scm> (>= 1 2 3 3 4 4 5) false
これも正常に動作していますね。次は再帰定義で階乗とフィボナッチ関数の値を求めてみましょう。
Scm> (define fact (lambda (x) (if (= x 0) 1 (* x (fact (- x 1)))))) fact Scm> (fact 9) 362880 Scm> (fact 10) 3628800 Scm> (fact 20) 2432902008176640000 Scm> (fact 50) 30414093201713378043612608166064768844377641568960512000000000000
Scm> (define fibo (lambda (n) (if (< n 2) 1 (+ (fibo (- n 1)) (fibo (- n 2)))))) fibo Scm> (fibo 1) 1 Scm> (fibo 2) 2 Scm> (fibo 3) 3 Scm> (fibo 4) 5 Scm> (fibo 5) 8 Scm> (fibo 10) 89 Scm> (fibo 20) 10946 Scm> (fibo 30) 1346269
正常に動作していますね。
次は set! で変数の値を書き換えます。
Scm> a unbound variable: a Scm> (set! a 10) unbound variable: a Scm> (define a 10) a Scm> (set! a 100) 100 Scm> a 100 Scm> x unbound variable: x Scm> ((lambda (x) (set! x (+ x 10)) x) 100) 110 Scm> x unbound variable: x
大域変数と局所変数ともに set! で書き換えることができます。また、クロージャが保存している値も set! で書き換えることができます。
Scm> (define foo (lambda (x) (lambda () (set! x (+ x 1))))) foo Scm> (define foo10 (foo 10)) foo10 Scm> (foo10) 11 Scm> (foo10) 12 Scm> (foo10) 13 Scm> (foo10) 14 Scm> (foo10) 15
クロージャを使うと、フィボナッチ関数の値を返すジェネレータも簡単に作成することができます。
Scm> (define fibogen (lambda (a b c) (lambda () (set! a (+ b c)) (set! c b) (set! b a)))) fibogen Scm> (define g (fibogen 0 0 1)) g Scm> (g) 1 Scm> (g) 1 Scm> (g) 2 Scm> (g) 3 Scm> (g) 5 Scm> (g) 8 Scm> (g) 13 Scm> (g) 21 Scm> (g) 34 Scm> (g) 55 Scm> (g) 89
最後に「末尾再帰最適化」について考えてみましょう。Haskell が末尾再帰最適化を行う場合、ある条件で eval が末尾再帰していれば、micro Scheme も末尾再帰最適化が行われます。なお、ここでいう末尾再帰最適化は処理速度のことではなく、次に示すような関数呼び出しにおいて、スタックを消費せずに実行できることです。
Scm> (define foo (lambda () (foo))) foo Scm> (foo) => 無限ループになる
末尾再帰最適化が行われる場合、foo を評価すると無限ループになります。実際、micro Scheme で foo を評価すると無限ループになります。
末尾再帰の末尾とは最後に行われる処理のことで、一般に末尾で関数を呼び出すことを「末尾呼び出し」といいます。関数を呼び出す場合、返ってきた後に行う処理のために、必要な情報を保存しておかなければいけません。ところが、末尾呼び出しはそのあと実行する処理がないので、情報を保存しておく必要がありません。このため、末尾再帰は繰り返しに変換することができるのです。
micro Scheme で S 式を評価するとき、末尾呼び出しが行われる場所は evalIf と evalBody の 2 か所しかありません。次のリストを見てください。
リスト : 末尾呼び出しの処理
evalIf :: Env -> SExpr -> Scm SExpr
evalIf env (CELL pred (CELL thenForm rest)) = do
v <- eval env pred
if v /= false
then eval env thenForm
else case rest of
CELL elseForm _ -> eval env elseForm
_ -> return false
evalIf _ _ = throwError $ "if : " ++ errNEA
evalBody :: Env -> SExpr -> Scm SExpr
evalBody env (CELL expr NIL) = eval env expr
evalBody env (CELL expr rest) = do
eval env expr
evalBody env rest
evalBody _ _ = throwError "invalid body form"
evalIf は条件部を評価したあと、then 節か else 節を評価しますが、そのあと評価する S 式はありません。どちらの節を評価するにしても末尾で eval を呼び出しているので、eval は evalIf を経由していますが末尾再帰になっています。
evalBody の場合も同様です。最後の S 式を評価するときの eval は末尾呼び出しになっているので、apply と evalBody を経由して eval は末尾再帰になります。このように eval を末尾再帰でプログラムすると、Haskell が末尾再帰最適化を行ってくれれば、micro Scheme で S 式を評価するときに末尾再帰最適化が行われます。
ここで、Haskell は遅延評価を行う処理系であることを思い出してください。たとえば、加算を行う add の処理で、INT (x + y) の x + y は遅延評価されます。このため、次のようなプログラムはスタックオーバーフローが発生して末尾再帰にはなりません。
リスト : n から m までの合計値を求める
(define sum
(lambda (n m a)
(if (> n m)
a
(sum (+ n 1) m (+ a n)))))
関数 sum は末尾再帰になっています。ところが、加算の処理で遅延評価が行われると、累積変数 a の値を返すまで (+ a n) の処理が蓄積されるため、スタックオーバーフローになるのです。
この場合、正格性フラグ ! を使うと簡単に正格評価を行うことできます。
リスト : S 式のデータ型
data SExpr = INT !Integer
| REAL !Double
| SYM String
| STR String
| CELL SExpr SExpr
| NIL
| PRIM (SExpr -> Scm SExpr)
| SYNT (Env -> SExpr -> Scm SExpr)
| CLOS SExpr LEnv
正格性フラグ ! は data 宣言の中で使用することができます。SExpr の中で INT !Integer と REAL !Double の二箇所に正格性フラグを使っています。これで、算術演算で INT と REAL に値を格納するとき、たとえば INT (x + y) の式 x + y は正格評価されます。
それでは実行してみましょう。
$ stack exec ghci -- +RTS -K2m -RTS GHCi, version 8.8.4: https://www.haskell.org/ghc/ :? for help Prelude> :l mscheme2 [1 of 1] Compiling Main ( mscheme2.hs, interpreted ) Ok, one module loaded. *Main> :main Scm> (define sum (lambda (n m a) (if (> n m) a (sum (+ n 1) m (+ a n))))) sum Scm> (sum 1 10000 0) 50005000 Scm> (sum 1 100000 0) 5000050000
デフォルトのスタックサイズが大きいので、オプション +RTS -K2m -RTS を使ってスタックサイズを 2 M byte に設定します。それでもプログラムは正常に動作します。正格評価フラグを設定しない、または、次のように Scheme のプログラムが末尾再帰でなければ、スタックオーバーフローが発生します。
Scm> (define sum (lambda (n m) (if (> n m) 0 (+ n (sum (+ n 1) m))))) sum Scm> (sum 1 10000) 50005000 Scm> (sum 1 100000) *** Exception: stack overflow
関数 sum は末尾再帰ではないので、大きな値を計算すると当然ですがスタックオーバーフローが発生します。
今回はここまでです。次回は micro Scheme に「伝統的なマクロ」を追加しましょう。
--
-- mscheme2.hs : microScheme
--
-- Copyright (C) 2013-2021 Makoto Hiroi
--
import Data.Char
import Data.IORef
import qualified Data.HashTable.IO as H
import Control.Monad.Except
import System.IO
-- S 式の定義
data SExpr = INT !Integer
| REAL !Double
| SYM String
| STR String
| CELL SExpr SExpr
| NIL
| PRIM (SExpr -> Scm SExpr)
| SYNT (Env -> SExpr -> Scm SExpr)
| CLOS SExpr LEnv
-- 等値の定義
instance Eq SExpr where
INT x == INT y = x == y
REAL x == REAL y = x == y
SYM x == SYM y = x == y
STR x == STR y = x == y
NIL == NIL = True
_ == _ = False
-- パーサエラーの定義
data ParseErr = ParseErr String String deriving Show
-- パーサの定義
type Parser a = Either ParseErr a
-- エラーの送出
parseError :: String -> String -> Parser a
parseError x s = Left (ParseErr x s)
-- 評価器の定義
type Scm a = ExceptT String IO a
-- ローカル環境の定義
type LEnv = [(String, IORef SExpr)]
pushLEnv :: String -> SExpr -> LEnv -> IO LEnv
pushLEnv s v env = do
a <- v `seq` newIORef v
return ((s, a):env)
lookupLEnv :: String -> LEnv -> IO (Maybe SExpr)
lookupLEnv s env =
case lookup s env of
Nothing -> return Nothing
Just v -> do a <- readIORef v
return (Just a)
updateLEnv :: String -> SExpr -> LEnv -> IO (LEnv)
updateLEnv s v env =
case lookup s env of
Nothing -> pushLEnv s v env
Just a -> do writeIORef a v
return env
-- グローバルな環境
type HashTable k v = H.BasicHashTable k v
type GEnv = HashTable String SExpr
-- 両方の環境を保持する
type Env = (GEnv, LEnv)
-- 真偽値
true = SYM "true"
false = SYM "false"
-- Primitive の定義
errNUM = "Illegal argument, Number required"
errINT = "Illegal argument, Integer required"
errNEA = "Not enough arguments"
errCELL = "Illegal argument, List required"
errZERO = "Divide by zero"
-- リスト操作
car :: SExpr -> Scm SExpr
car NIL = throwError $ "car : " ++ errNEA
car (CELL (CELL a _) _) = return a
car _ = throwError $ "car : " ++ errCELL
cdr :: SExpr -> Scm SExpr
cdr NIL = throwError $ "cdr : " ++ errNEA
cdr (CELL (CELL _ d) _) = return d
cdr _ = throwError $ "cdr : " ++ errCELL
cons :: SExpr -> Scm SExpr
cons (CELL a (CELL b _)) = return (CELL a b)
cons _ = throwError $ "cons : " ++ errNEA
pair :: SExpr -> Scm SExpr
pair NIL = throwError $ "pair? : " ++ errNEA
pair (CELL (CELL _ _) _) = return true
pair _ = return false
-- 畳み込み
foldCell :: (SExpr -> SExpr -> Scm SExpr) -> SExpr -> SExpr -> Scm SExpr
foldCell _ a NIL = return a
foldCell f a (CELL x rest) = do v <- f a x
foldCell f v rest
foldCell _ _ _ = throwError errCELL
-- 四則演算
add :: SExpr -> SExpr -> Scm SExpr
add (INT x) (INT y) = return (INT (x + y))
add (INT x) (REAL y) = return (REAL (fromIntegral x + y))
add (REAL x) (INT y) = return (REAL (x + fromIntegral y))
add (REAL x) (REAL y) = return (REAL (x + y))
add _ _ = throwError $ "+ : " ++ errNUM
adds :: SExpr -> Scm SExpr
adds xs = foldCell add (INT 0) xs
sub :: SExpr -> SExpr -> Scm SExpr
sub (INT x) (INT y) = return (INT (x - y))
sub (INT x) (REAL y) = return (REAL (fromIntegral x - y))
sub (REAL x) (INT y) = return (REAL (x - fromIntegral y))
sub (REAL x) (REAL y) = return (REAL (x - y))
sub _ _ = throwError $ "- : " ++ errNUM
subs :: SExpr -> Scm SExpr
subs NIL = throwError $ "- : " ++ errNEA
subs (CELL (INT a) NIL) = return (INT (-a))
subs (CELL (REAL a) NIL) = return (REAL (-a))
subs (CELL a rest) = foldCell sub a rest
mul :: SExpr -> SExpr -> Scm SExpr
mul (INT x) (INT y) = return (INT (x * y))
mul (INT x) (REAL y) = return (REAL (fromIntegral x * y))
mul (REAL x) (INT y) = return (REAL (x * fromIntegral y))
mul (REAL x) (REAL y) = return (REAL (x * y))
mul _ _ = throwError $ "- : " ++ errNUM
muls :: SExpr -> Scm SExpr
muls xs = foldCell mul (INT 1) xs
div' :: SExpr -> SExpr -> Scm SExpr
div' _ (INT 0) = throwError errZERO
div' _ (REAL 0) = throwError errZERO
div' (INT x) (INT y) = return (INT (x `div` y))
div' (INT x) (REAL y) = return (REAL (fromIntegral x / y))
div' (REAL x) (INT y) = return (REAL (x / fromIntegral y))
div' (REAL x) (REAL y) = return (REAL (x / y))
div' _ _ = throwError $ "- : " ++ errNUM
divs :: SExpr -> Scm SExpr
divs NIL = throwError $ "/ : " ++ errNEA
divs (CELL a NIL) = div' (INT 1) a
divs (CELL a rest) = foldCell div' a rest
mod' :: SExpr -> Scm SExpr
mod' NIL = throwError $ "mod : " ++ errNEA
mod' (CELL _ NIL) = throwError $ "mod : " ++ errNEA
mod' (CELL _ (CELL (INT 0) _)) = throwError errZERO
mod' (CELL _ (CELL (REAL 0) _)) = throwError errZERO
mod' (CELL (INT x) (CELL (INT y) _)) = return (INT (mod x y))
mod' _ = throwError $ "mod : " ++ errINT
-- 等値の判定
eq' :: SExpr -> Scm SExpr
eq' (CELL x (CELL y _)) =
if x == y then return true else return false
eq' _ = throwError $ "eq : " ++ errNEA
equal' :: SExpr -> Scm SExpr
equal' (CELL x (CELL y _)) =
if iter x y then return true else return false
where iter (CELL a b) (CELL c d) = iter a c && iter b d
iter x y = x == y
equal' _ = throwError $ "equal : " ++ errNEA
-- 数値の比較演算子
compareNum :: SExpr -> SExpr -> Scm Ordering
compareNum (INT x) (INT y) = return $ compare x y
compareNum (INT x) (REAL y) = return $ compare (fromIntegral x) y
compareNum (REAL x) (INT y) = return $ compare x (fromIntegral y)
compareNum (REAL x) (REAL y) = return $ compare x y
compareNum _ _ = throwError errNUM
compareNums :: (Ordering -> Bool) -> SExpr -> Scm SExpr
compareNums _ NIL = throwError errNEA
compareNums _ (CELL _ NIL) = throwError errNEA
compareNums p (CELL x (CELL y NIL)) = do
r <- compareNum x y
if p r then return true else return false
compareNums p (CELL x ys@(CELL y _)) = do
r <- compareNum x y
if p r then compareNums p ys else return false
compareNums _ _ = throwError "invalid function form"
eqNum, ltNum, gtNum, ltEq, gtEq :: SExpr -> Scm SExpr
eqNum = compareNums (== EQ)
ltNum = compareNums (== LT)
gtNum = compareNums (== GT)
ltEq = compareNums (<= EQ)
gtEq = compareNums (>= EQ)
--
-- S 式の表示
--
showCell :: SExpr -> String
showCell (CELL a d) =
show a ++ case d of
NIL -> ""
PRIM _ -> "<primitive>"
CLOS _ _ -> "<closure>"
SYNT _ -> "<syntax>"
INT x -> " . " ++ show x
REAL x -> " . " ++ show x
SYM x -> " . " ++ x
STR x -> " . " ++ show x
_ -> " " ++ showCell d
showCell xs = show xs
instance Show SExpr where
show (INT x) = show x
show (REAL x) = show x
show (SYM x) = x
show (STR x) = show x
show NIL = "()"
show (SYNT _) = "<syntax>"
show (PRIM _) = "<primitive>"
show (CLOS _ _) = "<closure>"
show xs = "(" ++ showCell xs ++ ")"
--
-- S 式の読み込み
--
isAlpha' :: Char -> Bool
isAlpha' x = elem x "!$%&*+-/:<=>?@^_~"
isIdent0 :: Char -> Bool
isIdent0 x = isAlpha x || isAlpha' x
isIdent1 :: Char -> Bool
isIdent1 x = isAlphaNum x || isAlpha' x
isREAL :: Char -> Bool
isREAL x = elem x ".eE"
quote = SYM "quote"
isNUM :: String -> Bool
isNUM (x:_) = isDigit x
isNUM _ = False
getNumber :: String -> Parser (SExpr, String)
getNumber xs =
let (s, ys) = span isDigit xs
in if not (null ys) && isREAL (head ys)
then case reads xs of
[] -> parseError "" "" -- ありえないエラー
[(y', ys')] -> return (REAL y', ys')
else return (INT (read s), ys)
readSExpr :: String -> Parser (SExpr, String)
readSExpr [] = parseError "" "EOF"
readSExpr (x:xs)
| isSpace x = readSExpr xs
| isDigit x = getNumber (x:xs)
| isIdent0 x = if x == '+' && isNUM xs
then getNumber xs
else if x == '-' && isNUM xs
then do (y, ys) <- getNumber xs
case y of
INT x -> return (INT (- x), ys)
REAL x -> return (REAL (- x), ys)
else let (name, ys) = span isIdent1 (x:xs)
in return (SYM name, ys)
| otherwise =
case x of
'(' -> readCell 0 xs
';' -> readSExpr $ dropWhile (/= '\n') xs
'"' -> case reads (x:xs) of
[] -> parseError "" ""
[(y, ys)] -> y `seq` ys `seq` return (STR y, ys)
'\'' -> readSExpr xs >>= \(e, ys) -> e `seq` ys `seq` return (CELL quote (CELL e NIL), ys)
_ -> parseError xs ("unexpected token: " ++ show x)
readCell :: Int -> String -> Parser (SExpr, String)
readCell _ [] = parseError "" "EOF"
readCell n (x:xs)
| isSpace x = readCell n xs
| otherwise =
case x of
')' -> xs `seq` return (NIL, xs)
'.' -> if n == 0
then parseError xs "invalid dotted list"
else do (e, ys) <- readSExpr xs
case dropWhile isSpace ys of
')':zs -> return (e, zs)
_ -> parseError xs "invalid dotted list"
'(' -> do (a, ys) <- readCell 0 xs
(d, zs) <- readCell 1 ys
return (CELL a d, zs)
_ -> do (a, ys) <- readSExpr (x:xs)
(d, zs) <- readCell 1 ys
return (CELL a d, zs)
--
-- S 式の評価
--
eval :: Env -> SExpr -> Scm SExpr
eval env NIL = return NIL
eval env v@(INT _) = return v
eval env v@(REAL _) = return v
eval env v@(STR _) = return v
eval env (SYM name) = do
a <- liftIO $ lookupLEnv name $ snd env
case a of
Nothing -> do b <- liftIO $ H.lookup (fst env) name
case b of
Nothing -> throwError $ "unbound variable: " ++ name
Just v -> return v
Just v -> return v
eval env (CELL func args) = do
v <- eval env func
case v of
SYNT f -> f env args
_ -> do vs <- evalArguments env args
apply env v vs
-- 引数の評価
evalArguments :: Env -> SExpr -> Scm SExpr
evalArguments env NIL = return NIL
evalArguments env (CELL expr rest) = do
v <- eval env expr
vs <- evalArguments env rest
return (CELL v vs)
evalArguments _ _ = throwError "invalid function form"
-- 変数束縛
makeBindings :: LEnv -> SExpr -> SExpr -> Scm LEnv
makeBindings lenv NIL _ = return lenv
makeBindings lenv (SYM name) rest = liftIO $ pushLEnv name rest lenv
makeBindings lenv (CELL (SYM name) parms) (CELL v args) = do
lenv' <- makeBindings lenv parms args
liftIO (pushLEnv name v lenv')
makeBindings lenv _ NIL = throwError errNEA
makeBindings lenv _ _ = throwError "invalid arguments form"
-- 関数適用
apply :: Env -> SExpr -> SExpr -> Scm SExpr
apply env func actuals =
case func of
PRIM f -> f actuals
CLOS (CELL parms body) lenv0 -> do
lenv1 <- makeBindings lenv0 parms actuals
evalBody (fst env, lenv1) body
_ -> throwError $ "Not Function: " ++ show func
-- 本体の評価
evalBody :: Env -> SExpr -> Scm SExpr
evalBody env (CELL expr NIL) = eval env expr
evalBody env (CELL expr rest) = do
eval env expr
evalBody env rest
evalBody _ _ = throwError "invalid body form"
--
-- シンタックス形式
--
-- quote
evalQuote :: Env -> SExpr -> Scm SExpr
evalQuote env (CELL expr _) = return expr
evalQuote _ _ = throwError "invalid quote form"
-- define
evalDef :: Env -> SExpr -> Scm SExpr
evalDef env (CELL sym@(SYM name) (CELL expr NIL)) = do
v <- eval env expr
liftIO $ H.insert (fst env) name v
return sym
evalDef _ _ = throwError "invalid define form"
-- if
evalIf :: Env -> SExpr -> Scm SExpr
evalIf env (CELL pred (CELL thenForm rest)) = do
v <- eval env pred
if v /= false
then eval env thenForm
else case rest of
CELL elseForm _ -> eval env elseForm
_ -> return false
evalIf _ _ = throwError $ "if : " ++ errNEA
-- lambda
evalLambda :: Env -> SExpr -> Scm SExpr
evalLambda env expr = return (CLOS expr (snd env))
-- set!
evalSet :: Env -> SExpr -> Scm SExpr
evalSet env (CELL (SYM name) (CELL expr _)) = do
v <- eval env expr
a <- liftIO $ lookupLEnv name (snd env)
case a of
Nothing -> do b <- liftIO $ H.lookup (fst env) name
case b of
Nothing -> throwError $ "unbound variable: " ++ name
Just _ -> do liftIO $ H.insert (fst env) name v
return v
Just _ -> do liftIO $ updateLEnv name v (snd env)
return v
evalSet _ _ = throwError "invalid set! form"
--
-- 大域変数の初期化
--
initGEnv :: [(String, SExpr)]
initGEnv = [("true", true),
("false", false),
("quote", SYNT evalQuote),
("define", SYNT evalDef),
("lambda", SYNT evalLambda),
("if", SYNT evalIf),
("set!", SYNT evalSet),
("eq?", PRIM eq'),
("equal?", PRIM equal'),
("pair?", PRIM pair),
("+", PRIM adds),
("-", PRIM subs),
("*", PRIM muls),
("/", PRIM divs),
("mod", PRIM mod'),
("=", PRIM eqNum),
("<", PRIM ltNum),
(">", PRIM gtNum),
("<=", PRIM ltEq),
(">=", PRIM gtEq),
("car", PRIM car),
("cdr", PRIM cdr),
("cons", PRIM cons)]
-- read-eval-print-loop
repl :: Env -> String -> IO ()
repl env xs = do
putStr "Scm> "
hFlush stdout
case readSExpr xs of
Left (ParseErr xs' mes) -> do putStrLn mes
repl env $ dropWhile (/= '\n') xs'
Right (expr, xs') -> do result <- runExceptT $ eval env expr
case result of
Left mes -> putStrLn mes
Right v -> print v
repl env xs'
main :: IO ()
main = do
xs <- hGetContents stdin
ht <- H.fromList initGEnv :: IO (GEnv)
repl (ht, []) xs