From 05ef231de4861bbb2670488735426ce47b30e7ae Mon Sep 17 00:00:00 2001 From: Sami Samhuri Date: Thu, 21 Apr 2011 14:41:01 -0700 Subject: [PATCH] add is? and equal? primitives (is? is like eq?) --- src/bool.h | 1 - src/comment.c | 7 ++ src/comment.h | 2 + src/dlist.c | 9 +++ src/dlist.h | 2 + src/int.c | 5 -- src/int.h | 1 - src/lake.c | 42 ++++++++++++ src/lake.h | 7 +- src/list.c | 12 +++- src/list.h | 3 +- src/primitive.c | 165 ++++++++++++++++++++++++++++++++++++------------ src/primitive.h | 2 +- src/string.c | 6 +- src/string.h | 3 +- src/sym.c | 5 -- src/sym.h | 1 - src/symtable.c | 2 +- 18 files changed, 210 insertions(+), 65 deletions(-) diff --git a/src/bool.h b/src/bool.h index 268a5da..e16aba2 100644 --- a/src/bool.h +++ b/src/bool.h @@ -16,7 +16,6 @@ LakeBool *bool_from_int(int b); gboolean bool_val(LakeBool *b); LakeStr *bool_to_str(LakeBool *b); -LakeBool *bool_eq(LakeBool *a, LakeBool *b); char *bool_repr(LakeBool *b); LakeVal* bool_and(LakeVal *a, LakeVal *b); LakeVal* bool_or(LakeVal *a, LakeVal *b); diff --git a/src/comment.c b/src/comment.c index 2e64732..e65d4d4 100644 --- a/src/comment.c +++ b/src/comment.c @@ -7,8 +7,10 @@ * */ +#include #include "comment.h" #include "lake.h" +#include "string.h" static LakeComment *comment_alloc(void) { @@ -34,3 +36,8 @@ char *comment_repr(LakeComment *comment) { return g_strdup(STR_S(comment->text)); } + +gboolean comm_equal(LakeComment *a, LakeComment *b) +{ + return str_equal(COMM_TEXT(a), COMM_TEXT(b)); +} diff --git a/src/comment.h b/src/comment.h index 9839bd7..e5c66a3 100644 --- a/src/comment.h +++ b/src/comment.h @@ -10,10 +10,12 @@ #ifndef _LAKE_COMMENT_H #define _LAKE_COMMENT_H 1 +#include #include "lake.h" LakeComment *comment_make(LakeStr *text); LakeComment *comment_from_c(char *text); char *comment_repr(LakeComment *comment); +gboolean comm_equal(LakeComment *a, LakeComment *b); #endif diff --git a/src/dlist.c b/src/dlist.c index 4575574..31c508c 100644 --- a/src/dlist.c +++ b/src/dlist.c @@ -48,3 +48,12 @@ char *dlist_repr(LakeDottedList *dlist) g_string_free(s, FALSE); /* don't free char data */ return repr; } + +gboolean dlist_equal(LakeDottedList *a, LakeDottedList *b) +{ + LakeVal *headA = VAL(DLIST_HEAD(a)); + LakeVal *tailA = DLIST_TAIL(a); + LakeVal *headB = VAL(DLIST_HEAD(b)); + LakeVal *tailB = DLIST_TAIL(b); + return lake_equal(headA, headB) && lake_equal(tailA, tailB); +} diff --git a/src/dlist.h b/src/dlist.h index 9feb0aa..df767e6 100644 --- a/src/dlist.h +++ b/src/dlist.h @@ -10,9 +10,11 @@ #ifndef _LAKE_DLIST_H #define _LAKE_DLIST_H 1 +#include #include "lake.h" LakeDottedList *dlist_make(LakeList *head, LakeVal *tail); char *dlist_repr(LakeDottedList *dlist); +gboolean dlist_equal(LakeDottedList *a, LakeDottedList *b); #endif diff --git a/src/int.c b/src/int.c index 363f66f..12e7460 100644 --- a/src/int.c +++ b/src/int.c @@ -48,11 +48,6 @@ LakeInt *int_cmp(LakeInt *a, LakeInt *b) return result; } -LakeBool *int_eq(LakeInt *a, LakeInt *b) -{ - return bool_from_int(a->val == b->val); -} - LakeStr *int_to_str(LakeInt *i) { char *s = g_strdup_printf("%d", i->val); diff --git a/src/int.h b/src/int.h index dc1dc59..4832259 100644 --- a/src/int.h +++ b/src/int.h @@ -16,7 +16,6 @@ LakeInt *int_make(void); LakeInt *int_copy(LakeInt *i); LakeInt *int_from_c(int n); LakeInt *int_cmp(LakeInt *a, LakeInt *b); -LakeBool *int_eq(LakeInt *a, LakeInt *b); LakeStr *int_to_str(LakeInt *i); #endif \ No newline at end of file diff --git a/src/lake.c b/src/lake.c index e906f11..274e305 100644 --- a/src/lake.c +++ b/src/lake.c @@ -147,6 +147,48 @@ char *repr(LakeVal *expr) 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; +} + +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 comm_equal(COMM(a), COMM(b)); + + default: + ERR("unknown type %d (%s)", a->type, type_name(a)); + return FALSE; + } +} + static void run_repl(Env *env) { puts("Lake Scheme v" LAKE_VERSION); diff --git a/src/lake.h b/src/lake.h index a1d5316..4ed324b 100644 --- a/src/lake.h +++ b/src/lake.h @@ -46,6 +46,7 @@ typedef struct lake_val LakeVal; #define VAL_SIZE(x) (VAL(x)->size) #define IS(t, x) (VAL(x)->type == t) +#define IS_NIL(x) (IS(TYPE_LIST, x) && LIST_N(LIST(x)) == 0) struct lake_sym { LakeVal base; @@ -113,13 +114,13 @@ typedef struct lake_dlist LakeDottedList; #define DLIST_HEAD(x) (x->head) #define DLIST_TAIL(x) (x->tail) -typedef LakeVal *(*lake_fn)(LakeList *args); +typedef LakeVal *(*lake_prim)(LakeList *args); struct lake_primitive { LakeVal base; char *name; int arity; - lake_fn fn; + lake_prim fn; }; typedef struct lake_primitive LakePrimitive; @@ -147,6 +148,8 @@ typedef struct lake_comment LakeComment; #define COMM_TEXT(x) (x->text) +gboolean lake_is(LakeVal *a, LakeVal *b); +gboolean lake_equal(LakeVal *a, LakeVal *b); char *repr(LakeVal *val); #include diff --git a/src/list.c b/src/list.c index 936ff1c..ff01290 100644 --- a/src/list.c +++ b/src/list.c @@ -170,10 +170,16 @@ LakeInt *list_cmp(LakeList *a, LakeList *b) return 0; } -LakeBool *list_eq(LakeList *a, LakeList *b) +gboolean list_equal(LakeList *a, LakeList *b) { - /* TODO */ - return bool_from_int(a == b); + if (a == b) return TRUE; + size_t n = LIST_N(a); + if (n != LIST_N(b)) return FALSE; + size_t i; + for (i = 0; i < n; ++i) { + if (!lake_equal(LIST_VAL(a, i), LIST_VAL(b, i))) return FALSE; + } + return TRUE; } LakeStr *list_to_str(LakeList *list) diff --git a/src/list.h b/src/list.h index 8b4345f..43858d1 100644 --- a/src/list.h +++ b/src/list.h @@ -10,6 +10,7 @@ #ifndef _LAKE_LIST_H #define _LAKE_LIST_H 1 +#include #include #include "lake.h" #include "string.h" @@ -28,7 +29,7 @@ LakeVal *list_pop(LakeList *list); LakeVal *list_shift(LakeList *list); LakeVal *list_unshift(LakeList *list, LakeVal *val); LakeInt *list_cmp(LakeList *a, LakeList *b); -LakeBool *list_eq(LakeList *a, LakeList *b); +gboolean list_equal(LakeList *a, LakeList *b); LakeStr *list_to_str(LakeList *list); char *list_repr(LakeList *list); diff --git a/src/primitive.c b/src/primitive.c index 40d525a..b4ab0f6 100644 --- a/src/primitive.c +++ b/src/primitive.c @@ -9,9 +9,15 @@ #include #include +#include "comment.h" #include "env.h" +#include "int.h" +#include "dlist.h" +#include "fn.h" +#include "list.h" #include "lake.h" #include "primitive.h" +#include "string.h" static LakePrimitive *prim_alloc(void) { @@ -21,7 +27,7 @@ static LakePrimitive *prim_alloc(void) return prim; } -LakePrimitive *prim_make(char *name, int arity, lake_fn fn) +LakePrimitive *prim_make(char *name, int arity, lake_prim fn) { LakePrimitive *prim = prim_alloc(); prim->name = g_strdup(name); @@ -35,21 +41,64 @@ char *prim_repr(LakePrimitive *prim) return g_strdup_printf("<#primitive:%s(%d)>", prim->name, prim->arity); } -static LakeVal *prim_nullP(LakeList *args) +static LakeVal *_car(LakeList *args) +{ + LakeList *list = LIST(LIST_VAL(args, 0)); + if (IS(TYPE_LIST, list) && LIST_N(list) > 0) { + return LIST_VAL(list, 0); + } + ERR("not a pair: %s", list_repr(list)); + return NULL; +} + +static LakeVal *_cdr(LakeList *args) +{ + LakeList *list = LIST(LIST_VAL(args, 0)); + if (IS(TYPE_LIST, list) && LIST_N(list) > 0) { + LakeList *cdr = list_copy(list); + list_shift(cdr); + return VAL(cdr); + } + ERR("not a pair: %s", list_repr(list)); + return NULL; +} + +static LakeVal *_cons(LakeList *args) +{ + LakeVal *car = LIST_VAL(args, 0); + LakeVal *cdr = LIST_VAL(args, 1); + return VAL(list_cons(car, cdr)); +} + +static LakeVal *_nullP(LakeList *args) { LakeVal *val = list_shift(args); LakeBool *is_null = IS(TYPE_LIST, val) && LIST_N(LIST(val)) == 0 ? T : F; return VAL(is_null); } -static LakeVal *prim_pairP(LakeList *args) +static LakeVal *_pairP(LakeList *args) { LakeVal *val = list_shift(args); LakeBool *is_pair = IS(TYPE_LIST, val) && LIST_N(LIST(val)) > 0 ? T : F; return VAL(is_pair); } -static LakeVal *prim_not(LakeList *args) +static LakeVal *_isP(LakeList *args) +{ + LakeVal *a = LIST_VAL(args, 0); + LakeVal *b = LIST_VAL(args, 1); + return VAL(bool_from_int(lake_is(a, b))); +} + +static LakeVal *_equalP(LakeList *args) +{ + LakeVal *a = LIST_VAL(args, 0); + LakeVal *b = LIST_VAL(args, 1); + return VAL(bool_from_int(lake_equal(a, b))); +} + +static LakeVal *_not(LakeList *args) { LakeVal *val = list_shift(args); LakeBool *not = IS_FALSE(val) ? T : F; @@ -63,7 +112,7 @@ static LakeVal *prim_not(LakeList *args) } \ } while (0) -static LakeVal *prim_add(LakeList *args) +static LakeVal *_add(LakeList *args) { int result = 0; size_t n = LIST_N(args); @@ -76,7 +125,7 @@ static LakeVal *prim_add(LakeList *args) return VAL(int_from_c(result)); } -static LakeVal *prim_sub(LakeList *args) +static LakeVal *_sub(LakeList *args) { size_t n = LIST_N(args); @@ -95,7 +144,7 @@ static LakeVal *prim_sub(LakeList *args) return VAL(int_from_c(result)); } -static LakeVal *prim_mul(LakeList *args) +static LakeVal *_mul(LakeList *args) { int result = 1; size_t n = LIST_N(args); @@ -110,7 +159,7 @@ static LakeVal *prim_mul(LakeList *args) #define DIVIDE_BY_ZERO() ERR("divide by zero") -static LakeVal *prim_div(LakeList *args) +static LakeVal *_div(LakeList *args) { size_t n = LIST_N(args); @@ -146,7 +195,7 @@ static LakeVal *prim_div(LakeList *args) return VAL(int_from_c(result)); } -static LakeVal *prim_int_eq(LakeList *args) +static LakeVal *_int_eq(LakeList *args) { gboolean result = TRUE; size_t n = LIST_N(args); @@ -164,33 +213,46 @@ static LakeVal *prim_int_eq(LakeList *args) return VAL(bool_from_int(result)); } -static LakeVal *prim_car(LakeList *args) +static LakeVal *_int_lt(LakeList *args) { - LakeList *list = LIST(LIST_VAL(args, 0)); - if (IS(TYPE_LIST, list) && LIST_N(list) > 0) { - return LIST_VAL(list, 0); + gboolean result = TRUE; + size_t n = LIST_N(args); + size_t i; + int curr, prev; + + if (n > 1) { + for (i = 0; i < n; ++i) { + LakeVal *v = LIST_VAL(args, i); + ENSURE_INT(v, i); + curr = INT_VAL(INT(v)); + if (i > 0) { + result = result && prev < curr; + } + prev = INT_VAL(INT(v)); + } } - ERR("not a pair: %s", list_repr(list)); - return NULL; + return VAL(bool_from_int(result)); } -static LakeVal *prim_cdr(LakeList *args) +static LakeVal *_int_gt(LakeList *args) { - LakeList *list = LIST(LIST_VAL(args, 0)); - if (IS(TYPE_LIST, list) && LIST_N(list) > 0) { - LakeList *cdr = list_copy(list); - list_shift(cdr); - return VAL(cdr); - } - ERR("not a pair: %s", list_repr(list)); - return NULL; -} + gboolean result = TRUE; + size_t n = LIST_N(args); + size_t i; + int curr, prev; -static LakeVal *prim_cons(LakeList *args) -{ - LakeVal *car = LIST_VAL(args, 0); - LakeVal *cdr = LIST_VAL(args, 1); - return VAL(list_cons(car, cdr)); + if (n > 1) { + for (i = 0; i < n; ++i) { + LakeVal *v = LIST_VAL(args, i); + ENSURE_INT(v, i); + curr = INT_VAL(INT(v)); + if (i > 0) { + result = result && prev > curr; + } + prev = INT_VAL(INT(v)); + } + } + return VAL(bool_from_int(result)); } Env *primitive_bindings(void) @@ -198,16 +260,37 @@ Env *primitive_bindings(void) #define DEFINE(name, fn, arity) env_define(env, sym_intern(name), VAL(prim_make(name, arity, fn))) Env *env = env_toplevel(); - DEFINE("null?", prim_nullP, 1); - DEFINE("pair?", prim_pairP, 1); - DEFINE("not", prim_not, 1); - DEFINE("+", prim_add, ARITY_VARARGS); - DEFINE("-", prim_sub, ARITY_VARARGS); - DEFINE("*", prim_mul, ARITY_VARARGS); - DEFINE("/", prim_div, ARITY_VARARGS); - DEFINE("=", prim_int_eq, ARITY_VARARGS); - DEFINE("car", prim_car, 1); - DEFINE("cdr", prim_cdr, 1); - DEFINE("cons", prim_cons, 2); + DEFINE("car", _car, 1); + DEFINE("cdr", _cdr, 1); + DEFINE("cons", _cons, 2); + DEFINE("null?", _nullP, 1); + DEFINE("pair?", _pairP, 1); + DEFINE("is?", _isP, 2); + DEFINE("equal?", _equalP, 2); + DEFINE("not", _not, 1); + DEFINE("+", _add, ARITY_VARARGS); + DEFINE("-", _sub, ARITY_VARARGS); + DEFINE("*", _mul, ARITY_VARARGS); + DEFINE("/", _div, ARITY_VARARGS); + DEFINE("=", _int_eq, ARITY_VARARGS); + DEFINE("<", _int_lt, ARITY_VARARGS); + DEFINE(">", _int_gt, ARITY_VARARGS); + + /* symbol? */ + /* list? */ + /* dotted-list? */ + /* number? */ + /* integer? */ + /* string? */ + /* bool? */ + /* function? */ + /* primitive? */ + + /* string=? */ + /* string< */ + /* string> */ + /* string-concatenate */ + /* string-slice */ + return env; } diff --git a/src/primitive.h b/src/primitive.h index d2aa304..468073a 100644 --- a/src/primitive.h +++ b/src/primitive.h @@ -13,7 +13,7 @@ #include "env.h" #include "lake.h" -LakePrimitive *prim_make(char *name, int arity, lake_fn fn); +LakePrimitive *prim_make(char *name, int arity, lake_prim fn); char *prim_repr(LakePrimitive *prim); Env *primitive_bindings(void); diff --git a/src/string.c b/src/string.c index a2273b9..ea9439d 100644 --- a/src/string.c +++ b/src/string.c @@ -67,9 +67,11 @@ LakeInt *str_cmp(LakeStr *a, LakeStr *b) return int_from_c(g_strcmp0(a->s, b->s)); } -LakeBool *str_eq(LakeStr *a, LakeStr *b) +gboolean str_equal(LakeStr *a, LakeStr *b) { - return bool_from_int(g_strcmp0(a->s, b->s) == 0); + size_t n = STR_N(a); + if (n != STR_N(b)) return FALSE; + return g_strcmp0(a->s, b->s) == 0; } LakeStr *str_to_str(LakeStr *str) diff --git a/src/string.h b/src/string.h index 02358f4..185354a 100644 --- a/src/string.h +++ b/src/string.h @@ -10,6 +10,7 @@ #ifndef _LAKE_STRING_H #define _LAKE_STRING_H 1 +#include #include "lake.h" LakeStr *str_make(void); @@ -20,7 +21,7 @@ char *str_val(LakeStr *str); LakeInt *str_len(LakeStr *str); LakeVal *str_set(LakeStr *str, char *s); LakeInt *str_cmp(LakeStr *a, LakeStr *b); -LakeBool *str_eq(LakeStr *a, LakeStr *b); +gboolean str_equal(LakeStr *a, LakeStr *b); LakeStr *str_to_str(LakeStr *str); #endif \ No newline at end of file diff --git a/src/sym.c b/src/sym.c index 60d180b..4fc7a75 100644 --- a/src/sym.c +++ b/src/sym.c @@ -59,8 +59,3 @@ unsigned long sym_val(LakeSym *sym) { return sym->hash; } - -LakeBool *sym_eq(LakeSym *a, LakeSym *b) -{ - return bool_from_int(g_strcmp0(a->s, b->s) == 0); -} diff --git a/src/sym.h b/src/sym.h index ee10379..6e0abc3 100644 --- a/src/sym.h +++ b/src/sym.h @@ -17,6 +17,5 @@ LakeStr *sym_to_str(LakeSym *sym); LakeSym *sym_from_str(LakeStr *str); char *sym_repr(LakeSym *sym); unsigned long sym_val(LakeSym *sym); -LakeBool *sym_eq(LakeSym *a, LakeSym *b); #endif \ No newline at end of file diff --git a/src/symtable.c b/src/symtable.c index 1d1db4a..1917f22 100644 --- a/src/symtable.c +++ b/src/symtable.c @@ -18,7 +18,7 @@ static guint _sym_hash(gconstpointer key) static gboolean _sym_eq(gconstpointer a, gconstpointer b) { - return BOOL_VAL(sym_eq(SYM(a), SYM(b))); + return a == b; } GHashTable *symtable_make(void)