tarot-viewing/vm/builtins.c

#include <assert.h>

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

#include "objects.h"
#include "interpreter.h"
#include "symboltable.h"
//#include "gc.h"
#include "information.h"
#include "loader.h"
#include "vm.h"
#include "allocator.h"
#include "glovars.h"
#include "ports.h"

// get Nth thing on the stack
#define STACK(N) stack[reg_rbp + 1 + N]

// list functions
scm bltn_cons(void) {
	scm p = stack[reg_rbp + 1];
	scm q = stack[reg_rbp + 2];

	return allocate_cons(p, q);
}

scm bltn_car(void) {
	scm a = stack[reg_rbp + 1];

	info_assert(scm_gettag(a) == TAG_CONS);
	return get_cons_car(a);
}

scm bltn_cdr(void) {
	scm a = stack[reg_rbp + 1];

	info_assert(scm_gettag(a) == TAG_CONS);
	return get_cons_cdr(a);
}

scm bltn_nullq(void) {
	if (stack[reg_rbp + 1] == ATOM_NUL)
		return ATOM_TRU;
	else
		return ATOM_FLS;
}

scm bltn_pairq(void) {
	return mk_bool(scm_gettag(stack[reg_rbp + 1]) == TAG_CONS);
}

scm bltn_symbolq(void) {
	return mk_bool(scm_gettag(stack[reg_rbp + 1]) == ATOM_SYM);
}

scm bltn_stringq(void) {
	return mk_bool(scm_gettag(stack[reg_rbp + 1]) == TAG_STRG);
}

scm bltn_charq(void) {
	return mk_bool(scm_gettag(stack[reg_rbp + 1]) == ATOM_CHR);
}

scm bltn_booleanq(void) {
	scm x = scm_gettag(stack[reg_rbp + 1]);
	return mk_bool(x == ATOM_TRU || x == ATOM_FLS);
}

scm bltn_numberq(void) {
	return mk_bool(scm_gettag(stack[reg_rbp + 1]) == TAG_NUMB);
}

scm bltn_display(void);
scm bltn_error(void) {
	stack_trace();
	bltn_display();
	exit(1);
}

scm bltn_exit(void) {
	exit(1);
}

// printing functions
scm bltn_display(void) {
	scm atom;

	atom = stack[reg_rbp + 1];
	
	switch (scm_gettag(atom)) {
	case ATOM_FLS:
		printf("#f");
		break;

	case ATOM_TRU:
		printf("#t");
		break;

	case ATOM_NUL:
		printf("()");
		break;

	case ATOM_SYM:
		printf("%s", lookup(get_sym(atom)));
		break;

	case ATOM_CHR:
		printf("%c", (char)get_chr(atom));
		break;
	
	case TAG_NUMB:
		printf("%ld", get_numb(atom));
		break;

	case TAG_STRG:
		printf("%s", get_strg_data(atom));
		break;

	default:
		fprintf(stderr, "Unsupported type in call to print, atom=%lu\n", atom);
		break;
	}
	
	return ATOM_FLS;
}


  scm bltn_display_port(void) {
  scm atom;

  atom = STACK(0);
  scm port = STACK(1);
  FILE *to = port_get_file(port);

  switch (scm_gettag(atom)) {
  case ATOM_FLS:
  fprintf(to, "#f");
  break;

  case ATOM_TRU:
  fprintf(to, "#t");
  break;

  case ATOM_NUL:
  fprintf(to, "()");
  break;

  case ATOM_SYM:
  fprintf(to, "%s", lookup(get_sym(atom)));
  break;

  case ATOM_CHR:
	  fprintf(to, "%c", (char)get_chr(atom));
  break;
	
  case TAG_NUMB:
  fprintf(to, "%ld", get_numb(atom));
  break;

  case TAG_STRG:
  fprintf(to, "%s", get_strg_data(atom));
  break;

  default:
  fprintf(stderr, "Unsupported type in call to print, atom=%lu\n", atom);
  break;
  }
	
  return ATOM_FLS;
  }

scm bltn_newline(void) {
	puts("");
	
	return ATOM_FLS;
}

// equality functions
scm bltn_eq(void) {
	if (stack[reg_rbp + 1] == stack[reg_rbp + 2])
		return ATOM_TRU;
	else
		return ATOM_FLS;
}
scm bltn_equals(void) {
	scm p = stack[reg_rbp + 1];
	scm q = stack[reg_rbp + 2];
	info_assert(scm_gettag(p) == TAG_NUMB);
	info_assert(scm_gettag(q) == TAG_NUMB);

	if (p == q)
		return ATOM_TRU;
	else
		return ATOM_FLS;
}

// arithmetic operators
scm bltn_mul(void) {
	scm p = stack[reg_rbp + 1];
	scm q = stack[reg_rbp + 2];
	info_assert(scm_gettag(p) == TAG_NUMB);
	info_assert(scm_gettag(q) == TAG_NUMB);
	return mk_numb(get_numb(p) * get_numb(q));
}

scm bltn_div(void) {
	scm p = stack[reg_rbp + 1];
	scm q = stack[reg_rbp + 2];
	info_assert(scm_gettag(p) == TAG_NUMB);
	info_assert(scm_gettag(q) == TAG_NUMB);
	return mk_numb(get_numb(p) / get_numb(q));
}

scm bltn_add(void) {
	scm p = stack[reg_rbp + 1];
	scm q = stack[reg_rbp + 2];
	info_assert(scm_gettag(p) == TAG_NUMB);
	info_assert(scm_gettag(q) == TAG_NUMB);
	return mk_numb(get_numb(p) + get_numb(q));
}

scm bltn_sub(void) {
	scm p = stack[reg_rbp + 1];
	scm q = stack[reg_rbp + 2];
	info_assert(scm_gettag(p) == TAG_NUMB);
	info_assert(scm_gettag(q) == TAG_NUMB);
	return mk_numb(get_numb(p) - get_numb(q));
}

scm bltn_mod(void) {
	scm p = stack[reg_rbp + 1];
	scm q = stack[reg_rbp + 2];
	info_assert(scm_gettag(p) == TAG_NUMB);
	info_assert(scm_gettag(q) == TAG_NUMB);
	return mk_numb(get_numb(p) % get_numb(q));
}

// inequalities
scm bltn_lt(void) {
	scm p = stack[reg_rbp + 1];
	scm q = stack[reg_rbp + 2];
	info_assert(scm_gettag(p) == TAG_NUMB);
	info_assert(scm_gettag(q) == TAG_NUMB);
	return mk_bool(get_numb(p) < get_numb(q));
}
scm bltn_gt(void) {
	scm p = stack[reg_rbp + 1];
	scm q = stack[reg_rbp + 2];
	info_assert(scm_gettag(p) == TAG_NUMB);
	info_assert(scm_gettag(q) == TAG_NUMB);
	return mk_bool(get_numb(p) > get_numb(q));
}
scm bltn_le(void) {
	scm p = stack[reg_rbp + 1];
	scm q = stack[reg_rbp + 2];
	info_assert(scm_gettag(p) == TAG_NUMB);
	info_assert(scm_gettag(q) == TAG_NUMB);
	return mk_bool(get_numb(p) <= get_numb(q));
}
scm bltn_ge(void) {
	scm p = stack[reg_rbp + 1];
	scm q = stack[reg_rbp + 2];
	info_assert(scm_gettag(p) == TAG_NUMB);
	info_assert(scm_gettag(q) == TAG_NUMB);
	return mk_bool(get_numb(p) >= get_numb(q));
}

// mutation
scm bltn_set_car(void) {
	scm p = stack[reg_rbp + 1];
	scm q = stack[reg_rbp + 2];
	set_cons_car(p, q);
	return ATOM_FLS;
}

scm bltn_set_cdr(void) {
	scm p = stack[reg_rbp + 1];
	scm q = stack[reg_rbp + 2];
	set_cons_cdr(p, q);
	return ATOM_FLS;
}

// vectors
scm bltn_make_vector(void) {
	scm p = stack[reg_rbp + 1];
	scm q = stack[reg_rbp + 2];
	info_assert(scm_gettag(p) == TAG_NUMB);
	return allocate_vect(get_numb(p), q);
}

scm bltn_vectorq(void) {
	return mk_bool(scm_gettag(stack[reg_rbp + 1]) == TAG_VECT);
}

scm bltn_vector_ref(void) {
	scm vec = stack[reg_rbp + 1];
	scm idx = stack[reg_rbp + 2];
	info_assert(scm_gettag(idx) == TAG_NUMB);
	info_assert(get_numb(idx) < get_hdr_scm_size(get_vect(stack[reg_rbp + 1])[0]));
	return get_vect(vec)[1 + get_numb(idx)];
}

scm bltn_vector_set(void) {
	scm vec = stack[reg_rbp + 1];
	scm idx = stack[reg_rbp + 2];
	scm val = stack[reg_rbp + 3];
	info_assert(scm_gettag(idx) == TAG_NUMB);
	get_vect(vec)[1 + get_numb(idx)] = val;
	return val;
}

scm bltn_vector_length(void) {
	return mk_numb(get_hdr_scm_size(get_vect(stack[reg_rbp + 1])[0]));
}

///// string ones

scm bltn_make_string(void) {
	scm args_0 = stack[reg_rbp + 1];
	scm args_1 = stack[reg_rbp + 2];
	
	char string_tmp_buf[51200] = { 0 };
	int len;

	//assert(bytecode_args_num == 2);

	info_assert(scm_gettag(args_0) == TAG_NUMB);
	info_assert(scm_gettag(args_1) == ATOM_CHR);

	int i;
	char c;

	len = get_numb(args_0);
	c = (char)get_chr(args_1);

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

	return allocate_strg(string_tmp_buf, len);

}

scm bltn_string_set(void) {
	scm args_0 = stack[reg_rbp + 1];
	scm args_1 = stack[reg_rbp + 2];
	scm args_2 = stack[reg_rbp + 3];
	//  info_assert(args_num == 3);

	info_assert(scm_gettag(args_0) == TAG_STRG);
	info_assert(scm_gettag(args_1) == TAG_NUMB);
	info_assert(scm_gettag(args_2) == ATOM_CHR);

	int i = get_numb(args_1);

	info_assert(i < get_strg_len(args_0));

	get_strg_data(args_0)[i] = get_chr(args_2);

	return 0;
}

scm bltn_string_ref(void) {
	scm args_0 = stack[reg_rbp + 1];
	scm args_1 = stack[reg_rbp + 2];
	//  info_assert(args_num == 2);

	info_assert(scm_gettag(args_0) == TAG_STRG);
	info_assert(scm_gettag(args_1) == TAG_NUMB);

	int i = get_numb(args_1);

	info_assert(i < get_strg_len(args_0));

	return mk_chr(get_strg_data(args_0)[i]);
}

scm bltn_string_length(void) {
	scm args_0 = stack[reg_rbp + 1];
	info_assert(scm_gettag(args_0) == TAG_STRG);
	return mk_numb(get_strg_len(args_0));
}

scm bltn_string_to_symbol(void) {
	scm args_0 = stack[reg_rbp + 1];
	//info_assert(bytecode_args_num == 1);

	info_assert(scm_gettag(args_0) == TAG_STRG);

        scm res = intern((char*)get_strg_data(args_0));
//printf("SYM:[%s][%lu]\n", get_strg_data(args_0), res);
	return res;
}

scm bltn_string_eql(void) {
	scm args_0 = stack[reg_rbp + 1];
	scm args_1 = stack[reg_rbp + 2];

	//info_assert(bytecode_args_num == 2);

	info_assert(scm_gettag(args_0) == TAG_STRG);
	info_assert(scm_gettag(args_1) == TAG_STRG);
	
	if(get_strg_len(args_0) != get_strg_len(args_1))
		return ATOM_FLS;

	if(strcmp((char*)get_strg_data(args_0), (char*)get_strg_data(args_1)))
		return ATOM_FLS;
	
	return ATOM_TRU;
}

scm bltn_number_to_char(void) {
	return mk_chr(get_numb(stack[reg_rbp + 1]));
}
scm bltn_char_to_number(void) {
	return mk_numb(get_chr(stack[reg_rbp + 1]));
}
scm bltn_symb_to_strn(void) {
	char *s = lookup(get_sym(STACK(0)));
	info_assert(s);
	return allocate_strg(s, strlen(s));
}

scm bltn_strn_append(void) {
	scm p = STACK(0);
	scm q = STACK(1);
	scm s = allocate_strg(NULL, get_strg_len(p) + get_strg_len(q));

	memcpy(get_strg_data(s), get_strg_data(p), get_strg_len(p));
	memcpy(get_strg_data(s) + get_strg_len(p), get_strg_data(q), get_strg_len(q));
	get_strg_data(s)[get_strg_len(p) + get_strg_len(q)] = '\0';

	return s;
}

// io

scm bltn_eof_objectq(void) {
	int r = get_chr(STACK(0)) == -1;
	//	if(r)puts("OEOF");
	return mk_bool(r);
}

scm bltn_read_char(void) {
	info_assert(scm_gettag(STACK(0)) == ATOM_PRT);
	char c=fgetc(port_get_file(STACK(0)));
//		printf("CHR:%c\n", c);
	return mk_chr(c);
}

scm bltn_open_input_port(void) {
	info_assert(scm_gettag(STACK(0)) == TAG_STRG);

	FILE *f = fopen((char *)get_strg_data(STACK(0)), "r");
	if(!f) {
		fprintf(stderr, "couldn't open file %s\n", get_strg_data(STACK(0)));
	}
	info_assert(f);
	
	return mk_port(f);
}

scm bltn_close_port(void) {
	info_assert(scm_gettag(STACK(0)) == ATOM_PRT);

	port_close(STACK(0));

	return ATOM_FLS;
}

int fpeek(FILE *stream)
{
	int c;

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

	return c;
}

scm bltn_peek_char(void) {
	info_assert(scm_gettag(STACK(0)) == ATOM_PRT);
	return mk_chr(fpeek(port_get_file(STACK(0))));
}

// VM

scm bltn_vm_open() {
	int fd[2];
	// make a pipe
	info_assert(!pipe(&fd[0]));

	// make a port out of it
	return mk_pipe(fdopen(fd[1], "w"), fdopen(fd[0], "r"));
}

scm bltn_vm_finish() {
	scm p = STACK(0);
	info_assert(scm_gettag(p) == ATOM_PRT);

	FILE *f1, *f2;

	scm *tmp = vm_code + vm_code_size;

	f1 = port_get_file(p);
	f2 = port_get_pipe_end(p);

	fclose(f1);
	load_code(f2);
	fclose(f2);

	// TODO remove it from the table
	// but dont re-close the fds

	vm_exec(tmp);

	return reg_acc;
}

scm bltn_gensym(void) {
	char string_tmp_buf[512] = { 0 };

	info_assert(scm_gettag(STACK(0)) == TAG_STRG);

	snprintf(string_tmp_buf, sizeof(string_tmp_buf), "%s%08x", get_strg_data(STACK(0)), rand()%0xFFFFFFFF);

	return intern(string_tmp_buf); 
}

/////////////////////////////

void builtins_init(scm argv) {
	// list functions
	glo_define(intern("cons"), mk_numb(2), mk_bltn(bltn_cons));
	glo_define(intern("car"), mk_numb(1), mk_bltn(bltn_car));
	glo_define(intern("cdr"), mk_numb(1), mk_bltn(bltn_cdr));
	glo_define(intern("set-car!"), mk_numb(2), mk_bltn(bltn_set_car));
	glo_define(intern("set-cdr!"), mk_numb(2), mk_bltn(bltn_set_cdr));
	glo_define(intern("null?"), mk_numb(1), mk_bltn(bltn_nullq));
	glo_define(intern("pair?"), mk_numb(1), mk_bltn(bltn_pairq));
	glo_define(intern("symbol?"), mk_numb(1), mk_bltn(bltn_symbolq));
	glo_define(intern("string?"), mk_numb(1), mk_bltn(bltn_stringq));
	glo_define(intern("char?"), mk_numb(1), mk_bltn(bltn_charq));
	glo_define(intern("boolean?"), mk_numb(1), mk_bltn(bltn_booleanq));
	glo_define(intern("number?"), mk_numb(1), mk_bltn(bltn_numberq));

	glo_define(intern("%display"), mk_numb(1), mk_bltn(bltn_display));
	glo_define(intern("newline"), mk_numb(0), mk_bltn(bltn_newline));

	// printing functions
	//	glo_define(intern("print"), mk_numb(), mk_bltn(bltn_display)); // JUST FOR DEBUGGING
	glo_define(intern("error"), mk_numb(1), mk_bltn(bltn_error));
	glo_define(intern("exit"), mk_numb(0), mk_bltn(bltn_exit));
	
	// equality functions
	glo_define(intern("eq?"), mk_numb(2), mk_bltn(bltn_eq));
	glo_define(intern("="), mk_numb(2), mk_bltn(bltn_equals));

	// arithmetic operators
	glo_define(intern("*"), mk_numb(2), mk_bltn(bltn_mul));
	glo_define(intern("+"), mk_numb(2), mk_bltn(bltn_add));
	glo_define(intern("-"), mk_numb(2), mk_bltn(bltn_sub));
	glo_define(intern("modulo"), mk_numb(2), mk_bltn(bltn_mod));
	glo_define(intern("quotient"), mk_numb(2), mk_bltn(bltn_div));
	glo_define(intern("remainder"), mk_numb(2), mk_bltn(bltn_mod));

	// inequalities
	glo_define(intern("<"), mk_numb(2), mk_bltn(bltn_lt));
	glo_define(intern(">"), mk_numb(2), mk_bltn(bltn_gt));
	glo_define(intern("<="), mk_numb(2), mk_bltn(bltn_le));
	glo_define(intern(">="), mk_numb(2), mk_bltn(bltn_ge));

	// vectors
	glo_define(intern("make-vector"), mk_numb(2), mk_bltn(bltn_make_vector));
	glo_define(intern("vector?"), mk_numb(1), mk_bltn(bltn_vectorq));
	glo_define(intern("vector-ref"), mk_numb(2), mk_bltn(bltn_vector_ref));
	glo_define(intern("vector-set!"), mk_numb(3), mk_bltn(bltn_vector_set));
	glo_define(intern("vector-length"), mk_numb(1), mk_bltn(bltn_vector_length));

	// strings
	glo_define(intern("make-string"), mk_numb(2), mk_bltn(bltn_make_string));
	glo_define(intern("string-set!"), mk_numb(3), mk_bltn(bltn_string_set));
	glo_define(intern("string-ref"), mk_numb(2), mk_bltn(bltn_string_ref));
	glo_define(intern("string->symbol"), mk_numb(1), mk_bltn(bltn_string_to_symbol));
	glo_define(intern("string-length"), mk_numb(1), mk_bltn(bltn_string_length));
	glo_define(intern("string=?"), mk_numb(2), mk_bltn(bltn_string_eql));

	glo_define(intern("integer->char"), mk_numb(1), mk_bltn(bltn_number_to_char));
	glo_define(intern("char->integer"), mk_numb(1), mk_bltn(bltn_char_to_number));
	glo_define(intern("symbol->string"), mk_numb(1), mk_bltn(bltn_symb_to_strn));

	glo_define(intern("string-append"), mk_numb(2), mk_bltn(bltn_strn_append));

	// io
	glo_define(intern("eof-object?"), mk_numb(1), mk_bltn(bltn_eof_objectq));
	glo_define(intern("read-char"), mk_numb(1), mk_bltn(bltn_read_char));
	glo_define(intern("peek-char"), mk_numb(1), mk_bltn(bltn_peek_char));
	glo_define(intern("open-input-port"), mk_numb(1), mk_bltn(bltn_open_input_port));
	glo_define(intern("close-port"), mk_numb(1), mk_bltn(bltn_close_port));
	glo_define(intern("standard-input"), ATOM_FLS, mk_port(stdin));
	glo_define(intern("argv"), ATOM_FLS, argv);

	// vm
	glo_define(intern("vm:open"), mk_numb(0), mk_bltn(bltn_vm_open));
	glo_define(intern("vm:finish"), mk_numb(1), mk_bltn(bltn_vm_finish));
	glo_define(intern("display:port"), mk_numb(2), mk_bltn(bltn_display_port));

	glo_define(intern("gensym"), mk_numb(1), mk_bltn(bltn_gensym));
}