Пример #1
0
lval* lval_call(lenv* env, lval* function, lval* args) {
    lval_func* func = function->data.func;
    
    if (func->builtin != NULL) {
        return func->builtin(env, args);
    }
    
    //Check arg counts
    LASSERT(args, func->formals->cell_count <= args->cell_count, LERR_SYNTAX,
            "lambda: insufficient arguments. Expected %ld got %ld", func->formals->cell_count, args->cell_count);
    
    for(int i = 0; i < func->formals->cell_count; i++) {
        lenv_put(func->env, func->formals->cell_list[i], args->cell_list[i]);
    }
    
    if (func->va != NULL) {
        lval* vaArgs = lval_q_expr();
        
        for(int i = func->formals->cell_count; i < args->cell_count; i ++ ) {
            lval_add(vaArgs, lval_copy(args->cell_list[i]));
        }
        
        lenv_put(func->env, func->va, vaArgs);
        lval_delete(vaArgs);
    }
    
    lval_delete(args);
    
    func->env->parent = env;
    
    return eval(func->env, lval_add(lval_s_expr(), lval_copy(func->body)));
}
Пример #2
0
int main(int argc, char* *argv){
    init_parser();
    lenv *e = lenv_new();
    lenv_add_builtins(e);
    if (access(STD_LIB, F_OK) != -1){
        lval *err = builtin_load(e, lval_add(lval_sexpr(), lval_str((char *)STD_LIB)));
        if (err->type == LVAL_ERR) lval_println(err);
        lval_del(err);
    } else {
        printf("Can't find stdlib at %s.\n", STD_LIB);
    }

    if (argc > 1){
        for (int i = 1; i < argc; i++){
            lval *args = lval_add(lval_sexpr(), lval_str(argv[i]));
            lval *x = builtin_load(e, args);

            if (x->type == LVAL_ERR) lval_println(x);
            lval_del(x);
        }
    } else {
        puts("Aroma Version v0.0.0.1");
        puts("Press Ctrl+C to Exit.");

        char *input = NULL;
        mpc_result_t r;

        while (true){
            input = readline(">>> ");
            if (strlen(input) < 1) {
                continue;
            }
            add_history(input);
            if (mpc_parse("<stdin>", input, Lispy, &r)){
                /* mpc_ast_print(r.output); */
                lval *x = lval_eval(e, lval_read(r.output));
                lval_println(x);
                lval_del(x);

                mpc_ast_delete(r.output);
            } else {
                mpc_err_print(r.error);
                mpc_err_delete(r.error);
            }
            /* printf("%s\n", input); */
            free(input);
        }
    }

    lenv_del(e);
    cleanup_parser();

    return 0;
}
Пример #3
0
int main(int argc, char** argv){
    puts("yafl Version 0.0.1");
    puts("Press CTRL+C to Exit\n");

    gen_parsers();
    lenv* e = lenv_new();
    lenv_add_builtins(e);
    lval* core = lval_add(lval_sexpr(), lval_str("src/yfl/core.yfl"));
    //printf("gets here");
    lval* core_loaded = builtin_load(e, core);

    if(core_loaded->type == LVAL_ERR) {lval_println(core_loaded);}
    lval_del(core_loaded);

    if(argc >= 2){ //execute file
        for(int i = 1; i < argc; i++){

            lval* args = lval_add(lval_sexpr(), lval_str(argv[i]));

            lval* x = builtin_load(e, args);

            if(x->type == LVAL_ERR) { lval_println(x); }
            lval_del(x);
        }
    }
    else{ //Start REPL

        while(1){
            char* input = readline("yafl> ");
            add_history(input);
            mpc_result_t r;
            if(mpc_parse("<stdin>", input, Yafl, &r)){

                lval* x = lval_eval(e, lval_read(r.output));
                lval_println(x);
                lval_del(x);
                mpc_ast_delete(r.output);
            }else{
                mpc_err_print(r.error);
                mpc_err_delete(r.error);
            }

            free(input);
        }
    }

    teardown_parsers();
    return 0;
}
Пример #4
0
struct lval* lval_join(struct lval* v, struct lval* x) {
    while (x->count) {
        v = lval_add(v, lval_pop(x, 0));
    }
    lval_del(x);
    return v;
}
Пример #5
0
struct lval* lval_read(mpc_ast_t* node) {

    // Upwrap top-level form as a single expression
    if (strcmp(node->tag, ">") == 0) {
        return lval_read(node->children[1]);
    }

    if (strstr(node->tag, "number")) {
        return lval_read_num(node->contents);
    }
    if (strstr(node->tag, "symbol")) {
        return lval_sym(node->contents);
    }
    if (strstr(node->tag, "bool")) {
        return lval_read_bool(node->contents);
    }

    struct lval* x;
    if (strstr(node->tag, "sexp")) {
        x = lval_sexp();
    }
    else if (strstr(node->tag, "qexp")) {
        x = lval_qexp();
    }
    else {
        return lval_err("Unexpected node: %s", node->tag);
    }

    for (int i = 0; i < node->children_num; i++) {
        if (read_ignore(node->children[i])) continue;
        x = lval_add(x, lval_read(node->children[i]));
    }
    return x;
}
Пример #6
0
lval* lval_call(lenv* e, lval* f, lval* a){

    if(f->builtin) {
        return f->builtin(e,a);
    }

    int given = a->count;
    int total = f->formals->count;


    while(a->count){
        if(f->formals->count == 0){
            lval_del(a); return lval_err("too many args. expected %i, got %i",
                                         total, given);
        }

        lval* sym = lval_pop(f->formals, 0);

        if(strcmp(sym->sym, "&") == 0){
            if(f->formals->count != 1){
                lval_del(a);
                return lval_err("too many args after '&'.  only 1 allowed");
            }

            lval* nsym = lval_pop(f->formals, 0);
            lenv_put(f->env, nsym, builtin_list(e, a));
            lval_del(sym); lval_del(nsym);
            break;
        }

        lval* val = lval_pop(a, 0);
        lenv_put(f->env, sym, val);
        lval_del(sym);
        lval_del(val);
    }

    lval_del(a);

    if(f->formals->count >0 &&
       strcmp(f->formals->cell[0]->sym, "&") == 0){
        if(f->formals->count != 2){
            return lval_err("'&' should be followed by a single arg");
        }

        lval_del(lval_pop(f->formals, 0));

        lval* sym = lval_pop(f->formals, 0);
        lval* val = lval_qexpr();

        lenv_put(f->env, sym, val);
        lval_del(sym); lval_del(val);
    }

    if(f->formals->count == 0){
        f->env->par = e;
        return builtin_eval(f->env, lval_add(lval_sexpr(), lval_copy(f->body)));
    }else{
        return lval_copy(f);
    }
}
Пример #7
0
lval* lval_join(lval* a, lval* b) {
    while(b->cell_count > 0) {
        lval_add(a, lval_pop(b,0));
    }
    lval_delete(b);
    return a;
}
Пример #8
0
lval* lval_join(lval* x, lval* y) {
    while (y->count) {
        x = lval_add(x, lval_pop(y, 0));
    }

    lval_del(y);
    return x;
}
lval* lval_join(lval* x, lval* y) {
  for (int i = 0; i > y->count; i++) {
    x = lval_add(x, y->cell[i]);
  }
  free(y->cell);
  free(y);
  return x;
}
Пример #10
0
lval_t *lval_join(lval_t *a, lval_t *b) {
  /* Move all items from b -> a */
  while (b->count > 0) {
    lval_add(a, lval_pop(b, 0));
  }

  lval_del(b);
  return a;
}
Пример #11
0
struct lval* lval_builtin_cons(struct lenv* e, struct lval* v) {
    LNUMARGS(v, 2, "cons");
    LTYPE(v, LVAL_QEXP, 1, "cons");

    // New q-exp with first arg
    struct lval* x = lval_qexp();
    lval_add(x, lval_pop(v, 0));

    // Old q-exp from second arg
    struct lval* q = lval_take(v, 0);

    while (q->count) {
        lval_add(x, lval_pop(q, 0));
    }
    lval_del(q);

    return lval_eval(e, x);
}
Пример #12
0
lval* lval_join(lval* x, lval* y) {
  /* For each cell in 'y' add it to 'x' */
  while (y->count) {
    x = lval_add(x, lval_pop(y, 0));
  }

  /* Delete the empty 'y' and return 'x' */
  lval_del(y);
  return x;
}
Пример #13
0
//Appends element to beginning of list
lval* builtin_cons(lenv* e, lval* a) {
  LASSERT_NUM("cons", a, 2);
  LASSERT_TYPE("cons", a, 1, LVAL_QEXPR);

  lval* x = lval_qexpr();
  x = lval_add(x, lval_pop(a, 0));
  x = lval_join(x, lval_pop(a, 0));
  lval_del(a);
  return x;
}
Пример #14
0
struct lval* lval_eval_call(struct lenv* e, struct lval* f, struct lval* args) {
    if (f->fun_type == LVAL_FUN_BUILTIN) {
        return f->builtin(e, args);
    }

    int given = args->count;
    int total = f->args->count;

    while (args->count) {
        if (f->args->count == 0) {
            lval_del(args);
            return lval_err(
                       "Too many arguments. Got %i, expected %i.",
                       given, total
                   );
        }

        struct lval* sym = lval_pop(f->args, 0);

        if (strcmp(sym->sym, "&") == 0) {
            // varargs
            lval_del(sym);
            sym = lval_pop(f->args, 0);
            lenv_put(f->env, sym->sym, lval_builtin_list(e, args));
            lval_del(sym);
            break;
        }

        struct lval* val = lval_pop(args, 0);
        lenv_put(f->env, sym->sym, val);

        lval_del(sym);
        lval_del(val);
    }

    lval_del(args);

    if (f->args->count > 0) {
        if (strcmp(f->args->cell[0]->sym, "&") != 0) {
            return lval_copy(f);
        }
        // Got all args except varargs, so produce empty list
        struct lval* val = lval_qexp();
        lenv_put(f->env, f->args->cell[1]->sym, val);
        lval_del(val);
    }

    f->env->parent = e;

    struct lval* sexp = lval_sexp();
    lval_add(sexp, lval_copy(f->body));

    return lval_builtin_eval(f->env, sexp);
}
Пример #15
0
struct lval* lval_builtin_if(struct lenv* e, struct lval* v) {
    LNUMARGS(v, 3, "if");
    LTYPE(v, LVAL_BOOL, 0, "if");
    LTYPE(v, LVAL_QEXP, 1, "if");
    LTYPE(v, LVAL_QEXP, 2, "if");

    int result = v->cell[0]->flag;

    struct lval* x = lval_sexp();
    lval_add(x, lval_take(v, result ? 1 : 2));

    return lval_builtin_eval(e, x);
}
Пример #16
0
lval *lval_read(mpc_ast_t *t) {
    if (strstr(t->tag, "long")) {
        return lval_read_long(t);
    }
    if (strstr(t->tag, "double")) {
        return lval_read_double(t);
    }
    if (strstr(t->tag, "symbol")) {
        return lval_sym(t->contents);
    }

    lval *x = NULL;
    if (strcmp(t->tag, ">") == 0) {
        x = lval_sexpr();
    }
    if (strstr(t->tag, "sexpr")) {
        x = lval_sexpr();
    }
    if (strstr(t->tag, "qexpr")) {
        x = lval_qexpr();
    }

    for (int i = 0; i < t->children_num; i++) {
        mpc_ast_t *child = t->children[i];
        char *contents = child->contents;
        if (strcmp(contents, "(") == 0) {
            continue;
        }
        if (strcmp(contents, ")") == 0) {
            continue;
        }
        if (strcmp(contents, "{") == 0) {
            continue;
        }
        if (strcmp(contents, "}") == 0) {
            continue;
        }

        if (strcmp(child->tag, "regex") == 0) {
            continue;
        }

        x = lval_add(x, lval_read(child));
    }

    return x;
}
Пример #17
0
lval* lval_read(mpc_ast_t* t) {
  if (strstr(t->tag, "number")) { return lval_read_num(t); }
  if (strstr(t->tag, "symbol")) { return lval_sym(t->contents); }

  lval* x = NULL;
  if (strcmp(t->tag, ">") == 0) { x = lval_sexpr(); } 
  if (strstr(t->tag, "sexpr"))  { x = lval_sexpr(); }
  if (strstr(t->tag, "qexpr"))  { x = lval_qexpr(); }

  for (int i = 0; i < t->children_num; i++) {
    if (strcmp(t->children[i]->contents, "(") == 0) { continue; }
    if (strcmp(t->children[i]->contents, ")") == 0) { continue; }
    if (strcmp(t->children[i]->contents, "}") == 0) { continue; }
    if (strcmp(t->children[i]->contents, "{") == 0) { continue; }
    if (strcmp(t->children[i]->tag,  "regex") == 0) { continue; }
    x = lval_add(x, lval_read(t->children[i]));
  }

  return x;
}
Пример #18
0
int main(int argc, char** argv) {

    init_parser();

    /* initialize environment */
    lenv* e = lenv_new();
    lenv_add_builtins(e);

    /* load standard library functions */
    lval* x = builtin_load(e, lval_add(lval_sexpr(), lval_str("prelude.lsp")));
    if (x->type == LVAL_ERR) { lval_println(x); }
    lval_del(x);

    if (argc >= 2) {

        /* read from command line */
        parse_args(e, argc, argv);

    } else {

        /* interactive prompt */
        say_hello();
        while (1) {
            char* input = prompt();
            lval* x = parse(input);
            if (x != NULL) {
                x = lval_eval(e, x);
                lval_println(x);
                lval_del(x);
            }
            free(input);
        }

    }

    /* cleanup */
    lenv_del(e);
    free_parser();

    return 0;
}
Пример #19
0
lval* lval_read(mpc_ast_t* t) {

  /* If Symbol or Number return conversion to that type */
  if (strstr(t->tag, "number")) { return lval_read_num(t); }
  if (strstr(t->tag, "symbol")) { return lval_sym(t->contents); }

  /* If root (>) or sexpr then create empty list */
  lval* x = NULL;
  if (strcmp(t->tag, ">") == 0) { x = lval_sexpr(); }
  if (strstr(t->tag, "sexpr"))  { x = lval_sexpr(); }

  /* Fill this list with any valid expression contained within */
  for (int i = 0; i < t->children_num; i++) {
    if (strcmp(t->children[i]->contents, "(") == 0) { continue; }
    if (strcmp(t->children[i]->contents, ")") == 0) { continue; }
    if (strcmp(t->children[i]->contents, "}") == 0) { continue; }
    if (strcmp(t->children[i]->contents, "{") == 0) { continue; }
    if (strcmp(t->children[i]->tag,  "regex") == 0) { continue; }
    x = lval_add(x, lval_read(t->children[i]));
  }

  return x;
}
Пример #20
0
lval* lval_read(mpc_ast_t* t)
{
    if (strstr(t->tag, "number")) { return lval_read_num(t); }
    if (strstr(t->tag, "symbol")) { return lval_symbol(t->contents); }
    if (strstr(t->tag, "string")) { return lval_read_str(t); }

    // if root (>) or sexpr, cearte an empty lval_sexpr.
    lval *x = NULL;
    if (strcmp(t->tag, ">") == 0) { x = lval_sexpr(); }
    if (strstr(t->tag, "sexpr")) { x = lval_sexpr(); }
    if (strstr(t->tag, "qexpr")) { x = lval_qexpr(); }

    for (int i = 0; i < t->children_num; i++) {
        if (strcmp(t->children[i]->contents, "(") == 0) { continue; }
        if (strcmp(t->children[i]->contents, ")") == 0) { continue; }
        if (strcmp(t->children[i]->contents, "{") == 0) { continue; }
        if (strcmp(t->children[i]->contents, "}") == 0) { continue; }
        if (strcmp(t->children[i]->tag, "regex") == 0) { continue; }
        if (strstr(t->children[i]->tag, "comment")) { continue; }
        x = lval_add(x, lval_read(t->children[i]));
    }

    return x;
}
Пример #21
0
lval *lval_read(mpc_ast_t *t)
{
  // convert symbols and nums to lvals
  if (strstr(t->tag, "number")) { return lval_read_num(t); }
  if (strstr(t->tag, "symbol")) { return lval_sym(t->contents); }

  // if root or sexpr creat empty list
  lval *x = NULL;
  if (strcmp(t->tag, ">") == 0) { x = lval_sexpr(); }
  if (strstr(t->tag, "sexpr"))  { x = lval_sexpr(); }
  if (strstr(t->tag, "qexpr"))  { x = lval_qexpr(); }

  // fill list with any valid expr contained within
  for (int i = 0; i < t->children_num; i++)
  {
    if (strcmp(t->children[i]->contents, "(") == 0) { continue; }
    if (strcmp(t->children[i]->contents, ")") == 0) { continue; }
    if (strcmp(t->children[i]->contents, "{") == 0) { continue; }
    if (strcmp(t->children[i]->contents, "}") == 0) { continue; }
    if (strcmp(t->children[i]->tag,  "regex") == 0) { continue; }
    x = lval_add(x, lval_read(t->children[i]));
  }
  return x;
}
Пример #22
0
lval* lval_call(lenv* e, lval* f, lval* a) {

  if (f->builtin) { return f->builtin(e, a); }

  int given = a->count;
  int total = f->formals->count;

  while (a->count) {

    if (f->formals->count == 0) {
      lval_del(a); return lval_err(
        "Function passed too many arguments. "
        "Got %i, Expected %i.", given, total); 
    }

    lval* sym = lval_pop(f->formals, 0);

    lval* val = lval_pop(a, 0);

    lenv_put(f->env, sym, val);

    lval_del(sym); lval_del(val);
  }

  lval_del(a);

  if (f->formals->count == 0) {

    f->env->par = e;

    return builtin_eval(
      f->env, lval_add(lval_sexpr(), lval_copy(f->body)));
  } else {
    return lval_copy(f);
  }
}
Пример #23
0
int main(int argc, char** argv) {
    // Initialization
    parser_init();
    lenv* env = lenv_new();
    builtins_init(env);

    if (argc >= 2) {
        // Loop over file names
        for (int i = 1; i < argc; i++) {
            lval* args   = lval_add(lval_sexpr(), lval_str(argv[i]));
            lval* result = builtin_load(env, args);

            if (result->type == LVAL_ERR) {
                lval_println(env, result);
            }
            lval_del(result);
        }
    } else {
        // Welcome message
        puts("MLisp Version 0.1dev");
        puts("Enter 'quit' to exit\n");

        while (1) {
            char* input = read_input();
            add_history(input);

            if (input == NULL || strstr(input, "exit") || strstr(input, "quit")) {
                puts("Bye!");
                if (input != NULL) {
                    xfree(input);
                }
                break;
            }

            lval* result = NULL;
            mpc_err_t* parser_error = NULL;

            if (parse("<stdin>", input, env, &result, &parser_error)) {
                if (!(result->type == LVAL_SEXPR && result->count == 0)) {
                    char* repr = lval_repr(env, result);
                    printf("%s\n", repr);
                    xfree(repr);
                }

                lval_del(result);
            } else {
                mpc_err_print(parser_error);
                mpc_err_delete(parser_error);
            }

            xfree(input);
        }
    }

    lenv_del(env);

    // Undefine and delete our parsers
    parser_cleanup();

    return 0;
}
Пример #24
0
lval *lval_call(lenv *e, lval *f, lval *a)
{
  if (f->builtin)
  {
    return f->builtin(e, a);
  }

  int given = a->count;
  int total = f->formals->count;

  while (a->count)
  {
    if (f->formals->count == 0)
    {
      lval_del(a);
      return lval_err("Function passed too many arguments\n"
        "  got %i expected %i", given, total);
    }
    lval *sym = lval_pop(f->formals, 0);

    if (strcmp(sym->sym, "&") == 0)
    {
      if (f->formals->count != 1)
      {
        lval_del(a);
        return lval_err("Function format invalid\n"
          "  symbol '&' not followed by single symbol");
      }
      lval *nsym = lval_pop(f->formals, 0);
      lenv_put(f->env, nsym, builtin_list(e, a));
      lval_del(sym);
      lval_del(nsym);
      break;
    }

    lval *val = lval_pop(a, 0);
    lenv_put(f->env, sym, val);
    lval_del(sym);
    lval_del(val);
  }
  lval_del(a);

  if (f->formals->count > 0 && strcmp(f->formals->cell[0]->sym, "&") == 0)
  {
    if (f->formals->count != 2)
    {
      return lval_err("Function format invalid\n"
        "  symbol '&' not followed by single symbol");
    }

    lval_del(lval_pop(f->formals, 0));
    lval *sym = lval_pop(f->formals, 0);
    lval *val = lval_qexpr();
    lval_del(sym);
    lval_del(val);
  }

  if (f->formals->count == 0)
  {
    f->env->par = e;
    return builtin_eval(f->env, lval_add(lval_sexpr(), lval_copy(f->body)));
  }
  else
  {
    return lval_copy(f);
  }
}
Пример #25
0
lval *lval_call(lenv *e, lval *f, lval *a){
    if (f->builtin){ return f->builtin(e, a); }

    int given = a->count;
    int required = f->formals->count;

    while (a->count){
        if (f->formals->count == 0){
            lval_del(a);
            return lval_err("Function passed too many arguments."
                            "Expected %d, got %d.", required, given);
        }

        lval *sym = lval_pop(f->formals, 0);

        if (strcmp(sym->sym, "&") == 0){
            /* Ensure & is followed by another symbol */
            if (f->formals->count != 1){
                lval_del(a);
                return lval_err("& not followed by single symbol");
            }

            /* Bound next formal to remaining arguments */
            lval *nsym = lval_pop(f->formals, 0);
            lenv_set(f->env, nsym, builtin_list(e, a));
            lval_del(sym);
            lval_del(nsym);
            break;
        }

        /* Take out the argument */
        lval *val = lval_pop(a, 0);

        /* Bound to sym */
        lenv_set(f->env, sym, val);

        lval_del(sym);
        lval_del(val);
    }

    lval_del(a);

    /* If & remaining in argument list, bound to () */
    if (f->formals->count > 0 && 
        strcmp(f->formals->cell[0]->sym, "&") == 0){

        /* Ensure & is not passed invalidly */
        if(f->formals->count != 2){
            return lval_err("& not followed by single symbol");
        }

        /* Delete & */
        lval_del(lval_pop(f->formals, 0));

        /* pop next formal */
        lval *sym = lval_pop(f->formals, 0);

        lval *empty = lval_qexpr();

        lenv_set(f->env, sym, empty);
        lval_del(sym);
        lval_del(empty);
    }


    if (f->formals->count == 0){
        f->env->parent = e;

        return builtin_eval(f->env, lval_add(lval_sexpr(), lval_copy(f->body)));
    } else {
        return lval_copy(f);
    }
}
Пример #26
0
int main(int argc, char** argv) {
    
    printf("KLisp Version %s\n", VERSION);
    
    //Init environment
    lenv* env = lenv_new();
    lenv_add_builtin_funcs(env);
    setup_parsers();
    
    //Attempt to import/run files specified on the command line
    if (argc > 1) {
        for(int i = 1; i < argc; i++) {
            lval* loadargs = lval_add(lval_s_expr(), lval_str(argv[i]));
            
            lval* result = builtin_load(env, loadargs);
            
            if (result->type == LVAL_ERR) {
                lval_println(result);
            }
            
            lval_delete(result);
        }
    }
    
    int exitcode = EXIT_SUCCESS;
    
    while(1) {
        char *input = readline("> ");
        if (NULL == input) {
            break;
        }
        add_history(input);
        
        mpc_ast_t* ast_result = tokenize(input);
        
        free(input);
        
        if (ast_result != NULL) {
            
            //Parse the ast
            lval* result = parse(ast_result);
            if (result == NULL) {
                result = lval_err(LERR_OTHER);
            }
            
            //Evaluate
            result = eval(env, result);
            
            BOOL exit = FALSE;
            if (result != NULL && result->type == LVAL_EXIT) {
                exit = TRUE;
                exitcode = result->data.exitcode;
            } else {
                //print the result
                lval_println(result);
            }
            
            //Cleanup
            lval_delete(result);
            mpc_ast_delete(ast_result);
            
            if (exit == TRUE) {;
                break;
            }
        }
        
    }
    
    lenv_delete(env);
    cleanup_parsers();
    
    return (exitcode);
}
lval* lval_call(lenv* e, lval* f, lval* a) {

  /* If Builtin then simply apply that */
  if (f->builtin) { return f->builtin(e, a); }

  /* Record Argument Counts */
  int given = a->count;
  int total = f->formals->count;

  /* While arguments still remain to be processed */
  while (a->count) {

    /* If we've ran out of formal arguments to bind */
    if (f->formals->count == 0) {
      lval_del(a);
      return lval_err("Function passed too many arguments. Got %i, Expected %i.", given, total);
    }

    /* Pop the first symbol from the formals */
    lval* sym = lval_pop(f->formals, 0);

    /* Special Case to deal with '&' */
    if (strcmp(sym->sym, "&") == 0) {

      /* Ensure '&' is followed by another symbol */
      if (f->formals->count != 1) {
        lval_del(a);
        return lval_err("Function format invalid. Symbol '&' not followed by single symbol.");
      }

      /* Next formal should be bound to remaining arguments */
      lval* nsym = lval_pop(f->formals, 0);
      lenv_put(f->env, nsym, builtin_list(e, a));
      lval_del(sym); lval_del(nsym);
      break;
    }

    /* Pop the next argument from the list */
    lval* val = lval_pop(a, 0);

    /* Bind a copy into the function's environment */
    lenv_put(f->env, sym, val);

    /* Delete symbol and value */
    lval_del(sym); lval_del(val);
  }

  /* Argument list is now bound so can be cleaned up */
  lval_del(a);

  /* If '&' remains in formal list it should be bound to empty list */
  if (f->formals->count > 0 &&
    strcmp(f->formals->cell[0]->sym, "&") == 0) {

    /* Check to ensure that & is not passed invalidly. */
    if (f->formals->count != 2) {
      return lval_err("Function format invalid. Symbol '&' not followed by single symbol.");
    }

    /* Pop and delete '&' symbol */
    lval_del(lval_pop(f->formals, 0));

    /* Pop next symbol and create empty list */
    lval* sym = lval_pop(f->formals, 0);
    lval* val = lval_qexpr();

    /* Bind to environment and delete */
    lenv_put(f->env, sym, val);
    lval_del(sym); lval_del(val);
  }

  /* If all formals have been bound evaluate */
  if (f->formals->count == 0) {

    /* Set Function Environment parent to current evaluation Environment */
    f->env->par = e;

    /* Evaluate and return */
    return builtin_eval(f->env, lval_add(lval_sexpr(), lval_copy(f->body)));
  } else {
    /* Otherwise return partially evaluated function */
    return lval_copy(f);
  }

}
Пример #28
0
lval* lval_call(lenv* e, lval* f, lval* a) {
    if (f->builtin) {
        return f->builtin(e, a);
    }

    int given = a->count;
    int total = f->formals->count;

    while (a->count) {
        if (f->formals->count == 0) {
            lval_del(a);
            return lval_err("Function passed too many arguments. Expected %i, Got %i.", total, given);
        }

        lval* sym = lval_pop(f->formals, 0);

        // Variadic operator
        if (strcmp(sym->sym, "&") == 0){
            if (f->formals->count != 1) {
                lval_del(a);
                return lval_err("Function format invalid. "
                        "Symbol '&' not followed by a single symbol");
            }

            lval* nsym = lval_pop(f->formals, 0);
            lenv_put(f->env, nsym, builtin_list(e, a));
            lval_del(sym);
            lval_del(nsym);
            break;
        }

        lval* val = lval_pop(a, 0);
        lenv_put(f->env, sym, val);
        lval_del(val);
        lval_del(sym);
    }

    lval_del(a);

    // If '&' remains in formal list bind to empty list
    if (f->formals->count > 0 &&
            strcmp(f->formals->cell[0]->sym, "&") == 0) {
        if (f->formals->count != 2) {
            return lval_err("Function format invalid. "
                    "Symbol '&' not followed by a single symbol");
        }

        lval_del(lval_pop(f->formals, 0));

        lval* sym = lval_pop(f->formals, 0);
        lval* val = lval_qexpr();

        lenv_put(f->env, sym, val);
        lval_del(val);
        lval_del(sym);
    }

    if (f->formals->count == 0) {
        f->env->par = e;
        return builtin_eval(f->env, lval_add(lval_sexpr(), lval_copy(f->body)));
    } else {
        return lval_copy(f);
    }
}