build_your_own_lisp/chapter_10/lispy.c

#include <stdio.h>
#include <stdlib.h>
#include <assert.h>
#include "../mpc/mpc.h"


/* If we are on Windows compile these functions */
#ifdef _WIN32
#include <string.h>

static char buffer[2048];

/* Fake readline function */
char* readline(char* prompt) {
    fputs(prompt, stdout);
    fgets(buffer, 2048, stdin);
    char* cpy = malloc(strlen(buffer)+1);
    assert(cpy != NULL)
    strcpy(cpy, buffer);
    cpy[strlen(cpy)-1] = '\0';
    return cpy;
}

/* Fake add_history function */
void add_history(char* unused) {}

/* Otherwise include the editline headers
   could use __APPLE__ for detection of OSX */
#else
#include <editline/readline.h>
#endif

/* Include type and function declarations */
#include "lispy.h"


/* Construct a pointer to a new number lval */
lval* lval_num(long x) {
    lval* v = malloc(sizeof(lval));
    assert(v != NULL);
    v->type = LVAL_NUM;
    v->num = x;
    return v;
}


/* Construct a pointer to a new decimal lval */
lval* lval_dec(double x) {
    lval* v = malloc(sizeof(lval));
    assert(v != NULL);
    v->type = LVAL_DEC;
    v->dec = x;
    return v;
}


/* Construct a pointer to a new error lval */
lval* lval_err(char* m) {
    lval* v = malloc(sizeof(lval));
    assert(v != NULL);
    v->type = LVAL_ERR;
    v->err = malloc(strlen(m)+1);
    assert(v->err != NULL);
    strcpy(v->err, m);
    return v;
}


/* Construct a pointer to a new symbol lval */
lval* lval_sym(char* s) {
    lval* v = malloc(sizeof(lval));
    assert(v != NULL);
    v->type = LVAL_SYM;
    v->sym = malloc(strlen(s)+1);
    assert(v->sym != NULL);
    strcpy(v->sym, s);
    return v;
}


/* Construct a pointer to a new empty sexpr lval */
lval* lval_sexpr(void) {
    lval* v = malloc(sizeof(lval));
    assert(v != NULL);
    v->type = LVAL_SEXPR;
    v->count = 0;
    v->cell = NULL;
    return v;
}


/* Construct a pointer to a new empty qexpr lval */
lval* lval_qexpr(void) {
    lval* v = malloc(sizeof(lval));
    assert(v != NULL);
    v->type = LVAL_QEXPR;
    v->count = 0;
    v->cell = NULL;
    return v;
}


/* Free memory of an lval and all its members */
void lval_del(lval* v) {

    switch (v->type) {
        /* Do nothing special for number / decimal type */
        case LVAL_NUM:
        case LVAL_DEC:
            break;

        /* For err or sym free the string data */
        case LVAL_ERR:
            free(v->err);
            break;
        case LVAL_SYM:
            free(v->sym);
            break;

        /* If sexpr then delete all elements inside */
        case LVAL_SEXPR:
        case LVAL_QEXPR:
            for (size_t i = 0; i < v->count; i++) {
                lval_del(v->cell[i]);
            }
            /* Also free the memory allocated to contain
               the pointers */
            free(v->cell);
            break;
    }
    /* Free the memory allocated for the lval struct itself */
    free(v);
}


lval* lval_read_num(mpc_ast_t* t) {
    errno = 0;
    if (strstr(t->contents, ".")) {
        double x = strtod(t->contents, NULL);
        return errno != ERANGE ? lval_dec(x)
                               : lval_err("Invalid number");
    } else {
        long x = strtol(t->contents, NULL, 10);
        return errno != ERANGE ? lval_num(x)
                               : lval_err("Invalid number");
    }
}


lval* lval_read(mpc_ast_t* t) {

    /* If symbol or number return conversion to that type */
    if (strstr(t->tag, "number")) {
        return lval_read_num(t);
    }
    if (strstr(t->tag, "symbol")) {
        return lval_sym(t->contents);
    }

    /* If root (>) or sexpr then create empty list */
    lval* x = NULL;
    if (strcmp(t->tag, ">") == 0 || strstr(t->tag, "sexpr")) {
        x = lval_sexpr();
    }

    /* If qexpr create then empty list */
    if (strstr(t->tag, "qexpr")) {
        x = lval_qexpr();
    }

    /* Fill this list with any valid expression
       contained within */
    for (size_t i = 0; i < (size_t) t->children_num; i++) {
        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_add(x, lval_read(t->children[i]));
    }

    return x;
}


lval* lval_add(lval* v, lval* x) {
    v->count++;
    v->cell = realloc(v->cell, sizeof(lval*) * v->count);
    assert(v->cell != NULL);
    v->cell[v->count-1] = x;
    return v;
}


void lval_expr_print(lval* v, char open, char close) {
    /* Opening char */
    putchar(open);

    for (size_t i = 0; i < v->count; i++) {
        /* Print value contained within */
        lval_print(v->cell[i]);
        /* Don't print trailing space if last element */
        if (i != (v->count-1)) {
            putchar(' ');
        }
    }
    /* Opening char */
    putchar(close);
}


/* Print an lval */
void lval_print(lval* v) {

    switch (v->type) {
        /* In the case the type is a number print it
           Then break out of the switch */
        case LVAL_NUM:
            printf("%li", v->num);
            break;
        case LVAL_DEC:
            printf("%.2f", v->dec);
            break;
        /* In the case the type is an error */
        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;
        case LVAL_QEXPR:
            lval_expr_print(v, '{', '}');
            break;
    }

}


/* Print an lval followed by a newline */
void lval_println(lval* v) {
    lval_print(v);
    putchar('\n');
}


lval* lval_eval_sexpr(lval* v) {

    /* Evaluate children */
    for (size_t i = 0; i < v->count; i++) {
        v->cell[i] = lval_eval(v->cell[i]);
    }

    /* Error checking */
    for (size_t i = 0; i < v->count; i++) {
        if (v->cell[i]->type == LVAL_ERR) {
            return lval_take(v, i);
        }
    }

    /* Empty expression */
    if (v->count == 0) {
        return v;
    }

    /* Single expression */
    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 builtin with operator */
    lval* result = builtin_op(v, f->sym);
    lval_del(f);
    return result;

}


lval* lval_eval(lval* v) {

    /* Evaluate sexpressions */
    if (v->type == LVAL_SEXPR) {
        return lval_eval_sexpr(v);
    }

    /* All other lval types remain the same */
    return v;

}


lval* lval_pop(lval* v, size_t i) {

    /* Fine the item at i */
    lval* x = v->cell[i];

    /* Shift memory after the item at i over the top */
    memmove(&v->cell[i], &v->cell[i+1],
            sizeof(lval*) * (v->count-i-1));

    /* Decrease the count of items in the list */
    v->count--;

    /* Reallocate the memory used */
    v->cell = realloc(v->cell, sizeof(lval*) * v->count);
    assert(v->cell != NULL);

    return x;

}

lval* lval_take(lval* v, size_t i) {

    lval* x = lval_pop(v, i);
    lval_del(v);
    return x;

}


lval* builtin_op(lval* a, char* op) {

    /* Ensure all arguments are numbers */
    for (size_t i = 0; i < a->count; i++) {
        if (a->cell[i]->type != LVAL_NUM && a->cell[i]->type != LVAL_DEC) {
            lval_del(a);
            return lval_err("Cannot operate on non-number/non-decimal!");
        }
    }

    /* Pop the 1st element */
    lval* x = lval_pop(a, 0);

    /* If no arguments and sub then perform unary negation */
    if (strcmp(op, "-") == 0 &&  a->count == 0) {
        if (x->type == LVAL_NUM) {
            x->num = -x->num;
        } else {
            x->dec = -x->dec;
        }
    }

    /* While there are still elements remaining */
    while (a->count > 0) {
        /* Pop the next element */
        lval* y = lval_pop(a, 0);
        if (x->type == LVAL_NUM && y->type == LVAL_NUM) {
            if (strcmp(op, "+") == 0) {x->num += y->num;}
            if (strcmp(op, "-") == 0) {x->num -= y->num;}
            if (strcmp(op, "*") == 0) {x->num *= y->num;}
            if (strcmp(op, "/") == 0) {
                /* If second operand is zero return error */
                if (y->num == 0) {
                    lval_del(x);
                    lval_del(y);
                    x = lval_err("Division by zero!");
                    break;
                }
                x->num /= y->num;
            }
            if (strcmp(op, "%") == 0) {x->num %= y->num;}
            if (strcmp(op, "^") == 0) {x->num = (pow(x->num, y->num));}
            if (strcmp(op, "min") == 0) {x->num = min(x->num, y->num);}
            if (strcmp(op, "max") == 0) {x->num = max(x->num, y->num);}
        } else {
            /* Cast integer number into double if necessary */
            double b = x->type == LVAL_NUM ? (double) x->num : x->dec;
            double c = y->type == LVAL_NUM ? (double) y->num : y->dec;
            /* Perform all operations on double */
            if (strcmp(op, "+") == 0) {b += c;}
            if (strcmp(op, "-") == 0) {b -= c;}
            if (strcmp(op, "*") == 0) {b *= c;}
            if (strcmp(op, "/") == 0) {
                /* If second operand is zero return error */
                if (c == 0) {
                    lval_del(x);
                    lval_del(y);
                    x = lval_err("Division by zero!");
                    break;
                }
                b /= c;
            }
            if (strcmp(op, "%") == 0) {b = fmod(b, c);}
            if (strcmp(op, "^") == 0) {b = (pow(b, c));}
            if (strcmp(op, "min") == 0) {b = fmin(b, c);}
            if (strcmp(op, "max") == 0) {b = fmax(b, c);}
            x->type = LVAL_DEC;
            x->dec = b;
        }
    }

    lval_del(a);
    return x;

}


lval* builtin_head(lval* a) {

    /* Check error conditions */
    LASSERT(a, a->count == 1,
            "Function 'head' passed too many arguments!");

    LASSERT(a, a->cell[0]->type == LVAL_QEXPR,
        "Function 'head' passed incorrect type!");

    LASSERT(a, a->cell[0]->count != 0,
        "Function 'head' passed {}!");

    /* Otherwise take first argument */
    lval* v = lval_take(a, 0);

    /* Delete all elements that are not head and return */
    while (v-> count > 1) {
        lval_del(lval_pop(v, 1));
    }

    return v;

}


lval* builtin_tail(lval* a) {

    /* Check error conditions */
    LASSERT(a, a->count == 1,
            "Function 'tail' passed too many arguments!");

    LASSERT(a, a->cell[0]->type == LVAL_QEXPR,
        "Function 'tail' passed incorrect type!");

    LASSERT(a, a->cell[0]->count != 0,
        "Function 'tail' passed {}!");

    /* Otherwise take first argument */
    lval* v = lval_take(a, 0);

    /* Delete first element and return */
    lval_del(lval_pop(v, 0));

    return v;

}


lval* builtin_list(lval* a) {

    a->type = LVAL_QEXPR;
    return a;

}


lval* builtin_eval(lval* a) {

    /* Check error conditions */
    LASSERT(a, a->count == 1,
            "Function 'eval' passed too many arguments!");

    LASSERT(a, a->cell[0]->type == LVAL_QEXPR,
        "Function 'eval' passed incorrect type!");

    lval* x = lval_take(a, 0);
    x->type = LVAL_SEXPR;
    return lval_eval(x);

}


lval* builtin_join(lval* a) {

    /* Check error conditions */
    for (size_t i = 0; i < a->count; i++) {
        LASSERT(a, a->cell[i]->type == LVAL_QEXPR,
        "Function 'join' passed incorrect type!");
    }

    lval* x = lval_pop(a, 0);

    while (a->count) {
        x = lval_join(x, lval_pop(a, 0));
    }

    lval_del(a);
    return x;

}


lval* lval_join(lval* x, lval* y) {

    /* For each cell in y add it to x */
    while (y->count) {
        x = lval_add(x, lval_pop(y, 0));
    }

    /* Delete the empty y and return x */
    lval_del(y);
    return x;

}


long min(long x, long y) {
    if (x <= y) {
        return x;
    } else {
        return y;
    }
}


long max(long x, long y) {
    if (x >= y) {
        return x;
    } else {
        return y;
    }
}


int main() {

    /* Create some parsers */
    mpc_parser_t* Number = mpc_new("number");
    mpc_parser_t* Symbol = mpc_new("symbol");
    mpc_parser_t* Sexpr = mpc_new("sexpr");
    mpc_parser_t* Qexpr = mpc_new("qexpr");
    mpc_parser_t* Expr = mpc_new("expr");
    mpc_parser_t* Lispy = mpc_new("lispy");

    /* Define them with the following language */
    mpca_lang(MPCA_LANG_DEFAULT, parser,
        Number, Symbol, Sexpr, Qexpr, Expr, Lispy);

    /* Print version and exit information */
    puts(lispy_version);
    puts("Press Ctrl+c to exit\n");

    /* In a never ending loop */
    while (1) {
        /* Output our prompt and get input */
        char* input = readline("lispy> ");

        /* Add input to history */
        add_history(input);

        /* Attempt to parse the user input */
        mpc_result_t r;
        if (mpc_parse("<stdin>", input, Lispy, &r)) {
            /* On success evaluate the user input */
            lval* x = lval_eval(lval_read(r.output));
            lval_println(x);
            lval_del(x);
        } else {
            /* Otherwise print the error */
            mpc_err_print(r.error);
            mpc_err_delete(r.error);
        }

        /* Free retrieved input */
        free(input);
    }

    /* Undefine and delete our parsers */
    mpc_cleanup(6, Number, Symbol, Sexpr, Qexpr, Expr, Lispy);

    return 0;
}