#はじめに

C++のプログラムにスクリプト言語を組み込みたくなることはよくある。その用途は定型作業や動作確認の自動化のほか、より単純な初期設定であったり、あるいはシステムそのものの記述だったりすることもある。

組み込み用途のスクリプト言語は定番となっているものがいくつかある。LuaやPythonなどだ。またそういったスクリプト言語へのFFIを自動的にラッピングしてくれるプログラムもいくつかある。代表的なのはSWIGか。

しかし実際にスクリプト言語を組み込もうとすると、結構な量の文書を読まなければならず正直めんどい。セットアップの方法もOS毎に違うから、さらにめんどい。もっと楽に！頭を使わずに！できないもんかと思い探してみたところ、すごいいいのありましたw

#s7

https://ccrma.stanford.edu/software/snd/snd/s7.html
ftp://ccrma-ftp.stanford.edu/pub/Lisp/s7.tar.gz

s7はスタンフォード大学が公開している組み込み用のScheme処理系で、r5rsとr7rsに準拠しているらしい。ライセンスはたぶんBSDとのこと。

その最大の特徴はファイル構成の単純さにあり、s7.hとs7.cという二つしかない。クロスプラットフォームであるにもかかわらずセットアップやコンフィギュレーションが不要で、基本的にこの二つのファイルとmus-config.hというカスタマイズ用のヘッダーファイルだけでいい。

ドキュメントもHTMLファイル一つで完結していて、ブラウザで検索するのが楽。あとソースファイルを開いてみると、Mini-Schemeという前世紀に京都大学が公開した処理系を大元の母体にしているようで、ここもなんか好き。

構成の単純さに反して仕様は本格的で、ソースファイルから抜粋すると

50  * s7.c is organized as follows:
51  *    structs and type flags
52  *    constants
53  *    GC
54  *    stacks
55  *    symbols and keywords
56  *    environments
57  *    continuations
58  *    numbers
59  *    characters
60  *    strings
61  *    ports
62  *    format
63  *    lists
64  *    vectors
65  *    hash-tables
66  *    c-objects
67  *    functions
68  *    equal?
69  *    generic length, copy, reverse, fill!, append
70  *    error handlers
71  *    sundry leftovers
72  *    the optimizers
73  *    multiple-values, quasiquote
74  *    eval
75  *    multiprecision arithmetic
76  *    *s7* environment
77  *    initialization
78  *    repl

あとこれは今のところ俺にはあまり重要じゃないんだけど、計算速度がすごい速いみたいなんだよね。

; fib.scm
(define (fib n)
  (if (< n 2) n
    (+ (fib (- n 1)) (fib (- n 2)))))
(let ((i 30))
  (display (fib i)))
(newline)

これをgaucheで実行すると、

$ time gosh fib.scm
832040

real	0m0.151s
user	0m0.138s
sys	0m0.009s

s7だと、

$ time ./s7 fib.scm
load fib.scm
832040

real	0m0.050s
user	0m0.041s
sys	0m0.005s

だいたい3倍くらい速い。俺が愛用するchickenでも計測したけどここには書かない。チキン…

ちなみにs7の実行ファイルは上記mus-config.hに以下のような記述を加えてs7.cをコンパイルするとできる。

#define WITH_MAIN 1

この実行ファイルをREPL（対話形式）で使うには、カレントディレクトリにs7の以下ファイルをコピーするとできるようだ。

cload.scm
libc.scm	
repl.scm

#s7wrap

でまあここからが本題なんだけど、俺としてはこのs7をできるだけ楽チンに自作のC++プログラムに組み込みたかった。そこで単純な定義ファイルからラッパーを出力するプログラムを書いたのだった。これを使うと、s7のドキュメントやヘッダーファイルを一切読むことなくs7を利用できる。

ちょっと長いけど、以下がソース全文。s7自身で書かれている。

; s7wrap.scm

(define (read-all)
  (let loop ((r '()))
    (let ((l (read)))
      (if (eof-object? l)
        (reverse r)
        (loop (cons l r))))))

(define (declare-apis ll)
  (map (lambda (l)
         (let ((name (car l)))
           (format #f
             "s7_pointer api_~A (s7_scheme *sc, s7_pointer args);"
             name)))
    ll))

(define (get-api-name l)
  (car l))

(define (get-api-type l)
  (cadr l))

(define (get-api-args l)
  (let loop ((l (cdddr l))
             (r '()))
    (if (and (pair? l) (not (string? (car l))))
      (loop (cdr l)
        (cons (car l) r))
      (reverse r))))

(define (get-arg-name l)
  (if (pair? l)
    (car l)
    l))

(define (get-arg-type l)
  (if (pair? l)
    (cadr l)
    'atom))

(define (get-arg-s7-type-str l)
  (let ((type (get-arg-type l)))
    (get-s7-type-str type)))

(define (get-s7-type-str type)
  (cond
    ((eq? type 'bool)
     "boolean")
    ((eq? type 'ptr)
     "c_pointer")
    ((eq? type 'str)
     "string")
    ((eq? type 'int)
     "integer")
    ((eq? type 'real)
     "real")
    ((eq? type 'atom)
     "s7_pointer")
    ((eq? type 'void)
     "unspecified")
    (else (error "get-arg-type()" type))))

(define (get-arg-type-str l)
  (get-type-str (get-arg-type l)))

(define (get-type-str type)
  (cond
    ((eq? type 'bool)
     "bool")
    ((eq? type 'ptr)
     "void*")
    ((eq? type 'str)
     "const char*")
    ((eq? type 'int)
     "long long")
    ((eq? type 'real)
     "double")
    ((eq? type 'atom)
     "s7_pointer")
    ((eq? type 'void)
     "void")
    (else (error "get-arg-type()" type))))

(define (has-rest-args? l)
  (let ((e (tail l)))
    (or (symbol? e)
      (string? e))))

(define (tail l)
  (let loop ((l l))
    (let ((r (cdr l)))
      (cond
        ((null? r)
         (car l))
        ((pair? r)
         (loop r))
        (else r)))))

(define (range n)
  (let loop ((i 0)
             (ret '()))
    (if (= i n)
      (reverse ret)
      (loop (+ i 1) (cons i ret)))))

(define (get-api-expr l)
  (let ((name (car l))
        (type (cadr l))
        (args (cdddr l)))
    (format #f "(~A~{~A~}) -> ~A"
      name
      (map (lambda (arg)
             (cond
               ((pair? arg)
                (format #f " ~A" (car arg)))
               ((symbol? arg)
                (format #f " . ~A" arg))
               (else "")))
        args)
      type)))

(define (get-api-desc l)
  #;(caddr l)
  (let ((expr (get-api-expr l))
        (desc (caddr l))
        (l (cdddr l)))
    (format #f "~A\\n~A~{~A~}"
      expr
      desc
      (map (lambda (arg)
             (cond
               ((string? arg)
                (format #f ": ~A" arg))
               ((symbol? arg)
                (format #f "\\n  ~A (list)" arg))
               (else
                 (let ((name (car arg))
                       (type (cadr arg)))
                   (if (null? (cddr arg))
                     (format #f "\\n  ~A (~A)" name type)
                     (let ((desc (caddr arg)))
                       (format #f "\\n  ~A (~A): ~A" name type desc)))))))
        l))))

(define (define-s7-funcs ll)
  (map (lambda (l)
         (let ((name (car l))
               (argc (length (get-api-args l)))
               (desc (get-api-desc l))
               (rest (has-rest-args? l)))
           (format #f "\t\ts7_define_function (s7, \"api_~A\", ::api_~A, ~A, 0, ~A, \"~A\");"
             name name argc (if rest "true" "false") desc)))
    ll))

(define (declare-api-methods ll)
  (map (lambda (l)
         (let ((type (get-type-str (get-api-type l)))
               (name (get-api-name l))
               (args (get-api-args l)))
           (format #f "\t~A api_~A (~{~A~|, ~});"
             type name (declare-api-methods--args args))))
    ll))

(define (chop-tail l)
  (let loop ((l l)
             (r '()))
    (if (null? (cdr l))
      (reverse r)
      (loop (cdr l) 
        (cons (car l) r)))))

(define (chop-rest-doc args)
  (if (null? args) args
    (if (not (has-rest-args? args)) args
      (let ((e (tail args)))
        (if (symbol? e) args
          (chop-tail args))))))

(define (declare-api-methods--args args)
  (map (lambda (l)
         (let ((name (get-arg-name l))
               (type-str (get-arg-type-str l)))
           (format #f "~A ~A" type-str name)))
    (chop-rest-doc args)))

(define (define-s7-wrappers ll)
  (map (lambda (l)
         (let ((api-name (get-api-name l))
               (api-type (get-api-type l))
               (api-args (get-api-args l)))
           (let ((api-s7-type-str (get-s7-type-str api-type))
                 (api-type-str (get-type-str api-type)))
             (format #f "\
inline s7_pointer api_~A (s7_scheme *sc, s7_pointer args)
{
~{~A~}\
    ~AS7::get().api_~A (~{~A~|, ~});
    return ~A;
}"
               api-name
               (define-s7-wrappers--args api-name api-args)
               (if (eq? api-type 'void) "" (string-append api-type-str " ret = "))
               api-name
               (map (lambda (arg)
                      (format #f "arg_~A" (get-arg-name arg)))
                 api-args)
               (cond
                 ((eq? api-type 'atom) "ret")
                 ((eq? api-type 'void) "s7_unspecified (sc)")
                 (else (string-append "s7_make_" api-s7-type-str " (sc, ret)")))))))
    ll))

(define (define-s7-wrappers--args api-name args)
  (if (null? args) args
    (let ((args (chop-rest-doc args)))
      (map (lambda (pos arg)
             (if (pair? arg)
               (let ((name (get-arg-name arg))
                     (type (get-arg-type arg))
                     (type-str (get-arg-type-str arg))
                     (s7-type-str (get-arg-s7-type-str arg))
                     (pos (+ pos 1)))
                 (if (eq? type 'atom)
                   (format #f "\
    ~A arg_~A = s7_car (args);
    args = s7_cdr (args);
" type-str name)
                   (format #f "\
    if (!s7_is_~A (s7_car (args)))
        return (s7_wrong_type_arg_error (sc, \"api_~A\", ~A, s7_car (args), \"an ~A\"));
    ~A arg_~A = s7_~A (~As7_car (args));
    args = s7_cdr (args);
"
                     s7-type-str
                     api-name pos s7-type-str
                     type-str name s7-type-str
                     (if (eq? type 'bool) "sc, " ""))))
               (format #f "\
    s7_pointer arg_~A = args;
"
                 arg)))
        (range (length args)) args))))

(define (s7-wrap port ll)
  (format port "\
#ifndef S7WRAP
#define S7WRAP

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

extern \"C\" {
#include \"s7.h\"
~{~A
~}\
}

class S7 {
public:
// IMPLEMENT BELOW

    void init ();
~{~A
~}\

// IMPLEMENT ABOVE
private:
    s7_scheme *s7;
    char buff[4096];
    S7 ()
    : s7 (s7_init())
    {
~{~A
~}\
    }
    virtual ~~S7 ()
    {}
public:
    class Atom
    {
        s7_pointer atom;
        s7_int loc;
        Atom (const Atom& atom)=delete;
        Atom& operator= (const Atom& atom)=delete;
    public:
        Atom ()
        : atom (nullptr)
        {}
        Atom (s7_pointer atom)
        : atom (atom), loc (s7_gc_protect (S7::get(), atom))
        {}
        virtual ~~Atom()
        {
            if (atom != nullptr)
                s7_gc_unprotect_at (S7::get(), loc);
        }
        operator s7_pointer() const
        {
            return atom;
        }
        Atom& operator= (s7_pointer s7p)
        {
            if (atom != nullptr)
                s7_gc_unprotect_at (S7::get(), loc);
            atom = s7p;
            if (atom != nullptr)
                loc = s7_gc_protect (S7::get(), atom);
            return *this;
        }
        Atom (Atom&& one)
        : atom (one.atom), loc (one.loc)
        {
            one.atom = nullptr;
        }
        const Atom& operator= (Atom&& one)
        {
            atom = one.atom;
            loc = one.loc;
            one.atom = nullptr;
            return *this;
        }
    };
    class Env {
        Atom env;
        Env (const Env& env)=delete;
    public:
        Env (s7_pointer e)
        : env (s7_sublet (S7::get(), e, s7_nil (S7::get())))
        {}
        Env ()
        : env (s7_sublet (S7::get(), s7_curlet (S7::get()), s7_nil (S7::get())))
        {}
        Env (Env& env)
        : env (s7_sublet (S7::get(), env, s7_nil (S7::get())))
        {}
        template<class T=s7_pointer>
        T eval (const char* s)
        {
            return S7::get().eval<T> (s, this);
        }
        virtual ~~Env ()
        {}
        operator s7_pointer () { return env; }
        void load (const char* path)
        {
            S7& s7 = S7::get();
            if (!s7_load_with_environment (s7, path, env)) {
                sprintf (s7.buff, \"S7::Env::load() : CAN'T FIND %s.\", path);
                throw s7.buff;
            }
        }
    };
    static S7& get ()
    {
        static S7 s7;
        return s7;
    }
    operator s7_scheme* () { return s7; }

    template<class T=s7_pointer>
    T eval (const char* s, S7::Env* env=nullptr);
    const char* eval_as_string (const char* s) {
        s7_pointer s7_ret = s7_eval_c_string (s7, s);
        char* rs = s7_object_to_c_string (s7, s7_ret);
        strcpy (buff, rs);
        free (rs);
        return buff;
    }
    void def_var (const char* name, int val)
    {
        s7_define_variable (s7, name, s7_make_integer (s7, val));
    }
    void def_var (const char* name, double val)
    {
        s7_define_variable (s7, name, s7_make_real (s7, val));
    }
    void def_var (const char* name, const char* val)
    {
        s7_define_variable (s7, name, s7_make_string (s7, val));
    }
    void def_var (const char* name, void* val)
    {
        s7_define_variable (s7, name, s7_make_c_pointer (s7, val));
    }
    void load (const char* path)
    {
        if (!s7_load (s7, path)) {
            sprintf (buff, \"S7::load() : CAN'T FIND %s.\", path);
            throw buff;
        }
    }
    s7_pointer set_err_hook (const char* proc_name);
};

template<>
inline s7_pointer S7::eval (const char* s, S7::Env* env)
{
    return env == nullptr ?
        s7_eval_c_string (s7, s):
        s7_eval_c_string_with_environment (s7, s, *env);
}

template<>
inline const char* S7::eval (const char* s, S7::Env* env)
{
    s7_pointer s7_ret = eval (s, env);
    if (!s7_is_string (s7_ret))
        throw \"S7::eval<const char*>() : NOT STRING\";
    return s7_string (s7_ret);
}

template<>
inline long long S7::eval (const char* s, S7::Env* env)
{
    s7_pointer s7_ret = eval (s, env);
    if (!s7_is_integer (s7_ret))
        throw \"S7::eval<long long>() : NOT INTEGER\";
    return s7_integer (s7_ret);
}

template<>
inline double S7::eval (const char* s, S7::Env* env)
{
    s7_pointer s7_ret = eval (s, env);
    if (!s7_is_real (s7_ret))
        throw \"S7::eval<double>() : NOT DOUBLE\";
    return s7_real (s7_ret);
}

template<>
inline bool S7::eval (const char* s, S7::Env* env)
{
    s7_pointer s7_ret = eval (s, env);
    if (!s7_is_boolean (s7_ret))
        throw \"S7::eval<bool>() : NOT BOOLEAN\";
    return s7_boolean (s7, s7_ret);
}

inline s7_pointer S7::set_err_hook (const char* proc_name)
{
    sprintf (buff, \"\
(set! (hook-functions *error-hook*) ~
  (list (lambda (hook) ~
          (set! (hook 'result) ~
            (%s (apply format #f (hook 'data)) (stacktrace))))))\
\", proc_name);
    return eval (buff);
}

extern \"C\" {
~{~A
~}\
} // extern \"C\"

#endif // S7_WRAP_H
"
    (declare-apis ll)
    (declare-api-methods ll)
    (define-s7-funcs ll)
    (define-s7-wrappers ll)
    ))

(if (not (defined? 'S7WRAP_TEST))
  (s7-wrap *stdout* (read-all)))

これをs7wrap.scmとかそんな名前で保存して、上述したs7の実行ファイルに読み込ませ、出力をC++のヘッダーファイルにリダイレクトする。

cat api.def | ./s7 s7wrap.scm > api.hpp

api.defっていうのは定義ファイルで、以下のようにS式で記述する。

(関数名 戻り値の型 説明文
  (引数名 引数の型 [説明文])
  ...)
...

例：
(hoge int "ほげ"
  (s str "文字列")
  (n real "実数"))
(fuga void "ふが"
  (p ptr))

注意点として関数名および引数名はC++の命名規則に従う。ハイフンとかは使えない。

定義ファイルの型とC++の型は次のように対応する。

bool ... bool
int  ... long long
real ... double
str  ... const char*
ptr  ... void*
atom ... s7_pointer
void ... void

生成されたヘッダーファイルはC++11以降で使える。C++側ではこのファイルだけをインクルードすればいい。この中にはS7というシングルトンのクラスが定義されており、

auto&& s7 = S7::get();
printf ("%lld\n", s7.eval<long long> ("(api_hoge \"fuga\" 0.1)"));

みたいな感じで呼び出すんですなー。ちょっと残念なことに、定義ファイルから生成された関数にはapi_というプレフィックスが強制的についてしまう。

あと当然ながら関数の定義は自分で行わなくてはならない。生成されたS7クラスの中に

// IMPLEMENT BELOW

	void init();
	long long api_hoge (const char* s, double n);
	void api_fuga (void* p);

// IMPLEMENT ABOVE

みたいな部分があるから、ここのを適当な場所で実装する。

#include "api.hpp"

void S7::init() {}

long long S7::api_hoge (const char* s, double n)
{
	return strlen (s) + (int)n;
}

init()ってのは、定数とか独自の型とかを初期化するのに使う。これを実装した場合はmain()とかから呼び出さないといけない。

なお、s7.cのオブジェクトファイルを作るときにはmus-config.hから上述のWITH_MAINって定義を取っ払わないといけない。空のファイルにしてもいいけど、以下はあってもいいような気がする。

WITH_SYSTEM_EXTRAS ... 1 if you want some additional OS-related functions built-in (default is 0)
WITH_C_LOADER ... 1 if you want to be able to load shared object files with load.

#S7クラスの詳しい使い方

・ファイルのロード

S7::get().load (path);

・式の評価（テンプレート引数で戻り値の型を指定)

S7::get().eval<long long> (src);
S7::get().eval<const char*> (src);
S7::get().eval<double> (src);
S7::get().eval<void*> (src);
S7::get().eval<s7_pointer> (src); // デフォルトのテンプレート引数

・グローバル変数の定義（valueにはeval()のテンプレート引数と同じ型が使える）

S7::get().def_var (var_name, value);

・エラーフック

S7::get().set_err_hook (proc_name);

エラーフックで指定する関数は以下のような引数構成のもの。scheme側で定義した関数でもいい。

(on_error void "errrrror hooooook"
  (description str "説明")
  (stack_trace str "スタックトレース"))

この場合のset_err_hookの呼び出しは、

S7::get().set_err_hook ("api_on_error");

あとS7クラスにはchar buff[4096]というメンバ変数があって、これは関数から文字列を返したいときなどに使う。

#S7::Envクラス

s7にはenvironmentという階層化された名前空間の仕組みがあるんだけど、それを抽象化したクラス。これはトップレベルの名前空間を汚さずにスクリプトファイルを実行したい場合などに使える。なおコピー代入禁止だけどmoveには対応。

・生成

auto&& env = S7::Env();
auto&& env_env = S7::Env (env); // 上層のenvironmentを指定

・ファイルのロード

env.load (path);

・式の評価（テンプレート引数で戻り値の型を指定)

env.eval<long long> (src);
env.eval<const char*> (src);
env.eval<double> (src);
env.eval<void*> (src);
S7::get().eval<s7_pointer> (src); // デフォルトのテンプレート引数

#s7をより使いこなす

s7.hを読むと、schemeの関数とCの関数がだいたい一対一で対応しているからすごく分かりやすい。s7wrapはs7のことを全く勉強しないでも使えるけど、例えばコールバックとか独自の型とか、s7により密着した実装を行うのはそれほど難しくないと思う。

s7のC関数を直接呼ぶ場合はs7_schemeっていうs7本体のポインタを引数に取ることが多いんだけど、これはS7クラスの中ではs7っていうメンバ変数で参照する。S7クラスにはs7_schemeへのキャストオペレーターがあるので、*thisでも大丈夫。

またs7_pointerっていうのはアトムのことなんだけど、これはほっとくとGCの対象になってしまうので、アトムをC++側で保持したい場合はロックする必要がある。

s7_int loc = s7_gc_protect (s7, s7p);

解放したい場合は

s7_gc_unprotect_at (s7, loc);

一応これを抽象化したS7::Atomなるクラスを用意している。コピー禁止だけどmoveには対応。代入演算子で上書きもできる。

S7::Atom atom (s7_make_integer (S7::get(), 1));
atom = s7_make_integer (S7::get(), 2);
printf ("%lld\n", s7_integer (atom)); // 2

あとenvironmentを伴うC関数を呼び出したい時は、S7::Envにs7_pointer*へのキャストオペレーターがあるのでそのまま引数に渡せる。

#可変長引数

可変長引数も一応はできる。

(hoge int "hoge"
  (n int "整数")
  rest "残り")

このように定義ファイルで引数の最後にシンボルを置くと、

// IMPLEMENT BELOW

	long long api_hoge (long long n, s7_pointer rest);

// IMPLEMENT ABOVE

みたいな感じで残りの引数を受け取れる。これはリストなので、s7_car()とかs7_cdr()とかで値を取り出せる。

#おわりに

s7wrapは我ながら便利だと思うので、できれば外人さんにも使ってもらいたい。しかし俺の英語力は書く方が幼稚園児レベルなので、紹介するのは難しい。もしs7wrapを気に入ったらぜひ外人さんにもおすすめしてくれ！

いじょう