mirror of
https://github.com/samsonjs/lake.git
synced 2026-03-25 08:55:49 +00:00
147 lines
3.2 KiB
C
147 lines
3.2 KiB
C
/**
|
|
* lake.c
|
|
* Lake Scheme
|
|
*
|
|
* Copyright 2011 Sami Samhuri
|
|
* MIT License
|
|
*
|
|
* A quick and dirty scheme written in C, for fun and to use while
|
|
* reading The Little Schemer.
|
|
*
|
|
*/
|
|
|
|
#include <glib.h>
|
|
#include "comment.h"
|
|
#include "env.h"
|
|
#include "eval.h"
|
|
#include "lake.h"
|
|
#include "list.h"
|
|
#include "primitive.h"
|
|
#include "str.h"
|
|
#include "symtable.h"
|
|
|
|
char *lake_repr(LakeVal *expr)
|
|
{
|
|
if (expr == NULL) return g_strdup("(null)");
|
|
|
|
char *s = NULL;
|
|
|
|
switch (expr->type) {
|
|
|
|
case TYPE_SYM:
|
|
s = sym_repr(SYM(expr));
|
|
break;
|
|
|
|
case TYPE_BOOL:
|
|
s = BOOL_REPR(BOOL(expr));
|
|
break;
|
|
|
|
case TYPE_INT:
|
|
s = int_repr(INT(expr));
|
|
break;
|
|
|
|
case TYPE_STR:
|
|
s = g_strdup_printf("\"%s\"", STR_S(STR(expr)));
|
|
break;
|
|
|
|
case TYPE_LIST:
|
|
s = list_repr(LIST(expr));
|
|
break;
|
|
|
|
case TYPE_DLIST:
|
|
s = dlist_repr(DLIST(expr));
|
|
break;
|
|
|
|
case TYPE_PRIM:
|
|
s = prim_repr(PRIM(expr));
|
|
break;
|
|
|
|
case TYPE_FN:
|
|
s = fn_repr(FN(expr));
|
|
break;
|
|
|
|
case TYPE_COMM:
|
|
s = comment_repr(COMM(expr));
|
|
break;
|
|
|
|
default:
|
|
fprintf(stderr, "error: unrecognized value, type %d, size %zu bytes", expr->type, expr->size);
|
|
s = g_strdup("");
|
|
}
|
|
|
|
return s;
|
|
}
|
|
|
|
gboolean lake_is(LakeVal *a, LakeVal *b)
|
|
{
|
|
if (IS(TYPE_INT, a) && IS(TYPE_INT, b)) {
|
|
return INT_VAL(INT(a)) == INT_VAL(INT(b));
|
|
}
|
|
if (IS_NIL(a) && IS_NIL(b)) return TRUE;
|
|
return a == b;
|
|
}
|
|
|
|
static char *type_name(LakeVal *expr)
|
|
{
|
|
static char *type_names[9] = { "nil", "symbol", "boolean", "integer", "string", "list",
|
|
"dotted-list", "primitive", "function"
|
|
};
|
|
|
|
LakeType t = expr->type;
|
|
return t >= 0 && t <= 8 ? type_names[t] : "(not a LakeVal)";
|
|
}
|
|
|
|
gboolean lake_equal(LakeVal *a, LakeVal *b)
|
|
{
|
|
if (a->type != b->type) return FALSE;
|
|
switch (a->type) {
|
|
|
|
/* singletons can be compared directly */
|
|
case TYPE_SYM:
|
|
case TYPE_BOOL:
|
|
case TYPE_PRIM:
|
|
case TYPE_FN:
|
|
return a == b;
|
|
|
|
case TYPE_INT:
|
|
return INT_VAL(INT(a)) == INT_VAL(INT(b));
|
|
|
|
case TYPE_STR:
|
|
return str_equal(STR(a), STR(b));
|
|
|
|
case TYPE_LIST:
|
|
return list_equal(LIST(a), LIST(b));
|
|
|
|
case TYPE_DLIST:
|
|
return dlist_equal(DLIST(a), DLIST(b));
|
|
|
|
case TYPE_COMM:
|
|
return comment_equal(COMM(a), COMM(b));
|
|
|
|
default:
|
|
ERR("unknown type %d (%s)", a->type, type_name(a));
|
|
return FALSE;
|
|
}
|
|
}
|
|
|
|
static LakeBool *bool_make(gboolean val)
|
|
{
|
|
LakeBool *b = g_malloc(sizeof(LakeBool));
|
|
VAL(b)->type = TYPE_BOOL;
|
|
VAL(b)->size = sizeof(LakeBool);
|
|
b->val = val;
|
|
return b;
|
|
}
|
|
|
|
LakeCtx *lake_init(void)
|
|
{
|
|
LakeCtx *ctx = g_malloc(sizeof(LakeCtx));
|
|
ctx->toplevel = env_make(NULL);
|
|
ctx->symbols = g_hash_table_new(g_str_hash, g_str_equal);
|
|
ctx->special_form_handlers = symtable_make();
|
|
ctx->T = bool_make(TRUE);
|
|
ctx->F = bool_make(FALSE);
|
|
bind_primitives(ctx);
|
|
init_special_form_handlers(ctx);
|
|
return ctx;
|
|
}
|