開発環境
- OS X Yosemite - Apple (OS)
- Emacs (CUI)、BBEdit - Bare Bones Software, Inc. (GUI) (Text Editor)
- C (プログラミング言語)
- Clang/LLVM (コンパイラ, Xcode - Apple)
Schemeの処理系(解釈系、評価機、レジスタ計算機を翻訳した命令列中心のより、もう少しC言語の特性を使った書き方をしたもの(label, gotoではなく、関数を呼び出すとか))を少しずつ書き進めてめていくことに。とりあえず、gmpの使い方を覚えながら、数値の単純な四則演算(二項演算)をできるように。
参考書籍等
- 計算機プログラムの構造と解釈[第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版
k-scheme, kscheme
コード(BBEdit, Emacs)
data.h
#pragma once
#include <gmp.h>
#include <stdbool.h>
#include <stdarg.h>
typedef enum {
/* 基本型 */
PAIR,
EMPTY,
Z,
Q,
R,
SYMBOL,
CHAR,
STRING,
BOOL,
/* 接続 */
FN,
/* garbage collector */
BROKEN_HEART,
/* primitive_procedure */
CAR,
CDR,
SET_CAR,
SET_CDR,
CONS,
IS_EQ,
IS_PAIR,
IS_NULL,
IS_SYMBOL,
IS_NUMBER,
IS_CHAR,
IS_STRING,
MAP,
LIST,
EXIT,
/* procedures number */
NUMBER_ADD,
NUMBER_SUB,
NUMBER_MUL,
NUMBER_DIV,
NUMBER_EQ,
NUMBER_LESS_THAN,
/* stdout */
DISPLAY,
NEWLINE,
/* 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;
} data_u;
typedef struct {
data_type type;
data_u data;
} data_s;
data_s data_s_copy(data_s in);
void data_s_free(data_s in);
void data_s_print(FILE *stream, data_s in);
typedef struct symbol_table_s {
char *s;
struct symbol_table_s *next;
} symbol_table_s;
data_s symbol_new(char *in);
data_s vector_ref(data_s in1[], data_s in2);
data_s vector_set(data_s in1[], data_s in2, data_s in3);
data.c
#include "data.h"
#include "list_operations.h"
#include <stdlib.h>
#include <string.h>
#include <stdio.h>
#include <ctype.h>
const data_s true_data = {.type = BOOL, .data.bln = true};
const data_s false_data = {.type = BOOL, .data.bln = false};
const data_s empty_data = {.type = EMPTY};
const data_s error_data = {.type = ERROR};
const data_s undef = {.type = UNDEF};
data_s data_s_copy(data_s in) {
data_s out = {.type = in.type};
if (in.type == Z) {
mpz_init_set(out.data.z, in.data.z);
}
else if (in.type == Q)
mpq_set(out.data.q, in.data.q);
else if (in.type == R)
mpf_init_set(out.data.r, in.data.r);
else if (in.type == STRING)
out.data.str = strdup(in.data.str);
else
out.data = in.data;
return out;
}
#include "running_evaluator.h"
void data_s_free(data_s in) {
switch (in.type) {
case Z:
mpz_clear(in.data.z);
break;
case Q:
mpq_clear(in.data.q);
break;
case R:
mpf_clear(in.data.r);
break;
case STRING:
free(in.data.str);
break;
default:
break;
}
in.type = UNDEF;
}
static void data_s_pair_print(FILE *stream, data_s in, int flag) {
if (flag) {
printf("(");
}
data_s a = car(in);
if (a.type == PAIR)
data_s_pair_print(stream, a, 1);
else
data_s_print(stream, a);
data_s b = cdr(in);
if (b.type == EMPTY)
fprintf(stream, ")");
else if (b.type == PAIR) {
printf(" ");
data_s_pair_print(stream, b, 0);
} else {
fprintf(stream, " . ");
data_s_print(stream, b);
fprintf(stream, ")");
}
}
void data_s_print(FILE *stream, data_s in) {
switch (in.type) {
case PAIR:
data_s_pair_print(stream, in, 1);
break;
case EMPTY:
fprintf(stream, "()");
break;
case Z:
mpz_out_str(stream, 10, in.data.z);
break;
case Q:
mpq_canonicalize(in.data.q);
mpq_out_str(stream, 10, in.data.q);
break;
case R:
mpf_out_str(stream, 10, 0, in.data.r);
break;
case SYMBOL:
fprintf(stream, "%s", in.data.symbol);
break;
case CHAR:
fprintf(stream, "%c\n", in.data.ch);
break;
case STRING: {
fputc('"', stream);
char ch;
while ((ch = *in.data.str) != '\0') {
if (isspace(ch)) {
if (ch == ' ')
fputc(' ', stream);
else {
fputc('\\', stream);
if (ch == '\t')
fputc('t', stream);
else if (ch == '\n')
fputc('n', stream);
else if (ch == '\v')
fputc('v', stream);
else if (ch == '\f')
fputc('f', stream);
else if (ch == '\r')
fputc('r', stream);
}
} else {
fputc(ch, stream);
}
in.data.str++;
}
fputc('"', stream);
break;
}
case BOOL:
if (in.data.bln)
fprintf(stream, "#t");
else
fprintf(stream, "#f");
break;
case CAR:
fprintf(stream, "car");
break;
case CDR:
fprintf(stream, "cdr");
break;
case SET_CAR:
fprintf(stream, "set-car!");
break;
case SET_CDR:
fprintf(stream, "set-cdr!");
break;
case CONS:
fprintf(stream, "cons");
break;
case IS_EQ:
fprintf(stream, "eq?");
break;
case IS_PAIR:
fprintf(stream, "pair?");
break;
case IS_NULL:
fprintf(stream, "null?");
break;
case IS_SYMBOL:
fprintf(stream, "symbol?");
break;
case IS_NUMBER:
fprintf(stream, "number?");
break;
case IS_CHAR:
fprintf(stream, "char?");
break;
case IS_STRING:
fprintf(stream, "string?");
break;
case MAP:
fprintf(stream, "map");
break;
case LIST:
fprintf(stream, "list");
break;
case NUMBER_ADD:
fprintf(stream, "+");
break;
case NUMBER_SUB:
fprintf(stream, "-");
break;
case NUMBER_MUL:
fprintf(stream, "*");
break;
case NUMBER_DIV:
fprintf(stream, "/");
break;
case NUMBER_EQ:
fprintf(stream, "=");
break;
case DISPLAY:
fprintf(stream, "display");
break;
case NEWLINE:
fprintf(stream, "newline");
break;
case EXIT:
fprintf(stream, "exit");
break;
default:
fprintf(stream, ";undefined");
break;
}
}
data_s symbol_new(char *in) {
static char *obarray[1000000];
static int obarray_max = 0;
int i;
for (i = 0; i < obarray_max; i++) {
if (strcmp(in, obarray[i]) == 0)
return (data_s){.type = SYMBOL, .data.symbol = obarray[i]};
}
obarray[i] = strdup(in);
obarray_max++;
Stopif(obarray_max == 1000000, exit(1), "obarray length");
return (data_s){.type = SYMBOL, .data.symbol = obarray[i]};
}
data_s vector_ref(data_s in1[], data_s in2) {
return in1[in2.data.index];
}
data_s vector_set(data_s in1[], data_s in2, data_s in3) {
data_s_free(in1[in2.data.index]);
in1[in2.data.index] = data_s_copy(in3);
return undef;
}
list_operations.h
#pragma once
#include "data.h"
#include <stdarg.h>
/* primitive procedures */
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);
data_s cons(data_s in1, data_s in2);
data_s is_eq(data_s in1, data_s in2);
data_s is_pair(data_s in);
data_s is_null(data_s in);
data_s is_symbol(data_s in);
data_s is_number(data_s in);
data_s is_char(data_s in);
data_s is_string(data_s in);
/* other primitive procedure */
data_s set(data_s in1, data_s in2);
data_s list(int args, ...);
data_s append(data_s in1, data_s in2);
#include <stdarg.h>
data_s error(char *in, int args, ...);
/* stack */
void save(data_s in);
data_s restore();
void initialize_stack();
/* stop-and-copy garbage collector */
void begin_garbage_collection();
void reassign_root();
void gc_loop();
void update_car();
void update_cdr();
void relocate_old_result_in_new();
void pair();
void already_moved();
void gc_flip();
list_operations.c
#include "list_operations.h"
#include "stopif.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;
#define memory_size 1000000
/* const int memory_size = 1000000; */
data_s cars[memory_size];
data_s cdrs[memory_size];
data_s car(data_s in) {
return vector_ref(cars, in);
}
data_s cdr(data_s in) {
return vector_ref(cdrs, in);
}
extern void user_print(data_s);
data_s set_car(data_s in1, data_s in2) {
vector_set(cars, in1, in2);
return undef;
}
data_s set_cdr(data_s in1, data_s in2) {
vector_set(cdrs, in1, in2);
return undef;
}
int free_index = 10;
data_s root;
extern data_s expr, env, val, cont, proc, argl, unev, stack,
the_global_environment;
data_s cons(data_s in1, data_s in2) {
vector_set(cars, (data_s){.type=PAIR, .data.index=free_index}, in1);
vector_set(cdrs, (data_s){.type=PAIR, .data.index=free_index}, in2);
data_s out = {.type = PAIR, .data.index = free_index};
free_index++;
if (free_index == memory_size) {
vector_set(cars, (data_s){.type=PAIR, .data.index=0}, expr);
vector_set(cdrs, (data_s){.type=PAIR, .data.index=0},
(data_s){.type=PAIR, .data.index=1});
vector_set(cars, (data_s){.type=PAIR, .data.index=1}, env);
vector_set(cdrs, (data_s){.type=PAIR, .data.index=1},
(data_s){.type=PAIR, .data.index=2});
vector_set(cars, (data_s){.type=PAIR, .data.index=2}, val);
vector_set(cdrs, (data_s){.type=PAIR, .data.index=2},
(data_s){.type=PAIR, .data.index=3});
vector_set(cars, (data_s){.type=PAIR, .data.index=3}, cont);
vector_set(cdrs, (data_s){.type=PAIR, .data.index=3},
(data_s){.type=PAIR, .data.index=4});
vector_set(cars, (data_s){.type=PAIR, .data.index=4}, proc);
vector_set(cdrs, (data_s){.type=PAIR, .data.index=4},
(data_s){.type=PAIR, .data.index=5});
vector_set(cars, (data_s){.type=PAIR, .data.index=5}, argl);
vector_set(cdrs, (data_s){.type=PAIR, .data.index=5},
(data_s){.type=PAIR, .data.index=6});
vector_set(cars, (data_s){.type=PAIR, .data.index=6}, unev);
vector_set(cdrs, (data_s){.type=PAIR, .data.index=6},
(data_s){.type=PAIR, .data.index=7});
vector_set(cars, (data_s){.type=PAIR, .data.index=7}, stack);
vector_set(cdrs, (data_s){.type=PAIR, .data.index=7},
(data_s){.type=PAIR, .data.index=8});
vector_set(cars, (data_s){.type=PAIR, .data.index=8}, out);
vector_set(cdrs, (data_s){.type=PAIR, .data.index=8},
(data_s){.type=PAIR, .data.index=9});
vector_set(cars, (data_s){.type=PAIR, .data.index=9},
the_global_environment);
vector_set(cdrs, (data_s){.type=PAIR, .data.index=9}, empty_data);
root = (data_s){.type=PAIR, .data.index = 0};
printf(";begin garbage collection: %d\n", free_index);
begin_garbage_collection();
printf(";end garbage collection: %d\n", free_index);
expr = car(root);
env = car(cdr(root));
val = car(cdr(cdr(root)));
cont = car(cdr(cdr(cdr(root))));
proc = car(cdr(cdr(cdr(cdr(root)))));
argl = car(cdr(cdr(cdr(cdr(cdr(root))))));
unev = car(cdr(cdr(cdr(cdr(cdr(cdr(root)))))));
stack = car(cdr(cdr(cdr(cdr(cdr(cdr(cdr(root))))))));
out = car(cdr(cdr(cdr(cdr(cdr(cdr(cdr(cdr(root)))))))));
the_global_environment =
car(cdr(cdr(cdr(cdr(cdr(cdr(cdr(cdr(cdr(root))))))))));
}
return out;
}
data_s is_eq(data_s in1, data_s in2) {
if (in1.type == in2.type) {
data_u d1 = in1.data, d2 = in2.data;
switch (in1.type) {
case PAIR:
return d1.index == d1.index ? true_data : false_data;
case EMPTY:
return true_data;
case Z:
return mpz_cmp(d1.z, d2.z) == 0 ? true_data : false_data;
case Q:
return mpq_equal(d1.q, d2.q) ? true_data : false_data;
case R:
return mpf_cmp(d1.r, d2.r) == 0 ? true_data : false_data;
case SYMBOL:
return d1.symbol == d2.symbol ? true_data : false_data;
case CHAR:
return d1.ch == d2.ch ? true_data : false_data;
case STRING:
return strcmp(d1.str, d2.str) == 0 ? true_data : false_data;
case BOOL:
return d1.bln == d2.bln ? true_data : false_data;
default:
break;
}
}
return false_data;
}
data_s is_pair(data_s in) { return in.type == PAIR ? true_data : false_data; }
data_s is_null(data_s in) { return in.type == EMPTY ? true_data : false_data; }
data_s is_symbol(data_s in) {
return in.type == SYMBOL ? true_data : false_data;
}
data_s is_number(data_s in) {
switch (in.type) {
case Z:
case Q:
case R:
return true_data;
default:
return false_data;
}
}
data_s is_char(data_s in) { return in.type == CHAR ? true_data : false_data; }
data_s is_string(data_s in) {
return in.type == STRING ? true_data : false_data;
}
data_s set(data_s in1, data_s in2) {
data_s_free(in1);
in1 = in2;
return in1;
}
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 - 1; i >= 0; i--)
out = cons(data_array[i], 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 error(char *in, int args, ...) {
fprintf(stderr, ";%s", in);
va_list ap;
va_start(ap, args);
for (int i = 0; i < args; i++)
data_s_print(stderr, va_arg(ap, data_s));
va_end(ap);
printf("\n");
return error_data;
}
data_s stack;
void save(data_s in) { stack = cons(in, stack); }
data_s restore() {
data_s t = car(stack);
stack = cdr(stack);
return t;
}
void initialize_stack() { stack = empty_data; }
/* stop-and-copy garbage collector */
/* data_s root; */
data_s new_cars[memory_size];
data_s new_cdrs[memory_size];
int scan_index;
data_s old_data;
data_s new_data;
data_s relocate_cont;
void begin_garbage_collection() {
free_index = 10;
scan_index = 10;
old_data = root;
relocate_cont.data.fn = reassign_root;
relocate_old_result_in_new();
}
void reassign_root() {
root = new_data;
gc_loop();
}
void gc_loop() {
if (scan_index == free_index)
gc_flip();
else {
old_data = new_cars[scan_index];
relocate_cont.data.fn = update_car;
relocate_old_result_in_new();
}
}
void update_car() {
vector_set(new_cars, (data_s){.type=PAIR, .data.index=scan_index}, new_data);
old_data = vector_ref(new_cdrs, (data_s){.type=PAIR, .data.index=scan_index});
relocate_cont.data.fn = update_cdr;
relocate_old_result_in_new();
}
void update_cdr() {
vector_set(new_cdrs, (data_s){.type=PAIR, .data.index=scan_index}, new_data);
new_cdrs[scan_index] = new_data;
scan_index++;
gc_loop();
}
void relocate_old_result_in_new() {
if (old_data.type == PAIR)
pair();
else {
new_data = old_data;
relocate_cont.data.fn();
}
}
data_s broken_heart = {.type = BROKEN_HEART};
void pair() {
data_s oldcr = vector_ref(cars, old_data);
if (oldcr.type == BROKEN_HEART)
already_moved();
else {
new_data = (data_s){.type=PAIR, .data.index=free_index};
free_index++;
Stopif(free_index == memory_size, exit(1), "メモリーが足りません");
vector_set(new_cars, new_data, oldcr);
oldcr = vector_ref(cdrs, old_data);
vector_set(new_cdrs, new_data, oldcr);
vector_set(cars, old_data, broken_heart);
vector_set(cdrs, old_data, new_data);
relocate_cont.data.fn();
}
}
void already_moved() {
new_data = vector_ref(cdrs, old_data);
relocate_cont.data.fn();
}
void gc_flip() {
for (int i = 10; i < memory_size; i++) {
vector_set(cdrs, (data_s){.type=PAIR, .data.index=i},
vector_ref(new_cdrs, (data_s){.type=PAIR, .data.index=i}));
vector_set(cars, (data_s){.type=PAIR, .data.index=i},
vector_ref(new_cars, (data_s){.type=PAIR, .data.index=i}));
}
}
data_structures.h
#pragma once
#include <stdbool.h>
#include "data.h"
/* bool is_true(data_s in); */
/* bool is_false(data_s in); */
data_s make_procedure(data_s parameters, data_s body, data_s env);
bool is_compound_procedure(data_s in);
data_s procedure_parameters(data_s in);
data_s procedure_body(data_s in);
data_s procedure_environment(data_s in);
data_s enclosing_environment(data_s env);
data_s first_frame(data_s env);
data_s make_frame(data_s variables, data_s values);
data_s frame_variables(data_s frame);
data_s frame_values(data_s frame);
data_s add_binding_to_frame(data_s var, data_s val, data_s frame);
int c_length(data_s in);
data_s extend_environment(data_s vars, data_s vals, data_s base_env);
data_s lookup_variable_value(data_s var, 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 empty_arglist();
data_s adjoin_arg(data_s arg, data_s arglist);
bool is_last_operand(data_s in);
data_structures.c
#include "data_structures.h"
#include "list_operations.h"
#include "expressions.h"
/* bool is_true(data_s in) { */
/* return !is_false(in); */
/* } */
/* bool is_false(data_s in) { */
/* return in.type == BOOL && in.data.bln == true; */
/* } */
extern data_s true_data;
extern data_s false_data;
extern data_s empty_data;
extern data_s error_data;
extern data_s undef;
data_s procedure;
data_s make_procedure(data_s parameters, data_s body, data_s env) {
return list(4, procedure, parameters, body, env);
}
bool is_compound_procedure(data_s in) {
return is_tagged_list(in, "procedure");
}
data_s procedure_parameters(data_s in) { return car(cdr(in)); }
data_s procedure_body(data_s in) { return car(cdr(cdr(in))); }
data_s procedure_environment(data_s in) { return car(cdr(cdr(cdr(in)))); }
data_s enclosing_environment(data_s env) { return cdr(env); }
data_s first_frame(data_s env) { return car(env); }
data_s the_empty_environment;
data_s make_frame(data_s variables, data_s values) {
return cons(variables, values);
}
data_s frame_variables(data_s frame) { return car(frame); }
data_s frame_values(data_s frame) { return cdr(frame); }
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)));
}
int c_length(data_s in) {
if (in.type == EMPTY)
return 0;
return 1 + c_length(cdr(in));
}
data_s extend_environment(data_s vars, data_s vals, data_s base_env) {
int vars_len = c_length(vars);
int vals_len = c_length(vals);
if (vars_len == vals_len)
return cons(make_frame(vars, vals), base_env);
if (vars_len < vals_len) {
error("Too many arguments suppllied: ", 2, vars, vals);
return error_data;
}
error("Too few arguments supplied: ", 2, vars, vals);
return error_data;
}
static data_s scan(data_s var, data_s env, data_s vars, data_s vals);
static data_s env_loop(data_s var, data_s env);
data_s scan(data_s var, data_s env, data_s vars, data_s vals) {
if (vars.type == EMPTY)
return env_loop(var, enclosing_environment(env));
data_s t = is_eq(var, car(vars));
if (t.data.bln == true)
return car(vals);
return scan(var, env, cdr(vars), cdr(vals));
}
data_s env_loop(data_s var, data_s env) {
if (env.type == EMPTY) {
error("Unbound variable: ", 1, var);
return error_data;
}
data_s frame = first_frame(env);
return scan(var, env, frame_variables(frame), frame_values(frame));
}
data_s lookup_variable_value(data_s var, data_s env) {
return env_loop(var, env);
}
static data_s scan1(data_s var, data_s val, data_s env, data_s vars,
data_s vals);
static data_s env_loop1(data_s var, data_s val, data_s env);
data_s scan1(data_s var, data_s val, data_s env, data_s vars, data_s vals) {
if (vars.type == EMPTY)
return env_loop1(var, val, enclosing_environment(env));
data_s t = is_eq(var, car(vars));
if (t.data.bln == true)
return set_car(vals, val);
return scan1(var, val, env, cdr(vars), cdr(vals));
}
data_s env_loop1(data_s var, data_s val, data_s env) {
if (env.type == EMPTY) {
error("Unbound variable -- SET!: ", 1, var);
return error_data;
}
data_s frame = first_frame(env);
return scan1(var, val, env, frame_variables(frame), frame_values(frame));
}
data_s set_variable_value(data_s var, data_s val, data_s env) {
return env_loop1(var, val, env);
}
static data_s scan2(data_s var, data_s val, data_s env, data_s frame,
data_s vars, data_s vals) {
if (vars.type == EMPTY)
return add_binding_to_frame(var, val, frame);
data_s t = is_eq(var, car(vars));
if (t.data.bln == true)
return set_car(vals, val);
return scan2(var, val, env, frame, cdr(vars), cdr(vals));
}
data_s define_variable(data_s var, data_s val, data_s env) {
data_s frame = first_frame(env);
return scan2(var, val, env, frame, frame_variables(frame),
frame_values(frame));
}
data_s empty_arglist() { return empty_data; }
data_s adjoin_arg(data_s arg, data_s arglist) {
return append(arglist, list(1, arg));
}
bool is_last_operand(data_s in) {
data_s t = cdr(in);
return t.type == EMPTY;
}
expressions.h
#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);
expressions.c
#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 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 make_lambda(data_s parameters, data_s body) {
data_s lambda = symbol_new("lambda");
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));
}
apply_number.h
#pragma once
#include "data.h"
#include "list_operations.h"
data_s number_apply_add(data_s in);
data_s number_apply_sub(data_s in);
data_s number_apply_mul(data_s in);
data_s number_apply_div(data_s in);
data_s number_apply_eq(data_s in);
data_s number_apply_less_than(data_s in);
apply_number.c
#include "apply_number.h"
#include <gmp.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;
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 number_apply_add(data_s in) { return number_add(car(in),
car(cdr(in))); }
data_s number_apply_sub(data_s in) { return number_sub(car(in),
car(cdr(in))); }
data_s number_apply_mul(data_s in) { return number_mul(car(in),
car(cdr(in))); }
data_s number_apply_div(data_s in) { return number_div(car(in),
car(cdr(in))); }
data_s number_apply_eq(data_s in) { return number_eq(car(in), car(cdr(in)));
}
data_s number_apply_less_than(data_s in) {
return number_less_than(car(in), car(cdr(in)));
}
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;
}
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;
}
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;
}
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;
}
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;
}
running_evaluator.h
#pragma once
#include "data.h"
#include <stdbool.h>
data_s setup_environment();
data_s the_global_environment;
data_s get_global_environment();
bool is_primitive_procedure(data_s in);
data_s primitive_implementation(data_s in);
data_s primitive_procedures;
data_s primitive_procedure_names();
data_s primitive_procedure_objects();
data_s apply_primitive_procedure(data_s proc, data_s args);
void user_print(data_s in);
running_evaluator.c
#include "running_evaluator.h"
#include "list_operations.h"
#include "expressions.h"
#include "data_structures.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;
extern data_s the_empty_environment;
data_s setup_environment() {
data_s names = primitive_procedure_names();
data_s objects = primitive_procedure_objects();
data_s initial_env =
extend_environment(names, objects, the_empty_environment);
return initial_env;
}
data_s the_global_environment;
data_s get_global_environment() { return the_global_environment; }
bool is_primitive_procedure(data_s in) {
return is_tagged_list(in, "primitive");
}
data_s primitive_implementation(data_s in) { return car(cdr(in)); }
data_s primitive_procedures;
static data_s iter(data_s in) {
if (in.type == EMPTY)
return empty_data;
return cons(car(car(in)), iter(cdr(in)));
}
data_s primitive_procedure_names() { return iter(primitive_procedures); }
data_s primitive;
static data_s inner(data_s in) { return list(2, primitive, car(cdr(in)));}
static data_s iter1(data_s in) {
if (in.type == EMPTY)
return empty_data;
return cons(inner(car(in)), iter1(cdr(in)));
}
data_s primitive_procedure_objects() { return iter1(primitive_procedures); }
#include "apply_number.h"
static data_s apply_list(data_s in) {
int len = c_length(in);
data_s a[len];
data_s t = in;
for (int i = 0; i < len; i++) {
a[i] = car(t);
t = cdr(t);
}
data_s out = empty_data;
for (int i = len - 1; i >= 0; i--)
out = cons(a[i], out);
return out;
}
data_s apply_primitive_procedure(data_s proc, data_s args) {
data_s p = primitive_implementation(proc);
switch (p.type) {
case CAR:
return car(car(args));
case CDR:
return cdr(car(args));
case SET_CAR:
return set_car(car(args), car(cdr(args)));
case CONS:
return cons(car(args), car(cdr(args)));
case IS_EQ:
return is_eq(car(args), car(cdr(args)));
case IS_PAIR:
return is_pair(car(args));
case IS_NULL:
return is_null(car(args));
case IS_SYMBOL:
return is_symbol(car(args));
case IS_NUMBER:
return is_number(car(args));
case IS_CHAR:
return is_char(car(args));
case IS_STRING:
return is_string(car(args));
case MAP:
case LIST:
return apply_list(args);
case NUMBER_ADD:
return number_apply_add(args);
case NUMBER_SUB:
return number_apply_sub(args);
case NUMBER_MUL:
return number_apply_mul(args);
case NUMBER_DIV:
return number_apply_div(args);
break;
case NUMBER_EQ:
return number_apply_eq(args);
case NUMBER_LESS_THAN:
return number_apply_less_than(args);
case DISPLAY: {
data_s d = car(args);
if (d.type == STRING)
printf("%s", d.data.str);
else
data_s_print(stdout, d);
return undef;
}
case NEWLINE:
printf("\n");
return undef;
case EXIT:
exit(0);
default:
return undef;
}
}
data_s compound_procedure;
data_s procedure_env;
void user_print(data_s in) {
if (is_compound_procedure(in)) {
data_s_print(stdout, list(4, compound_procedure, procedure_parameters(in),
procedure_body(in), procedure_env));
} else {
data_s_print(stdout, in);
}
printf("\n");
}
kread.h
#pragma once
#include "data.h"
data_s kread();
kread.c
#include <stdio.h>
#include <ctype.h>
#include "kread.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;
static void skip_spaces();
static data_s read_pair();
static data_s read_atom();
static data_s read_number();
static data_s read_symbol();
static data_s read_char();
static data_s read_string();
static data_s read_bool();
data_s kread() {
data_s out;
skip_spaces();
char ch = getchar();
if (ch == EOF)
exit(0);
if (ch == '(') {
out = read_pair();
} else {
ungetc(ch, stdin);
out = read_atom();
}
return out;
}
static void skip_spaces() {
char ch;
while (isspace(ch = getchar()))
;
ungetc(ch, stdin);
}
static data_s read_pair() {
skip_spaces();
char ch = getchar();
if (ch == ')')
return empty_data;
ungetc(ch, stdin);
data_s a = kread();
skip_spaces();
ch = getchar();
if (ch == ')')
return cons(a, empty_data);
ungetc(ch, stdin);
ungetc('(', stdin);
return cons(a, kread());
}
static data_s read_atom() {
data_s out;
char ch = getchar();
char ch1 = '\0';
if (ch == '\'')
out = read_char();
else if (ch == '"')
out = read_string();
else if (ch == '#')
out = read_bool();
else if (isdigit(ch)) {
ungetc(ch, stdin);
out = read_number();
} else if ((ch == '+' || ch == '-') && isdigit(ch1 = getchar())) {
ungetc(ch1, stdin);
ungetc(ch, stdin);
out = read_number();
} else {
if (ch1 != '\0')
ungetc(ch1, stdin);
ungetc(ch, stdin);
out = read_symbol();
}
return out;
}
static data_s read_number() {
static int number_size = 1000000;
data_s out;
char s[number_size];
int i = 0;
char ch = getchar();
s[i] = ch;
i++;
while (isdigit(ch = getchar())) {
s[i] = ch;
i++;
}
if (ch == '.') {
s[i] = ch;
i++;
while (isdigit(ch = getchar())) {
s[i] = ch;
i++;
}
s[i] = '\0';
if (ch == '(' || ch == ')')
ungetc(ch, stdin);
out.type = R;
mpf_init_set_str(out.data.r, s, 10);
} else if (ch == '/') {
s[i] = ch;
i++;
while (isdigit(ch = getchar())) {
s[i] = ch;
i++;
}
s[i] = '\0';
if (ch == '(' || ch == ')')
ungetc(ch, stdin);
out.type = Q;
mpq_init(out.data.q);
mpq_set_str(out.data.q, s, 10);
} else {
s[i] = '\0';
if (ch == '(' || ch == ')')
ungetc(ch, stdin);
out.type = Z;
mpz_init_set_str(out.data.z, s, 10);
}
return out;
}
#define symbol_size 100
static data_s read_symbol() {
/* static const int symbol_size = 100; */
static char symbol[symbol_size];
int i;
char ch = getchar();
for (i = 0; !isspace(ch) && ch != '(' && ch != ')'; i++) {
symbol[i] = ch;
ch = getchar();
}
symbol[i] = '\0';
if (ch == '(' || ch == ')')
ungetc(ch, stdin);
data_s out = symbol_new(symbol);
return out;
}
static data_s read_char() {
data_s out = {.type = CHAR, .data.ch = getchar()};
getchar();
return out;
}
data_s read_string() {
static int str_size = 1000000;
data_s out;
char str[str_size];
int i = 0;
while (1) {
char ch = getchar();
if (ch == '\\') {
str[i] = ch;
i++;
ch = getchar();
str[i] = ch;
i++;
} else if (ch == '\"') {
str[i] = '\0';
break;
} else {
str[i] = ch;
i++;
}
}
out = (data_s){.type = STRING, .data.str = strdup(str)};
return out;
}
static data_s read_bool() {
char ch = getchar();
if (ch == 't')
return true_data;
if (ch == 'f')
return false_data;
return error_data;
}
kscheme.h
#pragma once
/* 構文の型による場合分け */
void eval_dispatch();
/* 単純式の評価 */
void ev_self_eval();
void ev_variable();
void ev_quoted();
void ev_lambda();
/* 手続き作用の評価 */
void ev_application();
void ev_appl_did_operator();
void ev_appl_operand_loop();
void ev_appl_accumulate_arg();
void ev_appl_last_arg();
void ev_appl_accum_last_arg();
/* 手続き作用 */
void apply_dispatch();
void primitive_apply();
void compound_apply();
/* 並びの評価 */
void ev_begin();
void ev_sequence();
void ev_sequence_cont();
void ev_sequence_last_expr();
/* 条件式 */
void ev_if();
void ev_if_decide();
void ev_if_alternative();
void ev_if_consequent();
/* 代入と定義 */
void ev_assignment();
void ev_assignment1();
void ev_definition();
void ev_definition1();
/* 評価の実行 */
void read_eval_print_loop();
void print_result();
void unknown_expression_type();
void unknown_procedure_type();
void signal_error();
kscheme.c
#include "kscheme.h"
#include "data.h"
#include "list_operations.h"
#include "expressions.h"
#include "data_structures.h"
#include "running_evaluator.h"
#include "kread.h"
#include <stdio.h>
data_s expr, env, val, cont, proc, argl, unev;
/* 構文の型による場合分け */
void eval_dispatch() {
if (is_self_evaluating(expr))
ev_self_eval();
else if (is_variable(expr))
ev_variable();
else if (is_quoted(expr))
ev_quoted();
else if (is_assignment(expr))
ev_assignment();
else if (is_definition(expr))
ev_definition();
else if (is_if(expr))
ev_if();
else if (is_lambda(expr))
ev_lambda();
else if (is_begin(expr))
ev_begin();
else if (is_application(expr))
ev_application();
else
unknown_expression_type();
}
/* 単純式の評価 */
void ev_self_eval() {
val = expr;
cont.data.fn();
}
void ev_variable() {
val = lookup_variable_value(expr, env);
cont.data.fn();
}
void ev_quoted() {
val = text_of_quotation(expr);
cont.data.fn();
}
void ev_lambda() {
unev = lambda_parameters(expr);
expr = lambda_body(expr);
val = make_procedure(unev, expr, env);
cont.data.fn();
}
/* 手続き作用の評価 */
void ev_application() {
save(cont);
save(env);
unev = operands(expr);
save(unev);
expr = operator(expr);
cont.data.fn = ev_appl_did_operator;
eval_dispatch();
}
void ev_appl_did_operator() {
unev = restore();
env = restore();
argl = empty_arglist();
proc = val;
if (no_operands(unev))
apply_dispatch();
else {
save(proc);
ev_appl_operand_loop();
}
}
void ev_appl_operand_loop() {
save(argl);
expr = first_operand(unev);
if (is_last_operand(unev))
ev_appl_last_arg();
else {
save(env);
save(unev);
cont.data.fn = ev_appl_accumulate_arg;
eval_dispatch();
}
}
void ev_appl_accumulate_arg() {
unev = restore();
env = restore();
argl = restore();
argl = adjoin_arg(val, argl);
unev = rest_operands(unev);
ev_appl_operand_loop();
}
void ev_appl_last_arg() {
cont.data.fn = ev_appl_accum_last_arg;
eval_dispatch();
}
void ev_appl_accum_last_arg() {
argl = restore();
argl = adjoin_arg(val, argl);
proc = restore();
apply_dispatch();
}
/* 手続き作用 */
void apply_dispatch() {
if (is_primitive_procedure(proc))
primitive_apply();
else if (is_compound_procedure(proc))
compound_apply();
else
unknown_procedure_type();
}
void primitive_apply() {
val = apply_primitive_procedure(proc, argl);
cont = restore();
cont.data.fn();
}
void compound_apply() {
unev = procedure_parameters(proc);
env = procedure_environment(proc);
env = extend_environment(unev, argl, env);
unev = procedure_body(proc);
ev_sequence();
}
/* 並びの評価 */
void ev_begin() {
unev = begin_actions(expr);
save(cont);
ev_sequence();
}
void ev_sequence() {
expr = first_expr(unev);
if (is_last_expr(unev))
ev_sequence_last_expr();
else {
save(unev);
save(env);
cont.data.fn = ev_sequence_cont;
eval_dispatch();
}
}
void ev_sequence_cont() {
env = restore();
unev = restore();
unev = rest_exprs(unev);
ev_sequence();
}
void ev_sequence_last_expr() {
cont = restore();
eval_dispatch();
}
/* 条件式 */
void ev_if() {
save(expr);
save(env);
save(cont);
cont.data.fn = ev_if_decide;
expr = if_predicate(expr);
eval_dispatch();
}
void ev_if_decide() {
cont = restore();
env = restore();
expr = restore();
if (val.type != BOOL || val.data.bln != false)
ev_if_consequent();
else
ev_if_alternative();
}
void ev_if_alternative() {
expr = if_alternative(expr);
eval_dispatch();
}
void ev_if_consequent() {
expr = if_consequent(expr);
eval_dispatch();
}
/* 代入と定義 */
void ev_assignment() {
unev = assignment_variable(expr);
save(unev);
expr = assignment_value(expr);
save(env);
save(cont);
cont.data.fn = ev_assignment1;
eval_dispatch();
}
void ev_assignment1() {
cont = restore();
env = restore();
unev = restore();
set_variable_value(unev, val, env);
cont.data.fn();
}
void ev_definition() {
unev = definition_variable(expr);
save(unev);
expr = definition_value(expr);
save(env);
save(cont);
cont.data.fn = ev_definition1;
eval_dispatch();
}
void ev_definition1() {
cont = restore();
env = restore();
unev = restore();
define_variable(unev, val, env);
val = unev;
cont.data.fn();
}
/* 評価の実行 */
void read_eval_print_loop() {
initialize_stack();
printf(";;; EC-Eval input:\n");
expr = kread();
env = get_global_environment();
cont.data.fn = print_result;
eval_dispatch();
}
void print_result() {
printf(";;; EC-Eval value:\n");
user_print(val);
read_eval_print_loop();
}
void unknown_expression_type() {
data_s unknown_expression_type_error =
symbol_new(";Unknown expression type error");
val = unknown_expression_type_error;
signal_error();
}
void unknown_procedure_type() {
data_s unknown_procedure_type_error =
symbol_new(";Unknown procedure type error");
cont = restore();
val = unknown_procedure_type_error;
signal_error();
}
void signal_error() {
user_print(val);
read_eval_print_loop();
}
extern data_s root; /* garbage collection */
extern data_s stack;
extern data_s procedure;
extern data_s primitive;
extern data_s the_empty_environment;
extern data_s primitive_procedures;
extern data_s the_global_environment;
extern data_s compound_procedure;
extern data_s procedure_env;
extern data_s empty_data;
int main() {
expr = env = val = cont = proc = argl = unev = empty_data;
procedure = symbol_new("procedure");
primitive = symbol_new("primitive");
compound_procedure = symbol_new("compound-procedure");
procedure_env = symbol_new("<procedure-env>");
the_empty_environment = empty_data;
primitive_procedures =
list(23, list(2, symbol_new("car"), (data_s){.type = CAR}),
list(2, symbol_new("cdr"), (data_s){.type = CDR}),
list(2, symbol_new("set-car!"), (data_s){.type = SET_CAR}),
list(2, symbol_new("set-cdr!"), (data_s){.type = SET_CDR}),
list(2, symbol_new("cons"), (data_s){.type = CONS}),
list(2, symbol_new("eq?"), (data_s){.type = IS_EQ}),
list(2, symbol_new("pair?"), (data_s){.type = IS_PAIR}),
list(2, symbol_new("null?"), (data_s){.type = IS_NULL}),
list(2, symbol_new("symbol?"), (data_s){.type = IS_SYMBOL}),
list(2, symbol_new("number?"), (data_s){.type = IS_NUMBER}),
list(2, symbol_new("char?"), (data_s){.type = IS_CHAR}),
list(2, symbol_new("string?"), (data_s){.type = IS_STRING}),
list(2, symbol_new("map"), (data_s){.type = MAP}),
list(2, symbol_new("list"), (data_s){.type = LIST}),
list(2, symbol_new("+"), (data_s){.type=NUMBER_ADD}),
list(2, symbol_new("-"), (data_s){.type=NUMBER_SUB}),
list(2, symbol_new("*"), (data_s){.type=NUMBER_MUL}),
list(2, symbol_new("/"), (data_s){.type=NUMBER_DIV}),
list(2, symbol_new("="), (data_s){.type=NUMBER_EQ}),
list(2, symbol_new("<"), (data_s){.type=NUMBER_LESS_THAN}),
list(2, symbol_new("display"), (data_s){.type=DISPLAY}),
list(2, symbol_new("newline"), (data_s){.type=NEWLINE}),
list(2, symbol_new("exit"), (data_s){.type=EXIT}));
the_global_environment = setup_environment();
read_eval_print_loop();
}
Clang/LLVMだとうまくいかなかったから、GCCに変えたらうまくいった。問題は残ったままだろうけど。というか、それ以前にまだ書きかけのところがいっぱいあったり。
階乗計算の手続き、フィボナッチ数を求める手続きで、等号、掛け算、引き算ができることを確認。
入出力結果(Terminal(gosh), REPL(Read, Eval, Print, Loop))
$ ./kscheme
;;; EC-Eval input:
(define factorial
(lambda (n)
(if (= n 1)
1
(* n (factorial (- n 1))))))
;;; EC-Eval value:
factorial
;;; EC-Eval input:
(factorial 1000)
;;; EC-Eval value:
402387260077093773543702433923003985719374864210714632543799910429938512398629020592044208486969404800479988610197196058631666872994808558901323829669944590997424504087073759918823627727188732519779505950995276120874975462497043601418278094646496291056393887437886487337119181045825783647849977012476632889835955735432513185323958463075557409114262417474349347553428646576611667797396668820291207379143853719588249808126867838374559731746136085379534524221586593201928090878297308431392844403281231558611036976801357304216168747609675871348312025478589320767169132448426236131412508780208000261683151027341827977704784635868170164365024153691398281264810213092761244896359928705114964975419909342221566832572080821333186116811553615836546984046708975602900950537616475847728421889679646244945160765353408198901385442487984959953319101723355556602139450399736280750137837615307127761926849034352625200015888535147331611702103968175921510907788019393178114194545257223865541461062892187960223838971476088506276862967146674697562911234082439208160153780889893964518263243671616762179168909779911903754031274622289988005195444414282012187361745992642956581746628302955570299024324153181617210465832036786906117260158783520751516284225540265170483304226143974286933061690897968482590125458327168226458066526769958652682272807075781391858178889652208164348344825993266043367660176999612831860788386150279465955131156552036093988180612138558600301435694527224206344631797460594682573103790084024432438465657245014402821885252470935190620929023136493273497565513958720559654228749774011413346962715422845862377387538230483865688976461927383814900140767310446640259899490222221765904339901886018566526485061799702356193897017860040811889729918311021171229845901641921068884387121855646124960798722908519296819372388642614839657382291123125024186649353143970137428531926649875337218940694281434118520158014123344828015051399694290153483077644569099073152433278288269864602789864321139083506217095002597389863554277196742822248757586765752344220207573630569498825087968928162753848863396909959826280956121450994871701244516461260379029309120889086942028510640182154399457156805941872748998094254742173582401063677404595741785160829230135358081840096996372524230560855903700624271243416909004153690105933983835777939410970027753472000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000
;;; EC-Eval input:
(define fib
(lambda (n)
(if (= n 0)
0
(if (= n 1)
1
(+ (fib (- n 1))
(fib (- n 2)))))))
;;; EC-Eval value:
fib
;;; EC-Eval input:
(fib 20)
;begin garbage collection: 1000000
;end garbage collection: 285
;;; EC-Eval value:
6765
;;; EC-Eval input:
(exit)
$
0 コメント:
コメントを投稿