added standard library and example programs

8 files changed, 404 insertions, 23 deletions

diff --git a/Makefile b/Makefile
index 1f685e6..ba62bae 100644
--- a/Makefile
+++ b/Makefile
@@ -3,7 +3,7 @@ CC = gcc
 CFLAGS = -g -std=c89 -Wall
 LDFLAGS = 
 
-SRCS = $(wildcard *.c)
+SRCS = lith.c main.c
 OBJS = $(SRCS:.c=.o)
 
 $(BIN): $(OBJS)
diff --git a/factorial.lith b/factorial.lith
new file mode 100644
index 0000000..2349fb7
--- /dev/null
+++ b/factorial.lith
@@ -0,0 +1,13 @@
+;;;; factorial.lith
+;;;; the factorial program written in lith
+
+(define (! n)
+    (if (< n 2)
+        1
+        (* n (! (- n 1)))))
+
+(define (fac n)
+    (apply * (range 1 n)))
+
+(print (! 5) (! 6))
+(print (fac 10))
diff --git a/fizzbuzz.lith b/fizzbuzz.lith
new file mode 100644
index 0000000..1dac1f6
--- /dev/null
+++ b/fizzbuzz.lith
@@ -0,0 +1,12 @@
+;;;; fizzbuzz program written in lith
+
+(define 1to100 (range 1 100))
+
+(define (to-fizz-buzz n)
+    (cond
+        ((divides n 15) "FizzBuzz")
+        ((divides n 3) "Fizz")
+        ((divides n 5) "Buzz")
+        (else n)))
+
+(for-each print (map to-fizz-buzz 1to100))
diff --git a/hello.lith b/hello.lith
new file mode 100644
index 0000000..c6355be
--- /dev/null
+++ b/hello.lith
@@ -0,0 +1,4 @@
+;;;; hello.lith
+;;;; the "Hello, world!" program written in lith
+
+(print "Hello, world!")
diff --git a/lib.lith b/lib.lith
new file mode 100644
index 0000000..3a66062
--- /dev/null
+++ b/lib.lith
@@ -0,0 +1,174 @@
+;;;; lib.lith
+;;;; the standard library of lith
+
+(define (list . args) args)
+(define (caar x) (car (car x)))
+(define (cadr x) (car (cdr x)))
+(define (cdar x) (cdr (car x)))
+(define (cddr x) (cdr (cdr x)))
+
+(define (not x) (if x #f #t))
+
+(define (pair? p)
+    (eq? (typeof p) 'pair))
+(define (integer? i)
+    (eq? (typeof i) 'integer))
+(define (number? n)
+    (eq? (typeof n) 'number))
+
+(define (foldl f init lst)
+    (if (nil? lst)
+        init
+        (foldl f (f init (car lst)) (cdr lst))))
+
+(define (map f lst)
+    (if (nil? lst)
+        ()
+        (cons (f (car lst)) (map f (cdr lst)))))
+
+(define (foldr f init lst)
+    (if (nil? lst)
+        init
+        (f (car lst) (foldr f init (cdr lst)))))
+
+(define (last lst)
+    (if (nil? lst)
+        ()
+        (if (nil? (cdr lst))
+            (car lst)
+            (last (cdr lst)))))
+
+(define (begin . body) (last body))
+
+(define (reverse lst)
+    (foldl (lambda (a x) (cons x a)) () lst))
+
+(define (append a b)
+    (foldr cons b a))
+
+(define-macro (quasiquote x)
+    (if (pair? x)
+        (if (eq? (car x) 'unquote)
+            (cadr x)
+            (if (if (pair? (car x)) (eq? (caar x) 'unquote-splicing) #f)
+                (list 'append
+                    (cadr (car x))
+                    (list 'quasiquote (cdr x)))
+                (list 'cons
+                    (list 'quasiquote (car x))
+                    (list 'quasiquote (cdr x)))))
+        (list 'quote x)))
+
+(define (flip f)
+    (lambda (a b)
+        (f b a)))
+
+(define-macro (and . x)
+    (if (nil? x)
+        #t
+        `(if ,(car x) (and . ,(cdr x)) #f)))
+
+(define-macro (or . x)
+    (if (nil? x)
+        #f
+        `(if ,(car x) #t (or . ,(cdr x)))))
+
+(define-macro (let env . body)
+    `((lambda ,(map car env) . ,body) . ,(map cadr env)))
+
+(define (numeric? x)
+    (or (integer? x) (number? x)))
+
+(define (+ . n)
+    (foldl :+ 0 n))
+(define (* . n)
+    (foldl :* 1 n))
+
+(define (- . n)
+    (if (nil? n)
+        0
+        (foldl :- (car n) (cdr n))))
+
+(define (/ . n)
+    (if (nil? n)
+        1
+        (foldl :/ (car n) (cdr n))))
+
+(define infty (:/ 1.0 0.0))
+(define -infty (:/ -1.0 0.0))
+
+(define (:<= a b) (not (:> a b)))
+(define (:>= a b) (not (:< a b)))
+
+(define (< a b . c)
+    (if (nil? c)
+        (:< a b)
+        (and (:< a b) (apply < (cons b c)))))
+(define (> a b . c)
+    (if (nil? c)
+        (:> a b)
+        (and (:> a b) (apply > (cons b c)))))
+(define (= a b . c)
+    (if (nil? c)
+        (:== a b)
+        (and (:== a b) (apply = (cons b c)))))
+(define (<= a b . c)
+    (if (nil? c)
+        (:<= a b)
+        (and (:<= a b) (apply <= (cons b c)))))
+(define (>= a b . c)
+    (if (nil? c)
+        (:>= a b)
+        (and (:>= a b) (apply >= (cons b c)))))
+
+(define (!= a b)
+    (not (:== a b)))
+
+(define (mod a b) (:% a b))
+
+(define-macro (cond . body)
+    (if (nil? body)
+        (error "cond: no else clause")
+        (if (not (pair? (car body)))
+            (error "cond: expecting a list as clause")
+            (if (eq? (caar body) 'else)
+                `(begin . ,(cdar body))
+                `(if ,(caar body)
+                    (begin . ,(cdar body))
+                    (cond . ,(cdr body)))))))
+
+(define (sign x)
+    (cond
+        ((not (numeric? x)) (error "sign: input must be numeric"))
+        ((< x 0) -1)
+        ((> x 0) 1)
+        (else 0)))
+
+(define (filter f lst)
+    (if (nil? lst)
+        ()
+        (let ((rest (filter f (cdr lst)))
+              (cur (car lst)))
+            (if (f cur)
+                (cons cur rest)
+                rest))))
+
+(define (abs x)
+    (if (< x 0) (- x) x))
+(define (divides a b)
+    (= (mod a b) 0))
+
+(define (1+ x) (+ x 1))
+(define (1- x) (- x 1))
+
+(define (range a b)
+    (if (> a b)
+        ()
+        (cons a (range (1+ a) b))))
+
+(define (o f g) (lambda (x) (f (g x))))
+
+(define (for-each f lst)
+    (if (nil? lst)
+        ()
+        (begin (f (car lst)) (for-each f (cdr lst)))))
diff --git a/lith.c b/lith.c
index 71539c3..d53812d 100644
--- a/lith.c
+++ b/lith.c
@@ -102,8 +102,10 @@ static void lex(lith_st *L, char *input, char **start, char **end)
 {
     if (!(input = skip(L, input))) { *start = *end = NULL; return; }
     *start = input;
-    if (strchr("()'", *input)) {
+    if (strchr("()'@`", *input)) {
         *end = input + 1;
+    } else if (*input == ',') {
+        *end = input + ((input[1] == '@') ? 2 : 1);
     } else if (*input == '"') {
         /* skip the string starting " character */
         eat_string(L, *start + 1, end);
@@ -222,7 +224,7 @@ static lith_value *read_list_expr(lith_st *L, char *start, char **end)
 static lith_value *read_expr(lith_st *L, char *start, char **end)
 {
     lith_value *p, *q, *v;
-    char *t;
+    char *t, *s;
     lex(L, start, &t, end);
     if (LITH_IS_ERR(L)) return NULL;
     if (*t == '(') {
@@ -231,9 +233,18 @@ static lith_value *read_expr(lith_st *L, char *start, char **end)
         L->error = LITH_ERR_SYNTAX;
         L->error_state.msg = "unbalanced parenthesis, expected an expression";
         return NULL;
-    } else if (*t == '\'') {
-        p = LITH_CONS(L, lith_get_symbol(L, "quote"), L->nil);
-        v = read_expr(L, t + 1, end);
+    } else if ((*t == '\'') || (*t == '@') || (*t == ',') || (*t == '`')) {
+        s = ((*t == '\'')
+            ? "quote"
+            : (((*t == '@') || (*t == '`'))
+                ? "quasiquote"
+                : ((*t == ',')
+                    ? ((t[1] == '@')
+                        ? "unquote-splicing"
+                        : "unquote")
+                    : "???" )));
+        p = LITH_CONS(L, lith_get_symbol(L, s), L->nil);
+        v = read_expr(L, *end, end);
         if (!v) { lith_free_value(p); return NULL; }
         q = LITH_CONS(L, v, L->nil);
         if (!q) { lith_free_value(v); lith_free_value(p); return NULL; }
@@ -465,6 +476,55 @@ static lith_value *builtin__nil(lith_st *L, lith_value *args)
     return LITH_IN_BOOL(LITH_IS_NIL(LITH_CAR(args)));
 }
 
+static lith_value *builtin__apply(lith_st *L, lith_value *args)
+{
+    lith_value *f, *aargs, *cargs;
+    if (!lith_expect_nargs(L, "apply", 2, args, 1)) return NULL;
+    f = LITH_CAR(args);
+    aargs = LITH_CAR(LITH_CDR(args));
+    cargs = lith_copy_value(L, aargs);
+    if (!cargs) return NULL;
+    return lith_apply(L, f, cargs);
+}
+
+static lith_value *builtin__error(lith_st *L, lith_value *args)
+{
+    lith_value *arg;
+    if (!lith_expect_nargs(L, "error", 1, args, 1)) return NULL;
+    arg = LITH_CAR(args);
+    if (!lith_expect_type(L, "error", 1, LITH_TYPE_STRING, arg)) return NULL;
+    L->error = LITH_ERR_CUSTOM;
+    L->error_state.msg = arg->value.string.buf;
+    return NULL;
+}
+
+char *slurp(lith_st *L, char *filename)
+{
+    FILE *file;
+    char *buffer;
+    long length;
+    
+    file = fopen(filename, "r");
+    if (!file) {
+        L->error = LITH_ERR_CUSTOM;
+        L->error_state.msg = "could not open the file to be read";
+        return NULL;
+    }
+    
+    fseek(file, 0, SEEK_END);
+    length = ftell(file);
+    fseek(file, 0, SEEK_SET);
+    
+    buffer = emalloc(L, length + 1);
+    if (!buffer) return NULL;
+    
+    fread(buffer, 1, length, file);
+    buffer[length] = '\0';
+    fclose(file);
+    
+    return buffer;
+}
+
 static void init_types(char **types)
 {
     types[LITH_TYPE_NIL] = "nil";
@@ -486,7 +546,7 @@ void lith_init(lith_st *L)
     L->error = LITH_ERR_OK;
     L->error_state.manual = 0;
     L->error_state.success = 1;
-    L->error_state.sym = L->error_state.msg = L->error_state.name = NULL;
+    L->error_state.sym = L->error_state.msg = L->error_state.name = L->error_state.expr = NULL;
     L->nil = lith_new_value(L);
     L->nil->type = LITH_TYPE_NIL;
     L->True = lith_new_value(L);
@@ -513,11 +573,23 @@ void lith_free(lith_st *L)
         free(v);
         p = LITH_CDR(p);
     }
+    if (L->error_state.expr)
+        free(L->error_state.expr);
     free(L->False);
     free(L->True);
     free(L->nil);
 }
 
+void lith_clear_error_state(lith_st *L)
+{
+    L->error = LITH_ERR_OK;
+    L->error_state.success = 1;
+    L->error_state.manual = 0;
+    L->error_state.msg = L->error_state.sym = L->error_state.name = NULL;
+    if (L->error_state.expr)
+        free(L->error_state.expr);
+}
+
 lith_value *lith_new_value(lith_st *L)
 {
     return emalloc(L, sizeof(lith_value));
@@ -611,7 +683,7 @@ void lith_free_value(lith_value *val)
     if (LITH_IS(val, LITH_TYPE_PAIR)) {
         lith_free_value(LITH_CAR(val));
         lith_free_value(LITH_CDR(val));
-    } else if (LITH_IS(val, LITH_TYPE_CLOSURE) || LITH_IS(val, LITH_TYPE_CLOSURE)) {
+    } else if (LITH_IS(val, LITH_TYPE_CLOSURE) || LITH_IS(val, LITH_TYPE_MACRO)) {
         lith_free_value(LITH_CDR(val));
     } else if (LITH_IS(val, LITH_TYPE_STRING)) {
         free(val->value.string.buf);
@@ -751,8 +823,15 @@ void lith_print_error(lith_st *L, int full)
         if (E.manual) fprintf(stderr, "%s", E.msg);
         else fprintf(stderr, "expecting %s instead of %s as the argument number %zu", L->types[E.type.expected], L->types[E.type.got], E.type.narg);
         break;
+    case LITH_ERR_CUSTOM:
+        fprintf(stderr, "error: %s", E.msg);
+        break;
     }
     if (E.name) fprintf(stderr, " [in '%s']", E.name);
+    if (E.expr) {
+        fprintf(stderr, "\noccured in: ");
+        lith_print_value(E.expr);
+    }
     fputc('\n', stderr);
 }
 
@@ -829,6 +908,8 @@ void lith_fill_env(lith_st *L)
     LITH_FN_REGISTER(L, V, "eq?", builtin__eq);
     LITH_FN_REGISTER(L, V, "typeof", builtin__typeof);
     LITH_FN_REGISTER(L, V, "nil?", builtin__nil);
+    LITH_FN_REGISTER(L, V, "apply", builtin__apply);
+    LITH_FN_REGISTER(L, V, "error", builtin__error);
     #undef LITH_FN_REGISTER
 }
 
@@ -844,6 +925,7 @@ int lith_expect_nargs(lith_st *L, char *name, size_t expect, lith_value *args, i
         E->nargs.expected = expect;
         E->nargs.exact = exact;
         E->nargs.got = len;
+        E->expr = lith_copy_value(L, args);
         return 0;
     } else {
         return 1;
@@ -861,6 +943,7 @@ int lith_expect_type(lith_st *L, char *name, size_t narg, lith_valtype type, lit
     E->type.expected = type;
     E->type.got = val->type;
     E->type.narg = narg;
+    E->expr = lith_copy_value(L, val);
     return 0;
 }
 
@@ -879,7 +962,7 @@ lith_value *lith_eval_expr(lith_st *L, lith_env *V, lith_value *expr)
     f = LITH_CAR(expr);
     rest = LITH_CDR(expr);
     if (LITH_IS(f, LITH_TYPE_SYMBOL)) {
-       if (LITH_SYM_EQ(f, "quote")) {
+        if (LITH_SYM_EQ(f, "quote")) {
             if (!lith_expect_nargs(L, "quote", 1, rest, 1))
                 return NULL;
             return lith_copy_value(L, LITH_CAR(rest));
@@ -995,7 +1078,7 @@ lith_value *lith_apply(lith_st *L, lith_value *f, lith_value *args)
     } else if (!LITH_IS(f, LITH_TYPE_CLOSURE) && !LITH_IS(f, LITH_TYPE_MACRO)) {
         L->error = LITH_ERR_TYPE;
         L->error_state.manual = 1;
-        L->error_state.msg = "can not call  non-callable";
+        L->error_state.msg = "can not call non-callable";
         L->error_state.name = "{apply}";
         return NULL;
     }
@@ -1051,4 +1134,42 @@ void lith_run_string(lith_st *L, lith_env *V, char *input)
         }
     }
     lith_print_error(L, 1);
+    if (LITH_AT_END_NO_ERR(L))
+        lith_clear_error_state(L);
+}
+
+void lith_run_file(lith_st *L, lith_env *V, char *filename)
+{
+    char *contents, *end;
+    lith_value *expr, *result;
+    L->filename = filename;
+    contents = slurp(L, filename);
+    if (!contents) {
+        lith_print_error(L, 1);
+        return;
+    }
+    end = contents;
+    while (!LITH_IS_ERR(L)) {
+        if ((expr = lith_read_expr(L, end, &end))) {
+            if ((result = lith_eval_expr(L, V, expr))) {
+                lith_free_value(result);
+            } else {
+                break;
+            }
+            lith_free_value(expr);
+        }
+    }
+    free(contents);
+    if (LITH_AT_END_NO_ERR(L)) {
+        lith_clear_error_state(L);
+        return;
+    }
+    
+    lith_print_error(L, 1);
+    if (expr) {
+        printf("error occurred when evaluating the expression:\n\t");
+        lith_print_value(expr);
+        putchar('\n');
+        lith_free_value(expr);
+    }
 }
diff --git a/lith.h b/lith.h
index dd46619..69af6c3 100644
--- a/lith.h
+++ b/lith.h
@@ -4,6 +4,8 @@
 
 #include <stddef.h>
 
+#define LITH_VERSION_STRING "0.1.0"
+
 typedef struct lith_value lith_value;
 typedef struct lith_value lith_env;
 typedef struct lith_state lith_st;
@@ -17,7 +19,8 @@ enum lith_error {
     LITH_ERR_NOMEM,
     LITH_ERR_UNBOUND,
     LITH_ERR_NARGS,
-    LITH_ERR_TYPE
+    LITH_ERR_TYPE,
+    LITH_ERR_CUSTOM
 };
 
 enum lith_value_type {
@@ -65,6 +68,7 @@ struct lith_state {
     struct lith_error_state {
         int success, manual;
         char *msg, *sym, *name;
+        lith_value *expr;
         struct lith_error_state__argsize { size_t expected, got; int exact; } nargs;
         struct lith_error_state__type { lith_valtype expected, got; size_t narg; } type;
     } error_state;
@@ -77,6 +81,8 @@ struct lith_state {
 };
 
 #define LITH_IS_ERR(L) ((L)->error != LITH_ERR_OK)
+#define LITH_AT_END_NO_ERR(L) (((L)->error == LITH_ERR_EOF) && (L)->error_state.success)
+
 #define LITH_TO_BOOL(B) ((!LITH_IS_NIL(B)) && !(LITH_IS(B, LITH_TYPE_BOOLEAN) && !((B)->value.boolean)))
 #define LITH_IN_BOOL(B) ((B) ? L->True : L->False)
 
@@ -87,7 +93,7 @@ struct lith_state {
 
 void lith_init(lith_st *);
 void lith_free(lith_st *);
-
+void lith_clear_error_state(lith_st *);
 void lith_print_error(lith_st *, int);
 
 lith_value *lith_new_value(lith_st *);
@@ -123,5 +129,6 @@ int lith_expect_type(lith_st *, char *, size_t, lith_valtype, lith_value *);
 int lith_expect_nargs(lith_st *, char *, size_t, lith_value *, int);
 
 void lith_run_string(lith_st *, lith_env *, char *);
+void lith_run_file(lith_st *, lith_env *, char *);
 
 #endif
diff --git a/main.c b/main.c
index c2a2ebd..cc6b58c 100644
--- a/main.c
+++ b/main.c
@@ -4,26 +4,76 @@
 
 #include <stdio.h>
 #include <stdlib.h>
+#include <string.h>
+
+static void show_version(void)
+{
+    fprintf(stderr, "lith version %s: a small lisp-like language interpreter\n", LITH_VERSION_STRING);
+}
+
+static void show_help(char *progname)
+{
+    show_version();
+    fprintf(stderr, "usage: %s [OPTIONS] [FILES] ...\n", progname);
+    fprintf(stderr,
+        "Available options: \n\n"
+        "    -e <expr>\n"
+        "    --evaluate <expr>\n"
+        "            evaluate the <expr>\n\n"
+        "    -h, --help\n"
+        "            show this help\n\n"
+        "    -v, --version\n"
+        "            show version\n\n"
+        "");
+}
+
+static void illegal_option(char *progname, char *opt)
+{
+    fprintf(stderr, "lith: invalid option '%s': try '%s --help' to know the available options\n", opt, progname);
+}
 
 int main(int argc, char **argv)
 {
+    int ret;
     lith_st T, *L;
-    lith_env *V;
-    
-    if (argc < 2) return 32;
+    lith_env *V, *W;
+    char **arg;
     
+    if (argc < 2) return 8;
+    ret = 0;
     L = &T;
-    
     lith_init(L);
-    V = lith_new_env(L, L->global);
-    
-    lith_run_string(L, V, argv[1]);
+    W = lith_new_env(L, L->global);
+    lith_run_file(L, W, "lib.lith");
+    if (LITH_IS_ERR(L)) ret |= 16; 
     
-    printf("environment: "); lith_print_value(V); putchar('\n');
-    printf("symbol table: "); lith_print_value(L->symbol_table); putchar('\n');
+    for (arg = argv+1; arg < argv+argc; arg++) {
+        if ((*arg)[0] != '-') {
+            V = lith_new_env(L, W);
+            lith_run_file(L, V, *arg);
+            lith_free_env(V);
+            if (LITH_IS_ERR(L)) ret |= 64;
+            lith_clear_error_state(L);
+        } else if (!strcmp(*arg, "-e") || !strcmp(*arg, "--evaluate")) {
+            V = lith_new_env(L, W);
+            lith_run_string(L, V, *++arg);
+            lith_free_env(V);
+            if (LITH_IS_ERR(L)) ret |= 32;
+            lith_clear_error_state(L);
+        } else if (!strcmp(*arg, "-h") || !strcmp(*arg, "--help")) {
+            show_help(argv[0]);
+            break;
+        } else if (!strcmp(*arg, "-v") || !strcmp(*arg, "--version")) {
+            show_version();
+            break;
+        } else {
+            illegal_option(argv[0], *arg);
+            break;
+        }
+    }
     
-    lith_free_env(V);
+    lith_free_env(W);
     lith_free(L);
     
-    return 0;
+    return ret;
 }