s_expressions.c

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

#include <editline/readline.h>
#include <editline/history.h>


#include "s_expressions.h"

void* new(size_t size, const char* error)
{
  errno = 0;
  void* v = malloc(sizeof(lval));
  if (v == NULL && size != 0) {
    fprintf(stderr, "%s: %s\n", error, strerror(errno));
    abort();
  }
  return v;
}

void* renew(void *v, size_t size, const char* error)
{
  errno = 0;
  v = realloc(v, sizeof(lval));
  if ((v == NULL && size != 0) || errno != 0) {
    fprintf(stderr, "%s: %s\n", error, strerror(errno));
    abort();
  }
  return v;
}

lval* lval_int(long long x)
{
  lval* v = new(sizeof(lval), "Failed to allocate memory for lval_int");
  v->type = LVAL_INT;
  v->inum = x;
  return v;
}

lval* lval_real(long double x)
{
  lval* v = new(sizeof(lval), "Failed to allocate memory for lval_real");
  v->type = LVAL_REAL;
  v->rnum = x;
  return v;
}

lval* lval_err(const char* m)
{
  lval* v = new(sizeof(lval), "Failed to allocate memory for lval_err");
  v->type = LVAL_ERR;

  v->err = new(strlen(m) + 1, "Failed to allocate memory for error message in lval_err");
  strcpy(v->err, m);

  return v;
}

lval* lval_sym(const char* s)
{
  lval* v = new(sizeof(lval), "Failed to allocate memory for lval_sym");
  v->type = LVAL_SYM;

  v->sym = new(strlen(s) + 1, "Failed to allocate memory for symbol in lval_sym");
  strcpy(v->sym, s);

  return v;
}

lval* lval_sexpr(void)
{
  errno = 0;
  lval* v = new(sizeof(lval), "Failed to allocate memory for lval_sexpr");

  v->type  = LVAL_SEXPR;
  v->count = 0;
  v->cell  = NULL;

  return v;
}

void lval_del(lval* v)
{
  /* don't double delete, or rather: don't try to access null pointers ;) */
  if (v == NULL) { return ; }

  switch(v->type) {
    case LVAL_INT:  break;
    case LVAL_REAL: break;

    case LVAL_ERR: free(v->err); break;
    case LVAL_SYM: free(v->sym); break;

    case LVAL_SEXPR:
      /* delete[] ;) */
      for (size_t i = 0; i < v->count; i += 1) {
        lval_del(v->cell[i]);
      }
      free(v->cell);
    break;

    default:
      fprintf(stderr, "we extended the struct, but not this method. FAILING HARD!\n");
      abort();
    break;
  }
  /* I'm finally free! */
  free(v);
}

void lval_expr_print(lval* v, char open, char close)
{
  putchar(open);
  for (size_t i = 0; i < v->count; i += 1) {
    lval_print(v->cell[i]);

    if (i != v->count - 1) { putchar(' '); }
  }
  putchar(close);
}

void lval_print(lval* v)
{
  switch (v->type) {
    case LVAL_INT:   printf("%lld", v->inum); break;
    case LVAL_REAL:  printf("%Lf", v->rnum); break;
    case LVAL_ERR:   printf("Error: %s!", v->err); break;
    case LVAL_SYM:   printf("%s", v->sym); break;
    case LVAL_SEXPR: lval_expr_print(v, '(', ')'); break;
    default: 
      fprintf(stderr, "we extended the enum, but not this method. FAILING HARD!\n");
      abort();
    break;
  }
}

void lval_println(lval* v) { lval_print(v); putchar('\n'); }

lval* lval_push(lval* v, lval* x)
{
  v->count += 1;
  v->cell = renew(v->cell, sizeof(lval*) * v->count, "Failed to reallocate memory in lval_push for cell");
  /* don't go off by one.. */
  v->cell[v->count - 1] = x;
  return v;
}


lval* lval_read_inum(mpc_ast_t* t)
{
    errno = 0;
    long long x = strtoll(t->contents, NULL, 10);
    return errno != ERANGE ? lval_int(x) : lval_err("invalid number");
}

lval* lval_read_rnum(mpc_ast_t* t)
{
    errno = 0;
    long double x = strtold(t->contents, NULL);
    return errno != ERANGE ? lval_real(x) : lval_err("invalid number");
}

lval* lval_read(mpc_ast_t* t)
{
  if (strstr(t->tag, "integer")) { return lval_read_inum(t); }
  if (strstr(t->tag, "double"))  { return lval_read_rnum(t); }
  if (strstr(t->tag, "symbol"))  { return lval_sym(t->contents); }

	lval* x = NULL;

  /* if this is the root ('>'), or sexpr, create an empty list */
  if (strcmp(t->tag, ">") == 0) { x = lval_sexpr(); }
  if (strstr(t->tag, "sexpr"))  { x = lval_sexpr(); }

  /* fill this list with any valid expressions contained */
  for (size_t i = 0; i < t->children_num; i += 1) {
    if (strcmp(t->children[i]->contents, "(") == 0) { continue; }
    if (strcmp(t->children[i]->contents, ")") == 0) { continue; }
    if (strcmp(t->children[i]->contents, "{") == 0) { continue; }
    if (strcmp(t->children[i]->contents, "}") == 0) { continue; }
    if (strcmp(t->children[i]->tag,  "regex") == 0) { continue; }
    x = lval_push(x, lval_read(t->children[i]));
  }

	return x;
}

lval* lval_eval_sexpr(lval* v)
{
  /* evaluate children */
  for (size_t i = 0; i < v->count; i += 1) {
    v->cell[i] = lval_eval(v->cell[i]);
  }
  /* a second pass for error checking */
  for (size_t i = 0; i < v->count; i += 1) {
    if (v->cell[i]->type == LVAL_ERR) { return lval_take(v, i); }
  }

  /* empty expressions */
  if (v->count == 0) { return v; }

  /* single expressions */
  if (v->count == 1) { return lval_take(v, 0); }

  /* ensure first element is symbol */
  lval* f = lval_pop(v, 0);
  if (f->type != LVAL_SYM) {
    lval_del(f); lval_del(v);
    return lval_err("S-Expression does not start with symbol!");
  }

  /* call with builtin operators */
  lval* result = lval_builtin_op(v, f->sym);
  lval_del(f);
  return result;
}

lval* lval_eval(lval* v)
{
  if (v->type == LVAL_SEXPR) { return lval_eval_sexpr(v); }

  /* all other types remain the same */
  return v;
}

lval* lval_pop(lval* v, off_t i)
{
  lval* x = v->cell[i];

  /* shift the memory following the item "i" over the top of it. */
  memmove(&v->cell[i], &v->cell[i + 1], sizeof(lval*) * (v->count - i - 1));
  /* n.b.: according to memove(3) this function call doesn't fail. cool. I guess. */

  v->count -= 1;

  v->cell = renew(v->cell, sizeof(lval*) * v->count, "Failed to reallocate memory for cell in lval_pop");
  return x;
}

lval* lval_take(lval* v, off_t i)
{
  lval* x = lval_pop(v, i);
  lval_del(v);
  return x;
}

lval* type_operator(lval* x, const lval* y, char op)
{
	if (x->type == LVAL_INT && y->type == LVAL_INT)         { OPERATOR(x->inum, y->inum, op); }
	else if (x->type == LVAL_REAL && y->type == LVAL_REAL)  { OPERATOR(x->rnum, y->rnum, op); }
	else if (x->type == LVAL_REAL)                          { OPERATOR(x->rnum, (long double)y->inum, op); }
	else {
		x->type = LVAL_REAL;
		x->rnum = (long double)x->inum;
		OPERATOR(x->inum, y->rnum, op);
	}
	return x;
}

lval* lval_builtin_op(lval* a, const char *op)
{
  for (size_t i = 0; i < a->count; i += 1) {
    if (a->cell[i]->type != LVAL_INT || a->cell[i]->type != LVAL_REAL) {
      lval_del(a);
      return lval_err("Cannot operate on non-number!");
    }
  }

	/* pop first element */
	lval* x = lval_pop(a, 0);

	/* unary operators */
	if ((strcmp(op, "-")   == 0) && a->count == 0) {
    if (x->type == LVAL_REAL) { x->rnum  = -x->rnum; }
    else { x->inum = -x->inum; }
  }
	if ((strcmp(op, "inc") == 0) && a->count == 0) {
    if (x->type == LVAL_REAL) { x->rnum += 1 ; }
    else { x->inum += 1; }
  }
	if ((strcmp(op, "dec") == 0) && a->count == 0) {
    if (x->type == LVAL_REAL) { x->rnum -= 1; }
    else { x->inum -= 1; }
  }

  while (a->count > 0) {
    /* pop next element */
    lval* y = lval_pop(a, 0);

    if (strcmp(op, "min") == 0) {
      if (x->type == LVAL_INT && y->type == LVAL_INT)        { x->inum = fmin(x->inum, y->inum); }
      else if (x->type == LVAL_REAL && y->type == LVAL_REAL) { x->rnum = fmin(x->rnum, y->rnum); }
      else if (x->type == LVAL_REAL)                         { x->rnum = fmin(x->rnum, (long double)y->inum); }
      else {
        x->type = LVAL_REAL;
        x->rnum = fmin((long double)x->inum, y->rnum);
      }
    }
    if (strcmp(op, "max") == 0) {
      if (x->type == LVAL_INT && y->type == LVAL_INT)        { x->inum = fmax(x->inum, y->inum); }
      else if (x->type == LVAL_REAL && y->type == LVAL_REAL) { x->rnum = fmax(x->rnum, y->rnum); }
      else if (x->type == LVAL_REAL)                         { x->rnum = fmax(x->rnum, (long double)y->inum); }
      else {
        x->type = LVAL_REAL;
        x->rnum = fmax((long double)x->inum, y->rnum);
      }
    }
    if (strcmp(op, "+") == 0) { type_operator(x, y, op[0]); }
    if (strcmp(op, "-") == 0) { type_operator(x, y, op[0]); }
    if (strcmp(op, "*") == 0) { type_operator(x, y, op[0]); }
    if (strcmp(op, "^") == 0) {
      if (x->type == LVAL_INT && y->type == LVAL_INT)        { x->inum = pow(x->inum, y->inum); }
      else if (x->type == LVAL_REAL && y->type == LVAL_REAL) { x->rnum = pow(x->rnum, y->rnum); }
      else if (x->type == LVAL_REAL)                         { x->rnum = pow(x->rnum, (long double)y->inum); }
      else {
        x->type = LVAL_REAL;
        x->rnum = pow((long double)x->inum, y->rnum);
      }
    }
    if (strcmp(op, "/") == 0 || strcmp(op, "%") == 0) {
      if ((y->type == LVAL_REAL && y->rnum == 0.0) || (y->type == LVAL_INT && y->rnum == 0.0)) {
        lval_del(x); lval_del(y);
        x = lval_err("Division by Zero");
        break;
      }
      if (op[0] == '/') { type_operator(x, y, '/'); }
      if (op[0] == '%') {
        if (x->type == LVAL_INT && y->type == LVAL_INT)        { x->inum %= y->inum; }
        else if (x->type == LVAL_REAL && y->type == LVAL_REAL) { x->rnum = fmod(x->rnum, y->rnum); }
        else if (x->type == LVAL_REAL)                         { x->rnum = fmod(x->rnum, (long double)y->inum); }
        else {
          x->type = LVAL_REAL;
          x->rnum = fmod((long double)x->inum, y->rnum);
        }
      }
    }

    lval_del(y);
  }

  lval_del(a);
  return x;
}

int main (int argc, char **argv)
{
	mpc_parser_t* Integer  = mpc_new("integer");
	mpc_parser_t* Double   = mpc_new("double");
	mpc_parser_t* Symbol   = mpc_new("symbol");
	mpc_parser_t* Sexpr    = mpc_new("sexpr");
	mpc_parser_t* Expr     = mpc_new("expr");
	mpc_parser_t* Lispy    = mpc_new("lispy");

  const char *grammar = 
    "                                                                                         \n\
      double   : /-?[0-9]+.[0-9]+/ | ;                                                        \n\
      integer  : /-?[0-9]+/ | ;                                                               \n\
      symbol   : '+' | '-' | '*' | '/' | '%' | '^' | \"min\" | \"max\" | \"inc\" | \"dec\" ;  \n\
      sexpr    : '(' <expr>* ')' ;                                                            \n\
      expr     : <double> | <integer> | <symbol> | <sexpr> ;                                  \n\
      lispy    : /^/ <expr>* /$/ ;                                                            \n\
    \n";

  printf("Grammar: %s\n", grammar);

  mpca_lang(MPC_LANG_DEFAULT, grammar,
      Double, Integer, Symbol, Sexpr, Expr, Lispy);

  puts("Lispy Version 0.0.0.5");
  puts("Press Ctrl+c to exit\n");

  while (1) {
    mpc_result_t r;
    char *input = readline("lispy> ");
    add_history(input);

    if (mpc_parse("<stdin>", input, Lispy, &r)) {
      lval* result = lval_eval(lval_read(r.output));

      lval_println(result);

      lval_del(result);
      mpc_ast_delete(r.output);
    } else {
      mpc_err_print(r.error);
      mpc_err_delete(r.error);
    }
    free (input);
  }

  mpc_cleanup(4, Symbol, Sexpr, Expr, Lispy);
  return 0;
}

s_expressions.h

#ifndef __S_EXPRESSIONS_H
#define __S_EXPRESSIONS_H

#include "mpc.h"

typedef enum { 
  LVAL_INT,
  LVAL_REAL,
  LVAL_ERR,
  LVAL_SYM,
  LVAL_SEXPR,
} lval_type;

typedef enum {
  LERR_DIV_ZERO,
  LERR_BAD_OP,
  LERR_BAD_NUM,
} lerr;

typedef struct lval {
  lval_type type;
  union {
    long long inum;
    long double rnum;
  };

  char* err;
  char* sym;

  size_t count;
  struct lval** cell;
} lval;

/* malloc helper */
void* renew(void *v, size_t size, const char* error);
void* new(size_t size, const char* error);

/* constructors */
lval* lval_num(long long x);
lval* lval_err(const char* m);
lval* lval_sym(const char* s);
lval* lval_sexpr(void);
/* deconstructor */
void  lval_del(lval* v);
/* other lval methods */
lval* lval_push(lval* v, lval* x);
lval* lval_pop(lval* v, off_t i);
/* lval_take is like lval_pop!(v, i), in that it modifies v. */
lval* lval_take(lval* v, off_t i);
lval* lval_read(mpc_ast_t* t);
lval* lval_read_num(mpc_ast_t* t);
lval* lval_eval_sexpr(lval* v);
lval* lval_eval(lval* v);
lval* lval_builtin_op(lval* v, const char *sym);

/* print helpers */
void  lval_print(lval* v);
void  lval_expr_print(lval* v, char open, char close);
void  lval_println(lval* v);

lval* type_operator(lval* x, const lval* y, char op);

#define OPERATOR(x, y, op)      do { \
  if ( op == '+' ) { x += y ; }      \
  if ( op == '-' ) { x -= y ; }      \
  if ( op == '*' ) { x *= y ; }      \
  if ( op == '/' ) { x /= y ; }      \
} while(0)



#endif /*  __S_EXPRESSIONS_H */