magic/vm-src/builtins.c

#include <stdio.h>
#include <stdlib.h>
#include <string.h>
#include <assert.h>

#include "tags.h"
#include "builtins.h"
#include "bytecode.h"
#include "symboltable.h"
#include "gc.h"

void scm_display(scm x) {
  switch(scm_get_tag(x)) {
  case atom_tag_fals:
    printf("%s", "#f");
    break;
    
  case atom_tag_true:
    printf("%s", "#t");
    break;
    
  case atom_tag_null:
    printf("%s", "()");
    break;
    
  case atom_tag_symb:
    printf("%s", lookup(get_symb(x)));
    break;
    
  case atom_tag_char:
    printf("%c", get_char(x));
    break;
    
  case tag_numb:
    printf("%ld", get_numb(x));
    break;
    
  case tag_cons:
    printf("<PAIR>");
    break;
    
  case tag_clos:
    printf("<CLOS>");
    break;
    
  case tag_vect:
    printf("<VECT>");
    break;
    
  case tag_strn:
    printf("%s", (char*)get_strn_data(x));
    break;
    
  default:
    printf("<UNKNOWN>");
  }
}

scm builtin_display() {
  assert(bytecode_args_num == 1);
  scm_display(bytecode_args[0]);
  return 0;
}

scm builtin_newline() {
  puts("");
  return 0;
}

//

scm builtin_cons() {
  assert(bytecode_args_num == 2);
  return heap_alloc_cons(bytecode_args[0], bytecode_args[1]);
}

scm builtin_car() {
  assert(bytecode_args_num == 1);
  return get_cons_car(bytecode_args[0]);
}

scm builtin_cdr() {
  assert(bytecode_args_num == 1);
  return get_cons_cdr(bytecode_args[0]);
}

scm builtin_set_car() {
  assert(bytecode_args_num == 2);
  set_cons_car(bytecode_args[0], bytecode_args[1]);
  return 0;
}

scm builtin_set_cdr() {
  assert(bytecode_args_num == 2);
  set_cons_cdr(bytecode_args[0], bytecode_args[1]);
  return 0;
}

//

scm builtin_nullq() {
  assert(bytecode_args_num == 1);
  return mk_bool(scm_get_tag(bytecode_args[0])
		 == atom_tag_null);
}

scm builtin_pairq() {
  assert(bytecode_args_num == 1);
  return mk_bool(scm_get_tag(bytecode_args[0])
		 == tag_cons);
}

scm builtin_numberq() {
  assert(bytecode_args_num == 1);
  return mk_bool(scm_get_tag(bytecode_args[0])
		 == tag_numb);
}

scm builtin_booleanq() {
  assert(bytecode_args_num == 1);
  return mk_bool((scm_get_tag(bytecode_args[0])
		  == atom_tag_fals) ||
		 (scm_get_tag(bytecode_args[0])
		  == atom_tag_true));
}

scm builtin_stringq() {
  assert(bytecode_args_num == 1);
  return mk_bool(scm_get_tag(bytecode_args[0])
		 == tag_strn);
}

scm builtin_charq() {
  assert(bytecode_args_num == 1);
  return mk_bool(scm_get_tag(bytecode_args[0])
		 == atom_tag_char);
}

scm builtin_symbolq() {
  assert(bytecode_args_num == 1);
  return mk_bool(scm_get_tag(bytecode_args[0])
		 == atom_tag_symb);
}

scm builtin_vectorq() {
  assert(bytecode_args_num == 1);
  return mk_bool(scm_get_tag(bytecode_args[0])
		 == tag_vect);
}

//

scm builtin_add() {
  assert(bytecode_args_num == 2);
  return mk_numb(get_numb(bytecode_args[0])
		 + get_numb(bytecode_args[1]));
}

scm builtin_subtract() {
  assert(bytecode_args_num == 2);
  return mk_numb(get_numb(bytecode_args[0])
		 - get_numb(bytecode_args[1]));
}

scm builtin_multiply() {
  assert(bytecode_args_num == 2);
  return mk_numb(get_numb(bytecode_args[0])
		 * get_numb(bytecode_args[1]));
}

scm builtin_quotient() {
  assert(bytecode_args_num == 2);
  return mk_numb(get_numb(bytecode_args[0])
		 / get_numb(bytecode_args[1]));
}

scm builtin_modulo() {
  assert(bytecode_args_num == 2);
  return mk_numb(get_numb(bytecode_args[0])
		 % get_numb(bytecode_args[1]));
}

scm builtin_eq() {
  assert(bytecode_args_num == 2);
  return mk_bool(bytecode_args[0]
		 == bytecode_args[1]);
}

scm builtin_lt() {
  assert(bytecode_args_num == 2);
  return mk_bool(get_numb(bytecode_args[0])
		 < get_numb(bytecode_args[1]));
}

scm builtin_gt() {
  assert(bytecode_args_num == 2);
  return mk_bool(get_numb(bytecode_args[0])
		 > get_numb(bytecode_args[1]));
}

scm builtin_le() {
  assert(bytecode_args_num == 2);
  return mk_bool(get_numb(bytecode_args[0])
		 <= get_numb(bytecode_args[1]));
}

scm builtin_ge() {
  assert(bytecode_args_num == 2);
  return mk_bool(get_numb(bytecode_args[0])
		 >= get_numb(bytecode_args[1]));
}

scm builtin_vector_ref() {
  assert(bytecode_args_num == 2);

  assert(scm_get_tag(bytecode_args[0]) == tag_vect);
  assert(scm_get_tag(bytecode_args[1]) == tag_numb);

  scm *p;
  
  p = get_vect(bytecode_args[0]);

  assert(get_numb(bytecode_args[1]) < header_scm_size(p[0]));
  
  return p[1 + get_numb(bytecode_args[1])];
}

scm builtin_vector_set_bang() {
  assert(bytecode_args_num == 3);

  assert(scm_get_tag(bytecode_args[0]) == tag_vect);
  assert(scm_get_tag(bytecode_args[1]) == tag_numb);
  
  scm *p;
  
  p = get_vect(bytecode_args[0]);

  assert(get_numb(bytecode_args[1]) < header_scm_size(p[0]));
  
  p[1 + get_numb(bytecode_args[1])] = bytecode_args[2];
  
  return 0;
}

scm builtin_make_vector() {
  assert(bytecode_args_num == 2);
  
  assert(scm_get_tag(bytecode_args[0]) == tag_numb);

  return heap_alloc_vect(get_numb(bytecode_args[0]), bytecode_args[1]);
}

scm builtin_vector_length() {
  assert(bytecode_args_num == 1);

  assert(scm_get_tag(bytecode_args[0]) == tag_vect);

  scm *p;
  
  p = get_vect(bytecode_args[0]);
  
  return mk_numb(header_scm_size(p[0]));
}

//

scm builtin_make_string() {
  char string_tmp_buf[512] = { 0 };
  int len;
  
  assert(bytecode_args_num == 2);

  assert(scm_get_tag(bytecode_args[0]) == tag_numb);
  assert(scm_get_tag(bytecode_args[1]) == atom_tag_char);

  int i;
  char c;

  len = get_numb(bytecode_args[0]);
  c = get_char(bytecode_args[1]);
  
  for(i = 0; i < len; i++) {
    string_tmp_buf[i] = c;
  }
  string_tmp_buf[i] = '\0';

  return heap_alloc_strn(string_tmp_buf, len);
}

scm builtin_string_set_bang() {
  assert(bytecode_args_num == 3);

  assert(scm_get_tag(bytecode_args[0]) == tag_strn);
  assert(scm_get_tag(bytecode_args[1]) == tag_numb);
  assert(scm_get_tag(bytecode_args[2]) == atom_tag_char);
  
  int i = get_numb(bytecode_args[1]);
  
  assert(i < get_strn_len(bytecode_args[0]));
  
  get_strn_data(bytecode_args[0])[i] = get_char(bytecode_args[2]);

  return 0;
}

scm builtin_string_ref() {
  assert(bytecode_args_num == 2);

  assert(scm_get_tag(bytecode_args[0]) == tag_strn);
  assert(scm_get_tag(bytecode_args[1]) == tag_numb);

  int i = get_numb(bytecode_args[1]);
  
  assert(i < get_strn_len(bytecode_args[0]));

  return mk_char(get_strn_data(bytecode_args[0])[i]);
}

scm builtin_string_to_symbol() {
  assert(bytecode_args_num == 1);

  assert(scm_get_tag(bytecode_args[0]) == tag_strn);

  return intern((char*)get_strn_data(bytecode_args[0]));
}

scm builtin_string_length() {
  assert(bytecode_args_num == 1);

  assert(scm_get_tag(bytecode_args[0]) == tag_strn);

  return mk_numb(get_strn_len(bytecode_args[0]));
}

scm builtin_string_eql() {
  assert(bytecode_args_num == 2);

  assert(scm_get_tag(bytecode_args[0]) == tag_strn);
  assert(scm_get_tag(bytecode_args[1]) == tag_strn);

  if(get_strn_len(bytecode_args[0]) != get_strn_len(bytecode_args[1]))
    return mk_fals();
  
  if(strcmp((char*)get_strn_data(bytecode_args[0]), (char*)get_strn_data(bytecode_args[1])))
    return mk_fals();

  return mk_true();
}

//

scm builtin_eof_objectq() {
  assert(bytecode_args_num == 1);
  return mk_bool(get_char(bytecode_args[0])
		 == -1);
}

scm builtin_read_char() {
  assert(bytecode_args_num == 0);
  
  return mk_char(fgetc(stdin));
}

int fpeek(FILE *stream)
{
    int c;

    c = fgetc(stream);
    ungetc(c, stream);

    return c;
}

scm builtin_peek_char() {
  assert(bytecode_args_num == 0);
  
  return mk_char(fpeek(stdin));
}

//

scm builtin_gensym() {
  char string_tmp_buf[512] = { 0 };
  char *s;

  assert(bytecode_args_num == 1);
 
  switch(scm_get_tag(bytecode_args[0])) {
  case tag_strn:
    s = (char*)get_strn_data(bytecode_args[0]);
    break;
    
  case atom_tag_symb:
    s = lookup(get_symb(bytecode_args[0]));
    break;
    
  default:
    fprintf(stderr, "gensym was passed the wrong type of object\n");
    exit(-1);
  }
  
  snprintf(string_tmp_buf, sizeof(string_tmp_buf), "%s%08x", s, rand()%0xFFFFFFFF);

  return intern(string_tmp_buf);
}

//

scm builtin_symbol_to_string() {
  assert(bytecode_args_num == 1);
  
  assert(scm_get_tag(bytecode_args[0]) == atom_tag_symb);

  char *p = lookup(get_symb(bytecode_args[0]));
  
  return heap_alloc_strn(p, strlen(p));
}

scm builtin_char_to_integer() {
  assert(bytecode_args_num == 1);
  
  assert(scm_get_tag(bytecode_args[0]) == atom_tag_char);

  return mk_numb(get_char(bytecode_args[0]));
}

//

builtin_handler handler[bltn_max] = {
  [bltn_gensym] = builtin_gensym,
  
  [bltn_display] = builtin_display,
  [bltn_newline] = builtin_newline,
  [bltn_eq] = builtin_eq,
  
  [bltn_cons] = builtin_cons,
  [bltn_car] = builtin_car,
  [bltn_cdr] = builtin_cdr,
  [bltn_set_car] = builtin_set_car,
  [bltn_set_cdr] = builtin_set_cdr,
  
  [bltn_nullq] = builtin_nullq,
  [bltn_pairq] = builtin_pairq,
  [bltn_numberq] = builtin_numberq,
  [bltn_booleanq] = builtin_booleanq,
  [bltn_stringq] = builtin_stringq,
  [bltn_charq] = builtin_charq,
  [bltn_symbolq] = builtin_symbolq,
  [bltn_vectorq] = builtin_vectorq,

  [bltn_add] = builtin_add,
  [bltn_subtract] = builtin_subtract,
  [bltn_multiply] = builtin_multiply,
  [bltn_eql] = builtin_eq,
  [bltn_lt] = builtin_lt,
  [bltn_gt] = builtin_gt,
  [bltn_le] = builtin_le,
  [bltn_ge] = builtin_ge,
  
  [bltn_quotient] = builtin_quotient,
  [bltn_modulo] = builtin_modulo,

  [bltn_vector_ref] = builtin_vector_ref,
  [bltn_vector_set_bang] = builtin_vector_set_bang,
  [bltn_make_vector] = builtin_make_vector,
  [bltn_vector_length] = builtin_vector_length,
  
  [bltn_make_string] = builtin_make_string,
  [bltn_string_set_bang] = builtin_string_set_bang,
  [bltn_string_ref] = builtin_string_ref,
  [bltn_string_to_symbol] = builtin_string_to_symbol,
  [bltn_string_length] = builtin_string_length,
  [bltn_string_eql] = builtin_string_eql,
  
  [bltn_eof_objectq] = builtin_eof_objectq,
  [bltn_read_char] = builtin_read_char,
  [bltn_peek_char] = builtin_peek_char,

  [bltn_symbol_to_string] = builtin_symbol_to_string,
  [bltn_char_to_integer] = builtin_char_to_integer,

  //[bltn_] = builtin_,
};