Scheme - C言語による Scheme の interpreter (k-scheme, kscheme) (算術演算、加減乗除(+, -, *, /))

開発環境

OS X Yosemite - Apple, Ubuntu (OS)
Emacs (CUI)、BBEdit - Bare Bones Software, Inc. (GUI) (Text Editor)
C (プログラミング言語)
Clang/LLVM (コンパイラ, Xcode - Apple)

Schemeの処理系(解釈系、評価機、レジスタ計算機を翻訳したもの)を少しずつ書き進めてめていくことに。

算術演算、加減乗除(+, -, *, /)を追加。

参考書籍等

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 0
#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.
//

#ifndef __k_scheme__list_structured_memory__
#define __k_scheme__list_structured_memory__

#include <stdio.h>
#include <stdlib.h>
#include <string.h>
#include <stdarg.h>
#include <ctype.h>
#include <errno.h>

typedef enum {
  SYMBOL, INT, RATIONAL, DOUBLE, CHAR, STRING, POINTER, EMPTY, BROKEN_HEART,
  CONT, 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 struct {
  int pm;                       /* 1なら+、0なら- */
  int a;
  int b;
} rational;
typedef union {
  vect_index i;                 /* POINTER */
  int n;                        /* INT */
  rational r;                   /* RATIONAL */
  double d;                     /* DOUBLE */
  char ch;                      /* CHAR */
  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_char(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 error(char *s, int args, ...);

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 string_print(typed_ptr reg);

void load(typed_ptr reg);
void eval_loop(char * filename, char *s);

void read_eval_print_loop();

int gcd(int a, int b);
  
#endif /* defined(__k_scheme__list_structured_memory__) */

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 <math.h>

#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 add_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 sub_ptr = {SYMBOL, {.symbol=21}};
typed_ptr mul_ptr = {SYMBOL, {.symbol=22}};
typed_ptr div_ptr = {SYMBOL, {.symbol=23}};

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[21] = strdup("-");
  symbol_table[22] = strdup("*");
  symbol_table[23] = strdup("/");
  symbol_table_i = 24;
}

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) || is_char(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)
{
  switch (reg.type) {
  case INT:
  case RATIONAL:
  case DOUBLE: return 1;
  default: return 0;
  }
}

int is_char(typed_ptr reg)
{
  return reg.type == CHAR;
}

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;
  int n;
  int m;
  int g;
    
  if (is_eq(car_ptr, reg1)) c = car(car(reg2));
  else if (is_eq(cdr_ptr, reg1)) c = cdr(car(reg2));
  else if (is_eq(cons_ptr, reg1)) c = cons(car(reg2), car(cdr(reg2)));
  else if (is_eq(is_null_ptr, reg1))
    c = is_null(car(reg2)) ? true_ptr : false_ptr;
  else if (is_eq(add_ptr, reg1)) {
    a = car(reg2);
    b = car(cdr(reg2));
    switch (a.type) {
    case INT:
      switch (b.type) {
      case INT:
        c.type = INT;
        c.ptr.n = a.ptr.n + b.ptr.n;
        break;
      case RATIONAL:
        c.type = RATIONAL;
        n = a.ptr.n * (b.ptr.r.pm ? 1 : -1) * b.ptr.r.b + b.ptr.r.a;
        m = b.ptr.r.b;
        c.ptr.r.pm = n >= 0;
        n = abs(n);
        g = gcd(n, m);
        n /= g;
        m /= g;
        c.ptr.r.a = n;
        c.ptr.r.b = m;
        break;
      case DOUBLE:
        c.type = DOUBLE;
        c.ptr.d = (double)a.ptr.n + b.ptr.d;
        break;
      default: break;
      }
      break;
    case RATIONAL:
      switch (b.type) {
      case INT: c = apply_in_underlying_scheme(reg1, list(2, b, a)); break;
      case RATIONAL:
        c.type = RATIONAL;
        c.ptr.r.pm = a.ptr.r.pm == b.ptr.r.pm;
        n = a.ptr.r.a * b.ptr.r.b + a.ptr.r.b * b.ptr.r.a;
        m = a.ptr.r.b * b.ptr.r.b;
        g = gcd(n, m);
        n /= g;
        m /= g;
        c.ptr.r.a = n < 0 ? -1 * n : n;
        c.ptr.r.b = m < 0 ? -1 * m : m;
        break;
      case DOUBLE:
        c.type = DOUBLE;
        c.ptr.d =  (double)a.ptr.r.a / a.ptr.r.b + b.ptr.d;
        break;
      default: break;
      }
      break;
    case DOUBLE:
      switch (b.type) {
      case INT:
      case RATIONAL: c = apply_in_underlying_scheme(reg1, list(2, b, a)); break;
      case DOUBLE:
        c.type = DOUBLE;
        c.ptr.d = a.ptr.d + b.ptr.d;
        break;
      default: break;
      }
      break;
    default: break;
    }
  } else if (is_eq(reg1, sub_ptr)) {
    a = car(reg2);
    b = car(cdr(reg2));
    switch (a.type) {
    case INT:
      switch (b.type) {
      case INT:
        c.type = INT;
        c.ptr.n = a.ptr.n - b.ptr.n;
        break;
      case RATIONAL:
        c.type = RATIONAL;
        n =
          (a.ptr.r.pm == b.ptr.r.pm  ? 1 : -1) * a.ptr.n * b.ptr.r.b -
          a.ptr.r.b * b.ptr.r.a;
        m = b.ptr.r.b;
        c.ptr.r.pm = n >= 0;
        n = abs(n);
        g = gcd(n, m);
        c.ptr.r.a = n / g;
        c.ptr.r.b = m / g;
        break;
      case DOUBLE:
        c.type = DOUBLE;
        c.ptr.d = (double)a.ptr.n - b.ptr.d;
        break;
      default: break;
      }
      break;
    case RATIONAL:
      switch (b.type) {
      case INT:
        c.type = RATIONAL;
        n = (a.ptr.r.pm ? 1 : -1) * a.ptr.r.a - b.ptr.n * a.ptr.r.b;
        m = a.ptr.r.b;
        c.ptr.r.pm = n >= 0;
        n = abs(n);
        g = gcd(n, m);
        c.ptr.r.a = n / g;
        c.ptr.r.b = m / g;
        break;
      case RATIONAL:
        c.type = RATIONAL;
        n =
          (a.ptr.r.pm ? 1 : -1) * a.ptr.r.a * b.ptr.r.b -
          (b.ptr.r.pm ? 1 : -1) * a.ptr.r.b * b.ptr.r.a;
        m = a.ptr.r.b * b.ptr.r.b;
        c.ptr.r.pm = n >= 0;
        n = abs(n);
        g = gcd(n, m);
        c.ptr.r.a = n / g;
        c.ptr.r.b = m / g;
        break;
      case DOUBLE:
        c.type = DOUBLE;
        c.ptr.d = (double)a.ptr.r.a / a.ptr.r.b - b.ptr.d;
        break;
      default: break;
      }
      break;
    case DOUBLE:
      switch (b.type) {
      case INT:
        c.type = DOUBLE;
        c.ptr.d = a.ptr.d - (double)b.ptr.n;
        break;
      case RATIONAL:
        c.type = DOUBLE;
        c.ptr.d =
          a.ptr.d -
          (b.ptr.r.pm ? 1 : -1) * (double)b.ptr.r.a / b.ptr.r.b;
        break;
      case DOUBLE:
        c.type = DOUBLE;
        c.ptr.d = a.ptr.d - b.ptr.d;
      default: break;
      }
      break;
    default: break;
    }
  } else if (is_eq(reg1, mul_ptr)) {
    a = car(reg2);
    b = car(cdr(reg2));
    switch (a.type) {
    case INT:
      switch (b.type) {
      case INT:
        c.type = INT;
        c.ptr.n = a.ptr.n * b.ptr.n;
        break;
      case RATIONAL:
        c.type = RATIONAL;
        c.ptr.r.pm = a.ptr.n >= 0 == b.ptr.r.pm;
        n = abs(a.ptr.n) * b.ptr.r.a;
        m = b.ptr.r.b;
        g = gcd(n, m);
        c.ptr.r.a = n / g;
        c.ptr.r.b = m / g;
        break;
      case DOUBLE:
        c.type = DOUBLE;
        c.ptr.d = a.ptr.n * b.ptr.d;
        break;
      default: break;
      }
      break;
    case RATIONAL:
      switch (b.type) {
      case INT: c = apply_in_underlying_scheme(reg1, list(2, b, a)); break;
      case RATIONAL:
        c.type = RATIONAL;
        c.ptr.r.pm = a.ptr.r.pm == b.ptr.r.pm;
        n = a.ptr.r.a * b.ptr.r.a;
        m = a.ptr.r.b * b.ptr.r.b;
        g = gcd(n, m);
        c.ptr.r.a = n / g;
        c.ptr.r.b = m / g;
        break;
      case DOUBLE:
        c.type = DOUBLE;
        c.ptr.d =
          (a.ptr.r.pm ? 1 : -1) * (double)a.ptr.r.a / a.ptr.r.b * b.ptr.d;
        break;
      default: break;
      }
      break;
    case DOUBLE:
      switch (b.type) {
      case INT:
      case RATIONAL: c = apply_in_underlying_scheme(reg1, list(2, b, a)); break;
      case DOUBLE:
        c.type = DOUBLE;
        c.ptr.d = a.ptr.d * b.ptr.d;
        break;
      default: break;
      }
      break;
    default: break;
    }
  } else if (is_eq(reg1, div_ptr)) {
    a = car(reg2);
    b = car(cdr(reg2));
    switch (a.type) {
    case INT:
      switch (b.type) {
      case INT:
        c.type = RATIONAL;
        c.ptr.r.pm = a.ptr.n * b.ptr.n >= 0 ? 1 : 0;
        n = abs(a.ptr.n);
        m = abs(b.ptr.n);
        g = gcd(n, m);
        c.ptr.r.a = n / g;
        c.ptr.r.b = m / g;
        break;
      case RATIONAL:
        c.type = RATIONAL;
        c.ptr.r.pm = (a.ptr.n >= 0) == b.ptr.r.pm;
        n = abs(a.ptr.n) * b.ptr.r.b;
        m = b.ptr.r.a;
        g = gcd(n, m);
        c.ptr.r.a = n / g;
        c.ptr.r.b = m / g;
        break;
      case DOUBLE:
        c.type = DOUBLE;
        c.ptr.d = a.ptr.n / b.ptr.d;
        break;
      default: break;
      }
      break;
    case RATIONAL:
      switch (b.type) {
      case INT:
        c.type = RATIONAL;
        c.ptr.r.pm = a.ptr.r.pm == (b.ptr.n >= 0);
        c.ptr.r.a = a.ptr.r.a * abs(b.ptr.n);
        c.ptr.r.b = b.ptr.r.b;
        break;
      case RATIONAL:
        c.type = RATIONAL;
        c.ptr.r.pm = a.ptr.r.pm == b.ptr.r.pm;
        n = a.ptr.r.a * b.ptr.r.b;
        m = a.ptr.r.b * b.ptr.r.a;
        g = gcd(n, m);
        c.ptr.r.a = n / g;
        c.ptr.r.b = m / g;
        break;
      case DOUBLE:
        c.type = DOUBLE;
        c.ptr.d =
          (a.ptr.r.pm ? 1 : - 1) * (double)a.ptr.r.a / a.ptr.r.b / b.ptr.d;
        break;
      default: break;
      }
      break;
    case DOUBLE:
      switch (b.type) {        
      case INT:
        c.type = DOUBLE;
        c.ptr.d = a.ptr.d / b.ptr.n;
        break;
      case RATIONAL:
        c.type = DOUBLE;
        c.ptr.d =
          a.ptr.d * (a.ptr.r.pm ? 1 : -1) * (double)b.ptr.r.b / b.ptr.r.a;
        break;
      case DOUBLE:
        c.type = DOUBLE;
        c.ptr.d = a.ptr.d / b.ptr.d;
        break;
      default: break;
      }
      break;
    default: break;
    }
  }
  else if (is_eq(exit_ptr, reg1)) {
    /* メモリーを解放してから */
    exit(0);
  }
  else if (is_eq(error_ptr, reg1)) c =  error("", 1, reg1);
  else if (is_eq(load_ptr, reg1)) load(car(reg2));
  return c;
}

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(13,
         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, add_ptr, add_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),
         list(2, sub_ptr, sub_ptr),
         list(2, mul_ptr, mul_ptr),
         list(2, div_ptr, div_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;
  int flag = 1;
  int in_string = 0;
    
  for (i = 0; i < 7; i++)
    lines[i] = begin[i];
    
  while (1) {
    if (fgets(line, sizeof(line), stdin) == NULL)
      exit(0);
    /* 最初が空白行か確認 */
    if (flag) {
      for (j = 0; isspace(line[j]) && line[j] != '\n';j++)
        putchar(line[j]);
      /* 空白 */
      if (line[j] == '\n') continue;
      flag = 0;
    }
    for (j = 0; line[j] != '\0'; j++) {
      /* マルチライン文字列に対応 */
      if (line[j] == '"') {
        if (in_string && (j == 0 ||
                          line[j - 1] != '\\' ||
                          (line[j - 1] == '\\' && line[j - 2] == '\\')))
          in_string = 0;
        else
          in_string = 1;
      }
        
      if (!in_string && line[j] == '(') parentheses--;
      else if (!in_string && line[j] == ')') parentheses++;
    }
    for (k = 0; k < j; k++, i++)
      lines[i] = line[k];
    if (parentheses >= 0 && !in_string) 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;
  char ch;
  int pm = 1;
    
  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) || (*s == '-' && isdigit(*(s + 1)))) {
    if (*s == '-') {
      pm = 0;
      s++;
    }
    while (isdigit(*s))
      s++;
    /* 整数の場合 */
    if (*s == '\0' || isspace(*s)) {
      ptr.type = INT;
      ch = *s;
      *s = '\0';
      ptr.ptr.n = pm ? atoi(s2) : -1 * atoi(s2 + 1);
      *s = ch;
      /* 有理数の場合 */
    } else if (*s == '/') {
      int a;
      int b;
      int g;
      int pm1 = 1;
      ptr.type = RATIONAL;
      *s = '\0';
      a = pm ? atoi(s2) : atoi(s2 + 1);
      *s = '/';
      s++;
      if (*s == '-') {
        pm1 = 0;
        s++;
      }
      s2 = s;
      while (isdigit(*s))
        s++;
      ch = *s;
      *s = '\0';
      b = atoi(s2);
      if (b != 0) {
        g = gcd(a, b);
        a = a / g;
        b = b / g;
      }
      ptr.ptr.r.a = a;
      ptr.ptr.r.b = b;
      *s = ch;
      pm = pm == pm1 ? 1 : 0;
      ptr.ptr.r.pm = pm;
      /* 実数の場合 */
    } else if (*s == '.' ) {
      ptr.type = DOUBLE;
      s++;
      while (isdigit(*s))
        s++;
      ch = *s;
      *s = '\0';
      ptr.ptr.d = atof(s2);
      *s = ch;
    }
    /* 文字の場合 */
  } else if (*s == '#') {
    /* 文字の場合 */
    if (*(s + 1) == '\\') {
      ptr.type = CHAR;
      ptr.ptr.ch = *(s + 2);
    }
    /* 文字列の場合 */
  } else if (*s == '"') {
    ptr.type = STRING;
    s2 = s;
    s++;
    while (*s != '"') {
      if (*s == '\\' && (*(s + 1) == '"' || *(s + 1) == '\\')) s += 2;
      else s++;
    }
    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 != '"') {
      if (*s == '\\' && (*(s + 1) == '"' || *(s + 1) == '\\')) s += 2;
      else 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;
    /* 文字の場合 */
  case '#':
    /* 文字の場合 */
    if (*(s + 1) == '\\') {
      ch = *(s + 3);
      *(s + 3) = '\0';
      sp.a = strdup(s1);
      *(s + 3) = ch;
      if (*(s + 3) == ')')
        sp.b = strdup("()");
      else {
        *(s + 2) = '(';
        sp.b = strdup(s + 2);
      }
    }
    break;
  default:
    while (!isspace(*s) && *s != ')')
      s++;
    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 RATIONAL:
      if (reg.ptr.r.b == 0) fprintf(stderr ,"Divided by zero.");
      else {
        if (!reg.ptr.r.pm) putchar('-');
        if (reg.ptr.r.b == 1) printf("%d", reg.ptr.r.a);
        else printf("%d/%d", reg.ptr.r.a, reg.ptr.r.b);
      }
      break;
    case DOUBLE:
      printf("%g", reg.ptr.d);
      if (reg.ptr.d == floor(reg.ptr.d)) printf(".0");
      break;
    case EMPTY: printf("()"); break;
      /* エスケープシーケンス可視化した出力に対応 */
    case CHAR:
      printf("#\\");
      switch (reg.ptr.ch) {
      case '\b': printf("backspace"); break;
      case '\f': printf("page"); break;
      case '\n': printf("newline"); break;
      case '\r': printf("return"); break;
      case '\t': printf("tab"); break;
      case '\\': putchar('\\'); break;
      default: putchar(reg.ptr.ch); break;
      }
      break;
    case STRING: string_print(reg); 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 string_print(typed_ptr reg)
{
  char *s = reg.ptr.str;

  while (*s != '\0') {
    switch(*s) {
    case '\b': printf("\\b"); break;
    case '\f': printf("\\f"); break;
    case '\n': printf("\\n"); break;
    case '\r': printf("\\r"); break;
    case '\t': printf("\\t"); break;
    case '\\': putchar('\\'); break;
    default: putchar(*s); break;
    }
    s++;
  }
}

void load(typed_ptr reg)
{
  char begin[] = "(begin ";
  char lines[1000000];
  char *s;
  char *filename = reg.ptr.str + 1;
  FILE *in_file;
  char ch;
  int i;

  *(filename + strlen(filename) - 1) = '\0';
  in_file = fopen(filename, "r");
  if (in_file == NULL) {
    fprintf(stderr, "%s\n", strerror(errno));
    read_eval_print_loop();
  }
  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);
  free(reg.ptr.str);
  read_eval_print_loop();
}

/* load procedure用 */
void eval_loop(char * filename, char *s)
{
  /* read_eval_loop: ラベル以下削除*/
  expr = user_read_1(s);
  /* env = get_global_environment(); すでに取得済み*/
  save(cont);
  cont.ptr.ptr = &&loaded;
  goto eval_dispatch;
  /* print_result: ラベル以下削除*/
 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();
}

/* ユークリッド互除法 */
int gcd(int a, int b)
{
  int r = a % b;
  
  while (r != 0) {
    a = b;
    b = r;
    r = a % b;
  }
  return b;
}

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(gosh), 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
$

Kamimura's blog

2014年11月21日金曜日

Scheme - C言語による Scheme の interpreter (k-scheme, kscheme) (算術演算、加減乗除(+, -, *, /))

0 コメント:

コメントを投稿