diff options
| -rw-r--r-- | lib.lith | 9 | ||||
| -rw-r--r-- | lith.c | 422 | ||||
| -rw-r--r-- | lith.h | 53 | ||||
| -rw-r--r-- | main.c | 25 |
4 files changed, 321 insertions, 188 deletions
diff --git a/lib.lith b/lib.lith index 3a66062..4cd5591 100644 --- a/lib.lith +++ b/lib.lith @@ -15,6 +15,10 @@ (eq? (typeof i) 'integer)) (define (number? n) (eq? (typeof n) 'number)) +(define (boolean? n) + (eq? (typeof n) 'boolean)) +(define (string? s) + (eq? (typeof s) 'string)) (define (foldl f init lst) (if (nil? lst) @@ -38,8 +42,6 @@ (car lst) (last (cdr lst))))) -(define (begin . body) (last body)) - (define (reverse lst) (foldl (lambda (a x) (cons x a)) () lst)) @@ -126,6 +128,9 @@ (define (mod a b) (:% a b)) +(define-macro (begin a . body) + `((lambda () ,a . ,body))) + (define-macro (cond . body) (if (nil? body) (error "cond: no else clause") diff --git a/lith.c b/lith.c index 2e9b472..7eefa37 100644 --- a/lith.c +++ b/lith.c @@ -26,29 +26,29 @@ static char *lith__strndup(lith_st *L, char *str, size_t len) return newstr; } -static void print_string(lith_string string) +static void print_string(lith_string string, FILE *file) { size_t i; char *s; s = string.buf; - putchar('"'); + fputc('"', file); for (i = 0; i < string.len; s++, i++) { if ((*s == '\\') || (*s == '"')) { - putchar('\\'); - putchar(*s); + fputc('\\', file); + fputc(*s, file); } else if (*s == '\n') { - printf("\\n"); + fprintf(file, "\\n"); } else if (*s == '\t') { - printf("\\t"); + fprintf(file, "\\t"); } else if (*s == '\0') { - printf("\\0"); + fprintf(file, "\\0"); } else if ((*s < 32) || (*s > 126)) { - printf("\\x%02X", (unsigned char)(*s)); + fprintf(file, "\\x%02X", (unsigned char)(*s)); } else { - putchar(*s); + fputc(*s, file); } } - putchar('"'); + fputc('"', file); } static char *skip(lith_st *L, char *input) @@ -70,7 +70,9 @@ static char *skip(lith_st *L, char *input) static int ishexchar(int c) { - return (('0' <= c) && (c <= '9')) || (('a' <= c) && (c <= 'f')) || (('A' <= c) && (c <= 'F')); + return (('0' <= c) && (c <= '9')) + || (('a' <= c) && (c <= 'f')) + || (('A' <= c) && (c <= 'F')); } static void eat_string(lith_st *L, char *start, char **end) @@ -79,21 +81,17 @@ static void eat_string(lith_st *L, char *start, char **end) if (**end == '\\') { ++*end; if (**end == 'x') { - if (!((ishexchar(*++*end) && ishexchar(*++*end)))) { /* May God and You forgive me */ - L->error = LITH_ERR_SYNTAX; - L->error_state.success = 0; - L->error_state.msg = + if (!((ishexchar(*++*end) && ishexchar(*++*end)))) { + lith_simple_error(L, LITH_ERR_SYNTAX, "Invalid character escape literal, " - "expecting two hexadecimal characters"; + "expecting two hexadecimal characters"); return; } } } } if (!**end) { - L->error = LITH_ERR_EOF; - L->error_state.success = 0; - L->error_state.msg = "while reading a string literal"; + lith_simple_error(L, LITH_ERR_EOF, "while reading a string literal"); } else { /* skip the string ending " character */ ++*end; @@ -104,12 +102,13 @@ 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 ((*input == '(') || (*input == ')') || (*input == '\'') + || (*input == '@') || (*input == '`')) { *end = input + 1; } else if (*input == ',') { *end = input + ((input[1] == '@') ? 2 : 1); } else if (*input == '"') { - /* skip the string starting " character */ + /* +1 to skip the string starting " character */ eat_string(L, *start + 1, end); } else { *end = *start + strcspn(*start, " \t\n;()"); @@ -152,19 +151,18 @@ static lith_value *read_atom(lith_st *L, char *start, char *end) lith_value *val; if (*start == '"') { + /* -1 to skip the string ending " character */ string = read_string(L, start, end - 1, &length); if (LITH_IS_ERR(L)) return NULL; val = lith_make_string(L, string, length); free(string); return val; } - if ((*start == '#') && ((end - start) == 2) && ((start[1] == 't') || (start[1] == 'f'))) { + if ((*start == '#') && ((end - start) == 2) + && ((start[1] == 't') || (start[1] == 'f'))) { return (start[1] == 'f') ? L->False : L->True; } - if ((*start == '+') || (*start == '-')) - sign = (*start == '-') ? -1 : 1; - else - sign = 1; + sign = (*start == '-') ? -1 : 1; integer = strtol(start, &next, 10); if (*next == '.') { number = strtod(next, &next); @@ -176,7 +174,7 @@ static lith_value *read_atom(lith_st *L, char *start, char *end) } else { string = lith__strndup(L, start, end - start); if (!string) return NULL; - val = (!strcmp(string, "nil")) ? L->nil : lith_get_symbol(L, string); + val = lith_get_symbol(L, string); free(string); return val; } @@ -196,8 +194,8 @@ static lith_value *read_list_expr(lith_st *L, char *start, char **end) if (*t == ')') return v; if (*t == '.' && (*end - t == 1)) { if (LITH_IS_NIL(p)) { - L->error = LITH_ERR_SYNTAX; - L->error_state.msg = "invalid improper list starting with '.'"; + lith_simple_error(L, LITH_ERR_SYNTAX, + "improper lists do not start with '.'"); lith_free_value(v); return NULL; } @@ -209,8 +207,8 @@ static lith_value *read_list_expr(lith_st *L, char *start, char **end) LITH_CDR(p) = r; lex(L, *end, &t, end); if (LITH_IS_ERR(L) || (*t != ')')) { - L->error = LITH_ERR_SYNTAX; - L->error_state.msg = "expecting ')' for the end of this improper list"; + lith_simple_error(L, LITH_ERR_SYNTAX, + "expecting ')' at the end of this improper list"); lith_free_value(v); return NULL; } @@ -240,8 +238,7 @@ static lith_value *read_expr(lith_st *L, char *start, char **end) if (*t == '(') { return read_list_expr(L, *end, end); } else if (*t == ')') { - L->error = LITH_ERR_SYNTAX; - L->error_state.msg = "unbalanced parenthesis, expected an expression"; + lith_simple_error(L, LITH_ERR_SYNTAX, "unbalanced parenthesis, expected an expression"); return NULL; } else if ((*t == '\'') || (*t == '@') || (*t == ',') || (*t == '`')) { s = ((*t == '\'') @@ -283,16 +280,17 @@ static size_t list_length(lith_value *v) return len; } -static size_t lamargs_length(lith_value *args, int *im) +static size_t lamargs_length(lith_value *args, int *improper) { size_t i; for (i = 0; LITH_IS(args, LITH_TYPE_PAIR); args = LITH_CDR(args)) ++i; - *im = !LITH_IS_NIL(args); + *improper = !LITH_IS_NIL(args); return i; } /* builtin functions of lith */ +/* (car '(a . b)) -> a */ static lith_value *builtin__car(lith_st *L, lith_value *args) { lith_value *list; @@ -302,6 +300,7 @@ static lith_value *builtin__car(lith_st *L, lith_value *args) return LITH_CAR(list); } +/* (cdr '(a . b)) -> b */ static lith_value *builtin__cdr(lith_st *L, lith_value *args) { lith_value *pair; @@ -311,6 +310,7 @@ static lith_value *builtin__cdr(lith_st *L, lith_value *args) return LITH_CDR(pair); } +/* (cons a b) -> (a . b) */ static lith_value *builtin__cons(lith_st *L, lith_value *args) { lith_value *head, *tail; @@ -322,18 +322,18 @@ static lith_value *builtin__cons(lith_st *L, lith_value *args) static void lith__print(lith_value *v) { - char *s; - size_t i, len; if (LITH_IS(v, LITH_TYPE_STRING)) { - s = v->value.string.buf; - len = v->value.string.len; - for (i = 0; i < len; i++) - putchar(*s++); + fwrite(v->value.string.buf, 1, v->value.string.len, stdout); } else { - lith_print_value(v); + lith_print_value(v, stdout); } } +/* (print ...) -> () + * and prints the values + * separated by ' ' + * and a newline ('\n') + */ static lith_value *builtin__print(lith_st *L, lith_value *args) { lith_value *v; @@ -365,9 +365,8 @@ static lith_value *builtin__print(lith_st *L, lith_value *args) n2_is_number = LITH_IS(arg2, LITH_TYPE_NUMBER); \ n2_is_numeric = n2_is_integer || n2_is_number; \ if (!n1_is_numeric || !n2_is_numeric) { \ - L->error = LITH_ERR_TYPE; \ - L->error_state.manual = 1; \ - L->error_state.msg = "expected numeric types (integers or numbers) as argument"; \ + lith_simple_error(L, LITH_ERR_TYPE, \ + "expected numeric types (integers or numbers) as argument"); \ return NULL; \ } @@ -385,6 +384,13 @@ static lith_value *builtin__print(lith_st *L, lith_value *args) : arg2->value.number)); \ } +/* op1 <- (:+), (:-), (:*) + * (op1 int int) -> int + * (op1 int num) -> num + * (op1 num int) -> num + * (op1 num num) -> num + */ + static lith_value *builtin__add(lith_st *L, lith_value *args) { COMMON1(":+") @@ -405,12 +411,17 @@ static lith_value *builtin__multiply(lith_st *L, lith_value *args) #define COMMON3(op, q) \ if (q && (arg2->value.integer == 0L)) { \ - L->error = LITH_ERR_TYPE; \ - L->error_state.manual = 1; \ - L->error_state.msg = "cannot " op " by zero!!"; \ + lith_simple_error(L, LITH_ERR_TYPE, "cannot " op " by zero!!"); \ return NULL; \ } +/* type int_n0 = int \ {0} ; hah! + * (:/ int int_n0) -> int + * (:/ int num) -> num + * (:/ num int) -> num + * (:/ num num) -> num + */ + static lith_value *builtin__divide(lith_st *L, lith_value *args) { COMMON1(":/") @@ -418,6 +429,7 @@ static lith_value *builtin__divide(lith_st *L, lith_value *args) COMMON2(/) } +/* (:% int int) -> int */ static lith_value *builtin__modulus(lith_st *L, lith_value *args) { lith_value *arg1, *arg2; @@ -425,9 +437,7 @@ static lith_value *builtin__modulus(lith_st *L, lith_value *args) arg1 = LITH_CAR(args); arg2 = LITH_CAR(LITH_CDR(args)); if (!LITH_IS(arg1, LITH_TYPE_INTEGER) || !LITH_IS(arg2, LITH_TYPE_INTEGER)) { - L->error = LITH_ERR_TYPE; - L->error_state.manual = 1; - L->error_state.msg = "can calculate modulus with integral only arguments"; + lith_simple_error(L, LITH_ERR_TYPE, "can calculate modulus with integral arguments only"); return NULL; } COMMON3("mod", 1) @@ -449,19 +459,24 @@ static lith_value *builtin__modulus(lith_st *L, lith_value *args) ); \ } -static lith_value *builtin__less_than(lith_st *L, lith_value *args) +/* type numeric = int U num ; huh! + * op2 <- (:<, :==, :>) + * (op2 numeric numeric) -> bool + */ + +static lith_value *builtin__is_less_than(lith_st *L, lith_value *args) { COMMON1(":<") COMMON4(<) } -static lith_value *builtin__equal(lith_st *L, lith_value *args) +static lith_value *builtin__is_num_equal(lith_st *L, lith_value *args) { COMMON1(":==") COMMON4(==) } -static lith_value *builtin__greater_than(lith_st *L, lith_value *args) +static lith_value *builtin__is_greater_than(lith_st *L, lith_value *args) { COMMON1(":>") COMMON4(>) @@ -472,7 +487,8 @@ static lith_value *builtin__greater_than(lith_st *L, lith_value *args) #undef COMMON2 #undef COMMON1 -static lith_value *builtin__eq(lith_st *L, lith_value *args) +/* (eq? a b) -> bool */ +static lith_value *builtin__is_eq(lith_st *L, lith_value *args) { int eq; lith_value *arg1, *arg2; @@ -497,6 +513,7 @@ static lith_value *builtin__eq(lith_st *L, lith_value *args) return LITH_IN_BOOL(eq); } +/* (typeof a) -> sym */ static lith_value *builtin__typeof(lith_st *L, lith_value *args) { lith_value *val; @@ -505,12 +522,14 @@ static lith_value *builtin__typeof(lith_st *L, lith_value *args) return lith_get_symbol(L, L->types[val->type]); } -static lith_value *builtin__nil(lith_st *L, lith_value *args) +/* (nil? a) -> bool */ +static lith_value *builtin__is_nil(lith_st *L, lith_value *args) { if (!lith_expect_nargs(L, "nil?", 1, args, 1)) return NULL; return LITH_IN_BOOL(LITH_IS_NIL(LITH_CAR(args))); } +/* (apply (i... -> a) (i...)) -> a */ static lith_value *builtin__apply(lith_st *L, lith_value *args) { lith_value *f, *aargs, *cargs; @@ -522,6 +541,7 @@ static lith_value *builtin__apply(lith_st *L, lith_value *args) return lith_apply(L, f, cargs); } +/* (error str) -> _|_ */ static lith_value *builtin__error(lith_st *L, lith_value *args) { lith_value *arg; @@ -533,6 +553,11 @@ static lith_value *builtin__error(lith_st *L, lith_value *args) return NULL; } +/* (load str) -> () + * the contents of the file given by + * the string containing the path of that file is executed + */ + static lith_value *builtin__load(lith_st *L, lith_value *args) { lith_value *filename; @@ -540,13 +565,14 @@ static lith_value *builtin__load(lith_st *L, lith_value *args) filename = LITH_CAR(args); if (!lith_expect_type(L, "load", 1, LITH_TYPE_STRING, filename)) return NULL; lith_run_file(L, L->global, filename->value.string.buf); - /* Forgive me */ if (LITH_IS_ERR(L)) return NULL; else return L->nil; } +/* some more utilities */ + char *slurp(lith_st *L, char *filename) { FILE *file; @@ -555,8 +581,7 @@ char *slurp(lith_st *L, char *filename) file = fopen(filename, "r"); if (!file) { - L->error = LITH_ERR_CUSTOM; - L->error_state.msg = "could not open the file to be read"; + lith_simple_error(L, LITH_ERR_CUSTOM, "could not open the file to be read"); return NULL; } @@ -588,6 +613,28 @@ static void init_types(char **types) types[LITH_TYPE_MACRO] = "macro"; } +struct lith_lib_fn lith_builtins[] = { + {"car", builtin__car}, + {"cdr", builtin__cdr}, + {"cons", builtin__cons}, + {"typeof", builtin__typeof}, + {"print", builtin__print}, + {":+", builtin__add}, + {":-", builtin__subtract}, + {":*", builtin__multiply}, + {":/", builtin__divide}, + {":%", builtin__modulus}, + {":<", builtin__is_less_than}, + {":==", builtin__is_num_equal}, + {":>", builtin__is_greater_than}, + {"eq?", builtin__is_eq}, + {"nil?", builtin__is_nil}, + {"apply", builtin__apply}, + {"error", builtin__error}, + {"load", builtin__load}, + {NULL, NULL} +}; + /* Public functions */ void lith_init(lith_st *L) @@ -609,7 +656,7 @@ void lith_init(lith_st *L) L->global = lith_new_env(L, L->global); L->filename = "<<unspecified>>"; init_types(L->types); - lith_fill_env(L); + lith_fill_env(L, lith_builtins); } void lith_free(lith_st *L) @@ -624,7 +671,7 @@ void lith_free(lith_st *L) p = LITH_CDR(p); } if (L->error_state.expr) - free(L->error_state.expr); + lith_free_value(L->error_state.expr); free(L->False); free(L->True); free(L->nil); @@ -690,18 +737,25 @@ lith_value *lith_make_builtin(lith_st *L, lith_builtin_function function) return val; } -lith_value *lith_make_closure(lith_st *L, lith_env *parent_env, lith_value *arg_names, lith_value *body) +lith_value *lith_make_closure(lith_st *L, lith_env *parent_env, + lith_value *name, lith_value *arg_names, lith_value *body) { - lith_value *val, *p; + lith_value *val; + lith_closure *f; + val = lith_new_value(L); + if (!val) return NULL; + f = emalloc(L, sizeof(*f)); + if (!f) { free(val); return NULL; } arg_names = lith_copy_value(L, arg_names); - if (!arg_names) return NULL; + if (!arg_names) { free(val); free(f); return NULL; } body = lith_copy_value(L, body); - if (!body) { lith_free_value(arg_names); return NULL; } - p = LITH_CONS(L, arg_names, body); - if (!p) { lith_free_value(arg_names); lith_free_value(body); return NULL; } - val = LITH_CONS(L, parent_env, p); - if (!val) { lith_free_value(p); return NULL; } + if (!body) { free(val); free(f); lith_free_value(arg_names); return NULL; } + f->name = name; + f->parent = parent_env; + f->args = arg_names; + f->body = body; val->type = LITH_TYPE_CLOSURE; + val->value.closure = f; return val; } @@ -736,10 +790,13 @@ void lith_free_value(lith_value *val) 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_MACRO)) { - lith_free_value(LITH_CDR(val)); + lith_free_value(val->value.closure->args); + lith_free_value(val->value.closure->body); + free(val->value.closure); } else if (LITH_IS(val, LITH_TYPE_STRING)) { free(val->value.string.buf); - } else if (LITH_IS_NIL(val) || LITH_IS(val, LITH_TYPE_BOOLEAN) || LITH_IS(val, LITH_TYPE_SYMBOL)) { + } else if (LITH_IS_NIL(val) || LITH_IS(val, LITH_TYPE_BOOLEAN) + || LITH_IS(val, LITH_TYPE_SYMBOL)) { return; } free(val); @@ -762,44 +819,47 @@ lith_value *lith_get_symbol(lith_st *L, char *name) return sym; } -void lith_print_value(lith_value *val) +void lith_print_value(lith_value *val, FILE *file) { if (LITH_IS_NIL(val)) { - printf("()"); + fprintf(file, "()"); } else if (LITH_IS(val, LITH_TYPE_SYMBOL)) { - printf("%s", val->value.symbol); + fprintf(file, "%s", val->value.symbol); } else if (LITH_IS(val, LITH_TYPE_STRING)) { - print_string(val->value.string); + print_string(val->value.string, stdout); } else if (LITH_IS(val, LITH_TYPE_BOOLEAN)) { - printf("#%c", val->value.boolean ? 't' : 'f'); + fprintf(file, "#%c", val->value.boolean ? 't' : 'f'); } else if (LITH_IS(val, LITH_TYPE_INTEGER)) { - printf("%ld", val->value.integer); + fprintf(file, "%ld", val->value.integer); } else if (LITH_IS(val, LITH_TYPE_NUMBER)) { - printf("%.*f", LITH_NFP, val->value.number); + fprintf(file, "%.15g", val->value.number); } else if (LITH_IS(val, LITH_TYPE_BUILTIN)) { - printf("#builtin:<%p>", val->value.function); - } else if (LITH_IS(val, LITH_TYPE_CLOSURE)) { - printf("#lambda:<%p>", val); - } else if (LITH_IS(val, LITH_TYPE_MACRO)) { - printf("#macro:<%p>", val); + fprintf(file, "#<builtin at %p>", val->value.function); + } else if (LITH_IS(val, LITH_TYPE_CLOSURE) || LITH_IS(val, LITH_TYPE_MACRO)) { + fprintf(file, "#<%s", LITH_IS(val, LITH_TYPE_MACRO) ? "macro" : "lambda"); + if (val->value.closure->name) { + fputc(' ', file); + lith_print_value(val->value.closure->name, file); + } + fprintf(file, " at %p>", val->value.closure); } else if (!LITH_IS(val, LITH_TYPE_PAIR)) { - printf("#<%p>", val); + fprintf(file, "#<unknown object at %p>", val); } else { - putchar('('); - lith_print_value(LITH_CAR(val)); + fputc('(', file); + lith_print_value(LITH_CAR(val), file); val = LITH_CDR(val); while (!LITH_IS_NIL(val)) { if (LITH_IS(val, LITH_TYPE_PAIR)) { - putchar(' '); - lith_print_value(LITH_CAR(val)); + fputc(' ', file); + lith_print_value(LITH_CAR(val), file); val = LITH_CDR(val); } else { - printf(" . "); - lith_print_value(val); + fprintf(file, " . "); + lith_print_value(val, file); break; } } - putchar(')'); + fputc(')', file); } } @@ -818,7 +878,8 @@ lith_value *lith_copy_value(lith_st *L, lith_value *val) return lith_make_builtin(L, val->value.function); case LITH_TYPE_MACRO: case LITH_TYPE_CLOSURE: - v = lith_make_closure(L, LITH_CAR(val), LITH_CAR(LITH_CDR(val)), LITH_CDR(LITH_CDR(val))); + v = lith_make_closure(L, val->value.closure->parent, val->value.closure->name, + val->value.closure->args, val->value.closure->body); if (LITH_IS(val, LITH_TYPE_MACRO)) v->type = LITH_TYPE_MACRO; return v; @@ -828,7 +889,8 @@ lith_value *lith_copy_value(lith_st *L, lith_value *val) pair = LITH_CONS(L, head, L->nil); if (!pair) { lith_free_value(head); return NULL; } val = LITH_CDR(val); - for (p = pair; LITH_IS(val, LITH_TYPE_PAIR); val = LITH_CDR(val), p = LITH_CDR(p)) { + for (p = pair; LITH_IS(val, LITH_TYPE_PAIR); + val = LITH_CDR(val), p = LITH_CDR(p)) { v = lith_copy_value(L, LITH_CAR(val)); if (!v) { lith_free_value(pair); return NULL; } w = LITH_CONS(L, v, L->nil); @@ -845,6 +907,16 @@ lith_value *lith_copy_value(lith_st *L, lith_value *val) } } +void lith_simple_error(lith_st *L, enum lith_error errtype, char *msg) +{ + L->error = errtype; + L->error_state.msg = msg; + if (errtype == LITH_ERR_EOF) + L->error_state.success = 0; + else if (errtype == LITH_ERR_TYPE) + L->error_state.manual = 1; +} + void lith_print_error(lith_st *L, int full) { struct lith_error_state E = L->error_state; @@ -862,11 +934,14 @@ void lith_print_error(lith_st *L, int full) fprintf(stderr, "syntax error: %s", E.msg); break; case LITH_ERR_NOMEM: - fprintf(stderr, "no memory"); + fprintf(stderr, "out of memory"); break; case LITH_ERR_UNBOUND: fprintf(stderr, "unbound symbol: '%s'", E.sym); break; + case LITH_ERR_REDEFINE: + fprintf(stderr, "trying to redefine already defined symbol: '%s'", E.sym); + break; case LITH_ERR_NARGS: fprintf(stderr, "wrong number of arguments: " "expected %s%zu argument(s) but given %zu argument(s)", @@ -890,7 +965,7 @@ void lith_print_error(lith_st *L, int full) fprintf(stderr, " [in '%s']", E.name); if (E.expr) { fprintf(stderr, "\noccured in: "); - lith_print_value(E.expr); + lith_print_value(E.expr, stderr); } fputc('\n', stderr); } @@ -930,6 +1005,27 @@ lith_value *lith_env_get(lith_st *L, lith_env *V, lith_value *name) return NULL; } +void lith_env_set(lith_st *L, lith_env *V, lith_value *name, lith_value *value) +{ + lith_env *parent; + lith_value *kvs, *kv; + parent = V; + do { + kvs = LITH_CDR(parent); + parent = LITH_CAR(parent); + while (!LITH_IS_NIL(kvs)) { + kv = LITH_CAR(kvs); + if (LITH_CAR(kv) == name) { + LITH_CDR(kv) = value; + return; + } + kvs = LITH_CDR(kvs); + } + } while (!LITH_IS_NIL(parent)); + L->error = LITH_ERR_UNBOUND; + L->error_state.sym = name->value.symbol; +} + void lith_env_put(lith_st *L, lith_env *V, lith_value *name, lith_value *value) { lith_value *kvs, *kv; @@ -937,7 +1033,8 @@ void lith_env_put(lith_st *L, lith_env *V, lith_value *name, lith_value *value) while (!LITH_IS_NIL(kvs)) { kv = LITH_CAR(kvs); if (name == LITH_CAR(kv)) { - LITH_CDR(kv) = value; + L->error = LITH_ERR_REDEFINE; + L->error_state.sym = name->value.symbol; return; } kvs = LITH_CDR(kvs); @@ -947,35 +1044,19 @@ void lith_env_put(lith_st *L, lith_env *V, lith_value *name, lith_value *value) LITH_CDR(V) = LITH_CONS(L, kv, LITH_CDR(V)); } -void lith_fill_env(lith_st *L) +void lith_fill_env(lith_st *L, lith_lib lib) { lith_env *V; + struct lith_lib_fn *fns; V = L->global; - #define LITH_REGISTER_BUILTIN(s, fn) \ - lith_env_put(L, V, lith_get_symbol(L, s), \ - lith_make_builtin(L, builtin__ ## fn)) - LITH_REGISTER_BUILTIN("print", print); - LITH_REGISTER_BUILTIN("car", car); - LITH_REGISTER_BUILTIN("cdr", cdr); - LITH_REGISTER_BUILTIN("cons", cons); - LITH_REGISTER_BUILTIN(":+", add); - LITH_REGISTER_BUILTIN(":-", subtract); - LITH_REGISTER_BUILTIN(":*", multiply); - LITH_REGISTER_BUILTIN(":/", divide); - LITH_REGISTER_BUILTIN(":%", modulus); - LITH_REGISTER_BUILTIN(":<", less_than); - LITH_REGISTER_BUILTIN(":==", equal); - LITH_REGISTER_BUILTIN(":>", greater_than); - LITH_REGISTER_BUILTIN("eq?", eq); - LITH_REGISTER_BUILTIN("typeof", typeof); - LITH_REGISTER_BUILTIN("nil?", nil); - LITH_REGISTER_BUILTIN("apply", apply); - LITH_REGISTER_BUILTIN("error", error); - LITH_REGISTER_BUILTIN("load", load); - #undef LITH_REGISTER_BUILTIN -} - -int lith_expect_nargs(lith_st *L, char *name, size_t expect, lith_value *args, int exact) + for (fns = lib; fns->name; ++fns) { + lith_env_put(L, V, lith_get_symbol(L, fns->name), + lith_make_builtin(L, fns->fn)); + } +} + +int lith_expect_nargs(lith_st *L, char *name, size_t expect, + lith_value *args, int exact) { size_t len; struct lith_error_state *E; @@ -994,7 +1075,8 @@ int lith_expect_nargs(lith_st *L, char *name, size_t expect, lith_value *args, i } } -int lith_expect_type(lith_st *L, char *name, size_t narg, lith_valtype type, lith_value *val) +int lith_expect_type(lith_st *L, char *name, size_t narg, + lith_valtype type, lith_value *val) { struct lith_error_state *E; E = &L->error_state; @@ -1017,8 +1099,8 @@ lith_value *lith_eval_expr(lith_st *L, lith_env *V, lith_value *expr) } else if (!LITH_IS(expr, LITH_TYPE_PAIR)) { return lith_copy_value(L, expr); } else if (!is_proper_list(expr)) { - L->error = LITH_ERR_SYNTAX; - L->error_state.msg = "atom or proper list expected as expression"; + lith_simple_error(L, LITH_ERR_SYNTAX, + "atom or proper list expected as expression"); return NULL; } f = LITH_CAR(expr); @@ -1041,23 +1123,37 @@ lith_value *lith_eval_expr(lith_st *L, lith_env *V, lith_value *expr) p = LITH_CDR(rest); if (!LITH_IS(sym, LITH_TYPE_SYMBOL)) { if (!LITH_IS(sym, LITH_TYPE_PAIR)) { - L->error = LITH_ERR_TYPE; + lith_simple_error(L, LITH_ERR_TYPE, + "first argument must be a symbol or pair"); L->error_state.name = "define"; - L->error_state.manual = 1; - L->error_state.msg = "first argument must be a symbol or pair"; return NULL; } args = LITH_CDR(sym); sym = LITH_CAR(sym); if (!lith_expect_type(L, "define", 1, LITH_TYPE_SYMBOL, sym)) return NULL; - val = lith_make_closure(L, V, args, p); + val = lith_make_closure(L, V, sym, args, p); } else { if (!lith_expect_nargs(L, "define", 2, rest, 1)) return NULL; val = lith_eval_expr(L, V, LITH_CAR(p)); + if (LITH_IS_CALLABLE(val)) + val->value.closure->name = sym; } if (!val) return NULL; lith_env_put(L, V, sym, val); return L->nil; + } else if (LITH_SYM_EQ(f, "set!")) { + if (!lith_expect_nargs(L, "set!", 2, rest, 1)) + return NULL; + sym = LITH_CAR(rest); + val = LITH_CAR(LITH_CDR(rest)); + if (!lith_expect_type(L, "set!", 1, LITH_TYPE_SYMBOL, sym)) + return NULL; + val = lith_eval_expr(L, V, val); + if (!val) return NULL; + lith_env_set(L, V, sym, val); + if (LITH_IS_CALLABLE(val)) + val->value.closure->name = sym; + return L->nil; } else if (LITH_SYM_EQ(f, "define-macro")) { if (!lith_expect_nargs(L, "define-macro", 2, rest, 0)) return NULL; @@ -1075,6 +1171,7 @@ lith_value *lith_eval_expr(lith_st *L, lith_env *V, lith_value *expr) val = lith_eval_expr(L, V, r); if (!val) return NULL; val->type = LITH_TYPE_MACRO; + val->value.closure->name = sym; lith_env_put(L, V, sym, val); return L->nil; } else if (LITH_SYM_EQ(f, "lambda")) { @@ -1083,23 +1180,23 @@ lith_value *lith_eval_expr(lith_st *L, lith_env *V, lith_value *expr) args = LITH_CAR(rest); p = LITH_CDR(rest); if (!is_proper_list(p)) { - L->error = LITH_ERR_SYNTAX; - L->error_state.msg = "body of lambda expression must be proper list"; + lith_simple_error(L, LITH_ERR_SYNTAX, + "body of lambda expression must be proper list"); return NULL; } for (q = args; LITH_IS(q, LITH_TYPE_PAIR); q = LITH_CDR(q)) { if (!LITH_IS(LITH_CAR(q), LITH_TYPE_SYMBOL)) { - L->error = LITH_ERR_SYNTAX; - L->error_state.msg = "arguments in lambda expression must be symbols"; + lith_simple_error(L, LITH_ERR_SYNTAX, + "arguments in lambda expression must be symbols"); return NULL; } } if (!LITH_IS_NIL(q) && !LITH_IS(q, LITH_TYPE_SYMBOL)) { - L->error = LITH_ERR_SYNTAX; - L->error_state.msg = "arguments in lambda expression must be symbols"; + lith_simple_error(L, LITH_ERR_SYNTAX, + "arguments in lambda expression must be symbols"); return NULL; } - return lith_make_closure(L, V, args, p); + return lith_make_closure(L, V, NULL, args, p); } } f = lith_eval_expr(L, V, f); @@ -1131,40 +1228,33 @@ lith_value *lith_eval_expr(lith_st *L, lith_env *V, lith_value *expr) lith_value *lith_apply(lith_st *L, lith_value *f, lith_value *args) { - int imgr, imer; - size_t gnargs, enargs; + int is_improper_list; + size_t len; lith_env *env; - lith_value *argn, *body, *r; + lith_value *expected_args, *body, *r; + lith_closure *fn; if (LITH_IS(f, LITH_TYPE_BUILTIN)) { return (*f->value.function)(L, 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"; + lith_simple_error(L, LITH_ERR_TYPE, "can not call non-callable"); L->error_state.name = "{apply}"; return NULL; } - env = lith_new_env(L, LITH_CAR(f)); - argn = LITH_CDR(f); - body = LITH_CDR(argn); - argn = LITH_CAR(argn); - gnargs = lamargs_length(args, &imgr); - enargs = lamargs_length(argn, &imer); - if (imer ? (gnargs < enargs) : (gnargs != enargs)) { - L->error = LITH_ERR_NARGS; - L->error_state.name = "{lambda}"; - L->error_state.nargs.expected = enargs; - L->error_state.nargs.got = gnargs; - L->error_state.nargs.exact = !imer; - return NULL; - } - while (LITH_IS(argn, LITH_TYPE_PAIR)) { - lith_env_put(L, env, LITH_CAR(argn), LITH_CAR(args)); - argn = LITH_CDR(argn); + fn = f->value.closure; + env = lith_new_env(L, fn->parent); + body = fn->body; + expected_args = fn->args; + len = lamargs_length(expected_args, &is_improper_list); + if (!lith_expect_nargs(L, + fn->name ? fn->name->value.symbol : "{lambda}", + len, args, !is_improper_list)) return NULL; + while (LITH_IS(expected_args, LITH_TYPE_PAIR)) { + lith_env_put(L, env, LITH_CAR(expected_args), LITH_CAR(args)); + expected_args = LITH_CDR(expected_args); args = LITH_CDR(args); } - if (!LITH_IS_NIL(argn)) - lith_env_put(L, env, argn, args); + if (!LITH_IS_NIL(expected_args)) + lith_env_put(L, env, expected_args, args); r = NULL; while (!LITH_IS_NIL(body)) { if (r) lith_free_value(r); @@ -1184,11 +1274,11 @@ void lith_run_string(lith_st *L, lith_env *V, char *input) while (!LITH_IS_ERR(L)) { if ((expr = lith_read_expr(L, end, &end))) { printf(">> "); - lith_print_value(expr); + lith_print_value(expr, stdout); putchar('\n'); if ((res = lith_eval_expr(L, V, expr))) { printf("-> "); - lith_print_value(res); + lith_print_value(res, stdout); lith_free_value(res); putchar('\n'); } @@ -1231,9 +1321,9 @@ void lith_run_file(lith_st *L, lith_env *V, char *filename) lith_print_error(L, 1); if (expr) { - printf("error occurred when evaluating the expression:\n\t"); - lith_print_value(expr); - putchar('\n'); + fprintf(stderr, "error occurred when evaluating the expression:\n\t"); + lith_print_value(expr, stderr); + fputc('\n', stderr); lith_free_value(expr); } } diff --git a/lith.h b/lith.h index 3d9d1fb..719374e 100644 --- a/lith.h +++ b/lith.h @@ -3,6 +3,7 @@ #define lith_h #include <stddef.h> +#include <stdio.h> #define LITH_VERSION_STRING "0.1.0-alpha" @@ -10,7 +11,9 @@ typedef struct lith_value lith_value; typedef struct lith_value lith_env; typedef struct lith_state lith_st; typedef struct lith_string lith_string; +typedef struct lith_closure lith_closure; typedef enum lith_value_type lith_valtype; +typedef struct lith_lib_fn *lith_lib; enum lith_error { LITH_ERR_OK, @@ -18,6 +21,7 @@ enum lith_error { LITH_ERR_SYNTAX, LITH_ERR_NOMEM, LITH_ERR_UNBOUND, + LITH_ERR_REDEFINE, LITH_ERR_NARGS, LITH_ERR_TYPE, LITH_ERR_CUSTOM @@ -46,10 +50,20 @@ struct lith_value { int boolean; long integer; double number; - struct lith_string { size_t len; char *buf; } string; + struct lith_string { + size_t len; + char *buf; + } string; char *symbol; - struct { struct lith_value *car, *cdr; } pair; + struct { + struct lith_value *car, *cdr; + } pair; lith_builtin_function function; + struct lith_closure { + lith_value *name; + lith_env *parent; + lith_value *args, *body; + } *closure; } value; }; @@ -63,14 +77,23 @@ struct lith_value { #define LITH_CDR(p) ((p)->value.pair.cdr) #define LITH_CONS lith_make_pair +#define LITH_IS_CALLABLE(F) \ + (LITH_IS(F, LITH_TYPE_MACRO) || LITH_IS(F, LITH_TYPE_CLOSURE)) + struct lith_state { enum lith_error error; 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; + 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; char *types[LITH_NTYPES]; lith_value *nil; @@ -80,24 +103,29 @@ struct lith_state { char *filename; }; +struct lith_lib_fn { + char *name; + lith_builtin_function fn; +}; + +extern struct lith_lib_fn lith_builtins[]; + #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) -/* When a number is printed, how many digits you want after the decimal point */ -#ifndef LITH_NFP -#define LITH_NFP 8 -#endif +/* Public functions: the API of this library */ void lith_init(lith_st *); void lith_free(lith_st *); void lith_clear_error_state(lith_st *); void lith_print_error(lith_st *, int); +void lith_simple_error(lith_st *, enum lith_error, char *); lith_value *lith_new_value(lith_st *); -void lith_print_value(lith_value *); +void lith_print_value(lith_value *, FILE *); void lith_free_value(lith_value *); lith_value *lith_copy_value(lith_st *, lith_value *); @@ -106,7 +134,7 @@ lith_value *lith_make_number(lith_st *, double); lith_value *lith_make_symbol(lith_st *, char *); lith_value *lith_make_string(lith_st *, char *, size_t); lith_value *lith_make_builtin(lith_st *, lith_builtin_function); -lith_value *lith_make_closure(lith_st *, lith_env *, lith_value *, lith_value *); +lith_value *lith_make_closure(lith_st *, lith_env *, lith_value *, lith_value *, lith_value *); lith_value *lith_make_pair(lith_st *, lith_value *, lith_value *); lith_value *lith_get_symbol(lith_st *, char *); @@ -121,9 +149,10 @@ lith_env *lith_new_env(lith_st *, lith_env *); void lith_free_env(lith_env *); lith_value *lith_env_get(lith_st *, lith_env *, lith_value *); +void lith_env_set(lith_st *, lith_env *, lith_value *, lith_value *); void lith_env_put(lith_st *, lith_env *, lith_value *, lith_value *); -void lith_fill_env(lith_st *); +void lith_fill_env(lith_st *, lith_lib); 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); @@ -131,4 +160,4 @@ 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 +#endif /* lith_h */ diff --git a/main.c b/main.c index 5b192e0..dd2e824 100644 --- a/main.c +++ b/main.c @@ -32,9 +32,24 @@ int main(int argc, char **argv) int ret; lith_st T, *L; lith_env *V, *W; - char **arg; + char **arg, *a; + + if (argc < 2) { + show_help(argv[0]); + return 8; + } + + a = argv[1]; + if (a[0] == '-') { + if (!strcmp(a, "-v") || !strcmp(a, "--version")) { + show_version(); + return 0; + } else if (!strcmp(a, "-h") || !strcmp(a, "--help")) { + show_help(argv[0]); + return 0; + } + } - if (argc < 2) return 8; ret = 0; L = &T; lith_init(L); @@ -59,12 +74,6 @@ int main(int argc, char **argv) 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 { fprintf(stderr, "lith: invalid option '%s': try '%s --help' for available options\n", *arg, argv[0]); break; |