【他言語版へのリンク記事】簡易LISP処理系の実装例【各言語版まとめ】

この記事は，下記拙作記事のHaskell版を抜粋・修正したものを利用した，簡易LISP処理系（"McCarthy's Original Lisp"）の実装例をまとめたものです．

『括弧文字列』簡易パーサ実装例まとめ
リスト処理関数（cons,car,cdr,eq,atom）実装例まとめ（Haskell版は字句解析部のみ）

最低限の機能をもったLISP処理系の実装の場合，本体である評価器（eval）実装はとても簡単であり，むしろ，字句・構文解析を行うS式入出力やリスト処理実装の方が開発言語ごとの手間が多く，それが敷居になっている人向けにまとめています．

処理系の概要

実行例は次の通り．GHC 8.4.4にて確認．

$ ghci
GHCi, version 8.4.4: http://www.haskell.org/ghc/  :? for help
Prelude> :l jmclisp.hs
[1 of 1] Compiling Main             ( jmclisp.hs, interpreted )
Ok, one module loaded.
*Main> main
(car (cdr '(10 20 30)))

20
*Main> main
((lambda (x) (car (cdr x))) '(abc def ghi))

def
*Main> main
((lambda (f x y) (f x (f y '()))) 'cons '10 '20)

(10 20)
*Main> main
((lambda (f x y) (f x (f y '())))
'(lambda (x y) (cons x (cons y '())))
'10 '20)

(10 (20 ()))
*Main> main
((lambda (assoc k v) (assoc k v))
'(lambda (k v)
   (cond ((eq v '()) nil)
         ((eq (car (car v)) k)
          (car v))
         (t (assoc k (cdr v)))))
'Orange
'((Apple . 120) (Orange . 210) (Lemon . 180)))

(Orange . 210)

実装内容は次の通り．

"McCarthy's Original Lisp"をベースにした評価器
数字を含むアトムは全てシンボルとし，変数の値とする場合はquote（'）を使用
構文としてquoteの他，condとlambdaが使用可能
組込関数：atom eq cons car cdr（内部でコンスセルを作成）
真偽値はt（真）およびnil（偽）＝空リスト＝()
エラーチェックなし，モジュール化なし，ガーベジコレクションなし

"McCarthy's Original Lisp"の詳細についてはまとめ記事を参照．ダイナミックスコープということもあり，実行例ではlambda式をletrec（Scheme）やlabels（Common Lisp）などの代わりに使用しています．

実装例

ソースコード一式

jmclisp.hs

--
-- JMC Lisp: defined in McCarthy's 1960 paper,
-- with S-expression input/output and basic list processing
--


-- basic list processing: cons, car, cdr, eq, atom
-- and S-expression output

data CELL = NIL | T | Sybl String | Pair CELL CELL

sStrcons :: CELL -> String
sStrcons (Pair x y) =
  case y of
    NIL      -> show x
    T        -> show x
    (Sybl a) -> show x ++ " . " ++ a
    _        -> show x ++  " "  ++ sStrcons y

instance Show CELL where
  show NIL      = "()"
  show T        = "t"
  show (Sybl x) = x
  show ss       = "(" ++ sStrcons ss ++ ")"

instance Eq CELL where
  NIL    == NIL    = True
  T      == T      = True
  Sybl x == Sybl y = x == y
  _      == _      = False

cons :: CELL -> CELL -> CELL
cons x y = Pair x y

car :: CELL -> CELL
car (Pair x _) = x

cdr :: CELL -> CELL
cdr (Pair _ y) = y

eq :: CELL -> CELL -> Bool
eq s1 s2 = s1 == s2

atom :: CELL -> Bool
atom s =
  case s of
    NIL      -> True
    T        -> True
    (Sybl s) -> True
    _        -> False


-- S-expression input: s_read

--- s_lex

s_replace :: String -> String
s_replace [] = ""
s_replace (c : s) =
  case c of
    '(' -> " ( "
    ')' -> " ) "
    '\'' -> " \' "
    _    -> [c]
  ++ s_replace s

s_lex :: String -> [String]
s_lex s = words $ s_replace s

--- s_syn

s_quote :: CELL -> [String] -> [(CELL, [String])]
s_quote x s
  | (not $ null s) && (last s == "\'")
    = [(cons (Sybl "quote") $ cons x NIL, init s)]
  | otherwise = [(x, s)]

s_syn0 :: CELL -> [String] -> [(CELL, [String])]
s_syn0 r s =
  let t  = last s
      ss = init s
  in case t of
       "(" -> do return (r, s)
       "." -> do (rr, rss) <- s_syn $ init s
                 c <- [cons rr $ car r]
                 (cr, css) <- s_syn0 c rss
                 return (cr, css)
       _   -> do (rr, rss) <- s_syn s
                 c <- [cons rr r]
                 (cr, css) <- s_syn0 c rss
                 return (cr, css)

s_syn :: [String] -> [(CELL, [String])]
s_syn s =
  let t  = last s
      ss = init s
  in case t of
       ")" -> do (r, ss) <- s_syn0 NIL ss
                 ss <- [init ss]
                 (r, ss) <- s_quote r ss
                 return (r, ss)
       _   -> do (t, ss) <- s_quote (Sybl t) ss
                 return (t, ss)

--- s_read

s_read :: String -> CELL
s_read s = r where [(r, _)] = s_syn $ s_lex s


-- JMC Lisp evaluator: s_eval

eq_ :: CELL -> CELL -> CELL
eq_ s1 s2 = if s1 == s2 then T else NIL

atom_ :: CELL -> CELL
atom_ s =
  case s of
    NIL      -> T
    T        -> T
    (Sybl s) -> T
    _        -> NIL

caar :: CELL -> CELL
caar x = (car (car x))

cadr :: CELL -> CELL
cadr x = (car (cdr x))

cadar :: CELL -> CELL
cadar x = (car (cdr (car x)))

caddr :: CELL -> CELL
caddr x = (car (cdr (cdr x)))

caddar :: CELL -> CELL
caddar x = (car (cdr (cdr (car x))))

s_append :: CELL -> CELL -> CELL
s_append x y
  | x == NIL  = y
  | otherwise = (cons (car x) (s_append (cdr x) y))

s_list :: CELL -> CELL -> CELL
s_list x y = (cons x (cons y NIL))

s_pair :: CELL -> CELL -> CELL
s_pair x y
  | x == NIL && y == NIL = NIL
  | not (atom x) && not (atom y)
    = (cons (s_list (car x) (car y)) (s_pair (cdr x) (cdr y)))

s_assoc :: CELL -> CELL -> CELL
s_assoc x y
  | (eq (caar y) x) = (cadar y)
  | otherwise       = (s_assoc x (cdr y))

s_eval :: CELL -> CELL -> CELL
s_eval e a =
  if      (eq e (Sybl "t"))   then T
  else if (eq e (Sybl "nil")) then NIL
  else if (atom e) then (s_assoc e a)
  else if (atom (car e)) then
    if      (eq (car e) (Sybl "quote")) then (cadr e)
    else if (eq (car e) (Sybl "atom"))  then (atom_ (s_eval (cadr e)  a))
    else if (eq (car e) (Sybl "eq"))    then (eq_   (s_eval (cadr e)  a)
                                                    (s_eval (caddr e) a))
    else if (eq (car e) (Sybl "car"))   then (car   (s_eval (cadr e)  a))
    else if (eq (car e) (Sybl "cdr"))   then (cdr   (s_eval (cadr e)  a))
    else if (eq (car e) (Sybl "cons"))  then (cons  (s_eval (cadr e)  a)
                                                    (s_eval (caddr e) a))
    else if (eq (car e) (Sybl "cond"))  then (evcon (cdr e) a)
    else (s_eval (cons (s_assoc (car e) a) (cdr e)) a)
  else if (eq (caar e) (Sybl "lambda")) then
          (s_eval (caddar e) (s_append (s_pair (cadar e) (evlis (cdr e) a)) a))
  else NIL

evcon :: CELL -> CELL -> CELL
evcon c a
  | (s_eval (caar c) a) == T = (s_eval (cadar c) a)
  | otherwise = (evcon (cdr c) a)

evlis :: CELL -> CELL -> CELL
evlis m a
  | m == NIL  = NIL
  | otherwise = (cons (s_eval (car m) a) (evlis (cdr m) a))


-- REP (no Loop): s_rep

s_rep e = (s_eval (s_read e) NIL)

getLines :: IO [String]
getLines = do
  s <- getLine
  if s == "" then return []
  else do
    ss <- getLines
    return (s : ss)

main = do
  r <- getLines
  let s = foldl (++) "" r
  print $ s_rep s

解説

リスト処理：cons car cdr eq atom（Show定義によるS式出力込）
先の記事からほとんどを抜粋．型制約を簡単にするため（具体的には，評価器s_evalの戻り値の型を，S式の型であるCELLに統一するため），真偽値をBool再定義ではなくTおよびNILに設定（言語仕様上ではtおよびnil=()）．
S式入力：s_read
先の記事から，字句解析部s_lexを()および'の識別に変更．抽象構文木生成部s_synは新規に作成し，字句解析によって得られた文字列配列に対してリストモナドなどを使用して走査（スキャン）処理を行いながら，上記リスト処理で定義されたS式の型CELLおよびconsを用いてコンスセルに基づく構文木を生成．それらをまとめたS式入力関数s_readを定義．
評価器：s_eval＋ユーティリティ関数
"McCarthy's Original Lisp"をベースにs_eval関数およびユーティリティ関数を作成．オリジナルおよび他言語実装版との大きな違いは，Haskell上の真偽値を返すeq atomとは別に，T NILを返すeq_ atom_を別途定義し，condなどの言語実装上では，Tか否かはEqの==定義を用いて条件判断を行っていること．理由は，上記のリスト処理実装解説にある通り．
REP (no Loop)：s_rep
s_read→s_evalをまとめたs_repを定義．GHCiやプログラムファイル上では，二重引用符で囲んだ（LISP記述としての）文字列を複数行に分けて入力・記述することができないため，空行を入力するまで行単位の文字列入力をリストに蓄積するIOモナドgetLinesを定義，それをmain関数で結合してs_repに渡すよう記述．

備考

記事に関する補足

評価器のみの場合，約95行／2500バイトほど．それ以外が約100行／2500バイトほどで，半々といったところ．もっとも，評価器については，オリジナルや他言語実装版との比較のため，わざとLISP並の括弧表現と冗長な条件分岐記述を行っているので，短くしようと思えばかなり短くできるかも．とはいえ，リスト処理／S式入力実装は数日（の間に時間を見つけてちょこちょこと）かかったのに対し，評価器については，真偽値の扱いの変更を含めても，実装に要した時間は数十分程度だったのだけれども．

更新履歴

2020-09-17：s_lexを修正（別記事コメントより）
2020-09-16：初版公開