mirror of
https://github.com/samsonjs/lake.git
synced 2026-03-25 08:55:49 +00:00
Use clang-format to enforce code style
This commit is contained in:
parent
f0bd86b61c
commit
001478f7e8
49 changed files with 2320 additions and 2167 deletions
13
.clang-format
Normal file
13
.clang-format
Normal file
|
|
@ -0,0 +1,13 @@
|
|||
{
|
||||
BasedOnStyle: LLVM,
|
||||
UseTab: Never,
|
||||
IndentWidth: 4,
|
||||
TabWidth: 4,
|
||||
BreakBeforeBraces: Allman,
|
||||
AllowShortIfStatementsOnASingleLine: true,
|
||||
IndentCaseLabels: false,
|
||||
ColumnLimit: 80,
|
||||
AccessModifierOffset: -4,
|
||||
NamespaceIndentation: All,
|
||||
FixNamespaceComments: false,
|
||||
}
|
||||
5
Makefile
5
Makefile
|
|
@ -18,4 +18,7 @@ test:
|
|||
test_clean:
|
||||
cd test && make clean
|
||||
|
||||
.PHONY: all clean test test_clean
|
||||
format:
|
||||
script/clang-format
|
||||
|
||||
.PHONY: all clean test test_clean format
|
||||
|
|
|
|||
7
script/clang-format
Executable file
7
script/clang-format
Executable file
|
|
@ -0,0 +1,7 @@
|
|||
#!/usr/bin/env zsh
|
||||
|
||||
set -euo pipefail
|
||||
|
||||
for file in src/**/*.[ch] test/**/*.[ch]; do
|
||||
clang-format -i "$file"
|
||||
done
|
||||
49
src/bool.c
49
src/bool.c
|
|
@ -1,58 +1,43 @@
|
|||
/**
|
||||
* bool.c
|
||||
* Lake Scheme
|
||||
*
|
||||
* Copyright 2011 Sami Samhuri
|
||||
* MIT License
|
||||
*
|
||||
*/
|
||||
* bool.c
|
||||
* Lake Scheme
|
||||
*
|
||||
* Copyright 2011 Sami Samhuri
|
||||
* MIT License
|
||||
*
|
||||
*/
|
||||
|
||||
#include <string.h>
|
||||
#include "bool.h"
|
||||
#include "common.h"
|
||||
#include "lake.h"
|
||||
#include <string.h>
|
||||
|
||||
bool lake_bool_val(LakeBool *b)
|
||||
{
|
||||
return b->val;
|
||||
}
|
||||
bool lake_bool_val(LakeBool *b) { return b->val; }
|
||||
|
||||
bool lake_is_true(LakeCtx *ctx, LakeVal *x)
|
||||
{
|
||||
return VAL(x) == VAL(ctx->T);
|
||||
}
|
||||
bool lake_is_true(LakeCtx *ctx, LakeVal *x) { return VAL(x) == VAL(ctx->T); }
|
||||
|
||||
bool lake_is_false(LakeCtx *ctx, LakeVal *x)
|
||||
{
|
||||
return VAL(x) == VAL(ctx->F);
|
||||
}
|
||||
bool lake_is_false(LakeCtx *ctx, LakeVal *x) { return VAL(x) == VAL(ctx->F); }
|
||||
|
||||
bool lake_is_truthy(LakeCtx *ctx, LakeVal *x)
|
||||
{
|
||||
return !lake_is_false(ctx, x);
|
||||
}
|
||||
bool lake_is_truthy(LakeCtx *ctx, LakeVal *x) { return !lake_is_false(ctx, x); }
|
||||
|
||||
bool lake_is_falsy(LakeCtx *ctx, LakeVal *x)
|
||||
{
|
||||
return lake_is_false(ctx, x);
|
||||
}
|
||||
bool lake_is_falsy(LakeCtx *ctx, LakeVal *x) { return lake_is_false(ctx, x); }
|
||||
|
||||
LakeBool *lake_bool_from_int(LakeCtx *ctx, int n)
|
||||
{
|
||||
return n ? ctx->T : ctx->F;
|
||||
return n ? ctx->T : ctx->F;
|
||||
}
|
||||
|
||||
char *lake_bool_repr(LakeBool *b)
|
||||
{
|
||||
return strdup(lake_bool_val(b) ? "#t" : "#f");
|
||||
return strdup(lake_bool_val(b) ? "#t" : "#f");
|
||||
}
|
||||
|
||||
LakeVal *lake_bool_and(LakeCtx *ctx, LakeVal *x, LakeVal *y)
|
||||
{
|
||||
return lake_is_truthy(ctx, x) && lake_is_truthy(ctx, y) ? y : x;
|
||||
return lake_is_truthy(ctx, x) && lake_is_truthy(ctx, y) ? y : x;
|
||||
}
|
||||
|
||||
LakeVal *lake_bool_or(LakeCtx *ctx, LakeVal *x, LakeVal *y)
|
||||
{
|
||||
return lake_is_truthy(ctx, x) ? x : y;
|
||||
return lake_is_truthy(ctx, x) ? x : y;
|
||||
}
|
||||
|
|
|
|||
14
src/bool.h
14
src/bool.h
|
|
@ -1,11 +1,11 @@
|
|||
/**
|
||||
* bool.h
|
||||
* Lake Scheme
|
||||
*
|
||||
* Copyright 2011 Sami Samhuri
|
||||
* MIT License
|
||||
*
|
||||
*/
|
||||
* bool.h
|
||||
* Lake Scheme
|
||||
*
|
||||
* Copyright 2011 Sami Samhuri
|
||||
* MIT License
|
||||
*
|
||||
*/
|
||||
|
||||
#ifndef _LAKE_BOOL_H
|
||||
#define _LAKE_BOOL_H
|
||||
|
|
|
|||
|
|
@ -1,44 +1,44 @@
|
|||
/**
|
||||
* comment.c
|
||||
* Lake Scheme
|
||||
*
|
||||
* Copyright 2011 Sami Samhuri
|
||||
* MIT License
|
||||
*
|
||||
*/
|
||||
* comment.c
|
||||
* Lake Scheme
|
||||
*
|
||||
* Copyright 2011 Sami Samhuri
|
||||
* MIT License
|
||||
*
|
||||
*/
|
||||
|
||||
#include <string.h>
|
||||
#include "common.h"
|
||||
#include "comment.h"
|
||||
#include "common.h"
|
||||
#include "lake.h"
|
||||
#include "str.h"
|
||||
#include <string.h>
|
||||
|
||||
static LakeComment *comment_alloc(void)
|
||||
{
|
||||
LakeComment *comment = malloc(sizeof(LakeComment));
|
||||
VAL(comment)->type = TYPE_COMM;
|
||||
VAL(comment)->size = sizeof(LakeComment);
|
||||
return comment;
|
||||
LakeComment *comment = malloc(sizeof(LakeComment));
|
||||
VAL(comment)->type = TYPE_COMM;
|
||||
VAL(comment)->size = sizeof(LakeComment);
|
||||
return comment;
|
||||
}
|
||||
|
||||
LakeComment *comment_make(LakeStr *text)
|
||||
{
|
||||
LakeComment *comment = comment_alloc();
|
||||
comment->text = text;
|
||||
return comment;
|
||||
LakeComment *comment = comment_alloc();
|
||||
comment->text = text;
|
||||
return comment;
|
||||
}
|
||||
|
||||
LakeComment *comment_from_c(char *text)
|
||||
{
|
||||
return comment_make(lake_str_from_c(text));
|
||||
return comment_make(lake_str_from_c(text));
|
||||
}
|
||||
|
||||
char *comment_repr(LakeComment *comment)
|
||||
{
|
||||
return strndup(STR_S(comment->text), STR_N(comment->text));
|
||||
return strndup(STR_S(comment->text), STR_N(comment->text));
|
||||
}
|
||||
|
||||
bool comment_equal(LakeComment *a, LakeComment *b)
|
||||
{
|
||||
return lake_str_equal(COMM_TEXT(a), COMM_TEXT(b));
|
||||
return lake_str_equal(COMM_TEXT(a), COMM_TEXT(b));
|
||||
}
|
||||
|
|
|
|||
|
|
@ -1,11 +1,11 @@
|
|||
/**
|
||||
* comment.h
|
||||
* Lake Scheme
|
||||
*
|
||||
* Copyright 2011 Sami Samhuri
|
||||
* MIT License
|
||||
*
|
||||
*/
|
||||
* comment.h
|
||||
* Lake Scheme
|
||||
*
|
||||
* Copyright 2011 Sami Samhuri
|
||||
* MIT License
|
||||
*
|
||||
*/
|
||||
|
||||
#ifndef _LAKE_COMMENT_H
|
||||
#define _LAKE_COMMENT_H
|
||||
|
|
|
|||
26
src/common.c
26
src/common.c
|
|
@ -1,21 +1,21 @@
|
|||
/**
|
||||
* common.c
|
||||
* Lake Scheme
|
||||
*
|
||||
* Copyright 2011 Sami Samhuri
|
||||
* MIT License
|
||||
*
|
||||
*/
|
||||
* common.c
|
||||
* Lake Scheme
|
||||
*
|
||||
* Copyright 2011 Sami Samhuri
|
||||
* MIT License
|
||||
*
|
||||
*/
|
||||
|
||||
#include <stddef.h>
|
||||
#include <string.h>
|
||||
#include <stdlib.h>
|
||||
#include <stdio.h>
|
||||
#include <stdlib.h>
|
||||
#include <string.h>
|
||||
|
||||
char *lake_str_append(char *s1, char *s2)
|
||||
{
|
||||
size_t n2 = strlen(s2);
|
||||
s1 = realloc(s1, strlen(s1) + n2 + 1);
|
||||
strncat(s1, s2, n2);
|
||||
return s1;
|
||||
size_t n2 = strlen(s2);
|
||||
s1 = realloc(s1, strlen(s1) + n2 + 1);
|
||||
strncat(s1, s2, n2);
|
||||
return s1;
|
||||
}
|
||||
|
|
|
|||
14
src/common.h
14
src/common.h
|
|
@ -1,11 +1,11 @@
|
|||
/**
|
||||
* common.h
|
||||
* Lake Scheme
|
||||
*
|
||||
* Copyright 2011 Sami Samhuri
|
||||
* MIT License
|
||||
*
|
||||
*/
|
||||
* common.h
|
||||
* Lake Scheme
|
||||
*
|
||||
* Copyright 2011 Sami Samhuri
|
||||
* MIT License
|
||||
*
|
||||
*/
|
||||
|
||||
#ifndef _LAKE_COMMON_H
|
||||
#define _LAKE_COMMON_H
|
||||
|
|
|
|||
93
src/dlist.c
93
src/dlist.c
|
|
@ -1,11 +1,11 @@
|
|||
/**
|
||||
* dlist.c
|
||||
* Lake Scheme
|
||||
*
|
||||
* Copyright 2011 Sami Samhuri
|
||||
* MIT License
|
||||
*
|
||||
*/
|
||||
* dlist.c
|
||||
* Lake Scheme
|
||||
*
|
||||
* Copyright 2011 Sami Samhuri
|
||||
* MIT License
|
||||
*
|
||||
*/
|
||||
|
||||
#include "dlist.h"
|
||||
#include "common.h"
|
||||
|
|
@ -13,62 +13,59 @@
|
|||
|
||||
static LakeDottedList *dlist_alloc(void)
|
||||
{
|
||||
LakeDottedList *dlist = malloc(sizeof(LakeDottedList));
|
||||
VAL(dlist)->type = TYPE_DLIST;
|
||||
VAL(dlist)->size = sizeof(LakeDottedList);
|
||||
return dlist;
|
||||
LakeDottedList *dlist = malloc(sizeof(LakeDottedList));
|
||||
VAL(dlist)->type = TYPE_DLIST;
|
||||
VAL(dlist)->size = sizeof(LakeDottedList);
|
||||
return dlist;
|
||||
}
|
||||
|
||||
LakeDottedList *dlist_make(LakeList *head, LakeVal *tail)
|
||||
{
|
||||
LakeDottedList *dlist = dlist_alloc();
|
||||
dlist->head = head;
|
||||
dlist->tail = tail;
|
||||
return dlist;
|
||||
LakeDottedList *dlist = dlist_alloc();
|
||||
dlist->head = head;
|
||||
dlist->tail = tail;
|
||||
return dlist;
|
||||
}
|
||||
|
||||
LakeList *dlist_head(LakeDottedList *dlist)
|
||||
{
|
||||
return dlist->head;
|
||||
}
|
||||
LakeList *dlist_head(LakeDottedList *dlist) { return dlist->head; }
|
||||
|
||||
LakeVal *dlist_tail(LakeDottedList *dlist)
|
||||
{
|
||||
return dlist->tail;
|
||||
}
|
||||
LakeVal *dlist_tail(LakeDottedList *dlist) { return dlist->tail; }
|
||||
|
||||
char *dlist_repr(LakeDottedList *dlist)
|
||||
{
|
||||
char *s = malloc(2);
|
||||
s[0] = '(';
|
||||
s[1] = '\0';
|
||||
int i;
|
||||
char *s2;
|
||||
if (dlist->head && LIST_N(dlist->head)) {
|
||||
for (i = 0; i < LIST_N(dlist->head); ++i) {
|
||||
s2 = lake_repr(LIST_VAL(dlist->head, i));
|
||||
s = lake_str_append(s, s2);
|
||||
free(s2);
|
||||
if (i != LIST_N(dlist->head) - 1) s = lake_str_append(s, " ");
|
||||
char *s = malloc(2);
|
||||
s[0] = '(';
|
||||
s[1] = '\0';
|
||||
int i;
|
||||
char *s2;
|
||||
if (dlist->head && LIST_N(dlist->head))
|
||||
{
|
||||
for (i = 0; i < LIST_N(dlist->head); ++i)
|
||||
{
|
||||
s2 = lake_repr(LIST_VAL(dlist->head, i));
|
||||
s = lake_str_append(s, s2);
|
||||
free(s2);
|
||||
if (i != LIST_N(dlist->head) - 1) s = lake_str_append(s, " ");
|
||||
}
|
||||
}
|
||||
}
|
||||
else if (dlist->head) {
|
||||
s2 = lake_repr(dlist->head);
|
||||
else if (dlist->head)
|
||||
{
|
||||
s2 = lake_repr(dlist->head);
|
||||
s = lake_str_append(s, s2);
|
||||
free(s2);
|
||||
}
|
||||
s = lake_str_append(s, " . ");
|
||||
s2 = lake_repr(dlist->tail);
|
||||
s = lake_str_append(s, s2);
|
||||
free(s2);
|
||||
}
|
||||
s = lake_str_append(s, " . ");
|
||||
s2 = lake_repr(dlist->tail);
|
||||
s = lake_str_append(s, s2);
|
||||
free(s2);
|
||||
return lake_str_append(s, ")");
|
||||
return lake_str_append(s, ")");
|
||||
}
|
||||
|
||||
bool 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);
|
||||
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);
|
||||
}
|
||||
|
|
|
|||
14
src/dlist.h
14
src/dlist.h
|
|
@ -1,11 +1,11 @@
|
|||
/**
|
||||
* dlist.h
|
||||
* Lake Scheme
|
||||
*
|
||||
* Copyright 2011 Sami Samhuri
|
||||
* MIT License
|
||||
*
|
||||
*/
|
||||
* dlist.h
|
||||
* Lake Scheme
|
||||
*
|
||||
* Copyright 2011 Sami Samhuri
|
||||
* MIT License
|
||||
*
|
||||
*/
|
||||
|
||||
#ifndef _LAKE_DLIST_H
|
||||
#define _LAKE_DLIST_H
|
||||
|
|
|
|||
62
src/env.c
62
src/env.c
|
|
@ -1,59 +1,61 @@
|
|||
/**
|
||||
* env.c
|
||||
* Lake Scheme
|
||||
*
|
||||
* Copyright 2011 Sami Samhuri
|
||||
* MIT License
|
||||
*
|
||||
*/
|
||||
* env.c
|
||||
* Lake Scheme
|
||||
*
|
||||
* Copyright 2011 Sami Samhuri
|
||||
* MIT License
|
||||
*
|
||||
*/
|
||||
|
||||
#include <stdio.h>
|
||||
#include <stdlib.h>
|
||||
#include "env.h"
|
||||
#include "common.h"
|
||||
#include "hash.h"
|
||||
#include "lake.h"
|
||||
#include "env.h"
|
||||
#include <stdio.h>
|
||||
#include <stdlib.h>
|
||||
|
||||
Env *env_make(Env *parent)
|
||||
{
|
||||
Env *env = malloc(sizeof(Env));
|
||||
env->parent = parent;
|
||||
env->bindings = lake_hash_make();
|
||||
return env;
|
||||
Env *env = malloc(sizeof(Env));
|
||||
env->parent = parent;
|
||||
env->bindings = lake_hash_make();
|
||||
return env;
|
||||
}
|
||||
|
||||
Env *env_is_defined(Env *env, LakeSym *key)
|
||||
{
|
||||
if (lake_hash_get(env->bindings, key->s) != NULL) return env;
|
||||
return env->parent ? env_is_defined(env->parent, key) : NULL;
|
||||
if (lake_hash_get(env->bindings, key->s) != NULL) return env;
|
||||
return env->parent ? env_is_defined(env->parent, key) : NULL;
|
||||
}
|
||||
|
||||
static void env_put(Env *env, LakeSym *key, LakeVal *val)
|
||||
{
|
||||
lake_hash_put(env->bindings, key->s, val);
|
||||
lake_hash_put(env->bindings, key->s, val);
|
||||
}
|
||||
|
||||
LakeVal *env_define(Env *env, LakeSym *key, LakeVal *val)
|
||||
{
|
||||
env_put(env, key, val);
|
||||
return val;
|
||||
env_put(env, key, val);
|
||||
return val;
|
||||
}
|
||||
|
||||
LakeVal *env_set(Env *env, LakeSym *key, LakeVal *val)
|
||||
{
|
||||
Env *definedEnv;
|
||||
if (!(definedEnv = env_is_defined(env, key))) {
|
||||
return NULL;
|
||||
}
|
||||
env_put(definedEnv, key, val);
|
||||
return val;
|
||||
Env *definedEnv;
|
||||
if (!(definedEnv = env_is_defined(env, key)))
|
||||
{
|
||||
return NULL;
|
||||
}
|
||||
env_put(definedEnv, key, val);
|
||||
return val;
|
||||
}
|
||||
|
||||
LakeVal *env_get(Env *env, LakeSym *key)
|
||||
{
|
||||
LakeVal *val = lake_hash_get(env->bindings, key->s);
|
||||
if (!val && env->parent) {
|
||||
val = env_get(env->parent, key);
|
||||
}
|
||||
return val;
|
||||
LakeVal *val = lake_hash_get(env->bindings, key->s);
|
||||
if (!val && env->parent)
|
||||
{
|
||||
val = env_get(env->parent, key);
|
||||
}
|
||||
return val;
|
||||
}
|
||||
|
|
|
|||
21
src/env.h
21
src/env.h
|
|
@ -1,11 +1,11 @@
|
|||
/**
|
||||
* env.h
|
||||
* Lake Scheme
|
||||
*
|
||||
* Copyright 2011 Sami Samhuri
|
||||
* MIT License
|
||||
*
|
||||
*/
|
||||
* env.h
|
||||
* Lake Scheme
|
||||
*
|
||||
* Copyright 2011 Sami Samhuri
|
||||
* MIT License
|
||||
*
|
||||
*/
|
||||
|
||||
#ifndef _LAKE_ENV_H
|
||||
#define _LAKE_ENV_H
|
||||
|
|
@ -13,9 +13,10 @@
|
|||
#include "common.h"
|
||||
#include "hash.h"
|
||||
|
||||
struct env {
|
||||
struct env *parent;
|
||||
lake_hash_t *bindings;
|
||||
struct env
|
||||
{
|
||||
struct env *parent;
|
||||
lake_hash_t *bindings;
|
||||
};
|
||||
typedef struct env Env;
|
||||
|
||||
|
|
|
|||
578
src/eval.c
578
src/eval.c
|
|
@ -1,392 +1,446 @@
|
|||
/**
|
||||
* eval.c
|
||||
* Lake Scheme
|
||||
*
|
||||
* Copyright 2011 Sami Samhuri
|
||||
* MIT License
|
||||
*
|
||||
*/
|
||||
* eval.c
|
||||
* Lake Scheme
|
||||
*
|
||||
* Copyright 2011 Sami Samhuri
|
||||
* MIT License
|
||||
*
|
||||
*/
|
||||
|
||||
#include <stdlib.h>
|
||||
#include <stdio.h>
|
||||
#include <string.h>
|
||||
#include "eval.h"
|
||||
#include "bool.h"
|
||||
#include "common.h"
|
||||
#include "env.h"
|
||||
#include "eval.h"
|
||||
#include "fn.h"
|
||||
#include "lake.h"
|
||||
#include "parse.h"
|
||||
#include <stdio.h>
|
||||
#include <stdlib.h>
|
||||
#include <string.h>
|
||||
|
||||
typedef LakeVal *(*special_form_handler)(LakeCtx *ctx, Env *env, LakeList *expr);
|
||||
typedef LakeVal *(*special_form_handler)(LakeCtx *ctx, Env *env,
|
||||
LakeList *expr);
|
||||
|
||||
static void invalid_special_form(LakeList *expr, char *detail)
|
||||
{
|
||||
ERR("malformed special form, %s: %s", detail, lake_repr(expr));
|
||||
ERR("malformed special form, %s: %s", detail, lake_repr(expr));
|
||||
}
|
||||
|
||||
/* expr begins with the symbol "quote" so the quoted value is the 2nd value */
|
||||
static LakeVal *_quote(LakeCtx *ctx, Env *env, LakeList *expr)
|
||||
{
|
||||
if (LIST_N(expr) == 2) {
|
||||
return list_pop(expr);
|
||||
}
|
||||
invalid_special_form(expr, "quote requires exactly one parameter");
|
||||
return NULL;
|
||||
if (LIST_N(expr) == 2)
|
||||
{
|
||||
return list_pop(expr);
|
||||
}
|
||||
invalid_special_form(expr, "quote requires exactly one parameter");
|
||||
return NULL;
|
||||
}
|
||||
|
||||
static LakeVal *_and(LakeCtx *ctx, Env *env, LakeList *expr)
|
||||
{
|
||||
/* drop the "and" symbol */
|
||||
list_shift(expr);
|
||||
/* drop the "and" symbol */
|
||||
list_shift(expr);
|
||||
|
||||
/* (and ...) */
|
||||
LakeVal *result = LIST_N(expr) ? eval(ctx, env, list_shift(expr)) : VAL(ctx->T);
|
||||
while (lake_is_truthy(ctx, result) && LIST_N(expr) > 0) {
|
||||
result = lake_bool_and(ctx, result, eval(ctx, env, list_shift(expr)));
|
||||
}
|
||||
return result;
|
||||
/* (and ...) */
|
||||
LakeVal *result =
|
||||
LIST_N(expr) ? eval(ctx, env, list_shift(expr)) : VAL(ctx->T);
|
||||
while (lake_is_truthy(ctx, result) && LIST_N(expr) > 0)
|
||||
{
|
||||
result = lake_bool_and(ctx, result, eval(ctx, env, list_shift(expr)));
|
||||
}
|
||||
return result;
|
||||
}
|
||||
|
||||
static LakeVal *_or(LakeCtx *ctx, Env *env, LakeList *expr)
|
||||
{
|
||||
/* drop the "or" symbol */
|
||||
list_shift(expr);
|
||||
/* drop the "or" symbol */
|
||||
list_shift(expr);
|
||||
|
||||
/* (or ...) */
|
||||
LakeVal *result = LIST_N(expr) ? eval(ctx, env, list_shift(expr)) : VAL(ctx->F);
|
||||
while (lake_is_falsy(ctx, result) && LIST_N(expr) > 0) {
|
||||
result = lake_bool_or(ctx, result, eval(ctx, env, list_shift(expr)));
|
||||
}
|
||||
return result;
|
||||
/* (or ...) */
|
||||
LakeVal *result =
|
||||
LIST_N(expr) ? eval(ctx, env, list_shift(expr)) : VAL(ctx->F);
|
||||
while (lake_is_falsy(ctx, result) && LIST_N(expr) > 0)
|
||||
{
|
||||
result = lake_bool_or(ctx, result, eval(ctx, env, list_shift(expr)));
|
||||
}
|
||||
return result;
|
||||
}
|
||||
|
||||
static LakeVal *_setB(LakeCtx *ctx, Env *env, LakeList *expr)
|
||||
{
|
||||
/* (set! x 42) */
|
||||
if (LIST_N(expr) == 3 && lake_is_type(TYPE_SYM, LIST_VAL(expr, 1))) {
|
||||
list_shift(expr); /* drop the "set!" symbol */
|
||||
LakeSym *var = SYM(list_shift(expr));
|
||||
LakeVal *form = list_shift(expr);
|
||||
if (!env_set(env, var, form)) {
|
||||
ERR("%s is not defined", sym_repr(var));
|
||||
/* (set! x 42) */
|
||||
if (LIST_N(expr) == 3 && lake_is_type(TYPE_SYM, LIST_VAL(expr, 1)))
|
||||
{
|
||||
list_shift(expr); /* drop the "set!" symbol */
|
||||
LakeSym *var = SYM(list_shift(expr));
|
||||
LakeVal *form = list_shift(expr);
|
||||
if (!env_set(env, var, form))
|
||||
{
|
||||
ERR("%s is not defined", sym_repr(var));
|
||||
}
|
||||
}
|
||||
}
|
||||
else {
|
||||
invalid_special_form(expr, "set! requires exactly 2 parameters");
|
||||
}
|
||||
return NULL;
|
||||
else
|
||||
{
|
||||
invalid_special_form(expr, "set! requires exactly 2 parameters");
|
||||
}
|
||||
return NULL;
|
||||
}
|
||||
|
||||
static LakeVal *_define(LakeCtx *ctx, Env *env, LakeList *expr)
|
||||
{
|
||||
/* TODO: make these more robust, check all expected params */
|
||||
/* TODO: make these more robust, check all expected params */
|
||||
|
||||
/* (define x 42) */
|
||||
if (LIST_N(expr) == 3 && lake_is_type(TYPE_SYM, LIST_VAL(expr, 1))) {
|
||||
list_shift(expr); /* drop the "define" symbol */
|
||||
LakeSym *var = SYM(list_shift(expr));
|
||||
LakeVal *form = list_shift(expr);
|
||||
env_define(env, var, eval(ctx, env, form));
|
||||
}
|
||||
/* (define x 42) */
|
||||
if (LIST_N(expr) == 3 && lake_is_type(TYPE_SYM, LIST_VAL(expr, 1)))
|
||||
{
|
||||
list_shift(expr); /* drop the "define" symbol */
|
||||
LakeSym *var = SYM(list_shift(expr));
|
||||
LakeVal *form = list_shift(expr);
|
||||
env_define(env, var, eval(ctx, env, form));
|
||||
}
|
||||
|
||||
/* (define (inc x) (+ 1 x)) */
|
||||
else if (LIST_N(expr) >= 3 && lake_is_type(TYPE_LIST, LIST_VAL(expr, 1))) {
|
||||
list_shift(expr); /* drop the "define" symbol */
|
||||
LakeList *params = LIST(list_shift(expr));
|
||||
LakeSym *var = SYM(list_shift(params));
|
||||
LakeList *body = expr;
|
||||
env_define(env, var, VAL(fn_make(params, NULL, body, env)));
|
||||
}
|
||||
/* (define (inc x) (+ 1 x)) */
|
||||
else if (LIST_N(expr) >= 3 && lake_is_type(TYPE_LIST, LIST_VAL(expr, 1)))
|
||||
{
|
||||
list_shift(expr); /* drop the "define" symbol */
|
||||
LakeList *params = LIST(list_shift(expr));
|
||||
LakeSym *var = SYM(list_shift(params));
|
||||
LakeList *body = expr;
|
||||
env_define(env, var, VAL(fn_make(params, NULL, body, env)));
|
||||
}
|
||||
|
||||
/* (define (print format . args) (...)) */
|
||||
else if (LIST_N(expr) >= 3 && lake_is_type(TYPE_DLIST, LIST_VAL(expr, 1))) {
|
||||
list_shift(expr); /* drop the "define" symbol */
|
||||
LakeDottedList *def = DLIST(list_shift(expr));
|
||||
LakeList *params = dlist_head(def);
|
||||
LakeSym *varargs = SYM(dlist_tail(def));
|
||||
LakeSym *var = SYM(list_shift(params));
|
||||
LakeList *body = expr;
|
||||
env_define(env, var, VAL(fn_make(params, varargs, body, env)));
|
||||
}
|
||||
/* (define (print format . args) (...)) */
|
||||
else if (LIST_N(expr) >= 3 && lake_is_type(TYPE_DLIST, LIST_VAL(expr, 1)))
|
||||
{
|
||||
list_shift(expr); /* drop the "define" symbol */
|
||||
LakeDottedList *def = DLIST(list_shift(expr));
|
||||
LakeList *params = dlist_head(def);
|
||||
LakeSym *varargs = SYM(dlist_tail(def));
|
||||
LakeSym *var = SYM(list_shift(params));
|
||||
LakeList *body = expr;
|
||||
env_define(env, var, VAL(fn_make(params, varargs, body, env)));
|
||||
}
|
||||
|
||||
else {
|
||||
invalid_special_form(expr, "define requires at least 2 parameters");
|
||||
}
|
||||
else
|
||||
{
|
||||
invalid_special_form(expr, "define requires at least 2 parameters");
|
||||
}
|
||||
|
||||
return NULL;
|
||||
return NULL;
|
||||
}
|
||||
|
||||
static LakeVal *_lambda(LakeCtx *ctx, Env *env, LakeList *expr)
|
||||
{
|
||||
/* (lambda (a b c) ...) */
|
||||
if (LIST_N(expr) >= 3 && lake_is_type(TYPE_LIST, LIST_VAL(expr, 1))) {
|
||||
list_shift(expr); /* drop the "lambda" symbol */
|
||||
LakeList *params = LIST(list_shift(expr));
|
||||
LakeList *body = expr;
|
||||
return VAL(fn_make(params, NULL, body, env));
|
||||
}
|
||||
else if (LIST_N(expr) >= 3 && lake_is_type(TYPE_DLIST, LIST_VAL(expr, 1))) {
|
||||
list_shift(expr); /* drop the "lambda" symbol */
|
||||
LakeDottedList *def = DLIST(list_shift(expr));
|
||||
LakeList *params = dlist_head(def);
|
||||
LakeSym *varargs = SYM(dlist_tail(def));
|
||||
LakeList *body = expr;
|
||||
return VAL(fn_make(params, varargs, body, env));
|
||||
}
|
||||
else if (LIST_N(expr) >= 3 && lake_is_type(TYPE_SYM, LIST_VAL(expr, 1))) {
|
||||
list_shift(expr); /* drop the "lambda" symbol */
|
||||
LakeSym *varargs = SYM(list_shift(expr));
|
||||
LakeList *body = expr;
|
||||
return VAL(fn_make(list_make(), varargs, body, env));
|
||||
}
|
||||
else {
|
||||
invalid_special_form(expr, "lambda requires at least 2 parameters");
|
||||
return NULL;
|
||||
}
|
||||
if (LIST_N(expr) >= 3 && lake_is_type(TYPE_LIST, LIST_VAL(expr, 1)))
|
||||
{
|
||||
list_shift(expr); /* drop the "lambda" symbol */
|
||||
LakeList *params = LIST(list_shift(expr));
|
||||
LakeList *body = expr;
|
||||
return VAL(fn_make(params, NULL, body, env));
|
||||
}
|
||||
else if (LIST_N(expr) >= 3 && lake_is_type(TYPE_DLIST, LIST_VAL(expr, 1)))
|
||||
{
|
||||
list_shift(expr); /* drop the "lambda" symbol */
|
||||
LakeDottedList *def = DLIST(list_shift(expr));
|
||||
LakeList *params = dlist_head(def);
|
||||
LakeSym *varargs = SYM(dlist_tail(def));
|
||||
LakeList *body = expr;
|
||||
return VAL(fn_make(params, varargs, body, env));
|
||||
}
|
||||
else if (LIST_N(expr) >= 3 && lake_is_type(TYPE_SYM, LIST_VAL(expr, 1)))
|
||||
{
|
||||
list_shift(expr); /* drop the "lambda" symbol */
|
||||
LakeSym *varargs = SYM(list_shift(expr));
|
||||
LakeList *body = expr;
|
||||
return VAL(fn_make(list_make(), varargs, body, env));
|
||||
}
|
||||
else
|
||||
{
|
||||
invalid_special_form(expr, "lambda requires at least 2 parameters");
|
||||
return NULL;
|
||||
}
|
||||
}
|
||||
|
||||
static LakeVal *_if(LakeCtx *ctx, Env *env, LakeList *expr)
|
||||
{
|
||||
if (LIST_N(expr) != 3) {
|
||||
invalid_special_form(expr, "if requires 3 parameters");
|
||||
return NULL;
|
||||
}
|
||||
list_shift(expr); /* "if" token */
|
||||
LakeVal *cond = eval(ctx, env, list_shift(expr));
|
||||
if (lake_is_truthy(ctx, cond)) {
|
||||
return eval(ctx, env, list_shift(expr));
|
||||
}
|
||||
else {
|
||||
return eval(ctx, env, LIST_VAL(expr, 1));
|
||||
}
|
||||
if (LIST_N(expr) != 3)
|
||||
{
|
||||
invalid_special_form(expr, "if requires 3 parameters");
|
||||
return NULL;
|
||||
}
|
||||
list_shift(expr); /* "if" token */
|
||||
LakeVal *cond = eval(ctx, env, list_shift(expr));
|
||||
if (lake_is_truthy(ctx, cond))
|
||||
{
|
||||
return eval(ctx, env, list_shift(expr));
|
||||
}
|
||||
else
|
||||
{
|
||||
return eval(ctx, env, LIST_VAL(expr, 1));
|
||||
}
|
||||
}
|
||||
|
||||
static LakeVal *_cond(LakeCtx *ctx, Env *env, LakeList *expr)
|
||||
{
|
||||
static LakeVal *ELSE = NULL;
|
||||
if (!ELSE) ELSE = VAL(sym_intern(ctx, "else"));
|
||||
static LakeVal *ELSE = NULL;
|
||||
if (!ELSE) ELSE = VAL(sym_intern(ctx, "else"));
|
||||
|
||||
list_shift(expr); /* "cond" token */
|
||||
LakeVal *pred;
|
||||
LakeList *conseq;
|
||||
while (LIST_N(expr)) {
|
||||
if (!lake_is_type(TYPE_LIST, LIST_VAL(expr, 0))) {
|
||||
invalid_special_form(expr, "expected a (predicate consequence) pair");
|
||||
return NULL;
|
||||
list_shift(expr); /* "cond" token */
|
||||
LakeVal *pred;
|
||||
LakeList *conseq;
|
||||
while (LIST_N(expr))
|
||||
{
|
||||
if (!lake_is_type(TYPE_LIST, LIST_VAL(expr, 0)))
|
||||
{
|
||||
invalid_special_form(expr,
|
||||
"expected a (predicate consequence) pair");
|
||||
return NULL;
|
||||
}
|
||||
conseq = LIST(list_shift(expr));
|
||||
pred = list_shift(conseq);
|
||||
if (pred == ELSE || lake_is_truthy(ctx, eval(ctx, env, pred)))
|
||||
{
|
||||
return eval_exprs1(ctx, env, conseq);
|
||||
}
|
||||
}
|
||||
conseq = LIST(list_shift(expr));
|
||||
pred = list_shift(conseq);
|
||||
if (pred == ELSE || lake_is_truthy(ctx, eval(ctx, env, pred))) {
|
||||
return eval_exprs1(ctx, env, conseq);
|
||||
}
|
||||
}
|
||||
return NULL;
|
||||
return NULL;
|
||||
}
|
||||
|
||||
static LakeVal *_when(LakeCtx *ctx, Env *env, LakeList *expr)
|
||||
{
|
||||
if (LIST_N(expr) < 2) {
|
||||
invalid_special_form(expr, "when requires at least 2 parameters");
|
||||
return NULL;
|
||||
}
|
||||
list_shift(expr); /* "when" token */
|
||||
LakeVal *cond = eval(ctx, env, list_shift(expr));
|
||||
return lake_is_truthy(ctx, cond) ? eval_exprs1(ctx, env, expr) : NULL;
|
||||
if (LIST_N(expr) < 2)
|
||||
{
|
||||
invalid_special_form(expr, "when requires at least 2 parameters");
|
||||
return NULL;
|
||||
}
|
||||
list_shift(expr); /* "when" token */
|
||||
LakeVal *cond = eval(ctx, env, list_shift(expr));
|
||||
return lake_is_truthy(ctx, cond) ? eval_exprs1(ctx, env, expr) : NULL;
|
||||
}
|
||||
|
||||
typedef LakeVal *(*handler)(LakeCtx *, Env *, LakeList *);
|
||||
|
||||
static void define_handler(LakeCtx *ctx, char *name, handler fn)
|
||||
{
|
||||
lake_hash_put(ctx->special_form_handlers, name, (void *)fn);
|
||||
lake_hash_put(ctx->special_form_handlers, name, (void *)fn);
|
||||
}
|
||||
|
||||
void init_special_form_handlers(LakeCtx *ctx)
|
||||
{
|
||||
/* define_handler(ctx, "load", &load_special_form); */
|
||||
define_handler(ctx, "quote", &_quote);
|
||||
define_handler(ctx, "and", &_and);
|
||||
define_handler(ctx, "or", &_or);
|
||||
define_handler(ctx, "if", &_if);
|
||||
define_handler(ctx, "when", &_when);
|
||||
define_handler(ctx, "cond", &_cond);
|
||||
define_handler(ctx, "set!", &_setB);
|
||||
define_handler(ctx, "define", &_define);
|
||||
define_handler(ctx, "lambda", &_lambda);
|
||||
/* define_handler(ctx, "let", &_let); */
|
||||
/* define_handler(ctx, "let!", &_letB); */
|
||||
/* define_handler(ctx, "letrec", &_letrec); */
|
||||
/* define_handler(ctx, "load", &load_special_form); */
|
||||
define_handler(ctx, "quote", &_quote);
|
||||
define_handler(ctx, "and", &_and);
|
||||
define_handler(ctx, "or", &_or);
|
||||
define_handler(ctx, "if", &_if);
|
||||
define_handler(ctx, "when", &_when);
|
||||
define_handler(ctx, "cond", &_cond);
|
||||
define_handler(ctx, "set!", &_setB);
|
||||
define_handler(ctx, "define", &_define);
|
||||
define_handler(ctx, "lambda", &_lambda);
|
||||
/* define_handler(ctx, "let", &_let); */
|
||||
/* define_handler(ctx, "let!", &_letB); */
|
||||
/* define_handler(ctx, "letrec", &_letrec); */
|
||||
}
|
||||
|
||||
bool is_special_form(LakeCtx *ctx, LakeList *expr)
|
||||
{
|
||||
LakeVal *head = LIST_VAL(expr, 0);
|
||||
if (!lake_is_type(TYPE_SYM, head)) return FALSE;
|
||||
return lake_hash_has(ctx->special_form_handlers, SYM(head)->s);
|
||||
LakeVal *head = LIST_VAL(expr, 0);
|
||||
if (!lake_is_type(TYPE_SYM, head)) return FALSE;
|
||||
return lake_hash_has(ctx->special_form_handlers, SYM(head)->s);
|
||||
}
|
||||
|
||||
static special_form_handler get_special_form_handler(LakeCtx *ctx, LakeSym *name)
|
||||
static special_form_handler get_special_form_handler(LakeCtx *ctx,
|
||||
LakeSym *name)
|
||||
{
|
||||
return (special_form_handler)lake_hash_get(ctx->special_form_handlers, name->s);
|
||||
return (special_form_handler)lake_hash_get(ctx->special_form_handlers,
|
||||
name->s);
|
||||
}
|
||||
|
||||
static LakeVal *eval_special_form(LakeCtx *ctx, Env *env, LakeList *expr)
|
||||
{
|
||||
LakeSym *name = SYM(LIST_VAL(expr, 0));
|
||||
special_form_handler handler = get_special_form_handler(ctx, name);
|
||||
if (handler) {
|
||||
return handler(ctx, env, list_copy(expr));
|
||||
}
|
||||
ERR("unrecognized special form: %s", sym_repr(name));
|
||||
return NULL;
|
||||
LakeSym *name = SYM(LIST_VAL(expr, 0));
|
||||
special_form_handler handler = get_special_form_handler(ctx, name);
|
||||
if (handler)
|
||||
{
|
||||
return handler(ctx, env, list_copy(expr));
|
||||
}
|
||||
ERR("unrecognized special form: %s", sym_repr(name));
|
||||
return NULL;
|
||||
}
|
||||
|
||||
LakeVal *eval_str(LakeCtx *ctx, Env *env, char *s)
|
||||
{
|
||||
return eval(ctx, env, parse_expr(ctx, s, strlen(s)));
|
||||
return eval(ctx, env, parse_expr(ctx, s, strlen(s)));
|
||||
}
|
||||
|
||||
LakeVal *eval(LakeCtx *ctx, Env *env, LakeVal *expr)
|
||||
{
|
||||
LakeVal *result;
|
||||
LakeList *list;
|
||||
LakeVal *result;
|
||||
LakeList *list;
|
||||
|
||||
switch (expr->type) {
|
||||
switch (expr->type)
|
||||
{
|
||||
|
||||
/* self evaluating types */
|
||||
case TYPE_BOOL:
|
||||
case TYPE_INT:
|
||||
case TYPE_STR:
|
||||
result = expr;
|
||||
break;
|
||||
result = expr;
|
||||
break;
|
||||
|
||||
case TYPE_SYM:
|
||||
result = env_get(env, (void *)SYM(expr));
|
||||
if (!result) {
|
||||
ERR("undefined variable: %s", sym_repr(SYM(expr)));
|
||||
}
|
||||
break;
|
||||
result = env_get(env, (void *)SYM(expr));
|
||||
if (!result)
|
||||
{
|
||||
ERR("undefined variable: %s", sym_repr(SYM(expr)));
|
||||
}
|
||||
break;
|
||||
|
||||
case TYPE_DLIST:
|
||||
ERR("malformed function call");
|
||||
result = NULL;
|
||||
break;
|
||||
ERR("malformed function call");
|
||||
result = NULL;
|
||||
break;
|
||||
|
||||
case TYPE_COMM:
|
||||
result = NULL;
|
||||
break;
|
||||
result = NULL;
|
||||
break;
|
||||
|
||||
case TYPE_LIST:
|
||||
list = LIST(expr);
|
||||
list = LIST(expr);
|
||||
|
||||
if (LIST_N(list) == 0) {
|
||||
result = expr;
|
||||
}
|
||||
else {
|
||||
if (is_special_form(ctx, list)) {
|
||||
result = eval_special_form(ctx, env, list);
|
||||
if (LIST_N(list) == 0)
|
||||
{
|
||||
result = expr;
|
||||
}
|
||||
else {
|
||||
LakeVal *fn = eval(ctx, env, LIST_VAL(list, 0));
|
||||
if (!fn) {
|
||||
return NULL;
|
||||
}
|
||||
LakeList *args = list_make_with_capacity(LIST_N(list) - 1);
|
||||
int i;
|
||||
LakeVal *v;
|
||||
for (i = 1; i < LIST_N(list); ++i) {
|
||||
v = eval(ctx, env, LIST_VAL(list, i));
|
||||
if (v != NULL) {
|
||||
list_append(args, v);
|
||||
else
|
||||
{
|
||||
if (is_special_form(ctx, list))
|
||||
{
|
||||
result = eval_special_form(ctx, env, list);
|
||||
}
|
||||
else {
|
||||
list_free(args);
|
||||
result = NULL;
|
||||
goto done;
|
||||
else
|
||||
{
|
||||
LakeVal *fn = eval(ctx, env, LIST_VAL(list, 0));
|
||||
if (!fn)
|
||||
{
|
||||
return NULL;
|
||||
}
|
||||
LakeList *args = list_make_with_capacity(LIST_N(list) - 1);
|
||||
int i;
|
||||
LakeVal *v;
|
||||
for (i = 1; i < LIST_N(list); ++i)
|
||||
{
|
||||
v = eval(ctx, env, LIST_VAL(list, i));
|
||||
if (v != NULL)
|
||||
{
|
||||
list_append(args, v);
|
||||
}
|
||||
else
|
||||
{
|
||||
list_free(args);
|
||||
result = NULL;
|
||||
goto done;
|
||||
}
|
||||
}
|
||||
result = apply(ctx, fn, args);
|
||||
}
|
||||
}
|
||||
result = apply(ctx, fn, args);
|
||||
}
|
||||
}
|
||||
break;
|
||||
break;
|
||||
|
||||
default:
|
||||
ERR("unrecognized value, type %d, size %zu bytes", expr->type, expr->size);
|
||||
DIE("we don't eval that around here!");
|
||||
}
|
||||
ERR("unrecognized value, type %d, size %zu bytes", expr->type,
|
||||
expr->size);
|
||||
DIE("we don't eval that around here!");
|
||||
}
|
||||
|
||||
done: return result;
|
||||
done:
|
||||
return result;
|
||||
}
|
||||
|
||||
LakeList *eval_exprs(LakeCtx *ctx, Env *env, LakeList *exprs)
|
||||
{
|
||||
LakeList *results = list_make_with_capacity(LIST_N(exprs));
|
||||
int i;
|
||||
for (i = 0; i < LIST_N(exprs); ++i) {
|
||||
list_append(results, eval(ctx, env, LIST_VAL(exprs, i)));
|
||||
}
|
||||
return results;
|
||||
LakeList *results = list_make_with_capacity(LIST_N(exprs));
|
||||
int i;
|
||||
for (i = 0; i < LIST_N(exprs); ++i)
|
||||
{
|
||||
list_append(results, eval(ctx, env, LIST_VAL(exprs, i)));
|
||||
}
|
||||
return results;
|
||||
}
|
||||
|
||||
LakeVal *eval_exprs1(LakeCtx *ctx, Env *env, LakeList *exprs)
|
||||
{
|
||||
LakeList *results = eval_exprs(ctx, env, exprs);
|
||||
LakeVal *result = list_pop(results);
|
||||
list_free(results);
|
||||
return result;
|
||||
LakeList *results = eval_exprs(ctx, env, exprs);
|
||||
LakeVal *result = list_pop(results);
|
||||
list_free(results);
|
||||
return result;
|
||||
}
|
||||
|
||||
LakeVal *apply(LakeCtx *ctx, LakeVal *fnVal, LakeList *args)
|
||||
{
|
||||
LakeVal *result = NULL;
|
||||
if (lake_is_type(TYPE_PRIM, fnVal)) {
|
||||
LakePrimitive *prim = PRIM(fnVal);
|
||||
int arity = prim->arity;
|
||||
if (arity == ARITY_VARARGS || LIST_N(args) == arity) {
|
||||
result = prim->fn(ctx, args);
|
||||
LakeVal *result = NULL;
|
||||
if (lake_is_type(TYPE_PRIM, fnVal))
|
||||
{
|
||||
LakePrimitive *prim = PRIM(fnVal);
|
||||
int arity = prim->arity;
|
||||
if (arity == ARITY_VARARGS || LIST_N(args) == arity)
|
||||
{
|
||||
result = prim->fn(ctx, args);
|
||||
}
|
||||
else
|
||||
{
|
||||
ERR("%s expects %d params but got %zu", prim->name, arity,
|
||||
LIST_N(args));
|
||||
result = NULL;
|
||||
}
|
||||
}
|
||||
else {
|
||||
ERR("%s expects %d params but got %zu", prim->name, arity, LIST_N(args));
|
||||
result = NULL;
|
||||
}
|
||||
}
|
||||
else if (lake_is_type(TYPE_FN, fnVal)) {
|
||||
LakeFn *fn = FN(fnVal);
|
||||
else if (lake_is_type(TYPE_FN, fnVal))
|
||||
{
|
||||
LakeFn *fn = FN(fnVal);
|
||||
|
||||
/* Check # of params */
|
||||
size_t nparams = LIST_N(fn->params);
|
||||
if (!fn->varargs && LIST_N(args) != nparams) {
|
||||
ERR("expected %zu params but got %zu", nparams, LIST_N(args));
|
||||
return NULL;
|
||||
}
|
||||
else if (fn->varargs && LIST_N(args) < nparams) {
|
||||
ERR("expected at least %zu params but got %zu", nparams, LIST_N(args));
|
||||
return NULL;
|
||||
}
|
||||
/* Check # of params */
|
||||
size_t nparams = LIST_N(fn->params);
|
||||
if (!fn->varargs && LIST_N(args) != nparams)
|
||||
{
|
||||
ERR("expected %zu params but got %zu", nparams, LIST_N(args));
|
||||
return NULL;
|
||||
}
|
||||
else if (fn->varargs && LIST_N(args) < nparams)
|
||||
{
|
||||
ERR("expected at least %zu params but got %zu", nparams,
|
||||
LIST_N(args));
|
||||
return NULL;
|
||||
}
|
||||
|
||||
Env *env = env_make(fn->closure);
|
||||
Env *env = env_make(fn->closure);
|
||||
|
||||
/* bind each (param,arg) pair in env */
|
||||
size_t i;
|
||||
for (i = 0; i < nparams; ++i) {
|
||||
env_define(env, SYM(LIST_VAL(fn->params, i)), LIST_VAL(args, i));
|
||||
/* bind each (param,arg) pair in env */
|
||||
size_t i;
|
||||
for (i = 0; i < nparams; ++i)
|
||||
{
|
||||
env_define(env, SYM(LIST_VAL(fn->params, i)), LIST_VAL(args, i));
|
||||
}
|
||||
|
||||
/* bind varargs */
|
||||
if (fn->varargs)
|
||||
{
|
||||
LakeList *remainingArgs =
|
||||
list_make_with_capacity(LIST_N(args) - nparams);
|
||||
for (; i < LIST_N(args); ++i)
|
||||
{
|
||||
list_append(remainingArgs, LIST_VAL(args, i));
|
||||
}
|
||||
env_define(env, fn->varargs, VAL(remainingArgs));
|
||||
}
|
||||
|
||||
/* evaluate body */
|
||||
result = eval_exprs1(ctx, env, fn->body);
|
||||
}
|
||||
|
||||
/* bind varargs */
|
||||
if (fn->varargs) {
|
||||
LakeList *remainingArgs = list_make_with_capacity(LIST_N(args) - nparams);
|
||||
for (; i < LIST_N(args); ++i) {
|
||||
list_append(remainingArgs, LIST_VAL(args, i));
|
||||
}
|
||||
env_define(env, fn->varargs, VAL(remainingArgs));
|
||||
else
|
||||
{
|
||||
ERR("not a function: %s", lake_repr(fnVal));
|
||||
}
|
||||
|
||||
/* evaluate body */
|
||||
result = eval_exprs1(ctx, env, fn->body);
|
||||
}
|
||||
else {
|
||||
ERR("not a function: %s", lake_repr(fnVal));
|
||||
}
|
||||
return result;
|
||||
return result;
|
||||
}
|
||||
|
|
|
|||
14
src/eval.h
14
src/eval.h
|
|
@ -1,11 +1,11 @@
|
|||
/**
|
||||
* eval.h
|
||||
* Lake Scheme
|
||||
*
|
||||
* Copyright 2011 Sami Samhuri
|
||||
* MIT License
|
||||
*
|
||||
*/
|
||||
* eval.h
|
||||
* Lake Scheme
|
||||
*
|
||||
* Copyright 2011 Sami Samhuri
|
||||
* MIT License
|
||||
*
|
||||
*/
|
||||
|
||||
#ifndef _LAKE_EVAL_H
|
||||
#define _LAKE_EVAL_H
|
||||
|
|
|
|||
103
src/fn.c
103
src/fn.c
|
|
@ -1,65 +1,70 @@
|
|||
/**
|
||||
* fn.c
|
||||
* Lake Scheme
|
||||
*
|
||||
* Copyright 2011 Sami Samhuri
|
||||
* MIT License
|
||||
*
|
||||
*/
|
||||
* fn.c
|
||||
* Lake Scheme
|
||||
*
|
||||
* Copyright 2011 Sami Samhuri
|
||||
* MIT License
|
||||
*
|
||||
*/
|
||||
|
||||
#include <stdlib.h>
|
||||
#include "fn.h"
|
||||
#include "common.h"
|
||||
#include "env.h"
|
||||
#include "fn.h"
|
||||
#include "lake.h"
|
||||
#include <stdlib.h>
|
||||
|
||||
static LakeFn *fn_alloc(void)
|
||||
{
|
||||
LakeFn *fn = malloc(sizeof(LakeFn));
|
||||
VAL(fn)->type = TYPE_FN;
|
||||
VAL(fn)->size = sizeof(LakeFn);
|
||||
return fn;
|
||||
LakeFn *fn = malloc(sizeof(LakeFn));
|
||||
VAL(fn)->type = TYPE_FN;
|
||||
VAL(fn)->size = sizeof(LakeFn);
|
||||
return fn;
|
||||
}
|
||||
|
||||
LakeFn *fn_make(LakeList *params, LakeSym *varargs, LakeList *body, Env *closure)
|
||||
LakeFn *fn_make(LakeList *params, LakeSym *varargs, LakeList *body,
|
||||
Env *closure)
|
||||
{
|
||||
LakeFn *fn = fn_alloc();
|
||||
fn->params = params;
|
||||
fn->varargs = varargs;
|
||||
fn->body = body;
|
||||
fn->closure = closure;
|
||||
return fn;
|
||||
LakeFn *fn = fn_alloc();
|
||||
fn->params = params;
|
||||
fn->varargs = varargs;
|
||||
fn->body = body;
|
||||
fn->closure = closure;
|
||||
return fn;
|
||||
}
|
||||
|
||||
char *fn_repr(LakeFn *fn)
|
||||
{
|
||||
char *s = malloc(8);
|
||||
s[0] = '\0';
|
||||
s = lake_str_append(s, "(lambda ");
|
||||
char *s2;
|
||||
if (LIST_N(fn->params) && fn->varargs) {
|
||||
LakeDottedList *params = dlist_make(fn->params, VAL(fn->varargs));
|
||||
s2 = dlist_repr(params);
|
||||
s = lake_str_append(s, s2);
|
||||
free(s2);
|
||||
}
|
||||
else if (fn->varargs) {
|
||||
s2 = lake_repr(fn->varargs);
|
||||
s = lake_str_append(s, s2);
|
||||
free(s2);
|
||||
}
|
||||
else {
|
||||
s2 = lake_repr(fn->params);
|
||||
s = lake_str_append(s, s2);
|
||||
free(s2);
|
||||
}
|
||||
s = lake_str_append(s, " ");
|
||||
int i;
|
||||
for (i = 0; i < LIST_N(fn->body); ++i) {
|
||||
s2 = lake_repr(LIST_VAL(fn->body, i));
|
||||
s = lake_str_append(s, s2);
|
||||
free(s2);
|
||||
if (i != LIST_N(fn->body) - 1) s = lake_str_append(s, " ");
|
||||
}
|
||||
return lake_str_append(s, ")");
|
||||
char *s = malloc(8);
|
||||
s[0] = '\0';
|
||||
s = lake_str_append(s, "(lambda ");
|
||||
char *s2;
|
||||
if (LIST_N(fn->params) && fn->varargs)
|
||||
{
|
||||
LakeDottedList *params = dlist_make(fn->params, VAL(fn->varargs));
|
||||
s2 = dlist_repr(params);
|
||||
s = lake_str_append(s, s2);
|
||||
free(s2);
|
||||
}
|
||||
else if (fn->varargs)
|
||||
{
|
||||
s2 = lake_repr(fn->varargs);
|
||||
s = lake_str_append(s, s2);
|
||||
free(s2);
|
||||
}
|
||||
else
|
||||
{
|
||||
s2 = lake_repr(fn->params);
|
||||
s = lake_str_append(s, s2);
|
||||
free(s2);
|
||||
}
|
||||
s = lake_str_append(s, " ");
|
||||
int i;
|
||||
for (i = 0; i < LIST_N(fn->body); ++i)
|
||||
{
|
||||
s2 = lake_repr(LIST_VAL(fn->body, i));
|
||||
s = lake_str_append(s, s2);
|
||||
free(s2);
|
||||
if (i != LIST_N(fn->body) - 1) s = lake_str_append(s, " ");
|
||||
}
|
||||
return lake_str_append(s, ")");
|
||||
}
|
||||
|
|
|
|||
17
src/fn.h
17
src/fn.h
|
|
@ -1,11 +1,11 @@
|
|||
/**
|
||||
* fn.h
|
||||
* Lake Scheme
|
||||
*
|
||||
* Copyright 2011 Sami Samhuri
|
||||
* MIT License
|
||||
*
|
||||
*/
|
||||
* fn.h
|
||||
* Lake Scheme
|
||||
*
|
||||
* Copyright 2011 Sami Samhuri
|
||||
* MIT License
|
||||
*
|
||||
*/
|
||||
|
||||
#ifndef _LAKE_FN_H
|
||||
#define _LAKE_FN_H
|
||||
|
|
@ -13,7 +13,8 @@
|
|||
#include "env.h"
|
||||
#include "lake.h"
|
||||
|
||||
LakeFn *fn_make(LakeList *params, LakeSym *varargs, LakeList *body, Env *closure);
|
||||
LakeFn *fn_make(LakeList *params, LakeSym *varargs, LakeList *body,
|
||||
Env *closure);
|
||||
char *fn_repr(LakeFn *fn);
|
||||
|
||||
#endif
|
||||
43
src/hash.c
43
src/hash.c
|
|
@ -1,29 +1,32 @@
|
|||
/**
|
||||
* hash.c
|
||||
* Lake Scheme
|
||||
*
|
||||
* Copyright 2011 Sami Samhuri
|
||||
* MIT License
|
||||
*
|
||||
* Lifted from TJ Holowaychuk's Luna.
|
||||
* https://raw.github.com/visionmedia/luna
|
||||
*
|
||||
*/
|
||||
* hash.c
|
||||
* Lake Scheme
|
||||
*
|
||||
* Copyright 2011 Sami Samhuri
|
||||
* MIT License
|
||||
*
|
||||
* Lifted from TJ Holowaychuk's Luna.
|
||||
* https://raw.github.com/visionmedia/luna
|
||||
*
|
||||
*/
|
||||
|
||||
#include "hash.h"
|
||||
|
||||
void lake_hash_put(khash_t(value) *h, char *key, void *val) {
|
||||
int ret;
|
||||
khiter_t k = kh_put(value, h, key, &ret);
|
||||
kh_value(h, k) = val;
|
||||
void lake_hash_put(khash_t(value) * h, char *key, void *val)
|
||||
{
|
||||
int ret;
|
||||
khiter_t k = kh_put(value, h, key, &ret);
|
||||
kh_value(h, k) = val;
|
||||
}
|
||||
|
||||
void *lake_hash_get(khash_t(value) *h, char *key) {
|
||||
khiter_t k = kh_get(value, h, key);
|
||||
return k == kh_end(h) ? NULL : kh_value(h, k);
|
||||
void *lake_hash_get(khash_t(value) * h, char *key)
|
||||
{
|
||||
khiter_t k = kh_get(value, h, key);
|
||||
return k == kh_end(h) ? NULL : kh_value(h, k);
|
||||
}
|
||||
|
||||
bool lake_hash_has(khash_t(value) *h, char *key) {
|
||||
khiter_t k = kh_get(value, h, key);
|
||||
return kh_exist(h, k);
|
||||
bool lake_hash_has(khash_t(value) * h, char *key)
|
||||
{
|
||||
khiter_t k = kh_get(value, h, key);
|
||||
return kh_exist(h, k);
|
||||
}
|
||||
|
|
|
|||
28
src/hash.h
28
src/hash.h
|
|
@ -1,20 +1,20 @@
|
|||
/**
|
||||
* hash.h
|
||||
* Lake Scheme
|
||||
*
|
||||
* Copyright 2011 Sami Samhuri
|
||||
* MIT License
|
||||
*
|
||||
* Lifted from TJ Holowaychuk's Luna.
|
||||
* https://raw.github.com/visionmedia/luna
|
||||
*
|
||||
*/
|
||||
* hash.h
|
||||
* Lake Scheme
|
||||
*
|
||||
* Copyright 2011 Sami Samhuri
|
||||
* MIT License
|
||||
*
|
||||
* Lifted from TJ Holowaychuk's Luna.
|
||||
* https://raw.github.com/visionmedia/luna
|
||||
*
|
||||
*/
|
||||
|
||||
#ifndef _LAKE_HASH_H
|
||||
#define _LAKE_HASH_H
|
||||
|
||||
#include "khash.h"
|
||||
#include "common.h"
|
||||
#include "khash.h"
|
||||
|
||||
KHASH_MAP_INIT_STR(value, void *);
|
||||
|
||||
|
|
@ -23,8 +23,8 @@ typedef khash_t(value) lake_hash_t;
|
|||
#define lake_hash_make() kh_init(value)
|
||||
#define lake_hash_free(h) kh_destroy(value, h)
|
||||
|
||||
bool lake_hash_has(khash_t(value) *h, char *key);
|
||||
void lake_hash_put(khash_t(value) *h, char *key, void *val);
|
||||
void *lake_hash_get(khash_t(value) *h, char *key);
|
||||
bool lake_hash_has(khash_t(value) * h, char *key);
|
||||
void lake_hash_put(khash_t(value) * h, char *key, void *val);
|
||||
void *lake_hash_get(khash_t(value) * h, char *key);
|
||||
|
||||
#endif
|
||||
|
|
|
|||
51
src/int.c
51
src/int.c
|
|
@ -1,49 +1,46 @@
|
|||
/**
|
||||
* int.c
|
||||
* Lake Scheme
|
||||
*
|
||||
* Copyright 2011 Sami Samhuri
|
||||
* MIT License
|
||||
*
|
||||
*/
|
||||
* int.c
|
||||
* Lake Scheme
|
||||
*
|
||||
* Copyright 2011 Sami Samhuri
|
||||
* MIT License
|
||||
*
|
||||
*/
|
||||
|
||||
#include <stdlib.h>
|
||||
#include "common.h"
|
||||
#include "int.h"
|
||||
#include "common.h"
|
||||
#include "lake.h"
|
||||
#include "str.h"
|
||||
#include <stdlib.h>
|
||||
|
||||
static LakeInt *int_alloc(void)
|
||||
{
|
||||
LakeInt *i = malloc(sizeof(LakeInt));
|
||||
VAL(i)->type = TYPE_INT;
|
||||
VAL(i)->size = sizeof(LakeInt);
|
||||
return i;
|
||||
LakeInt *i = malloc(sizeof(LakeInt));
|
||||
VAL(i)->type = TYPE_INT;
|
||||
VAL(i)->size = sizeof(LakeInt);
|
||||
return i;
|
||||
}
|
||||
|
||||
LakeInt *int_make(void)
|
||||
{
|
||||
return int_from_c(0);
|
||||
}
|
||||
LakeInt *int_make(void) { return int_from_c(0); }
|
||||
|
||||
LakeInt *int_from_c(int n)
|
||||
{
|
||||
LakeInt *i = int_alloc();
|
||||
i->val = n;
|
||||
return i;
|
||||
LakeInt *i = int_alloc();
|
||||
i->val = n;
|
||||
return i;
|
||||
}
|
||||
|
||||
char *int_repr(LakeInt *i)
|
||||
{
|
||||
char *s = malloc(MAX_INT_LENGTH + 1);
|
||||
snprintf(s, MAX_INT_LENGTH, "%d", i->val);
|
||||
return s;
|
||||
char *s = malloc(MAX_INT_LENGTH + 1);
|
||||
snprintf(s, MAX_INT_LENGTH, "%d", i->val);
|
||||
return s;
|
||||
}
|
||||
|
||||
LakeStr *int_to_str(LakeInt *i)
|
||||
{
|
||||
char *s = int_repr(i);
|
||||
LakeStr *str = lake_str_from_c(s);
|
||||
free(s);
|
||||
return str;
|
||||
char *s = int_repr(i);
|
||||
LakeStr *str = lake_str_from_c(s);
|
||||
free(s);
|
||||
return str;
|
||||
}
|
||||
|
|
|
|||
14
src/int.h
14
src/int.h
|
|
@ -1,11 +1,11 @@
|
|||
/**
|
||||
* int.h
|
||||
* Lake Scheme
|
||||
*
|
||||
* Copyright 2011 Sami Samhuri
|
||||
* MIT License
|
||||
*
|
||||
*/
|
||||
* int.h
|
||||
* Lake Scheme
|
||||
*
|
||||
* Copyright 2011 Sami Samhuri
|
||||
* MIT License
|
||||
*
|
||||
*/
|
||||
|
||||
#ifndef _LAKE_INT_H
|
||||
#define _LAKE_INT_H
|
||||
|
|
|
|||
528
src/khash.h
528
src/khash.h
|
|
@ -29,38 +29,38 @@
|
|||
#include "khash.h"
|
||||
KHASH_MAP_INIT_INT(32, char)
|
||||
int main() {
|
||||
int ret, is_missing;
|
||||
khiter_t k;
|
||||
khash_t(32) *h = kh_init(32);
|
||||
k = kh_put(32, h, 5, &ret);
|
||||
if (!ret) kh_del(32, h, k);
|
||||
kh_value(h, k) = 10;
|
||||
k = kh_get(32, h, 10);
|
||||
is_missing = (k == kh_end(h));
|
||||
k = kh_get(32, h, 5);
|
||||
kh_del(32, h, k);
|
||||
for (k = kh_begin(h); k != kh_end(h); ++k)
|
||||
if (kh_exist(h, k)) kh_value(h, k) = 1;
|
||||
kh_destroy(32, h);
|
||||
return 0;
|
||||
int ret, is_missing;
|
||||
khiter_t k;
|
||||
khash_t(32) *h = kh_init(32);
|
||||
k = kh_put(32, h, 5, &ret);
|
||||
if (!ret) kh_del(32, h, k);
|
||||
kh_value(h, k) = 10;
|
||||
k = kh_get(32, h, 10);
|
||||
is_missing = (k == kh_end(h));
|
||||
k = kh_get(32, h, 5);
|
||||
kh_del(32, h, k);
|
||||
for (k = kh_begin(h); k != kh_end(h); ++k)
|
||||
if (kh_exist(h, k)) kh_value(h, k) = 1;
|
||||
kh_destroy(32, h);
|
||||
return 0;
|
||||
}
|
||||
*/
|
||||
|
||||
/*
|
||||
2011-09-16 (0.2.6):
|
||||
|
||||
* The capacity is a power of 2. This seems to dramatically improve the
|
||||
speed for simple keys. Thank Zilong Tan for the suggestion. Reference:
|
||||
* The capacity is a power of 2. This seems to dramatically improve the
|
||||
speed for simple keys. Thank Zilong Tan for the suggestion. Reference:
|
||||
|
||||
- http://code.google.com/p/ulib/
|
||||
- http://nothings.org/computer/judy/
|
||||
- http://code.google.com/p/ulib/
|
||||
- http://nothings.org/computer/judy/
|
||||
|
||||
* Allow to optionally use linear probing which usually has better
|
||||
performance for random input. Double hashing is still the default as it
|
||||
is more robust to certain non-random input.
|
||||
* Allow to optionally use linear probing which usually has better
|
||||
performance for random input. Double hashing is still the default as it
|
||||
is more robust to certain non-random input.
|
||||
|
||||
* Added Wang's integer hash function (not used by default). This hash
|
||||
function is more robust to certain non-random input.
|
||||
* Added Wang's integer hash function (not used by default). This hash
|
||||
function is more robust to certain non-random input.
|
||||
|
||||
2011-02-14 (0.2.5):
|
||||
|
||||
|
|
@ -72,32 +72,31 @@ int main() {
|
|||
|
||||
2008-09-19 (0.2.3):
|
||||
|
||||
* Corrected the example
|
||||
* Improved interfaces
|
||||
* Corrected the example
|
||||
* Improved interfaces
|
||||
|
||||
2008-09-11 (0.2.2):
|
||||
|
||||
* Improved speed a little in kh_put()
|
||||
* Improved speed a little in kh_put()
|
||||
|
||||
2008-09-10 (0.2.1):
|
||||
|
||||
* Added kh_clear()
|
||||
* Fixed a compiling error
|
||||
* Added kh_clear()
|
||||
* Fixed a compiling error
|
||||
|
||||
2008-09-02 (0.2.0):
|
||||
|
||||
* Changed to token concatenation which increases flexibility.
|
||||
* Changed to token concatenation which increases flexibility.
|
||||
|
||||
2008-08-31 (0.1.2):
|
||||
|
||||
* Fixed a bug in kh_get(), which has not been tested previously.
|
||||
* Fixed a bug in kh_get(), which has not been tested previously.
|
||||
|
||||
2008-08-31 (0.1.1):
|
||||
|
||||
* Added destructor
|
||||
* Added destructor
|
||||
*/
|
||||
|
||||
|
||||
#ifndef __AC_KHASH_H
|
||||
#define __AC_KHASH_H
|
||||
|
||||
|
|
@ -109,9 +108,9 @@ int main() {
|
|||
|
||||
#define AC_VERSION_KHASH_H "0.2.6"
|
||||
|
||||
#include <limits.h>
|
||||
#include <stdlib.h>
|
||||
#include <string.h>
|
||||
#include <limits.h>
|
||||
|
||||
/* compipler specific configuration */
|
||||
|
||||
|
|
@ -134,185 +133,269 @@ typedef unsigned long long khint64_t;
|
|||
typedef khint32_t khint_t;
|
||||
typedef khint_t khiter_t;
|
||||
|
||||
#define __ac_isempty(flag, i) ((flag[i>>4]>>((i&0xfU)<<1))&2)
|
||||
#define __ac_isdel(flag, i) ((flag[i>>4]>>((i&0xfU)<<1))&1)
|
||||
#define __ac_iseither(flag, i) ((flag[i>>4]>>((i&0xfU)<<1))&3)
|
||||
#define __ac_set_isdel_false(flag, i) (flag[i>>4]&=~(1ul<<((i&0xfU)<<1)))
|
||||
#define __ac_set_isempty_false(flag, i) (flag[i>>4]&=~(2ul<<((i&0xfU)<<1)))
|
||||
#define __ac_set_isboth_false(flag, i) (flag[i>>4]&=~(3ul<<((i&0xfU)<<1)))
|
||||
#define __ac_set_isdel_true(flag, i) (flag[i>>4]|=1ul<<((i&0xfU)<<1))
|
||||
#define __ac_isempty(flag, i) ((flag[i >> 4] >> ((i & 0xfU) << 1)) & 2)
|
||||
#define __ac_isdel(flag, i) ((flag[i >> 4] >> ((i & 0xfU) << 1)) & 1)
|
||||
#define __ac_iseither(flag, i) ((flag[i >> 4] >> ((i & 0xfU) << 1)) & 3)
|
||||
#define __ac_set_isdel_false(flag, i) \
|
||||
(flag[i >> 4] &= ~(1ul << ((i & 0xfU) << 1)))
|
||||
#define __ac_set_isempty_false(flag, i) \
|
||||
(flag[i >> 4] &= ~(2ul << ((i & 0xfU) << 1)))
|
||||
#define __ac_set_isboth_false(flag, i) \
|
||||
(flag[i >> 4] &= ~(3ul << ((i & 0xfU) << 1)))
|
||||
#define __ac_set_isdel_true(flag, i) (flag[i >> 4] |= 1ul << ((i & 0xfU) << 1))
|
||||
|
||||
#ifdef KHASH_LINEAR
|
||||
#define __ac_inc(k, m) 1
|
||||
#else
|
||||
#define __ac_inc(k, m) (((k)>>3 ^ (k)<<3) | 1) & (m)
|
||||
#define __ac_inc(k, m) (((k) >> 3 ^ (k) << 3) | 1) & (m)
|
||||
#endif
|
||||
|
||||
#define __ac_fsize(m) ((m) < 16? 1 : (m)>>4)
|
||||
#define __ac_fsize(m) ((m) < 16 ? 1 : (m) >> 4)
|
||||
|
||||
#ifndef kroundup32
|
||||
#define kroundup32(x) (--(x), (x)|=(x)>>1, (x)|=(x)>>2, (x)|=(x)>>4, (x)|=(x)>>8, (x)|=(x)>>16, ++(x))
|
||||
#define kroundup32(x) \
|
||||
(--(x), (x) |= (x) >> 1, (x) |= (x) >> 2, (x) |= (x) >> 4, \
|
||||
(x) |= (x) >> 8, (x) |= (x) >> 16, ++(x))
|
||||
#endif
|
||||
|
||||
static const double __ac_HASH_UPPER = 0.77;
|
||||
|
||||
#define KHASH_DECLARE(name, khkey_t, khval_t) \
|
||||
typedef struct { \
|
||||
khint_t n_buckets, size, n_occupied, upper_bound; \
|
||||
khint32_t *flags; \
|
||||
khkey_t *keys; \
|
||||
khval_t *vals; \
|
||||
} kh_##name##_t; \
|
||||
extern kh_##name##_t *kh_init_##name(); \
|
||||
extern void kh_destroy_##name(kh_##name##_t *h); \
|
||||
extern void kh_clear_##name(kh_##name##_t *h); \
|
||||
extern khint_t kh_get_##name(const kh_##name##_t *h, khkey_t key); \
|
||||
extern void kh_resize_##name(kh_##name##_t *h, khint_t new_n_buckets); \
|
||||
extern khint_t kh_put_##name(kh_##name##_t *h, khkey_t key, int *ret); \
|
||||
extern void kh_del_##name(kh_##name##_t *h, khint_t x);
|
||||
#define KHASH_DECLARE(name, khkey_t, khval_t) \
|
||||
typedef struct \
|
||||
{ \
|
||||
khint_t n_buckets, size, n_occupied, upper_bound; \
|
||||
khint32_t *flags; \
|
||||
khkey_t *keys; \
|
||||
khval_t *vals; \
|
||||
} kh_##name##_t; \
|
||||
extern kh_##name##_t *kh_init_##name(); \
|
||||
extern void kh_destroy_##name(kh_##name##_t *h); \
|
||||
extern void kh_clear_##name(kh_##name##_t *h); \
|
||||
extern khint_t kh_get_##name(const kh_##name##_t *h, khkey_t key); \
|
||||
extern void kh_resize_##name(kh_##name##_t *h, khint_t new_n_buckets); \
|
||||
extern khint_t kh_put_##name(kh_##name##_t *h, khkey_t key, int *ret); \
|
||||
extern void kh_del_##name(kh_##name##_t *h, khint_t x);
|
||||
|
||||
#define KHASH_INIT2(name, SCOPE, khkey_t, khval_t, kh_is_map, __hash_func, __hash_equal) \
|
||||
typedef struct { \
|
||||
khint_t n_buckets, size, n_occupied, upper_bound; \
|
||||
khint32_t *flags; \
|
||||
khkey_t *keys; \
|
||||
khval_t *vals; \
|
||||
} kh_##name##_t; \
|
||||
SCOPE kh_##name##_t *kh_init_##name() { \
|
||||
return (kh_##name##_t*)calloc(1, sizeof(kh_##name##_t)); \
|
||||
} \
|
||||
SCOPE void kh_destroy_##name(kh_##name##_t *h) \
|
||||
{ \
|
||||
if (h) { \
|
||||
free(h->keys); free(h->flags); \
|
||||
free(h->vals); \
|
||||
free(h); \
|
||||
} \
|
||||
} \
|
||||
SCOPE void kh_clear_##name(kh_##name##_t *h) \
|
||||
{ \
|
||||
if (h && h->flags) { \
|
||||
memset(h->flags, 0xaa, __ac_fsize(h->n_buckets) * sizeof(khint32_t)); \
|
||||
h->size = h->n_occupied = 0; \
|
||||
} \
|
||||
} \
|
||||
SCOPE khint_t kh_get_##name(const kh_##name##_t *h, khkey_t key) \
|
||||
{ \
|
||||
if (h->n_buckets) { \
|
||||
khint_t inc, k, i, last, mask; \
|
||||
mask = h->n_buckets - 1; \
|
||||
k = __hash_func(key); i = k & mask; \
|
||||
inc = __ac_inc(k, mask); last = i; /* inc==1 for linear probing */ \
|
||||
while (!__ac_isempty(h->flags, i) && (__ac_isdel(h->flags, i) || !__hash_equal(h->keys[i], key))) { \
|
||||
i = (i + inc) & mask; \
|
||||
if (i == last) return h->n_buckets; \
|
||||
} \
|
||||
return __ac_iseither(h->flags, i)? h->n_buckets : i; \
|
||||
} else return 0; \
|
||||
} \
|
||||
SCOPE void kh_resize_##name(kh_##name##_t *h, khint_t new_n_buckets) \
|
||||
{ /* This function uses 0.25*n_bucktes bytes of working space instead of [sizeof(key_t+val_t)+.25]*n_buckets. */ \
|
||||
khint32_t *new_flags = 0; \
|
||||
khint_t j = 1; \
|
||||
{ \
|
||||
kroundup32(new_n_buckets); \
|
||||
if (new_n_buckets < 4) new_n_buckets = 4; \
|
||||
if (h->size >= (khint_t)(new_n_buckets * __ac_HASH_UPPER + 0.5)) j = 0; /* requested size is too small */ \
|
||||
else { /* hash table size to be changed (shrink or expand); rehash */ \
|
||||
new_flags = (khint32_t*)malloc(__ac_fsize(new_n_buckets) * sizeof(khint32_t)); \
|
||||
memset(new_flags, 0xaa, __ac_fsize(new_n_buckets) * sizeof(khint32_t)); \
|
||||
if (h->n_buckets < new_n_buckets) { /* expand */ \
|
||||
h->keys = (khkey_t*)realloc(h->keys, new_n_buckets * sizeof(khkey_t)); \
|
||||
if (kh_is_map) h->vals = (khval_t*)realloc(h->vals, new_n_buckets * sizeof(khval_t)); \
|
||||
} /* otherwise shrink */ \
|
||||
} \
|
||||
} \
|
||||
if (j) { /* rehashing is needed */ \
|
||||
for (j = 0; j != h->n_buckets; ++j) { \
|
||||
if (__ac_iseither(h->flags, j) == 0) { \
|
||||
khkey_t key = h->keys[j]; \
|
||||
khval_t val; \
|
||||
khint_t new_mask; \
|
||||
new_mask = new_n_buckets - 1; \
|
||||
if (kh_is_map) val = h->vals[j]; \
|
||||
__ac_set_isdel_true(h->flags, j); \
|
||||
while (1) { /* kick-out process; sort of like in Cuckoo hashing */ \
|
||||
khint_t inc, k, i; \
|
||||
k = __hash_func(key); \
|
||||
i = k & new_mask; \
|
||||
inc = __ac_inc(k, new_mask); \
|
||||
while (!__ac_isempty(new_flags, i)) i = (i + inc) & new_mask; \
|
||||
__ac_set_isempty_false(new_flags, i); \
|
||||
if (i < h->n_buckets && __ac_iseither(h->flags, i) == 0) { /* kick out the existing element */ \
|
||||
{ khkey_t tmp = h->keys[i]; h->keys[i] = key; key = tmp; } \
|
||||
if (kh_is_map) { khval_t tmp = h->vals[i]; h->vals[i] = val; val = tmp; } \
|
||||
__ac_set_isdel_true(h->flags, i); /* mark it as deleted in the old hash table */ \
|
||||
} else { /* write the element and jump out of the loop */ \
|
||||
h->keys[i] = key; \
|
||||
if (kh_is_map) h->vals[i] = val; \
|
||||
break; \
|
||||
} \
|
||||
} \
|
||||
} \
|
||||
} \
|
||||
if (h->n_buckets > new_n_buckets) { /* shrink the hash table */ \
|
||||
h->keys = (khkey_t*)realloc(h->keys, new_n_buckets * sizeof(khkey_t)); \
|
||||
if (kh_is_map) h->vals = (khval_t*)realloc(h->vals, new_n_buckets * sizeof(khval_t)); \
|
||||
} \
|
||||
free(h->flags); /* free the working space */ \
|
||||
h->flags = new_flags; \
|
||||
h->n_buckets = new_n_buckets; \
|
||||
h->n_occupied = h->size; \
|
||||
h->upper_bound = (khint_t)(h->n_buckets * __ac_HASH_UPPER + 0.5); \
|
||||
} \
|
||||
} \
|
||||
SCOPE khint_t kh_put_##name(kh_##name##_t *h, khkey_t key, int *ret) \
|
||||
{ \
|
||||
khint_t x; \
|
||||
if (h->n_occupied >= h->upper_bound) { /* update the hash table */ \
|
||||
if (h->n_buckets > (h->size<<1)) kh_resize_##name(h, h->n_buckets - 1); /* clear "deleted" elements */ \
|
||||
else kh_resize_##name(h, h->n_buckets + 1); /* expand the hash table */ \
|
||||
} /* TODO: to implement automatically shrinking; resize() already support shrinking */ \
|
||||
{ \
|
||||
khint_t inc, k, i, site, last, mask = h->n_buckets - 1; \
|
||||
x = site = h->n_buckets; k = __hash_func(key); i = k & mask; \
|
||||
if (__ac_isempty(h->flags, i)) x = i; /* for speed up */ \
|
||||
else { \
|
||||
inc = __ac_inc(k, mask); last = i; \
|
||||
while (!__ac_isempty(h->flags, i) && (__ac_isdel(h->flags, i) || !__hash_equal(h->keys[i], key))) { \
|
||||
if (__ac_isdel(h->flags, i)) site = i; \
|
||||
i = (i + inc) & mask; \
|
||||
if (i == last) { x = site; break; } \
|
||||
} \
|
||||
if (x == h->n_buckets) { \
|
||||
if (__ac_isempty(h->flags, i) && site != h->n_buckets) x = site; \
|
||||
else x = i; \
|
||||
} \
|
||||
} \
|
||||
} \
|
||||
if (__ac_isempty(h->flags, x)) { /* not present at all */ \
|
||||
h->keys[x] = key; \
|
||||
__ac_set_isboth_false(h->flags, x); \
|
||||
++h->size; ++h->n_occupied; \
|
||||
*ret = 1; \
|
||||
} else if (__ac_isdel(h->flags, x)) { /* deleted */ \
|
||||
h->keys[x] = key; \
|
||||
__ac_set_isboth_false(h->flags, x); \
|
||||
++h->size; \
|
||||
*ret = 2; \
|
||||
} else *ret = 0; /* Don't touch h->keys[x] if present and not deleted */ \
|
||||
return x; \
|
||||
} \
|
||||
SCOPE void kh_del_##name(kh_##name##_t *h, khint_t x) \
|
||||
{ \
|
||||
if (x != h->n_buckets && !__ac_iseither(h->flags, x)) { \
|
||||
__ac_set_isdel_true(h->flags, x); \
|
||||
--h->size; \
|
||||
} \
|
||||
}
|
||||
#define KHASH_INIT2(name, SCOPE, khkey_t, khval_t, kh_is_map, __hash_func, \
|
||||
__hash_equal) \
|
||||
typedef struct \
|
||||
{ \
|
||||
khint_t n_buckets, size, n_occupied, upper_bound; \
|
||||
khint32_t *flags; \
|
||||
khkey_t *keys; \
|
||||
khval_t *vals; \
|
||||
} kh_##name##_t; \
|
||||
SCOPE kh_##name##_t *kh_init_##name() \
|
||||
{ \
|
||||
return (kh_##name##_t *)calloc(1, sizeof(kh_##name##_t)); \
|
||||
} \
|
||||
SCOPE void kh_destroy_##name(kh_##name##_t *h) \
|
||||
{ \
|
||||
if (h) \
|
||||
{ \
|
||||
free(h->keys); \
|
||||
free(h->flags); \
|
||||
free(h->vals); \
|
||||
free(h); \
|
||||
} \
|
||||
} \
|
||||
SCOPE void kh_clear_##name(kh_##name##_t *h) \
|
||||
{ \
|
||||
if (h && h->flags) \
|
||||
{ \
|
||||
memset(h->flags, 0xaa, \
|
||||
__ac_fsize(h->n_buckets) * sizeof(khint32_t)); \
|
||||
h->size = h->n_occupied = 0; \
|
||||
} \
|
||||
} \
|
||||
SCOPE khint_t kh_get_##name(const kh_##name##_t *h, khkey_t key) \
|
||||
{ \
|
||||
if (h->n_buckets) \
|
||||
{ \
|
||||
khint_t inc, k, i, last, mask; \
|
||||
mask = h->n_buckets - 1; \
|
||||
k = __hash_func(key); \
|
||||
i = k & mask; \
|
||||
inc = __ac_inc(k, mask); \
|
||||
last = i; /* inc==1 for linear probing */ \
|
||||
while ( \
|
||||
!__ac_isempty(h->flags, i) && \
|
||||
(__ac_isdel(h->flags, i) || !__hash_equal(h->keys[i], key))) \
|
||||
{ \
|
||||
i = (i + inc) & mask; \
|
||||
if (i == last) return h->n_buckets; \
|
||||
} \
|
||||
return __ac_iseither(h->flags, i) ? h->n_buckets : i; \
|
||||
} \
|
||||
else \
|
||||
return 0; \
|
||||
} \
|
||||
SCOPE void kh_resize_##name(kh_##name##_t *h, khint_t new_n_buckets) \
|
||||
{ /* This function uses 0.25*n_bucktes bytes of working space instead of \
|
||||
[sizeof(key_t+val_t)+.25]*n_buckets. */ \
|
||||
khint32_t *new_flags = 0; \
|
||||
khint_t j = 1; \
|
||||
{ \
|
||||
kroundup32(new_n_buckets); \
|
||||
if (new_n_buckets < 4) new_n_buckets = 4; \
|
||||
if (h->size >= (khint_t)(new_n_buckets * __ac_HASH_UPPER + 0.5)) \
|
||||
j = 0; /* requested size is too small */ \
|
||||
else \
|
||||
{ /* hash table size to be changed (shrink or expand); rehash */ \
|
||||
new_flags = (khint32_t *)malloc(__ac_fsize(new_n_buckets) * \
|
||||
sizeof(khint32_t)); \
|
||||
memset(new_flags, 0xaa, \
|
||||
__ac_fsize(new_n_buckets) * sizeof(khint32_t)); \
|
||||
if (h->n_buckets < new_n_buckets) \
|
||||
{ /* expand */ \
|
||||
h->keys = (khkey_t *)realloc( \
|
||||
h->keys, new_n_buckets * sizeof(khkey_t)); \
|
||||
if (kh_is_map) \
|
||||
h->vals = (khval_t *)realloc( \
|
||||
h->vals, new_n_buckets * sizeof(khval_t)); \
|
||||
} /* otherwise shrink */ \
|
||||
} \
|
||||
} \
|
||||
if (j) \
|
||||
{ /* rehashing is needed */ \
|
||||
for (j = 0; j != h->n_buckets; ++j) \
|
||||
{ \
|
||||
if (__ac_iseither(h->flags, j) == 0) \
|
||||
{ \
|
||||
khkey_t key = h->keys[j]; \
|
||||
khval_t val; \
|
||||
khint_t new_mask; \
|
||||
new_mask = new_n_buckets - 1; \
|
||||
if (kh_is_map) val = h->vals[j]; \
|
||||
__ac_set_isdel_true(h->flags, j); \
|
||||
while (1) \
|
||||
{ /* kick-out process; sort of like in Cuckoo hashing */ \
|
||||
khint_t inc, k, i; \
|
||||
k = __hash_func(key); \
|
||||
i = k & new_mask; \
|
||||
inc = __ac_inc(k, new_mask); \
|
||||
while (!__ac_isempty(new_flags, i)) \
|
||||
i = (i + inc) & new_mask; \
|
||||
__ac_set_isempty_false(new_flags, i); \
|
||||
if (i < h->n_buckets && \
|
||||
__ac_iseither(h->flags, i) == 0) \
|
||||
{ /* kick out the existing element */ \
|
||||
{ \
|
||||
khkey_t tmp = h->keys[i]; \
|
||||
h->keys[i] = key; \
|
||||
key = tmp; \
|
||||
} \
|
||||
if (kh_is_map) \
|
||||
{ \
|
||||
khval_t tmp = h->vals[i]; \
|
||||
h->vals[i] = val; \
|
||||
val = tmp; \
|
||||
} \
|
||||
__ac_set_isdel_true(h->flags, \
|
||||
i); /* mark it as deleted in \
|
||||
the old hash table */ \
|
||||
} \
|
||||
else \
|
||||
{ /* write the element and jump out of the loop */ \
|
||||
h->keys[i] = key; \
|
||||
if (kh_is_map) h->vals[i] = val; \
|
||||
break; \
|
||||
} \
|
||||
} \
|
||||
} \
|
||||
} \
|
||||
if (h->n_buckets > new_n_buckets) \
|
||||
{ /* shrink the hash table */ \
|
||||
h->keys = (khkey_t *)realloc(h->keys, \
|
||||
new_n_buckets * sizeof(khkey_t)); \
|
||||
if (kh_is_map) \
|
||||
h->vals = (khval_t *)realloc( \
|
||||
h->vals, new_n_buckets * sizeof(khval_t)); \
|
||||
} \
|
||||
free(h->flags); /* free the working space */ \
|
||||
h->flags = new_flags; \
|
||||
h->n_buckets = new_n_buckets; \
|
||||
h->n_occupied = h->size; \
|
||||
h->upper_bound = (khint_t)(h->n_buckets * __ac_HASH_UPPER + 0.5); \
|
||||
} \
|
||||
} \
|
||||
SCOPE khint_t kh_put_##name(kh_##name##_t *h, khkey_t key, int *ret) \
|
||||
{ \
|
||||
khint_t x; \
|
||||
if (h->n_occupied >= h->upper_bound) \
|
||||
{ /* update the hash table */ \
|
||||
if (h->n_buckets > (h->size << 1)) \
|
||||
kh_resize_##name(h, h->n_buckets - \
|
||||
1); /* clear "deleted" elements */ \
|
||||
else \
|
||||
kh_resize_##name(h, h->n_buckets + \
|
||||
1); /* expand the hash table */ \
|
||||
} /* TODO: to implement automatically shrinking; resize() already \
|
||||
support shrinking */ \
|
||||
{ \
|
||||
khint_t inc, k, i, site, last, mask = h->n_buckets - 1; \
|
||||
x = site = h->n_buckets; \
|
||||
k = __hash_func(key); \
|
||||
i = k & mask; \
|
||||
if (__ac_isempty(h->flags, i)) \
|
||||
x = i; /* for speed up */ \
|
||||
else \
|
||||
{ \
|
||||
inc = __ac_inc(k, mask); \
|
||||
last = i; \
|
||||
while (!__ac_isempty(h->flags, i) && \
|
||||
(__ac_isdel(h->flags, i) || \
|
||||
!__hash_equal(h->keys[i], key))) \
|
||||
{ \
|
||||
if (__ac_isdel(h->flags, i)) site = i; \
|
||||
i = (i + inc) & mask; \
|
||||
if (i == last) \
|
||||
{ \
|
||||
x = site; \
|
||||
break; \
|
||||
} \
|
||||
} \
|
||||
if (x == h->n_buckets) \
|
||||
{ \
|
||||
if (__ac_isempty(h->flags, i) && site != h->n_buckets) \
|
||||
x = site; \
|
||||
else \
|
||||
x = i; \
|
||||
} \
|
||||
} \
|
||||
} \
|
||||
if (__ac_isempty(h->flags, x)) \
|
||||
{ /* not present at all */ \
|
||||
h->keys[x] = key; \
|
||||
__ac_set_isboth_false(h->flags, x); \
|
||||
++h->size; \
|
||||
++h->n_occupied; \
|
||||
*ret = 1; \
|
||||
} \
|
||||
else if (__ac_isdel(h->flags, x)) \
|
||||
{ /* deleted */ \
|
||||
h->keys[x] = key; \
|
||||
__ac_set_isboth_false(h->flags, x); \
|
||||
++h->size; \
|
||||
*ret = 2; \
|
||||
} \
|
||||
else \
|
||||
*ret = 0; /* Don't touch h->keys[x] if present and not deleted */ \
|
||||
return x; \
|
||||
} \
|
||||
SCOPE void kh_del_##name(kh_##name##_t *h, khint_t x) \
|
||||
{ \
|
||||
if (x != h->n_buckets && !__ac_iseither(h->flags, x)) \
|
||||
{ \
|
||||
__ac_set_isdel_true(h->flags, x); \
|
||||
--h->size; \
|
||||
} \
|
||||
}
|
||||
|
||||
#define KHASH_INIT(name, khkey_t, khval_t, kh_is_map, __hash_func, __hash_equal) \
|
||||
KHASH_INIT2(name, static inline, khkey_t, khval_t, kh_is_map, __hash_func, __hash_equal)
|
||||
#define KHASH_INIT(name, khkey_t, khval_t, kh_is_map, __hash_func, \
|
||||
__hash_equal) \
|
||||
KHASH_INIT2(name, static inline, khkey_t, khval_t, kh_is_map, __hash_func, \
|
||||
__hash_equal)
|
||||
|
||||
/* --- BEGIN OF HASH FUNCTIONS --- */
|
||||
|
||||
|
|
@ -331,7 +414,7 @@ static const double __ac_HASH_UPPER = 0.77;
|
|||
@param key The integer [khint64_t]
|
||||
@return The hash value [khint_t]
|
||||
*/
|
||||
#define kh_int64_hash_func(key) (khint32_t)((key)>>33^(key)^(key)<<11)
|
||||
#define kh_int64_hash_func(key) (khint32_t)((key) >> 33 ^ (key) ^ (key) << 11)
|
||||
/*! @function
|
||||
@abstract 64-bit integer comparison function
|
||||
*/
|
||||
|
|
@ -343,9 +426,11 @@ static const double __ac_HASH_UPPER = 0.77;
|
|||
*/
|
||||
static inline khint_t __ac_X31_hash_string(const char *s)
|
||||
{
|
||||
khint_t h = *s;
|
||||
if (h) for (++s ; *s; ++s) h = (h << 5) - h + *s;
|
||||
return h;
|
||||
khint_t h = *s;
|
||||
if (h)
|
||||
for (++s; *s; ++s)
|
||||
h = (h << 5) - h + *s;
|
||||
return h;
|
||||
}
|
||||
/*! @function
|
||||
@abstract Another interface to const char* hash function
|
||||
|
|
@ -361,11 +446,11 @@ static inline khint_t __ac_X31_hash_string(const char *s)
|
|||
static inline khint_t __ac_Wang_hash(khint_t key)
|
||||
{
|
||||
key += ~(key << 15);
|
||||
key ^= (key >> 10);
|
||||
key += (key << 3);
|
||||
key ^= (key >> 6);
|
||||
key ^= (key >> 10);
|
||||
key += (key << 3);
|
||||
key ^= (key >> 6);
|
||||
key += ~(key << 11);
|
||||
key ^= (key >> 16);
|
||||
key ^= (key >> 16);
|
||||
return key;
|
||||
}
|
||||
#define kh_int_hash_func2(k) __ac_Wang_hash((khint_t)key)
|
||||
|
|
@ -416,7 +501,7 @@ static inline khint_t __ac_Wang_hash(khint_t key)
|
|||
@param k Key [type of keys]
|
||||
@param r Extra return code: 0 if the key is present in the hash table;
|
||||
1 if the bucket is empty (never used); 2 if the element in
|
||||
the bucket has been deleted [int*]
|
||||
the bucket has been deleted [int*]
|
||||
@return Iterator to the inserted element [khint_t]
|
||||
*/
|
||||
#define kh_put(name, h, k, r) kh_put_##name(h, k, r)
|
||||
|
|
@ -426,7 +511,8 @@ static inline khint_t __ac_Wang_hash(khint_t key)
|
|||
@param name Name of the hash table [symbol]
|
||||
@param h Pointer to the hash table [khash_t(name)*]
|
||||
@param k Key [type of keys]
|
||||
@return Iterator to the found element, or kh_end(h) is the element is absent [khint_t]
|
||||
@return Iterator to the found element, or kh_end(h) is the element is
|
||||
absent [khint_t]
|
||||
*/
|
||||
#define kh_get(name, h, k) kh_get_##name(h, k)
|
||||
|
||||
|
|
@ -502,46 +588,48 @@ static inline khint_t __ac_Wang_hash(khint_t key)
|
|||
@abstract Instantiate a hash set containing integer keys
|
||||
@param name Name of the hash table [symbol]
|
||||
*/
|
||||
#define KHASH_SET_INIT_INT(name) \
|
||||
KHASH_INIT(name, khint32_t, char, 0, kh_int_hash_func, kh_int_hash_equal)
|
||||
#define KHASH_SET_INIT_INT(name) \
|
||||
KHASH_INIT(name, khint32_t, char, 0, kh_int_hash_func, kh_int_hash_equal)
|
||||
|
||||
/*! @function
|
||||
@abstract Instantiate a hash map containing integer keys
|
||||
@param name Name of the hash table [symbol]
|
||||
@param khval_t Type of values [type]
|
||||
*/
|
||||
#define KHASH_MAP_INIT_INT(name, khval_t) \
|
||||
KHASH_INIT(name, khint32_t, khval_t, 1, kh_int_hash_func, kh_int_hash_equal)
|
||||
#define KHASH_MAP_INIT_INT(name, khval_t) \
|
||||
KHASH_INIT(name, khint32_t, khval_t, 1, kh_int_hash_func, kh_int_hash_equal)
|
||||
|
||||
/*! @function
|
||||
@abstract Instantiate a hash map containing 64-bit integer keys
|
||||
@param name Name of the hash table [symbol]
|
||||
*/
|
||||
#define KHASH_SET_INIT_INT64(name) \
|
||||
KHASH_INIT(name, khint64_t, char, 0, kh_int64_hash_func, kh_int64_hash_equal)
|
||||
#define KHASH_SET_INIT_INT64(name) \
|
||||
KHASH_INIT(name, khint64_t, char, 0, kh_int64_hash_func, \
|
||||
kh_int64_hash_equal)
|
||||
|
||||
/*! @function
|
||||
@abstract Instantiate a hash map containing 64-bit integer keys
|
||||
@param name Name of the hash table [symbol]
|
||||
@param khval_t Type of values [type]
|
||||
*/
|
||||
#define KHASH_MAP_INIT_INT64(name, khval_t) \
|
||||
KHASH_INIT(name, khint64_t, khval_t, 1, kh_int64_hash_func, kh_int64_hash_equal)
|
||||
#define KHASH_MAP_INIT_INT64(name, khval_t) \
|
||||
KHASH_INIT(name, khint64_t, khval_t, 1, kh_int64_hash_func, \
|
||||
kh_int64_hash_equal)
|
||||
|
||||
typedef const char *kh_cstr_t;
|
||||
/*! @function
|
||||
@abstract Instantiate a hash map containing const char* keys
|
||||
@param name Name of the hash table [symbol]
|
||||
*/
|
||||
#define KHASH_SET_INIT_STR(name) \
|
||||
KHASH_INIT(name, kh_cstr_t, char, 0, kh_str_hash_func, kh_str_hash_equal)
|
||||
#define KHASH_SET_INIT_STR(name) \
|
||||
KHASH_INIT(name, kh_cstr_t, char, 0, kh_str_hash_func, kh_str_hash_equal)
|
||||
|
||||
/*! @function
|
||||
@abstract Instantiate a hash map containing const char* keys
|
||||
@param name Name of the hash table [symbol]
|
||||
@param khval_t Type of values [type]
|
||||
*/
|
||||
#define KHASH_MAP_INIT_STR(name, khval_t) \
|
||||
KHASH_INIT(name, kh_cstr_t, khval_t, 1, kh_str_hash_func, kh_str_hash_equal)
|
||||
#define KHASH_MAP_INIT_STR(name, khval_t) \
|
||||
KHASH_INIT(name, kh_cstr_t, khval_t, 1, kh_str_hash_func, kh_str_hash_equal)
|
||||
|
||||
#endif /* __AC_KHASH_H */
|
||||
170
src/lake.c
170
src/lake.c
|
|
@ -1,171 +1,169 @@
|
|||
/**
|
||||
* 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.
|
||||
*
|
||||
*/
|
||||
* 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 "lake.h"
|
||||
#include "bool.h"
|
||||
#include "comment.h"
|
||||
#include "common.h"
|
||||
#include "hash.h"
|
||||
#include "env.h"
|
||||
#include "eval.h"
|
||||
#include "lake.h"
|
||||
#include "hash.h"
|
||||
#include "list.h"
|
||||
#include "primitive.h"
|
||||
#include "str.h"
|
||||
|
||||
int lake_val_size(void *x)
|
||||
{
|
||||
return VAL(x)->size;
|
||||
}
|
||||
int lake_val_size(void *x) { return VAL(x)->size; }
|
||||
|
||||
int lake_is_type(LakeType t, void *x)
|
||||
{
|
||||
return VAL(x)->type == t;
|
||||
}
|
||||
int lake_is_type(LakeType t, void *x) { return VAL(x)->type == t; }
|
||||
|
||||
char *lake_repr(void *expr)
|
||||
{
|
||||
if (expr == NULL) return strdup("(null)");
|
||||
if (expr == NULL) return strdup("(null)");
|
||||
|
||||
char *s = NULL;
|
||||
char *s = NULL;
|
||||
|
||||
LakeVal *e = VAL(expr);
|
||||
switch (e->type) {
|
||||
LakeVal *e = VAL(expr);
|
||||
switch (e->type)
|
||||
{
|
||||
|
||||
case TYPE_SYM:
|
||||
s = sym_repr(SYM(e));
|
||||
break;
|
||||
s = sym_repr(SYM(e));
|
||||
break;
|
||||
|
||||
case TYPE_BOOL:
|
||||
s = lake_bool_repr(BOOL(e));
|
||||
break;
|
||||
s = lake_bool_repr(BOOL(e));
|
||||
break;
|
||||
|
||||
case TYPE_INT:
|
||||
s = int_repr(INT(e));
|
||||
break;
|
||||
s = int_repr(INT(e));
|
||||
break;
|
||||
|
||||
case TYPE_STR: {
|
||||
case TYPE_STR:
|
||||
{
|
||||
size_t n = strlen(STR_S(STR(e))) + 2;
|
||||
s = malloc(n);
|
||||
/* TODO: quote the string */
|
||||
/* TODO: quote the string */
|
||||
snprintf(s, n, "\"%s\"", STR_S(STR(e)));
|
||||
break;
|
||||
}
|
||||
}
|
||||
|
||||
case TYPE_LIST:
|
||||
s = list_repr(LIST(e));
|
||||
break;
|
||||
s = list_repr(LIST(e));
|
||||
break;
|
||||
|
||||
case TYPE_DLIST:
|
||||
s = dlist_repr(DLIST(e));
|
||||
break;
|
||||
s = dlist_repr(DLIST(e));
|
||||
break;
|
||||
|
||||
case TYPE_PRIM:
|
||||
s = prim_repr(PRIM(e));
|
||||
break;
|
||||
s = prim_repr(PRIM(e));
|
||||
break;
|
||||
|
||||
case TYPE_FN:
|
||||
s = fn_repr(FN(e));
|
||||
break;
|
||||
s = fn_repr(FN(e));
|
||||
break;
|
||||
|
||||
case TYPE_COMM:
|
||||
s = comment_repr(COMM(e));
|
||||
break;
|
||||
s = comment_repr(COMM(e));
|
||||
break;
|
||||
|
||||
default:
|
||||
// If it wasn't a LakeVal we already crashed at the beginning of the switch,
|
||||
// so go ahead and print out the size too.
|
||||
fprintf(stderr, "error: unrecognized value, type %d, size %zu bytes",
|
||||
e->type, e->size);
|
||||
s = strdup("(unknown)");
|
||||
}
|
||||
// If it wasn't a LakeVal we already crashed at the beginning of the
|
||||
// switch, so go ahead and print out the size too.
|
||||
fprintf(stderr, "error: unrecognized value, type %d, size %zu bytes",
|
||||
e->type, e->size);
|
||||
s = strdup("(unknown)");
|
||||
}
|
||||
|
||||
return s;
|
||||
return s;
|
||||
}
|
||||
|
||||
bool lake_is_nil(LakeVal *x)
|
||||
{
|
||||
return lake_is_type(TYPE_LIST, x) && LIST_N(LIST(x)) == 0;
|
||||
return lake_is_type(TYPE_LIST, x) && LIST_N(LIST(x)) == 0;
|
||||
}
|
||||
|
||||
bool lake_is(LakeVal *a, LakeVal *b)
|
||||
{
|
||||
if (lake_is_type(TYPE_INT, a) && lake_is_type(TYPE_INT, b)) {
|
||||
return INT_VAL(INT(a)) == INT_VAL(INT(b));
|
||||
}
|
||||
if (lake_is_nil(a) && lake_is_nil(b)) return TRUE;
|
||||
return a == b;
|
||||
if (lake_is_type(TYPE_INT, a) && lake_is_type(TYPE_INT, b))
|
||||
{
|
||||
return INT_VAL(INT(a)) == INT_VAL(INT(b));
|
||||
}
|
||||
if (lake_is_nil(a) && lake_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"
|
||||
};
|
||||
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)";
|
||||
LakeType t = expr->type;
|
||||
return t >= 0 && t <= 8 ? type_names[t] : "(not a LakeVal)";
|
||||
}
|
||||
|
||||
bool lake_equal(LakeVal *a, LakeVal *b)
|
||||
{
|
||||
if (a->type != b->type) return FALSE;
|
||||
switch (a->type) {
|
||||
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;
|
||||
return a == b;
|
||||
|
||||
case TYPE_INT:
|
||||
return INT_VAL(INT(a)) == INT_VAL(INT(b));
|
||||
return INT_VAL(INT(a)) == INT_VAL(INT(b));
|
||||
|
||||
case TYPE_STR:
|
||||
return lake_str_equal(STR(a), STR(b));
|
||||
return lake_str_equal(STR(a), STR(b));
|
||||
|
||||
case TYPE_LIST:
|
||||
return list_equal(LIST(a), LIST(b));
|
||||
return list_equal(LIST(a), LIST(b));
|
||||
|
||||
case TYPE_DLIST:
|
||||
return dlist_equal(DLIST(a), DLIST(b));
|
||||
return dlist_equal(DLIST(a), DLIST(b));
|
||||
|
||||
case TYPE_COMM:
|
||||
return comment_equal(COMM(a), COMM(b));
|
||||
return comment_equal(COMM(a), COMM(b));
|
||||
|
||||
default:
|
||||
ERR("unknown type %d (%s)", a->type, type_name(a));
|
||||
return FALSE;
|
||||
}
|
||||
ERR("unknown type %d (%s)", a->type, type_name(a));
|
||||
return FALSE;
|
||||
}
|
||||
}
|
||||
|
||||
static LakeBool *bool_make(bool val)
|
||||
{
|
||||
LakeBool *b = malloc(sizeof(LakeBool));
|
||||
VAL(b)->type = TYPE_BOOL;
|
||||
VAL(b)->size = sizeof(LakeBool);
|
||||
b->val = val;
|
||||
return b;
|
||||
LakeBool *b = malloc(sizeof(LakeBool));
|
||||
VAL(b)->type = TYPE_BOOL;
|
||||
VAL(b)->size = sizeof(LakeBool);
|
||||
b->val = val;
|
||||
return b;
|
||||
}
|
||||
|
||||
LakeCtx *lake_init(void)
|
||||
{
|
||||
LakeCtx *ctx = malloc(sizeof(LakeCtx));
|
||||
ctx->toplevel = env_make(NULL);
|
||||
ctx->symbols = lake_hash_make();
|
||||
ctx->special_form_handlers = lake_hash_make();
|
||||
ctx->T = bool_make(TRUE);
|
||||
ctx->F = bool_make(FALSE);
|
||||
bind_primitives(ctx);
|
||||
init_special_form_handlers(ctx);
|
||||
return ctx;
|
||||
LakeCtx *ctx = malloc(sizeof(LakeCtx));
|
||||
ctx->toplevel = env_make(NULL);
|
||||
ctx->symbols = lake_hash_make();
|
||||
ctx->special_form_handlers = lake_hash_make();
|
||||
ctx->T = bool_make(TRUE);
|
||||
ctx->F = bool_make(FALSE);
|
||||
bind_primitives(ctx);
|
||||
init_special_form_handlers(ctx);
|
||||
return ctx;
|
||||
}
|
||||
|
|
|
|||
167
src/lake.h
167
src/lake.h
|
|
@ -1,31 +1,31 @@
|
|||
/**
|
||||
* lake.h
|
||||
* Lake Scheme
|
||||
*
|
||||
* Copyright 2011 Sami Samhuri
|
||||
* MIT License
|
||||
*
|
||||
*/
|
||||
* lake.h
|
||||
* Lake Scheme
|
||||
*
|
||||
* Copyright 2011 Sami Samhuri
|
||||
* MIT License
|
||||
*
|
||||
*/
|
||||
|
||||
#ifndef _LAKE_LAKE_H
|
||||
#define _LAKE_LAKE_H
|
||||
|
||||
#include <stdlib.h>
|
||||
#include "common.h"
|
||||
#include <stdlib.h>
|
||||
|
||||
#define LAKE_VERSION "0.1"
|
||||
|
||||
typedef int LakeType;
|
||||
|
||||
#define TYPE_SYM 1
|
||||
#define TYPE_BOOL 2
|
||||
#define TYPE_INT 3
|
||||
#define TYPE_STR 4
|
||||
#define TYPE_LIST 5
|
||||
#define TYPE_SYM 1
|
||||
#define TYPE_BOOL 2
|
||||
#define TYPE_INT 3
|
||||
#define TYPE_STR 4
|
||||
#define TYPE_LIST 5
|
||||
#define TYPE_DLIST 6
|
||||
#define TYPE_PRIM 7
|
||||
#define TYPE_FN 8
|
||||
#define TYPE_COMM 9
|
||||
#define TYPE_PRIM 7
|
||||
#define TYPE_FN 8
|
||||
#define TYPE_COMM 9
|
||||
|
||||
#define VAL(x) ((LakeVal *)x)
|
||||
#define SYM(x) ((LakeSym *)x)
|
||||
|
|
@ -38,49 +38,55 @@ typedef int LakeType;
|
|||
#define FN(x) ((LakeFn *)x)
|
||||
#define COMM(x) ((LakeComment *)x)
|
||||
|
||||
struct lake_val {
|
||||
LakeType type;
|
||||
size_t size;
|
||||
struct lake_val
|
||||
{
|
||||
LakeType type;
|
||||
size_t size;
|
||||
};
|
||||
typedef struct lake_val LakeVal;
|
||||
|
||||
struct lake_sym {
|
||||
LakeVal base;
|
||||
size_t n;
|
||||
char *s;
|
||||
unsigned long hash;
|
||||
struct lake_sym
|
||||
{
|
||||
LakeVal base;
|
||||
size_t n;
|
||||
char *s;
|
||||
unsigned long hash;
|
||||
};
|
||||
typedef struct lake_sym LakeSym;
|
||||
|
||||
struct lake_bool {
|
||||
LakeVal base;
|
||||
bool val;
|
||||
struct lake_bool
|
||||
{
|
||||
LakeVal base;
|
||||
bool val;
|
||||
};
|
||||
typedef struct lake_bool LakeBool;
|
||||
|
||||
struct lake_int {
|
||||
LakeVal base;
|
||||
int val;
|
||||
struct lake_int
|
||||
{
|
||||
LakeVal base;
|
||||
int val;
|
||||
};
|
||||
typedef struct lake_int LakeInt;
|
||||
|
||||
#define INT_VAL(x) (x->val)
|
||||
|
||||
struct lake_str {
|
||||
LakeVal base;
|
||||
size_t n;
|
||||
char *s;
|
||||
struct lake_str
|
||||
{
|
||||
LakeVal base;
|
||||
size_t n;
|
||||
char *s;
|
||||
};
|
||||
typedef struct lake_str LakeStr;
|
||||
|
||||
#define STR_N(str) (str->n)
|
||||
#define STR_S(str) (str->s)
|
||||
|
||||
struct lake_list {
|
||||
LakeVal base;
|
||||
size_t cap;
|
||||
size_t n;
|
||||
LakeVal **vals;
|
||||
struct lake_list
|
||||
{
|
||||
LakeVal base;
|
||||
size_t cap;
|
||||
size_t n;
|
||||
LakeVal **vals;
|
||||
};
|
||||
typedef struct lake_list LakeList;
|
||||
|
||||
|
|
@ -88,54 +94,58 @@ typedef struct lake_list LakeList;
|
|||
#define LIST_VALS(list) (list->vals)
|
||||
#define LIST_VAL(list, i) (i >= 0 && i < list->n ? list->vals[i] : NULL)
|
||||
|
||||
struct lake_dlist {
|
||||
LakeVal base;
|
||||
LakeList *head;
|
||||
LakeVal *tail;
|
||||
struct lake_dlist
|
||||
{
|
||||
LakeVal base;
|
||||
LakeList *head;
|
||||
LakeVal *tail;
|
||||
};
|
||||
typedef struct lake_dlist LakeDottedList;
|
||||
|
||||
#include "hash.h"
|
||||
#include "env.h"
|
||||
#include "hash.h"
|
||||
|
||||
/* Execution context */
|
||||
struct lake_ctx {
|
||||
Env *toplevel;
|
||||
lake_hash_t *symbols;
|
||||
lake_hash_t *special_form_handlers;
|
||||
LakeBool *T;
|
||||
LakeBool *F;
|
||||
struct lake_ctx
|
||||
{
|
||||
Env *toplevel;
|
||||
lake_hash_t *symbols;
|
||||
lake_hash_t *special_form_handlers;
|
||||
LakeBool *T;
|
||||
LakeBool *F;
|
||||
};
|
||||
typedef struct lake_ctx LakeCtx;
|
||||
|
||||
typedef LakeVal *(*lake_prim)(LakeCtx *ctx, LakeList *args);
|
||||
|
||||
struct lake_primitive {
|
||||
LakeVal base;
|
||||
char *name;
|
||||
int arity;
|
||||
lake_prim fn;
|
||||
struct lake_primitive
|
||||
{
|
||||
LakeVal base;
|
||||
char *name;
|
||||
int arity;
|
||||
lake_prim fn;
|
||||
};
|
||||
typedef struct lake_primitive LakePrimitive;
|
||||
|
||||
#define PRIM_ARITY(x) (x->arity)
|
||||
#define ARITY_VARARGS -1
|
||||
|
||||
|
||||
struct lake_fn {
|
||||
LakeVal base;
|
||||
LakeList *params;
|
||||
LakeSym *varargs;
|
||||
LakeList *body;
|
||||
Env *closure;
|
||||
struct lake_fn
|
||||
{
|
||||
LakeVal base;
|
||||
LakeList *params;
|
||||
LakeSym *varargs;
|
||||
LakeList *body;
|
||||
Env *closure;
|
||||
};
|
||||
typedef struct lake_fn LakeFn;
|
||||
|
||||
#define CALLABLE(x) (lake_is_type(TYPE_FN, x) || lake_is_type(TYPE_PRIM, x))
|
||||
|
||||
struct lake_comment {
|
||||
LakeVal base;
|
||||
LakeStr *text;
|
||||
struct lake_comment
|
||||
{
|
||||
LakeVal base;
|
||||
LakeStr *text;
|
||||
};
|
||||
typedef struct lake_comment LakeComment;
|
||||
|
||||
|
|
@ -151,23 +161,30 @@ char *lake_repr(void *val);
|
|||
|
||||
#include <stdio.h>
|
||||
|
||||
#define ERR(...) do { \
|
||||
fprintf(stderr, "error: "); \
|
||||
fprintf(stderr, __VA_ARGS__); \
|
||||
fprintf(stderr, "\n"); \
|
||||
#define ERR(...) \
|
||||
do \
|
||||
{ \
|
||||
fprintf(stderr, "error: "); \
|
||||
fprintf(stderr, __VA_ARGS__); \
|
||||
fprintf(stderr, "\n"); \
|
||||
} while (0)
|
||||
|
||||
#define DIE(...) do { ERR(__VA_ARGS__); exit(1); } while(0)
|
||||
#define DIE(...) \
|
||||
do \
|
||||
{ \
|
||||
ERR(__VA_ARGS__); \
|
||||
exit(1); \
|
||||
} while (0)
|
||||
#define OOM() DIE("%s:%d out of memory", __FILE__, __LINE__)
|
||||
|
||||
#include "bool.h"
|
||||
#include "sym.h"
|
||||
#include "int.h"
|
||||
#include "str.h"
|
||||
#include "list.h"
|
||||
#include "comment.h"
|
||||
#include "dlist.h"
|
||||
#include "fn.h"
|
||||
#include "comment.h"
|
||||
#include "int.h"
|
||||
#include "list.h"
|
||||
#include "primitive.h"
|
||||
#include "str.h"
|
||||
#include "sym.h"
|
||||
|
||||
#endif
|
||||
260
src/list.c
260
src/list.c
|
|
@ -1,20 +1,20 @@
|
|||
/**
|
||||
* list.c
|
||||
* Lake Scheme
|
||||
*
|
||||
* Copyright 2011 Sami Samhuri
|
||||
* MIT License
|
||||
*
|
||||
*/
|
||||
* list.c
|
||||
* Lake Scheme
|
||||
*
|
||||
* Copyright 2011 Sami Samhuri
|
||||
* MIT License
|
||||
*
|
||||
*/
|
||||
|
||||
#include <stdlib.h>
|
||||
#include <stdio.h>
|
||||
#include <string.h>
|
||||
#include "list.h"
|
||||
#include "common.h"
|
||||
#include "int.h"
|
||||
#include "lake.h"
|
||||
#include "list.h"
|
||||
#include "str.h"
|
||||
#include <stdio.h>
|
||||
#include <stdlib.h>
|
||||
#include <string.h>
|
||||
|
||||
/* TODO: use a linked list instead of this cheesy structure */
|
||||
|
||||
|
|
@ -22,184 +22,198 @@
|
|||
|
||||
static LakeList *list_alloc(void)
|
||||
{
|
||||
LakeList *list = malloc(sizeof(LakeList));
|
||||
VAL(list)->type = TYPE_LIST;
|
||||
VAL(list)->size = sizeof(LakeList);
|
||||
return list;
|
||||
LakeList *list = malloc(sizeof(LakeList));
|
||||
VAL(list)->type = TYPE_LIST;
|
||||
VAL(list)->size = sizeof(LakeList);
|
||||
return list;
|
||||
}
|
||||
|
||||
void list_free(LakeList *list)
|
||||
{
|
||||
/* TODO: proper memory management ... refcounting? */
|
||||
if (list) {
|
||||
free(list);
|
||||
}
|
||||
/* TODO: proper memory management ... refcounting? */
|
||||
if (list)
|
||||
{
|
||||
free(list);
|
||||
}
|
||||
}
|
||||
|
||||
LakeList *list_make(void)
|
||||
{
|
||||
LakeList *list = list_make_with_capacity(LIST_INIT_CAP);
|
||||
memset(list->vals, 0, list->cap);
|
||||
return list;
|
||||
LakeList *list = list_make_with_capacity(LIST_INIT_CAP);
|
||||
memset(list->vals, 0, list->cap);
|
||||
return list;
|
||||
}
|
||||
|
||||
LakeList *list_cons(LakeVal *car, LakeVal *cdr)
|
||||
{
|
||||
LakeList *list;
|
||||
if (lake_is_type(TYPE_LIST, cdr)) {
|
||||
list = LIST(cdr);
|
||||
list_unshift(list, car);
|
||||
}
|
||||
else {
|
||||
list = list_make_with_capacity(2);
|
||||
list_append(list, car);
|
||||
list_append(list, cdr);
|
||||
}
|
||||
return list;
|
||||
LakeList *list;
|
||||
if (lake_is_type(TYPE_LIST, cdr))
|
||||
{
|
||||
list = LIST(cdr);
|
||||
list_unshift(list, car);
|
||||
}
|
||||
else
|
||||
{
|
||||
list = list_make_with_capacity(2);
|
||||
list_append(list, car);
|
||||
list_append(list, cdr);
|
||||
}
|
||||
return list;
|
||||
}
|
||||
|
||||
LakeList *list_make_with_capacity(size_t cap)
|
||||
{
|
||||
LakeList *list = list_alloc();
|
||||
list->cap = cap;
|
||||
list->n = 0;
|
||||
list->vals = malloc(cap * sizeof(LakeVal *));
|
||||
return list;
|
||||
LakeList *list = list_alloc();
|
||||
list->cap = cap;
|
||||
list->n = 0;
|
||||
list->vals = malloc(cap * sizeof(LakeVal *));
|
||||
return list;
|
||||
}
|
||||
|
||||
LakeList *list_from_array(size_t n, LakeVal *vals[])
|
||||
{
|
||||
LakeList *list = list_make_with_capacity(n);
|
||||
memcpy(list->vals, vals, n * sizeof(LakeVal *));
|
||||
list->n = n;
|
||||
return list;
|
||||
LakeList *list = list_make_with_capacity(n);
|
||||
memcpy(list->vals, vals, n * sizeof(LakeVal *));
|
||||
list->n = n;
|
||||
return list;
|
||||
}
|
||||
|
||||
LakeInt *list_len(LakeList *list)
|
||||
{
|
||||
return int_from_c(list->n);
|
||||
}
|
||||
LakeInt *list_len(LakeList *list) { return int_from_c(list->n); }
|
||||
|
||||
LakeList *list_copy(LakeList *list)
|
||||
{
|
||||
return list_from_array(list->n, list->vals);
|
||||
return list_from_array(list->n, list->vals);
|
||||
}
|
||||
|
||||
static void list_grow(LakeList *list)
|
||||
{
|
||||
list->cap *= 2;
|
||||
list->vals = realloc(list->vals, list->cap * sizeof(LakeVal *));
|
||||
if (!list->vals) OOM();
|
||||
list->cap *= 2;
|
||||
list->vals = realloc(list->vals, list->cap * sizeof(LakeVal *));
|
||||
if (!list->vals) OOM();
|
||||
}
|
||||
|
||||
LakeVal *list_set(LakeList *list, size_t i, LakeVal *val)
|
||||
{
|
||||
if (i < list->n) {
|
||||
list->vals[i] = val;
|
||||
}
|
||||
return NULL;
|
||||
if (i < list->n)
|
||||
{
|
||||
list->vals[i] = val;
|
||||
}
|
||||
return NULL;
|
||||
}
|
||||
|
||||
LakeVal *list_get(LakeList *list, LakeInt *li)
|
||||
{
|
||||
int i = INT_VAL(li);
|
||||
if (i >= 0 && i < list->n) {
|
||||
return list->vals[i];
|
||||
}
|
||||
return NULL;
|
||||
int i = INT_VAL(li);
|
||||
if (i >= 0 && i < list->n)
|
||||
{
|
||||
return list->vals[i];
|
||||
}
|
||||
return NULL;
|
||||
}
|
||||
|
||||
LakeVal *list_append(LakeList *list, LakeVal *val)
|
||||
{
|
||||
if (list->n >= list->cap) {
|
||||
list_grow(list);
|
||||
}
|
||||
list->vals[list->n++] = val;
|
||||
return NULL;
|
||||
if (list->n >= list->cap)
|
||||
{
|
||||
list_grow(list);
|
||||
}
|
||||
list->vals[list->n++] = val;
|
||||
return NULL;
|
||||
}
|
||||
|
||||
LakeVal *list_shift(LakeList *list)
|
||||
{
|
||||
LakeVal *head = NULL;
|
||||
if (list->n > 0) {
|
||||
head = list->vals[0];
|
||||
size_t i;
|
||||
size_t n = list->n;
|
||||
for (i = 1; i < n; ++i) {
|
||||
list->vals[i - 1] = list->vals[i];
|
||||
LakeVal *head = NULL;
|
||||
if (list->n > 0)
|
||||
{
|
||||
head = list->vals[0];
|
||||
size_t i;
|
||||
size_t n = list->n;
|
||||
for (i = 1; i < n; ++i)
|
||||
{
|
||||
list->vals[i - 1] = list->vals[i];
|
||||
}
|
||||
list->n--;
|
||||
}
|
||||
list->n--;
|
||||
}
|
||||
return head;
|
||||
return head;
|
||||
}
|
||||
|
||||
LakeVal *list_unshift(LakeList *list, LakeVal *val)
|
||||
{
|
||||
if (list->n == 0) {
|
||||
list_append(list, val);
|
||||
}
|
||||
else {
|
||||
if (list->n >= list->cap) {
|
||||
list_grow(list);
|
||||
if (list->n == 0)
|
||||
{
|
||||
list_append(list, val);
|
||||
}
|
||||
size_t i = list->n++;
|
||||
do {
|
||||
list->vals[i] = list->vals[i - 1];
|
||||
} while (i--);
|
||||
list->vals[0] = val;
|
||||
}
|
||||
return NULL;
|
||||
else
|
||||
{
|
||||
if (list->n >= list->cap)
|
||||
{
|
||||
list_grow(list);
|
||||
}
|
||||
size_t i = list->n++;
|
||||
do
|
||||
{
|
||||
list->vals[i] = list->vals[i - 1];
|
||||
} while (i--);
|
||||
list->vals[0] = val;
|
||||
}
|
||||
return NULL;
|
||||
}
|
||||
|
||||
LakeVal *list_pop(LakeList *list)
|
||||
{
|
||||
LakeVal *tail = NULL;
|
||||
if (list->n > 0) {
|
||||
tail = list->vals[list->n - 1];
|
||||
list->n--;
|
||||
}
|
||||
return tail;
|
||||
LakeVal *tail = NULL;
|
||||
if (list->n > 0)
|
||||
{
|
||||
tail = list->vals[list->n - 1];
|
||||
list->n--;
|
||||
}
|
||||
return tail;
|
||||
}
|
||||
|
||||
bool list_equal(LakeList *a, LakeList *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;
|
||||
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)
|
||||
{
|
||||
char *s = list_repr(list);
|
||||
LakeStr *str = lake_str_from_c(s);
|
||||
free(s);
|
||||
return str;
|
||||
char *s = list_repr(list);
|
||||
LakeStr *str = lake_str_from_c(s);
|
||||
free(s);
|
||||
return str;
|
||||
}
|
||||
|
||||
char *list_repr(LakeList *list)
|
||||
{
|
||||
char *s = malloc(2);
|
||||
s[0] = '(';
|
||||
s[1] = '\0';
|
||||
int i;
|
||||
char *s2;
|
||||
LakeVal *val;
|
||||
for (i = 0; i < LIST_N(list); ++i) {
|
||||
val = LIST_VAL(list, i);
|
||||
if (val == VAL(list)) {
|
||||
s2 = strdup("[Circular]");
|
||||
char *s = malloc(2);
|
||||
s[0] = '(';
|
||||
s[1] = '\0';
|
||||
int i;
|
||||
char *s2;
|
||||
LakeVal *val;
|
||||
for (i = 0; i < LIST_N(list); ++i)
|
||||
{
|
||||
val = LIST_VAL(list, i);
|
||||
if (val == VAL(list))
|
||||
{
|
||||
s2 = strdup("[Circular]");
|
||||
}
|
||||
else
|
||||
{
|
||||
s2 = lake_repr(val);
|
||||
}
|
||||
s = lake_str_append(s, s2);
|
||||
free(s2);
|
||||
if (i != LIST_N(list) - 1) s = lake_str_append(s, " ");
|
||||
}
|
||||
else {
|
||||
s2 = lake_repr(val);
|
||||
}
|
||||
s = lake_str_append(s, s2);
|
||||
free(s2);
|
||||
if (i != LIST_N(list) - 1) s = lake_str_append(s, " ");
|
||||
}
|
||||
return lake_str_append(s, ")");
|
||||
return lake_str_append(s, ")");
|
||||
}
|
||||
|
|
|
|||
16
src/list.h
16
src/list.h
|
|
@ -1,19 +1,19 @@
|
|||
/**
|
||||
* list.h
|
||||
* Lake Scheme
|
||||
*
|
||||
* Copyright 2011 Sami Samhuri
|
||||
* MIT License
|
||||
*
|
||||
*/
|
||||
* list.h
|
||||
* Lake Scheme
|
||||
*
|
||||
* Copyright 2011 Sami Samhuri
|
||||
* MIT License
|
||||
*
|
||||
*/
|
||||
|
||||
#ifndef _LAKE_LIST_H
|
||||
#define _LAKE_LIST_H
|
||||
|
||||
#include <stdlib.h>
|
||||
#include "common.h"
|
||||
#include "lake.h"
|
||||
#include "str.h"
|
||||
#include <stdlib.h>
|
||||
|
||||
LakeList *list_make(void);
|
||||
LakeList *list_cons(LakeVal *car, LakeVal *cdr);
|
||||
|
|
|
|||
558
src/parse.c
558
src/parse.c
|
|
@ -1,30 +1,31 @@
|
|||
/**
|
||||
* parse.c
|
||||
* Lake Scheme
|
||||
*
|
||||
* Copyright 2011 Sami Samhuri
|
||||
* MIT License
|
||||
*
|
||||
*/
|
||||
* parse.c
|
||||
* Lake Scheme
|
||||
*
|
||||
* Copyright 2011 Sami Samhuri
|
||||
* MIT License
|
||||
*
|
||||
*/
|
||||
|
||||
#include <stdio.h>
|
||||
#include <stdlib.h>
|
||||
#include <string.h>
|
||||
#include "parse.h"
|
||||
#include "common.h"
|
||||
#include "dlist.h"
|
||||
#include "int.h"
|
||||
#include "lake.h"
|
||||
#include "list.h"
|
||||
#include "parse.h"
|
||||
#include "str.h"
|
||||
#include "sym.h"
|
||||
#include <stdio.h>
|
||||
#include <stdlib.h>
|
||||
#include <string.h>
|
||||
|
||||
struct context {
|
||||
char *s;
|
||||
size_t n;
|
||||
size_t i;
|
||||
size_t mark;
|
||||
LakeCtx *lake_ctx;
|
||||
struct context
|
||||
{
|
||||
char *s;
|
||||
size_t n;
|
||||
size_t i;
|
||||
size_t mark;
|
||||
LakeCtx *lake_ctx;
|
||||
};
|
||||
typedef struct context Ctx;
|
||||
|
||||
|
|
@ -33,361 +34,380 @@ static int maybe_spaces(Ctx *ctx);
|
|||
|
||||
static char peek(Ctx *ctx)
|
||||
{
|
||||
if (ctx->i < ctx->n) return ctx->s[ctx->i];
|
||||
return PARSE_EOF;
|
||||
if (ctx->i < ctx->n) return ctx->s[ctx->i];
|
||||
return PARSE_EOF;
|
||||
}
|
||||
|
||||
static void warn_trailing(Ctx *ctx)
|
||||
{
|
||||
maybe_spaces(ctx);
|
||||
/* don't warn about trailing comments */
|
||||
if (ctx->i < ctx->n && peek(ctx) != ';') {
|
||||
char *trailing = ctx->s + ctx->i;
|
||||
fprintf(stderr, "warning: ignoring %d trailing chars: %s\n", (int)(ctx->n - ctx->i), trailing);
|
||||
}
|
||||
maybe_spaces(ctx);
|
||||
/* don't warn about trailing comments */
|
||||
if (ctx->i < ctx->n && peek(ctx) != ';')
|
||||
{
|
||||
char *trailing = ctx->s + ctx->i;
|
||||
fprintf(stderr, "warning: ignoring %d trailing chars: %s\n",
|
||||
(int)(ctx->n - ctx->i), trailing);
|
||||
}
|
||||
}
|
||||
|
||||
LakeVal *parse_expr(LakeCtx *lake_ctx, char *s, size_t n)
|
||||
{
|
||||
Ctx ctx = { s, n, 0, 0, lake_ctx };
|
||||
LakeVal *result = _parse_expr(&ctx);
|
||||
warn_trailing(&ctx);
|
||||
return result;
|
||||
Ctx ctx = {s, n, 0, 0, lake_ctx};
|
||||
LakeVal *result = _parse_expr(&ctx);
|
||||
warn_trailing(&ctx);
|
||||
return result;
|
||||
}
|
||||
|
||||
LakeList *parse_exprs(LakeCtx *lake_ctx, char *s, size_t n)
|
||||
{
|
||||
Ctx ctx = { s, n, 0, 0, lake_ctx };
|
||||
LakeList *results = list_make();
|
||||
LakeVal *result;
|
||||
while (ctx.i < ctx.n) {
|
||||
result = _parse_expr(&ctx);
|
||||
if (result && result != VAL(PARSE_ERR)) {
|
||||
list_append(results, result);
|
||||
Ctx ctx = {s, n, 0, 0, lake_ctx};
|
||||
LakeList *results = list_make();
|
||||
LakeVal *result;
|
||||
while (ctx.i < ctx.n)
|
||||
{
|
||||
result = _parse_expr(&ctx);
|
||||
if (result && result != VAL(PARSE_ERR))
|
||||
{
|
||||
list_append(results, result);
|
||||
}
|
||||
else
|
||||
{
|
||||
list_free(results);
|
||||
return NULL;
|
||||
}
|
||||
}
|
||||
else {
|
||||
list_free(results);
|
||||
return NULL;
|
||||
}
|
||||
}
|
||||
warn_trailing(&ctx);
|
||||
return results;
|
||||
warn_trailing(&ctx);
|
||||
return results;
|
||||
}
|
||||
|
||||
LakeList *parse_naked_list(LakeCtx *lake_ctx, char *s, size_t n)
|
||||
{
|
||||
Ctx ctx = { s, n, 0, 0, lake_ctx };
|
||||
LakeList *list = list_make();
|
||||
char c;
|
||||
maybe_spaces(&ctx);
|
||||
while ((c = peek(&ctx)) != PARSE_EOF) {
|
||||
LakeVal *val = _parse_expr(&ctx);
|
||||
if (val == VAL(PARSE_ERR)) {
|
||||
list_free(list);
|
||||
ctx.i = ctx.n;
|
||||
return NULL;
|
||||
Ctx ctx = {s, n, 0, 0, lake_ctx};
|
||||
LakeList *list = list_make();
|
||||
char c;
|
||||
maybe_spaces(&ctx);
|
||||
while ((c = peek(&ctx)) != PARSE_EOF)
|
||||
{
|
||||
LakeVal *val = _parse_expr(&ctx);
|
||||
if (val == VAL(PARSE_ERR))
|
||||
{
|
||||
list_free(list);
|
||||
ctx.i = ctx.n;
|
||||
return NULL;
|
||||
}
|
||||
list_append(list, val);
|
||||
}
|
||||
list_append(list, val);
|
||||
}
|
||||
warn_trailing(&ctx);
|
||||
return list;
|
||||
warn_trailing(&ctx);
|
||||
return list;
|
||||
}
|
||||
|
||||
static void consume(Ctx *ctx, size_t n)
|
||||
{
|
||||
if (ctx->i + n > ctx->n) {
|
||||
DIE("cannot consume, no more input");
|
||||
}
|
||||
ctx->i += n;
|
||||
if (ctx->i + n > ctx->n)
|
||||
{
|
||||
DIE("cannot consume, no more input");
|
||||
}
|
||||
ctx->i += n;
|
||||
}
|
||||
|
||||
static char consume1(Ctx *ctx)
|
||||
{
|
||||
char c = peek(ctx);
|
||||
consume(ctx, 1);
|
||||
return c;
|
||||
char c = peek(ctx);
|
||||
consume(ctx, 1);
|
||||
return c;
|
||||
}
|
||||
|
||||
static char ch(Ctx *ctx, char expected)
|
||||
{
|
||||
char c = peek(ctx);
|
||||
if (c == expected) {
|
||||
consume1(ctx);
|
||||
return c;
|
||||
}
|
||||
DIE("parse error, expected '%c' got '%c'", expected, c);
|
||||
char c = peek(ctx);
|
||||
if (c == expected)
|
||||
{
|
||||
consume1(ctx);
|
||||
return c;
|
||||
}
|
||||
DIE("parse error, expected '%c' got '%c'", expected, c);
|
||||
}
|
||||
|
||||
static void mark(Ctx *ctx)
|
||||
{
|
||||
ctx->mark = ctx->i;
|
||||
}
|
||||
static void mark(Ctx *ctx) { ctx->mark = ctx->i; }
|
||||
|
||||
static void backtrack(Ctx *ctx)
|
||||
{
|
||||
ctx->i = ctx->mark;
|
||||
}
|
||||
static void backtrack(Ctx *ctx) { ctx->i = ctx->mark; }
|
||||
|
||||
static bool is_space(char c)
|
||||
{
|
||||
return strchr(" \r\n\t", c) != NULL;
|
||||
}
|
||||
static bool is_space(char c) { return strchr(" \r\n\t", c) != NULL; }
|
||||
|
||||
static bool is_letter(char c)
|
||||
{
|
||||
return (c >= 'a' && c <= 'z') || (c >= 'A' && c <= 'Z');
|
||||
return (c >= 'a' && c <= 'z') || (c >= 'A' && c <= 'Z');
|
||||
}
|
||||
|
||||
static bool is_symbol(char c)
|
||||
{
|
||||
return strchr("!$%&|*+-/:<=>?@^_~#", c) != NULL;
|
||||
return strchr("!$%&|*+-/:<=>?@^_~#", c) != NULL;
|
||||
}
|
||||
|
||||
static bool is_digit(char c)
|
||||
{
|
||||
return c >= '0' && c <= '9';
|
||||
}
|
||||
static bool is_digit(char c) { return c >= '0' && c <= '9'; }
|
||||
|
||||
static bool is_sym_char(char c)
|
||||
{
|
||||
return is_letter(c) || is_symbol(c) || is_digit(c);
|
||||
return is_letter(c) || is_symbol(c) || is_digit(c);
|
||||
}
|
||||
|
||||
static bool is_newline(char c)
|
||||
{
|
||||
return c == '\n' || c == '\r';
|
||||
}
|
||||
static bool is_newline(char c) { return c == '\n' || c == '\r'; }
|
||||
|
||||
static char *parse_while(Ctx *ctx, bool (*is_valid)(char))
|
||||
{
|
||||
size_t n = 8;
|
||||
size_t i = 0;
|
||||
char *s = malloc(n);
|
||||
char c;
|
||||
while ((c = peek(ctx)) != PARSE_EOF && is_valid(c)) {
|
||||
s[i++] = c;
|
||||
consume1(ctx);
|
||||
/* grow if necessary */
|
||||
if (i >= n) {
|
||||
n *= 2;
|
||||
if (!(s = realloc(s, n))) OOM();
|
||||
size_t n = 8;
|
||||
size_t i = 0;
|
||||
char *s = malloc(n);
|
||||
char c;
|
||||
while ((c = peek(ctx)) != PARSE_EOF && is_valid(c))
|
||||
{
|
||||
s[i++] = c;
|
||||
consume1(ctx);
|
||||
/* grow if necessary */
|
||||
if (i >= n)
|
||||
{
|
||||
n *= 2;
|
||||
if (!(s = realloc(s, n))) OOM();
|
||||
}
|
||||
}
|
||||
}
|
||||
s[i] = '\0';
|
||||
return s;
|
||||
s[i] = '\0';
|
||||
return s;
|
||||
}
|
||||
|
||||
static int maybe_spaces(Ctx *ctx)
|
||||
{
|
||||
while (is_space(peek(ctx))) {
|
||||
consume1(ctx);
|
||||
}
|
||||
return 1;
|
||||
while (is_space(peek(ctx)))
|
||||
{
|
||||
consume1(ctx);
|
||||
}
|
||||
return 1;
|
||||
}
|
||||
|
||||
static LakeVal *parse_int(Ctx *ctx)
|
||||
{
|
||||
mark(ctx);
|
||||
int n = 0;
|
||||
char c = peek(ctx);
|
||||
char sign = c == '-' ? -1 : 1;
|
||||
if (c == '-' || c == '+') {
|
||||
consume1(ctx);
|
||||
/* if not followed by a digit it's a symbol */
|
||||
if (!is_digit(peek(ctx))) {
|
||||
backtrack(ctx);
|
||||
return NULL;
|
||||
mark(ctx);
|
||||
int n = 0;
|
||||
char c = peek(ctx);
|
||||
char sign = c == '-' ? -1 : 1;
|
||||
if (c == '-' || c == '+')
|
||||
{
|
||||
consume1(ctx);
|
||||
/* if not followed by a digit it's a symbol */
|
||||
if (!is_digit(peek(ctx)))
|
||||
{
|
||||
backtrack(ctx);
|
||||
return NULL;
|
||||
}
|
||||
}
|
||||
}
|
||||
while (is_digit(c = peek(ctx))) {
|
||||
n *= 10;
|
||||
n += c - '0';
|
||||
consume1(ctx);
|
||||
}
|
||||
/* if we're looking at a symbol character bail, it's not a number */
|
||||
if (is_sym_char(peek(ctx))) {
|
||||
backtrack(ctx);
|
||||
return NULL;
|
||||
}
|
||||
return VAL(int_from_c(sign * n));
|
||||
while (is_digit(c = peek(ctx)))
|
||||
{
|
||||
n *= 10;
|
||||
n += c - '0';
|
||||
consume1(ctx);
|
||||
}
|
||||
/* if we're looking at a symbol character bail, it's not a number */
|
||||
if (is_sym_char(peek(ctx)))
|
||||
{
|
||||
backtrack(ctx);
|
||||
return NULL;
|
||||
}
|
||||
return VAL(int_from_c(sign * n));
|
||||
}
|
||||
|
||||
static LakeVal *parse_sym(Ctx *ctx)
|
||||
{
|
||||
LakeVal *val;
|
||||
static int size = 1024;
|
||||
char s[size];
|
||||
char c;
|
||||
int i = 0;
|
||||
while (is_sym_char(c = peek(ctx)) && i < size - 1) {
|
||||
s[i++] = c;
|
||||
consume1(ctx);
|
||||
}
|
||||
s[i] = '\0';
|
||||
if (strcmp(s, "#t") == 0) {
|
||||
val = VAL(ctx->lake_ctx->T);
|
||||
}
|
||||
else if (strcmp(s, "#f") == 0) {
|
||||
val = VAL(ctx->lake_ctx->F);
|
||||
}
|
||||
else {
|
||||
val = VAL(sym_intern(ctx->lake_ctx, s));
|
||||
}
|
||||
return val;
|
||||
LakeVal *val;
|
||||
static int size = 1024;
|
||||
char s[size];
|
||||
char c;
|
||||
int i = 0;
|
||||
while (is_sym_char(c = peek(ctx)) && i < size - 1)
|
||||
{
|
||||
s[i++] = c;
|
||||
consume1(ctx);
|
||||
}
|
||||
s[i] = '\0';
|
||||
if (strcmp(s, "#t") == 0)
|
||||
{
|
||||
val = VAL(ctx->lake_ctx->T);
|
||||
}
|
||||
else if (strcmp(s, "#f") == 0)
|
||||
{
|
||||
val = VAL(ctx->lake_ctx->F);
|
||||
}
|
||||
else
|
||||
{
|
||||
val = VAL(sym_intern(ctx->lake_ctx, s));
|
||||
}
|
||||
return val;
|
||||
}
|
||||
|
||||
static char escape_char(char c)
|
||||
{
|
||||
switch (c) {
|
||||
switch (c)
|
||||
{
|
||||
|
||||
case 'n':
|
||||
c = '\n';
|
||||
break;
|
||||
c = '\n';
|
||||
break;
|
||||
|
||||
case 'r':
|
||||
c = '\r';
|
||||
break;
|
||||
c = '\r';
|
||||
break;
|
||||
|
||||
case 't':
|
||||
c = '\t';
|
||||
break;
|
||||
c = '\t';
|
||||
break;
|
||||
|
||||
default:
|
||||
/* noop */
|
||||
break;
|
||||
|
||||
}
|
||||
return c;
|
||||
/* noop */
|
||||
break;
|
||||
}
|
||||
return c;
|
||||
}
|
||||
|
||||
static LakeVal *parse_str(Ctx *ctx)
|
||||
{
|
||||
size_t n = 8;
|
||||
size_t i = 0;
|
||||
char *s = malloc(n);
|
||||
char c;
|
||||
ch(ctx, '"');
|
||||
while ((c = peek(ctx)) != PARSE_EOF && c != '"') {
|
||||
/* handle backslash escapes */
|
||||
if (c == '\\') {
|
||||
consume1(ctx);
|
||||
c = escape_char(peek(ctx));
|
||||
if (c == PARSE_EOF) break;
|
||||
}
|
||||
s[i++] = c;
|
||||
consume1(ctx);
|
||||
size_t n = 8;
|
||||
size_t i = 0;
|
||||
char *s = malloc(n);
|
||||
char c;
|
||||
ch(ctx, '"');
|
||||
while ((c = peek(ctx)) != PARSE_EOF && c != '"')
|
||||
{
|
||||
/* handle backslash escapes */
|
||||
if (c == '\\')
|
||||
{
|
||||
consume1(ctx);
|
||||
c = escape_char(peek(ctx));
|
||||
if (c == PARSE_EOF) break;
|
||||
}
|
||||
s[i++] = c;
|
||||
consume1(ctx);
|
||||
/* grow if necessary */
|
||||
if (i >= n) {
|
||||
n *= 2;
|
||||
if (!(s = realloc(s, n))) OOM();
|
||||
if (i >= n)
|
||||
{
|
||||
n *= 2;
|
||||
if (!(s = realloc(s, n))) OOM();
|
||||
}
|
||||
}
|
||||
}
|
||||
s[i] = '\0';
|
||||
ch(ctx, '"');
|
||||
LakeStr *str = lake_str_from_c(s);
|
||||
free(s);
|
||||
return VAL(str);
|
||||
s[i] = '\0';
|
||||
ch(ctx, '"');
|
||||
LakeStr *str = lake_str_from_c(s);
|
||||
free(s);
|
||||
return VAL(str);
|
||||
}
|
||||
|
||||
static LakeVal* parse_list(Ctx *ctx)
|
||||
static LakeVal *parse_list(Ctx *ctx)
|
||||
{
|
||||
LakeList *list = list_make();
|
||||
ch(ctx, '(');
|
||||
char c;
|
||||
while ((c = peek(ctx)) != ')') {
|
||||
if (c == PARSE_EOF) {
|
||||
ERR("end of input while parsing list");
|
||||
list_free(list);
|
||||
ctx-> i = ctx->n;
|
||||
return NULL;
|
||||
}
|
||||
LakeList *list = list_make();
|
||||
ch(ctx, '(');
|
||||
char c;
|
||||
while ((c = peek(ctx)) != ')')
|
||||
{
|
||||
if (c == PARSE_EOF)
|
||||
{
|
||||
ERR("end of input while parsing list");
|
||||
list_free(list);
|
||||
ctx->i = ctx->n;
|
||||
return NULL;
|
||||
}
|
||||
|
||||
/* check for dotted lists */
|
||||
if (c == '.') {
|
||||
ch(ctx, '.');
|
||||
maybe_spaces(ctx);
|
||||
LakeVal *tail = _parse_expr(ctx);
|
||||
if (tail == VAL(PARSE_ERR)) {
|
||||
list_free(list);
|
||||
ctx->i = ctx->n;
|
||||
return NULL;
|
||||
}
|
||||
ch(ctx, ')');
|
||||
return VAL(dlist_make(list, tail));
|
||||
}
|
||||
/* check for dotted lists */
|
||||
if (c == '.')
|
||||
{
|
||||
ch(ctx, '.');
|
||||
maybe_spaces(ctx);
|
||||
LakeVal *tail = _parse_expr(ctx);
|
||||
if (tail == VAL(PARSE_ERR))
|
||||
{
|
||||
list_free(list);
|
||||
ctx->i = ctx->n;
|
||||
return NULL;
|
||||
}
|
||||
ch(ctx, ')');
|
||||
return VAL(dlist_make(list, tail));
|
||||
}
|
||||
|
||||
LakeVal *val = _parse_expr(ctx);
|
||||
if (val == VAL(PARSE_ERR)) {
|
||||
list_free(list);
|
||||
ctx->i = ctx->n;
|
||||
return NULL;
|
||||
LakeVal *val = _parse_expr(ctx);
|
||||
if (val == VAL(PARSE_ERR))
|
||||
{
|
||||
list_free(list);
|
||||
ctx->i = ctx->n;
|
||||
return NULL;
|
||||
}
|
||||
list_append(list, val);
|
||||
}
|
||||
list_append(list, val);
|
||||
}
|
||||
ch(ctx, ')');
|
||||
return VAL(list);
|
||||
ch(ctx, ')');
|
||||
return VAL(list);
|
||||
}
|
||||
|
||||
static LakeVal *parse_quoted(Ctx *ctx)
|
||||
{
|
||||
ch(ctx, '\'');
|
||||
LakeList *list = list_make();
|
||||
list_append(list, VAL(sym_intern(ctx->lake_ctx, "quote")));
|
||||
list_append(list, _parse_expr(ctx));
|
||||
return VAL(list);
|
||||
ch(ctx, '\'');
|
||||
LakeList *list = list_make();
|
||||
list_append(list, VAL(sym_intern(ctx->lake_ctx, "quote")));
|
||||
list_append(list, _parse_expr(ctx));
|
||||
return VAL(list);
|
||||
}
|
||||
|
||||
static bool is_not_newline(char c)
|
||||
{
|
||||
return !is_newline(c);
|
||||
}
|
||||
static bool is_not_newline(char c) { return !is_newline(c); }
|
||||
|
||||
static LakeVal *parse_comment(Ctx *ctx)
|
||||
{
|
||||
char *text = parse_while(ctx, is_not_newline);
|
||||
LakeComment *comment = comment_from_c(text);
|
||||
free(text);
|
||||
return VAL(comment);
|
||||
char *text = parse_while(ctx, is_not_newline);
|
||||
LakeComment *comment = comment_from_c(text);
|
||||
free(text);
|
||||
return VAL(comment);
|
||||
}
|
||||
|
||||
static LakeVal *_parse_expr(Ctx *ctx)
|
||||
{
|
||||
maybe_spaces(ctx);
|
||||
maybe_spaces(ctx);
|
||||
|
||||
LakeVal *result;
|
||||
char c = peek(ctx);
|
||||
/* try to parse a number, if that fails parse a symbol */
|
||||
if ((c >= '0' && c <= '9') || c == '-' || c == '+') {
|
||||
result = VAL(parse_int(ctx));
|
||||
if (result == NULL) {
|
||||
result = parse_sym(ctx);
|
||||
LakeVal *result;
|
||||
char c = peek(ctx);
|
||||
/* try to parse a number, if that fails parse a symbol */
|
||||
if ((c >= '0' && c <= '9') || c == '-' || c == '+')
|
||||
{
|
||||
result = VAL(parse_int(ctx));
|
||||
if (result == NULL)
|
||||
{
|
||||
result = parse_sym(ctx);
|
||||
}
|
||||
}
|
||||
}
|
||||
else if (is_letter(c) || is_symbol(c)) {
|
||||
result = parse_sym(ctx);
|
||||
}
|
||||
else if (c == '"') {
|
||||
result = parse_str(ctx);
|
||||
}
|
||||
else if (c == '\'') {
|
||||
result = parse_quoted(ctx);
|
||||
}
|
||||
else if (c == '(') {
|
||||
result = parse_list(ctx);
|
||||
}
|
||||
else if (c == ';') {
|
||||
result = parse_comment(ctx);
|
||||
}
|
||||
else if (c == PARSE_EOF) {
|
||||
result = NULL;
|
||||
}
|
||||
else {
|
||||
ERR("unexpected char '%c'", c);
|
||||
result = VAL(PARSE_ERR);
|
||||
ctx->i = ctx->n; /* consume the rest */
|
||||
result = NULL;
|
||||
}
|
||||
maybe_spaces(ctx);
|
||||
else if (is_letter(c) || is_symbol(c))
|
||||
{
|
||||
result = parse_sym(ctx);
|
||||
}
|
||||
else if (c == '"')
|
||||
{
|
||||
result = parse_str(ctx);
|
||||
}
|
||||
else if (c == '\'')
|
||||
{
|
||||
result = parse_quoted(ctx);
|
||||
}
|
||||
else if (c == '(')
|
||||
{
|
||||
result = parse_list(ctx);
|
||||
}
|
||||
else if (c == ';')
|
||||
{
|
||||
result = parse_comment(ctx);
|
||||
}
|
||||
else if (c == PARSE_EOF)
|
||||
{
|
||||
result = NULL;
|
||||
}
|
||||
else
|
||||
{
|
||||
ERR("unexpected char '%c'", c);
|
||||
result = VAL(PARSE_ERR);
|
||||
ctx->i = ctx->n; /* consume the rest */
|
||||
result = NULL;
|
||||
}
|
||||
maybe_spaces(ctx);
|
||||
|
||||
return result;
|
||||
return result;
|
||||
}
|
||||
|
|
|
|||
16
src/parse.h
16
src/parse.h
|
|
@ -1,17 +1,17 @@
|
|||
/**
|
||||
* parse.h
|
||||
* Lake Scheme
|
||||
*
|
||||
* Copyright 2011 Sami Samhuri
|
||||
* MIT License
|
||||
*
|
||||
*/
|
||||
* parse.h
|
||||
* Lake Scheme
|
||||
*
|
||||
* Copyright 2011 Sami Samhuri
|
||||
* MIT License
|
||||
*
|
||||
*/
|
||||
|
||||
#ifndef _LAKE_PARSE_H
|
||||
#define _LAKE_PARSE_H
|
||||
|
||||
#include <stdlib.h>
|
||||
#include "lake.h"
|
||||
#include <stdlib.h>
|
||||
|
||||
#define PARSE_EOF -1
|
||||
#define PARSE_ERR -2
|
||||
|
|
|
|||
501
src/primitive.c
501
src/primitive.c
|
|
@ -1,307 +1,338 @@
|
|||
/**
|
||||
* primitive.c
|
||||
* Lake Scheme
|
||||
*
|
||||
* Copyright 2011 Sami Samhuri
|
||||
* MIT License
|
||||
*
|
||||
*/
|
||||
* primitive.c
|
||||
* Lake Scheme
|
||||
*
|
||||
* Copyright 2011 Sami Samhuri
|
||||
* MIT License
|
||||
*
|
||||
*/
|
||||
|
||||
#include <stdlib.h>
|
||||
#include "primitive.h"
|
||||
#include "bool.h"
|
||||
#include "common.h"
|
||||
#include "comment.h"
|
||||
#include "common.h"
|
||||
#include "dlist.h"
|
||||
#include "env.h"
|
||||
#include "int.h"
|
||||
#include "dlist.h"
|
||||
#include "fn.h"
|
||||
#include "list.h"
|
||||
#include "int.h"
|
||||
#include "lake.h"
|
||||
#include "primitive.h"
|
||||
#include "list.h"
|
||||
#include "str.h"
|
||||
#include <stdlib.h>
|
||||
|
||||
static LakePrimitive *prim_alloc(void)
|
||||
{
|
||||
LakePrimitive *prim = malloc(sizeof(LakePrimitive));
|
||||
VAL(prim)->type = TYPE_PRIM;
|
||||
VAL(prim)->size = sizeof(LakePrimitive);
|
||||
return prim;
|
||||
LakePrimitive *prim = malloc(sizeof(LakePrimitive));
|
||||
VAL(prim)->type = TYPE_PRIM;
|
||||
VAL(prim)->size = sizeof(LakePrimitive);
|
||||
return prim;
|
||||
}
|
||||
|
||||
LakePrimitive *prim_make(char *name, int arity, lake_prim fn)
|
||||
{
|
||||
LakePrimitive *prim = prim_alloc();
|
||||
prim->name = strdup(name);
|
||||
prim->arity = arity;
|
||||
prim->fn = fn;
|
||||
return prim;
|
||||
LakePrimitive *prim = prim_alloc();
|
||||
prim->name = strdup(name);
|
||||
prim->arity = arity;
|
||||
prim->fn = fn;
|
||||
return prim;
|
||||
}
|
||||
|
||||
char *prim_repr(LakePrimitive *prim)
|
||||
{
|
||||
size_t n = 16 + strlen(prim->name) + MAX_INT_LENGTH;
|
||||
char *s = malloc(n);
|
||||
snprintf(s, n, "<#primitive:%s(%d)>", prim->name, prim->arity);
|
||||
return s;
|
||||
size_t n = 16 + strlen(prim->name) + MAX_INT_LENGTH;
|
||||
char *s = malloc(n);
|
||||
snprintf(s, n, "<#primitive:%s(%d)>", prim->name, prim->arity);
|
||||
return s;
|
||||
}
|
||||
|
||||
static LakeVal *_car(LakeCtx *ctx, LakeList *args)
|
||||
{
|
||||
LakeList *list = LIST(LIST_VAL(args, 0));
|
||||
if (lake_is_type(TYPE_LIST, list) && LIST_N(list) > 0) {
|
||||
return LIST_VAL(list, 0);
|
||||
}
|
||||
if (lake_is_type(TYPE_DLIST, list)) {
|
||||
return VAL(dlist_head(DLIST(list)));
|
||||
}
|
||||
ERR("not a pair: %s", lake_repr(list));
|
||||
return NULL;
|
||||
LakeList *list = LIST(LIST_VAL(args, 0));
|
||||
if (lake_is_type(TYPE_LIST, list) && LIST_N(list) > 0)
|
||||
{
|
||||
return LIST_VAL(list, 0);
|
||||
}
|
||||
if (lake_is_type(TYPE_DLIST, list))
|
||||
{
|
||||
return VAL(dlist_head(DLIST(list)));
|
||||
}
|
||||
ERR("not a pair: %s", lake_repr(list));
|
||||
return NULL;
|
||||
}
|
||||
|
||||
static LakeVal *_cdr(LakeCtx *ctx, LakeList *args)
|
||||
{
|
||||
LakeList *list = LIST(LIST_VAL(args, 0));
|
||||
if (lake_is_type(TYPE_LIST, list) && LIST_N(list) > 0) {
|
||||
LakeList *cdr = list_copy(list);
|
||||
list_shift(cdr);
|
||||
return VAL(cdr);
|
||||
}
|
||||
if (lake_is_type(TYPE_DLIST, list)) {
|
||||
return dlist_tail(DLIST(list));
|
||||
}
|
||||
ERR("not a pair: %s", lake_repr(list));
|
||||
return NULL;
|
||||
LakeList *list = LIST(LIST_VAL(args, 0));
|
||||
if (lake_is_type(TYPE_LIST, list) && LIST_N(list) > 0)
|
||||
{
|
||||
LakeList *cdr = list_copy(list);
|
||||
list_shift(cdr);
|
||||
return VAL(cdr);
|
||||
}
|
||||
if (lake_is_type(TYPE_DLIST, list))
|
||||
{
|
||||
return dlist_tail(DLIST(list));
|
||||
}
|
||||
ERR("not a pair: %s", lake_repr(list));
|
||||
return NULL;
|
||||
}
|
||||
|
||||
static LakeVal *_cons(LakeCtx *ctx, LakeList *args)
|
||||
{
|
||||
LakeVal *car = LIST_VAL(args, 0);
|
||||
LakeVal *cdr = LIST_VAL(args, 1);
|
||||
return VAL(list_cons(car, cdr));
|
||||
LakeVal *car = LIST_VAL(args, 0);
|
||||
LakeVal *cdr = LIST_VAL(args, 1);
|
||||
return VAL(list_cons(car, cdr));
|
||||
}
|
||||
|
||||
static LakeVal *_nullP(LakeCtx *ctx, LakeList *args)
|
||||
{
|
||||
LakeVal *val = list_shift(args);
|
||||
LakeBool *is_null = lake_bool_from_int(ctx, lake_is_type(TYPE_LIST, val) && LIST_N(LIST(val)) == 0);
|
||||
return VAL(is_null);
|
||||
LakeVal *val = list_shift(args);
|
||||
LakeBool *is_null = lake_bool_from_int(ctx, lake_is_type(TYPE_LIST, val) &&
|
||||
LIST_N(LIST(val)) == 0);
|
||||
return VAL(is_null);
|
||||
}
|
||||
|
||||
static LakeVal *_pairP(LakeCtx *ctx, LakeList *args)
|
||||
{
|
||||
LakeVal *val = list_shift(args);
|
||||
LakeBool *is_pair = lake_bool_from_int(ctx, lake_is_type(TYPE_LIST, val) && LIST_N(LIST(val)) > 0);
|
||||
return VAL(is_pair);
|
||||
LakeVal *val = list_shift(args);
|
||||
LakeBool *is_pair = lake_bool_from_int(ctx, lake_is_type(TYPE_LIST, val) &&
|
||||
LIST_N(LIST(val)) > 0);
|
||||
return VAL(is_pair);
|
||||
}
|
||||
|
||||
static LakeVal *_isP(LakeCtx *ctx, LakeList *args)
|
||||
{
|
||||
LakeVal *a = LIST_VAL(args, 0);
|
||||
LakeVal *b = LIST_VAL(args, 1);
|
||||
return VAL(lake_bool_from_int(ctx, lake_is(a, b)));
|
||||
LakeVal *a = LIST_VAL(args, 0);
|
||||
LakeVal *b = LIST_VAL(args, 1);
|
||||
return VAL(lake_bool_from_int(ctx, lake_is(a, b)));
|
||||
}
|
||||
|
||||
static LakeVal *_equalP(LakeCtx *ctx, LakeList *args)
|
||||
{
|
||||
LakeVal *a = LIST_VAL(args, 0);
|
||||
LakeVal *b = LIST_VAL(args, 1);
|
||||
return VAL(lake_bool_from_int(ctx, lake_equal(a, b)));
|
||||
LakeVal *a = LIST_VAL(args, 0);
|
||||
LakeVal *b = LIST_VAL(args, 1);
|
||||
return VAL(lake_bool_from_int(ctx, lake_equal(a, b)));
|
||||
}
|
||||
|
||||
static LakeVal *_not(LakeCtx *ctx, LakeList *args)
|
||||
{
|
||||
LakeVal *val = list_shift(args);
|
||||
LakeBool *not = lake_bool_from_int(ctx, lake_is_false(ctx, val));
|
||||
return VAL(not);
|
||||
LakeVal *val = list_shift(args);
|
||||
LakeBool *not = lake_bool_from_int(ctx, lake_is_false(ctx, val));
|
||||
return VAL(not );
|
||||
}
|
||||
|
||||
#define ENSURE_INT(x, i) do { \
|
||||
if (!lake_is_type(TYPE_INT, x)) { \
|
||||
ERR("argument %zu is not an integer: %s", i, lake_repr(x)); \
|
||||
return NULL; \
|
||||
} \
|
||||
} while (0)
|
||||
#define ENSURE_INT(x, i) \
|
||||
do \
|
||||
{ \
|
||||
if (!lake_is_type(TYPE_INT, x)) \
|
||||
{ \
|
||||
ERR("argument %zu is not an integer: %s", i, lake_repr(x)); \
|
||||
return NULL; \
|
||||
} \
|
||||
} while (0)
|
||||
|
||||
static LakeVal *_add(LakeCtx *ctx, LakeList *args)
|
||||
{
|
||||
int result = 0;
|
||||
size_t n = LIST_N(args);
|
||||
size_t i;
|
||||
for (i = 0; i < n; ++i) {
|
||||
LakeVal *v = LIST_VAL(args, i);
|
||||
ENSURE_INT(v, i);
|
||||
result += INT_VAL(INT(v));
|
||||
}
|
||||
return VAL(int_from_c(result));
|
||||
int result = 0;
|
||||
size_t n = LIST_N(args);
|
||||
size_t i;
|
||||
for (i = 0; i < n; ++i)
|
||||
{
|
||||
LakeVal *v = LIST_VAL(args, i);
|
||||
ENSURE_INT(v, i);
|
||||
result += INT_VAL(INT(v));
|
||||
}
|
||||
return VAL(int_from_c(result));
|
||||
}
|
||||
|
||||
static LakeVal *_sub(LakeCtx *ctx, LakeList *args)
|
||||
{
|
||||
size_t n = LIST_N(args);
|
||||
size_t n = LIST_N(args);
|
||||
|
||||
if (n < 1) {
|
||||
ERR("- requires at least one argument");
|
||||
return NULL;
|
||||
}
|
||||
if (n < 1)
|
||||
{
|
||||
ERR("- requires at least one argument");
|
||||
return NULL;
|
||||
}
|
||||
|
||||
int result = 0;
|
||||
size_t i;
|
||||
for (i = 0; i < n; ++i) {
|
||||
LakeVal *v = LIST_VAL(args, i);
|
||||
ENSURE_INT(v, i);
|
||||
result -= INT_VAL(INT(v));
|
||||
}
|
||||
return VAL(int_from_c(result));
|
||||
int result = 0;
|
||||
size_t i;
|
||||
for (i = 0; i < n; ++i)
|
||||
{
|
||||
LakeVal *v = LIST_VAL(args, i);
|
||||
ENSURE_INT(v, i);
|
||||
result -= INT_VAL(INT(v));
|
||||
}
|
||||
return VAL(int_from_c(result));
|
||||
}
|
||||
|
||||
static LakeVal *_mul(LakeCtx *ctx, LakeList *args)
|
||||
{
|
||||
int result = 1;
|
||||
size_t n = LIST_N(args);
|
||||
size_t i;
|
||||
for (i = 0; i < n; ++i) {
|
||||
LakeVal *v = LIST_VAL(args, i);
|
||||
ENSURE_INT(v, i);
|
||||
result *= INT_VAL(INT(v));
|
||||
}
|
||||
return VAL(int_from_c(result));
|
||||
int result = 1;
|
||||
size_t n = LIST_N(args);
|
||||
size_t i;
|
||||
for (i = 0; i < n; ++i)
|
||||
{
|
||||
LakeVal *v = LIST_VAL(args, i);
|
||||
ENSURE_INT(v, i);
|
||||
result *= INT_VAL(INT(v));
|
||||
}
|
||||
return VAL(int_from_c(result));
|
||||
}
|
||||
|
||||
#define DIVIDE_BY_ZERO() ERR("divide by zero")
|
||||
|
||||
static LakeVal *_div(LakeCtx *ctx, LakeList *args)
|
||||
{
|
||||
size_t n = LIST_N(args);
|
||||
size_t n = LIST_N(args);
|
||||
|
||||
if (n < 1) {
|
||||
ERR("/ requires at least one argument");
|
||||
return NULL;
|
||||
}
|
||||
|
||||
LakeVal *v = LIST_VAL(args, 0);
|
||||
ENSURE_INT(v, (size_t)0);
|
||||
int result = INT_VAL(INT(v));
|
||||
|
||||
if (n == 1) {
|
||||
if (result == 0) {
|
||||
DIVIDE_BY_ZERO();
|
||||
return NULL;
|
||||
}
|
||||
result = 1 / result;
|
||||
}
|
||||
else {
|
||||
size_t i;
|
||||
for (i = 1; i < n; ++i) {
|
||||
v = LIST_VAL(args, i);
|
||||
ENSURE_INT(v, i);
|
||||
int val = INT_VAL(INT(v));
|
||||
if (val == 0) {
|
||||
DIVIDE_BY_ZERO();
|
||||
if (n < 1)
|
||||
{
|
||||
ERR("/ requires at least one argument");
|
||||
return NULL;
|
||||
}
|
||||
result /= val;
|
||||
}
|
||||
}
|
||||
return VAL(int_from_c(result));
|
||||
|
||||
LakeVal *v = LIST_VAL(args, 0);
|
||||
ENSURE_INT(v, (size_t)0);
|
||||
int result = INT_VAL(INT(v));
|
||||
|
||||
if (n == 1)
|
||||
{
|
||||
if (result == 0)
|
||||
{
|
||||
DIVIDE_BY_ZERO();
|
||||
return NULL;
|
||||
}
|
||||
result = 1 / result;
|
||||
}
|
||||
else
|
||||
{
|
||||
size_t i;
|
||||
for (i = 1; i < n; ++i)
|
||||
{
|
||||
v = LIST_VAL(args, i);
|
||||
ENSURE_INT(v, i);
|
||||
int val = INT_VAL(INT(v));
|
||||
if (val == 0)
|
||||
{
|
||||
DIVIDE_BY_ZERO();
|
||||
return NULL;
|
||||
}
|
||||
result /= val;
|
||||
}
|
||||
}
|
||||
return VAL(int_from_c(result));
|
||||
}
|
||||
|
||||
static LakeVal *_int_eq(LakeCtx *ctx, LakeList *args)
|
||||
{
|
||||
bool result = TRUE;
|
||||
size_t n = LIST_N(args);
|
||||
size_t i;
|
||||
int curr, prev;
|
||||
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 && curr == prev;
|
||||
bool result = TRUE;
|
||||
size_t n = LIST_N(args);
|
||||
size_t i;
|
||||
int curr, prev;
|
||||
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 && curr == prev;
|
||||
}
|
||||
prev = INT_VAL(INT(v));
|
||||
}
|
||||
prev = INT_VAL(INT(v));
|
||||
}
|
||||
return VAL(lake_bool_from_int(ctx, result));
|
||||
return VAL(lake_bool_from_int(ctx, result));
|
||||
}
|
||||
|
||||
static LakeVal *_int_lt(LakeCtx *ctx, LakeList *args)
|
||||
{
|
||||
bool result = TRUE;
|
||||
size_t n = LIST_N(args);
|
||||
size_t i;
|
||||
int curr, prev;
|
||||
bool 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));
|
||||
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(lake_bool_from_int(ctx, result));
|
||||
return VAL(lake_bool_from_int(ctx, result));
|
||||
}
|
||||
|
||||
static LakeVal *_int_gt(LakeCtx *ctx, LakeList *args)
|
||||
{
|
||||
bool result = TRUE;
|
||||
size_t n = LIST_N(args);
|
||||
size_t i;
|
||||
int curr, prev;
|
||||
bool 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));
|
||||
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(lake_bool_from_int(ctx, result));
|
||||
return VAL(lake_bool_from_int(ctx, result));
|
||||
}
|
||||
|
||||
static LakeVal *_set_carB(LakeCtx *ctx, LakeList *args)
|
||||
{
|
||||
LakeList *list = LIST(LIST_VAL(args, 0));
|
||||
if (lake_is_type(TYPE_LIST, list)) {
|
||||
LakeVal *new_car = LIST_VAL(args, 1);
|
||||
if (LIST_N(list) == 0) {
|
||||
list_append(list, new_car);
|
||||
LakeList *list = LIST(LIST_VAL(args, 0));
|
||||
if (lake_is_type(TYPE_LIST, list))
|
||||
{
|
||||
LakeVal *new_car = LIST_VAL(args, 1);
|
||||
if (LIST_N(list) == 0)
|
||||
{
|
||||
list_append(list, new_car);
|
||||
}
|
||||
else
|
||||
{
|
||||
list_set(list, 0, new_car);
|
||||
}
|
||||
return VAL(list);
|
||||
}
|
||||
else {
|
||||
list_set(list, 0, new_car);
|
||||
}
|
||||
return VAL(list);
|
||||
}
|
||||
ERR("not a pair: %s", lake_repr(list));
|
||||
return NULL;
|
||||
ERR("not a pair: %s", lake_repr(list));
|
||||
return NULL;
|
||||
}
|
||||
|
||||
static LakeVal *_display(LakeCtx *ctx, LakeList *args)
|
||||
{
|
||||
size_t n = LIST_N(args);
|
||||
size_t i;
|
||||
int space = 0;
|
||||
for (i = 0; i < n; ++i) {
|
||||
if (space) putchar(' ');
|
||||
printf("%s", lake_repr(LIST_VAL(args, i)));
|
||||
space = 1;
|
||||
}
|
||||
putchar('\n');
|
||||
return NULL;
|
||||
size_t n = LIST_N(args);
|
||||
size_t i;
|
||||
int space = 0;
|
||||
for (i = 0; i < n; ++i)
|
||||
{
|
||||
if (space) putchar(' ');
|
||||
printf("%s", lake_repr(LIST_VAL(args, i)));
|
||||
space = 1;
|
||||
}
|
||||
putchar('\n');
|
||||
return NULL;
|
||||
}
|
||||
|
||||
#define DEFINE_PREDICATE(name, type) \
|
||||
static LakeVal *_## name ##P(LakeCtx *ctx, LakeList *args) \
|
||||
{ \
|
||||
return VAL(lake_bool_from_int(ctx, lake_is_type(type, LIST_VAL(args, 0)))); \
|
||||
}
|
||||
#define DEFINE_PREDICATE(name, type) \
|
||||
static LakeVal *_##name##P(LakeCtx *ctx, LakeList *args) \
|
||||
{ \
|
||||
return VAL( \
|
||||
lake_bool_from_int(ctx, lake_is_type(type, LIST_VAL(args, 0)))); \
|
||||
}
|
||||
|
||||
DEFINE_PREDICATE(symbol, TYPE_SYM)
|
||||
DEFINE_PREDICATE(list, TYPE_LIST)
|
||||
|
|
@ -317,44 +348,44 @@ DEFINE_PREDICATE(primitive, TYPE_PRIM)
|
|||
|
||||
void bind_primitives(LakeCtx *ctx)
|
||||
{
|
||||
#define DEFINE(name, fn, arity) env_define(ctx->toplevel, \
|
||||
sym_intern(ctx, name), \
|
||||
VAL(prim_make(name, arity, fn)))
|
||||
#define DEFINE(name, fn, arity) \
|
||||
env_define(ctx->toplevel, sym_intern(ctx, name), \
|
||||
VAL(prim_make(name, arity, fn)))
|
||||
|
||||
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);
|
||||
DEFINE("set-car!", _set_carB, 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);
|
||||
DEFINE("set-car!", _set_carB, 2);
|
||||
|
||||
DEFINE("display", _display, ARITY_VARARGS);
|
||||
DEFINE("display", _display, ARITY_VARARGS);
|
||||
|
||||
DEFINE("symbol?", _symbolP, 1);
|
||||
DEFINE("list?", _listP, 1);
|
||||
DEFINE("dotted-list?", _dotted_listP, 1);
|
||||
DEFINE("number?", _numberP, 1);
|
||||
DEFINE("integer?", _integerP, 1);
|
||||
DEFINE("string?", _stringP, 1);
|
||||
DEFINE("bool?", _boolP, 1);
|
||||
DEFINE("function?", _functionP, 1);
|
||||
DEFINE("primitive?", _primitiveP, 1);
|
||||
DEFINE("symbol?", _symbolP, 1);
|
||||
DEFINE("list?", _listP, 1);
|
||||
DEFINE("dotted-list?", _dotted_listP, 1);
|
||||
DEFINE("number?", _numberP, 1);
|
||||
DEFINE("integer?", _integerP, 1);
|
||||
DEFINE("string?", _stringP, 1);
|
||||
DEFINE("bool?", _boolP, 1);
|
||||
DEFINE("function?", _functionP, 1);
|
||||
DEFINE("primitive?", _primitiveP, 1);
|
||||
|
||||
/* string=? */
|
||||
/* string< */
|
||||
/* string> */
|
||||
/* string-concatenate */
|
||||
/* string-slice */
|
||||
/* string=? */
|
||||
/* string< */
|
||||
/* string> */
|
||||
/* string-concatenate */
|
||||
/* string-slice */
|
||||
|
||||
#undef DEFINE
|
||||
#undef DEFINE
|
||||
}
|
||||
|
|
|
|||
|
|
@ -1,11 +1,11 @@
|
|||
/**
|
||||
* primitive.h
|
||||
* Lake Scheme
|
||||
*
|
||||
* Copyright 2011 Sami Samhuri
|
||||
* MIT License
|
||||
*
|
||||
*/
|
||||
* primitive.h
|
||||
* Lake Scheme
|
||||
*
|
||||
* Copyright 2011 Sami Samhuri
|
||||
* MIT License
|
||||
*
|
||||
*/
|
||||
|
||||
#ifndef _LAKE_PRIMITIVE_H
|
||||
#define _LAKE_PRIMITIVE_H
|
||||
|
|
|
|||
261
src/repl.c
261
src/repl.c
|
|
@ -1,19 +1,15 @@
|
|||
/**
|
||||
* repl.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.
|
||||
*
|
||||
*/
|
||||
* repl.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 <errno.h>
|
||||
#include <stdio.h>
|
||||
#include <string.h>
|
||||
#include <sys/select.h>
|
||||
#include "common.h"
|
||||
#include "env.h"
|
||||
#include "eval.h"
|
||||
|
|
@ -21,146 +17,167 @@
|
|||
#include "list.h"
|
||||
#include "parse.h"
|
||||
#include "str.h"
|
||||
#include <errno.h>
|
||||
#include <stdio.h>
|
||||
#include <string.h>
|
||||
#include <sys/select.h>
|
||||
|
||||
void print(LakeVal *expr)
|
||||
{
|
||||
printf("%s\n", lake_repr(expr));
|
||||
}
|
||||
void print(LakeVal *expr) { printf("%s\n", lake_repr(expr)); }
|
||||
|
||||
static char first_char(char *s)
|
||||
{
|
||||
char c;
|
||||
while ((c = *s++) && (c == ' ' || c == '\n' || c == '\t'));
|
||||
return c;
|
||||
char c;
|
||||
while ((c = *s++) && (c == ' ' || c == '\n' || c == '\t'))
|
||||
;
|
||||
return c;
|
||||
}
|
||||
|
||||
static LakeVal *prompt_read(LakeCtx *ctx, Env *env, char *prompt)
|
||||
{
|
||||
static int n = 1024;
|
||||
printf("%s", prompt);
|
||||
char buf[n];
|
||||
if (!fgets(buf, n, stdin)) {
|
||||
if (ferror(stdin)) {
|
||||
fprintf(stderr, "error: cannot read from stdin");
|
||||
static int n = 1024;
|
||||
printf("%s", prompt);
|
||||
char buf[n];
|
||||
if (!fgets(buf, n, stdin))
|
||||
{
|
||||
if (ferror(stdin))
|
||||
{
|
||||
fprintf(stderr, "error: cannot read from stdin");
|
||||
}
|
||||
if (feof(stdin))
|
||||
{
|
||||
return VAL(EOF);
|
||||
}
|
||||
return NULL;
|
||||
}
|
||||
if (feof(stdin)) {
|
||||
return VAL(EOF);
|
||||
/* trim the newline if any */
|
||||
buf[strcspn(buf, "\n")] = '\0';
|
||||
|
||||
/* parse list expressions */
|
||||
if (first_char(buf) == '(')
|
||||
{
|
||||
return parse_expr(ctx, buf, strlen(buf));
|
||||
}
|
||||
return NULL;
|
||||
}
|
||||
/* trim the newline if any */
|
||||
buf[strcspn(buf, "\n")] = '\0';
|
||||
|
||||
/* parse list expressions */
|
||||
if (first_char(buf) == '(') {
|
||||
return parse_expr(ctx, buf, strlen(buf));
|
||||
}
|
||||
|
||||
/* try to parse a naked call without parens
|
||||
(makes the repl more palatable) */
|
||||
/* try to parse a naked call without parens
|
||||
(makes the repl more palatable) */
|
||||
LakeList *list = parse_naked_list(ctx, buf, strlen(buf));
|
||||
if (!list || LIST_N(list) == 0) return NULL;
|
||||
if (!list || LIST_N(list) == 0) return NULL;
|
||||
|
||||
LakeVal *result;
|
||||
LakeVal *result;
|
||||
|
||||
/* naked call */
|
||||
LakeVal *head;
|
||||
if (is_special_form(ctx, list) ||
|
||||
(LIST_N(list) > 1 && (head = eval(ctx, env, LIST_VAL(list, 0))) && CALLABLE(head))) {
|
||||
result = VAL(list);
|
||||
}
|
||||
/* naked call */
|
||||
LakeVal *head;
|
||||
if (is_special_form(ctx, list) ||
|
||||
(LIST_N(list) > 1 && (head = eval(ctx, env, LIST_VAL(list, 0))) &&
|
||||
CALLABLE(head)))
|
||||
{
|
||||
result = VAL(list);
|
||||
}
|
||||
|
||||
/* probably not function calls, just give the first expr
|
||||
(maybe do an implicit progn thing here) */
|
||||
else {
|
||||
result = LIST_VAL(list, 0);
|
||||
}
|
||||
/* probably not function calls, just give the first expr
|
||||
(maybe do an implicit progn thing here) */
|
||||
else
|
||||
{
|
||||
result = LIST_VAL(list, 0);
|
||||
}
|
||||
|
||||
return result;
|
||||
return result;
|
||||
}
|
||||
|
||||
static void run_repl(LakeCtx *ctx, Env *env)
|
||||
{
|
||||
puts("Lake Scheme v" LAKE_VERSION);
|
||||
LakeVal *expr;
|
||||
LakeVal *result;
|
||||
for (;;) {
|
||||
expr = prompt_read(ctx, env, "> ");
|
||||
if (expr == VAL(EOF)) break;
|
||||
if (expr == VAL(PARSE_ERR)) {
|
||||
ERR("parse error");
|
||||
continue;
|
||||
puts("Lake Scheme v" LAKE_VERSION);
|
||||
LakeVal *expr;
|
||||
LakeVal *result;
|
||||
for (;;)
|
||||
{
|
||||
expr = prompt_read(ctx, env, "> ");
|
||||
if (expr == VAL(EOF)) break;
|
||||
if (expr == VAL(PARSE_ERR))
|
||||
{
|
||||
ERR("parse error");
|
||||
continue;
|
||||
}
|
||||
if (expr)
|
||||
{
|
||||
result = eval(ctx, env, expr);
|
||||
if (result) print(result);
|
||||
}
|
||||
}
|
||||
if (expr) {
|
||||
result = eval(ctx, env, expr);
|
||||
if (result) print(result);
|
||||
}
|
||||
}
|
||||
}
|
||||
|
||||
static char *read_file(char const *filename)
|
||||
{
|
||||
FILE *fp = fopen(filename, "r");
|
||||
if (fp) {
|
||||
size_t size = 4096;
|
||||
char buf[size];
|
||||
size_t n = size;
|
||||
size_t i = 0;
|
||||
size_t read;
|
||||
char *s = malloc(n);
|
||||
FILE *fp = fopen(filename, "r");
|
||||
if (fp)
|
||||
{
|
||||
size_t size = 4096;
|
||||
char buf[size];
|
||||
size_t n = size;
|
||||
size_t i = 0;
|
||||
size_t read;
|
||||
char *s = malloc(n);
|
||||
|
||||
while (!feof(fp) && !ferror(fp)) {
|
||||
read = fread(buf, 1, size, fp);
|
||||
if (i + read > n) {
|
||||
n += size;
|
||||
if (!(s = realloc(s, n))) OOM();
|
||||
}
|
||||
memcpy(s + i, buf, read);
|
||||
i += read;
|
||||
}
|
||||
s[i] = '\0';
|
||||
if (ferror(fp)) {
|
||||
ERR("failed to read file %s: %s", filename, strerror(errno));
|
||||
return NULL;
|
||||
}
|
||||
fclose(fp);
|
||||
while (!feof(fp) && !ferror(fp))
|
||||
{
|
||||
read = fread(buf, 1, size, fp);
|
||||
if (i + read > n)
|
||||
{
|
||||
n += size;
|
||||
if (!(s = realloc(s, n))) OOM();
|
||||
}
|
||||
memcpy(s + i, buf, read);
|
||||
i += read;
|
||||
}
|
||||
s[i] = '\0';
|
||||
if (ferror(fp))
|
||||
{
|
||||
ERR("failed to read file %s: %s", filename, strerror(errno));
|
||||
return NULL;
|
||||
}
|
||||
fclose(fp);
|
||||
|
||||
return s;
|
||||
}
|
||||
else {
|
||||
ERR("cannot open file %s: %s", filename, strerror(errno));
|
||||
return NULL;
|
||||
}
|
||||
return s;
|
||||
}
|
||||
else
|
||||
{
|
||||
ERR("cannot open file %s: %s", filename, strerror(errno));
|
||||
return NULL;
|
||||
}
|
||||
}
|
||||
|
||||
int main (int argc, char const *argv[])
|
||||
int main(int argc, char const *argv[])
|
||||
{
|
||||
/* create an execution context */
|
||||
LakeCtx *ctx = lake_init();
|
||||
/* create an execution context */
|
||||
LakeCtx *ctx = lake_init();
|
||||
|
||||
/* create and bind args */
|
||||
LakeVal **argVals = malloc(argc * sizeof(LakeVal *));
|
||||
int i;
|
||||
for (i = 0; i < argc; ++i) {
|
||||
argVals[i] = VAL(lake_str_from_c((char *)argv[i]));
|
||||
}
|
||||
LakeList *args = list_from_array(argc, argVals);
|
||||
free(argVals);
|
||||
env_define(ctx->toplevel, sym_intern(ctx, "args"), VAL(args));
|
||||
|
||||
/* if a filename is given load the file */
|
||||
if (argc > 1) {
|
||||
char *text = read_file(argv[1]);
|
||||
if (text) {
|
||||
LakeList *exprs = parse_exprs(ctx, text, strlen(text));
|
||||
if (exprs) {
|
||||
eval_exprs(ctx, ctx->toplevel, exprs);
|
||||
}
|
||||
/* create and bind args */
|
||||
LakeVal **argVals = malloc(argc * sizeof(LakeVal *));
|
||||
int i;
|
||||
for (i = 0; i < argc; ++i)
|
||||
{
|
||||
argVals[i] = VAL(lake_str_from_c((char *)argv[i]));
|
||||
}
|
||||
}
|
||||
LakeList *args = list_from_array(argc, argVals);
|
||||
free(argVals);
|
||||
env_define(ctx->toplevel, sym_intern(ctx, "args"), VAL(args));
|
||||
|
||||
/* run the repl */
|
||||
run_repl(ctx, ctx->toplevel);
|
||||
/* if a filename is given load the file */
|
||||
if (argc > 1)
|
||||
{
|
||||
char *text = read_file(argv[1]);
|
||||
if (text)
|
||||
{
|
||||
LakeList *exprs = parse_exprs(ctx, text, strlen(text));
|
||||
if (exprs)
|
||||
{
|
||||
eval_exprs(ctx, ctx->toplevel, exprs);
|
||||
}
|
||||
}
|
||||
}
|
||||
|
||||
return 0;
|
||||
/* run the repl */
|
||||
run_repl(ctx, ctx->toplevel);
|
||||
|
||||
return 0;
|
||||
}
|
||||
|
|
|
|||
75
src/str.c
75
src/str.c
|
|
@ -1,77 +1,62 @@
|
|||
/**
|
||||
* str.c
|
||||
* Lake Scheme
|
||||
*
|
||||
* Copyright 2011 Sami Samhuri
|
||||
* MIT License
|
||||
*
|
||||
*/
|
||||
* str.c
|
||||
* Lake Scheme
|
||||
*
|
||||
* Copyright 2011 Sami Samhuri
|
||||
* MIT License
|
||||
*
|
||||
*/
|
||||
|
||||
#include <stdlib.h>
|
||||
#include <string.h>
|
||||
#include "str.h"
|
||||
#include "common.h"
|
||||
#include "int.h"
|
||||
#include "lake.h"
|
||||
#include "str.h"
|
||||
#include <stdlib.h>
|
||||
#include <string.h>
|
||||
|
||||
#define MIN(a, b) ((a) < (b) ? (a) : (b))
|
||||
|
||||
static LakeStr *lake_str_alloc(void)
|
||||
{
|
||||
LakeStr *str = malloc(sizeof(LakeStr));
|
||||
VAL(str)->type = TYPE_STR;
|
||||
VAL(str)->size = sizeof(LakeStr);
|
||||
return str;
|
||||
LakeStr *str = malloc(sizeof(LakeStr));
|
||||
VAL(str)->type = TYPE_STR;
|
||||
VAL(str)->size = sizeof(LakeStr);
|
||||
return str;
|
||||
}
|
||||
|
||||
void lake_str_free(LakeStr *str)
|
||||
{
|
||||
free(STR_S(str));
|
||||
free(str);
|
||||
free(STR_S(str));
|
||||
free(str);
|
||||
}
|
||||
|
||||
static LakeVal *lake_str_set(LakeStr *str, char *s)
|
||||
{
|
||||
STR_N(str) = strlen(s);
|
||||
STR_S(str) = strndup(s, STR_N(str));
|
||||
return NULL;
|
||||
STR_N(str) = strlen(s);
|
||||
STR_S(str) = strndup(s, STR_N(str));
|
||||
return NULL;
|
||||
}
|
||||
|
||||
LakeStr *lake_str_from_c(char *s)
|
||||
{
|
||||
LakeStr *str = lake_str_alloc();
|
||||
lake_str_set(str, s);
|
||||
return str;
|
||||
LakeStr *str = lake_str_alloc();
|
||||
lake_str_set(str, s);
|
||||
return str;
|
||||
}
|
||||
|
||||
LakeStr *lake_str_make(void)
|
||||
{
|
||||
return lake_str_from_c("");
|
||||
}
|
||||
LakeStr *lake_str_make(void) { return lake_str_from_c(""); }
|
||||
|
||||
LakeInt *lake_str_len(LakeStr *str)
|
||||
{
|
||||
return int_from_c(STR_N(str));
|
||||
}
|
||||
LakeInt *lake_str_len(LakeStr *str) { return int_from_c(STR_N(str)); }
|
||||
|
||||
LakeStr *lake_str_copy(LakeStr *str)
|
||||
{
|
||||
return lake_str_from_c(STR_S(str));
|
||||
}
|
||||
LakeStr *lake_str_copy(LakeStr *str) { return lake_str_from_c(STR_S(str)); }
|
||||
|
||||
char *lake_str_val(LakeStr *str)
|
||||
{
|
||||
return strndup(STR_S(str), STR_N(str));
|
||||
}
|
||||
char *lake_str_val(LakeStr *str) { return strndup(STR_S(str), STR_N(str)); }
|
||||
|
||||
bool lake_str_equal(LakeStr *a, LakeStr *b)
|
||||
{
|
||||
if (STR_N(a) != STR_N(b)) return FALSE;
|
||||
size_t n = MIN(STR_N(a), STR_N(b));
|
||||
return strncmp(STR_S(a), STR_S(b), n) == 0;
|
||||
if (STR_N(a) != STR_N(b)) return FALSE;
|
||||
size_t n = MIN(STR_N(a), STR_N(b));
|
||||
return strncmp(STR_S(a), STR_S(b), n) == 0;
|
||||
}
|
||||
|
||||
LakeStr *lake_str_to_str(LakeStr *str)
|
||||
{
|
||||
return lake_str_copy(str);
|
||||
}
|
||||
LakeStr *lake_str_to_str(LakeStr *str) { return lake_str_copy(str); }
|
||||
|
|
|
|||
14
src/str.h
14
src/str.h
|
|
@ -1,11 +1,11 @@
|
|||
/**
|
||||
* str.h
|
||||
* Lake Scheme
|
||||
*
|
||||
* Copyright 2011 Sami Samhuri
|
||||
* MIT License
|
||||
*
|
||||
*/
|
||||
* str.h
|
||||
* Lake Scheme
|
||||
*
|
||||
* Copyright 2011 Sami Samhuri
|
||||
* MIT License
|
||||
*
|
||||
*/
|
||||
|
||||
#ifndef _LAKE_STRING_H
|
||||
#define _LAKE_STRING_H
|
||||
|
|
|
|||
78
src/sym.c
78
src/sym.c
|
|
@ -1,73 +1,65 @@
|
|||
/**
|
||||
* sym.c
|
||||
* Lake Scheme
|
||||
*
|
||||
* Copyright 2011 Sami Samhuri
|
||||
* MIT License
|
||||
*
|
||||
*/
|
||||
* sym.c
|
||||
* Lake Scheme
|
||||
*
|
||||
* Copyright 2011 Sami Samhuri
|
||||
* MIT License
|
||||
*
|
||||
*/
|
||||
|
||||
#include <stdint.h>
|
||||
#include <stdio.h>
|
||||
#include <stdlib.h>
|
||||
#include <string.h>
|
||||
#include "sym.h"
|
||||
#include "common.h"
|
||||
#include "env.h"
|
||||
#include "lake.h"
|
||||
#include "str.h"
|
||||
#include "sym.h"
|
||||
#include <stdint.h>
|
||||
#include <stdio.h>
|
||||
#include <stdlib.h>
|
||||
#include <string.h>
|
||||
|
||||
/* djb's hash
|
||||
* http://www.cse.yorku.ca/~oz/hash.html
|
||||
*/
|
||||
static uint32_t str_hash(const char *s)
|
||||
{
|
||||
char c;
|
||||
uint32_t h = 5381;
|
||||
char c;
|
||||
uint32_t h = 5381;
|
||||
|
||||
while ((c = *s++))
|
||||
h = ((h << 5) + h) ^ c;
|
||||
while ((c = *s++))
|
||||
h = ((h << 5) + h) ^ c;
|
||||
|
||||
return h;
|
||||
return h;
|
||||
}
|
||||
|
||||
static LakeSym *sym_alloc(void)
|
||||
{
|
||||
LakeSym *sym = malloc(sizeof(LakeSym));
|
||||
VAL(sym)->type = TYPE_SYM;
|
||||
VAL(sym)->size = sizeof(LakeSym);
|
||||
return sym;
|
||||
LakeSym *sym = malloc(sizeof(LakeSym));
|
||||
VAL(sym)->type = TYPE_SYM;
|
||||
VAL(sym)->size = sizeof(LakeSym);
|
||||
return sym;
|
||||
}
|
||||
|
||||
LakeSym *sym_intern(LakeCtx *ctx, char *s)
|
||||
{
|
||||
LakeSym *sym = lake_hash_get(ctx->symbols, s);
|
||||
if (!sym) {
|
||||
sym = sym_alloc();
|
||||
sym->n = strlen(s);
|
||||
sym->s = strndup(s, sym->n);
|
||||
sym->hash = str_hash(s);
|
||||
lake_hash_put(ctx->symbols, sym->s, sym);
|
||||
}
|
||||
return sym;
|
||||
LakeSym *sym = lake_hash_get(ctx->symbols, s);
|
||||
if (!sym)
|
||||
{
|
||||
sym = sym_alloc();
|
||||
sym->n = strlen(s);
|
||||
sym->s = strndup(s, sym->n);
|
||||
sym->hash = str_hash(s);
|
||||
lake_hash_put(ctx->symbols, sym->s, sym);
|
||||
}
|
||||
return sym;
|
||||
}
|
||||
|
||||
LakeStr *sym_to_str(LakeSym *sym)
|
||||
{
|
||||
return lake_str_from_c(sym->s);
|
||||
}
|
||||
LakeStr *sym_to_str(LakeSym *sym) { return lake_str_from_c(sym->s); }
|
||||
|
||||
LakeSym *sym_from_str(LakeCtx *ctx, LakeStr *str)
|
||||
{
|
||||
return sym_intern(ctx, str->s);
|
||||
return sym_intern(ctx, str->s);
|
||||
}
|
||||
|
||||
char *sym_repr(LakeSym *sym)
|
||||
{
|
||||
return strndup(sym->s, sym->n);
|
||||
}
|
||||
char *sym_repr(LakeSym *sym) { return strndup(sym->s, sym->n); }
|
||||
|
||||
unsigned long sym_val(LakeSym *sym)
|
||||
{
|
||||
return sym->hash;
|
||||
}
|
||||
unsigned long sym_val(LakeSym *sym) { return sym->hash; }
|
||||
|
|
|
|||
14
src/sym.h
14
src/sym.h
|
|
@ -1,11 +1,11 @@
|
|||
/**
|
||||
* sym.h
|
||||
* Lake Scheme
|
||||
*
|
||||
* Copyright 2011 Sami Samhuri
|
||||
* MIT License
|
||||
*
|
||||
*/
|
||||
* sym.h
|
||||
* Lake Scheme
|
||||
*
|
||||
* Copyright 2011 Sami Samhuri
|
||||
* MIT License
|
||||
*
|
||||
*/
|
||||
|
||||
#ifndef _LAKE_SYM_H
|
||||
#define _LAKE_SYM_H
|
||||
|
|
|
|||
|
|
@ -1,22 +1,22 @@
|
|||
/**
|
||||
* laketest.c
|
||||
* Lake Scheme
|
||||
*
|
||||
* Copyright 2011 Sami Samhuri
|
||||
* MIT License
|
||||
*
|
||||
* Based on MinUnit: http://www.jera.com/techinfo/jtns/jtn002.html
|
||||
*
|
||||
*/
|
||||
* laketest.c
|
||||
* Lake Scheme
|
||||
*
|
||||
* Copyright 2011 Sami Samhuri
|
||||
* MIT License
|
||||
*
|
||||
* Based on MinUnit: http://www.jera.com/techinfo/jtns/jtn002.html
|
||||
*
|
||||
*/
|
||||
|
||||
#include "lake.h"
|
||||
#include "eval.h"
|
||||
#include "laketest.h"
|
||||
#include "parse.h"
|
||||
#include <fcntl.h>
|
||||
#include <stdio.h>
|
||||
#include <string.h>
|
||||
#include <unistd.h>
|
||||
#include "eval.h"
|
||||
#include "lake.h"
|
||||
#include "laketest.h"
|
||||
#include "parse.h"
|
||||
|
||||
static int captured = 0;
|
||||
|
||||
|
|
@ -54,16 +54,19 @@ int lt_run_tests(char *title, test_fn *tests)
|
|||
test_fn test;
|
||||
printf("-- %s --\n", title);
|
||||
capture_output();
|
||||
while ((test = *(tests++))) {
|
||||
while ((test = *(tests++)))
|
||||
{
|
||||
if ((message = test())) break;
|
||||
n_tests++;
|
||||
}
|
||||
restore_output();
|
||||
pass = message == 0;
|
||||
if (pass) {
|
||||
if (pass)
|
||||
{
|
||||
fprintf(stderr, "PASS: %d test%s\n", n_tests, n_tests == 1 ? "" : "s");
|
||||
}
|
||||
else {
|
||||
else
|
||||
{
|
||||
fprintf(stderr, "FAIL: %s\n", message);
|
||||
}
|
||||
return pass;
|
||||
|
|
|
|||
|
|
@ -1,26 +1,29 @@
|
|||
/**
|
||||
* laketest.h
|
||||
* Lake Scheme
|
||||
*
|
||||
* Copyright 2011 Sami Samhuri
|
||||
* MIT License
|
||||
*
|
||||
* Based on MinUnit: http://www.jera.com/techinfo/jtns/jtn002.html
|
||||
*
|
||||
*/
|
||||
* laketest.h
|
||||
* Lake Scheme
|
||||
*
|
||||
* Copyright 2011 Sami Samhuri
|
||||
* MIT License
|
||||
*
|
||||
* Based on MinUnit: http://www.jera.com/techinfo/jtns/jtn002.html
|
||||
*
|
||||
*/
|
||||
|
||||
#include <stdio.h>
|
||||
#include "lake.h"
|
||||
#include <stdio.h>
|
||||
|
||||
void restore_output(void);
|
||||
|
||||
#define lt_assert(message, test) do { \
|
||||
if (!(test)) { \
|
||||
restore_output(); \
|
||||
fprintf(stderr, "%s:%d assertion failed: " #test "\n", \
|
||||
__FILE__, __LINE__); \
|
||||
return message; \
|
||||
} \
|
||||
#define lt_assert(message, test) \
|
||||
do \
|
||||
{ \
|
||||
if (!(test)) \
|
||||
{ \
|
||||
restore_output(); \
|
||||
fprintf(stderr, "%s:%d assertion failed: " #test "\n", __FILE__, \
|
||||
__LINE__); \
|
||||
return message; \
|
||||
} \
|
||||
} while (0)
|
||||
|
||||
typedef char *(*test_fn)(void);
|
||||
|
|
|
|||
|
|
@ -1,17 +1,17 @@
|
|||
/**
|
||||
* test_comment.c
|
||||
* Lake Scheme
|
||||
*
|
||||
* Copyright 2011 Sami Samhuri
|
||||
* MIT License
|
||||
*
|
||||
*/
|
||||
* test_comment.c
|
||||
* Lake Scheme
|
||||
*
|
||||
* Copyright 2011 Sami Samhuri
|
||||
* MIT License
|
||||
*
|
||||
*/
|
||||
|
||||
#include <string.h>
|
||||
#include "laketest.h"
|
||||
#include "comment.h"
|
||||
#include "lake.h"
|
||||
#include "laketest.h"
|
||||
#include "str.h"
|
||||
#include <string.h>
|
||||
|
||||
#define TEXT "you are not expected to understand this"
|
||||
|
||||
|
|
@ -26,27 +26,22 @@ static LakeStr *text = NULL;
|
|||
int main(int argc, char const *argv[])
|
||||
{
|
||||
setup();
|
||||
return !lt_run_tests("Comments", (test_fn[]){
|
||||
test_comment_make,
|
||||
test_comment_from_c,
|
||||
test_comment_repr,
|
||||
test_comment_equal,
|
||||
NULL
|
||||
});
|
||||
return !lt_run_tests(
|
||||
"Comments", (test_fn[]){test_comment_make, test_comment_from_c,
|
||||
test_comment_repr, test_comment_equal, NULL});
|
||||
}
|
||||
|
||||
void setup(void)
|
||||
{
|
||||
text = lake_str_from_c(TEXT);
|
||||
}
|
||||
void setup(void) { text = lake_str_from_c(TEXT); }
|
||||
|
||||
/* LakeComment *comment_make(LakeStr *text) */
|
||||
static char *test_comment_make(void)
|
||||
{
|
||||
LakeComment *comment = comment_make(text);
|
||||
lt_assert("type is not TYPE_COMM", lake_is_type(TYPE_COMM, comment));
|
||||
lt_assert("value size is incorrect", lake_val_size(comment) == sizeof(LakeComment));
|
||||
lt_assert("comment text is incorrect", lake_str_equal(text, COMM_TEXT(comment)));
|
||||
lt_assert("value size is incorrect",
|
||||
lake_val_size(comment) == sizeof(LakeComment));
|
||||
lt_assert("comment text is incorrect",
|
||||
lake_str_equal(text, COMM_TEXT(comment)));
|
||||
return 0;
|
||||
}
|
||||
|
||||
|
|
@ -55,8 +50,10 @@ static char *test_comment_from_c(void)
|
|||
{
|
||||
LakeComment *comment = comment_from_c(TEXT);
|
||||
lt_assert("type is not TYPE_COMM", lake_is_type(TYPE_COMM, comment));
|
||||
lt_assert("value size is incorrect", lake_val_size(comment) == sizeof(LakeComment));
|
||||
lt_assert("comment text is incorrect", lake_str_equal(text, COMM_TEXT(comment)));
|
||||
lt_assert("value size is incorrect",
|
||||
lake_val_size(comment) == sizeof(LakeComment));
|
||||
lt_assert("comment text is incorrect",
|
||||
lake_str_equal(text, COMM_TEXT(comment)));
|
||||
return 0;
|
||||
}
|
||||
|
||||
|
|
@ -64,7 +61,8 @@ static char *test_comment_from_c(void)
|
|||
static char *test_comment_repr(void)
|
||||
{
|
||||
LakeComment *comment = comment_make(text);
|
||||
lt_assert("comment_repr is incorrect", strncmp(comment_repr(comment), TEXT, strlen(TEXT)) == 0);
|
||||
lt_assert("comment_repr is incorrect",
|
||||
strncmp(comment_repr(comment), TEXT, strlen(TEXT)) == 0);
|
||||
return 0;
|
||||
}
|
||||
|
||||
|
|
@ -73,7 +71,8 @@ static char *test_comment_equal(void)
|
|||
{
|
||||
LakeComment *a = comment_make(text);
|
||||
LakeComment *b = comment_from_c(TEXT);
|
||||
LakeComment *c = comment_from_c("and now for something completely different");
|
||||
LakeComment *c =
|
||||
comment_from_c("and now for something completely different");
|
||||
lt_assert("comment a != a", comment_equal(a, a));
|
||||
lt_assert("comment a != b", comment_equal(a, b));
|
||||
lt_assert("comment a == c", !comment_equal(a, c));
|
||||
|
|
|
|||
|
|
@ -1,17 +1,17 @@
|
|||
/**
|
||||
* test_dlist.c
|
||||
* Lake Scheme
|
||||
*
|
||||
* Copyright 2011 Sami Samhuri
|
||||
* MIT License
|
||||
*
|
||||
*/
|
||||
* test_dlist.c
|
||||
* Lake Scheme
|
||||
*
|
||||
* Copyright 2011 Sami Samhuri
|
||||
* MIT License
|
||||
*
|
||||
*/
|
||||
|
||||
#include <string.h>
|
||||
#include "common.h"
|
||||
#include "laketest.h"
|
||||
#include "lake.h"
|
||||
#include "laketest.h"
|
||||
#include "list.h"
|
||||
#include <string.h>
|
||||
|
||||
void setup(void);
|
||||
static char *test_dlist_make(void);
|
||||
|
|
@ -26,12 +26,9 @@ static char *REPR = "(() . ())";
|
|||
int main(int argc, char const *argv[])
|
||||
{
|
||||
setup();
|
||||
return !lt_run_tests("Dotted Lists", (test_fn[]){
|
||||
test_dlist_make,
|
||||
test_dlist_repr,
|
||||
test_dlist_equal,
|
||||
NULL
|
||||
});
|
||||
return !lt_run_tests(
|
||||
"Dotted Lists",
|
||||
(test_fn[]){test_dlist_make, test_dlist_repr, test_dlist_equal, NULL});
|
||||
}
|
||||
|
||||
void setup(void)
|
||||
|
|
@ -45,7 +42,8 @@ void setup(void)
|
|||
static char *test_dlist_make(void)
|
||||
{
|
||||
lt_assert("type is not TYPE_DLIST", lake_is_type(TYPE_DLIST, dlist));
|
||||
lt_assert("value size is incorrect", lake_val_size(dlist) == sizeof(LakeDottedList));
|
||||
lt_assert("value size is incorrect",
|
||||
lake_val_size(dlist) == sizeof(LakeDottedList));
|
||||
lt_assert("head value is incorrect",
|
||||
lake_equal(VAL(head), VAL(dlist_head(dlist))));
|
||||
lt_assert("tail value is incorrect", lake_equal(tail, dlist_tail(dlist)));
|
||||
|
|
@ -55,7 +53,8 @@ static char *test_dlist_make(void)
|
|||
/* char *dlist_repr(LakeDottedList *dlist) */
|
||||
static char *test_dlist_repr(void)
|
||||
{
|
||||
lt_assert("dlist_repr is incorrect", strncmp(dlist_repr(dlist), REPR, strlen(REPR)) == 0);
|
||||
lt_assert("dlist_repr is incorrect",
|
||||
strncmp(dlist_repr(dlist), REPR, strlen(REPR)) == 0);
|
||||
|
||||
char *REPR2 = "(spam eggs bacon spam eggs . spam)";
|
||||
LakeCtx *lake = lake_init();
|
||||
|
|
|
|||
|
|
@ -1,16 +1,16 @@
|
|||
/**
|
||||
* test_env.c
|
||||
* Lake Scheme
|
||||
*
|
||||
* Copyright 2011 Sami Samhuri
|
||||
* MIT License
|
||||
*
|
||||
*/
|
||||
* test_env.c
|
||||
* Lake Scheme
|
||||
*
|
||||
* Copyright 2011 Sami Samhuri
|
||||
* MIT License
|
||||
*
|
||||
*/
|
||||
|
||||
#include "common.h"
|
||||
#include "laketest.h"
|
||||
#include "env.h"
|
||||
#include "lake.h"
|
||||
#include "laketest.h"
|
||||
|
||||
void setup(void);
|
||||
static char *test_env_make(void);
|
||||
|
|
@ -31,14 +31,9 @@ static LakeSym *s_undef;
|
|||
int main(int argc, char const *argv[])
|
||||
{
|
||||
setup();
|
||||
return !lt_run_tests("Environment", (test_fn[]){
|
||||
test_env_make,
|
||||
test_env_define,
|
||||
test_env_set,
|
||||
test_env_get,
|
||||
test_env_is_defined,
|
||||
NULL
|
||||
});
|
||||
return !lt_run_tests(
|
||||
"Environment", (test_fn[]){test_env_make, test_env_define, test_env_set,
|
||||
test_env_get, test_env_is_defined, NULL});
|
||||
}
|
||||
|
||||
void setup(void)
|
||||
|
|
@ -59,7 +54,8 @@ static char *test_env_make(void)
|
|||
lt_assert("toplevel->bindings is NULL", toplevel->bindings != NULL);
|
||||
|
||||
lt_assert("firstlevel is NULL", firstlevel != NULL);
|
||||
lt_assert("firstlevel->parent is not toplevel", firstlevel->parent == toplevel);
|
||||
lt_assert("firstlevel->parent is not toplevel",
|
||||
firstlevel->parent == toplevel);
|
||||
|
||||
return 0;
|
||||
}
|
||||
|
|
|
|||
|
|
@ -1,16 +1,16 @@
|
|||
/**
|
||||
* test_eval.c
|
||||
* Lake Scheme
|
||||
*
|
||||
* Copyright 2011 Sami Samhuri
|
||||
* MIT License
|
||||
*
|
||||
*/
|
||||
* test_eval.c
|
||||
* Lake Scheme
|
||||
*
|
||||
* Copyright 2011 Sami Samhuri
|
||||
* MIT License
|
||||
*
|
||||
*/
|
||||
|
||||
#include "laketest.h"
|
||||
#include "env.h"
|
||||
#include "eval.h"
|
||||
#include "lake.h"
|
||||
#include "laketest.h"
|
||||
#include "parse.h"
|
||||
|
||||
void setup(void);
|
||||
|
|
@ -31,13 +31,9 @@ static LakePrimitive *p_cdr;
|
|||
int main(int argc, char const *argv[])
|
||||
{
|
||||
setup();
|
||||
return !lt_run_tests("Eval & Apply", (test_fn[]){
|
||||
test_eval,
|
||||
test_eval_exprs,
|
||||
test_eval_exprs1,
|
||||
test_apply,
|
||||
NULL
|
||||
});
|
||||
return !lt_run_tests("Eval & Apply",
|
||||
(test_fn[]){test_eval, test_eval_exprs,
|
||||
test_eval_exprs1, test_apply, NULL});
|
||||
}
|
||||
|
||||
void setup(void)
|
||||
|
|
@ -125,10 +121,12 @@ static char *test_eval(void)
|
|||
LakeSym *l_bound_sym = isP;
|
||||
LakeSym *l_unbound_sym = sym_intern(lake, "sex");
|
||||
lt_assert("bound symbol is? evaluated to null", NULL != EVAL(l_bound_sym));
|
||||
lt_assert("unbound symbol evaluated to non-null", NULL == EVAL(l_unbound_sym));
|
||||
lt_assert("unbound symbol evaluated to non-null",
|
||||
NULL == EVAL(l_unbound_sym));
|
||||
|
||||
LakeList *l_call = list_make();
|
||||
lt_assert("empty list (nil) did not self evaluate", VAL(l_call) == EVAL(l_call));
|
||||
lt_assert("empty list (nil) did not self evaluate",
|
||||
VAL(l_call) == EVAL(l_call));
|
||||
|
||||
LakeDottedList *l_dlist = dlist_make(list_make(), VAL(l_int));
|
||||
lt_assert("dotted-list evaluated to non-null", NULL == EVAL(l_dlist));
|
||||
|
|
@ -137,7 +135,8 @@ static char *test_eval(void)
|
|||
LakeSym *s_x = sym_intern(lake, "x");
|
||||
list_append(l_call, VAL(s_x));
|
||||
list_append(l_call, VAL(l_int));
|
||||
lt_assert("define special form evaluated to non-null", NULL == EVAL(l_call));
|
||||
lt_assert("define special form evaluated to non-null",
|
||||
NULL == EVAL(l_call));
|
||||
lt_assert("define bound an incorrect value", VAL(l_int) == EVAL(s_x));
|
||||
list_free(l_call);
|
||||
|
||||
|
|
@ -145,7 +144,8 @@ static char *test_eval(void)
|
|||
list_append(l_call, VAL(isP));
|
||||
list_append(l_call, VAL(s_x));
|
||||
list_append(l_call, VAL(l_int));
|
||||
lt_assert("primitive evaluated incorrectly", lake_is_true(lake, EVAL(l_call)));
|
||||
lt_assert("primitive evaluated incorrectly",
|
||||
lake_is_true(lake, EVAL(l_call)));
|
||||
list_free(l_call);
|
||||
|
||||
return 0;
|
||||
|
|
@ -175,7 +175,6 @@ static char *test_apply(void)
|
|||
NULL == apply(lake, fnVal, args));
|
||||
list_free(args);
|
||||
|
||||
|
||||
/* var args primitive */
|
||||
fnVal = EVAL(sym_intern(lake, "+"));
|
||||
args = list_make();
|
||||
|
|
@ -192,7 +191,6 @@ static char *test_apply(void)
|
|||
6 == INT_VAL(INT(apply(lake, fnVal, args))));
|
||||
list_free(args);
|
||||
|
||||
|
||||
/* set up a scheme function with fixed args */
|
||||
eval(lake, lake->toplevel,
|
||||
parse_expr(lake, "(define zero? (lambda (x) (= x 0)))", 35));
|
||||
|
|
@ -212,7 +210,6 @@ static char *test_apply(void)
|
|||
lt_assert("function applied incorrectly", NULL == apply(lake, fnVal, args));
|
||||
list_free(args);
|
||||
|
||||
|
||||
/* set up a scheme function with only var args */
|
||||
eval(lake, lake->toplevel,
|
||||
parse_expr(lake, "(define list (lambda rest rest))", 32));
|
||||
|
|
@ -234,7 +231,6 @@ static char *test_apply(void)
|
|||
NULL != apply(lake, fnVal, args));
|
||||
list_free(args);
|
||||
|
||||
|
||||
/* set up a scheme function with fixed and var args */
|
||||
eval(lake, lake->toplevel,
|
||||
parse_expr(lake, "(define frob (lambda (a b . rest) b))", 37));
|
||||
|
|
@ -262,7 +258,6 @@ static char *test_apply(void)
|
|||
NULL != apply(lake, fnVal, args));
|
||||
list_free(args);
|
||||
|
||||
|
||||
/* non-function in head position */
|
||||
lt_assert("apply with non-function returned non-null",
|
||||
NULL == apply(lake, VAL(sym), list_make()));
|
||||
|
|
|
|||
|
|
@ -1,32 +1,30 @@
|
|||
/**
|
||||
* test_fn.c
|
||||
* Lake Scheme
|
||||
*
|
||||
* Copyright 2011 Sami Samhuri
|
||||
* MIT License
|
||||
*
|
||||
*/
|
||||
* test_fn.c
|
||||
* Lake Scheme
|
||||
*
|
||||
* Copyright 2011 Sami Samhuri
|
||||
* MIT License
|
||||
*
|
||||
*/
|
||||
|
||||
#include <string.h>
|
||||
#include "laketest.h"
|
||||
#include "env.h"
|
||||
#include "eval.h"
|
||||
#include "lake.h"
|
||||
#include "laketest.h"
|
||||
#include "parse.h"
|
||||
#include <string.h>
|
||||
|
||||
static char *test_fn_make(void);
|
||||
static char *test_fn_repr(void);
|
||||
|
||||
int main(int argc, char const *argv[])
|
||||
{
|
||||
return !lt_run_tests("Functions", (test_fn[]){
|
||||
test_fn_make,
|
||||
test_fn_repr,
|
||||
NULL
|
||||
});
|
||||
return !lt_run_tests("Functions",
|
||||
(test_fn[]){test_fn_make, test_fn_repr, NULL});
|
||||
}
|
||||
|
||||
/* LakeFn *fn_make(LakeList *params, LakeSym *varargs, LakeList *body, Env *closure) */
|
||||
/* LakeFn *fn_make(LakeList *params, LakeSym *varargs, LakeList *body, Env
|
||||
* *closure) */
|
||||
static char *test_fn_make(void)
|
||||
{
|
||||
LakeList *params = list_make();
|
||||
|
|
|
|||
|
|
@ -1,16 +1,16 @@
|
|||
/**
|
||||
* test_int.c
|
||||
* Lake Scheme
|
||||
*
|
||||
* Copyright 2011 Sami Samhuri
|
||||
* MIT License
|
||||
*
|
||||
*/
|
||||
* test_int.c
|
||||
* Lake Scheme
|
||||
*
|
||||
* Copyright 2011 Sami Samhuri
|
||||
* MIT License
|
||||
*
|
||||
*/
|
||||
|
||||
#include <string.h>
|
||||
#include "int.h"
|
||||
#include "laketest.h"
|
||||
#include "lake.h"
|
||||
#include "laketest.h"
|
||||
#include <string.h>
|
||||
|
||||
static char *test_int_make(void);
|
||||
static char *test_int_from_c(void);
|
||||
|
|
@ -18,12 +18,8 @@ static char *test_int_repr(void);
|
|||
|
||||
int main(int argc, char const *argv[])
|
||||
{
|
||||
return !lt_run_tests("Integers", (test_fn[]){
|
||||
test_int_make,
|
||||
test_int_from_c,
|
||||
test_int_repr,
|
||||
NULL
|
||||
});
|
||||
return !lt_run_tests("Integers", (test_fn[]){test_int_make, test_int_from_c,
|
||||
test_int_repr, NULL});
|
||||
}
|
||||
|
||||
/* LakeInt *int_make(void) */
|
||||
|
|
|
|||
|
|
@ -1,21 +1,21 @@
|
|||
/**
|
||||
* test_lake.c
|
||||
* Lake Scheme
|
||||
*
|
||||
* Copyright 2011 Sami Samhuri
|
||||
* MIT License
|
||||
*
|
||||
*/
|
||||
* test_lake.c
|
||||
* Lake Scheme
|
||||
*
|
||||
* Copyright 2011 Sami Samhuri
|
||||
* MIT License
|
||||
*
|
||||
*/
|
||||
|
||||
#include <string.h>
|
||||
#include "laketest.h"
|
||||
#include "bool.h"
|
||||
#include "eval.h"
|
||||
#include "int.h"
|
||||
#include "lake.h"
|
||||
#include "laketest.h"
|
||||
#include "parse.h"
|
||||
#include "str.h"
|
||||
#include "sym.h"
|
||||
#include "eval.h"
|
||||
#include "parse.h"
|
||||
#include <string.h>
|
||||
|
||||
void setup(void);
|
||||
static char *test_lake_version(void);
|
||||
|
|
@ -29,20 +29,12 @@ static LakeCtx *lake;
|
|||
int main(int argc, char const *argv[])
|
||||
{
|
||||
setup();
|
||||
return !lt_run_tests("Lake", (test_fn[]){
|
||||
test_lake_version,
|
||||
test_lake_init,
|
||||
test_lake_is,
|
||||
test_lake_equal,
|
||||
test_lake_repr,
|
||||
NULL
|
||||
});
|
||||
return !lt_run_tests("Lake", (test_fn[]){test_lake_version, test_lake_init,
|
||||
test_lake_is, test_lake_equal,
|
||||
test_lake_repr, NULL});
|
||||
}
|
||||
|
||||
void setup(void)
|
||||
{
|
||||
lake = lake_init();
|
||||
}
|
||||
void setup(void) { lake = lake_init(); }
|
||||
|
||||
/* #define LAKE_VERSION "0.1" */
|
||||
static char *test_lake_version(void)
|
||||
|
|
@ -68,10 +60,7 @@ static char *test_lake_init(void)
|
|||
return 0;
|
||||
}
|
||||
|
||||
static bool _is(void *a, void *b)
|
||||
{
|
||||
return lake_is(VAL(a), VAL(b));
|
||||
}
|
||||
static bool _is(void *a, void *b) { return lake_is(VAL(a), VAL(b)); }
|
||||
|
||||
/* bool lake_is(LakeVal *a, LakeVal *b) */
|
||||
static char *test_lake_is(void)
|
||||
|
|
@ -79,7 +68,8 @@ static char *test_lake_is(void)
|
|||
LakeInt *i = int_from_c(42);
|
||||
|
||||
// ints are compared by value
|
||||
lt_assert("ints with equal values are not the same", _is(i, int_from_c(42)));
|
||||
lt_assert("ints with equal values are not the same",
|
||||
_is(i, int_from_c(42)));
|
||||
|
||||
// nil is compared by value
|
||||
lt_assert("null values are not the same", _is(list_make(), list_make()));
|
||||
|
|
@ -95,10 +85,7 @@ static char *test_lake_is(void)
|
|||
return 0;
|
||||
}
|
||||
|
||||
static bool _equal(void *a, void *b)
|
||||
{
|
||||
return lake_equal(VAL(a), VAL(b));
|
||||
}
|
||||
static bool _equal(void *a, void *b) { return lake_equal(VAL(a), VAL(b)); }
|
||||
|
||||
/* bool lake_equal(LakeVal *a, LakeVal *b) */
|
||||
static char *test_lake_equal(void)
|
||||
|
|
@ -128,7 +115,8 @@ static char *test_lake_equal(void)
|
|||
LakePrimitive *pair = PRIM(lt_eval(lake, "pair?"));
|
||||
lt_assert("primitive is not equal to itself", _equal(null, null));
|
||||
lt_assert("primitive is not equal to itself", _equal(null, null2));
|
||||
lt_assert("different primitives are equal to each other", !_equal(null, pair));
|
||||
lt_assert("different primitives are equal to each other",
|
||||
!_equal(null, pair));
|
||||
|
||||
// functions are compared by reference
|
||||
LakeFn *inc = FN(lt_eval(lake, "(lambda (x) (+ x 1))"));
|
||||
|
|
@ -147,8 +135,8 @@ static char *test_lake_equal(void)
|
|||
lt_assert("string is not equal to itself", _equal(arthur, arthur2));
|
||||
lt_assert("different strings are equal", !_equal(arthur, zaphod));
|
||||
|
||||
// lists are compared by value
|
||||
#define S(s) VAL(lake_str_from_c(s))
|
||||
// lists are compared by value
|
||||
#define S(s) VAL(lake_str_from_c(s))
|
||||
LakeList *fruits = list_make();
|
||||
list_append(fruits, S("mango"));
|
||||
list_append(fruits, S("pear"));
|
||||
|
|
@ -164,8 +152,9 @@ static char *test_lake_equal(void)
|
|||
lt_assert("different lists are equal", !_equal(fruits, ninjas));
|
||||
|
||||
LakeList *fruits_copy = list_copy(fruits);
|
||||
lt_assert("copy of list is not equal to original", _equal(fruits, fruits_copy));
|
||||
#undef S
|
||||
lt_assert("copy of list is not equal to original",
|
||||
_equal(fruits, fruits_copy));
|
||||
#undef S
|
||||
|
||||
// dotted lists are compared by value
|
||||
LakeDottedList *destruction = dlist_make(fruits, VAL(ninjas));
|
||||
|
|
@ -208,7 +197,8 @@ static char *test_lake_repr(void)
|
|||
list_append(vals, VAL(vals));
|
||||
list_append(vals, VAL(dlist_make(vals, VAL(int_from_c(4919)))));
|
||||
list_append(vals, eval(lake, lake->toplevel, parse_expr(lake, "null?", 5)));
|
||||
list_append(vals, eval(lake, lake->toplevel, parse_expr(lake, "(lambda xs xs)", 14)));
|
||||
list_append(vals, eval(lake, lake->toplevel,
|
||||
parse_expr(lake, "(lambda xs xs)", 14)));
|
||||
list_append(vals, VAL(comment_from_c("this is a comment")));
|
||||
|
||||
return 0;
|
||||
|
|
|
|||
118
test/test_list.c
118
test/test_list.c
|
|
@ -1,16 +1,16 @@
|
|||
/**
|
||||
* test_lake.c
|
||||
* Lake Scheme
|
||||
*
|
||||
* Copyright 2011 Sami Samhuri
|
||||
* MIT License
|
||||
*
|
||||
*/
|
||||
* test_lake.c
|
||||
* Lake Scheme
|
||||
*
|
||||
* Copyright 2011 Sami Samhuri
|
||||
* MIT License
|
||||
*
|
||||
*/
|
||||
|
||||
#include <string.h>
|
||||
#include "laketest.h"
|
||||
#include "lake.h"
|
||||
#include "laketest.h"
|
||||
#include "list.h"
|
||||
#include <string.h>
|
||||
|
||||
void setup(void);
|
||||
static char *test_list_make(void);
|
||||
|
|
@ -32,24 +32,13 @@ static char *test_list_repr(void);
|
|||
int main(int argc, char const *argv[])
|
||||
{
|
||||
setup();
|
||||
return !lt_run_tests("List", (test_fn[]){
|
||||
test_list_make,
|
||||
test_list_cons,
|
||||
test_list_make_with_capacity,
|
||||
test_list_from_array,
|
||||
test_list_copy,
|
||||
test_list_set,
|
||||
test_list_append,
|
||||
test_list_get,
|
||||
test_list_len,
|
||||
test_list_pop,
|
||||
test_list_shift,
|
||||
test_list_unshift,
|
||||
test_list_equal,
|
||||
test_list_to_str,
|
||||
test_list_repr,
|
||||
NULL
|
||||
});
|
||||
return !lt_run_tests(
|
||||
"List", (test_fn[]){test_list_make, test_list_cons,
|
||||
test_list_make_with_capacity, test_list_from_array,
|
||||
test_list_copy, test_list_set, test_list_append,
|
||||
test_list_get, test_list_len, test_list_pop,
|
||||
test_list_shift, test_list_unshift, test_list_equal,
|
||||
test_list_to_str, test_list_repr, NULL});
|
||||
}
|
||||
|
||||
void setup(void)
|
||||
|
|
@ -58,91 +47,46 @@ void setup(void)
|
|||
}
|
||||
|
||||
/* LakeList *list_make(void) */
|
||||
static char *test_list_make(void)
|
||||
{
|
||||
return 0;
|
||||
}
|
||||
static char *test_list_make(void) { return 0; }
|
||||
|
||||
/* LakeList *list_cons(LakeVal *car, LakeVal *cdr) */
|
||||
static char *test_list_cons(void)
|
||||
{
|
||||
return 0;
|
||||
}
|
||||
static char *test_list_cons(void) { return 0; }
|
||||
|
||||
/* LakeList *list_make_with_capacity(size_t cap) */
|
||||
static char *test_list_make_with_capacity(void)
|
||||
{
|
||||
return 0;
|
||||
}
|
||||
static char *test_list_make_with_capacity(void) { return 0; }
|
||||
|
||||
/* LakeList *list_from_array(size_t n, LakeVal *vals[]) */
|
||||
static char *test_list_from_array(void)
|
||||
{
|
||||
return 0;
|
||||
}
|
||||
static char *test_list_from_array(void) { return 0; }
|
||||
|
||||
/* LakeList *list_copy(LakeList *list) */
|
||||
static char *test_list_copy(void)
|
||||
{
|
||||
return 0;
|
||||
}
|
||||
static char *test_list_copy(void) { return 0; }
|
||||
|
||||
/* LakeVal *list_set(LakeList *list, size_t i, LakeVal *val) */
|
||||
static char *test_list_set(void)
|
||||
{
|
||||
return 0;
|
||||
}
|
||||
static char *test_list_set(void) { return 0; }
|
||||
|
||||
/* LakeVal *list_append(LakeList *list, LakeVal *val) */
|
||||
static char *test_list_append(void)
|
||||
{
|
||||
return 0;
|
||||
}
|
||||
static char *test_list_append(void) { return 0; }
|
||||
|
||||
/* LakeVal *list_get(LakeList *list, LakeInt *li) */
|
||||
static char *test_list_get(void)
|
||||
{
|
||||
return 0;
|
||||
}
|
||||
static char *test_list_get(void) { return 0; }
|
||||
|
||||
/* LakeInt *list_len(LakeList *list) */
|
||||
static char *test_list_len(void)
|
||||
{
|
||||
return 0;
|
||||
}
|
||||
static char *test_list_len(void) { return 0; }
|
||||
|
||||
/* LakeVal *list_pop(LakeList *list) */
|
||||
static char *test_list_pop(void)
|
||||
{
|
||||
return 0;
|
||||
}
|
||||
static char *test_list_pop(void) { return 0; }
|
||||
|
||||
/* LakeVal *list_shift(LakeList *list) */
|
||||
static char *test_list_shift(void)
|
||||
{
|
||||
return 0;
|
||||
}
|
||||
static char *test_list_shift(void) { return 0; }
|
||||
|
||||
/* LakeVal *list_unshift(LakeList *list, LakeVal *val) */
|
||||
static char *test_list_unshift(void)
|
||||
{
|
||||
return 0;
|
||||
}
|
||||
static char *test_list_unshift(void) { return 0; }
|
||||
|
||||
/* int list_equal(LakeList *a, LakeList *b) */
|
||||
static char *test_list_equal(void)
|
||||
{
|
||||
return 0;
|
||||
}
|
||||
static char *test_list_equal(void) { return 0; }
|
||||
|
||||
/* LakeStr *list_to_str(LakeList *list) */
|
||||
static char *test_list_to_str(void)
|
||||
{
|
||||
return 0;
|
||||
}
|
||||
static char *test_list_to_str(void) { return 0; }
|
||||
|
||||
/* char *list_repr(LakeList *list) */
|
||||
static char *test_list_repr(void)
|
||||
{
|
||||
return 0;
|
||||
}
|
||||
static char *test_list_repr(void) { return 0; }
|
||||
|
|
|
|||
|
|
@ -1,19 +1,19 @@
|
|||
#include "laketest.h"
|
||||
|
||||
/**
|
||||
* parse.h
|
||||
* Lake Scheme
|
||||
*
|
||||
* Copyright 2011 Sami Samhuri
|
||||
* MIT License
|
||||
*
|
||||
*/
|
||||
* parse.h
|
||||
* Lake Scheme
|
||||
*
|
||||
* Copyright 2011 Sami Samhuri
|
||||
* MIT License
|
||||
*
|
||||
*/
|
||||
|
||||
#ifndef _LAKE_PARSE_H
|
||||
#define _LAKE_PARSE_H
|
||||
|
||||
#include <stdlib.h>
|
||||
#include "lake.h"
|
||||
#include <stdlib.h>
|
||||
|
||||
#define PARSE_EOF -1
|
||||
#define PARSE_ERR -2
|
||||
|
|
|
|||
|
|
@ -1,13 +1,13 @@
|
|||
#include "laketest.h"
|
||||
|
||||
/**
|
||||
* primitive.h
|
||||
* Lake Scheme
|
||||
*
|
||||
* Copyright 2011 Sami Samhuri
|
||||
* MIT License
|
||||
*
|
||||
*/
|
||||
* primitive.h
|
||||
* Lake Scheme
|
||||
*
|
||||
* Copyright 2011 Sami Samhuri
|
||||
* MIT License
|
||||
*
|
||||
*/
|
||||
|
||||
#ifndef _LAKE_PRIMITIVE_H
|
||||
#define _LAKE_PRIMITIVE_H
|
||||
|
|
|
|||
|
|
@ -1,15 +1,15 @@
|
|||
/**
|
||||
* test_str.c
|
||||
* Lake Scheme
|
||||
*
|
||||
* Copyright 2011 Sami Samhuri
|
||||
* MIT License
|
||||
*
|
||||
*/
|
||||
* test_str.c
|
||||
* Lake Scheme
|
||||
*
|
||||
* Copyright 2011 Sami Samhuri
|
||||
* MIT License
|
||||
*
|
||||
*/
|
||||
|
||||
#include "common.h"
|
||||
#include "laketest.h"
|
||||
#include "lake.h"
|
||||
#include "laketest.h"
|
||||
|
||||
/* LakeStr *lake_str_make(void) */
|
||||
/* void lake_str_free(LakeStr *str) */
|
||||
|
|
|
|||
|
|
@ -1,13 +1,13 @@
|
|||
#include "laketest.h"
|
||||
|
||||
/**
|
||||
* sym.h
|
||||
* Lake Scheme
|
||||
*
|
||||
* Copyright 2011 Sami Samhuri
|
||||
* MIT License
|
||||
*
|
||||
*/
|
||||
* sym.h
|
||||
* Lake Scheme
|
||||
*
|
||||
* Copyright 2011 Sami Samhuri
|
||||
* MIT License
|
||||
*
|
||||
*/
|
||||
|
||||
#ifndef _LAKE_SYM_H
|
||||
#define _LAKE_SYM_H
|
||||
|
|
|
|||
Loading…
Reference in a new issue