From c8d8d9015ff56c538986b24fc58af2aa42c0a5f7 Mon Sep 17 00:00:00 2001 From: Sudipto Mallick Date: Tue, 21 Apr 2020 17:18:21 +0000 Subject: added standard library and example programs --- Makefile | 2 +- factorial.lith | 13 +++++ fizzbuzz.lith | 12 ++++ hello.lith | 4 ++ lib.lith | 174 +++++++++++++++++++++++++++++++++++++++++++++++++++++++++ lith.c | 139 ++++++++++++++++++++++++++++++++++++++++++--- lith.h | 11 +++- main.c | 72 ++++++++++++++++++++---- 8 files changed, 404 insertions(+), 23 deletions(-) create mode 100644 factorial.lith create mode 100644 fizzbuzz.lith create mode 100644 hello.lith create mode 100644 lib.lith 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 +#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 #include +#include + +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 \n" + " --evaluate \n" + " evaluate the \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; } -- cgit 1.4.1-2-gfad0