今回は micro Scheme に「マクロ (macro)」という機能を追加しましょう。define で定義できる関数は引数を評価するタイプで、シンタックス形式のように引数を評価しない関数を定義することはできません。Scheme (Lisp) でプログラミングする場合、ほとんどの処理は define で定義する関数で作ることができますが、シンタックス形式のように引数を評価しない関数を定義した方が便利な場合もあります。このようなとき、役に立つのがマクロです。
Scheme の場合、マクロは二種類あります。一つは仕様書 (R5RS など) で定義されているマクロで、これを「健全なマクロ」といいます。これに対し、昔から Lisp で使われているマクロを「伝統的なマクロ」といいます。多くの Scheme 処理系では、どちらのマクロも使えるようになっています。健全なマクロは作るのが大変なので、今回は伝統的なマクロを追加することにします。
まずは最初に伝統的なマクロについて簡単に説明します。
Lisp ではマクロを関数のように定義します。伝統的なマクロを定義するには define-macro を使います。
(define-macro マクロ名 (lambda (<仮引数> ...) Ｓ式 ...))
define-macro の構文は define と同じです。define-macro で定義されたマクロは、次のような特徴を持ちます。
この 2 番目の機能が Lisp におけるマクロの特徴です。これを図に示すと、次のようになります。
[Ｓ式] ─ 評価 -> [新しいＳ式] ─ 評価 -> [マクロの返り値]
（マクロ展開）
図 : マクロの動作
S 式を評価することで新しい S 式を組み立てます。この部分がマクロ展開に相当します。そして、その S 式を評価した値がマクロの返り値となります。S 式を組み立てるということは、自動的にプログラムを作ることと同じですね。これは、リストにプログラムとデータの 2 つの役割を持たせている Lisp だからこそ可能なことなのです。
まず、マクロと関数の違いを理解するために、数を 2 乗する処理をマクロと関数で作ってみましょう。関数は簡単ですね。
リスト : 数を 2 乗する関数 (define square (lambda (x) (* x x)))
マクロは次のように定義します。
リスト : 数を 2 乗するマクロ (define-macro m-square (lambda (x) (list '* x x)))
マクロ名は m-square としました。それでは、引数に (+ 1 2) を与えて m-square を評価してみます。
(m-square (+ 1 2))
仮引数 x に (+ 1 2) がセット（評価されないことに注意）
マクロの本体 (list '* x x) を評価する
=> (* (+ 1 2) (+ 1 2)) （Ｓ式が組み立てられる）
=> 9 （Ｓ式を評価した結果）
図 : マクロの実行
関数であれば引数 (+ 1 2) が評価されて、その返り値である 3 が square に渡されますね。マクロの場合、引数は評価されないので、仮引数 x には S 式である (+ 1 2) がそのままセットされます。
次に、マクロ本体を評価します。マクロを使いこなすポイントですが、まず評価したい S 式を組み立てることを考えます。最初の評価で S 式を組み立て、それを評価することで目的の処理を実現するのがマクロなのです。
この場合、引数の 2 乗する (* x x) という S 式を作ればいいわけです。list は引数を要素とする新しいリストを返す関数でしたね。この場合、シンボル * と x の値である (+ 1 2) が要素となったリストが返されます。
これでマクロ展開が終了しました。マクロの仮引数は、マクロ展開されるときだけ有効です。マクロ展開されたＳ式を評価するときは、それらの値は破棄されます。あとは、この S 式を評価して 9 という値が結果となります。
ところで、マクロを定義するとき、S 式を組み立てるため list をたくさん使うことになり少々面倒です。実は、「バッククォート ( ` )」という機能を使うと、S 式を簡単に組み立てることができます。
バッククォートはクォート ( ' ) と同様に引数の評価を行いません。ですが、バッククォートの中でコンマ ( , ) で始まる S 式があると、その S 式を評価した値で置き換えられます。簡単な例を示しましょう。
gosh> (define var 'pen) var gosh> var pen gosh> `(this is a ,var) (this is a pen)
変数 var にはシンボル pen がセットされています。次の S 式の中で ,var は var を評価した値、つまり pen に置き換わるのです。また、S 式の評価結果がリストの場合は、コンマアットマーク (,@) を使うことができます。,@ を使うと、リストをはずした値と置き換わります。,@ を使う場合、値がリストでなければエラーになります。次の例を見てください。
gosh> (define var '(pen)) var gosh> var (pen) gosh> `(this is a ,var) (this is a (pen)) gosh> `(this is a ,@var) (this is a pen)
今度は変数 var にリスト (pen) がセットされました。次の S 式の中で ,varは (pen) に置き換わります。そして、その次の S 式の中では、,@var は pen に置き換わるのです。それから、コンマやコンマアットマークはバッククォートの中でしか使うことができません。ほかの S 式の中で評価した場合はエラーとなります。ご注意ください。
昔の Lisp 処理系では、引数を評価するタイプを EXPR 型や SUBR 型、引数を評価しないタイプを NEXPR 型や FSUBR 型と呼び、ユーザーが NEXPR 型の関数を定義することができました。Scheme や Common Lisp の場合、ユーザーが定義できるのは関数とマクロだけです。シンタックス形式の関数を定義する場合はマクロを使うことになります。
マクロを実行する場合、必ずマクロ展開が行われるため、通常の関数よりも実行時間は遅くなります。だったら、NEXPR 型の関数を定義できるようにした方が実行速度の点で有利なはずです。ところが、Scheme や Common Lisp では必要最低限のシンタックス形式を定義し、よく使われる制御構造はマクロで定義されています。これではインタプリタでの動作が遅くなります。
では、なぜ実行速度が遅くなるのにマクロを使っているのでしょう。それは、Common Lisp や多くの Scheme 処理系がコンパイラの使用を前提としているからです。たとえば、Gauche はプログラムをバイトコードにコンパイルしてから実行します。Common Lisp では、CLISP がバイトコードに、SBCL がネイティブコードにプログラムをコンパイルします。
プログラムでマクロを呼び出している場所は、コンパイル時にマクロ展開されるため、コンパイル済みのコードにはマクロ呼び出しがなくなってしまうのです。つまり、コンパイル済みのコードは、マクロを呼び出す処理とマクロ展開の処理がなくなることにより、確実にインタプリタよりも高速に実行することができるのです。逆にいえば、コンパイラを使わないとマクロを効果的に使うことはできません。ご注意くださいませ。
それではプログラムを作りましょう。まず最初に、マクロを表すデータ型を定義します。
リスト : S 式の定義
type ScmFunc = Env -> SExpr -> Scm SExpr
data SExpr = INT !Integer
| REAL !Double
| SYM String
| STR String
| CELL SExpr SExpr
| NIL
| PRIM ScmFunc
| SYNT ScmFunc
| CLOS SExpr LEnv
| MACR SExpr
ScmFunc は PRIM と SYNT の関数の型を表します。今回から PRIM の関数にも環境 Env を渡すように修正します。マクロはシンタックス形式 define-macro で定義します。マクロはラムダ式で表します。マクロのデータ型は MACR SExpr で、引数の SExpr にはラムダ式の評価結果であるクロージャをセットします。この処理を関数 evalDefM で行います。
リスト : マクロの定義 evalDefM :: Env -> SExpr -> Scm SExpr evalDefM env (CELL sym@(SYM name) (CELL expr NIL)) = do v <- eval env expr lift $ H.insert (fst env) name (MACR v) return sym evalDefM _ _ = throwError "invalid define-macro form"
処理内容は evalDef とほぼ同じですが、eval の返り値 v (クロージャ) を MACR に格納し、それと変数名 name をタプルにまとめて大域変数の環境に追加します。
次はバッククオートで使用する記号を処理するため、S 式を読み込む関数 readSExpr を修正します。バッククオートで使う記号 (` , ,@) は省略形で、次に示す S 式に変換されます。
`(...) : (quasiquote (...)) ,expr : (unquote expr) ,@expr : (unquote-splicing expr)
この変換処理を関数 readSExpr で行います。プログラムは次のようになります。
リスト : S 式の読み込み
quote = SYM "quote"
quasiquote = SYM "quasiquote"
unquote = SYM "unquote"
unquoteSplicing = SYM "unquote-splicing"
readSExpr :: String -> Parser (SExpr, String)
readSExpr [] = throwError $ strMsg "EOF"
readSExpr (x:xs)
| isSpace x = readSExpr xs
・・・ 省略 ・・・
| 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)
'`' -> readSExpr xs >>=
\(e, ys) -> e `seq` ys `seq` return (CELL quasiquote (CELL e NIL), ys)
',' -> if not (null xs) && head xs == '@'
then readSExpr (tail xs) >>= \(e, ys) -> e `seq` ys `seq`
return (CELL unquoteSplicing (CELL e NIL), ys)
else readSExpr xs >>= \(e, ys) -> e `seq` ys `seq`
return (CELL unquote (CELL e NIL), ys)
_ -> parseError xs ("unexpected token: " ++ show x)
考え方は quote の処理と同じです。x が記号 ` であれば、readSExpr xs で次の S 式を読み込み、CELL quasiquote (CELL e NIL) を返します。記号 , の場合は、次の記号をチェックして、@ であれば CELL unquoteSplicing (CELL e NIL) を返し、そうでなければ CELL unquote (CELL e NIL) を返します。
次は eval にマクロを評価する処理を追加します。
リスト : eval の修正
eval :: Env -> SExpr -> Scm SExpr
eval env NIL = return NIL
・・・ 省略 ・・・
eval env (CELL func args) = do
v <- eval env func
case v of
SYNT f -> f env args
MACR f -> do expr <- apply env f args
eval env expr
_ -> do vs <- evalArguments env args
apply env v vs
引数 func の評価結果がマクロ MACR f の場合、f にはクロージャが格納されているので、それを apply で評価します。このとき、引数 args は評価しないでそのまま渡すことに注意してください。apply の返り値は S 式なので、それを eval で再度評価します。
もし、S 式の中でマクロが使われていたら、そこでまたマクロ展開が行われ、組み立てられた S 式が評価されます。これでマクロの再帰呼び出しも処理することができます。実行速度は遅くなりますが、たったこれだけの処理でマクロの強力な機能を実現することができます。
次は高階関数 apply を作りましょう。Scheme の関数 apply は次のように使います。
apply func args-list
apply は最初の引数 func を関数として呼び出します。このとき、第 2 引数のリストの要素が func の引数として渡されます。apply は func の評価結果を返します。簡単な使用例を示しましょう。
gosh> (apply + '(1 2 3)) 6 gosh> (apply car '((1 2 3))) 1
また apply は次のように、func と args-list の間に引数を与えることができます。
gosh> (apply + 4 5 6 '(1 2 3)) 21
apply はリストに格納されている要素を引数として関数に渡す場合に便利です。
プログラムは次のようになります。
リスト : 高階関数 apply
apply' :: ScmFunc
apply' _ (CELL _ NIL) = throwError $ "apply : " ++ errNEA
apply' env (CELL func args) = do
apply env func $ iter args
where iter (CELL NIL NIL) = NIL
iter (CELL xs@(CELL _ _) NIL) = xs
iter (CELL x xs) = CELL x (iter xs)
apply' _ _ = throwError $ "apply : " ++ errNEA
局所関数 iter で、引数を順番に最後尾の引数 (リスト) に追加します。あとは、iter の返り値を apply に渡して関数 func を呼び出すだけです。
次はエラーメッセージを表示する micro Scheme の関数 error を作ります。
リスト : エラーの表示 error' :: ScmFunc error' _ (CELL (STR x) NIL) = throwError $ "ERROR: " ++ x error' _ (CELL (STR x) (CELL y _)) = throwError $ "ERROR: " ++ x ++ " " ++ show y error' _ (CELL x _) = throwError $ "ERROR: " ++ show x error' _ _ = throwError "ERROR: "
関数 error は第 1 引数が文字列で、第 2 引数が S 式です。第 2 引数は省略することができます。第 1 引数が文字列で無い場合はそれをそのまま表示します。引数が無い場合は "ERROR: " だけを表示します。あとは throwError でエラーを返すだけです。
最後にファイルに書かれたプログラムを読み込む micro Scheme の関数 load を作りましょう。ファイル名は文字列で指定します。プログラムは次のようになります。
リスト : ファイルの読み込み (load)
load :: ScmFunc
load env (CELL (STR filename) _) = do
xs <- lift $ readFile filename
r <- lift $ iter xs
if r then return true else return false
where
iter :: String -> IO Bool
iter xs =
case readSExpr xs of
Left (ParseErr xs' mes) -> if mes == "EOF"
then return True
else do print mes
return False
Right (expr, xs') -> do result <- runExceptT $ eval env expr
case result of
Left mes -> do print mes
return False
Right _ -> iter xs'
load _ _ = throwError "invalid load form"
処理内容は repl とほぼ同じです。局所関数 iter でファイルの終了 "EOF" を検出するまでプログラムを読み込み、それを eval で評価するだけです。途中でエラーが返された場合はエラーメッセージを表示して false を返します。プログラムを正常にロードできた場合は true を返します。
それでは実行してみましょう。まず最初に簡単なマクロを試してみます。
Scm> (define-macro m-square (lambda (x) (list '* x x))) m-square Scm> (m-square 10) 100 Scm> (define-macro add (lambda (xs) (cons '+ xs))) add Scm> (add (1 2 3 4 5)) 15
正常に動作していますね。次は apply を試してみましょう。
Scm> (apply + '(1 2 3 4 5)) 15 Scm> (apply + 10 11 12 '(1 2 3 4 5)) 48 Scm> (define length (lambda (xs) (if (pair? xs) (+ 1 (length (cdr xs))) 0))) length Scm> (length '(1 2 3 4 5)) 5 Scm> (define avg (lambda (xs) (/ (apply + xs) (length xs)))) avg Scm> (avg '(1.0 2.0 3.0 4.5 5.7 6.9)) 3.85
関数 length はリストの要素の個数を返します。length と apply を使うと、リストの要素の平均値を求める関数 avg は簡単に作成することができます。
今回はここまでです。次回はバッククォートの処理を実装して、micro Scheme 用の簡単なライブラリを作ってみましょう。
--
-- mscheme.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 Control.Monad.Trans
import Control.Monad.IO.Class
import System.IO
-- S 式の定義
type ScmFunc = Env -> SExpr -> Scm SExpr
data SExpr = INT !Integer
| REAL !Double
| SYM String
| STR String
| CELL SExpr SExpr
| NIL
| PRIM ScmFunc
| SYNT ScmFunc
| CLOS SExpr LEnv
| MACR SExpr
-- 等値の定義
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, cdr, cons, pair :: ScmFunc
car _ NIL = throwError $ "car : " ++ errNEA
car _ (CELL (CELL a _) _) = return a
car _ _ = throwError $ "car : " ++ errCELL
cdr _ NIL = throwError $ "cdr : " ++ errNEA
cdr _ (CELL (CELL _ d) _) = return d
cdr _ _ = throwError $ "cdr : " ++ errCELL
cons _ (CELL a (CELL b _)) = return (CELL a b)
cons _ _ = throwError $ "cons : " ++ errNEA
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
-- 四則演算
adds, subs, muls, divs, mod' :: ScmFunc
add, sub, mul, div' :: 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 _ xs = foldCell add (INT 0) xs
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 _ 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 (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 _ xs = foldCell mul (INT 1) xs
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 _ NIL = throwError $ "/ : " ++ errNEA
divs _ (CELL a NIL) = div' (INT 1) a
divs _ (CELL a rest) = foldCell div' a rest
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', equal' :: ScmFunc
eq' _ (CELL x (CELL y _)) =
if x == y then return true else return false
eq' _ _ = throwError $ "eq : " ++ errNEA
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 :: ScmFunc
eqNum _ = compareNums (== EQ)
ltNum _ = compareNums (== LT)
gtNum _ = compareNums (== GT)
ltEq _ = compareNums (<= EQ)
gtEq _ = compareNums (>= EQ)
-- apply
apply' :: ScmFunc
apply' _ (CELL _ NIL) = throwError $ "apply : " ++ errNEA
apply' env (CELL func args) = do
apply env func $ iter args
where iter (CELL NIL NIL) = NIL
iter (CELL xs@(CELL _ _) NIL) = xs
iter (CELL x xs) = CELL x (iter xs)
apply' _ _ = throwError $ "apply : " ++ errNEA
-- エラー
error' :: ScmFunc
error' _ (CELL (STR x) NIL) = throwError $ "ERROR: " ++ x
error' _ (CELL (STR x) (CELL y _)) = throwError $ "ERROR: " ++ x ++ " " ++ show y
error' _ (CELL x _) = throwError $ "ERROR: " ++ show x
error' _ _ = throwError "ERROR: "
-- load
load :: ScmFunc
load env (CELL (STR filename) _) = do
xs <- lift $ readFile filename
r <- lift $ iter xs
if r then return true else return false
where
iter :: String -> IO Bool
iter xs =
case readSExpr xs of
Left (ParseErr xs' mes) -> if mes == "EOF"
then return True
else do print mes
return False
Right (expr, xs') -> do result <- runExceptT $ eval env expr
case result of
Left mes -> do print mes
return False
Right _ -> iter xs'
load _ _ = throwError "invalid load form"
--
-- S 式の表示
--
showCell :: SExpr -> String
showCell (CELL a d) =
show a ++ case d of
NIL -> ""
PRIM _ -> "<primitive>"
CLOS _ _ -> "<closure>"
SYNT _ -> "<syntax>"
MACR _ -> "<macro>"
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 (MACR _) = "<macro>"
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"
quasiquote = SYM "quasiquote"
unquote = SYM "unquote"
unquoteSplicing = SYM "unquote-splicing"
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)
'`' -> readSExpr xs >>=
\(e, ys) -> e `seq` ys `seq` return (CELL quasiquote (CELL e NIL), ys)
',' -> if not (null xs) && head xs == '@'
then readSExpr (tail xs) >>= \(e, ys) -> e `seq` ys `seq`
return (CELL unquoteSplicing (CELL e NIL), ys)
else readSExpr xs >>= \(e, ys) -> e `seq` ys `seq`
return (CELL unquote (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
MACR f -> do expr <- apply env f args
eval env expr
_ -> 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 = lift $ pushLEnv name rest lenv
makeBindings lenv (CELL (SYM name) parms) (CELL v args) = do
lenv' <- makeBindings lenv parms args
lift (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 env 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
lift $ H.insert (fst env) name v
return sym
evalDef _ _ = throwError "invalid define form"
-- define-macro
evalDefM :: Env -> SExpr -> Scm SExpr
evalDefM env (CELL sym@(SYM name) (CELL expr NIL)) = do
v <- eval env expr
lift $ H.insert (fst env) name (MACR v)
return sym
evalDefM _ _ = throwError "invalid define-macro 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 <- lift $ lookupLEnv name (snd env)
case a of
Nothing -> do b <- lift $ H.lookup (fst env) name
case b of
Nothing -> throwError $ "unbound variable: " ++ name
Just _ -> do lift $ H.insert (fst env) name v
return v
Just _ -> do lift $ 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),
("define-macro", SYNT evalDefM),
("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),
("load", PRIM load),
("apply", PRIM apply'),
("error", PRIM error')]
-- 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