簡易LISP処理系の実装例（C言語版）

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

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

• 『括弧文字列』簡易パーサ実装例まとめ
• リスト処理関数（cons,car,cdr,eq,atom）実装例まとめ

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

#処理系の概要
main関数にLISPプログラムを埋め込んだ場合の実行例（UNIXシェル）は次の通り．32ビット版GCC 8.3.0にて確認．

int main(void)
{
  s_rep("(car (cdr '(10 20 30)))");

  s_rep("((lambda (x) (car (cdr x))) '(abc def ghi))");

  s_rep("((lambda (func x y) (func x (func y '()))) \
          'cons '10 '20)");

  s_rep("((lambda (func x y) (func x (func y '()))) \
         '(lambda (x y) (cons x (cons y '())))      \
         '10 '20)");

  s_rep("((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)))");

  return (0);
}

$ cc -Wall -o jmclisp *.c
$ ./jmclisp 
20
def
(10 20)
(10 (20 ()))
(Orange . 210)

実装内容は次の通り．

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

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

#実装例

##ソースコード一式

s_list.h

#include <stdio.h>
#include <stdlib.h>
#include <string.h>
#include <stdint.h>

#ifndef S_LIST_H_
#define S_LIST_H_

typedef uintptr_t value_t;
enum NODE_TAG { NODE_STRG, NODE_CONS };

typedef struct _node_t_ {
  value_t value;
  enum NODE_TAG tag;
} _node_t, *node_t;

node_t node(value_t value, enum NODE_TAG tag);

typedef struct _cons_t_ {
  node_t x;
  node_t y;
} _cons_t, *cons_t;

node_t cons(node_t x, node_t y);

#define str_to_node(s)  (node((value_t)(s), NODE_STRG))
#define node_to_str(s)  ((char *)(s->value))
#define car(s)    (((cons_t)(s->value))->x)
#define cdr(s)    (((cons_t)(s->value))->y)

int eq(node_t s1, node_t s2);

#define n_strg(s)  (s->tag == NODE_STRG)
#define n_cons(s)  (s->tag == NODE_CONS)

#define atom(s)   (eq(s, NULL) || n_strg(s))

#endif

s_list.c

#include "s_list.h"

node_t node(value_t value, enum NODE_TAG tag)
{
  node_t n = (node_t)malloc(sizeof(_node_t));
  n->value = value; n->tag = tag;
  return (n);
}

node_t cons(node_t x, node_t y)
{
  cons_t c = (cons_t)malloc(sizeof(_cons_t));
  c->x = x; c->y = y;
  node_t n = node((value_t)c, NODE_CONS);
  return (n);
}

int eq(node_t s1, node_t s2)
{
  if (s1 == NULL && s2 == NULL) return (1);
  else if (s1 == NULL || s2 == NULL) return (0);
  else if (n_cons(s1) || n_cons(s2)) return (0);
  else return (!strcmp(node_to_str(s1), node_to_str(s2)));
}

s_lex.h

#include <stdio.h>
#include <stdlib.h>
#include <string.h>

#ifndef S_LEX_H_
#define S_LEX_H_

#define SSTR_MAX 4096

int s_lex(const char *s, char* sl[]);

#endif

s_lex.c

#include "s_lex.h"

int s_lex(const char *s, char* sl[])
{
  char sf[SSTR_MAX * 3];
  int i, j = 0;
  for (i = 0; i < strlen(s); i++) {
    switch (s[i]) {
      case '(':
      case ')':
      case '\'':
        sf[j++] = ' '; sf[j++] = s[i]; sf[j++] = ' ';
        break;
      case '\n': j++; break;
      default: sf[j++] = s[i];
    }
  }
  sf[j] = '\0';

  char *t;
  int len = 0;
  for (t = strtok(sf, " "); t != NULL; t = strtok(NULL, " "))
    sl[len++] = t;
  sl[len] = NULL;

  return (len);
}

s_syn.h

#include <stdio.h>
#include <stdlib.h>

#ifndef S_SYN_H_
#define S_SYN_H_

#include "s_list.h"

node_t s_syn(char *s[], int *pos);

#endif

s_syn.c

#include "s_list.h"
#include "s_syn.h"

node_t s_syn(char *s[], int *pos)
{
  char *t = s[*pos];
  *pos = *pos - 1;

  if (t[0] == ')') {
    node_t r = NULL;
    while (s[*pos][0] != '(') {
      if (s[*pos][0] == '.') {
        *pos = *pos - 1;
        r = cons(s_syn(s, pos), car(r));
      } else {
        r = cons(s_syn(s, pos), r);
      }
    }
    *pos = *pos - 1;
    if (*pos != -1 && s[*pos][0] == '\'') {
      *pos = *pos - 1;
      return cons(str_to_node("quote"), cons(r, NULL));
    } else {
      return (r);
    }
  } else {
    node_t tn = str_to_node(t);
    if (*pos != -1 && s[*pos][0] == '\'') {
      *pos = *pos - 1;
      return cons(str_to_node("quote"), cons(tn, NULL));
    } else {
      return (tn);
    }
  }
}

s_display.h

#include <stdio.h>
#include <stdlib.h>
#include <string.h>

#ifndef S_DISPLAY_H_
#define S_DISPLAY_H_

#include "s_list.h"

void s_display(node_t s);
void s_strcons(node_t s);

#endif

s_display.c

#include "s_list.h"
#include "s_display.h"

void s_strcons(node_t s)
{
  s_display(car(s));
  node_t sd = cdr(s);
  if (sd == NULL) {
  } else if (n_strg(sd)) {
    printf(" . "); printf("%s", node_to_str(sd));
  } else {
    printf(" "); s_strcons(sd);
  }
}

void s_display(node_t s)
{
  if (s == NULL) {
    printf("()");
  } else if (n_strg(s)) {
     printf("%s", node_to_str(s));
  } else {
    printf("("); s_strcons(s); printf(")");
  }
}

s_eval.h

#include <stdio.h>
#include <stdlib.h>

#ifndef S_EVAL_H_
#define S_EVAL_H_

#include "s_list.h"

#define S_T   (str_to_node("t"))
#define S_NIL (NULL)

node_t caar(node_t x);
node_t cadr(node_t x);
node_t cadar(node_t x);
node_t caddr(node_t x);
node_t caddar(node_t x);

node_t s_null(node_t x);
node_t s_append(node_t x, node_t y);
node_t s_list(node_t x, node_t y);
node_t s_pair(node_t x, node_t y);
node_t s_assoc(node_t x, node_t y);

node_t s_eval(node_t e, node_t a);
node_t evcon(node_t c, node_t a);
node_t evlis(node_t m, node_t a);

#endif

s_eval.c

#include <stdio.h>
#include <stdlib.h>

#include "s_list.h"
#include "s_eval.h"

node_t caar(node_t x) { return car(car(x)); }
node_t cadr(node_t x) { return car(cdr(x)); }
node_t cadar(node_t x) { return car(cdr(car(x))); }
node_t caddr(node_t x) { return car(cdr(cdr(x))); }
node_t caddar(node_t x) { return car(cdr(cdr(car(x)))); }

node_t s_null(node_t x) {
  if (eq(x, NULL)) return S_T; else return S_NIL;
}

node_t s_append(node_t x, node_t y)
{
  if (s_null(x)) return y;
  else return cons(car(x), s_append(cdr(x), y));
}

node_t s_list(node_t x, node_t y)
{
  return cons(x, cons(y, NULL));
}

node_t s_pair(node_t x, node_t y)
{
  if (s_null(x) && s_null(y)) return NULL;
  else if (!atom(x) && !atom(y))
    return cons(s_list(car(x), car(y)),
                s_pair(cdr(x), cdr(y)));
  else return S_NIL;
}

node_t s_assoc(node_t x, node_t y)
{
  if (s_null(y)) return S_NIL;
  else if (eq(caar(y), x)) return cadar(y);
  else return s_assoc(x, cdr(y));
}

node_t s_eval(node_t e, node_t a)
{
  if      (eq(e, str_to_node("t")))   return S_T;
  else if (eq(e, str_to_node("nil"))) return S_NIL;
  else if (atom(e)) return s_assoc(e, a);
  else if (atom(car(e))) {
    if      (eq(car(e), str_to_node("quote"))) return cadr(e);
    else if (eq(car(e), str_to_node("atom")))
      if (atom(s_eval(cadr(e), a))) return S_T;
      else return S_NIL;
    else if (eq(car(e), str_to_node("eq")))
      if (eq(s_eval(cadr(e), a), s_eval(caddr(e), a))) return S_T;
      else return S_NIL;
    else if (eq(car(e), str_to_node("car")))   return car( s_eval(cadr(e), a));
    else if (eq(car(e), str_to_node("cdr")))   return cdr( s_eval(cadr(e), a));
    else if (eq(car(e), str_to_node("cons")))  return cons(s_eval(cadr(e), a),
                                                           s_eval(caddr(e), a));
    else if (eq(car(e), str_to_node("cond")))  return evcon(cdr(e), a);
    else return s_eval(cons(s_assoc(car(e), a), cdr(e)), a);
  } else if (eq(caar(e), str_to_node("lambda"))) {
    return s_eval(caddar(e),
                  s_append(s_pair(cadar(e), evlis(cdr(e), a)), a));
  } else {
    printf("Error"); return NULL;
  }
}

node_t evcon(node_t c, node_t a)
{
  if (s_eval(caar(c), a)) return s_eval(cadar(c), a);
  else return evcon(cdr(c), a);
}

node_t evlis(node_t m, node_t a)
{
  if (s_null(m)) return NULL;
  else return cons(s_eval(car(m), a), evlis(cdr(m), a));
}

jmclisp.c

#include "s_list.h"
#include "s_lex.h"
#include "s_syn.h"
#include "s_display.h"
#include "s_eval.h"

/* REP (no Loop) */
void s_rep(const char s[])
{
  char *lr_s[SSTR_MAX]; int s_len;
  s_len = s_lex(s, lr_s) - 1;
  node_t rs = s_syn(lr_s, &s_len);
  node_t r = s_eval(rs, NULL);
  s_display(r); printf("\n");
  free(rs); free(r);
}

int main(void)
{
  char s1[] = "(car (cdr '(10 20 30)))";
  s_rep(s1);

  char s2[] = "((lambda (x) (car (cdr x))) '(abc def ghi))";
  s_rep(s2);

  char s3[] = "((lambda (func x y) (func x (func y '()))) \
                'cons '10 '20)";
  s_rep(s3);

  char s4[] = "((lambda (func x y) (func x (func y '()))) \
                '(lambda (x y) (cons x (cons y '())))     \
                '10 '20)";
  s_rep(s4);

  char s5[] = "((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) (Lemmon . 180)))";
  s_rep(s5);

  return (0);
}

$ ls
jmclisp.c    s_display.h  s_eval.h  s_lex.h   s_list.h  s_syn.h
s_display.c  s_eval.c     s_lex.c   s_list.c  s_syn.c
$ cc -Wall -o jmclisp *.c
$ ./jmclisp
20
def
(10 20)
(10 (20 ()))
(Orange . 210)

##解説

• リスト処理：cons car cdr eq atom（s_list.h，s_list.c）
  先の記事より，ほぼそのまま抜粋．C言語版については，S式入出力の元記事でも名称等を修正した上で使用しています．~~~※今回のコードは32ビット仕様の場合です．64ビット仕様の場合は，s_list.h内value_tの型定義を（unsigned intではなく）unsigned longとして下さい．~~~stdint.hを読み込んでuintptr_tを使うようにしました．

• S式字句解析：s_lex（s_lex.h，s_lex.c），S式抽象構文木生成：s_syn（s_syn.h，s_syn.c）
  先の記事から，字句解析部を()および'の識別に変更．抽象構文木生成部については，元記事でもリスト処理関数でコンスセルによる構文木を生成しており，そこに，ドット対とクォート記号に対応するための記述を追加．

• S式出力：s_display（s_display.h，s_display.c）
  S式出力部はs_displayとして新規に作成．他の言語バージョンでは文字列相当を返すがC言語では厳しいので，処理結果のS式抽象構文木を表示するだけのものとして実装．

• 評価器：s_eval＋ユーティリティ関数（s_eval.h，s_eval.c）
  "McCarthy's Original Lisp"をベースにs_eval関数およびユーティリティ関数を作成．

• REP (no Loop)：s_repおよびmain関数（jmclisp.c）
  実行例のmain関数を含めたs_rep定義例（および，コンパイル・実行の様子）．REPLも実装できなくはありませんが，例によって処理系本体よりも手間暇かかることから，関心のある方は，今回掲載するプログラムコードを参考に，独自に作成してみても良いかもしれません．

#備考

##記事に関する補足

• 各部分のファイルサイズ等は次の通り．全体約7800バイト中3000バイトほどがeval関連の実装であるあたりに，今回の記事の主旨が確認できそう．

$ wc *
  51  172 1243 jmclisp.c
  26   61  448 s_display.c
  13   19  184 s_display.h
  84  287 2445 s_eval.c
  28   70  553 s_eval.h
  27   90  505 s_lex.c
  12   20  164 s_lex.h
  25   85  562 s_list.c
  37   90  763 s_list.h
  36  120  746 s_syn.c
  12   16  140 s_syn.h
 351 1030 7753 合計

• TermuxのClangだと，value_tをunsigned longにしてもセグフォ吐く時がある…どうしたものかな．（2021/04/03）~~~ちゃんとstdint.h読み込んでuintptr_tにしてもやっぱりセグフォ吐く…うーん．~~~文字列バッファの大きさを4倍にしたら動きますた．だから，いくら楽でも配列の見込み静的確保はメモリリークの温床だってあれほど（略）．

##更新履歴

• 2020-04-03：valut_tの定義と文字列バッファの大きさを変更
• 2020-09-11：実装例をソースコード一式＋解説の構成に変更
• 2020-09-10：リスト処理部について，64ビット仕様の場合を注記
• 2020-09-09：初版公開