開発環境
- OS X Yosemite - Apple, Ubuntu (OS)
- Emacs (CUI)、BBEdit - Bare Bones Software, Inc. (GUI) (Text Editor)
- C (プログラミング言語)
- Clang/LLVM (コンパイラ, Xcode - Apple)
Schemeの処理系(解釈系、評価機、レジスタ計算機を翻訳した命令列中心のより、もう少しC言語の特性を使った書き方をしたもの(label, gotoではなく、関数を呼び出すとか))を少しずつ書き進めてめていくことに。
GLibのHashTableを利用して、データ主導で構文振り分けをするように変更とcond構文の追加。(else節についてはどう実装するか、まだ迷い中。。)
データ主導にして加法的になったから、今後新しい構文を追加してくのが楽になったかも。
参考書籍等
- 計算機プログラムの構造と解釈[第2版]
- Structure and Interpretation of Computer Programs (原書)
- R7RSHomePage – Scheme Working Groups
- Head First C ―頭とからだで覚えるCの基本
- 21st Century C: C Tips from the New School
- プログラミング言語C 第2版 ANSI規格準拠
- プログラミング言語Cアンサー・ブック 第2版
- C実践プログラミング 第3版
kscheme
コード(BBEdit, Emacs)
#pragma once
void ev_application();
#pragma once
void apply_dispatch();
#pragma once
#include "data.h"
extern const data_s assignment_data;
void assignment_print(FILE *stream, data_s in);
void ev_assignment();
#pragma once
#include "data.h"
extern const data_s begin_data;
void begin_print(FILE *stream, data_s in);
void ev_begin();
#pragma once
#include "data.h"
extern const data_s true_data;
extern const data_s false_data;
void boolean_print(FILE *stream, data_s in);
bool is_true(data_s in);
#pragma once
#include "data.h"
extern const data_s cond_data;
void cond_print(FILE *stream, data_s in);
void ev_cond();
#pragma once
#include <glib.h>
#include <gmp.h>
#include <stdbool.h>
#include <stdarg.h>
typedef enum {
/* 基本型 */
PAIR,
EMPTY,
Z,
Q,
R,
SYMBOL,
CHAR,
STRING,
BOOLEAN,
/* 接続 */
FN,
/* primitive_procedure */
PRIMITIVE_PROCEDURE,
PROCEDURE,
/* syntax */
QUOTE,
ASSIGNMENT,
DEFINITION,
IF,
LAMBDA,
BEGIN,
COND,
QUASIQUOTE,
/* 初期化 */
NONE,
/* undefined */
UNDEF,
/* error */
ERROR,
} data_type;
typedef void (*a_fn_type)(void);
typedef union {
int index;
mpz_t z;
mpq_t q;
mpf_t r;
char *symbol;
char ch;
char *str;
bool bln;
a_fn_type fn;
char *proc_name;
} data_u;
typedef struct {
data_type type;
data_u data;
} data_s;
extern GHashTable *data_s_new_fns;
typedef data_s (*data_s_new_fn_type)(char *in);
void check_data_s_new_fn_type(data_s_new_fn_type fn);
#define data_s_new_hash_add(type, fn) \
{ \
check_data_s_new_fn_type(fn); \
g_hash_table_insert(data_s_new_fns, GINT_TO_POINTER(type), fn); \
}
data_s data_s_new(data_type type, char *in);
extern GHashTable *data_s_copy_fns;
typedef data_s (*data_s_copy_fn_type)(data_s in);
void check_data_s_copy_fn_type(data_s_copy_fn_type cf);
#define data_s_copy_hash_add(type, fn) \
{ \
check_data_s_copy_fn_type(fn); \
g_hash_table_insert(data_s_copy_fns, GINT_TO_POINTER(type), fn); \
}
data_s data_s_copy(data_s in);
extern GHashTable *data_s_free_fns;
typedef void (*data_s_free_fn_type)(data_s in);
void check_data_s_free_fn_type(data_s_free_fn_type ff);
#define data_s_free_hash_add(type, fn) \
{ \
check_data_s_free_fn_type(fn); \
g_hash_table_insert(data_s_free_fns, GINT_TO_POINTER(type), fn); \
}
data_s data_s_free(data_s in);
#include <stdio.h>
extern GHashTable *data_s_print_fns;
typedef void (*data_s_print_fn_type)(FILE *stream, data_s in);
void check_data_s_print_fn_type(data_s_print_fn_type fn);
#define data_s_print_hash_add(type, fn) \
{ \
check_data_s_print_fn_type(fn); \
g_hash_table_insert(data_s_print_fns, GINT_TO_POINTER(type), fn); \
}
void data_s_print(FILE *stream, data_s in);
void data_s_fns_init();
#pragma once
#include "data.h"
extern const data_s definition_data;
void definition_print(FILE *stream, data_s in);
void ev_definition();
#pragma once
#include "data.h"
extern const data_s empty_data;
void empty_print(FILE *stream, data_s in);
data_s is_null(data_s in);
#pragma once
#include "data.h"
data_s lookup_variable_value(data_s expr, data_s env);
data_s set_variable_value(data_s var, data_s val, data_s env);
data_s define_variable(data_s var, data_s val, data_s env);
data_s extend_environment(data_s vars, data_s vals, data_s base_env);
extern data_s global_environment;
data_s setup_environment();
#pragma once
#include "data.h"
extern const data_s error_data;
void error_print(FILE *stream, data_s in);
void ev_error();
#pragma once
#include "data.h"
#include <glib.h>
extern data_s expr, env, val, cont, proc, argl, unev;
extern GHashTable *eval_fns;
typedef void (*eval_fn_type)(void);
void check_eval_fn_type(eval_fn_type ef);
#define eval_hash_add(type, fn) \
{ \
check_eval_fn_type(fn); \
g_hash_table_insert(eval_fns, GINT_TO_POINTER(type), fn); \
}
extern int eval_flag;
void eval_dispatch();
void eval_fns_init();
#pragma once
#include "data.h"
#include <stdbool.h>
bool is_self_evaluating(data_s in);
bool is_variable(data_s in);
bool is_tagged_list(data_s in, char *tag);
bool is_quoted(data_s in);
data_s text_of_quotation(data_s in);
bool is_assignment(data_s in);
data_s assignment_variable(data_s in);
data_s assignment_value(data_s in);
bool is_definition(data_s in);
data_s definition_variable(data_s in);
data_s definition_value(data_s in);
bool is_lambda(data_s in);
data_s lambda_parameters(data_s in);
data_s lambda_body(data_s in);
data_s make_lambda(data_s parameters, data_s body);
bool is_if(data_s in);
data_s if_predicate(data_s in);
data_s if_consequent(data_s in);
data_s if_alternative(data_s in);
data_s make_if(data_s predicate, data_s consequent, data_s alternative);
bool is_begin(data_s in);
data_s begin_actions(data_s in);
bool is_last_expr(data_s in);
data_s first_expr(data_s in);
data_s rest_exprs(data_s in);
data_s sequence2expr(data_s in);
data_s make_begin(data_s in);
bool is_application(data_s in);
data_s operator(data_s in);
data_s operands(data_s in);
bool no_operands(data_s in);
data_s first_operand(data_s in);
data_s rest_operands(data_s in);
bool is_cond(data_s in);
data_s cond_clauses(data_s in);
bool is_cond_else_clause(data_s in);
data_s cond_predicate(data_s in);
data_s cond_actions(data_s in);
data_s expand_clauses(data_s in);
#pragma once
void begin_garbage_collection();
#pragma once
#include "data.h"
extern const data_s if_data;
void if_print(FILE *stream, data_s in);
void ev_if();
extern data_s if_sym;
data_s make_if(data_s in1, data_s in2, data_s in3);
#pragma once
#include "data.h"
data_s kread(FILE *in);
#pragma once
#include "data.h"
extern const data_s lambda_data;
void lambda_print(FILE *stream, data_s in);
void ev_lambda();
extern data_s lambda_sym;
data_s make_lambda(data_s in1, data_s in2);
#pragma once
#include "data.h"
extern const int memory_size;
extern data_s *cars;
extern data_s *cdrs;
extern char *markers;
extern int marker_count;
extern data_s root;
data_s car(data_s in);
data_s cdr(data_s in);
data_s set_car(data_s in1, data_s in2);
data_s set_cdr(data_s in1, data_s in2);
extern int marker_count;
extern int free_index;
data_s cons(data_s in1, data_s in2);
data_s set(data_s *in1, data_s in2);
#include <stdarg.h>
data_s list(int args, ...);
data_s append(data_s in1, data_s in2);
data_s caar(data_s in);
data_s cadr(data_s in);
data_s cdar(data_s in);
data_s cddr(data_s in);
data_s caaar(data_s in);
data_s caadr(data_s in);
data_s cadar(data_s in);
data_s caddr(data_s in);
data_s cdaar(data_s in);
data_s cdadr(data_s in);
data_s cddar(data_s in);
data_s cdddr(data_s in);
data_s caaaar(data_s in);
data_s caaadr(data_s in);
data_s caadar(data_s in);
data_s caaddr(data_s in);
data_s cadaar(data_s in);
data_s cadadr(data_s in);
data_s caddar(data_s in);
data_s cadddr(data_s in);
data_s cdaaar(data_s in);
data_s cdaadr(data_s in);
data_s cdadar(data_s in);
data_s cdaddr(data_s in);
data_s cddaar(data_s in);
data_s cddadr(data_s in);
data_s cdddar(data_s in);
data_s cddddr(data_s in);
#pragma once
#include "data.h"
const data_s none_data;
#pragma once
#include "data.h"
data_s is_number(data_s in);
#pragma once
#include "data.h"
data_s number_q_new(char *in);
data_s number_q_copy(data_s in);
void number_q_free(data_s in);
void number_q_print(FILE *stream, data_s in);
bool number_q_eq(data_s in1, data_s in2);
#pragma once
#include "data.h"
data_s number_r_new(char *in);
data_s number_r_copy(data_s in);
void number_r_free(data_s in);
void number_r_print(FILE *stream, data_s in);
bool number_r_eq(data_s in1, data_s in2);
#pragma once
#include "data.h"
data_s number_z_new(char *in);
data_s number_z_copy(data_s in);
void number_z_free(data_s in);
void number_z_print(FILE *stream, data_s in);
bool number_z_eq(data_s in1, data_s in2);
#pragma once
#include "data.h"
/* void pair_free(data_s in); */
void pair_print(FILE *stream, data_s in);
bool pair_eq(data_s in1, data_s in2);
data_s is_pair(data_s in);
#pragma once
#include "data.h"
data_s prim_car(data_s in);
data_s prim_cdr(data_s in);
data_s prim_set_car(data_s in);
data_s prim_set_cdr(data_s in);
data_s prim_cons(data_s in);
/* data_s prim_set(data_s in); */
data_s prim_list(data_s in);
data_s prim_append(data_s in);
data_s prim_caar(data_s in);
data_s prim_cadr(data_s in);
data_s prim_cdar(data_s in);
data_s prim_cddr(data_s in);
data_s prim_caaar(data_s in);
data_s prim_caadr(data_s in);
data_s prim_cadar(data_s in);
data_s prim_caddr(data_s in);
data_s prim_cdaar(data_s in);
data_s prim_cdadr(data_s in);
data_s prim_cddar(data_s in);
data_s prim_cdddr(data_s in);
data_s prim_caaaar(data_s in);
data_s prim_caaadr(data_s in);
data_s prim_caadar(data_s in);
data_s prim_caaddr(data_s in);
data_s prim_cadaar(data_s in);
data_s prim_cadadr(data_s in);
data_s prim_caddar(data_s in);
data_s prim_cadddr(data_s in);
data_s prim_cdaaar(data_s in);
data_s prim_cdaadr(data_s in);
data_s prim_cdadar(data_s in);
data_s prim_cdaddr(data_s in);
data_s prim_cddaar(data_s in);
data_s prim_cddadr(data_s in);
data_s prim_cdddar(data_s in);
data_s prim_cddddr(data_s in);
#pragma once
#include "data.h"
data_s prim_number_add(data_s in);
data_s prim_number_sub(data_s in);
data_s prim_number_mul(data_s in);
data_s prim_number_div(data_s in);
data_s prim_number_eq(data_s in);
data_s prim_number_less_than(data_s in);
#pragma once
#include "data.h"
data_s primitive_procedure_new(char *in);
void primitive_procedure_print(FILE *stream, data_s in);
bool is_primitive_procedure(data_s in);
data_s apply_primitive_procedure(data_s in1, data_s in2);
void prim_proc_init();
#pragma once
#include "data.h"
void procedure_print(FILE *stream, data_s in);
bool is_procedure(data_s in);
data_s make_procedure(data_s param, data_s body, data_s env);
#pragma once
#include "data.h"
void quasiquote_print(FILE *stream, data_s in);
extern const data_s quasiquote_data;
#pragma once
#include "data.h"
void quote_print(FILE *stream, data_s in);
extern const data_s quote_data;
void ev_quoted();
#pragma once
void read_eval_print_loop();
#pragma once
#include "data.h"
bool is_self_evaluating(data_s in);
void ev_self_eval();
#pragma once
void ev_sequence();
#pragma once
#include "data.h"
extern data_s stack;
void save(data_s in);
data_s restore();
void initialize_stack();
void print_statistics();
#include <stdio.h>
#include <stdlib.h> //abort
/** Set this to \c 's' to stop the program on an error.
Otherwise, functions return a value on failure.*/
char error_mode;
/** To where should I write errors? If this is \c NULL, write to \c stderr. */
FILE *error_log;
#define Stopif(assertion, error_action, ...) { \
if (assertion){ \
fprintf(error_log ? error_log : stderr, __VA_ARGS__); \
fprintf(error_log ? error_log : stderr, "\n"); \
if (error_mode=='s') abort(); \
else {error_action;} \
}}
#pragma once
#include "data.h"
data_s string_new(char *in);
data_s string_copy(data_s in);
void string_free(data_s in);
void string_print(FILE *stream, data_s in);
#pragma once
#include "data.h"
extern GHashTable *obarray;
data_s symbol_new(char *in);
void symbol_print(FILE *stream, data_s in);
bool symbol_eq(data_s in1, data_s in2);
data_s is_symbol(data_s in);
#pragma once
#include "data.h"
extern const data_s undef;
void undef_print(FILE *stream, data_s in);
#pragma once
#include "data.h"
bool is_variable(data_s in);
void ev_variable();
#include "application.h"
#include "evaluator.h"
#include "list_operations.h"
#include "stack.h"
static void ev_appl_did_operator();
static void ev_appl_operand_loop();
static void ev_appl_accumulate_arg();
static void ev_appl_last_arg();
static void ev_appl_accum_last_arg();
void ev_application() {
save(env);
unev = data_s_free(unev);
unev = cdr(expr);
save(unev);
expr = car(expr);
eval_dispatch();
ev_appl_did_operator();
}
#include "empty.h"
#include "apply.h"
static void ev_appl_did_operator() {
/* printf("ev_appl_did_operator\n"); */
data_s_free(unev);
unev = restore();
env = restore();
argl = empty_data;
proc = data_s_copy(val);
if (unev.type == EMPTY)
apply_dispatch();
else {
save(proc);
ev_appl_operand_loop();
}
}
static void ev_appl_operand_loop() {
/* printf("ev_appl_operand_loop\n"); */
save(argl);
data_s_free(expr);
expr = car(unev);
if (cdr(unev).type == EMPTY) {
ev_appl_last_arg();
} else {
save(env);
save(unev);
eval_dispatch();
ev_appl_accumulate_arg();
}
}
static void ev_appl_accumulate_arg() {
/* printf("ev_appl_accumulate_arg\n"); */
data_s_free(unev);
unev = restore();
env = restore();
argl = restore();
argl = append(argl, list(1, val));
unev = cdr(unev);
ev_appl_operand_loop();
}
static void ev_appl_last_arg() {
/* printf("ev_appl_last_arg\n"); */
eval_dispatch();
ev_appl_accum_last_arg();
}
static void ev_appl_accum_last_arg() {
/* printf("ev_appl_accum_last_arg\n"); */
argl = restore();
argl = append(argl, list(1, val));
data_s_free(proc);
proc = restore();
apply_dispatch();
}
#include "apply.h"
#include "primitive_procedure.h"
#include "procedure.h"
#include "evaluator.h"
static void primitive_apply();
static void compound_apply();
void apply_dispatch() {
/* printf("apply_dispatch\n"); */
/* printf("proc: "); */
/* data_s_print(stdout, proc); */
/* printf("\n"); */
/* printf("argl: "); */
/* data_s_print(stdout, argl); */
/* printf("\n"); */
if (is_primitive_procedure(proc)) {
primitive_apply();
} else if (is_procedure(proc))
compound_apply();
}
#include "stack.h"
static void primitive_apply() {
data_s_free(val);
val = apply_primitive_procedure(proc, argl);
}
#include "environment.h"
#include "sequence.h"
#include "list_operations.h"
#include "environment.h"
static void compound_apply() {
/* printf("compound_apply\n"); */
unev = data_s_free(unev);
unev = car(proc);
env = caddr(proc);
env = extend_environment(unev, argl, env);
unev = cadr(proc);
ev_sequence();
}
#include "assignment.h"
#include "evaluator.h"
#include "list_operations.h"
#include "stack.h"
const data_s assignment_data = {.type = ASSIGNMENT};
void assignment_print(FILE *stream, data_s in) {
fprintf(stream, "#<syntax set!>");
}
static void f() {}
static void ev_assignment1();
void ev_assignment() {
unev = data_s_free(unev);
unev = cadr(expr);
save(unev);
data_s t = caddr(expr);
expr = data_s_free(expr);
expr = t;
save(env);
/* save(cont); */
/* cont.data.fn = ev_assignment1;変更 */
/* cont.data.fn = f; */
eval_dispatch();
ev_assignment1();
}
#include "environment.h"
static void ev_assignment1() {
/* cont = restore(); */
env = data_s_free(env);
env = restore();
unev = data_s_free(unev);
unev = restore();
set_variable_value(unev, val, env);
/* cont.data.fn(); */
}
#include "begin.h"
const data_s begin_data = {.type=BEGIN};
void begin_print(FILE *stream, data_s in) {
fprintf(stream, "#<syntax begin>");
}
#include "evaluator.h"
#include "list_operations.h"
#include "stack.h"
#include "sequence.h"
void ev_begin() {
data_s_free(unev);
unev = cdr(expr);
ev_sequence();
}
#include "boolean.h"
const data_s true_data = {.type = BOOLEAN, .data.bln = true};
const data_s false_data = {.type = BOOLEAN, .data.bln = false};
void boolean_print(FILE *stream, data_s in) {
if (in.data.bln == true)
fprintf(stream, "#t");
else {
fprintf(stream, "#f");
}
}
bool boolean_eq(data_s in1, data_s in2) { return in1.data.bln == in2.data.bln; }
bool is_true(data_s in) {
return in.type != BOOLEAN || in.data.bln != false ? true : false;
}
#include "cond.h"
const data_s cond_data = {.type = COND};
void cond_print(FILE *stream, data_s in) { fprintf(stream, "#<syntax cond>"); }
#include "evaluator.h"
#include "list_operations.h"
#include "undef.h"
#include "if.h"
#include "symbol.h"
#include "begin.h"
#include "environment.h"
static data_s expand_clauses(data_s in) {
if (in.type == EMPTY)
return undef;
data_s first = car(in);
data_s rest = cdr(in);
data_s t = cdr(first);
if (t.type == EMPTY)
return make_if(car(first), t, expand_clauses(rest));
if (cdr(t).type == EMPTY)
return make_if(car(first), car(t), expand_clauses(rest));
return make_if(car(first), cons(begin_data, t), expand_clauses(rest));
}
static data_s cond2if(data_s in) { return expand_clauses(cdr(in)); }
void ev_cond() {
expr = cond2if(expr);
eval_flag = 1;
}
#include "data.h"
#include "list_operations.h"
#include <stdlib.h>
#include <string.h>
#include <stdio.h>
#include <ctype.h>
GHashTable *data_s_new_fns;
void check_data_s_new_fn_type(data_s_new_fn_type fn) {}
data_s data_s_new(data_type type, char *in) {
data_s_new_fn_type nf =
g_hash_table_lookup(data_s_new_fns, GINT_TO_POINTER(type));
return nf(in);
}
GHashTable *data_s_copy_fns;
void check_data_s_copy_fn_type(data_s_copy_fn_type cf) {}
data_s data_s_copy(data_s in) {
data_s_copy_fn_type cf =
g_hash_table_lookup(data_s_copy_fns, GINT_TO_POINTER(in.type));
if (!cf)
return in;
else
return cf(in);
}
#include "none.h"
GHashTable *data_s_free_fns;
void check_data_s_free_fn_type(data_s_free_fn_type ff) {}
data_s data_s_free(data_s in) {
data_s_free_fn_type ff =
g_hash_table_lookup(data_s_free_fns, GINT_TO_POINTER(in.type));
if (ff)
ff(in);
return none_data;
}
GHashTable *data_s_print_fns;
void check_data_s_print_fn_type(data_s_print_fn_type pf) {}
void data_s_print(FILE *stream, data_s in) {
data_s_print_fn_type pf =
g_hash_table_lookup(data_s_print_fns, GINT_TO_POINTER(in.type));
if (pf)
pf(stream, in);
}
#include "pair.h"
#include "empty.h"
#include "number_z.h"
#include "number_q.h"
#include "number_r.h"
#include "symbol.h"
#include "string.h"
#include "boolean.h"
#include "primitive_procedure.h"
#include "undef.h"
#include "error.h"
#include "quote.h"
#include "assignment.h"
#include "definition.h"
#include "if.h"
#include "lambda.h"
#include "procedure.h"
#include "begin.h"
#include "cond.h"
#include "quasiquote.h"
void data_s_fns_init() {
data_s_new_fns = g_hash_table_new(g_direct_hash, g_direct_equal);
data_s_copy_fns = g_hash_table_new(g_direct_hash, g_direct_equal);
data_s_free_fns = g_hash_table_new(g_direct_hash, g_direct_equal);
data_s_print_fns = g_hash_table_new(g_direct_hash, g_direct_equal);
/* data_s_free_hash_add(PAIR, pair_free); */
data_s_print_hash_add(PAIR, pair_print);
data_s_print_hash_add(EMPTY, empty_print);
data_s_new_hash_add(Z, number_z_new);
data_s_copy_hash_add(Z, number_z_copy);
data_s_free_hash_add(Z, number_z_free);
data_s_print_hash_add(Z, number_z_print);
data_s_new_hash_add(Q, number_q_new);
data_s_copy_hash_add(Q, number_q_copy);
data_s_free_hash_add(Q, number_q_free);
data_s_print_hash_add(Q, number_q_print);
data_s_new_hash_add(R, number_r_new);
data_s_copy_hash_add(R, number_r_copy);
data_s_free_hash_add(R, number_r_free);
data_s_print_hash_add(R, number_r_print);
obarray = g_hash_table_new(g_str_hash, g_str_equal);
data_s_new_hash_add(SYMBOL, symbol_new);
data_s_print_hash_add(SYMBOL, symbol_print);
data_s_new_hash_add(STRING, string_new);
data_s_copy_hash_add(STRING, string_copy);
data_s_free_hash_add(STRING, string_free);
data_s_print_hash_add(STRING, string_print);
data_s_print_hash_add(BOOLEAN, boolean_print);
data_s_new_hash_add(PRIMITIVE_PROCEDURE, primitive_procedure_new);
data_s_print_hash_add(PRIMITIVE_PROCEDURE, primitive_procedure_print);
data_s_print_hash_add(PROCEDURE, procedure_print);
data_s_print_hash_add(UNDEF, undef_print);
data_s_print_hash_add(ERROR, error_print);
/* syntax */
data_s_print_hash_add(QUOTE, quote_print);
data_s_print_hash_add(ASSIGNMENT, assignment_print);
data_s_print_hash_add(DEFINITION, definition_print);
if_sym = data_s_new(SYMBOL, "if");
data_s_print_hash_add(IF, if_print);
lambda_sym = data_s_new(SYMBOL, "lambda");
data_s_print_hash_add(LAMBDA, lambda_print);
data_s_print_hash_add(BEGIN, begin_print);
data_s_print_hash_add(COND, cond_print);
data_s_print_hash_add(QUASIQUOTE, quasiquote_print);
}
#include "definition.h"
const data_s definition_data = {.type = DEFINITION};
void definition_print(FILE *stream, data_s in) {
fprintf(stream, "#<syntax define>");
}
#include "evaluator.h"
#include "stack.h"
#include "list_operations.h"
#include "lambda.h"
static void ev_definition1();
static void f() {}
void ev_definition() {
unev = data_s_free(unev);
data_type type = cadr(expr).type;
unev = type == SYMBOL ? cadr(expr) : caadr(expr);
save(unev);
expr = type == SYMBOL ? caddr(expr) : make_lambda(cdadr(expr), cddr(expr));
save(env);
/* save(cont); */
/* cont.data.fn = ev_definition1; 変更 */
/* cont.data.fn = f; */
eval_dispatch();
ev_definition1();
}
#include "environment.h"
#include "undef.h"
static void ev_definition1() {
/* cont = restore(); */
env = restore();
data_s_free(unev);
unev = restore();
define_variable(unev, val, env);
/* cont.data.fn(); */
}
#include "empty.h"
const data_s empty_data = {.type=EMPTY};
void empty_print(FILE *stream, data_s in) {
fprintf(stream, "()");
}
#include "boolean.h"
data_s is_null(data_s in) {
return in.type == EMPTY ? true_data : false_data;
}
#include "environment.h"
#include "list_operations.h"
#include "symbol.h"
#include "error.h"
data_s lookup_variable_value(data_s var, data_s env) {
while (env.type != EMPTY) {
data_s frame = car(env);
data_s vars = car(frame);
data_s vals = cdr(frame);
while (vars.type != EMPTY) {
if (symbol_eq(var, car(vars)))
return car(vals);
vars = cdr(vars);
vals = cdr(vals);
}
env = cdr(env);
}
fprintf(stderr, "Unbound variable: ");
data_s_print(stderr, var);
return error_data;
}
data_s set_variable_value(data_s var, data_s val, data_s env) {
while (env.type != EMPTY) {
data_s frame = car(env);
data_s vars = car(frame);
data_s vals = cdr(frame);
while (vars.type != EMPTY) {
if (symbol_eq(var, car(vars)))
return set_car(vals, val);
vars = cdr(vars);
vals = cdr(vals);
}
env = cdr(env);
}
fprintf(stderr, "Unbound variable -- SET!: ");
data_s_print(stderr, var);
return error_data;
}
static data_s add_binding_to_frame(data_s var, data_s val, data_s frame) {
set_car(frame, cons(var, car(frame)));
return set_cdr(frame, cons(val, cdr(frame)));
}
data_s define_variable(data_s var, data_s val, data_s env) {
data_s frame = car(env);
data_s vars = car(frame);
data_s vals = cdr(frame);
while (vars.type != EMPTY) {
if (symbol_eq(var, car(vars)))
return set_car(vals, val);
vars = cdr(vars);
vals = cdr(vals);
}
return add_binding_to_frame(var, val, frame);
}
static int length(data_s in) {
int len = 0;
while (in.type != EMPTY) {
len++;
in = cdr(in);
}
return len;
}
data_s extend_environment(data_s vars, data_s vals, data_s base_env) {
int vars_len = length(vars);
int vals_len = length(vals);
if (vars_len == vals_len)
return cons(cons(vars, vals), base_env);
else if (vars_len < vals_len) {
fprintf(stderr, "Too many arguments supplied ");
data_s_print(stderr, vars);
fprintf(stderr, " ");
data_s_print(stderr, vals);
return error_data;
} else {
fprintf(stderr, "Too few arguments supplied ");
data_s_print(stderr, vars);
fprintf(stderr, " ");
data_s_print(stderr, vals);
return error_data;
}
}
data_s global_environment;
#include "empty.h"
#include "quote.h"
#include "boolean.h"
#include "assignment.h"
#include "definition.h"
#include "if.h"
#include "lambda.h"
#include "begin.h"
#include "cond.h"
#include "quasiquote.h"
#include "primitive_procedure.h"
data_s setup_environment() {
data_s frame = cons(empty_data, empty_data);
data_s initial_env = cons(frame, empty_data);
char *syntax_symbols[] = {"quote", "set!", "define", "if",
"lambda", "begin", "cond", "quasiquote"};
data_s ds[] = {quote_data, assignment_data, definition_data,
if_data, lambda_data, begin_data,
cond_data, quasiquote_data};
for (int i = 0; i < 8; i++)
define_variable(data_s_new(SYMBOL, syntax_symbols[i]), ds[i], initial_env);
char *boolean_symbols[] = {"#t", "#f"};
data_s boolean_data[] = {true_data, false_data};
for (int i = 0; i < 2; i++)
define_variable(data_s_new(SYMBOL, boolean_symbols[i]), boolean_data[i],
initial_env);
prim_proc_init();
char *prim_proc_names[] = {
"car", "cdr", "set-car!", "set-cdr", "cons", "list", "append",
"caar", "cadr", "cdar", "cddr", "caaar", "caadr", "cadar",
"caddr", "cdaar", "cdadr", "cddar", "cdddr", "caaaar", "caaadr",
"caadar", "caaddr", "cadaar", "cadadr", "caddar", "cadddr", "cdaaar",
"cdaadr", "cdadar", "cdaddr", "cddaar", "cddadr", "cdddar", "cddddr",
"+", "-", "*", "/", "=", "<"};
for (int i = 0; i < 41; i++)
define_variable(data_s_new(SYMBOL, prim_proc_names[i]),
primitive_procedure_new(prim_proc_names[i]), initial_env);
return initial_env;
}
#include "error.h"
const data_s error_data = {.type=ERROR};
void error_print(FILE *stream, data_s in) {
fprintf(stream, "ERROR");
}
#include "evaluator.h"
#include "repl.h"
void ev_error() {
printf("\n");
data_s_print(stdout, val);
printf("\n");
read_eval_print_loop();
}
#include "evaluator.h"
data_s expr = {.type = NONE};
data_s env = {.type = NONE};
data_s val = {.type = NONE};
data_s cont = {.type = NONE};
data_s proc = {.type = NONE};
data_s argl = {.type = NONE};
data_s unev = {.type = NONE};
GHashTable *eval_fns;
void check_eval_fn_type(eval_fn_type ef) {}
#include "self_evaluating.h"
#include "variable.h"
#include "list_operations.h"
#include "application.h"
#include "environment.h"
int eval_flag;
void eval_dispatch() {
do {
eval_flag = 0;
if (is_self_evaluating(expr)) {
ev_self_eval();
} else if (is_variable(expr))
ev_variable();
else {
data_s t1 = car(expr);
if (t1.type == PAIR) {
ev_application();
} else {
data_s t2 = lookup_variable_value(t1, env);
eval_fn_type ef =
g_hash_table_lookup(eval_fns, GINT_TO_POINTER(t2.type));
data_s_free(t1);
data_s_free(t2);
if (!ef) {
ev_application();
} else {
ef();
}
}
}
} while (eval_flag);
}
#include "quote.h"
#include "assignment.h"
#include "definition.h"
#include "if.h"
#include "lambda.h"
#include "begin.h"
#include "cond.h"
void eval_fns_init() {
eval_fns = g_hash_table_new(g_direct_hash, g_direct_equal);
data_type types[] = {QUOTE, ASSIGNMENT, DEFINITION, IF, COND, LAMBDA, BEGIN};
eval_fn_type fns[] = {ev_quoted, ev_assignment, ev_definition, ev_if,
ev_cond, ev_lambda, ev_begin};
for (int i = 0; i < 7; i++)
eval_hash_add(types[i], fns[i]);
}
#include "expressions.h"
#include "list_operations.h"
extern data_s true_data;
extern data_s false_data;
extern data_s empty_data;
extern data_s error_data;
extern data_s undef;
bool is_self_evaluating(data_s in) {
switch (in.type) {
case Z:
case Q:
case R:
case CHAR:
case STRING:
case BOOL:
return true;
default:
return false;
}
}
bool is_variable(data_s in) { return in.type == SYMBOL; }
bool is_tagged_list(data_s in1, char *s) {
if (in1.type == PAIR) {
data_s t = car(in1);
if (t.type == SYMBOL && strcmp(t.data.symbol, s) == 0)
return true;
}
return false;
}
bool is_quoted(data_s in) { return is_tagged_list(in, "quote"); }
data_s text_of_quotation(data_s in) { return car(cdr(in)); }
bool is_assignment(data_s in) { return is_tagged_list(in, "set!"); }
data_s assignment_variable(data_s in) { return car(cdr(in)); }
data_s assignment_value(data_s in) { return car(cdr(cdr(in))); }
bool is_definition(data_s in) { return is_tagged_list(in, "define"); }
data_s definition_variable(data_s in) {
data_s t = car(cdr(in));
return t.type == SYMBOL ? car(cdr(in)) : car(car(cdr(in)));
}
data_s definition_value(data_s in) {
data_s t = car(cdr(in));
return t.type == SYMBOL ? car(cdr(cdr(in)))
: make_lambda(cdr(car(cdr(in))), cdr(cdr(in)));
}
bool is_lambda(data_s in) { return is_tagged_list(in, "lambda"); }
data_s lambda_parameters(data_s in) { return car(cdr(in)); }
data_s lambda_body(data_s in) { return cdr(cdr(in)); }
data_s lambda;
data_s make_lambda(data_s parameters, data_s body) {
return cons(lambda, cons(parameters, body));
}
bool is_if(data_s in) { return is_tagged_list(in, "if"); }
data_s if_predicate(data_s in) { return car(cdr(in)); }
data_s if_consequent(data_s in) { return car(cdr(cdr(in))); }
data_s if_alternative(data_s in) {
data_s t = cdr(cdr(cdr(in)));
return t.type != EMPTY ? car(cdr(cdr(cdr(in)))) : false_data;
}
data_s make_if(data_s predicate, data_s consequent, data_s alternative) {
data_s if_sym = symbol_new("if");
return cons(if_sym,
cons(predicate, cons(consequent, cons(alternative,
(data_s){.type = EMPTY}))));
}
bool is_begin(data_s in) { return is_tagged_list(in, "begin"); }
data_s begin_actions(data_s in) { return cdr(in); }
bool is_last_expr(data_s in) {
data_s t = cdr(in);
return t.type == EMPTY;
}
data_s first_expr(data_s in) { return car(in); }
data_s rest_exprs(data_s in) { return cdr(in); }
data_s sequence2expr(data_s in) {
if (in.type == EMPTY)
return in;
if (is_last_expr(in))
return first_expr(in);
return make_begin(in);
}
data_s make_begin(data_s in) {
data_s begin = symbol_new("begin");
return cons(begin, in);
}
bool is_application(data_s in) { return in.type == PAIR; }
data_s operator(data_s in) { return car(in); }
data_s operands(data_s in) { return cdr(in); }
bool no_operands(data_s in) { return in.type == EMPTY; }
data_s first_operand(data_s in) { return car(in); }
data_s rest_operands(data_s in) { return cdr(in); }
bool is_cond(data_s in) { return is_tagged_list(in, "cond"); }
data_s cond_clauses(data_s in) { return cdr(in); }
bool is_cond_else_clause(data_s in) {
return is_tagged_list(cond_predicate(in), "else");
}
data_s cond_predicate(data_s in) { return car(in); }
data_s cond_actions(data_s in) { return cdr(in); }
data_s expand_clauses(data_s in) {
if (in.type == EMPTY)
return false_data;
data_s first = car(in), rest = cdr(in);
if (is_cond_else_clause(first)) {
if (rest.type == EMPTY)
return sequence2expr(cond_actions(first));
return error("ELSE clause isn't last -- COND->IF", 1, in);
}
return make_if(cond_predicate(first), sequence2expr(cond_actions(first)),
expand_clauses(rest));
}
#include "garbage_collector.h"
#include "list_operations.h"
#include "evaluator.h"
#include "stack.h"
#include <string.h>
#include <stdlib.h> // exit
static void mark(data_s in);
void begin_garbage_collection() {
data_s t = {.type = PAIR, .data.index = free_index};
data_s root[] = {expr, env, val, cont, proc, argl, unev, stack, t};
marker_count = 0;
memset(markers, 0, sizeof(char) * memory_size);
for (int i = 0; i < 9; i++)
mark(root[i]);
if (marker_count == memory_size) {
fprintf(stderr, "メモリーが不足しています。\n");
exit(0);
}
for (int i = 0; i < memory_size; i++)
if (*(markers + i) == 0) {
*(cars + i) = data_s_free(*(cars + i));
*(cdrs + i) = data_s_free(*(cdrs + i));
}
}
static void mark(data_s in) {
if ((in.type == PAIR || in.type == PROCEDURE) &&
*(markers + in.data.index) == 0) {
marker_count++;
*(markers + in.data.index) = 1;
data_s h = car(in);
mark(h);
data_s t = cdr(in);
mark(t);
}
}
#include "if.h"
const data_s if_data = {.type=IF};
void if_print(FILE *stream, data_s in) {
fprintf(stream, "#<syntax if>");
}
#include "evaluator.h"
#include "stack.h"
#include "list_operations.h"
static void ev_if_decide();
void ev_if() {
save(expr);
save(env);
expr = cadr(expr);
eval_dispatch();
ev_if_decide(); /* 追加 */
}
#include "boolean.h"
static void ev_if_consequent();
static void ev_if_alternative();
static void ev_if_decide() {
env = restore();
expr = data_s_free(expr);
expr = restore();
if (is_true(val))
ev_if_consequent();
else
ev_if_alternative();
}
static data_s if_alternative(data_s in);
static void ev_if_alternative() {
expr = if_alternative(expr);
/* eval_dispatch(); */
eval_flag = 1;
}
static void ev_if_consequent() {
expr = caddr(expr);
/* eval_dispatch(); */
eval_flag = 1;
}
#include "undef.h"
static data_s if_alternative(data_s in) {
data_s t = cdddr(in);
return t.type == EMPTY ? undef : car(t);
}
data_s if_sym;
data_s make_if(data_s in1, data_s in2, data_s in3) {
return list(4, if_sym , in1, in2, in3);
}
#include "kread.h"
#include <stdlib.h> // exit
#include <stdio.h>
#include <ctype.h>
#include <string.h>
#include "list_operations.h"
#include "stopif.h"
#include <errno.h>
static void skip_spaces(FILE *in);
static void skip_line(FILE *in);
static data_s read_pair(FILE *in);
static data_s read_atom(FILE *in);
static data_s read_number(FILE *in);
static data_s read_symbol(FILE *in);
static data_s read_char(FILE *in);
static data_s read_string(FILE *in);
data_s kread(FILE *in) {
data_s out;
skip_spaces(in);
char ch = fgetc(in);
Stopif(ch == EOF && ferror(in), exit(1), "%s", strerror(errno));
if (ch == EOF)
exit(0);
if (ch == ';') {
skip_line(in);
out = kread(in);
} else if (ch == '(') {
out = read_pair(in);
} else {
Stopif(ungetc(ch, in) == EOF && ferror(in), exit(1), "%s", strerror(errno));
out = read_atom(in);
}
return out;
}
static void skip_spaces(FILE *in) {
char ch;
while (isspace(ch = fgetc(in)))
;
Stopif(ungetc(ch, in) == EOF && ferror(in), exit(1), "%s", strerror(errno));
}
static void skip_line(FILE *in) {
char ch;
while ((ch =fgetc(in)) != '\n')
Stopif(ch == EOF && ferror(in), exit(1), "%s", strerror(errno));;
}
#include "empty.h"
static data_s read_pair(FILE *in) {
skip_spaces(in);
char ch = fgetc(in);
Stopif(ch == EOF && ferror(in), exit(1), "%s", strerror(errno));
if (ch == ')')
return empty_data;
Stopif(ungetc(ch, in) == EOF && ferror(in), exit(1), "%s", strerror(errno));
data_s a = kread(in);
skip_spaces(in);
ch = fgetc(in);
Stopif(ch == EOF && ferror(in), exit(1), "%s", strerror(errno));
if (ch == ')')
return cons(a, empty_data);
Stopif(ungetc(ch, in) == EOF && ferror(in), exit(1), "%s", strerror(errno));
Stopif(ungetc('(', in) == EOF && ferror(in), exit(1), "%s", strerror(errno));
return cons(a, kread(in));
}
static data_s read_atom(FILE *in) {
data_s out;
char ch = fgetc(in);
Stopif(ch == EOF && ferror(in), exit(1), "%s", strerror(errno));
char ch1 = '\0';
if (ch == '\'') {
out = kread(in);
out = cons(out, empty_data);
out = cons(data_s_new(SYMBOL, "quote"), out);
} else if (ch == '"')
out = read_string(in);
else if (ch == '#') {
ch = fgetc(in);
Stopif(ch == EOF && ferror(in), exit(1), "%s", strerror(errno));
if (ch == 't')
out = data_s_new(SYMBOL, "#t");
else if (ch == 'f')
out = data_s_new(SYMBOL, "#f");
else if (ch == '\\')
out = read_char(in);
} else if (isdigit(ch)) {
Stopif(ungetc(ch, in) == EOF && ferror(in), exit(1), "%s", strerror(errno));
out = read_number(in);
} else if ((ch == '+' || ch == '-') && isdigit(ch1 = fgetc(in))) {
Stopif(ungetc(ch1, in) == EOF && ferror(in), exit(1), "%s",
strerror(errno));
Stopif(ungetc(ch, in) == EOF && ferror(in), exit(1), "%s",
strerror(errno));
out = read_number(in);
} else {
if (ch1 != '\0')
Stopif(ungetc(ch1, in) == EOF && ferror(in), exit(1), "%s",
strerror(errno));
Stopif(ungetc(ch, in) == EOF && ferror(in), exit(1), "%s", strerror(errno));
out = read_symbol(in);
}
return out;
}
static data_s read_number(FILE *in) {
static int number_size = 1000000;
data_s out;
char s[number_size];
int i = 0;
char ch = fgetc(in);
Stopif(ferror(in), exit(1), "%s", strerror(errno));
s[i] = ch;
i++;
while (isdigit(ch = fgetc(in))) {
s[i] = ch;
i++;
}
if (ch == '.') {
s[i] = ch;
i++;
while (isdigit(ch = fgetc(in))) {
s[i] = ch;
i++;
}
s[i] = '\0';
if (ch == '(' || ch == ')')
Stopif(ungetc(ch, in) == EOF && ferror(in), exit(1), "%s",
strerror(errno));
out = data_s_new(R, s);
} else if (ch == '/') {
s[i] = ch;
i++;
while (isdigit(ch = fgetc(in))) {
s[i] = ch;
i++;
}
s[i] = '\0';
if (ch == '(' || ch == ')')
Stopif(ungetc(ch, in) == EOF && ferror(in), exit(1), "%s",
strerror(errno));
out = data_s_new(Q, s);
} else {
s[i] = '\0';
if (ch == '(' || ch == ')')
Stopif(ungetc(ch, in) == EOF && ferror(in), exit(1), "%s",
strerror(errno));
out = data_s_new(Z, s);
}
return out;
}
#define symbol_size 100
static data_s read_symbol(FILE *in) {
/* static const int symbol_size = 100; */
static char symbol[symbol_size];
int i;
char ch = fgetc(in);
Stopif(ch == EOF && ferror(in), exit(1), "%s", strerror(errno));
for (i = 0; !isspace(ch) && ch != '(' && ch != ')'; i++) {
symbol[i] = ch;
ch = fgetc(in);
Stopif(ch == EOF && ferror(in), exit(1), "%s", strerror(errno));
}
symbol[i] = '\0';
if (ch == '(' || ch == ')')
Stopif(ungetc(ch, in) == EOF && ferror(in), exit(1), "%s", strerror(errno));
data_s out = data_s_new(SYMBOL, symbol);
return out;
}
static data_s read_char(FILE *in) {
data_s out = {.type = CHAR, .data.ch = fgetc(in)};
return out;
}
data_s read_string(FILE *in) {
static int str_size = 1000000;
data_s out;
char str[str_size];
int i = 0;
while (1) {
char ch = fgetc(in);
Stopif(ch == EOF && ferror(in), exit(1), "%s", strerror(errno));
if (ch == '\\') {
str[i] = ch;
i++;
ch = fgetc(in);
Stopif(ch == EOF && ferror(in), exit(1), "%s", strerror(errno));
str[i] = ch;
i++;
} else if (ch == '\"') {
str[i] = '\0';
break;
} else {
str[i] = ch;
i++;
}
}
out = data_s_new(STRING, str);
return out;
}
#include "lambda.h"
const data_s lambda_data = {.type=LAMBDA};
void lambda_print(FILE *stream, data_s in) {
fprintf(stream, "#<syntax lambda>");
}
#include "evaluator.h"
#include "list_operations.h"
#include "procedure.h"
void ev_lambda() {
unev = data_s_free(unev);
unev = cadr(expr);
expr = cddr(expr);
val = data_s_free(val);
val = make_procedure(unev, expr, env);
}
data_s lambda_sym;
data_s make_lambda(data_s in1, data_s in2) {
return cons(lambda_sym, cons(in1, in2));
}
#include "list_operations.h"
/* const int memory_size = 32768; /\* gcc *\/ */
const int memory_size = 15932; /* clang */
data_s *cars;
data_s *cdrs;
char *markers;
data_s car(data_s in) { return data_s_copy(*(cars + in.data.index)); }
data_s cdr(data_s in) { return data_s_copy(*(cdrs + in.data.index)); }
#include "undef.h"
data_s set_car(data_s in1, data_s in2) {
data_s_free(*(cars + in1.data.index));
*(cars + in1.data.index) = data_s_copy(in2);
return undef;
}
data_s set_cdr(data_s in1, data_s in2) {
data_s_free(*(cdrs + in1.data.index));
*(cdrs + in1.data.index) = data_s_copy(in2);
return undef;
}
#include "garbage_collector.h"
int marker_count = 0;
int free_index = 0;
data_s cons(data_s in1, data_s in2) {
*(markers + free_index) += 1;
marker_count++;
data_s out = {.type = PAIR, .data.index = free_index};
*(cars + free_index) = data_s_copy(in1);
*(cdrs + free_index) = data_s_copy(in2);
if (marker_count == memory_size) {
/* printf("garbage_collector start\n"); */
/* printf("%d\n", marker_count); */
begin_garbage_collection();
/* printf("%d\n", marker_count); */
/* printf("garbage_collector stop\n"); */
}
free_index++;
while (1) {
if (free_index == memory_size)
free_index = 0;
if (*(markers + free_index) == 0)
break;
free_index++;
}
return out;
}
#include "undef.h"
data_s set(data_s *in1, data_s in2) {
data_s_free(*in1);
*in1 = data_s_copy(in2);
return undef;
}
#include "empty.h"
data_s list(int args, ...) {
data_s data_array[args];
data_s out = empty_data;
va_list ap;
va_start(ap, args);
for (int i = 0; i < args; i++)
*(data_array + i) = va_arg(ap, data_s);
va_end(ap);
for (int i = args; i > 0; i--) {
out = cons(*(data_array + i - 1), out);
}
return out;
}
data_s append(data_s in1, data_s in2) {
if (in1.type == EMPTY)
return in2;
return cons(car(in1), append(cdr(in1), in2));
}
data_s caar(data_s in) { return car(car(in)); }
data_s cadr(data_s in) { return car(cdr(in)); }
data_s cdar(data_s in) { return cdr(car(in)); }
data_s cddr(data_s in) { return cdr(cdr(in)); }
data_s caaar(data_s in) { return car(car(car(in))); }
data_s caadr(data_s in) { return car(car(cdr(in))); }
data_s cadar(data_s in) { return car(cdr(car(in))); }
data_s caddr(data_s in) { return car(cdr(cdr(in))); }
data_s cdaar(data_s in) { return cdr(car(car(in))); }
data_s cdadr(data_s in) { return cdr(car(cdr(in))); }
data_s cddar(data_s in) { return cdr(cdr(car(in))); }
data_s cdddr(data_s in) { return cdr(cdr(cdr(in))); }
data_s caaaar(data_s in) { return car(car(car(car(in)))); }
data_s caaadr(data_s in) { return car(car(car(cdr(in)))); }
data_s caadar(data_s in) { return car(car(cdr(car(in)))); }
data_s caaddr(data_s in) { return car(car(cdr(cdr(in)))); }
data_s cadaar(data_s in) { return car(cdr(car(car(in)))); }
data_s cadadr(data_s in) { return car(cdr(car(cdr(in)))); }
data_s caddar(data_s in) { return car(cdr(cdr(car(in)))); }
data_s cadddr(data_s in) { return car(cdr(cdr(cdr(in)))); }
data_s cdaaar(data_s in) { return cdr(car(car(car(in)))); }
data_s cdaadr(data_s in) { return cdr(car(car(cdr(in)))); }
data_s cdadar(data_s in) { return cdr(car(cdr(car(in)))); }
data_s cdaddr(data_s in) { return cdr(car(cdr(cdr(in)))); }
data_s cddaar(data_s in) { return cdr(cdr(car(car(in)))); }
data_s cddadr(data_s in) { return cdr(cdr(car(cdr(in)))); }
data_s cdddar(data_s in) { return cdr(cdr(cdr(car(in)))); }
data_s cddddr(data_s in) { return cdr(cdr(cdr(cdr(in)))); }
#include "data.h"
#include "list_operations.h"
#include "stack.h"
#include <string.h>
#include "environment.h"
#include "evaluator.h"
#include "repl.h"
int main(int args, char *argv[]) {
data_s memory[2][memory_size];
cars = memory[0];
cdrs = memory[1];
char memory_markers[memory_size];
memset(memory_markers, 0, sizeof(memory_markers));
markers = memory_markers;
data_s_fns_init();
global_environment = setup_environment();
eval_fns_init();
read_eval_print_loop();
}
#include "none.h"
const data_s none_data = {.type=NONE};
#include "number.h"
#include <gmp.h>
#include "boolean.h"
data_s is_number(data_s in) {
return in.type == Z || in.type == Q || in.type == R ? true_data : false_data;
}
#include "number_q.h"
#include <gmp.h>
data_s number_q_new(char *in) {
data_s out = {.type=Q};
mpq_init(out.data.q);
mpq_set_str(out.data.q, in, 10);
return out;
}
data_s number_q_copy(data_s in) {
data_s out = {.type=Q};
mpq_set(out.data.q, in.data.q);
return out;
}
void number_q_free(data_s in) {
mpq_clear(in.data.q);
}
#include <stdio.h>
void number_q_print(FILE *stream, data_s in) {
mpq_canonicalize(in.data.q);
mpq_out_str(stream, 10, in.data.q);
}
bool number_q_eq(data_s in1, data_s in2) {
return mpq_equal(in1.data.q, in2.data.q);
}
#include "number_r.h"
#include <gmp.h>
data_s number_r_new(char *in) {
data_s out = {.type=R};
mpf_init_set_str(out.data.r, in, 10);
return out;
}
data_s number_r_copy(data_s in) {
data_s out = {.type=R};
mpf_init_set(out.data.r, in.data.r);
return out;
}
void number_r_free(data_s in) {
mpf_clear(in.data.r);
}
void number_r_print(FILE *stream, data_s in) {
mpf_out_str(stream, 10, 0, in.data.r);
}
bool number_r_eq(data_s in1, data_s in2) {
return mpf_cmp(in1.data.r, in2.data.r) == 0;
}
#include "number_z.h"
#include <gmp.h>
#include "stopif.h"
data_s number_z_new(char *in) {
data_s out = {.type=Z};
Stopif(mpz_init_set_str(out.data.z, in, 10) == -1,
exit(1),
"整数割り当て失敗");
return out;
}
data_s number_z_copy(data_s in) {
data_s out = {.type=Z};
mpz_init_set(out.data.z, in.data.z);
return out;
}
void number_z_free(data_s in) {
mpz_clear(in.data.z);
}
void number_z_print(FILE *stream, data_s in) {
mpz_out_str(stream, 10, in.data.z);
}
bool number_z_eq(data_s in1, data_s in2) {
return mpz_cmp(in1.data.z, in2.data.z) == 0;
}
#include "pair.h"
#include "list_operations.h"
/* void pair_free(data_s in) { */
/* int i = in.data.index; */
/* data_s_free(*(cars + i)); */
/* data_s_free(*(cdrs + i)); */
/* } */
static void pair_print_inner(FILE *stream, data_s in, int flag) {
if (flag)
fprintf(stream, "(");
int i = in.data.index;
data_s h = *(cars + i);
if (h.type == PAIR)
pair_print_inner(stream, h, 1);
else
data_s_print(stream, h);
data_s t = *(cdrs + i);
if (t.type == EMPTY)
fprintf(stream, ")");
else if (t.type == PAIR) {
fprintf(stream, " ");
pair_print_inner(stream, t, 0);
} else {
fprintf(stream, " . ");
data_s_print(stream, t);
fprintf(stream, ")");
}
}
void pair_print(FILE *stream, data_s in) { pair_print_inner(stream, in, 1); }
bool pair_eq(data_s in1, data_s in2) {
return in1.data.index == in2.data.index;
}
#include "prim_list_procedures.h"
#include "list_operations.h"
data_s prim_car(data_s in) { return car(car(in)); }
data_s prim_cdr(data_s in) { return cdr(car(in)); }
data_s prim_set_car(data_s in) { return set_car(car(in), cadr(in)); }
data_s prim_set_cdr(data_s in) { return set_cdr(car(in), cadr(in)); }
data_s prim_cons(data_s in) { return cons(car(in), cadr(in)); }
static int length(data_s in) {
int len = 0;
while (in.type != EMPTY) {
len++;
in = cdr(in);
}
return len;
}
#include "empty.h"
data_s prim_list(data_s in) {
int len = length(in);
data_s data_array[len];
for (int i = 0; i < len; i++) {
*(data_array + i) = car(in);
in = cdr(in);
}
data_s out = empty_data;
for (int i = len; i > 0; i--)
out = cons(*(data_array + i - 1), out);
return out;
}
data_s prim_append(data_s in) { return append(car(in), cadr(in)); }
data_s prim_caar(data_s in) { return car(car(in)); }
data_s prim_cadr(data_s in) { return car(cdr(in)); }
data_s prim_cdar(data_s in) { return cdr(car(in)); }
data_s prim_cddr(data_s in) { return cdr(cdr(in)); }
data_s prim_caaar(data_s in) { return car(car(car(in))); }
data_s prim_caadr(data_s in) { return car(car(cdr(in))); }
data_s prim_cadar(data_s in) { return car(cdr(car(in))); }
data_s prim_caddr(data_s in) { return car(cdr(cdr(in))); }
data_s prim_cdaar(data_s in) { return cdr(car(car(in))); }
data_s prim_cdadr(data_s in) { return cdr(car(cdr(in))); }
data_s prim_cddar(data_s in) { return cdr(cdr(car(in))); }
data_s prim_cdddr(data_s in) { return cdr(cdr(cdr(in))); }
data_s prim_caaaar(data_s in) { return car(car(car(car(in)))); }
data_s prim_caaadr(data_s in) { return car(car(car(cdr(in)))); }
data_s prim_caadar(data_s in) { return car(car(cdr(car(in)))); }
data_s prim_caaddr(data_s in) { return car(car(cdr(cdr(in)))); }
data_s prim_cadaar(data_s in) { return car(cdr(car(car(in)))); }
data_s prim_cadadr(data_s in) { return car(cdr(car(cdr(in)))); }
data_s prim_caddar(data_s in) { return car(cdr(cdr(car(in)))); }
data_s prim_cadddr(data_s in) { return car(cdr(cdr(cdr(in)))); }
data_s prim_cdaaar(data_s in) { return cdr(car(car(car(in)))); }
data_s prim_cdaadr(data_s in) { return cdr(car(car(cdr(in)))); }
data_s prim_cdadar(data_s in) { return cdr(car(cdr(car(in)))); }
data_s prim_cdaddr(data_s in) { return cdr(car(cdr(cdr(in)))); }
data_s prim_cddaar(data_s in) { return cdr(cdr(car(car(in)))); }
data_s prim_cddadr(data_s in) { return cdr(cdr(car(cdr(in)))); }
data_s prim_cdddar(data_s in) { return cdr(cdr(cdr(car(in)))); }
data_s prim_cddddr(data_s in) { return cdr(cdr(cdr(cdr(in)))); }
#include "prim_number_procedures.h"
#include "list_operations.h"
#include <gmp.h>
static data_s number_add(data_s in1, data_s in2);
static data_s number_sub(data_s in1, data_s in2);
static data_s number_mul(data_s in1, data_s in2);
static data_s number_div(data_s in1, data_s in2);
static data_s number_eq(data_s in1, data_s in2);
static data_s number_less_than(data_s in1, data_s in2);
data_s prim_number_add(data_s in) { return number_add(car(in), car(cdr(in))); }
data_s prim_number_sub(data_s in) { return number_sub(car(in), car(cdr(in))); }
data_s prim_number_mul(data_s in) { return number_mul(car(in), car(cdr(in))); }
data_s prim_number_div(data_s in) { return number_div(car(in), car(cdr(in))); }
data_s prim_number_eq(data_s in) { return number_eq(car(in), car(cdr(in))); }
data_s prim_number_less_than(data_s in) {
return number_less_than(car(in), car(cdr(in)));
}
#include "error.h"
static data_s number_add(data_s in1, data_s in2) {
data_s out;
if (in1.type == Z) {
if (in2.type == Z) {
out.type = Z;
mpz_init(out.data.z);
mpz_add(out.data.z, in1.data.z, in2.data.z);
} else if (in2.type == Q) {
out.type = Q;
mpq_init(out.data.q);
mpq_t x;
mpq_init(x);
mpq_set_z(x, in1.data.z);
mpq_add(out.data.q, x, in2.data.q);
mpq_clear(x);
} else if (in2.type == R) {
out.type = R;
mpf_init(out.data.r);
mpf_t x;
mpf_init(x);
mpf_set_z(x, in1.data.z);
mpf_add(out.data.r, x, in2.data.r);
mpf_clear(x);
} else {
out = error_data;
}
} else if (in1.type == Q) {
if (in2.type == Z)
out = number_add(in2, in1);
else if (in2.type == Q) {
out.type = Q;
mpq_init(out.data.q);
mpq_add(out.data.q, in1.data.q, in2.data.q);
} else if (in2.type == R) {
out.type = R;
mpf_init(out.data.r);
mpf_t x;
mpf_init(x);
mpf_set_q(x, in1.data.q);
mpf_add(out.data.r, x, in2.data.r);
mpf_clear(x);
} else
out = error_data;
} else if (in1.type == R) {
if (in2.type == Z)
out = number_add(in2, in1);
else if (in2.type == Q)
out = number_add(in2, in1);
else if (in2.type == R) {
out.type = R;
mpf_init(out.data.r);
mpf_add(out.data.r, in1.data.r, in2.data.r);
} else
out = error_data;
} else
out = error_data;
return out;
}
static data_s number_sub(data_s in1, data_s in2) {
data_s out;
if (in1.type == Z) {
if (in2.type == Z) {
out.type = Z;
mpz_init(out.data.z);
mpz_sub(out.data.z, in1.data.z, in2.data.z);
} else if (in2.type == Q) {
out.type = Q;
mpq_init(out.data.q);
mpq_t x;
mpq_init(x);
mpq_set_z(x, in1.data.z);
mpq_sub(out.data.q, x, in2.data.q);
mpq_clear(x);
} else if (in2.type == R) {
out.type = R;
mpf_init(out.data.r);
mpf_t x;
mpf_init(x);
mpf_set_z(x, in1.data.z);
mpf_sub(out.data.r, x, in2.data.r);
mpf_clear(x);
} else {
out = error_data;
}
} else if (in1.type == Q) {
if (in2.type == Z) {
out.type = Q;
mpq_init(out.data.q);
mpq_t x;
mpq_init(x);
mpq_set_z(x, in2.data.z);
mpq_sub(out.data.q, in1.data.q, x);
mpq_clear(x);
} else if (in2.type == Q) {
out.type = Q;
mpq_init(out.data.q);
mpq_sub(out.data.q, in1.data.q, in2.data.q);
} else if (in2.type == R) {
out.type = R;
mpf_init(out.data.r);
mpf_t x;
mpf_init(x);
mpf_set_q(x, in1.data.q);
mpf_sub(out.data.r, x, in2.data.r);
mpf_clear(x);
} else {
out = error_data;
}
} else if (in1.type == R) {
out.type = R;
mpf_init(out.data.r);
if (in2.type == Z) {
mpf_t x;
mpf_init(x);
mpf_set_z(x, in2.data.z);
mpf_sub(out.data.r, in1.data.r, x);
mpf_clear(x);
} else if (in2.type == Q) {
mpf_t x;
mpf_init(x);
mpf_set_q(x, in2.data.q);
mpf_sub(out.data.r, in1.data.r, x);
mpf_clear(x);
} else if (in2.type == R) {
mpf_sub(out.data.r, in1.data.r, in2.data.r);
} else {
out = error_data;
}
} else {
out = error_data;
}
return out;
}
static data_s number_mul(data_s in1, data_s in2) {
data_s out;
if (in1.type == Z) {
if (in2.type == Z) {
out.type = Z;
mpz_init(out.data.z);
mpz_mul(out.data.z, in1.data.z, in2.data.z);
} else if (in2.type == Q) {
out.type = Q;
mpq_init(out.data.q);
mpq_t x;
mpq_init(x);
mpq_set_z(x, in1.data.z);
mpq_mul(out.data.q, x, in2.data.q);
mpq_clear(x);
} else if (in2.type == R) {
out.type = R;
mpf_init(out.data.r);
mpf_t x;
mpf_init(x);
mpf_set_z(x, in1.data.z);
mpf_mul(out.data.r, x, in2.data.r);
mpf_clear(x);
} else {
out = error_data;
}
} else if (in1.type == Q) {
if (in2.type == Z)
out = number_mul(in2, in1);
else if (in2.type == Q) {
out.type = Q;
mpq_init(out.data.q);
mpq_mul(out.data.q, in1.data.q, in2.data.q);
} else if (in2.type == R) {
out.type = R;
mpf_init(out.data.r);
mpf_t x;
mpf_init(x);
mpf_set_q(x, in1.data.q);
mpf_mul(out.data.r, x, in2.data.r);
mpf_clear(x);
} else
out = error_data;
} else if (in1.type == R) {
if (in2.type == Z)
out = number_mul(in2, in1);
else if (in2.type == Q)
out = number_mul(in2, in1);
else if (in2.type == R) {
out.type = R;
mpf_init(out.data.r);
mpf_mul(out.data.r, in1.data.r, in2.data.r);
} else
out = error_data;
} else
out = error_data;
return out;
}
static data_s number_div(data_s in1, data_s in2) {
data_s out;
if (in1.type == Z) {
if (in2.type == Z) {
out.type = Q;
mpq_init(out.data.q);
mpq_t x, y;
mpq_init(x);
mpq_init(y);
mpq_set_z(x, in1.data.z);
mpq_set_z(y, in2.data.z);
mpq_div(out.data.q, x, y);
mpq_clear(x);
mpq_clear(y);
} else if (in2.type == Q) {
out.type = Q;
mpq_init(out.data.q);
mpq_t x;
mpq_init(x);
mpq_set_z(x, in1.data.z);
mpq_div(out.data.q, x, in2.data.q);
mpq_clear(x);
} else if (in2.type == R) {
out.type = R;
mpf_init(out.data.r);
mpf_t x;
mpf_init(x);
mpf_set_z(x, in1.data.z);
mpf_div(out.data.r, x, in2.data.r);
mpf_clear(x);
} else {
out = error_data;
}
} else if (in1.type == Q) {
if (in2.type == Z) {
out.type = Q;
mpq_init(out.data.q);
mpq_t x;
mpq_init(x);
mpq_set_z(x, in2.data.z);
mpq_div(out.data.q, in1.data.q, x);
mpq_clear(x);
} else if (in2.type == Q) {
out.type = Q;
mpq_init(out.data.q);
mpq_div(out.data.q, in1.data.q, in2.data.q);
} else if (in2.type == R) {
out.type = R;
mpf_init(out.data.r);
mpf_t x;
mpf_init(x);
mpf_set_q(x, in1.data.q);
mpf_div(out.data.r, x, in2.data.r);
mpf_clear(x);
} else {
out = error_data;
}
} else if (in1.type == R) {
out.type = R;
mpf_init(out.data.r);
if (in2.type == Z) {
mpf_t x;
mpf_init(x);
mpf_set_z(x, in2.data.z);
mpf_div(out.data.r, in1.data.r, x);
mpf_clear(x);
} else if (in2.type == Q) {
mpf_t x;
mpf_init(x);
mpf_set_q(x, in2.data.q);
mpf_div(out.data.r, in1.data.r, x);
mpf_clear(x);
} else if (in2.type == R) {
mpf_div(out.data.r, in1.data.r, in2.data.r);
} else {
out = error_data;
}
} else {
out = error_data;
}
return out;
}
#include "boolean.h"
static data_s number_eq(data_s in1, data_s in2) {
data_s out;
if (in1.type == Z) {
if (in2.type == Z) {
out = mpz_cmp(in1.data.z, in2.data.z) == 0 ? true_data : false_data;
} else if (in2.type == Q) {
mpq_t x;
mpq_init(x);
mpq_set_z(x, in1.data.z);
out = mpq_equal(x, in2.data.q) != 0 ? true_data : false_data;
mpq_clear(x);
} else if (in2.type == R) {
mpf_t x;
mpf_init(x);
mpf_set_z(x, in1.data.z);
out = mpf_cmp(x, in2.data.r) == 0 ? true_data : false_data;
mpf_clear(x);
} else {
out = error_data;
}
} else if (in1.type == Q) {
if (in2.type == Z)
out = number_eq(in2, in1);
else if (in2.type == Q) {
out = mpq_equal(in1.data.q, in2.data.q) != 0 ? true_data : false_data;
} else if (in2.type == R) {
mpf_t x;
mpf_init(x);
mpf_set_q(x, in1.data.q);
out = mpf_cmp(x, in2.data.r) == 0 ? true_data : false_data;
mpf_clear(x);
} else
out = error_data;
} else if (in1.type == R) {
if (in2.type == Z)
out = number_eq(in2, in1);
else if (in2.type == Q)
out = number_eq(in2, in1);
else if (in2.type == R) {
out = mpf_cmp(in1.data.r, in2.data.r) == 0 ? true_data : false_data;
} else
out = error_data;
} else
out = error_data;
return out;
}
static data_s number_less_than(data_s in1, data_s in2) {
data_s out;
if (in1.type == Z) {
if (in2.type == Z) {
out = mpz_cmp(in1.data.z, in2.data.z) < 0 ? true_data : false_data;
} else if (in2.type == Q) {
mpq_t x;
mpq_init(x);
mpq_set_z(x, in1.data.z);
out = mpq_cmp(x, in2.data.q) < 0 ? true_data : false_data;
mpq_clear(x);
} else if (in2.type == R) {
mpf_t x;
mpf_init(x);
mpf_set_z(x, in1.data.z);
out = mpf_cmp(x, in2.data.r) < 0 ? true_data : false_data;
mpf_clear(x);
} else {
out = error_data;
}
} else if (in1.type == Q) {
if (in2.type == Z) {
mpq_t x;
mpq_init(x);
mpq_set_z(x, in2.data.z);
out = mpq_cmp(in1.data.q, x) < 0 ? true_data : false_data;
mpq_clear(x);
} else if (in2.type == Q) {
out = mpq_cmp(in1.data.q, in2.data.q) < 0 ? true_data : false_data;
} else if (in2.type == R) {
mpf_t x;
mpf_init(x);
mpf_set_q(x, in1.data.q);
out = mpf_cmp(x, in2.data.r) < 0 ? true_data : false_data;
mpf_clear(x);
} else {
out = error_data;
}
} else if (in1.type == R) {
if (in2.type == Z) {
mpf_t x;
mpf_init(x);
mpf_set_z(x, in2.data.z);
out = mpf_cmp(in1.data.r, x) < 0 ? true_data : false_data;
mpf_clear(x);
} else if (in2.type == Q) {
mpf_t x;
mpf_init(x);
mpf_set_q(x, in2.data.q);
out = mpf_cmp(in1.data.r, x) < 0 ? true_data : false_data;
mpf_clear(x);
} else if (in2.type == R) {
out = mpf_cmp(in1.data.r, in2.data.r) < 0 ? true_data : false_data;
} else {
out = error_data;
}
} else {
out = error_data;
}
return out;
}
#include "primitive_procedure.h"
#include <string.h>
data_s primitive_procedure_new(char *in) {
return (data_s){.type = PRIMITIVE_PROCEDURE, .data.proc_name = strdup(in)};
}
void primitive_procedure_print(FILE *stream, data_s in) {
fprintf(stream, "#<primitive-procedure %s>", in.data.proc_name);
}
bool is_primitive_procedure(data_s in) {
return in.type == PRIMITIVE_PROCEDURE;
}
static GHashTable *prim_procs;
typedef data_s (*prim_proc_type)(data_s);
static void check_prim_proc_type(prim_proc_type pp) {}
#define prim_proc_hash_add(name, fn) \
{ \
check_prim_proc_type(fn); \
g_hash_table_insert(prim_procs, name, fn); \
}
data_s apply_primitive_procedure(data_s in1, data_s in2) {
prim_proc_type pp = g_hash_table_lookup(prim_procs, in1.data.proc_name);
return pp(in2);
}
#include "prim_list_procedures.h"
#include "prim_number_procedures.h"
void prim_proc_init() {
prim_procs = g_hash_table_new(g_str_hash, g_str_equal);
prim_proc_hash_add("car", prim_car);
prim_proc_hash_add("cdr", prim_cdr);
prim_proc_hash_add("set-car!", prim_set_car);
prim_proc_hash_add("set-cdr", prim_set_cdr);
prim_proc_hash_add("cons", prim_cons);
prim_proc_hash_add("list", prim_list);
prim_proc_hash_add("append", prim_append);
prim_proc_hash_add("caar", prim_caar);
prim_proc_hash_add("cadr", prim_cadr);
prim_proc_hash_add("cdar", prim_cdar);
prim_proc_hash_add("cddr", prim_cddr);
prim_proc_hash_add("caar", prim_caar);
prim_proc_hash_add("cadr", prim_cadr);
prim_proc_hash_add("cdar", prim_cdar);
prim_proc_hash_add("cddr", prim_cddr);
prim_proc_hash_add("caaaar", prim_caaaar);
prim_proc_hash_add("caaadr", prim_caaadr);
prim_proc_hash_add("caadar", prim_caadar);
prim_proc_hash_add("caaddr", prim_caaddr);
prim_proc_hash_add("cadaar", prim_cadaar);
prim_proc_hash_add("cadadr", prim_cadadr);
prim_proc_hash_add("caddar", prim_caddar);
prim_proc_hash_add("cadddr", prim_cadddr);
prim_proc_hash_add("cdaaar", prim_cdaaar);
prim_proc_hash_add("cdaadr", prim_cdaadr);
prim_proc_hash_add("cdadar", prim_cdadar);
prim_proc_hash_add("cdaddr", prim_cdaddr);
prim_proc_hash_add("cddaar", prim_cddaar);
prim_proc_hash_add("cddadr", prim_cddadr);
prim_proc_hash_add("cdddar", prim_cdddar);
prim_proc_hash_add("cddddr", prim_cddddr);
prim_proc_hash_add("+", prim_number_add);
prim_proc_hash_add("-", prim_number_sub);
prim_proc_hash_add("*", prim_number_mul);
prim_proc_hash_add("/", prim_number_div);
prim_proc_hash_add("=", prim_number_eq);
prim_proc_hash_add("<", prim_number_less_than);
}
#include "procedure.h"
#include "list_operations.h"
void procedure_print(FILE *stream, data_s in) {
fprintf(stream, "#<procedure ");
data_s_print(stream, car(in));
fprintf(stream, " ");
data_s_print(stream, cadr(in));
fprintf(stream, ">");
}
bool is_procedure(data_s in) {
return in.type == PROCEDURE ? true : false;
}
data_s make_procedure(data_s param, data_s body, data_s env) {
data_s out = list(3, param, body, env);
out.type = PROCEDURE;
return out;
}
#include "quasiquote.h"
void quasiquote_print(FILE *stream, data_s in) {
fprintf(stream, "#<syntax quasiquote>");
}
const data_s quasiquote_data = {.type = QUASIQUOTE};
#include "quote.h"
#include "evaluator.h"
#include "list_operations.h"
void quote_print(FILE *stream, data_s in) {
fprintf(stream, "#<syntax quote>");
}
const data_s quote_data = {.type = QUOTE};
void ev_quoted() {
data_s_free(val);
val = data_s_copy(cadr(expr));
/* cont.data.fn(); */
}
#include "repl.h"
#include "stack.h"
#include "kread.h"
#include "evaluator.h"
#include "environment.h"
#include "data.h"
static void print_result();
static void f() {}
void read_eval_print_loop() {
while (1) {
initialize_stack();
printf("kscm> ");
expr = data_s_free(expr);
expr = kread(stdin);
env = global_environment;
/* cont.data.fn = print_result; 変更 */
/* cont.data.fn = f; */
eval_dispatch(); /* 追加 */
print_result();
}
}
static void print_result() {
data_s_print(stdout, val);
printf("\n");
/* read_eval_print_loop(); */
}
#include "self_evaluating.h"
#include "evaluator.h"
bool is_self_evaluating(data_s in) {
data_type type = in.type;
return type == STRING || type == Z || type == Q || type == R;
}
void ev_self_eval() {
val = data_s_free(val);
val = data_s_copy(expr);
}
#include "sequence.h"
static void ev_sequence_cont();
#include "evaluator.h"
#include "data.h"
#include "list_operations.h"
#include "stack.h"
void ev_sequence() {
expr = data_s_free(expr);
expr = car(unev);
if (cdr(unev).type == EMPTY) {
/* eval_dispatch(); */
eval_flag = 1;
} else {
save(unev);
save(env);
eval_dispatch();
ev_sequence_cont();
}
}
static void ev_sequence_cont() {
env = restore();
data_s_free(unev);
unev = restore();
unev = cdr(unev);
ev_sequence();
}
#include "stack.h"
#include "list_operations.h"
static int number_pushes = 0;
static int max_depth = 0;
static int current_depth = 0;
#include "empty.h"
data_s stack;
void save(data_s in) {
stack = cons(in, stack);
number_pushes++;
current_depth++;
max_depth = max_depth > current_depth ? max_depth : current_depth;
}
data_s restore() {
data_s t = car(stack);
stack = cdr(stack);
current_depth--;
return t;
}
void initialize_stack() {
number_pushes = 0;
current_depth = 0;
max_depth = 0;
stack = empty_data;
}
void print_statistics() {
printf(";(total-pushes = %d maximum-depth = %d\n", number_pushes,
max_depth);
}
#include "string.h"
#include <string.h>
#include <stdlib.h>
#include "stopif.h"
data_s string_new(char *in) {
char *s = strdup(in);
Stopif(!s, exit(1), "メモリー不足");
return (data_s){.type = STRING, .data.str = s};
}
data_s string_copy(data_s in) {
char *s = strdup(in.data.str);
Stopif(!s, exit(1), "メモリー不足");
return (data_s){.type = STRING, .data.str = s};
}
void string_free(data_s in) {
free(in.data.str);
in.data.str = NULL;
}
#include <ctype.h>
void string_print(FILE *stream, data_s in) {
fprintf(stream, "\"");
char *s = in.data.str;
while (*s != '\0') {
if (isspace(*s)) {
if (*s == ' ')
fputc(' ', stream);
else {
fputc('\\', stream);
if (*s == '\t')
fputc('t', stream);
else if (*s == '\n')
fputc('n', stream);
else if (*s == '\v')
fputc('v', stream);
else if (*s == '\f')
fputc('f', stream);
else if (*s == '\r')
fputc('r', stream);
}
} else {
fputc(*s, stream);
}
s++;
}
fprintf(stream, "\"");
}
#include "symbol.h"
#include <glib.h>
#include <string.h>
GHashTable *obarray;
data_s symbol_new(char *in) {
char *s = g_hash_table_lookup(obarray, in);
if (!s) {
s = strdup(in);
g_hash_table_insert(obarray, in, s);
}
return (data_s){.type = SYMBOL, .data.symbol = s};
}
void symbol_print(FILE *stream, data_s in) {
fprintf(stream, "%s", in.data.symbol);
}
bool symbol_eq(data_s in1, data_s in2) {
return in1.data.symbol == in2.data.symbol;
}
#include "boolean.h"
data_s is_symbol(data_s in) {
return in.type == SYMBOL ? true_data : false_data;
}
#include "undef.h"
void undef_print(FILE *stream, data_s in) {
fprintf(stream, "UNDEFINED");
}
const data_s undef = {.type=UNDEF};
#include "variable.h"
#include "evaluator.h"
bool is_variable(data_s in) {
return in.type == SYMBOL;
}
#include "environment.h"
#include "error.h"
void ev_variable() {
val = data_s_free(val);
val = lookup_variable_value(expr, env);
if (val.type == ERROR)
ev_error();
}
入出力結果(Terminal(kscm), REPL(Read, Eval, Print, Loop))
$ cat test.scm
(define fact
(lambda (n)
(if (= n 1)
1
(* n (fact (- n 1))))))
(define fib
(lambda (n)
(cond ((= n 0) 0)
((= n 1) 1)
(#t (+ (fib (- n 1))
(fib (- n 2)))))))
;; (if (= n 0)
;; 0
;; (if (= n 1)
;; 1
;; (+ (fib (- n 1))
;; (fib (- n 2)))))))
(fact 1000)
(fib 25)
(define fact
(lambda (n)
(define iter
(lambda (n result)
(if (= n 0)
result
(iter (- n 1) (* n result)))))
(iter n 1)))
(fact 1000)
$ ./main < test.scm
kscm> #<procedure (n) ((if (= n 1) 1 (* n (fact (- n 1)))))>
kscm> #<procedure (n) ((cond ((= n 0) 0) ((= n 1) 1) (#t (+ (fib (- n 1)) (fib (- n 2))))))>
kscm> 402387260077093773543702433923003985719374864210714632543799910429938512398629020592044208486969404800479988610197196058631666872994808558901323829669944590997424504087073759918823627727188732519779505950995276120874975462497043601418278094646496291056393887437886487337119181045825783647849977012476632889835955735432513185323958463075557409114262417474349347553428646576611667797396668820291207379143853719588249808126867838374559731746136085379534524221586593201928090878297308431392844403281231558611036976801357304216168747609675871348312025478589320767169132448426236131412508780208000261683151027341827977704784635868170164365024153691398281264810213092761244896359928705114964975419909342221566832572080821333186116811553615836546984046708975602900950537616475847728421889679646244945160765353408198901385442487984959953319101723355556602139450399736280750137837615307127761926849034352625200015888535147331611702103968175921510907788019393178114194545257223865541461062892187960223838971476088506276862967146674697562911234082439208160153780889893964518263243671616762179168909779911903754031274622289988005195444414282012187361745992642956581746628302955570299024324153181617210465832036786906117260158783520751516284225540265170483304226143974286933061690897968482590125458327168226458066526769958652682272807075781391858178889652208164348344825993266043367660176999612831860788386150279465955131156552036093988180612138558600301435694527224206344631797460594682573103790084024432438465657245014402821885252470935190620929023136493273497565513958720559654228749774011413346962715422845862377387538230483865688976461927383814900140767310446640259899490222221765904339901886018566526485061799702356193897017860040811889729918311021171229845901641921068884387121855646124960798722908519296819372388642614839657382291123125024186649353143970137428531926649875337218940694281434118520158014123344828015051399694290153483077644569099073152433278288269864602789864321139083506217095002597389863554277196742822248757586765752344220207573630569498825087968928162753848863396909959826280956121450994871701244516461260379029309120889086942028510640182154399457156805941872748998094254742173582401063677404595741785160829230135358081840096996372524230560855903700624271243416909004153690105933983835777939410970027753472000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000
kscm> 75025
kscm> #<procedure (n) ((define iter (lambda (n result) (if (= n 0) result (iter (- n 1) (* n result))))) (iter n 1))>
kscm> 402387260077093773543702433923003985719374864210714632543799910429938512398629020592044208486969404800479988610197196058631666872994808558901323829669944590997424504087073759918823627727188732519779505950995276120874975462497043601418278094646496291056393887437886487337119181045825783647849977012476632889835955735432513185323958463075557409114262417474349347553428646576611667797396668820291207379143853719588249808126867838374559731746136085379534524221586593201928090878297308431392844403281231558611036976801357304216168747609675871348312025478589320767169132448426236131412508780208000261683151027341827977704784635868170164365024153691398281264810213092761244896359928705114964975419909342221566832572080821333186116811553615836546984046708975602900950537616475847728421889679646244945160765353408198901385442487984959953319101723355556602139450399736280750137837615307127761926849034352625200015888535147331611702103968175921510907788019393178114194545257223865541461062892187960223838971476088506276862967146674697562911234082439208160153780889893964518263243671616762179168909779911903754031274622289988005195444414282012187361745992642956581746628302955570299024324153181617210465832036786906117260158783520751516284225540265170483304226143974286933061690897968482590125458327168226458066526769958652682272807075781391858178889652208164348344825993266043367660176999612831860788386150279465955131156552036093988180612138558600301435694527224206344631797460594682573103790084024432438465657245014402821885252470935190620929023136493273497565513958720559654228749774011413346962715422845862377387538230483865688976461927383814900140767310446640259899490222221765904339901886018566526485061799702356193897017860040811889729918311021171229845901641921068884387121855646124960798722908519296819372388642614839657382291123125024186649353143970137428531926649875337218940694281434118520158014123344828015051399694290153483077644569099073152433278288269864602789864321139083506217095002597389863554277196742822248757586765752344220207573630569498825087968928162753848863396909959826280956121450994871701244516461260379029309120889086942028510640182154399457156805941872748998094254742173582401063677404595741785160829230135358081840096996372524230560855903700624271243416909004153690105933983835777939410970027753472000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000
kscm> $
0 コメント:
コメントを投稿