-#include <assert.h>
+#include "system/stacktrace.h"
#include <math.h>
#include <string.h>
+#include <stdarg.h>
+#include <stdbool.h>
#include "./builtins.h"
#include "./expr.h"
wrong_argument_type(Gc *gc, const char *type, struct Expr obj)
{
return eval_failure(
- list(gc, 3,
- SYMBOL(gc, "wrong-argument-type"),
- SYMBOL(gc, type),
- obj));
+ list(gc, "qqe", "wrong-argument-type", type, obj));
}
struct EvalResult
NUMBER(gc, count)));
}
-static struct EvalResult length(Gc *gc, struct Expr obj)
+struct EvalResult
+not_implemented(Gc *gc)
{
- if (!list_p(obj)) {
- return wrong_argument_type(gc, "listp", obj);
- }
+ return eval_failure(SYMBOL(gc, "not-implemented"));
+}
- return eval_success(NUMBER(gc, length_of_list(obj)));
+struct EvalResult
+read_error(Gc *gc, const char *error_message, long int character)
+{
+ return eval_failure(
+ list(gc, "qsd", "read-error", error_message, character));
}
static struct EvalResult eval_atom(Gc *gc, struct Scope *scope, struct Atom *atom)
switch (atom->type) {
case ATOM_NUMBER:
case ATOM_STRING:
+ case ATOM_LAMBDA:
case ATOM_NATIVE:
return eval_success(atom_as_expr(atom));
case ATOM_SYMBOL: {
- if (nil_p(atom_as_expr(atom))) {
- return eval_success(atom_as_expr(atom));
- }
-
struct Expr value = get_scope_value(scope, atom_as_expr(atom));
if (nil_p(value)) {
args));
}
-static struct EvalResult plus_op(Gc *gc, struct Expr args)
-{
- long int result = 0.0f;
-
- while (!nil_p(args)) {
- if (args.type != EXPR_CONS) {
- return eval_failure(CONS(gc,
- SYMBOL(gc, "expected-cons"),
- args));
- }
-
- if (args.cons->car.type != EXPR_ATOM ||
- args.cons->car.atom->type != ATOM_NUMBER) {
- return eval_failure(CONS(gc,
- SYMBOL(gc, "expected-number"),
- args.cons->car));
- }
-
- result += args.cons->car.atom->num;
- args = args.cons->cdr;
- }
-
- return eval_success(atom_as_expr(create_number_atom(gc, result)));
-}
-
static struct EvalResult call_lambda(Gc *gc,
- struct Scope *scope,
struct Expr lambda,
struct Expr args) {
if (!lambda_p(lambda)) {
args));
}
- struct Expr vars = lambda.cons->cdr.cons->car;
+ struct Expr vars = lambda.atom->lambda.args_list;
if (length_of_list(args) != length_of_list(vars)) {
return eval_failure(CONS(gc,
NUMBER(gc, length_of_list(args))));
}
- push_scope_frame(gc, scope, vars, args);
- struct Expr body = lambda.cons->cdr.cons->cdr;
+ struct Scope scope = {
+ .expr = lambda.atom->lambda.envir
+ };
+ push_scope_frame(gc, &scope, vars, args);
+
+ struct Expr body = lambda.atom->lambda.body;
struct EvalResult result = eval_success(NIL(gc));
while (!nil_p(body)) {
- result = eval(gc, scope, body.cons->car);
+ result = eval(gc, &scope, body.cons->car);
if (result.is_error) {
return result;
}
body = body.cons->cdr;
}
- pop_scope_frame(gc, scope);
-
return result;
}
-static struct EvalResult call_callable(Gc *gc,
- struct Scope *scope,
- struct Expr callable,
- struct Expr args) {
- if (callable.type == EXPR_ATOM && callable.atom->type == ATOM_NATIVE) {
- return ((NativeFunction)callable.atom->native.fun)(callable.atom->native.param, gc, scope, args);
+static struct EvalResult eval_funcall(Gc *gc,
+ struct Scope *scope,
+ struct Expr callable_expr,
+ struct Expr args_expr) {
+ struct EvalResult callable_result = eval(gc, scope, callable_expr);
+ if (callable_result.is_error) {
+ return callable_result;
}
- return call_lambda(gc, scope, callable, args);
-}
-
-static struct EvalResult eval_funcall(Gc *gc, struct Scope *scope, struct Cons *cons)
-{
- assert(cons);
- (void) scope;
-
- if (symbol_p(cons->car)) {
- if (strcmp(cons->car.atom->sym, "+") == 0) {
- struct EvalResult args = eval_all_args(gc, scope, cons->cdr);
- if (args.is_error) {
- return args;
- }
- return plus_op(gc, args.expr);
- } else if (strcmp(cons->car.atom->sym, "set") == 0) {
- struct Expr args = cons->cdr;
- struct EvalResult n = length(gc, args);
+ struct EvalResult args_result = symbol_p(callable_expr) && is_special(callable_expr.atom->sym)
+ ? eval_success(args_expr)
+ : eval_all_args(gc, scope, args_expr);
- if (n.is_error) {
- return n;
- }
-
- if (n.expr.atom->num != 2) {
- return eval_failure(list(gc, 3,
- SYMBOL(gc, "wrong-number-of-arguments"),
- SYMBOL(gc, "set"),
- NUMBER(gc, n.expr.atom->num)));
- }
-
- struct Expr name = args.cons->car;
- if (!symbol_p(name)) {
- return eval_failure(list(gc, 3,
- SYMBOL(gc, "wrong-type-argument"),
- SYMBOL(gc, "symbolp"),
- name));
- }
+ if (args_result.is_error) {
+ return args_result;
+ }
- struct EvalResult value = eval(gc, scope, args.cons->cdr.cons->car);
- if (value.is_error) {
- return value;
- }
+ if (callable_result.expr.type == EXPR_ATOM &&
+ callable_result.expr.atom->type == ATOM_NATIVE) {
+ return ((NativeFunction)callable_result.expr.atom->native.fun)(
+ callable_result.expr.atom->native.param, gc, scope, args_result.expr);
+ }
- set_scope_value(gc, scope, name, value.expr);
+ return call_lambda(gc, callable_result.expr, args_result.expr);
+}
- return eval_success(value.expr);
- } else if (strcmp(cons->car.atom->sym, "quote") == 0) {
- /* TODO(#334): quote does not check the amout of it's arguments */
- return eval_success(cons->cdr.cons->car);
- } else if (strcmp(cons->car.atom->sym, "begin") == 0) {
- struct Expr head = CDR(cons_as_expr(cons));
- struct EvalResult eval_result = eval_success(NIL(gc));
+struct EvalResult eval_block(Gc *gc, struct Scope *scope, struct Expr block)
+{
+ trace_assert(gc);
+ trace_assert(scope);
- while (cons_p(head)) {
- eval_result = eval(gc, scope, CAR(head));
- if (eval_result.is_error) {
- return eval_result;
- }
+ if (!list_p(block)) {
+ return wrong_argument_type(gc, "listp", block);
+ }
- head = CDR(head);
- }
+ struct Expr head = block;
+ struct EvalResult eval_result = eval_success(NIL(gc));
+ while (cons_p(head)) {
+ eval_result = eval(gc, scope, CAR(head));
+ if (eval_result.is_error) {
return eval_result;
- } else if (strcmp(cons->car.atom->sym, "lambda") == 0) {
- /* TODO(#335): lambda special form doesn't check if it forms a callable object */
- return eval_success(cons_as_expr(cons));
}
- }
-
- struct EvalResult r = eval_all_args(gc, scope, cons_as_expr(cons));
- if (r.is_error) {
- return r;
+ head = CDR(head);
}
- return call_callable(gc, scope, r.expr.cons->car, r.expr.cons->cdr);
+ return eval_result;
}
struct EvalResult eval(Gc *gc, struct Scope *scope, struct Expr expr)
return eval_atom(gc, scope, expr.atom);
case EXPR_CONS:
- return eval_funcall(gc, scope, expr.cons);
+ return eval_funcall(gc, scope, expr.cons->car, expr.cons->cdr);
default: {}
}
car(void *param, Gc *gc, struct Scope *scope, struct Expr args)
{
(void) param;
- assert(gc);
- assert(scope);
+ trace_assert(gc);
+ trace_assert(scope);
- if (!list_p(args)) {
- return wrong_argument_type(gc, "listp", args);
- }
+ struct Expr xs = NIL(gc);
- if (length_of_list(args) != 1) {
- return wrong_number_of_arguments(gc, length_of_list(args));
+ struct EvalResult result = match_list(gc, "e", args, &xs);
+ if (result.is_error) {
+ return result;
}
- struct Expr xs = args.cons->car;
-
if (nil_p(xs)) {
return eval_success(xs);
}
- return eval_success(xs.cons->car);
+ if (!cons_p(xs)) {
+ return wrong_argument_type(gc, "consp", xs);
+ }
+
+ return eval_success(CAR(xs));
}
-void load_std_library(Gc *gc, struct Scope *scope)
+struct EvalResult
+match_list(struct Gc *gc, const char *format, struct Expr xs, ...)
{
- set_scope_value(
- gc,
- scope,
- SYMBOL(gc, "car"),
- NATIVE(gc, car, NULL));
+ va_list args_list;
+ va_start(args_list, xs);
+
+ long int i = 0;
+ for (i = 0; *format != 0 && !nil_p(xs); ++i) {
+ if (!cons_p(xs)) {
+ va_end(args_list);
+ return wrong_argument_type(gc, "consp", xs);
+ }
+
+ struct Expr x = CAR(xs);
+
+ switch (*format) {
+ case 'd': {
+ if (!number_p(x)) {
+ va_end(args_list);
+ return wrong_argument_type(gc, "numberp", x);
+ }
+
+ long int *p = va_arg(args_list, long int *);
+ if (p != NULL) {
+ *p = x.atom->num;
+ }
+ } break;
+
+ case 's': {
+ if (!string_p(x)) {
+ va_end(args_list);
+ return wrong_argument_type(gc, "stringp", x);
+ }
+
+ const char **p = va_arg(args_list, const char**);
+ if (p != NULL) {
+ *p = x.atom->str;
+ }
+ } break;
+
+ case 'q': {
+ if (!symbol_p(x)) {
+ va_end(args_list);
+ return wrong_argument_type(gc, "symbolp", x);
+ }
+
+ const char **p = va_arg(args_list, const char**);
+ if (p != NULL) {
+ *p = x.atom->sym;
+ }
+ } break;
+
+ case 'e': {
+ struct Expr *p = va_arg(args_list, struct Expr*);
+ *p = x;
+ } break;
+
+ case '*': {
+ struct Expr *p = va_arg(args_list, struct Expr*);
+ if (p != NULL) {
+ *p = xs;
+ }
+ xs = NIL(gc);
+ } break;
+ }
+
+ format++;
+ if (!nil_p(xs)) {
+ xs = CDR(xs);
+ }
+ }
+
+ if (*format == '*' && nil_p(xs)) {
+ struct Expr *p = va_arg(args_list, struct Expr*);
+ if (p != NULL) {
+ *p = NIL(gc);
+ }
+ format++;
+ }
+
+ if (*format != 0 || !nil_p(xs)) {
+ va_end(args_list);
+ return wrong_number_of_arguments(gc, i);
+ }
+
+ va_end(args_list);
+ return eval_success(NIL(gc));
}
projects / nothing.git / blobdiff