M.Hiroi's Home Page

Functional Programming

お気楽 Haskell プログラミング入門

[ PrevPage | Haskell | NextPage ]

Haskell で作る micro Scheme (4)

今回は micro Scheme に「マクロ (macro)」という機能を追加しましょう。define で定義できる関数は引数を評価するタイプで、シンタックス形式のように引数を評価しない関数を定義することはできません。Scheme (Lisp) でプログラミングする場合、ほとんどの処理は define で定義する関数で作ることができますが、シンタックス形式のように引数を評価しない関数を定義した方が便利な場合もあります。このようなとき、役に立つのがマクロです。

Scheme の場合、マクロは二種類あります。一つは仕様書 (R5RS など) で定義されているマクロで、これを「健全なマクロ」といいます。これに対し、昔から Lisp で使われているマクロを「伝統的なマクロ」といいます。多くの Scheme 処理系では、どちらのマクロも使えるようになっています。健全なマクロは作るのが大変なので、今回は伝統的なマクロを追加することにします。

まずは最初に伝統的なマクロについて簡単に説明します。

●伝統的なマクロ

Lisp ではマクロを関数のように定義します。伝統的なマクロを定義するには define-macro を使います。

(define-macro マクロ名 (lambda (<仮引数> ...) S式 ...))

define-macro の構文は define と同じです。define-macro で定義されたマクロは、次のような特徴を持ちます。

この 2 番目の機能が Lisp におけるマクロの特徴です。これを図に示すと、次のようになります。

[S式] ─  評価  -> [新しいS式] ─ 評価 -> [マクロの返り値]
      (マクロ展開)


                   図 : マクロの動作

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)) (S式が組み立てられる)

=> 9                   (S式を評価した結果)


        図 : マクロの実行

関数であれば引数 (+ 1 2) が評価されて、その返り値である 3 が square に渡されますね。マクロの場合、引数は評価されないので、仮引数 x には S 式である (+ 1 2) がそのままセットされます。

次に、マクロ本体を評価します。マクロを使いこなすポイントですが、まず評価したい S 式を組み立てることを考えます。最初の評価で S 式を組み立て、それを評価することで目的の処理を実現するのがマクロなのです。

この場合、引数の 2 乗する (* x x) という S 式を作ればいいわけです。list は引数を要素とする新しいリストを返す関数でしたね。この場合、シンボル * と x の値である (+ 1 2) が要素となったリストが返されます。

これでマクロ展開が終了しました。マクロの仮引数は、マクロ展開されるときだけ有効です。マクロ展開されたS式を評価するときは、それらの値は破棄されます。あとは、この 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 の作成

次は高階関数 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 用の簡単なライブラリを作ってみましょう。

●参考文献, URL

  1. 黒川利明, 『LISP 入門』, 培風館, 1982
  2. Patrick Henry Winston, Berthold Klaus Paul Horn, 『LISP 原書第 3 版 (1)』, 培風館, 1992
    18. Lisp で書く Lisp
  3. R. Kent Dybvig (著), 村上雅章 (訳), 『プログラミング言語 SCHEME』, 株式会社ピアソン・エデュケーション, 2000
    9.2 Scheme のメタ循環インタプリタ
  4. Ravi Sethi (著), 神林靖 (訳), 『プログラミング言語の概念と構造』, アジソンウェスレイ, 1995
    第 11 章 定義インタプリタ
  5. Harold Abelson, Gerald Jay Sussman, Julie Sussman, "Structure and Interpretation of Computer Programs",
    4.1 The Metacircular Evaluator
  6. 稲葉雅幸, ソフトウェア特論, 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 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

初版 2013 年 8 月 25 日
改訂 2021 年 8 月 1 日

Copyright (C) 2013-2021 Makoto Hiroi
All rights reserved.

[ PrevPage | Haskell | NextPage ]