はじめに
s7にはネイティブのライブラリから関数や変数を動的ロードする仕組み(FFI)があり、POSIX環境であれば利用できる。このためのC++コードをお手軽に自動生成するスクリプトを書いたので、以下にご紹介。
s7のビルド
まずs7の実行ファイルのビルド方法から。以下の公式ページからtarballをダウンロードして、そん中のs7.cとs7.hを取ってくる。
で、同じディレクトリにmus-config.hというファイルを以下のように作成する。
#define WITH_SYSTEM_EXTRAS 1
#define WITH_C_LOADER 1
#define WITH_MAIN 1
コンパイルは以下のようにする。個々のオプションがどういう意味を持っているのかは俺には分からないw
linux:
gcc -O2 -o s7 s7.c -fPIC -shared -lm -ldl -I. -Wl,-export-dynamic
mac:
gcc -O2 -o s7 s7.c -dynamic -bundle -undefined suppress -flat_namespace -lm -ldl -I.
ちなみにwindowsのcygwinとmsys2ではうまく行かんかった(動的ロードが)。androidのtermuxではgccをg++に変えたらなぜかコンパイルできたw
本題
で、以下が本題のスクリプト。ちょっと長いけど。
s7_share.scm
; Copyright (C) 2024 Matsusaki Satoru
; SPDX-License-Identifier: 0BSD
(define (fold f a l)
(let loop ((l l)
(a a))
(if (not (pair? l))
a
(loop (cdr l) (f a (car l))))))
(define (range ini len)
(let loop ((i 0)
(l '()))
(if (= i len)
(reverse l)
(loop (+ i 1) (cons (+ ini i) l)))))
(define (string-find src dst)
(let ((src-len (string-length src))
(dst-len (string-length dst)))
(let loop ((pos 0)
(cnt 0))
(cond
((= cnt dst-len)
(- pos cnt))
((= pos src-len)
-1)
(else
(let ((src-char (string-ref src pos))
(dst-char (string-ref dst cnt)))
(loop (+ pos 1)
(if (eqv? src-char dst-char)
(+ cnt 1)
0))))))))
(define (string-replace str bef aft)
(let ((bef-len (string-length bef)))
(let loop ((str str)
(ret ""))
(let ((pos (string-find str bef)))
(if (< pos 0)
(if (= 0 (string-length ret))
str
(string-append ret str))
(loop
(substring str
(+ pos bef-len)
(string-length str))
(string-append ret
(substring str 0 pos)
aft)))))))
(define (read-all)
(let loop ((r '()))
(let ((l (read)))
(if (eof-object? l)
(reverse r)
(loop (cons l r))))))
(define (expand-types types)
(let ((ret (reverse
(fold (lambda (acc type)
(if (integer? type)
(let ((cnt (- type 1))
(type (car acc)))
(append (make-list cnt type) acc))
(cons type acc)))
'() types))))
(if (null? (cdr ret))
(car ret)
ret)))
(define (get-ret-type types)
(let loop ((types (vector->list types)))
(if (null? types)
#f
(let ((type (car types)))
(if (eq? type '->)
(expand-types (cdr types))
(loop (cdr types)))))))
(define (get-ret-len types)
(let loop ((types (vector->list types)))
(if (null? types)
#f
(let ((type (car types)))
(if (eq? type '->)
(cond
((eq? 'void (cadr types))
0)
((null? (cddr types))
1)
(else
(fold (lambda (acc type)
(+ acc (if (integer? type)
(- type 1)
1)))
1 (cddr types))))
(loop (cdr types)))))))
(define (get-arg-types _types)
(if (eq? 'void (_types 0))
'()
(let loop ((types (vector->list _types))
(ret '()))
(if (null? types)
(reverse ret)
(let ((type (car types)))
(cond
((eq? type '->)
(reverse ret))
((integer? type)
(loop (cdr types)
(let ((cnt (- type 1))
(type (car ret)))
(append (make-list cnt type) ret))))
(else
(loop (cdr types)
(cons (car types)
ret)))))))))
(define (get-cpp-type type obj-types)
(case type
((int) "int64_t")
((real) "double")
((str) "const char*")
((char) "uint8_t")
((bool) "bool")
((ivec) "int64_t*")
((rvec) "double*")
((bvec) "uint8_t*")
((void) "void")
((ptr obj) "void*")
((atom) "s7_pointer")
(else
(let ((id (obj-types type)))
(if id
(format #f "~A*" type)
(error "get-cpp-type(): ~A" type))))))
(define (get-cpp-val val)
(cond
((boolean? val)
(if val "true" "false"))
((char? val)
(char->integer val))
((string? val)
(string-replace (format #f "~S" val) "\n" "\\n"))
(else
val)))
(define (conv-cname name)
(let loop ((l (string->list (symbol->string name)))
(r '()))
(if (null? l)
(list->string (reverse r))
(let ((c (let (( c (car l)))
(if (or (char-alphabetic? c)
(char-numeric? c))
c #\_))))
(loop (cdr l) (cons c r))))))
(define (compile-obj obj-types id call-expr func-type proc-str)
(let ((ret-type (get-ret-type func-type))
(arg-types (get-arg-types func-type))
(args (cdr call-expr))
(args-len (length (cdr call-expr)))
(name (car call-expr)))
(set! (obj-types ret-type) id)
(format *stdout* "
namespace s7share {
static int type_tag_~A = 0; /* E */
static s7_pointer func_~A (s7_scheme *sc, s7_pointer args) { /* A */
~{\
~A /* B */
~}\
try {
~A* obj = [] (s7_scheme *s7~{, ~A~})/* -> ~~A* */ { /* C */
~A\
} (sc~{, arg~A~}); /* D */
return (s7_make_c_object (sc, type_tag_~A, (void *)obj));
} catch (std::exception& e) {
auto type = s7_make_symbol (sc, \"std::exception\");
auto info = s7_list (sc, 1, s7_make_string (sc, e.what()));
s7_error (sc, type, info);
return nullptr;
}
}
static s7_pointer string_~A (s7_scheme *sc, s7_pointer args) { /* F */
void* ptr = s7_c_object_value (s7_car (args));
static char buff [256];
snprintf (buff, sizeof (buff), \"~A(%p)\", ptr);
return s7_make_string (sc, buff);
}
static void free_~A (void *_obj) /* G */
{
auto obj = (~A*)_obj;
delete obj;
}
static bool equal_~A (void *obj1, void *obj2) /* I */
{
return obj1 == obj2;
}
static void init_~A (s7_scheme *s7) { /* J */
type_tag_~A = s7_make_c_type (s7, \"~A\");
s7_c_type_set_free (s7, type_tag_~A, free_~A);
s7_c_type_set_equal (s7, type_tag_~A, equal_~A);
s7_c_type_set_to_string (s7, type_tag_~A, string_~A);
}
} // namespace
"
id ; E
id ; A
(map (lambda (type pos) ; B
(if (eq? type 'atom)
(format #f "\
auto arg~A = s7_car (args);
args = s7_cdr (args);" pos)
(format #f "\
auto _arg~A = s7_car (args);
if (!~A)
return type_error (sc, ~A, \"~A\");
auto arg~A = ~A;
args = s7_cdr (args);"
pos
(case type
((int byte) (format #f "s7_is_integer (_arg~A)" pos))
((real) (format #f "s7_is_real (_arg~A)" pos))
((bool) (format #f "s7_is_boolean (_arg~A)" pos))
((ptr) (format #f "s7_is_c_pointer (_arg~A)" pos))
((char) (format #f "s7_is_character (_arg~A)" pos))
((ivec) (format #f "s7_is_int_vector (_arg~A)" pos))
((rvec) (format #f "s7_is_float_vector (_arg~A)" pos))
((bvec) (format #f "s7_is_byte_vector (_arg~A)" pos))
((obj) (format #f "s7_is_c_object (_arg~A)" pos))
((str) (format #f "s7_is_string (_arg~A)" pos))
(else
(let ((obj-id (obj-types type)))
(if obj-id
(format #f "s7_is_c_object (_arg~A) or !s7_c_object_value_checked (_arg~A, type_tag_~A)"
pos pos obj-id)
(error "arg type: ~A" type)))))
pos type
pos
(case type
((int) (format #f "s7_integer (_arg~A)" pos))
((real) (format #f "s7_real (_arg~A)" pos))
((bool) (format #f "s7_boolean (_arg~A)" pos))
((char) (format #f "s7_character (_arg~A)" pos))
((ivec) (format #f "s7_int_vector_elements (_arg~A)" pos))
((rvec) (format #f "s7_float_vector_elements (_arg~A)" pos))
((bvec) (format #f "s7_byte_vector_elements (_arg~A)" pos))
((str) (format #f "s7_string (_arg~A)" pos))
((ptr) (format #f "s7_c_pointer (_arg~A)" pos))
((obj) (format #f "s7_c_object_value (_arg~A)" pos))
(else
(let ((obj-id (obj-types type)))
(if obj-id
(format #f "(~A*)s7_c_object_value_checked (_arg~A, type_tag_~A)"
type pos obj-id)
(error "arg type: ~A" type)))))
)))
arg-types (range 0 (length arg-types)))
ret-type ; C
(map (lambda (type arg)
(format #f "~A ~A" (get-cpp-type type obj-types) arg))
arg-types args)
proc-str
(range 0 (length args)) ; D
id
id name ; F
id ret-type ; G
id ; I
id id name ; J
id id id id id id
)
(values (list (car call-expr) id 'atom 1 (list->vector arg-types))
name)
))
(define (compile-func obj-types id call-expr func-type proc-str)
(let ((ret-len (get-ret-len func-type))
(ret-type (get-ret-type func-type))
(arg-types (get-arg-types func-type))
(args (cdr call-expr))
(args-len (length (cdr call-expr)))
(name (car call-expr)))
(format *stdout* "
namespace s7share {
static s7_pointer func_~A (s7_scheme *sc, s7_pointer args) { /* A */
~{\
~A /* B */
~}\
try {
~A[] (s7_scheme *s7~{, ~A~})/* -> ~~A */ { /* C */
~A\
} (sc~{, arg~A~})~A; /* D */
~A\
} catch (std::exception& e) {
auto type = s7_make_symbol (sc, \"std::exception\");
auto info = s7_list (sc, 1, s7_make_string (sc, e.what()));
s7_error (sc, type, info);
return nullptr;
}
}}
"
id ; A
(map (lambda (type pos) ; B
(if (eq? type 'atom)
(format #f "\
auto arg~A = s7_car (args);
args = s7_cdr (args);" pos)
(format #f "\
auto _arg~A = s7_car (args);
if (!~A)
return type_error (sc, ~A, \"~A\");
auto arg~A = ~A;
args = s7_cdr (args);"
pos
(case type
((int byte) (format #f "s7_is_integer (_arg~A)" pos))
((real) (format #f "s7_is_real (_arg~A)" pos))
((bool) (format #f "s7_is_boolean (_arg~A)" pos))
((ptr) (format #f "s7_is_c_pointer (_arg~A)" pos))
((char) (format #f "s7_is_character (_arg~A)" pos))
((ivec) (format #f "s7_is_int_vector (_arg~A)" pos))
((rvec) (format #f "s7_is_float_vector (_arg~A)" pos))
((bvec) (format #f "s7_is_byte_vector (_arg~A)" pos))
((obj) (format #f "s7_is_c_object (_arg~A)" pos))
((str) (format #f "s7_is_string (_arg~A)" pos))
(else
(let ((obj-id (obj-types type)))
(if obj-id
(format #f "s7_is_c_object (_arg~A) or !s7_c_object_value_checked (_arg~A, type_tag_~A)"
pos pos obj-id)
(error "arg type: ~A" type)))))
pos type
pos
(case type
((int) "s7_integer (s7_car (args))")
((real) "s7_real (s7_car (args))")
((bool) "s7_boolean (sc, s7_car (args))")
((char) "s7_character (s7_car (args))")
((ivec) "s7_int_vector_elements (s7_car (args))")
((rvec) "s7_float_vector_elements (s7_car (args))")
((bvec) "s7_byte_vector_elements (s7_car (args))")
((str) "s7_string (s7_car (args))")
((ptr) "s7_c_pointer (s7_car (args))")
((obj) "s7_c_object_value (s7_car (args))")
(else
(let ((obj-id (obj-types type)))
(if obj-id
(format #f "(~A*)s7_c_object_value_checked (_arg~A, type_tag_~A)"
type pos obj-id)
(error "arg type: ~A" type)))))
)))
arg-types (range 0 (length arg-types)))
(case ret-len ; C
((0) "")
((1) (if (eq? ret-type 'atom)
"return "
(format #f "return ~A (sc, "
(case ret-type
((int) "s7_make_integer")
((real) "s7_make_real")
((str) "s7_make_string")
((bool) "s7_make_boolean")
((char) "s7_make_character")
((ptr) "s7_make_c_pointer")
(else (error "ret type: ~A" ret-type))))))
(else (format #f "auto [~{ret~A~^, ~}] = " (range 0 ret-len))))
(map (lambda (type arg)
(format #f "~A ~A" (get-cpp-type type obj-types) arg))
arg-types args)
proc-str
(range 0 (length args)) ; D
(if (and (= ret-len 1) (not (eq? ret-type 'atom))) ")" "")
(case ret-len
((0) " return s7_unspecified (sc);\n")
((1) "")
(else (format #f " return s7_values (sc, s7_list (sc, ~A~{, ~A~}));\n"
ret-len (map (lambda (type pos)
(if (eq? type 'atom)
(format #f "ret~A" pos)
(format #f "~A (sc, ret~A)"
(case type
((int) "s7_make_integer")
((real) "s7_make_real")
((str) "s7_make_string")
((bool) "s7_make_boolean")
((char) "s7_make_character")
((ptr) "s7_make_c_pointer")
(else (error "ret type: ~A" type)))
pos)))
ret-type (range 0 ret-len)))))
)
(list name id ret-type ret-len func-type)
))
(let ((obj-types (hash-table)))
(let loop ((ll (read-all))
(tag #f)
(func-id 0)
(funcs '())
(vals '())
(objs '()))
(if (null? ll)
(format *stdout* "
extern \"C\" {
void init_~A (s7_scheme *sc) { /* D */
~{\
~A /* B */
~}
~{\
~A /* C */
~}\
~{\
~A /* E */
~}\
}
} // extern \"C\"
"
tag ; A
(map (lambda (val) ; B
(let ((type (car val))
(name (cadr val))
(val (caddr val)))
(format #f
"s7_define_constant (sc, ~S, ~A);"
(symbol->string name)
(format #f "~A (sc, ~A)"
(case type
((int) "s7_make_integer")
((real) "s7_make_real")
((str) "s7_make_string")
((bool) "s7_make_boolean")
((char) "s7_make_character")
((ptr) "s7_make_c_pointer")
(else (error "val type: ~A" type)))
(get-cpp-val val)))))
vals)
(map (lambda (a) ; C
(call-with-values (lambda () (apply values a))
(lambda (name id ret-type ret-len _types)
(let ((args-len (length (get-arg-types _types))))
(format #f "s7_define_function (sc, ~S, s7share::func_~A, ~A, 0, false, ~S);"
(symbol->string name) id args-len (object->string _types))))))
funcs)
(map (lambda (obj) ; E
(format #f "s7share::init_~A (sc);" obj))
objs)
)
(let ((l (car ll)))
(if (not (pair? l))
(loop (cdr ll) tag func-id funcs vals objs)
(let ((head (car l)))
(case head
((tag)
(let ((tag (cadr l)))
(format *stdout* "\
// ~A
#include <string>
#include <tuple>
#include <sstream>
#include \"s7.h\"
namespace s7share {
static s7_pointer type_error (s7_scheme* sc, int64_t pos, const char* type) {
auto sym = s7_make_symbol (sc, \"s7share\");
std::ostringstream msg;
msg << \"arg:\" << pos << \" is not \" << type << \".\";
auto info = s7_list (sc, 1, s7_make_string (sc, msg.str().c_str()));
s7_error (sc, sym, info);
return nullptr;
}}
" tag)
(loop (cdr ll) tag func-id funcs vals objs)))
((header)
(display (cadr l))
(loop (cdr ll) tag func-id funcs vals objs))
((value val)
(loop (cdr ll) tag func-id funcs (cons (cdr l) vals) objs))
((function func)
(let ((func (apply compile-func obj-types func-id (cdr l))))
(loop (cdr ll) tag (+ 1 func-id) (cons func funcs) vals objs)))
((object obj)
(call-with-values (lambda () (apply compile-obj obj-types func-id (cdr l)))
(lambda (func obj)
(loop (cdr ll) tag (+ 1 func-id) (cons func funcs) vals (cons func-id objs)))))
(else (error "wrong: ~A" l)))))))))
使い方は
cat 定義ファイル | s7 s7share.scm > C++ファイル
定義ファイルについては、まず以下のサンプルを見てくれ。
share_regex.scm
(tag regex)
(header "\
#include <regex>
")
(obj (reg:regex expr) #(str -> std::regex) "\
return new std::regex (expr);
")
(func (reg:match reg str acc func) #(std::regex str atom 2 -> atom) "\
std::cmatch match;
std::regex_search (str, match, *reg);
for (std::csub_match submatch : match) {
s7_pointer str = s7_make_string (s7, submatch.str().c_str());
s7_pointer args = s7_list_nl (s7, 2, str, acc, NULL);
acc = s7_call (s7, func, args);
}
return acc;
")
(val str reg:real-num-expr "[+-]?[0-9]+\\.[0-9]+([eE][+-]?[0-9]+)?")
このように定義ファイルはS式で記述する。
(tag モジュール名)
(header C++文字列)
(object|obj (オブジェクト名 引数...) #(引数型名... -> C++クラス名) C++文字列)
...
(function|func (関数名 引数...) #(引数型名... -> 戻り値型名...) C++文字列)
...
(value|val 型名 定数名 値)
...
object/function/valueは順番通りでなく混在してても大丈夫。あと、valueの値はリテラルでなくシンボルでもよく、この場合はC++の定数ということになる。
型名は以下のようになっている。
int ... int64_t
real ... double
str ... const char*
ivec ... int64_t* (int-vector) (戻り値にできない)
rvec ... double* (float-vector) (戻り値にできない)
bvec ... uint8_t* (byte-vector) (戻り値にできない)
char ... uint8_t
bool ... bool
ptr ... void* (Cポインター)
obj ... void* (C++オブジェクト) (戻り値にできない)
atom ... s7_pointer (保持したい場合はs7_gc_protect/s7_gc_unprotect_atを使う)
void ... void (引数がない時もこの型名を使う。ex. #(void -> int))
C++クラス名 ... C++クラス名* (objectのC++クラス名) (戻り値にできない)
なおサンプルでは引数型名に atom 2 ってあるけど、これはatomが2つ続くことを意味している。あとs7っていうs7_scheme型の変数を参照しているけど、これはthisみたいに暗黙の引数を渡している。
またサンプルにはないけど、戻り値型名も引数型名と同じように複数の型を指定できる。この場合戻り値は多値となり、C++ではタプルを返す。例えばint real 2ならstd::tupleといった具合。
上記サンプルのコンパイルは
cat share_regex.scm | s7 s7_share.scm > regex.cxx
mac:
g++ -O2 -std=c++17 regex.cxx -o regex.so -dynamic -bundle -undefined suppress -flat_namespace
linux:
g++ -O2 -std=c++17 -fPIC regex.cxx -o regex.so -shared
テストのコードは
test_regex.scm
(load "regex.so" (inlet 'init_func 'init_regex))
(let ((reg (reg:regex "([0-9]{4})/([0-9]{2})/([0-9]{2})")))
(display (reverse (reg:match reg "2024/05/11" '() cons)))
(newline))
inletという関数？の2番目の引数を'init_モジュール名とするのがポイント。inletというのが何を意味するのかは俺には分からないw
あと、std::exceptionからの派生クラスの例外はs7の例外に変換される。例えば上記テストの正規表現から綴じ括弧を削除すると
;std::exception ("The expression contained mismatched ( and ).")
; (reg:regex "([0-9]{4})/([0-9]{2})/([...
; test_regex.scm, line 5, position: 89
; (reg:regex "([0-9]{4})/([0-9]{2})/([0-9]{...
などとs7がエラーを表示してくれる。
静的な組み込み
また、生成したC++のファイルは静的に組み込むこともでき、上記サンプルの場合だと
extern "C"
void init_regex (s7_scheme *sc);
適当な場所でこのように宣言し、適当な場所から呼び出せばよい。
おわりに
雑な説明になっちゃったけど、これC++やCのライブラリを取り込むのが滅茶楽になるので、できれば多くの人に使ってもらいたいw
しかしそもそもs7を使っている人はこの地球上に何人いるのであろうか。。
いじょう