mirror of https://github.com/smlckz/lith
Initial commit: now Turing complete!
This commit is contained in:
Sudipto Mallick
commit
0c4491519e
|
|
@ -0,0 +1,3 @@
|
|||
Permission to use, copy, modify and/or distribute this software for any purpose with or without fee is hereby granted.
|
||||
|
||||
THE SOFTWARE IS PROVIDED "AS IS" AND THE AUTHOR DISCLAIMS ALL WARRANTIES WITH REGARD TO THIS SOFTWARE INCLUDING ALL IMPLIED WARRANTIES OF MERCHANTIBILITY AND FITNESS. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR ANY SPECIAL, DIRECT, INDIRECT, OR CONSEQUENTIAL DAMAGES OR ANY DAMAGES WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR PROFITS, WHETHER IN AN ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION, ARISING OUT OF OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE.
|
||||
|
|
@ -0,0 +1,18 @@
|
|||
BIN = lith
|
||||
CC = gcc
|
||||
CFLAGS = -g -std=c89 -Wall
|
||||
LDFLAGS =
|
||||
|
||||
SRCS = $(wildcard *.c)
|
||||
OBJS = $(SRCS:.c=.o)
|
||||
|
||||
$(BIN): $(OBJS)
|
||||
$(CC) $(CFLAGS) $(LDFLAGS) -o $@ $(OBJS)
|
||||
|
||||
%.o: %.c lith.h
|
||||
$(CC) $(CFLAGS) -c -o $@ $<
|
||||
|
||||
clean:
|
||||
rm -f $(BIN) $(OBJS)
|
||||
|
||||
all: $(BIN)
|
||||
|
|
@ -0,0 +1,999 @@
|
|||
/* lith: a small interpreter written in C89: as a library */
|
||||
#include "lith.h"
|
||||
|
||||
#include <stdio.h>
|
||||
#include <stdlib.h>
|
||||
#include <string.h>
|
||||
|
||||
static void *emalloc(lith_st *L, size_t len)
|
||||
{
|
||||
void *p;
|
||||
p = malloc(len);
|
||||
if (!p) {
|
||||
L->error = LITH_ERR_NOMEM;
|
||||
}
|
||||
return p;
|
||||
}
|
||||
|
||||
static char *lith__strndup(lith_st *L, char *str, size_t len)
|
||||
{
|
||||
char *newstr, *p;
|
||||
newstr = emalloc(L, len + 1);
|
||||
if (!newstr) return NULL;
|
||||
p = newstr;
|
||||
while (len--) *p++ = *str++;
|
||||
*p = '\0';
|
||||
return newstr;
|
||||
}
|
||||
|
||||
static void print_string(lith_string string)
|
||||
{
|
||||
size_t i;
|
||||
char *s;
|
||||
s = string.buf;
|
||||
putchar('"');
|
||||
for (i = 0; i < string.len; s++, i++) {
|
||||
if ((*s == '\\') || (*s == '"')) {
|
||||
putchar('\\');
|
||||
putchar(*s);
|
||||
} else if (*s == '\n') {
|
||||
printf("\\n");
|
||||
} else if (*s == '\t') {
|
||||
printf("\\t");
|
||||
} else if (*s == '\0') {
|
||||
printf("\\0");
|
||||
} else if ((*s < 32) || (*s > 126)) {
|
||||
printf("\\x%02X", (unsigned char)(*s));
|
||||
} else {
|
||||
putchar(*s);
|
||||
}
|
||||
}
|
||||
putchar('"');
|
||||
}
|
||||
|
||||
static char *skip(lith_st *L, char *input)
|
||||
{
|
||||
size_t len;
|
||||
while (*input) {
|
||||
if ((len = strspn(input, " \t\n")) > 0) {
|
||||
input += len;
|
||||
} else if (*input == ';') {
|
||||
if (!(input = strchr(input, '\n')))
|
||||
break;
|
||||
} else { break; }
|
||||
}
|
||||
if (!input || !*input) {
|
||||
L->error = LITH_ERR_EOF;
|
||||
}
|
||||
return input;
|
||||
}
|
||||
|
||||
static int ishexchar(int c)
|
||||
{
|
||||
return (('0' <= c) && (c <= '9')) || (('a' <= c) && (c <= 'f')) || (('A' <= c) && (c <= 'F'));
|
||||
}
|
||||
|
||||
static void eat_string(lith_st *L, char *start, char **end)
|
||||
{
|
||||
for (*end = start; **end && (**end != '"'); ++*end) {
|
||||
if (**end == '\\') {
|
||||
++*end;
|
||||
if (**end == 'x') {
|
||||
if (!((ishexchar(*++*end) && ishexchar(*++*end)))) { /* May God and You forgive me */
|
||||
L->error = LITH_ERR_SYNTAX;
|
||||
L->error_state.success = 0;
|
||||
L->error_state.msg = "Invalid character escape literal, expecting two hexadecimal characters";
|
||||
return;
|
||||
}
|
||||
}
|
||||
}
|
||||
}
|
||||
if (!**end) {
|
||||
L->error = LITH_ERR_EOF;
|
||||
L->error_state.success = 0;
|
||||
L->error_state.msg = "while reading a string literal";
|
||||
} else {
|
||||
/* skip the string ending " character */
|
||||
++*end;
|
||||
}
|
||||
}
|
||||
|
||||
static void lex(lith_st *L, char *input, char **start, char **end)
|
||||
{
|
||||
if (!(input = skip(L, input))) { *start = *end = NULL; return; }
|
||||
*start = input;
|
||||
if (strchr("()", *input)) {
|
||||
*end = input + 1;
|
||||
} else if (*input == '"') {
|
||||
/* skip the string starting " character */
|
||||
eat_string(L, *start + 1, end);
|
||||
} else {
|
||||
*end = *start + strcspn(*start, " \t\n;()");
|
||||
}
|
||||
}
|
||||
|
||||
static char *read_string(lith_st *L, char *start, char *end, size_t *len)
|
||||
{
|
||||
char *string, *p;
|
||||
p = string = emalloc(L, end - start);
|
||||
if (!p) return NULL;
|
||||
for (start++; start < end; start++, p++) {
|
||||
if (*start == '\\') {
|
||||
switch (*++start) {
|
||||
case 'n': *p = '\n'; break;
|
||||
case 'r': *p = '\r'; break;
|
||||
case 't': *p = '\t'; break;
|
||||
case '0': *p = '\0'; break;
|
||||
case 'x': *p = (char) strtol(++start, NULL, 16); ++start; break;
|
||||
default: *p = *start; break;
|
||||
}
|
||||
} else {
|
||||
*p = *start;
|
||||
}
|
||||
}
|
||||
*len = p - string;
|
||||
return string;
|
||||
}
|
||||
|
||||
static lith_value *read_atom(lith_st *L, char *start, char *end)
|
||||
{
|
||||
char *string, *next;
|
||||
int sign;
|
||||
size_t length;
|
||||
long integer;
|
||||
double number;
|
||||
lith_value *val;
|
||||
|
||||
if (*start == '"') {
|
||||
string = read_string(L, start, end - 1, &length);
|
||||
if (LITH_IS_ERR(L)) return NULL;
|
||||
val = lith_make_string(L, string, length);
|
||||
free(string);
|
||||
return val;
|
||||
}
|
||||
if ((*start == '+') || (*start == '-')) sign = (*start == '-') ? -1 : 1;
|
||||
else sign = 1;
|
||||
integer = strtol(start, &next, 10);
|
||||
if (*next == '.') {
|
||||
number = strtod(next, &next);
|
||||
number *= sign;
|
||||
number += integer;
|
||||
return lith_make_number(L, number);
|
||||
} else if (next == end) {
|
||||
return lith_make_integer(L, integer);
|
||||
} else {
|
||||
string = lith__strndup(L, start, end - start);
|
||||
if (!string) return NULL;
|
||||
val = (!strcmp(string, "nil")) ? L->nil : lith_get_symbol(L, string);
|
||||
free(string);
|
||||
return val;
|
||||
}
|
||||
}
|
||||
|
||||
static lith_value *read_expr(lith_st *L, char *start, char **end);
|
||||
|
||||
static lith_value *read_list_expr(lith_st *L, char *start, char **end)
|
||||
{
|
||||
lith_value *p, *r, *v;
|
||||
char *t;
|
||||
*end = start;
|
||||
v = p = L->nil;
|
||||
for (;;) {
|
||||
lex(L, *end, &t, end);
|
||||
if (LITH_IS_ERR(L)) return NULL;
|
||||
if (*t == ')') return v;
|
||||
if (*t == '.' && (*end - t == 1)) {
|
||||
if (LITH_IS_NIL(p)) {
|
||||
L->error = LITH_ERR_SYNTAX;
|
||||
L->error_state.msg = "invalid improper list starting with '.'";
|
||||
lith_free_value(v);
|
||||
return NULL;
|
||||
}
|
||||
r = read_expr(L, *end, end);
|
||||
if (LITH_IS_ERR(L)) {
|
||||
lith_free_value(v);
|
||||
return NULL;
|
||||
}
|
||||
LITH_CDR(p) = r;
|
||||
lex(L, *end, &t, end);
|
||||
if (LITH_IS_ERR(L) || (*t != ')')) {
|
||||
L->error = LITH_ERR_SYNTAX;
|
||||
L->error_state.msg = "expecting ')' for the end of this improper list";
|
||||
lith_free_value(v);
|
||||
return NULL;
|
||||
}
|
||||
return v;
|
||||
}
|
||||
r = read_expr(L, t, end);
|
||||
if (LITH_IS_ERR(L)) {
|
||||
lith_free_value(v);
|
||||
return NULL;
|
||||
}
|
||||
if (LITH_IS_NIL(p)) {
|
||||
v = LITH_CONS(L, r, L->nil);
|
||||
p = v;
|
||||
} else {
|
||||
LITH_CDR(p) = LITH_CONS(L, r, L->nil);
|
||||
p = LITH_CDR(p);
|
||||
}
|
||||
}
|
||||
}
|
||||
|
||||
static lith_value *read_expr(lith_st *L, char *start, char **end)
|
||||
{
|
||||
char *t;
|
||||
lex(L, start, &t, end);
|
||||
if (LITH_IS_ERR(L)) return NULL;
|
||||
if (*t == '(') {
|
||||
return read_list_expr(L, *end, end);
|
||||
} else if (*t == ')') {
|
||||
L->error = LITH_ERR_SYNTAX;
|
||||
L->error_state.msg = "unbalanced parenthesis, expected an expression";
|
||||
return NULL;
|
||||
} else {
|
||||
return read_atom(L, t, *end);
|
||||
}
|
||||
}
|
||||
|
||||
static int is_proper_list(lith_value *list)
|
||||
{
|
||||
while (!LITH_IS_NIL(list)) {
|
||||
list = LITH_CDR(list);
|
||||
if (!(LITH_IS_NIL(list) || LITH_IS(list, LITH_TYPE_PAIR))) {
|
||||
return 0;
|
||||
}
|
||||
}
|
||||
return 1;
|
||||
}
|
||||
|
||||
static size_t list_length(lith_value *v)
|
||||
{
|
||||
size_t len;
|
||||
for (len = 0; !LITH_IS_NIL(v); len++) v = LITH_CDR(v);
|
||||
return len;
|
||||
}
|
||||
|
||||
static size_t lamargs_length(lith_value *args, int *im)
|
||||
{
|
||||
size_t i;
|
||||
for (i = 0; LITH_IS(args, LITH_TYPE_PAIR); args = LITH_CDR(args)) ++i;
|
||||
*im = !LITH_IS_NIL(args);
|
||||
return i;
|
||||
}
|
||||
|
||||
static lith_value *builtin__car(lith_st *L, lith_value *args)
|
||||
{
|
||||
lith_value *list;
|
||||
if (!lith_expect_nargs(L, "car", 1, args, 1)) return NULL;
|
||||
list = LITH_CAR(args);
|
||||
if (!lith_expect_type(L, "car", 1, LITH_TYPE_PAIR, list)) return NULL;
|
||||
return LITH_CAR(list);
|
||||
}
|
||||
|
||||
static lith_value *builtin__cdr(lith_st *L, lith_value *args)
|
||||
{
|
||||
lith_value *pair;
|
||||
if (!lith_expect_nargs(L, "cdr", 1, args, 1)) return NULL;
|
||||
pair = LITH_CAR(args);
|
||||
if (!lith_expect_type(L, "cdr", 1, LITH_TYPE_PAIR, pair)) return NULL;
|
||||
return LITH_CDR(pair);
|
||||
}
|
||||
|
||||
static lith_value *builtin__cons(lith_st *L, lith_value *args)
|
||||
{
|
||||
lith_value *head, *tail;
|
||||
if (!lith_expect_nargs(L, "cons", 2, args, 1)) return NULL;
|
||||
head = LITH_CAR(args);
|
||||
tail = LITH_CAR(LITH_CDR(args));
|
||||
return LITH_CONS(L, head, tail);
|
||||
}
|
||||
|
||||
static void lith__print(lith_value *v)
|
||||
{
|
||||
char *s;
|
||||
size_t i, len;
|
||||
if (LITH_IS(v, LITH_TYPE_STRING)) {
|
||||
s = v->value.string.buf;
|
||||
len = v->value.string.len;
|
||||
for (i = 0; i < len; i++)
|
||||
putchar(*s++);
|
||||
} else {
|
||||
lith_print_value(v);
|
||||
}
|
||||
}
|
||||
|
||||
static lith_value *builtin__print(lith_st *L, lith_value *args)
|
||||
{
|
||||
lith_value *v;
|
||||
if (!lith_expect_nargs(L, "print", 1, args, 0)) return NULL;
|
||||
v = args;
|
||||
lith__print(LITH_CAR(v));
|
||||
v = LITH_CDR(v);
|
||||
while (!LITH_IS_NIL(v)) {
|
||||
putchar(' ');
|
||||
lith__print(LITH_CAR(v));
|
||||
v = LITH_CDR(v);
|
||||
}
|
||||
putchar('\n');
|
||||
return L->nil;
|
||||
}
|
||||
|
||||
#define COMMON1(fname) \
|
||||
int n1i, n1n, n2i, n2n, n1m, n2m; \
|
||||
lith_value *ret, *arg1, *arg2; \
|
||||
if (!lith_expect_nargs(L, fname, 2, args, 1)) return NULL; \
|
||||
arg1 = LITH_CAR(args); \
|
||||
arg2 = LITH_CAR(LITH_CDR(args)); \
|
||||
n1i = LITH_IS(arg1, LITH_TYPE_INTEGER), n1n = LITH_IS(arg1, LITH_TYPE_NUMBER), n1m = n1i || n1n; \
|
||||
n2i = LITH_IS(arg2, LITH_TYPE_INTEGER), n2n = LITH_IS(arg2, LITH_TYPE_NUMBER), n2m = n2i || n2n; \
|
||||
if (!n1m || !n2m) { \
|
||||
L->error = LITH_ERR_TYPE; \
|
||||
L->error_state.manual = 1; \
|
||||
L->error_state.msg = "expected numeric types (integers or numbers) as argument"; \
|
||||
return NULL; \
|
||||
}
|
||||
|
||||
#define COMMON2(op) \
|
||||
if (n1i && n2i) { \
|
||||
ret = lith_make_integer(L, arg1->value.integer op arg2->value.integer); \
|
||||
} else { \
|
||||
ret = lith_make_number(L, (n1i ? ((double) (arg1->value.integer)) : arg1->value.number) op (n2i ? ((double) (arg2->value.integer)) : arg2->value.number)); \
|
||||
} \
|
||||
return ret;
|
||||
|
||||
static lith_value *builtin__add(lith_st *L, lith_value *args)
|
||||
{
|
||||
COMMON1(":+")
|
||||
COMMON2(+)
|
||||
}
|
||||
|
||||
static lith_value *builtin__subtract(lith_st *L, lith_value *args)
|
||||
{
|
||||
COMMON1(":-")
|
||||
COMMON2(-)
|
||||
}
|
||||
|
||||
static lith_value *builtin__multiply(lith_st *L, lith_value *args)
|
||||
{
|
||||
COMMON1(":*")
|
||||
COMMON2(*)
|
||||
}
|
||||
|
||||
#define COMMON3(op, q) \
|
||||
if (q && (arg2->value.integer == 0L)) { \
|
||||
L->error = LITH_ERR_TYPE; \
|
||||
L->error_state.manual = 1; \
|
||||
L->error_state.msg = "cannot " op " by zero!!"; \
|
||||
return NULL; \
|
||||
}
|
||||
|
||||
static lith_value *builtin__divide(lith_st *L, lith_value *args)
|
||||
{
|
||||
COMMON1(":/")
|
||||
COMMON3("divide", n2i)
|
||||
COMMON2(/)
|
||||
}
|
||||
|
||||
static lith_value *builtin__modulus(lith_st *L, lith_value *args)
|
||||
{
|
||||
lith_value *arg1, *arg2;
|
||||
if (!lith_expect_nargs(L, ":%", 2, args, 1)) return NULL;
|
||||
arg1 = LITH_CAR(args);
|
||||
arg2 = LITH_CAR(LITH_CDR(args));
|
||||
if (!LITH_IS(arg1, LITH_TYPE_INTEGER) || !LITH_IS(arg2, LITH_TYPE_INTEGER)) {
|
||||
L->error = LITH_ERR_TYPE;
|
||||
L->error_state.manual = 1;
|
||||
L->error_state.msg = "can calculate modulus with integral only arguments";
|
||||
return NULL;
|
||||
}
|
||||
COMMON3("mod", 1)
|
||||
return lith_make_integer(L, arg1->value.integer % arg2->value.integer);
|
||||
}
|
||||
|
||||
#define COMMON4(op) \
|
||||
if (n1i && n2i) { \
|
||||
return LITH_IN_BOOL(arg1->value.integer op arg2->value.integer); \
|
||||
} \
|
||||
return LITH_IN_BOOL((n1i ? ((double) (arg1->value.integer)) : arg1->value.number) op (n2i ? ((double) (arg2->value.integer)) : arg2->value.number)) ;
|
||||
|
||||
static lith_value *builtin__less_than(lith_st *L, lith_value *args)
|
||||
{
|
||||
COMMON1(":<")
|
||||
COMMON4(<)
|
||||
}
|
||||
|
||||
static lith_value *builtin__equal(lith_st *L, lith_value *args)
|
||||
{
|
||||
COMMON1(":==")
|
||||
COMMON4(==)
|
||||
}
|
||||
|
||||
static lith_value *builtin__greater_than(lith_st *L, lith_value *args)
|
||||
{
|
||||
COMMON1(":>")
|
||||
COMMON4(>)
|
||||
}
|
||||
|
||||
#undef COMMON4
|
||||
#undef COMMON3
|
||||
#undef COMMON2
|
||||
#undef COMMON1
|
||||
|
||||
static lith_value *builtin__eq(lith_st *L, lith_value *args)
|
||||
{
|
||||
int eq;
|
||||
lith_value *arg1, *arg2;
|
||||
if (!lith_expect_nargs(L, "eq?", 2, args, 1)) return NULL;
|
||||
arg1 = LITH_CAR(args);
|
||||
arg2 = LITH_CAR(LITH_CDR(args));
|
||||
if (arg1->type != arg2->type) return L->False;
|
||||
switch (arg1->type) {
|
||||
case LITH_TYPE_NIL:
|
||||
return L->True;
|
||||
case LITH_TYPE_INTEGER:
|
||||
eq = arg1->value.integer == arg2->value.integer; break;
|
||||
case LITH_TYPE_NUMBER:
|
||||
eq = arg1->value.number == arg2->value.number; break;
|
||||
case LITH_TYPE_STRING:
|
||||
if (arg1->value.string.len != arg2->value.string.len) return L->False;
|
||||
eq = !memcmp(arg1->value.string.buf, arg2->value.string.buf, arg2->value.string.len); break;
|
||||
default: eq = arg1 == arg2; break;
|
||||
}
|
||||
return LITH_IN_BOOL(eq);
|
||||
}
|
||||
|
||||
static void init_types(char **types)
|
||||
{
|
||||
types[LITH_TYPE_NIL] = "nil";
|
||||
types[LITH_TYPE_PAIR] = "pair";
|
||||
types[LITH_TYPE_BOOLEAN] = "boolean";
|
||||
types[LITH_TYPE_INTEGER] = "integer";
|
||||
types[LITH_TYPE_NUMBER] = "number";
|
||||
types[LITH_TYPE_SYMBOL] = "symbol";
|
||||
types[LITH_TYPE_STRING] = "string";
|
||||
types[LITH_TYPE_BUILTIN] = "builtin";
|
||||
types[LITH_TYPE_CLOSURE] = "closure";
|
||||
}
|
||||
|
||||
/* Public functions */
|
||||
|
||||
void lith_init(lith_st *L)
|
||||
{
|
||||
L->error = LITH_ERR_OK;
|
||||
L->error_state.manual = 0;
|
||||
L->error_state.success = 1;
|
||||
L->error_state.sym = L->error_state.msg = L->error_state.name = NULL;
|
||||
L->nil = lith_new_value(L);
|
||||
L->nil->type = LITH_TYPE_NIL;
|
||||
L->True = lith_new_value(L);
|
||||
L->False = lith_new_value(L);
|
||||
L->True->type = L->False->type = LITH_TYPE_BOOLEAN;
|
||||
L->True->value.boolean = 1;
|
||||
L->False->value.boolean = 0;
|
||||
L->symbol_table = L->nil;
|
||||
L->global = lith_new_env(L, L->nil);
|
||||
L->global = lith_new_env(L, L->global);
|
||||
L->filename = "<<unspecified>>";
|
||||
init_types(L->types);
|
||||
lith_fill_env(L);
|
||||
}
|
||||
|
||||
void lith_free(lith_st *L)
|
||||
{
|
||||
lith_value *p, *v;
|
||||
lith_free_value(L->global);
|
||||
p = L->symbol_table;
|
||||
while (!LITH_IS_NIL(p)) {
|
||||
v = LITH_CAR(p);
|
||||
free(v->value.symbol);
|
||||
free(v);
|
||||
p = LITH_CDR(p);
|
||||
}
|
||||
free(L->False);
|
||||
free(L->True);
|
||||
free(L->nil);
|
||||
}
|
||||
|
||||
lith_value *lith_new_value(lith_st *L)
|
||||
{
|
||||
return emalloc(L, sizeof(lith_value));
|
||||
}
|
||||
|
||||
lith_value *lith_make_integer(lith_st *L, long integer)
|
||||
{
|
||||
lith_value *val;
|
||||
val = lith_new_value(L);
|
||||
if (!val) return NULL;
|
||||
val->type = LITH_TYPE_INTEGER;
|
||||
val->value.integer = integer;
|
||||
return val;
|
||||
}
|
||||
|
||||
lith_value *lith_make_number(lith_st *L, double number)
|
||||
{
|
||||
lith_value *val;
|
||||
val = lith_new_value(L);
|
||||
if (!val) return NULL;
|
||||
val->type = LITH_TYPE_NUMBER;
|
||||
val->value.number = number;
|
||||
return val;
|
||||
}
|
||||
|
||||
lith_value *lith_make_symbol(lith_st *L, char *symbol)
|
||||
{
|
||||
lith_value *val;
|
||||
char *sym;
|
||||
val = lith_new_value(L);
|
||||
if (!val) return NULL;
|
||||
val->type = LITH_TYPE_SYMBOL;
|
||||
sym = lith__strndup(L, symbol, strlen(symbol));
|
||||
if (!sym) { free(val); return NULL; }
|
||||
val->value.symbol = sym;
|
||||
return val;
|
||||
}
|
||||
|
||||
lith_value *lith_make_builtin(lith_st *L, lith_builtin_function function)
|
||||
{
|
||||
lith_value *val;
|
||||
val = lith_new_value(L);
|
||||
if (!val) return NULL;
|
||||
val->type = LITH_TYPE_BUILTIN;
|
||||
val->value.function = function;
|
||||
return val;
|
||||
}
|
||||
|
||||
lith_value *lith_make_closure(lith_st *L, lith_env *parent_env, lith_value *arg_names, lith_value *body)
|
||||
{
|
||||
lith_value *val, *p;
|
||||
arg_names = lith_copy_value(L, arg_names);
|
||||
if (!arg_names) return NULL;
|
||||
body = lith_copy_value(L, body);
|
||||
if (!body) { lith_free_value(arg_names); return NULL; }
|
||||
p = LITH_CONS(L, arg_names, body);
|
||||
if (!p) { lith_free_value(arg_names); lith_free_value(body); return NULL; }
|
||||
val = LITH_CONS(L, parent_env, p);
|
||||
if (!val) { lith_free_value(p); return NULL; }
|
||||
val->type = LITH_TYPE_CLOSURE;
|
||||
return val;
|
||||
}
|
||||
|
||||
lith_value *lith_make_string(lith_st *L, char *string, size_t len)
|
||||
{
|
||||
lith_value *val;
|
||||
char *str;
|
||||
val = lith_new_value(L);
|
||||
if (!val) return NULL;
|
||||
val->type = LITH_TYPE_STRING;
|
||||
str = lith__strndup(L, string, len);
|
||||
if (!str) { free(val); return NULL; }
|
||||
val->value.string.len = len;
|
||||
val->value.string.buf = str;
|
||||
return val;
|
||||
}
|
||||
|
||||
lith_value *lith_make_pair(lith_st *L, lith_value *car, lith_value *cdr)
|
||||
{
|
||||
lith_value *val;
|
||||
val = lith_new_value(L);
|
||||
if (!val) return NULL;
|
||||
val->type = LITH_TYPE_PAIR;
|
||||
LITH_CAR(val) = car;
|
||||
LITH_CDR(val) = cdr;
|
||||
return val;
|
||||
}
|
||||
|
||||
void lith_free_value(lith_value *val)
|
||||
{
|
||||
if (LITH_IS(val, LITH_TYPE_PAIR)) {
|
||||
lith_free_value(LITH_CAR(val));
|
||||
lith_free_value(LITH_CDR(val));
|
||||
} else if (LITH_IS(val, LITH_TYPE_CLOSURE)) {
|
||||
lith_free_value(LITH_CDR(val));
|
||||
} else if (LITH_IS(val, LITH_TYPE_STRING)) {
|
||||
free(val->value.string.buf);
|
||||
} else if (LITH_IS_NIL(val) || LITH_IS(val, LITH_TYPE_BOOLEAN) || LITH_IS(val, LITH_TYPE_SYMBOL)) {
|
||||
return;
|
||||
}
|
||||
free(val);
|
||||
}
|
||||
|
||||
lith_value *lith_get_symbol(lith_st *L, char *name)
|
||||
{
|
||||
lith_value *sym, *p;
|
||||
p = L->symbol_table;
|
||||
while (!LITH_IS_NIL(p)) {
|
||||
sym = LITH_CAR(p);
|
||||
if (LITH_SYM_EQ(sym, name)) return sym;
|
||||
p = LITH_CDR(p);
|
||||
}
|
||||
sym = lith_make_symbol(L, name);
|
||||
if (!sym) return NULL;
|
||||
p = LITH_CONS(L, sym, L->symbol_table);
|
||||
if (!p) { lith_free_value(sym); return NULL; }
|
||||
L->symbol_table = p;
|
||||
return sym;
|
||||
}
|
||||
|
||||
void lith_print_value(lith_value *val)
|
||||
{
|
||||
if (LITH_IS_NIL(val)) {
|
||||
printf("()");
|
||||
} else if (LITH_IS(val, LITH_TYPE_SYMBOL)) {
|
||||
printf("%s", val->value.symbol);
|
||||
} else if (LITH_IS(val, LITH_TYPE_STRING)) {
|
||||
print_string(val->value.string);
|
||||
} else if (LITH_IS(val, LITH_TYPE_BOOLEAN)) {
|
||||
printf("#%c", val->value.boolean ? 't' : 'f');
|
||||
} else if (LITH_IS(val, LITH_TYPE_INTEGER)) {
|
||||
printf("%ld", val->value.integer);
|
||||
} else if (LITH_IS(val, LITH_TYPE_NUMBER)) {
|
||||
printf("%.*f", LITH_NFP, val->value.number);
|
||||
} else if (LITH_IS(val, LITH_TYPE_BUILTIN)) {
|
||||
printf("#builtin:<%p>", val->value.function);
|
||||
} else if (LITH_IS(val, LITH_TYPE_CLOSURE)) {
|
||||
printf("#lambda:<%p>", val);
|
||||
} else if (!LITH_IS(val, LITH_TYPE_PAIR)) {
|
||||
printf("#<%p>", val);
|
||||
} else {
|
||||
putchar('(');
|
||||
lith_print_value(LITH_CAR(val));
|
||||
val = LITH_CDR(val);
|
||||
while (!LITH_IS_NIL(val)) {
|
||||
if (LITH_IS(val, LITH_TYPE_PAIR)) {
|
||||
putchar(' ');
|
||||
lith_print_value(LITH_CAR(val));
|
||||
val = LITH_CDR(val);
|
||||
} else {
|
||||
printf(" . ");
|
||||
lith_print_value(val);
|
||||
break;
|
||||
}
|
||||
}
|
||||
putchar(')');
|
||||
}
|
||||
}
|
||||
|
||||
lith_value *lith_copy_value(lith_st *L, lith_value *val)
|
||||
{
|
||||
lith_value *head, *pair, *p, *v, *w;
|
||||
if (!val) return NULL;
|
||||
switch (val->type) {
|
||||
case LITH_TYPE_INTEGER:
|
||||
return lith_make_integer(L, val->value.integer);
|
||||
case LITH_TYPE_NUMBER:
|
||||
return lith_make_number(L, val->value.number);
|
||||
case LITH_TYPE_STRING:
|
||||
return lith_make_string(L, val->value.string.buf, val->value.string.len);
|
||||
case LITH_TYPE_BUILTIN:
|
||||
return lith_make_builtin(L, val->value.function);
|
||||
case LITH_TYPE_CLOSURE:
|
||||
return lith_make_closure(L, LITH_CAR(val), LITH_CAR(LITH_CDR(val)), LITH_CDR(LITH_CDR(val)));
|
||||
case LITH_TYPE_PAIR:
|
||||
head = lith_copy_value(L, LITH_CAR(val));
|
||||
if (!head) return NULL;
|
||||
pair = LITH_CONS(L, head, L->nil);
|
||||
if (!pair) { lith_free_value(head); return NULL; }
|
||||
val = LITH_CDR(val);
|
||||
for (p = pair; LITH_IS(val, LITH_TYPE_PAIR); val = LITH_CDR(val), p = LITH_CDR(p)) {
|
||||
v = lith_copy_value(L, LITH_CAR(val));
|
||||
if (!v) { lith_free_value(pair); return NULL; }
|
||||
w = LITH_CONS(L, v, L->nil);
|
||||
if (!w) { lith_free_value(pair); lith_free_value(v); }
|
||||
LITH_CDR(p) = w;
|
||||
}
|
||||
if (!LITH_IS_NIL(val)) {
|
||||
v = lith_copy_value(L, val);
|
||||
if (!v) { lith_free_value(v); return NULL; }
|
||||
LITH_CDR(p) = v;
|
||||
}
|
||||
return pair;
|
||||
default: return val;
|
||||
}
|
||||
}
|
||||
|
||||
void lith_print_error(lith_st *L, int full)
|
||||
{
|
||||
struct lith_error_state E = L->error_state;
|
||||
if (full) fprintf(stderr, "lith: %s: ", L->filename);
|
||||
switch (L->error) {
|
||||
case LITH_ERR_OK:
|
||||
fprintf(stderr, "none");
|
||||
break;
|
||||
case LITH_ERR_EOF:
|
||||
if (!E.success) fprintf(stderr, "Unexpected ");
|
||||
fprintf(stderr, "End of File");
|
||||
if (!E.success) fprintf(stderr, ": %s", E.msg);
|
||||
break;
|
||||
case LITH_ERR_SYNTAX:
|
||||
fprintf(stderr, "syntax error: %s", E.msg);
|
||||
break;
|
||||
case LITH_ERR_NOMEM:
|
||||
fprintf(stderr, "no memory");
|
||||
break;
|
||||
case LITH_ERR_UNBOUND:
|
||||
fprintf(stderr, "unbound symbol: '%s'", E.sym);
|
||||
break;
|
||||
case LITH_ERR_NARGS:
|
||||
fprintf(stderr, "wrong number of arguments: expected %s%zu argument(s) but given %zu argument(s)", (E.nargs.exact ? "" : "at least "), E.nargs.expected, E.nargs.got);
|
||||
break;
|
||||
case LITH_ERR_TYPE:
|
||||
fprintf(stderr, "type error: ");
|
||||
if (E.manual) fprintf(stderr, E.msg);
|
||||
else fprintf(stderr, "expecting %s instead of %s as the argument number %zu", L->types[E.type.expected], L->types[E.type.got], E.type.narg);
|
||||
break;
|
||||
}
|
||||
if (E.name) fprintf(stderr, " [in '%s']", E.name);
|
||||
fputc('\n', stderr);
|
||||
}
|
||||
|
||||
lith_value *lith_read_expr(lith_st *L, char *start, char **end)
|
||||
{
|
||||
return read_expr(L, start, end);
|
||||
}
|
||||
|
||||
lith_env *lith_new_env(lith_st *L, lith_env *parent)
|
||||
{
|
||||
return LITH_CONS(L, parent, L->nil);
|
||||
}
|
||||
|
||||
void lith_free_env(lith_env *V)
|
||||
{
|
||||
lith_free_value(LITH_CDR(V));
|
||||
}
|
||||
|
||||
lith_value *lith_env_get(lith_st *L, lith_env *V, lith_value *name)
|
||||
{
|
||||
lith_env *parent;
|
||||
lith_value *kvs, *kv;
|
||||
parent = V;
|
||||
do {
|
||||
kvs = LITH_CDR(parent);
|
||||
parent = LITH_CAR(parent);
|
||||
while (!LITH_IS_NIL(kvs)) {
|
||||
kv = LITH_CAR(kvs);
|
||||
if (LITH_CAR(kv) == name) return LITH_CDR(kv);
|
||||
kvs = LITH_CDR(kvs);
|
||||
}
|
||||
} while (!LITH_IS_NIL(parent));
|
||||
L->error = LITH_ERR_UNBOUND;
|
||||
L->error_state.sym = name->value.symbol;
|
||||
return NULL;
|
||||
}
|
||||
|
||||
void lith_env_set(lith_st *L, lith_env *V, lith_value *name, lith_value *value)
|
||||
{
|
||||
lith_value *kvs, *kv;
|
||||
kvs = LITH_CDR(V);
|
||||
while (!LITH_IS_NIL(kvs)) {
|
||||
kv = LITH_CAR(kvs);
|
||||
if (name == LITH_CAR(kv)) {
|
||||
LITH_CDR(kv) = value;
|
||||
return;
|
||||
}
|
||||
kvs = LITH_CDR(kvs);
|
||||
}
|
||||
kv = LITH_CONS(L, name, value);
|
||||
if (!kv) return;
|
||||
LITH_CDR(V) = LITH_CONS(L, kv, LITH_CDR(V));
|
||||
}
|
||||
|
||||
void lith_fill_env(lith_st *L)
|
||||
{
|
||||
lith_env *V;
|
||||
V = L->global;
|
||||
lith_env_set(L, V, lith_get_symbol(L, "#t"), L->True);
|
||||
lith_env_set(L, V, lith_get_symbol(L, "#f"), L->False);
|
||||
#define LITH_FN_REGISTER(L, V, s, fn) lith_env_set(L, V, lith_get_symbol(L, s), lith_make_builtin(L, fn))
|
||||
LITH_FN_REGISTER(L, V, "print", builtin__print);
|
||||
LITH_FN_REGISTER(L, V, "car", builtin__car);
|
||||
LITH_FN_REGISTER(L, V, "cdr", builtin__cdr);
|
||||
LITH_FN_REGISTER(L, V, "cons", builtin__cons);
|
||||
LITH_FN_REGISTER(L, V, ":+", builtin__add);
|
||||
LITH_FN_REGISTER(L, V, ":-", builtin__subtract);
|
||||
LITH_FN_REGISTER(L, V, ":*", builtin__multiply);
|
||||
LITH_FN_REGISTER(L, V, ":/", builtin__divide);
|
||||
LITH_FN_REGISTER(L, V, ":%", builtin__modulus);
|
||||
LITH_FN_REGISTER(L, V, ":<", builtin__less_than);
|
||||
LITH_FN_REGISTER(L, V, ":==", builtin__equal);
|
||||
LITH_FN_REGISTER(L, V, ":>", builtin__greater_than);
|
||||
LITH_FN_REGISTER(L, V, "eq?", builtin__eq);
|
||||
#undef LITH_FN_REGISTER
|
||||
}
|
||||
|
||||
int lith_expect_nargs(lith_st *L, char *name, size_t expect, lith_value *args, int exact)
|
||||
{
|
||||
size_t len;
|
||||
struct lith_error_state *E;
|
||||
E = &L->error_state;
|
||||
len = list_length(args);
|
||||
if (exact ? (len != expect) : (len < expect)) {
|
||||
L->error = LITH_ERR_NARGS;
|
||||
E->name = name;
|
||||
E->nargs.expected = expect;
|
||||
E->nargs.exact = exact;
|
||||
E->nargs.got = len;
|
||||
return 0;
|
||||
} else {
|
||||
return 1;
|
||||
}
|
||||
}
|
||||
|
||||
int lith_expect_type(lith_st *L, char *name, size_t narg, lith_valtype type, lith_value *val)
|
||||
{
|
||||
struct lith_error_state *E;
|
||||
E = &L->error_state;
|
||||
if (LITH_IS(val, type))
|
||||
return 1;
|
||||
L->error = LITH_ERR_TYPE;
|
||||
E->name = name;
|
||||
E->type.expected = type;
|
||||
E->type.got = val->type;
|
||||
E->type.narg = narg;
|
||||
return 0;
|
||||
}
|
||||
|
||||
lith_value *lith_eval_expr(lith_st *L, lith_env *V, lith_value *expr)
|
||||
{
|
||||
lith_value *f, *rest, *sym, *val, *args, *p, *q;
|
||||
if (LITH_IS(expr, LITH_TYPE_SYMBOL)) {
|
||||
return lith_copy_value(L, lith_env_get(L, V, expr));
|
||||
} else if (!LITH_IS(expr, LITH_TYPE_PAIR)) {
|
||||
return lith_copy_value(L, expr);
|
||||
} else if (!is_proper_list(expr)) {
|
||||
L->error = LITH_ERR_SYNTAX;
|
||||
L->error_state.msg = "atom or proper list expected as expression";
|
||||
return NULL;
|
||||
}
|
||||
f = LITH_CAR(expr);
|
||||
rest = LITH_CDR(expr);
|
||||
if (LITH_IS(f, LITH_TYPE_SYMBOL)) {
|
||||
if (LITH_SYM_EQ(f, "quote")) {
|
||||
if (!lith_expect_nargs(L, "quote", 1, rest, 1))
|
||||
return NULL;
|
||||
return lith_copy_value(L, LITH_CAR(rest));
|
||||
} else if (LITH_SYM_EQ(f, "if")) {
|
||||
if (!lith_expect_nargs(L, "if", 3, rest, 1)) return NULL;
|
||||
val = lith_eval_expr(L, V, LITH_CAR(rest));
|
||||
if (LITH_IS_ERR(L)) return NULL;
|
||||
p = LITH_CDR(rest);
|
||||
return lith_eval_expr(L, V, LITH_CAR(LITH_TO_BOOL(val) ? p : LITH_CDR(p)));
|
||||
} else if (LITH_SYM_EQ(f, "define")) {
|
||||
if (!lith_expect_nargs(L, "define", 2, rest, 0))
|
||||
return NULL;
|
||||
sym = LITH_CAR(rest);
|
||||
p = LITH_CDR(rest);
|
||||
if (!LITH_IS(sym, LITH_TYPE_SYMBOL)) {
|
||||
if (!LITH_IS(sym, LITH_TYPE_PAIR)) {
|
||||
L->error = LITH_ERR_TYPE;
|
||||
L->error_state.name = "define";
|
||||
L->error_state.manual = 1;
|
||||
L->error_state.msg = "first argument must be a symbol or pair";
|
||||
return NULL;
|
||||
}
|
||||
args = LITH_CDR(sym);
|
||||
sym = LITH_CAR(sym);
|
||||
if (!lith_expect_type(L, "define", 1, LITH_TYPE_SYMBOL, sym)) return NULL;
|
||||
val = lith_make_closure(L, V, args, p);
|
||||
} else {
|
||||
if (!lith_expect_nargs(L, "define", 2, rest, 1)) return NULL;
|
||||
val = lith_eval_expr(L, V, LITH_CAR(p));
|
||||
}
|
||||
if (!val) return NULL;
|
||||
lith_env_set(L, V, sym, val);
|
||||
return L->nil;
|
||||
} else if (LITH_SYM_EQ(f, "lambda")) {
|
||||
if (!lith_expect_nargs(L, "{lambda}", 2, rest, 0))
|
||||
return NULL;
|
||||
args = LITH_CAR(rest);
|
||||
p = LITH_CDR(rest);
|
||||
if (!is_proper_list(p)) {
|
||||
L->error = LITH_ERR_SYNTAX;
|
||||
L->error_state.msg = "body of lambda expression must be proper list";
|
||||
return NULL;
|
||||
}
|
||||
for (q = args; LITH_IS(q, LITH_TYPE_PAIR); q = LITH_CDR(q)) {
|
||||
if (!LITH_IS(LITH_CAR(q), LITH_TYPE_SYMBOL)) {
|
||||
L->error = LITH_ERR_SYNTAX;
|
||||
L->error_state.msg = "arguments in lambda expression must be symbols";
|
||||
return NULL;
|
||||
}
|
||||
}
|
||||
if (!LITH_IS_NIL(q) && !LITH_IS(q, LITH_TYPE_SYMBOL)) {
|
||||
L->error = LITH_ERR_SYNTAX;
|
||||
L->error_state.msg = "arguments in lambda expression must be symbols";
|
||||
return NULL;
|
||||
}
|
||||
return lith_make_closure(L, V, args, p);
|
||||
}
|
||||
}
|
||||
f = lith_eval_expr(L, V, f);
|
||||
if (LITH_IS_NIL(rest)) args = L->nil;
|
||||
else {
|
||||
args = lith_copy_value(L, rest);
|
||||
if (!args) return NULL;
|
||||
rest = args;
|
||||
val = lith_eval_expr(L, V, LITH_CAR(rest));
|
||||
if (!val) return NULL;
|
||||
args = LITH_CONS(L, val, L->nil);
|
||||
if (!args) { lith_free_value(val); return NULL; }
|
||||
rest = LITH_CDR(rest);
|
||||
for (p = args; !LITH_IS_NIL(rest); p = LITH_CDR(p), rest = LITH_CDR(rest)) {
|
||||
val = lith_eval_expr(L, V, LITH_CAR(rest));
|
||||
if (!val) { lith_free_value(args); return NULL; }
|
||||
q = LITH_CONS(L, val, L->nil);
|
||||
if (!q) { lith_free_value(args); lith_free_value(val); return NULL; }
|
||||
LITH_CDR(p) = q;
|
||||
}
|
||||
}
|
||||
if (!f) return NULL;
|
||||
return lith_apply(L, f, args);
|
||||
}
|
||||
|
||||
lith_value *lith_apply(lith_st *L, lith_value *f, lith_value *args)
|
||||
{
|
||||
int imgr, imer;
|
||||
size_t gnargs, enargs;
|
||||
lith_env *env;
|
||||
lith_value *argn, *body, *r;
|
||||
if (LITH_IS(f, LITH_TYPE_BUILTIN)) {
|
||||
return (*f->value.function)(L, args);
|
||||
} else if (!LITH_IS(f, LITH_TYPE_CLOSURE)) {
|
||||
L->error = LITH_ERR_TYPE;
|
||||
L->error_state.manual = 1;
|
||||
L->error_state.msg = "can not call non-callable";
|
||||
L->error_state.name = "{apply}";
|
||||
return NULL;
|
||||
}
|
||||
env = lith_new_env(L, LITH_CAR(f));
|
||||
argn = LITH_CDR(f);
|
||||
body = LITH_CDR(argn);
|
||||
argn = LITH_CAR(argn);
|
||||
gnargs = lamargs_length(args, &imgr);
|
||||
enargs = lamargs_length(argn, &imer);
|
||||
if (imer ? (gnargs < enargs) : (gnargs != enargs)) {
|
||||
L->error = LITH_ERR_NARGS;
|
||||
L->error_state.name = "{lambda}";
|
||||
L->error_state.nargs.expected = enargs;
|
||||
L->error_state.nargs.got = gnargs;
|
||||
L->error_state.nargs.exact = !imer;
|
||||
return NULL;
|
||||
}
|
||||
while (LITH_IS(argn, LITH_TYPE_PAIR)) {
|
||||
lith_env_set(L, env, LITH_CAR(argn), LITH_CAR(args));
|
||||
argn = LITH_CDR(argn);
|
||||
args = LITH_CDR(args);
|
||||
}
|
||||
if (!LITH_IS_NIL(argn))
|
||||
lith_env_set(L, env, argn, args);
|
||||
r = NULL;
|
||||
while (!LITH_IS_NIL(body)) {
|
||||
if (r) lith_free_value(r);
|
||||
r = lith_eval_expr(L, env, LITH_CAR(body));
|
||||
body = LITH_CDR(body);
|
||||
}
|
||||
return r;
|
||||
}
|
||||
|
||||
void lith_run_string(lith_st *L, lith_env *V, char *input)
|
||||
{
|
||||
char *end;
|
||||
lith_value *expr, *res;
|
||||
end = input;
|
||||
L->filename = "<<string>>";
|
||||
|
||||
while (!LITH_IS_ERR(L)) {
|
||||
if ((expr = lith_read_expr(L, end, &end))) {
|
||||
printf(">> ");
|
||||
lith_print_value(expr);
|
||||
putchar('\n');
|
||||
if ((res = lith_eval_expr(L, V, expr))) {
|
||||
printf("-> ");
|
||||
lith_print_value(res);
|
||||
lith_free_value(res);
|
||||
putchar('\n');
|
||||
}
|
||||
lith_free_value(expr);
|
||||
}
|
||||
}
|
||||
lith_print_error(L, 1);
|
||||
}
|
||||
|
|
@ -0,0 +1,126 @@
|
|||
/* lith: library header */
|
||||
#ifndef lith_h
|
||||
#define lith_h
|
||||
|
||||
#include <stddef.h>
|
||||
|
||||
typedef struct lith_value lith_value;
|
||||
typedef struct lith_value lith_env;
|
||||
typedef struct lith_state lith_st;
|
||||
typedef struct lith_string lith_string;
|
||||
typedef enum lith_value_type lith_valtype;
|
||||
|
||||
enum lith_error {
|
||||
LITH_ERR_OK,
|
||||
LITH_ERR_EOF,
|
||||
LITH_ERR_SYNTAX,
|
||||
LITH_ERR_NOMEM,
|
||||
LITH_ERR_UNBOUND,
|
||||
LITH_ERR_NARGS,
|
||||
LITH_ERR_TYPE
|
||||
};
|
||||
|
||||
enum lith_value_type {
|
||||
LITH_TYPE_NIL,
|
||||
LITH_TYPE_PAIR,
|
||||
LITH_TYPE_BOOLEAN,
|
||||
LITH_TYPE_INTEGER,
|
||||
LITH_TYPE_NUMBER,
|
||||
LITH_TYPE_STRING,
|
||||
LITH_TYPE_SYMBOL,
|
||||
LITH_TYPE_BUILTIN,
|
||||
LITH_TYPE_CLOSURE,
|
||||
|
||||
LITH_NTYPES /* number of types */
|
||||
};
|
||||
|
||||
typedef lith_value *(*lith_builtin_function)(lith_st *, lith_value *);
|
||||
|
||||
struct lith_value {
|
||||
lith_valtype type;
|
||||
union {
|
||||
int boolean;
|
||||
long integer;
|
||||
double number;
|
||||
struct lith_string { size_t len; char *buf; } string;
|
||||
char *symbol;
|
||||
struct { struct lith_value *car, *cdr; } pair;
|
||||
lith_builtin_function function;
|
||||
} value;
|
||||
};
|
||||
|
||||
|
||||
#define LITH_IS(p, q) ((p)->type == (q))
|
||||
#define LITH_IS_NIL(p) (LITH_IS(p, LITH_TYPE_NIL))
|
||||
|
||||
#define LITH_SYM_EQ(S, s) !strcmp((S)->value.symbol, (s))
|
||||
|
||||
#define LITH_CAR(p) ((p)->value.pair.car)
|
||||
#define LITH_CDR(p) ((p)->value.pair.cdr)
|
||||
#define LITH_CONS lith_make_pair
|
||||
|
||||
struct lith_state {
|
||||
enum lith_error error;
|
||||
struct lith_error_state {
|
||||
int success, manual;
|
||||
char *msg, *sym, *name;
|
||||
struct lith_error_state__argsize { size_t expected, got; int exact; } nargs;
|
||||
struct lith_error_state__type { lith_valtype expected, got; size_t narg; } type;
|
||||
} error_state;
|
||||
char *types[LITH_NTYPES];
|
||||
lith_value *nil;
|
||||
lith_value *True, *False;
|
||||
lith_value *symbol_table;
|
||||
lith_env *global;
|
||||
char *filename;
|
||||
};
|
||||
|
||||
#define LITH_IS_ERR(L) ((L)->error != LITH_ERR_OK)
|
||||
#define LITH_TO_BOOL(B) ((!LITH_IS_NIL(B)) && !(LITH_IS(B, LITH_TYPE_BOOLEAN) && !((B)->value.boolean)))
|
||||
#define LITH_IN_BOOL(B) ((B) ? L->True : L->False)
|
||||
|
||||
/* When a number is printed, how many digits you want after the decimal point */
|
||||
#ifndef LITH_NFP
|
||||
#define LITH_NFP 8
|
||||
#endif
|
||||
|
||||
void lith_init(lith_st *);
|
||||
void lith_free(lith_st *);
|
||||
|
||||
void lith_print_error(lith_st *, int);
|
||||
|
||||
lith_value *lith_new_value(lith_st *);
|
||||
void lith_print_value(lith_value *);
|
||||
void lith_free_value(lith_value *);
|
||||
lith_value *lith_copy_value(lith_st *, lith_value *);
|
||||
|
||||
lith_value *lith_make_integer(lith_st *, long);
|
||||
lith_value *lith_make_number(lith_st *, double);
|
||||
lith_value *lith_make_symbol(lith_st *, char *);
|
||||
lith_value *lith_make_string(lith_st *, char *, size_t);
|
||||
lith_value *lith_make_builtin(lith_st *, lith_builtin_function);
|
||||
lith_value *lith_make_closure(lith_st *, lith_env *, lith_value *, lith_value *);
|
||||
lith_value *lith_make_pair(lith_st *, lith_value *, lith_value *);
|
||||
|
||||
lith_value *lith_get_symbol(lith_st *, char *);
|
||||
|
||||
lith_value *lith_read_expr(lith_st *, char *, char **);
|
||||
|
||||
lith_value *lith_eval_expr(lith_st *, lith_env *, lith_value *);
|
||||
|
||||
lith_value *lith_apply(lith_st *, lith_value *f, lith_value *args);
|
||||
|
||||
lith_env *lith_new_env(lith_st *, lith_env *);
|
||||
void lith_free_env(lith_env *);
|
||||
|
||||
lith_value *lith_env_get(lith_st *, lith_env *, lith_value *);
|
||||
void lith_env_set(lith_st *, lith_env *, lith_value *, lith_value *);
|
||||
|
||||
void lith_fill_env(lith_st *);
|
||||
|
||||
int lith_expect_type(lith_st *, char *, size_t, lith_valtype, lith_value *);
|
||||
int lith_expect_nargs(lith_st *, char *, size_t, lith_value *, int);
|
||||
|
||||
void lith_run_string(lith_st *, lith_env *, char *);
|
||||
|
||||
#endif
|
||||
|
|
@ -0,0 +1,29 @@
|
|||
/* lith: interpreter */
|
||||
|
||||
#include "lith.h"
|
||||
|
||||
#include <stdio.h>
|
||||
#include <stdlib.h>
|
||||
|
||||
int main(int argc, char **argv)
|
||||
{
|
||||
lith_st T, *L;
|
||||
lith_env *V;
|
||||
|
||||
if (argc < 2) return 32;
|
||||
|
||||
L = &T;
|
||||
|
||||
lith_init(L);
|
||||
V = lith_new_env(L, L->global);
|
||||
|
||||
lith_run_string(L, V, argv[1]);
|
||||
|
||||
printf("environment: "); lith_print_value(V); putchar('\n');
|
||||
printf("symbol table: "); lith_print_value(L->symbol_table); putchar('\n');
|
||||
|
||||
lith_free_env(V);
|
||||
lith_free(L);
|
||||
|
||||
return 0;
|
||||
}
|
||||
Loading…
Reference in New Issue