aboutsummaryrefslogtreecommitdiff
path: root/src
diff options
context:
space:
mode:
Diffstat (limited to 'src')
-rw-r--r--src/builtins.c27
-rw-r--r--src/builtins.h4
-rw-r--r--src/interp.c47
-rw-r--r--src/interp.h4
-rw-r--r--src/main.c24
-rw-r--r--src/parser.c43
-rw-r--r--src/prelude.c2
-rw-r--r--src/prelude.lisp10
-rw-r--r--src/primitives.c83
-rw-r--r--src/primitives.h7
10 files changed, 226 insertions, 25 deletions
diff --git a/src/builtins.c b/src/builtins.c
index f64083b..88bcc9b 100644
--- a/src/builtins.c
+++ b/src/builtins.c
@@ -2,6 +2,33 @@
#include "interp.h"
#include "sexp.h"
+SExpRef builtin_exit(Interp *interp, SExpRef args) {
+ if (LENGTH(args) == 0) {
+ Interp_free(interp);
+ exit(0);
+ }
+ if (LENGTH(args) == 1) {
+ SExpRef x = CAR(args);
+ if (VALTYPE(x) != kIntegerSExp) goto error;
+ int retcode = REF(x)->integer;
+ Interp_free(interp);
+ exit(retcode);
+ }
+error:
+ return new_error(interp, "exit: argument error.\n");
+}
+
+SExpRef builtin_error(Interp *interp, SExpRef args) {
+ if (LENGTH(args) != 1) return new_error(interp, "err.\n");
+ if (VALTYPE(CAR(args)) == kStringSExp || VALTYPE(CAR(args)) == kSymbolSExp) {
+ return new_error(interp, "%s\n", REF(CAR(args))->str);
+ }
+ const char *str = lisp_to_string(interp, CAR(args));
+ SExpRef ret = new_error(interp, "%s\n", REF(CAR(args))->str);
+ free((void*)str);
+ return ret;
+}
+
SExpRef builtin_list(Interp *interp, SExpRef args) {
return args;
}
diff --git a/src/builtins.h b/src/builtins.h
index 5ed9133..8f9c428 100644
--- a/src/builtins.h
+++ b/src/builtins.h
@@ -3,19 +3,19 @@
#include "interp.h"
+SExpRef builtin_exit(Interp *interp, SExpRef sexp);
+SExpRef builtin_error(Interp *interp, SExpRef sexp);
SExpRef builtin_list(Interp *interp, SExpRef sexp);
SExpRef builtin_car(Interp *interp, SExpRef sexp);
SExpRef builtin_cdr(Interp *interp, SExpRef sexp);
SExpRef builtin_cons(Interp *interp, SExpRef sexp);
SExpRef builtin_not(Interp *interp, SExpRef sexp);
-
SExpRef builtin_add(Interp *interp, SExpRef sexp);
SExpRef builtin_sub(Interp *interp, SExpRef sexp);
SExpRef builtin_mul(Interp *interp, SExpRef sexp);
SExpRef builtin_div(Interp *interp, SExpRef sexp);
SExpRef builtin_idiv(Interp *interp, SExpRef sexp);
SExpRef builtin_mod(Interp *interp, SExpRef sexp);
-
SExpRef builtin_num_equal(Interp *interp, SExpRef sexp);
SExpRef builtin_num_neq(Interp *interp, SExpRef sexp);
SExpRef builtin_gt(Interp *interp, SExpRef sexp);
diff --git a/src/interp.c b/src/interp.c
index 397e85c..5893ccc 100644
--- a/src/interp.c
+++ b/src/interp.c
@@ -60,6 +60,7 @@ void Interp_init(Interp *self) {
self->stack = lisp_cons(self, self->top_level, self->nil);
self->reg = self->nil;
+ Interp_add_primitive(self, "eval", primitive_eval);
Interp_add_primitive(self, "if", primitive_if);
Interp_add_primitive(self, "cond", primitive_cond);
Interp_add_primitive(self, "progn", primitive_progn);
@@ -78,7 +79,14 @@ void Interp_init(Interp *self) {
Interp_add_primitive(self, "macroexpand-1", primitive_macroexpand1);
Interp_add_primitive(self, "and", primitive_and);
Interp_add_primitive(self, "or", primitive_or);
-
+ Interp_add_primitive(self, "return", primitive_return);
+ Interp_add_primitive(self, "break", primitive_break);
+ Interp_add_primitive(self, "continue", primitive_continue);
+ Interp_add_primitive(self, "assert", primitive_assert);
+ Interp_add_primitive(self, "assert-error", primitive_assert_error);
+ Interp_add_primitive(self, "load", primitive_load);
+
+ Interp_add_userfunc(self, "error", builtin_error);
Interp_add_userfunc(self, "show", builtin_show);
Interp_add_userfunc(self, "car", builtin_car);
Interp_add_userfunc(self, "list", builtin_list);
@@ -97,7 +105,9 @@ void Interp_init(Interp *self) {
Interp_add_userfunc(self, ">=", builtin_ge);
Interp_add_userfunc(self, "<=", builtin_le);
Interp_add_userfunc(self, "not", builtin_not);
- Interp_add_userfunc(self, "gcstat", builtin_gcstat);
+ Interp_add_userfunc(self, "exit", builtin_exit);
+ // debug functions
+ Interp_add_userfunc(self, "_gcstat", builtin_gcstat);
SExpRef ret = Interp_eval_string(self, bamboo_lisp_prelude);
Interp *interp = self;
@@ -244,7 +254,7 @@ void Interp_gc(Interp *interp, SExpRef tmproot) {
} else if (obj->type == kMacroSExp) {
SExpRefVector_push_back(&gcstack, obj->macro.args);
SExpRefVector_push_back(&gcstack, obj->macro.body);
- } else if (obj->type == kReturnSignal || obj->type == kBreakSignal) {
+ } else if (obj->type == kReturnSignal) {
SExpRefVector_push_back(&gcstack, obj->ret);
} else if (obj->type == kTailcallSExp) {
SExpRefVector_push_back(&gcstack, obj->tailcall.args);
@@ -533,7 +543,9 @@ end:
int lisp_length(Interp *interp, SExpRef lst) {
int cnt = 0;
- if (VALTYPE(lst) == kPairSExp) {
+ if (VALTYPE(lst) == kNilSExp) {
+ return 0;
+ } else if (VALTYPE(lst) == kPairSExp) {
while (REF(lst)->type == kPairSExp) {
cnt++;
lst = CDR(lst);
@@ -541,8 +553,7 @@ int lisp_length(Interp *interp, SExpRef lst) {
return cnt;
} else if (VALTYPE(lst) == kStringSExp) {
return strlen(REF(lst)->str);
- }
- return 1;
+ } else return -1;
}
static SExpRef build_function_env(Interp *interp, SExpRef func, SExpRef args) {
@@ -701,7 +712,9 @@ end:
return ret;
tailcall:
while (1) {
+ PUSH_REG(CONS(fn, args));
ret = lisp_apply(interp, fn, args, false);
+ POP_REG();
if (VALTYPE(ret) != kTailcallSExp) break;
fn = REF(ret)->tailcall.fn;
args = REF(ret)->tailcall.args;
@@ -834,3 +847,25 @@ SExpRef new_symbol(Interp *interp, const char *val) {
}
}
+SExpRef new_return(Interp *interp, SExpRef obj) {
+ SExpRef ret = new_sexp(interp);
+ SExp *psexp = Interp_ref(interp, ret);
+ psexp->type = kReturnSignal;
+ psexp->ret = obj;
+ return ret;
+}
+
+SExpRef new_break(Interp *interp) {
+ SExpRef ret = new_sexp(interp);
+ SExp *psexp = Interp_ref(interp, ret);
+ psexp->type = kBreakSignal;
+ return ret;
+}
+
+SExpRef new_continue(Interp *interp) {
+ SExpRef ret = new_sexp(interp);
+ SExp *psexp = Interp_ref(interp, ret);
+ psexp->type = kContinueSignal;
+ return ret;
+}
+
diff --git a/src/interp.h b/src/interp.h
index 4329442..76a3757 100644
--- a/src/interp.h
+++ b/src/interp.h
@@ -76,6 +76,7 @@ SExpRef Interp_load_file(Interp *interp, const char *filename);
#define PUSH_REG(_x) { interp->reg = CONS((_x), interp->reg); }
#define POP_REG() { interp->reg = CDR(interp->reg); }
+const char* lisp_to_string(Interp *interp, SExpRef val);
SExpRef lisp_macroexpand1(Interp *interp, SExpRef macro, SExpRef args);
SExpRef lisp_reverse(Interp *interp, SExpRef lst);
void lisp_defun(Interp *interp, const char *name, SExpRef val);
@@ -102,6 +103,9 @@ SExpRef lisp_div(Interp *interp, SExpRef args);
SExpRef new_error(Interp *interp, const char *format, ...);
SExpRef new_sexp(Interp *ctx);
+SExpRef new_return(Interp *ctx, SExpRef ret);
+SExpRef new_break(Interp *ctx);
+SExpRef new_continue(Interp *ctx);
SExpRef new_boolean(Interp *ctx, bool val);
SExpRef new_char(Interp *ctx, char val);
SExpRef new_integer(Interp *ctx, int64_t val);
diff --git a/src/main.c b/src/main.c
index 4fddea9..86a5d36 100644
--- a/src/main.c
+++ b/src/main.c
@@ -2,10 +2,28 @@
#include "parser.h"
#include "sexp.h"
-int main() {
- int ret = -1;
+int main(int argc, char **argv) {
+ int mainret = 0;
Interp interp;
Interp_init(&interp);
+ if (argc > 2) {
+ fprintf(stderr, "Usage: bamboo-lisp [file.lisp]\n");
+ return -1;
+ }
+ if (argc == 2) {
+ const char *filename = argv[1];
+ SExpRef ret = Interp_load_file(&interp, filename);
+ if (Interp_ref(&interp, ret)->type == kErrSignal) {
+ fprintf(stderr, "Error: %s", Interp_ref(&interp, ret)->str);
+ mainret = -1; goto end;
+ }
+ if (Interp_ref(&interp, ret)->type == kBreakSignal
+ || Interp_ref(&interp, ret)->type == kContinueSignal
+ || Interp_ref(&interp, ret)->type == kReturnSignal) {
+ fprintf(stderr, "Error: unexpected control flow signal.\n");
+ mainret = -1; goto end;
+ }
+ }
Parser_set_readline(interp.parser);
SExpRef sexp, res;
ParseResult parse_result;
@@ -34,5 +52,5 @@ int main() {
}
end:
Interp_free(&interp);
- return 0;
+ return mainret;
}
diff --git a/src/parser.c b/src/parser.c
index 87690c8..6982198 100644
--- a/src/parser.c
+++ b/src/parser.c
@@ -11,6 +11,15 @@
#define BUFSIZE 1024
+static void skip_comment(Parser *parser) {
+ if (Parser_peek(parser) == ';') {
+ while (1) {
+ int peek = Parser_peek(parser);
+ if (peek == '\n' || peek == EOF) break;
+ Parser_getchar(parser);
+ }
+ }
+}
static void skip_spaces(Parser *parser) {
while (isspace(Parser_peek(parser))) {
@@ -18,8 +27,19 @@ static void skip_spaces(Parser *parser) {
}
}
+static void skip_blank(Parser *parser) {
+ while (1) {
+ int peek = Parser_peek(parser);
+ if (!isspace(peek) && peek != ';') {
+ break;
+ }
+ skip_comment(parser);
+ skip_spaces(parser);
+ }
+}
+
bool Parser_is_end(Parser *parser) {
- skip_spaces(parser);
+ skip_blank(parser);
if (Parser_peek(parser) == EOF) return true;
return false;
}
@@ -71,6 +91,7 @@ void Parser_set_readline(Parser *parser) {
parser->readline_eof = false;
}
+
int Parser_getchar(Parser *ctx) {
if (ctx->parse_type == kParseString) {
if (*ctx->str_cursor == '\0') return EOF;
@@ -142,7 +163,7 @@ int Parser_peek(Parser *ctx) {
}
ParseResult parse_sexp(Parser *parser) {
- skip_spaces(parser);
+ skip_blank(parser);
if (Parser_peek(parser) == EOF) {
return ParseErr(parser, "Unexpected EOF.\n");
}
@@ -185,7 +206,7 @@ static ParseResult expect_space(Parser *parser) {
if (Parser_peek(parser) == EOF) {
return ParseErr(parser, "Unexpected EOF.\n");
}
- if (isspace(Parser_peek(parser))) {
+ if (isspace(Parser_peek(parser)) || Parser_peek(parser) == ';') {
return ParseOk(parser->ctx->nil);
}
return ParseErr(parser, "Expect space.\n");
@@ -196,7 +217,8 @@ static ParseResult expect_space_or_end(Parser *parser) {
return ParseErr(parser, "Unexpected EOF.\n");
}
if (isspace(Parser_peek(parser))
- || Parser_peek(parser) == ')') {
+ || Parser_peek(parser) == ')'
+ || Parser_peek(parser) == ';') {
return ParseOk(parser->ctx->nil);
}
return ParseErr(parser, "Expect space.\n");
@@ -220,7 +242,7 @@ ParseResult parse_list(Parser *parser) {
ret = expect_char(parser, '(');
if (ParseResult_is_err(ret)) goto end;
- skip_spaces(parser);
+ skip_blank(parser);
while (1) {
if (Parser_peek(parser) == EOF) {
ret = ParseErr(parser, "Unexpected EOF.\n");
@@ -240,16 +262,16 @@ ParseResult parse_list(Parser *parser) {
SExpRefVector_push_back(&elems, ret.val);
// ret = expect_space_or_end(parser);
// if (ParseResult_is_err(ret)) goto end;
- skip_spaces(parser);
+ skip_blank(parser);
}
// dot
ret = expect_space(parser);
if (ParseResult_is_err(ret)) goto end;
- skip_spaces(parser);
+ skip_blank(parser);
ret = parse_sexp(parser);
if (ParseResult_is_err(ret)) goto end;
SExpRefVector_push_back(&elems, ret.val);
- skip_spaces(parser);
+ skip_blank(parser);
ret = expect_char(parser, ')');
if (ParseResult_is_err(ret)) goto end;
ret = ParseOk(build_list_from_vector(parser->ctx, elems));
@@ -265,6 +287,7 @@ static char *read_token(Parser *parser) {
&& Parser_peek(parser) != ')'
&& Parser_peek(parser) != '('
&& Parser_peek(parser) != '"'
+ && Parser_peek(parser) != ';'
&& (i == 0 || Parser_peek(parser) != '#')
&& i < BUFSIZE - 1) {
parser->token_buf[i] = Parser_getchar(parser);
@@ -307,7 +330,9 @@ static bool is_symbol_subsequent(char c) {
static ParseResult parse_token(Parser *parser, const char *token) {
int len = strlen(token);
- if (len == 0) return ParseErr(parser, "Empty token.\n");
+ if (len == 0) {
+ return ParseErr(parser, "Empty token.\n");
+ }
if (len == 1) {
if (token[0] == '-' || token[0] == '+') {
return ParseOk(new_symbol(parser->ctx, token));
diff --git a/src/prelude.c b/src/prelude.c
index f810262..1389f28 100644
--- a/src/prelude.c
+++ b/src/prelude.c
@@ -1,6 +1,6 @@
#include "prelude.h"
-const char *bamboo_lisp_prelude = "(defvar nil \'())\n\n(defvar pi 3.1415926)\n\n(defmacro incq (i)\n `(setq ,i (+ ,i 1)))\n\n(defmacro decq (i)\n `(setq ,i (- ,i 1)))\n\n(defun zerop (x) (= x 0))\n";
+const char *bamboo_lisp_prelude = "(defvar nil \'())\n\n(defvar pi 3.1415926)\n\n(defmacro incq (i)\n `(setq ,i (+ ,i 1)))\n\n(defmacro decq (i)\n `(setq ,i (- ,i 1)))\n\n(defun zerop (x) (= x 0))\n\n(defmacro when (pred . body)\n `(if ,pred\n (progn ,@body)\n nil))\n\n(defmacro unless (pred . body)\n `(if ,pred\n nil\n (progn ,@body)))\n";
diff --git a/src/prelude.lisp b/src/prelude.lisp
index 3e7ab81..7b49977 100644
--- a/src/prelude.lisp
+++ b/src/prelude.lisp
@@ -9,3 +9,13 @@
`(setq ,i (- ,i 1)))
(defun zerop (x) (= x 0))
+
+(defmacro when (pred . body)
+ `(if ,pred
+ (progn ,@body)
+ nil))
+
+(defmacro unless (pred . body)
+ `(if ,pred
+ nil
+ (progn ,@body)))
diff --git a/src/primitives.c b/src/primitives.c
index 435080c..87c266e 100644
--- a/src/primitives.c
+++ b/src/primitives.c
@@ -1,6 +1,76 @@
#include "primitives.h"
#include "interp.h"
#include "sexp.h"
+#include "parser.h"
+
+SExpRef primitive_assert_error(Interp *interp, SExpRef args, bool istail) {
+ SExpRef eargs = lisp_eval_args(interp, args);
+ if (VALTYPE(eargs) == kErrSignal) return interp->t;
+ return new_error(interp, "assert-error failed: no error.\n");
+}
+
+SExpRef primitive_load(Interp *interp, SExpRef args, bool istail) {
+ if (CAR(interp->stack).idx != interp->top_level.idx) {
+ return new_error(interp, "load: load can only be in top level.\n");
+ }
+ if (LENGTH(args) != 1) return new_error(interp, "load: syntax error.\n");
+ if (VALTYPE(CAR(args)) != kStringSExp) return new_error(interp, "load: syntax error.\n");
+ Parser *old_parser = interp->parser;
+ Parser *new_parser = malloc(sizeof(Parser));
+ Parser_init(new_parser);
+ new_parser->ctx = interp;
+ interp->parser = new_parser;
+ SExpRef ret = Interp_load_file(interp, REF(CAR(args))->str);
+ Parser_free(new_parser);
+ free(new_parser);
+ interp->parser = old_parser;
+ return ret;
+}
+
+SExpRef primitive_return(Interp *interp, SExpRef args, bool istail) {
+ if (LENGTH(args) > 1) {
+ return new_error(interp, "return: syntax error.\n");
+ }
+ SExpRef ret = NIL;
+ if (!NILP(args)) {
+ ret = lisp_eval(interp, CAR(args), true);
+ }
+ return new_return(interp, ret);
+}
+
+SExpRef primitive_break(Interp *interp, SExpRef args, bool istail) {
+ if (LENGTH(args) > 0) {
+ return new_error(interp, "break: syntax error.\n");
+ }
+ return new_break(interp);
+}
+
+SExpRef primitive_continue(Interp *interp, SExpRef args, bool istail) {
+ if (LENGTH(args) > 0) {
+ return new_error(interp, "continue: syntax error.\n");
+ }
+ return new_continue(interp);
+}
+
+SExpRef primitive_assert(Interp *interp, SExpRef args, bool istail) {
+ SExpRef eargs = lisp_eval_args(interp, args);
+ if (LENGTH(args) != 1) {
+ return new_error(interp, "assert: expect 1 arg.\n");
+ }
+ if (TRUEP(CAR(eargs))) {
+ return interp->t;
+ } else {
+ const char *expstr = lisp_to_string(interp, args);
+ SExpRef ret = new_error(interp, "Assertion failed: %s.\n", expstr);
+ free((void*)expstr);
+ return ret;
+ }
+}
+
+SExpRef primitive_eval(Interp *interp, SExpRef args, bool istail) {
+ args = lisp_eval_args(interp, args);
+ return lisp_eval(interp, args, istail);
+}
SExpRef primitive_if(Interp *interp, SExpRef args, bool istail) {
SExpRef cond, tb, fb;
@@ -111,7 +181,10 @@ SExpRef primitive_let(Interp *interp, SExpRef args, bool istail) {
while (!NILP(iter)) {
x = CAR(iter);
val = EVAL(CADR(x));
- if (CTL_FL(val)) goto end;
+ if (CTL_FL(val)) {
+ ret = val;
+ goto end;
+ }
ret = lisp_setq(interp, REF(CAR(x))->str, val);
if (CTL_FL(ret)) goto end;
iter = CDR(iter);
@@ -127,7 +200,7 @@ SExpRef primitive_let(Interp *interp, SExpRef args, bool istail) {
} else {
ret = EVAL(exp);
}
- if (CTL_FL(val)) goto end;
+ if (CTL_FL(ret)) goto end;
iter = CDR(iter);
}
end:
@@ -154,7 +227,7 @@ nextloop:
}
return cond;
}
- if (!TRUEP(cond)) return ret;
+ if (!TRUEP(cond)) return NIL;
iter = body;
while (!NILP(iter)) {
x = CAR(iter);
@@ -163,7 +236,7 @@ nextloop:
return ret;
}
if (VALTYPE(ret) == kBreakSignal) {
- return REF(ret)->ret;
+ return NIL;
}
if (VALTYPE(ret) == kContinueSignal) {
goto nextloop;
@@ -358,7 +431,9 @@ static SExpRef quasi_on_list(Interp *interp, SExpRef lst) {
iter = lst;
while (!NILP(iter)) {
x = CAR(iter);
+ PUSH_REG(newlst);
newx = quasi_impl(interp, x, &slicing);
+ POP_REG();
if (CTL_FL(newx)) return newx;
if (slicing) {
j = newx;
diff --git a/src/primitives.h b/src/primitives.h
index 5e22ba9..f5dd8e8 100644
--- a/src/primitives.h
+++ b/src/primitives.h
@@ -3,6 +3,13 @@
#include "interp.h"
+SExpRef primitive_assert_error(Interp *interp, SExpRef sexp, bool istail);
+SExpRef primitive_load(Interp *interp, SExpRef sexp, bool istail);
+SExpRef primitive_return(Interp *interp, SExpRef sexp, bool istail);
+SExpRef primitive_break(Interp *interp, SExpRef sexp, bool istail);
+SExpRef primitive_continue(Interp *interp, SExpRef sexp, bool istail);
+SExpRef primitive_assert(Interp *interp, SExpRef sexp, bool istail);
+SExpRef primitive_eval(Interp *interp, SExpRef sexp, bool istail);
SExpRef primitive_if(Interp *interp, SExpRef sexp, bool istail);
SExpRef primitive_cond(Interp *interp, SExpRef sexp, bool istail);
SExpRef primitive_progn(Interp *interp, SExpRef sexp, bool istail);
generated by cgit v1.0 at 2025-12-29 19:20:25 +0000