開発環境
- OS X Yosemite - Apple, Ubuntu (OS)
- Emacs (CUI)、BBEdit - Bare Bones Software, Inc. (GUI) (Text Editor)
- C (プログラミング言語)
- Clang/LLVM (コンパイラ, Xcode - Apple)
Schemeの処理系(解釈系、評価機)を少しずつ書き始めてみることに。
基本手続き少し(cons、car、cdr…)と式(非負整数、文字列…)まで。
参考書籍等
- 計算機プログラムの構造と解釈[第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)
main.c
//
// main.c
// k-scheme
//
// Created by kamimura on 11/15/14.
// Copyright (c) 2014 kamimura. All rights reserved.
//
#define GLOBAL 1
#include <stdio.h>
#include <ctype.h>
#include "list_structured_memory.h"
int main(int argc, char *argv[])
{
initialize_symbol_table();
the_global_environment = setup_environment();
read_eval_print_loop();
return 0;
}
void read_eval_print_loop()
{
read_eval_print_loop:
if (GLOBAL) {
puts("**************************************************");
puts("グローバル環境");
user_print(the_global_environment);
puts("\n**************************************************");
}
initialize_stack();
/* puts(";;; EC-EVAL input:"); */
puts(";;; kscheme input:");
expr = user_read();
env = get_global_environment();
cont.ptr.ptr = &&print_result;
goto eval_dispatch;
print_result:
/* puts(";;; EC-EVAL value:"); */
puts(";;; kscheme value:");
user_print(val);
putchar('\n');
fflush(stdout);
goto read_eval_print_loop;
unknown_expression_type:
val = unknown_expression_type_error;
goto signal_error;
unknown_procedure_type:
cont = restore();
val = unknown_procedure_type_error;
goto signal_error;
signal_error:
user_print(val);
putchar('\n');
goto read_eval_print_loop;
eval_dispatch:
if (is_self_evaluating(expr)) goto ev_self_eval;
if (is_variable(expr)) goto ev_variable;
if (is_quoted(expr)) goto ev_quoted;
if (is_assignment(expr)) goto ev_assignment;
if (is_definition(expr)) goto ev_definition;
if (is_if(expr)) goto ev_if;
if (is_lambda(expr)) goto ev_lambda;
if (is_begin(expr)) goto ev_begin;
if (is_application(expr)) goto ev_application;
goto unknown_expression_type;
ev_self_eval:
val = expr;
goto *(cont.ptr.ptr);
ev_variable:
val = lookup_variable_value(expr, env);
goto *(cont.ptr.ptr);
ev_quoted:
val = text_of_quotation(expr);
goto *(cont.ptr.ptr);
ev_lambda:
unev = lambda_parameters(expr);
expr = lambda_body(expr);
val = make_procedure(unev, expr, env);
goto *(cont.ptr.ptr);
ev_application:
save(cont);
save(env);
unev = operands(expr);
save(unev);
expr = operator(expr);
cont.ptr.ptr = &&ev_appl_did_operator;
goto eval_dispatch;
ev_appl_did_operator:
unev = restore();
env = restore();
argl = empty_arglist();
proc = val;
if (is_no_operands(unev))
goto apply_dispatch;
save(proc);
ev_appl_operand_loop:
save(argl);
expr = first_operand(unev);
if (is_last_operand(unev))
goto ev_appl_last_arg;
save(env);
save(unev);
cont.ptr.ptr = &&ev_appl_accumulate_arg;
goto eval_dispatch;
ev_appl_accumulate_arg:
unev = restore();
env = restore();
argl = restore();
argl = adjoin_arg(val, argl);
unev = rest_operands(unev);
goto ev_appl_operand_loop;
ev_appl_last_arg:
cont.ptr.ptr = &&ev_appl_accum_last_arg;
goto eval_dispatch;
ev_appl_accum_last_arg:
argl = restore();
argl = adjoin_arg(val, argl);
proc = restore();
goto apply_dispatch;
apply_dispatch:
if (is_primitive_procedure(proc))
goto primitive_apply;
if (is_compound_procedure(proc))
goto compound_apply;
goto unknown_procedure_type;
primitive_apply:
val = apply_primitive_procedure(proc, argl);
cont = restore();
goto *(cont.ptr.ptr);
compound_apply:
unev = procedure_parameters(proc);
env = procedure_environment(proc);
env = extend_environment(unev, argl, env);
unev = procedure_body(proc);
goto ev_sequence;
ev_begin:
unev = begin_actions(expr);
save(cont);
goto ev_sequence;
ev_sequence:
expr = first_expr(unev);
if (is_last_expr(unev))
goto ev_sequence_last_exp;
save(unev);
save(env);
cont.ptr.ptr = &&ev_sequence_continue;
goto eval_dispatch;
ev_sequence_continue:
env = restore();
unev = restore();
unev = rest_exprs(unev);
goto ev_sequence;
ev_sequence_last_exp:
cont = restore();
goto eval_dispatch;
ev_if:
save(expr);
save(env);
save(cont);
cont.ptr.ptr = &&ev_if_decide;
expr = if_predicate(expr);
goto eval_dispatch;
ev_if_decide:
cont = restore();
env = restore();
expr = restore();
if (is_true(val))
goto ev_if_consequent;
/* ev_if_alternative: */
expr = if_alternative(expr);
goto eval_dispatch;
ev_if_consequent:
expr = if_consequent(expr);
goto eval_dispatch;
ev_assignment:
unev = assignment_variable(expr);
save(unev);
expr = assignment_value(expr);
save(env);
save(cont);
cont.ptr.ptr = &&ev_assignment_1;
goto eval_dispatch;
ev_assignment_1:
cont = restore();
env = restore();
unev = restore();
set_variable_value(unev, val, env);
val = get_ok_ptr();
goto *(cont.ptr.ptr);
ev_definition:
unev = definition_variable(expr);
save(unev);
expr = definition_value(expr);
save(env);
save(cont);
cont.ptr.ptr = &&ev_definition_1;
goto eval_dispatch;
ev_definition_1:
cont = restore();
env = restore();
unev = restore();
define_variable(unev, val, env);
val = get_ok_ptr();
goto *(cont.ptr.ptr);
}
list_structured_memory.h
//
// list_structured_memory.h
// k-scheme
//
// Created by kamimura on 11/15/14.
// Copyright (c) 2014 kamimura. All rights reserved.
//
#include <stdio.h>
#include <stdlib.h>
#include <string.h>
#include <stdarg.h>
#include <ctype.h>
#ifndef __k_scheme__list_structured_memory__
#define __k_scheme__list_structured_memory__
#endif /* defined(__k_scheme__list_structured_memory__) */
typedef enum {
POINTER, INT, SYMBOL, EMPTY, BROKEN_HEART, CONT, STRING, UNDEF,
UNKNOWN_EXPRESSION, UNKNOWN_PROCEDURE,
/* primitive_procedures */
CAR, CDR, CONS, PLUS, EXIT, ERROR, LOAD
} pointer_type;
typedef int vect_index;
typedef int symbol_index;
typedef union {
vect_index i; /* POINTER */
int n; /* INT */
symbol_index symbol; /* SYMBOL */
void *ptr; /* CONT */
char *str; /* STRING */
} pointer;
typedef struct {
pointer_type type;
pointer ptr;
} typed_ptr;
typed_ptr vector_ref(typed_ptr vector[], int n);
void vector_set(typed_ptr vector[], int n, typed_ptr value);
typed_ptr car(typed_ptr reg);
typed_ptr cdr(typed_ptr reg);
void set_car(typed_ptr reg1, typed_ptr reg2);
void set_cdr(typed_ptr reg1, typed_ptr reg2);
typed_ptr cons(typed_ptr reg1, typed_ptr reg2);
int is_eq(typed_ptr reg1, typed_ptr reg2);
int is_pair(typed_ptr reg);
int is_null(typed_ptr reg);
int is_symbol(typed_ptr reg);
void initialize_stack();
void save(typed_ptr reg);
typed_ptr restore();
int is_broken_heart(typed_ptr reg);
void garbage_collection();
void initialize_symbol_table();
void clear_symbol_table();
symbol_index add_symbol(char* s);
symbol_index find_symbol(char *s);
typed_ptr expr;
typed_ptr env;
typed_ptr val;
typed_ptr cont;
typed_ptr proc;
typed_ptr argl;
typed_ptr unev;
int is_self_evaluating(typed_ptr reg);
int is_variable(typed_ptr reg);
int is_quoted(typed_ptr reg);
int is_assignment(typed_ptr reg);
int is_definition(typed_ptr reg);
int is_if(typed_ptr reg);
int is_lambda(typed_ptr reg);
int is_begin(typed_ptr reg);
int is_application(typed_ptr reg);
int is_number(typed_ptr reg);
int is_string(typed_ptr reg);
int is_tagged_list(typed_ptr reg1, typed_ptr reg2);
typed_ptr lookup_variable_value(typed_ptr reg1, typed_ptr reg2);
typed_ptr the_empty_environment;
typed_ptr env_loop(typed_ptr reg1, typed_ptr reg2);
typed_ptr first_frame(typed_ptr reg);
typed_ptr frame_variables(typed_ptr reg);
typed_ptr frame_values(typed_ptr reg);
typed_ptr scan(typed_ptr reg1, typed_ptr reg2, typed_ptr reg3, typed_ptr reg4);
typed_ptr enclosing_environment(typed_ptr reg);
typed_ptr text_of_quotation(typed_ptr reg);
typed_ptr lambda_parameters(typed_ptr reg);
typed_ptr lambda_body(typed_ptr reg);
typed_ptr make_procedure(typed_ptr reg1, typed_ptr reg2, typed_ptr reg3);
typed_ptr list(int args, ...);
typed_ptr operands(typed_ptr reg);
typed_ptr operator(typed_ptr reg);
typed_ptr empty_arglist();
int is_no_operands(typed_ptr reg);
typed_ptr first_operand(typed_ptr reg);
int is_last_operand(typed_ptr reg);
typed_ptr adjoin_arg(typed_ptr reg1, typed_ptr reg2);
typed_ptr rest_operands(typed_ptr reg);
typed_ptr append(typed_ptr reg1, typed_ptr reg2);
int is_primitive_procedure(typed_ptr reg);
int is_compound_procedure(typed_ptr reg);
typed_ptr apply_primitive_procedure(typed_ptr reg1, typed_ptr reg2);
typed_ptr apply_in_underlying_scheme(typed_ptr reg1, typed_ptr reg2);
typed_ptr primitive_implementation(typed_ptr reg);
typed_ptr procedure_parameters(typed_ptr reg);
typed_ptr procedure_environment(typed_ptr reg);
typed_ptr extend_environment(typed_ptr reg1, typed_ptr reg2, typed_ptr reg3);
int length(typed_ptr reg);
typed_ptr make_frame(typed_ptr reg1, typed_ptr reg2);
typed_ptr procedure_body(typed_ptr reg);
typed_ptr begin_actions(typed_ptr reg);
typed_ptr first_expr(typed_ptr reg);
int is_last_expr(typed_ptr reg);
typed_ptr rest_exprs(typed_ptr reg);
typed_ptr if_predicate(typed_ptr reg);
int is_true(typed_ptr reg);
typed_ptr if_alternative(typed_ptr reg);
typed_ptr if_consequent(typed_ptr reg);
typed_ptr assignment_variable(typed_ptr reg);
typed_ptr assignment_value(typed_ptr reg);
void set_variable_value(typed_ptr reg1, typed_ptr reg2, typed_ptr reg3);
typed_ptr get_ok_ptr();
void env_loop_1(typed_ptr reg1, typed_ptr reg2, typed_ptr reg3);
void scan_1(typed_ptr reg1, typed_ptr reg2, typed_ptr reg3, typed_ptr reg4,
typed_ptr reg5);
typed_ptr definition_variable(typed_ptr reg);
typed_ptr make_lambda(typed_ptr reg1, typed_ptr reg2);
typed_ptr definition_value(typed_ptr reg);
void define_variable(typed_ptr reg1, typed_ptr reg2, typed_ptr reg3);
void scan_2(typed_ptr reg1, typed_ptr reg2, typed_ptr reg3, typed_ptr reg4,
typed_ptr reg5, typed_ptr reg6);
void add_binding_to_frame(typed_ptr reg1, typed_ptr reg2, typed_ptr reg3);
typed_ptr setup_environment();
typed_ptr map(const void * reg1, typed_ptr reg2);
typed_ptr primitive_procedure_names();
typed_ptr inner(typed_ptr reg);
typed_ptr primitive_procedure_objects();
typed_ptr the_global_environment;
typed_ptr get_global_environment();
typed_ptr primitive_procedures;
typed_ptr unknown_expression_type_error;
typed_ptr unknown_procedure_type_error;
typed_ptr user_read();
typed_ptr user_read_1(char *s);
typedef struct {
char *a;
char *b;
} str_pair;
str_pair user_read_2(char *s);
void user_print(typed_ptr reg);
void user_print_1(typed_ptr reg, int in_list);
void load(typed_ptr reg);
void eval_loop(char * filename, char *s);
void read_eval_print_loop();
list_structured_memory.c
//
// list_structured_memory.c
// k-scheme
//
// Created by kamimura on 11/15/14.
// Copyright (c) 2014 kamimura. All rights reserved.
//
#include "list_structured_memory.h"
const typed_ptr EMPTY_PTR = {EMPTY, {.n=0}};
const typed_ptr UNDEF_PTR = {UNDEF, {.n=0}};
const typed_ptr ERROR_PTR = {ERROR, {.n=0}};
const int MEMORY_SIZE = 1000;
typed_ptr the_cars[MEMORY_SIZE];
typed_ptr the_cdrs[MEMORY_SIZE];
const int SYMBOL_TABLE_SIZE = 10000;
char* symbol_table[SYMBOL_TABLE_SIZE];
typed_ptr quote_ptr = {SYMBOL, {.symbol=0}};
typed_ptr set_ptr = {SYMBOL, {.symbol=1}};
typed_ptr define_ptr = {SYMBOL, {.symbol=2}};
typed_ptr if_ptr = {SYMBOL, {.symbol=3}};
typed_ptr lambda_ptr = {SYMBOL, {.symbol=4}};
typed_ptr begin_ptr = {SYMBOL, {.symbol=5}};
typed_ptr procedure_ptr = {SYMBOL, {.symbol=6}};
typed_ptr primitive_ptr = {SYMBOL, {.symbol=7}};
typed_ptr false_ptr = {SYMBOL, {.symbol=8}};
typed_ptr ok_ptr = {SYMBOL, {.symbol=9}};
typed_ptr true_ptr = {SYMBOL, {.symbol=10}};
typed_ptr compound_procedure_ptr = {SYMBOL, {.symbol=11}};
typed_ptr procedure_env_ptr = {SYMBOL, {.symbol=12}};
/* primitive procedure (symbolで表現) */
typed_ptr car_ptr = {SYMBOL, {.symbol=13}};
typed_ptr cdr_ptr = {SYMBOL, {.symbol=14}};
typed_ptr cons_ptr = {SYMBOL, {.symbol=15}};
typed_ptr is_null_ptr = {SYMBOL, {.symbol=16}};
typed_ptr plus_ptr = {SYMBOL, {.symbol=17}};
typed_ptr exit_ptr = {SYMBOL, {.symbol=18}};
typed_ptr error_ptr = {SYMBOL, {.symbol=19}};
typed_ptr load_ptr = {SYMBOL, {.symbol=20}};
typed_ptr primitive_procedures;
int symbol_table_i;
const int STACK_SIZE = 10000;
typed_ptr the_stack[STACK_SIZE];
int stack_i = 0;
typed_ptr free_ptr = {POINTER, {.i=0}};
typed_ptr vector_ref(typed_ptr vector[], int n)
{
return vector[n];
}
void vector_set(typed_ptr vector[], int n, typed_ptr value)
{
vector[n] = value;
}
typed_ptr car(typed_ptr reg)
{
return vector_ref(the_cars, reg.ptr.i);
}
typed_ptr cdr(typed_ptr reg)
{
return vector_ref(the_cdrs, reg.ptr.i);
}
void set_car(typed_ptr reg1, typed_ptr reg2)
{
vector_set(the_cars, reg1.ptr.i, reg2);
}
void set_cdr(typed_ptr reg1, typed_ptr reg2)
{
vector_set(the_cdrs, reg1.ptr.i, reg2);
}
typed_ptr cons(typed_ptr reg1, typed_ptr reg2)
{
typed_ptr temp_ptr;
vector_set(the_cars, free_ptr.ptr.i, reg1);
vector_set(the_cdrs, free_ptr.ptr.i, reg2);
temp_ptr = free_ptr;
free_ptr.ptr.i++;
if (free_ptr.ptr.i == MEMORY_SIZE)
garbage_collection();
return temp_ptr;
}
int is_eq(typed_ptr reg1, typed_ptr reg2)
{
if (reg1.type == reg2.type)
switch (reg1.type) {
case POINTER: return reg1.ptr.i == reg2.ptr.i;
case INT: return reg1.ptr.n == reg2.ptr.n;
case SYMBOL: return reg1.ptr.symbol == reg2.ptr.symbol;
case EMPTY: return 1;
default: break;
}
return 0;
}
int is_pair(typed_ptr reg)
{
return reg.type == POINTER;
}
int is_null(typed_ptr reg)
{
return reg.type == EMPTY;
}
int is_symbol(typed_ptr reg)
{
return reg.type == SYMBOL;
}
typed_ptr error(char *s, int args, ...)
{
va_list ap;
int i;
fprintf(stderr, "%s ", s);
va_start(ap, args);
i = 0;
while (args > 1) {
/* エラー用のuser_printを後で実装 */
user_print(va_arg(ap, typed_ptr));
fputc(' ', stderr);
args--;
}
user_print(va_arg(ap, typed_ptr));
putchar('\n');
va_end(ap);
return ERROR_PTR;
}
void initialize_stack()
{
stack_i = 0;
}
void save(typed_ptr reg)
{
the_stack[stack_i] = reg;
stack_i++;
}
typed_ptr restore()
{
stack_i--;
return the_stack[stack_i];
}
/* for garbage collection */
typed_ptr root_ptr = {POINTER, {.i= 0}};
typed_ptr new_cars[MEMORY_SIZE];
typed_ptr new_cdrs[MEMORY_SIZE];
typed_ptr scan_ptr = {POINTER, {.i=0}};
typed_ptr old_ptr;
typed_ptr new_ptr;
void *relocate_continue;
typed_ptr oldcr_ptr;
const typed_ptr broken_heart = {BROKEN_HEART, {.n=0}};
typed_ptr temp[MEMORY_SIZE];
int k;
void garbage_collection()
{
/* begin_garbage_collection: */
free_ptr.ptr.i = 0;
scan_ptr.ptr.i = 0;
old_ptr = root_ptr;
relocate_continue = &&reassign_root;
goto relocate_old_result_in_new;
reassign_root:
root_ptr = new_ptr;
goto gc_loop;
gc_loop:
if (scan_ptr.ptr.i == free_ptr.ptr.i)
goto gc_flip;
old_ptr = vector_ref(new_cars, scan_ptr.ptr.i);
relocate_continue = &&update_car;
goto relocate_old_result_in_new;
update_car:
vector_set(new_cars, scan_ptr.ptr.i, new_ptr);
old_ptr = vector_ref(new_cdrs, scan_ptr.ptr.i);
relocate_continue = &&update_cdr;
update_cdr:
vector_set(new_cdrs, scan_ptr.ptr.i, new_ptr);
scan_ptr.ptr.i++;
goto gc_loop;
relocate_old_result_in_new:
if (is_pair(old_ptr))
goto pair;
new_ptr = old_ptr;
goto *relocate_continue;
pair:
oldcr_ptr = vector_ref(the_cars, oldcr_ptr.ptr.i);
if (is_broken_heart(oldcr_ptr))
goto already_moved;
new_ptr = free_ptr;
free_ptr.ptr.i++;
vector_set(new_cars, new_ptr.ptr.i, oldcr_ptr);
oldcr_ptr = vector_ref(the_cdrs, old_ptr.ptr.i);
vector_set(new_cars, new_ptr.ptr.i, oldcr_ptr);
vector_set(the_cars, old_ptr.ptr.i, broken_heart);
vector_set(the_cdrs, old_ptr.ptr.i, new_ptr);
goto *relocate_continue;
already_moved:
new_ptr = vector_ref(the_cdrs, old_ptr.ptr.i);
goto *relocate_continue;
gc_flip:
for (k = 0; k < MEMORY_SIZE; k++)
temp[k] = the_cdrs[k];
for (k = 0; k < MEMORY_SIZE; k++)
the_cdrs[k] = new_cdrs[k];
for (k = 0; k < MEMORY_SIZE; k++)
new_cdrs[k] = temp[k];
for (k = 0; k < MEMORY_SIZE; k++)
temp[k] = the_cars[k];
for (k = 0; k < MEMORY_SIZE; k++)
the_cars[k] = new_cars[k];
for (k = 0; k < MEMORY_SIZE; k++)
new_cars[k] = temp[k];
}
int is_broken_heart(typed_ptr reg)
{
return reg.type == BROKEN_HEART;
}
void initialize_symbol_table()
{
symbol_table[0] = strdup("quote");
symbol_table[1] = strdup("set!");
symbol_table[2] = strdup("define");
symbol_table[3] = strdup("if");
symbol_table[4] = strdup("lambda");
symbol_table[5] = strdup("begin");
symbol_table[6] = strdup("procedure");
symbol_table[7] = strdup("primitive");
symbol_table[8] = strdup("#f");
symbol_table[9] = strdup("ok");
symbol_table[10] = strdup("#t");
symbol_table[11] = strdup("compound-procedure");
symbol_table[12] = strdup("<procedure-env>");
/* primitive procedures */
symbol_table[13] = strdup("car");
symbol_table[14] = strdup("cdr");
symbol_table[15] = strdup("cons");
symbol_table[16] = strdup("null?");
symbol_table[17] = strdup("+");
symbol_table[18] = strdup("exit");
symbol_table[19] = strdup("error");
symbol_table[20] = strdup("load");
symbol_table_i = 21;
}
void clear_symbol_table()
{
symbol_index i = 0;
for (i = 0; i < symbol_table_i; i++)
free(symbol_table[i]);
}
symbol_index add_symbol(char* s)
{
symbol_index si = find_symbol(s);
if (si == -1) {
symbol_table[symbol_table_i] = strdup(s);
symbol_table_i++;
return symbol_table_i - 1;
}
return si;
}
symbol_index find_symbol(char *s)
{
symbol_index i = 0;
for (i = 0; i < symbol_table_i; i++)
if (strcmp(symbol_table[i], s) == 0)
return i;
return -1;
}
int is_self_evaluating(typed_ptr reg)
{
return is_number(reg) || is_string(reg) ? 1 : 0;
}
int is_variable(typed_ptr reg)
{
return is_symbol(reg);
}
int is_quoted(typed_ptr reg)
{
return is_tagged_list(reg, quote_ptr);
}
int is_assignment(typed_ptr reg)
{
return is_tagged_list(reg, set_ptr);
}
int is_definition(typed_ptr reg)
{
return is_tagged_list(reg, define_ptr);
}
int is_if(typed_ptr reg)
{
return is_tagged_list(reg, if_ptr);
}
int is_lambda(typed_ptr reg)
{
return is_tagged_list(reg, lambda_ptr);
}
int is_begin(typed_ptr reg)
{
return is_tagged_list(reg, begin_ptr);
}
int is_application(typed_ptr reg)
{
return is_pair(reg);
}
int is_number(typed_ptr reg)
{
return reg.type == INT;
}
int is_string(typed_ptr reg)
{
return reg.type == STRING;
}
int is_tagged_list(typed_ptr reg1, typed_ptr reg2)
{
return is_pair(reg1) && is_eq(car(reg1), reg2);
}
typed_ptr lookup_variable_value(typed_ptr reg1, typed_ptr reg2)
{
return env_loop(reg1, reg2);
}
typed_ptr env_loop(typed_ptr reg1, typed_ptr reg2)
{
typed_ptr frame;
if (is_eq(reg2, the_empty_environment)) {
error("Unbound variable ", 1, reg1);
return ERROR_PTR;
}
frame = first_frame(reg2);
return scan(reg1, reg2, frame_variables(frame), frame_values(frame));
}
typed_ptr first_frame(typed_ptr reg)
{
return car(reg);
}
typed_ptr frame_variables(typed_ptr reg)
{
return car(reg);
}
typed_ptr frame_values(typed_ptr reg)
{
return cdr(reg);
}
typed_ptr scan(typed_ptr reg1, typed_ptr reg2, typed_ptr reg3, typed_ptr reg4)
{
if (is_null(reg3))
return env_loop(reg1, enclosing_environment(reg2));
if (is_eq(reg1, car(reg3)))
return car(reg4);
return scan(reg1, reg2, cdr(reg3), cdr(reg4));
}
typed_ptr enclosing_environment(typed_ptr reg)
{
return cdr(reg);
}
typed_ptr text_of_quotation(typed_ptr reg)
{
return car(cdr(reg));
}
typed_ptr lambda_parameters(typed_ptr reg)
{
return car(cdr(reg));
}
typed_ptr lambda_body(typed_ptr reg)
{
return cdr(cdr(reg));
}
typed_ptr make_procedure(typed_ptr reg1, typed_ptr reg2, typed_ptr reg3)
{
return list(4, procedure_ptr, reg1, reg2, reg3);
}
typed_ptr list(int args, ...)
{
va_list ap;
typed_ptr reg = EMPTY_PTR;
typed_ptr regs[args];
va_start(ap, args);
int i;
for (i = 0; i < args; i++)
regs[i] = va_arg(ap, typed_ptr);
for (i = args - 1; i >= 0; i--)
reg = cons(regs[i], reg);
va_end(ap);
return reg;
}
typed_ptr operands(typed_ptr reg)
{
return cdr(reg);
}
typed_ptr operator(typed_ptr reg)
{
return car(reg);
}
typed_ptr empty_arglist()
{
return EMPTY_PTR;
}
int is_no_operands(typed_ptr reg)
{
return is_null(reg);
}
typed_ptr first_operand(typed_ptr reg)
{
return car(reg);
}
int is_last_operand(typed_ptr reg)
{
return is_null(cdr(reg));
}
typed_ptr adjoin_arg(typed_ptr reg1, typed_ptr reg2)
{
return append(reg2, list(1, reg1));
}
typed_ptr rest_operands(typed_ptr reg)
{
return cdr(reg);
}
typed_ptr append(typed_ptr reg1, typed_ptr reg2)
{
if (is_null(reg1))
return reg2;
return cons(car(reg1), append(cdr(reg1), reg2));
}
int is_primitive_procedure(typed_ptr reg)
{
return is_tagged_list(reg, primitive_ptr);
}
int is_compound_procedure(typed_ptr reg)
{
return is_tagged_list(reg, procedure_ptr);
}
typed_ptr apply_primitive_procedure(typed_ptr reg1, typed_ptr reg2)
{
return apply_in_underlying_scheme(primitive_implementation(reg1), reg2);
}
typed_ptr apply_in_underlying_scheme(typed_ptr reg1, typed_ptr reg2)
{
typed_ptr a;
typed_ptr b;
typed_ptr c;
if (is_eq(car_ptr, reg1)) return car(car(reg2));
if (is_eq(cdr_ptr, reg1)) return cdr(car(reg2));
if (is_eq(cons_ptr, reg1)) return cons(car(reg2), car(cdr(reg2)));
if (is_eq(is_null_ptr, reg1))
return is_null(car(reg2)) ? true_ptr : false_ptr;
if (is_eq(plus_ptr, reg1)) {
a = car(reg2);
b = car(cdr(reg2));
if (a.type == INT && b.type == INT) {
c.type = INT;
c.ptr.n = a.ptr.n + b.ptr.n;
return c;
}
}
if (is_eq(exit_ptr, reg1)) {
/* メモリーを解放してから */
exit(0);
}
if (is_eq(error_ptr, reg1)) {
return error("", 1, reg1);
}
if (is_eq(load_ptr, reg1)) {
load(car(reg2));
}
return UNDEF_PTR;
}
typed_ptr primitive_implementation(typed_ptr reg)
{
return car(cdr(reg));
}
typed_ptr procedure_parameters(typed_ptr reg)
{
return car(cdr(reg));
}
typed_ptr procedure_environment(typed_ptr reg)
{
return car(cdr(cdr(cdr(reg))));
}
typed_ptr extend_environment(typed_ptr reg1, typed_ptr reg2, typed_ptr reg3)
{
if (length(reg1) == length(reg2)) return cons(make_frame(reg1, reg2), reg3);
if (length(reg1) < length(reg2))
error("Too many arguments supplied", 2, reg1, reg2);
else
error("Too few arguments supplied", 2, reg1, reg2);
return reg3;
}
int length(typed_ptr reg)
{
if (is_null(reg)) return 0;
return 1 + length(cdr(reg));
}
typed_ptr make_frame(typed_ptr reg1, typed_ptr reg2)
{
return cons(reg1, reg2);
}
typed_ptr procedure_body(typed_ptr reg)
{
return car(cdr(cdr(reg)));
}
typed_ptr begin_actions(typed_ptr reg)
{
return cdr(reg);
}
typed_ptr first_expr(typed_ptr reg)
{
return car(reg);
}
int is_last_expr(typed_ptr reg)
{
return is_null(cdr(reg));
}
typed_ptr rest_exprs(typed_ptr reg)
{
return cdr(reg);
}
typed_ptr if_predicate(typed_ptr reg)
{
return car(cdr(reg));
}
int is_true(typed_ptr reg)
{
return !is_eq(reg, false_ptr);
}
typed_ptr if_alternative(typed_ptr reg)
{
return !is_null(cdr(cdr(cdr(reg)))) ? car(cdr(cdr(cdr(reg)))) : false_ptr;
}
typed_ptr if_consequent(typed_ptr reg)
{
return car(cdr(cdr(reg)));
}
typed_ptr assignment_variable(typed_ptr reg)
{
return car(cdr(reg));
}
typed_ptr assignment_value(typed_ptr reg)
{
return car(cdr(cdr(reg)));
}
void set_variable_value(typed_ptr reg1, typed_ptr reg2, typed_ptr reg3)
{
env_loop_1(reg1, reg2, reg3);
}
typed_ptr get_ok_ptr()
{
return ok_ptr;
}
void env_loop_1(typed_ptr reg1, typed_ptr reg2, typed_ptr reg3)
{
typed_ptr frame;
if (is_eq(reg3, the_empty_environment)) {
error("Unbound variable -- SET!", 1, reg1);
} else {
frame = first_frame(reg3);
scan_1(reg1, reg2, reg3, frame_variables(frame), frame_values(frame));
}
}
void scan_1(typed_ptr reg1, typed_ptr reg2, typed_ptr reg3, typed_ptr reg4,
typed_ptr reg5)
{
if (is_null(reg4)) env_loop_1(reg1, reg2, enclosing_environment(reg3));
else if (is_eq(reg1, car(reg4))) set_car(reg5, reg2);
else
scan_1(reg1, reg2, reg3, cdr(reg4), cdr(reg5));
}
typed_ptr definition_variable(typed_ptr reg)
{
return is_symbol(car(cdr(reg))) ? car(cdr(reg)) : car(car(cdr(reg)));
}
typed_ptr make_lambda(typed_ptr reg1, typed_ptr reg2)
{
return cons(lambda_ptr, cons(reg1, reg2));
}
typed_ptr definition_value(typed_ptr reg)
{
if (is_symbol(car(cdr(reg)))) return car(cdr(cdr(reg)));
return make_lambda(cdr(car(cdr(reg))), cdr(cdr(reg)));
}
void define_variable(typed_ptr reg1, typed_ptr reg2, typed_ptr reg3)
{
typed_ptr frame = first_frame(reg3);
scan_2(reg1, reg2, reg3, frame, frame_variables(frame),
frame_values(frame));
}
void scan_2(typed_ptr reg1, typed_ptr reg2, typed_ptr reg3, typed_ptr reg4,
typed_ptr reg5, typed_ptr reg6)
{
if (is_null(reg5)) add_binding_to_frame(reg1, reg2, reg4);
else if (is_eq(reg1, car(reg5))) set_car(reg6, reg2);
else scan_2(reg1, reg2, reg3, reg4, cdr(reg5), cdr(reg6));
}
void add_binding_to_frame(typed_ptr reg1, typed_ptr reg2, typed_ptr reg3)
{
set_car(reg3, cons(reg1, car(reg3)));
set_cdr(reg3, cons(reg2, cdr(reg3)));
}
typed_ptr setup_environment()
{
primitive_procedures =
list(10,
list(2, car_ptr, car_ptr),
list(2, cdr_ptr, cdr_ptr),
list(2, cons_ptr, cons_ptr),
list(2, is_null_ptr, is_null_ptr),
list(2, plus_ptr, plus_ptr),
list(2, exit_ptr, exit_ptr),
list(2, error_ptr, error_ptr),
list(2, set_ptr, set_ptr),
list(2, begin_ptr, begin_ptr),
list(2, load_ptr, load_ptr)
);
the_empty_environment = EMPTY_PTR;
typed_ptr initial_env = extend_environment(primitive_procedure_names(),
primitive_procedure_objects(),
the_empty_environment);
unknown_expression_type_error.type = UNKNOWN_EXPRESSION;
unknown_expression_type_error.ptr.n = 0;
unknown_procedure_type_error.type = UNKNOWN_PROCEDURE;
unknown_procedure_type_error.ptr.n = 0;
return initial_env;
}
typed_ptr map(const void * reg1, typed_ptr reg2)
{
typed_ptr (*reg3)(typed_ptr);
if (is_null(reg2)) return EMPTY_PTR;
reg3 = reg1;
return cons(reg3(car(reg2)), map(reg1, cdr(reg2)));
}
typed_ptr primitive_procedure_names()
{
return map(car, primitive_procedures);
}
typed_ptr primitive_procedure_objects()
{
return map(inner, primitive_procedures);
}
typed_ptr inner(typed_ptr reg)
{
return list(2, primitive_ptr, car(cdr(reg)));
}
typed_ptr get_global_environment()
{
val = UNDEF_PTR;
return the_global_environment;
}
typed_ptr user_read()
{
char line[1000];
char lines[1000000];
char begin[] = "(begin ";
char *s;
int i;
int j;
int k;
int parentheses = 0;
for (i = 0; i < 7; i++)
lines[i] = begin[i];
while (1) {
if (fgets(line, sizeof(line), stdin) == NULL)
exit(0);
for (j = 0; line[j] != '\0'; j++) {
if (line[j] == '(') parentheses--;
else if (line[j] == ')') parentheses++;
}
for (k = 0; k < j; k++, i++)
lines[i] = line[k];
if (parentheses >= 0) break;
}
lines[i] = ')';
lines[i + 1] = '\0';
s = strdup(lines);
return user_read_1(s);
}
typed_ptr user_read_1(char *s)
{
typed_ptr ptr;
char *s1 = s;
char *s2;
symbol_index si;
typed_ptr ptr1;
typed_ptr ptr2;
str_pair sp;
while (isspace(*s) && *s != '\0')
s++;
s2 = s;
if (*s == '\'') {
s2 = strdup(s + 1);
ptr = list(2, quote_ptr, user_read_1(s2));
} else if (isdigit(*s)) {
ptr.type = INT;
while (!isspace(*s) && *s != '\0')
s++;
*s = '\0';
ptr.ptr.n = atoi(s2);
} else if (*s == '"') {
ptr.type = STRING;
s++;
s2 = s;
while (*s != '"' || *(s - 1) == '\\')
s++;
*s = '\0';
ptr.ptr.str = strdup(s2);
*s = '"';
} else if (*s == '(') {
/* リストの場合 */
s++;
while (isspace(*s))
s++;
if (*s == ')') ptr = EMPTY_PTR;
else {
s2 = strdup(s);
sp = user_read_2(s2);
ptr1 = user_read_1(sp.a);
ptr2 = user_read_1(sp.b);
ptr = cons(ptr1, ptr2);
}
} else {
/* 記号の場合 */
ptr.type = SYMBOL;
while (!isspace(*s) && *s != '\0')
s++;
*s = '\0';
si = find_symbol(s2);
if (si != -1) {
ptr.ptr.symbol = si;
} else
ptr.ptr.symbol = add_symbol(s2);
}
free(s1);
return ptr;
}
str_pair user_read_2(char *s)
{
char *s1 = s;
str_pair sp;
char ch;
int parentheses;
switch(*s) {
case '"':
s++;
while (*s != '"' || *(s - 1) == '\\')
s++;
s++;
ch = *s;
*s = '\0';
sp.a = strdup(s1);
*s = ch;
if (*s == ')')
sp.b = strdup("()");
else {
s--;
*s = '(';
sp.b = strdup(s);
}
break;
case '(':
parentheses = -1;
while (parentheses != 0) {
s++;
if (*s == '(')
parentheses--;
else if (*s == ')')
parentheses++;
}
s++;
ch = *s;
*s = '\0';
sp.a = strdup(s1);
*s = ch;
s--;
*s = '(';
sp.b = strdup(s);
break;
case '\'':
if (*(s + 1) == '(') {
s++;
parentheses = -1;
while (parentheses != 0) {
s++;
if (*s == '(')
parentheses--;
else if (*s == ')')
parentheses++;
}
s++;
ch = *s;
sp.a = strdup(s1);
*s = ch;
s--;
*s = '(';
sp.b = strdup(s);
break;
}
default:
while (!isspace(*s) && *s != ')')
s++;
char ch = *s;
*s = '\0';
sp.a = strdup(s1);
*s = ch;
if (*s == ')')
sp.b = strdup("()");
else {
*s = '(';
sp.b = strdup(s);
}
break;
}
free(s1);
return sp;
}
void user_print(typed_ptr reg)
{
if (is_compound_procedure(reg))
user_print(list(4, compound_procedure_ptr, procedure_parameters(reg),
procedure_body(reg), procedure_env_ptr));
else {
switch (reg.type) {
case POINTER: user_print_1(reg, 0); break;
case SYMBOL: printf("%s", symbol_table[reg.ptr.symbol]); break;
case INT: printf("%d", reg.ptr.n); break;
case EMPTY: printf("()"); break;
case STRING: printf("\"%s\"", reg.ptr.str); break;
case UNDEF: printf("<undefined>");
case ERROR: fprintf(stderr, "ERROR"); break;
case UNKNOWN_EXPRESSION:
fprintf(stderr, "Unknown expression type error");
break;
case UNKNOWN_PROCEDURE:
fprintf(stderr, "Unknown procedure type error");
break;
default: break;
}
}
}
void user_print_1(typed_ptr reg, int in_list)
{
typed_ptr ptr1 = car(reg);
typed_ptr ptr2 = cdr(reg);
if (!in_list)
putchar('(');
user_print(ptr1);
switch (ptr2.type) {
case POINTER:
putchar(' ');
user_print_1(ptr2, 1);
break;
case EMPTY: printf(") "); break;
default:
printf(" . ");
user_print(ptr2);
printf(") ");
break;
}
}
void load(typed_ptr reg)
{
char begin[] = "(begin ";
char lines[1000000];
char *s;
char *filename = strdup(reg.ptr.str);
FILE *in_file = fopen(filename, "r");
char ch;
int i;
for (i = 0; i < 7; i++)
lines[i] = begin[i];
for (; (ch = fgetc(in_file)) != EOF; i++)
lines[i] = ch;
lines[i] = ')';
lines[i + 1] = '\0';
s = strdup(lines);
eval_loop(filename, s);
fclose(in_file);
read_eval_print_loop();
}
/* load procedure用 */
void eval_loop(char * filename, char *s)
{
/* read_eval_loop: */
/* if (GLOBAL) { */
/* puts("**************************************************"); */
/* puts("グローバル環境"); */
/* user_print(the_global_environment); */
/* puts("\n**************************************************"); */
/* } */
/* initialize_stack(); */
/* puts(";;; EC-EVAL input:"); */
/* puts(";;; kscheme input:"); */
expr = user_read_1(s);
/* env = get_global_environment(); */
save(cont);
cont.ptr.ptr = &&loaded;
goto eval_dispatch;
/* print_result: */
/* /\* puts(";;; EC-EVAL value:"); *\/ */
/* /\* puts(";;; kscheme value:"); *\/ */
/* user_print(val); */
/* putchar('\n'); */
/* fflush(stdout); */
/* goto read_eval_loop; */
unknown_expression_type:
val = unknown_expression_type_error;
goto signal_error;
unknown_procedure_type:
cont = restore();
val = unknown_procedure_type_error;
goto signal_error;
signal_error:
user_print(val);
putchar('\n');
goto loaded;
eval_dispatch:
if (is_self_evaluating(expr)) goto ev_self_eval;
if (is_variable(expr)) goto ev_variable;
if (is_quoted(expr)) goto ev_quoted;
if (is_assignment(expr)) goto ev_assignment;
if (is_definition(expr)) goto ev_definition;
if (is_if(expr)) goto ev_if;
if (is_lambda(expr)) goto ev_lambda;
if (is_begin(expr)) goto ev_begin;
if (is_application(expr)) goto ev_application;
goto unknown_expression_type;
ev_self_eval:
val = expr;
goto *(cont.ptr.ptr);
ev_variable:
val = lookup_variable_value(expr, env);
goto *(cont.ptr.ptr);
ev_quoted:
val = text_of_quotation(expr);
goto *(cont.ptr.ptr);
ev_lambda:
unev = lambda_parameters(expr);
expr = lambda_body(expr);
val = make_procedure(unev, expr, env);
goto *(cont.ptr.ptr);
ev_application:
save(cont);
save(env);
unev = operands(expr);
save(unev);
expr = operator(expr);
cont.ptr.ptr = &&ev_appl_did_operator;
goto eval_dispatch;
ev_appl_did_operator:
unev = restore();
env = restore();
argl = empty_arglist();
proc = val;
if (is_no_operands(unev))
goto apply_dispatch;
save(proc);
ev_appl_operand_loop:
save(argl);
expr = first_operand(unev);
if (is_last_operand(unev))
goto ev_appl_last_arg;
save(env);
save(unev);
cont.ptr.ptr = &&ev_appl_accumulate_arg;
goto eval_dispatch;
ev_appl_accumulate_arg:
unev = restore();
env = restore();
argl = restore();
argl = adjoin_arg(val, argl);
unev = rest_operands(unev);
goto ev_appl_operand_loop;
ev_appl_last_arg:
cont.ptr.ptr = &&ev_appl_accum_last_arg;
goto eval_dispatch;
ev_appl_accum_last_arg:
argl = restore();
argl = adjoin_arg(val, argl);
proc = restore();
goto apply_dispatch;
apply_dispatch:
if (is_primitive_procedure(proc))
goto primitive_apply;
if (is_compound_procedure(proc))
goto compound_apply;
goto unknown_procedure_type;
primitive_apply:
val = apply_primitive_procedure(proc, argl);
cont = restore();
goto *(cont.ptr.ptr);
compound_apply:
unev = procedure_parameters(proc);
env = procedure_environment(proc);
env = extend_environment(unev, argl, env);
unev = procedure_body(proc);
goto ev_sequence;
ev_begin:
unev = begin_actions(expr);
save(cont);
goto ev_sequence;
ev_sequence:
expr = first_expr(unev);
if (is_last_expr(unev))
goto ev_sequence_last_exp;
save(unev);
save(env);
cont.ptr.ptr = &&ev_sequence_continue;
goto eval_dispatch;
ev_sequence_continue:
env = restore();
unev = restore();
unev = rest_exprs(unev);
goto ev_sequence;
ev_sequence_last_exp:
cont = restore();
goto eval_dispatch;
ev_if:
save(expr);
save(env);
save(cont);
cont.ptr.ptr = &&ev_if_decide;
expr = if_predicate(expr);
goto eval_dispatch;
ev_if_decide:
cont = restore();
env = restore();
expr = restore();
if (is_true(val))
goto ev_if_consequent;
/* ev_if_alternative: */
expr = if_alternative(expr);
goto eval_dispatch;
ev_if_consequent:
expr = if_consequent(expr);
goto eval_dispatch;
ev_assignment:
unev = assignment_variable(expr);
save(unev);
expr = assignment_value(expr);
save(env);
save(cont);
cont.ptr.ptr = &&ev_assignment_1;
goto eval_dispatch;
ev_assignment_1:
cont = restore();
env = restore();
unev = restore();
set_variable_value(unev, val, env);
val = get_ok_ptr();
goto *(cont.ptr.ptr);
ev_definition:
unev = definition_variable(expr);
save(unev);
expr = definition_value(expr);
save(env);
save(cont);
cont.ptr.ptr = &&ev_definition_1;
goto eval_dispatch;
ev_definition_1:
cont = restore();
env = restore();
unev = restore();
define_variable(unev, val, env);
val = get_ok_ptr();
goto *(cont.ptr.ptr);
loaded:
cont = restore();
printf("%s is loaded.\n", filename);
read_eval_print_loop();
}
Makefile
P=kscheme CC=cc CFLAGS=-g -Wall # -O3 SRC=main.c list_structured_memory.c OBJ=main.o list_structured_memory.o LDLIBS= $(P): $(OBJ) $(CC) $(CFLAGS) $(LDLIBS) $(OBJ) -o $@ main.o: list_structured_memory.o main.c $(CC) $(CFLAGS) -c main.c -o $@ list_structured_memory.o: list_structured_memory.c $(CC) $(CFLAGS) -c list_structured_memory.c -o $@
入出力結果(Terminal, REPL(Read, Eval, Print, Loop))
$ make
cc -g -Wall -c list_structured_memory.c -o list_structured_memory.o
cc -g -Wall -c main.c -o main.o
cc -g -Wall main.o list_structured_memory.o -o kscheme
$ ./kscheme
;;; kscheme input:
5
;;; kscheme value:
5
;;; kscheme input:
"kamimura"
;;; kscheme value:
"kamimura"
;;; kscheme input:
(cons 1 2)
;;; kscheme value:
(1 . 2)
;;; kscheme input:
(cons 1 (cons 2 3))
;;; kscheme value:
(1 2 . 3)
;;; kscheme input:
(cons 1 (cons 2 '()))
;;; kscheme value:
(1 2)
;;; kscheme input:
(cons (cons 1 2)
(cons 3 4))
;;; kscheme value:
((1 . 2) 3 . 4)
;;; kscheme input:
(cons "1" 1)
;;; kscheme value:
("1" . 1)
;;; kscheme input:
(define a (cons 1 2))
;;; kscheme value:
ok
;;; kscheme input:
(car a)
;;; kscheme value:
1
;;; kscheme input:
(cdr a)
;;; kscheme value:
2
;;; kscheme input:
(define a (cons '() (cons (cons 1 2) (cons 3 4))))
;;; kscheme value:
ok
;;; kscheme input:
(car a
)
;;; kscheme value:
()
;;; kscheme input:
(cdr a)
;;; kscheme value:
((1 . 2) 3 . 4)
;;; kscheme input:
(car (cdr a))
;;; kscheme value:
(1 . 2)
;;; kscheme input:
(cdr (cdr a))
;;; kscheme value:
(3 . 4)
;;; kscheme input:
(car (cdr (cdr a)))
;;; kscheme value:
3
;;; kscheme input:
(cdr (cdr (cdr a)))
;;; kscheme value:
4
;;; kscheme input:
(exit)
$
0 コメント:
コメントを投稿