Exemplo n.º 1
0
/**
 * (append list ...)
 */
lv_t *p_append(lexec_t *exec, lv_t *v) {
    lv_t *r;
    lv_t *tptr, *vptr;

    assert(exec && v);
    assert((v->type == l_pair) || (v->type == l_null));

    rt_assert(c_list_length(v) > 1, le_arity, "expecting at least 1 arg");

    r = L_CAR(v);
    vptr = L_CDR(v);

    while(vptr) {
        r = lisp_dup_item(r);
        if(r->type == l_null)
            r = L_CAR(vptr);
        else {
            tptr = r;
            while(L_CDR(tptr))
                tptr = L_CDR(tptr);
            L_CDR(tptr) = L_CAR(vptr);
        }
        vptr = L_CDR(vptr);
    }

    return r;
}
Exemplo n.º 2
0
lv_t *p_load(lexec_t *exec, lv_t *v) {
    assert(v && exec);
    rt_assert(c_list_length(v) == 1, le_arity, "load arity");
    rt_assert(L_CAR(v)->type == l_str, le_type, "filename must be string");

    return c_sequential_eval(exec, c_parse_file(exec, L_STR(L_CAR(v))));
}
Exemplo n.º 3
0
/**
 * map a function onto a list, returning the
 * resulting list
 */
lv_t *lisp_map(lexec_t *exec, lv_t *v) {
    lv_t *vptr;
    lv_t *result = lisp_create_pair(NULL, NULL);
    lv_t *rptr = result;
    lv_t *fn, *list;

    assert(exec);

    fn = L_CAR(v);
    list = L_CDR(v);

    rt_assert(fn->type == l_fn, le_type, "map with non-function");
    rt_assert((list->type == l_pair) || (list->type == l_null),
              le_type, "map to non-list");

    if(list->type == l_null)
        return list;

    vptr = list;

    while(vptr) {
        L_CAR(rptr) = L_FN(fn)(exec, L_CAR(vptr));
        vptr=L_CDR(vptr);
        if(vptr) {
            L_CDR(rptr) = lisp_create_pair(NULL, NULL);
            rptr = L_CDR(rptr);
        }
    }

    return result;
}
Exemplo n.º 4
0
lv_t *p_not(lexec_t *exec, lv_t *v) {
    assert(v && exec);
    rt_assert(c_list_length(v) == 1, le_arity, "not arity");
    rt_assert(L_CAR(v)->type == l_bool, le_type, "not bool");

    return lisp_create_bool(!(L_BOOL(L_CAR(v))));
}
Exemplo n.º 5
0
lv_t *lisp_let_star(lexec_t *exec, lv_t *args, lv_t *expr) {
    lv_t *argp = args;
    lv_t *newenv;
    lv_t *result;

    newenv = lisp_create_pair(lisp_create_hash(), exec->env);

    rt_assert(args->type == l_null ||
              args->type == l_pair, le_type,
              "let arg type");

    lisp_exec_push_env(exec, newenv);

    if(args->type == l_pair) {
        /* walk through each element of the list,
           evaling k/v pairs and assigning them
           to an environment to run the expr in */
        while(argp && L_CAR(argp)) {
            rt_assert(c_list_length(L_CAR(argp)) == 2, le_arity,
                      "let arg arity");
            c_hash_insert(L_CAR(newenv), L_CAAR(argp),
                          lisp_eval(exec, L_CADAR(argp)));
            argp=L_CDR(argp);
        }
    }

    result = lisp_eval(exec, expr);
    lisp_exec_pop_env(exec);

    return result;
}
Exemplo n.º 6
0
/**
 * dup an object
 */
lv_t *lisp_dup_item(lv_t *v) {
    lv_t *r;
    lv_t *vptr = v;
    lv_t *rptr;
    assert(v);

    switch(v->type) {
    case l_int:
        r = lisp_create_int(0);
        mpz_set(L_INT(r), L_INT(v));
        return r;
    case l_rational:
        r = lisp_create_rational(1, 1);
        mpq_set(L_RAT(r), L_RAT(v));
        return r;
    case l_float:
        r = lisp_create_float(0.0);
        mpfr_set(L_FLOAT(r), L_FLOAT(v), MPFR_ROUND_TYPE);
        return r;
    case l_bool:
        return v;
    case l_sym:
        return lisp_create_symbol(L_SYM(v));
    case l_str:
        return lisp_create_string(L_STR(v));
    case l_null:
        return v;
    case l_port:
        /* can't really copy this -- it's a socket or a file
           handle, or something else.  */
        return v;
    case l_char:
        return lisp_create_char(L_CHAR(v));
    case l_fn:
        /* can't really copy this either, but it's essentially
           immutable */
        return v;
    case l_err:
        return lisp_create_err(L_ERR(v));
    case l_hash:
        /* FIXME: should really be a copy */
        return v;
    case l_pair:
        r = lisp_create_pair(NULL, NULL);
        rptr = r;

        while(vptr && L_CAR(vptr)) {
            L_CAR(rptr) = lisp_dup_item(L_CAR(vptr));
            vptr = L_CDR(vptr);
            if(vptr) {
                L_CDR(rptr) = lisp_create_pair(NULL, NULL);
                rptr = L_CDR(rptr);
            }
        }
        return r;
    }

    assert(0);
}
Exemplo n.º 7
0
/**
 * quasiquote a term
 */
lv_t *lisp_quasiquote(lexec_t *exec, lv_t *v) {
    lv_t *res;
    lv_t *vptr;
    lv_t *rptr;
    lv_t *v2, *v2ptr;

    /* strategy: walk through the list, expanding
       unquote and unquote-splicing terms */
    if(v->type == l_pair) {
        if (L_CAR(v)->type == l_sym &&
            !strcmp(L_SYM(L_CAR(v)), "unquote")) {
            rt_assert(c_list_length(L_CDR(v)) == 1, le_arity,
                      "unquote arity");
            return lisp_eval(exec, L_CADR(v));
        }

        /* quasi-quote and unquote-splice stuff */
        res = lisp_create_pair(NULL, NULL);
        rptr = res;
        vptr = v;
        while(vptr && L_CAR(vptr)) {
            if(L_CAR(vptr)->type == l_pair &&
               L_CAAR(vptr)->type == l_sym &&
               !strcmp(L_SYM(L_CAAR(vptr)), "unquote-splicing")) {
                /* splice this into result */
                rt_assert(c_list_length(L_CDAR(vptr)) == 1, le_arity,
                          "unquote-splicing arity");

                v2 = lisp_eval(exec, L_CAR(L_CDAR(vptr)));
                rt_assert(v2->type == l_pair || v2->type == l_null, le_type,
                          "unquote-splicing expects list");

                if(v2->type != l_null) {
                    v2ptr = v2;
                    while(v2ptr && L_CAR(v2ptr)) {
                        L_CAR(rptr) = L_CAR(v2ptr);
                        v2ptr = L_CDR(v2ptr);
                        if(v2ptr) {
                            L_CDR(rptr) = lisp_create_pair(NULL, NULL);
                            rptr = L_CDR(rptr);
                        }
                    }
                }
            } else {
                L_CAR(rptr) = lisp_quasiquote(exec, L_CAR(vptr));
            }

            vptr = L_CDR(vptr);
            if(vptr) {
                L_CDR(rptr) = lisp_create_pair(NULL, NULL);
                rptr = L_CDR(rptr);
            }
        }

        return res;
    } else {
        return v;
    }
}
Exemplo n.º 8
0
lv_t *p_set_car(lexec_t *exec, lv_t *v) {
    assert(v && exec);

    rt_assert(c_list_length(v) == 2, le_arity, "set-cdr arity");
    rt_assert(L_CAR(v)->type == l_pair, le_type, "set-car on non-pair");

    L_CAR(L_CAR(v)) = L_CADR(v);
    return lisp_create_null();
}
Exemplo n.º 9
0
lv_t *p_assert(lexec_t *exec, lv_t *v) {
    assert(v && exec);
    rt_assert(c_list_length(v) == 1, le_arity, "assert arity");
    rt_assert(L_CAR(v)->type == l_bool, le_type, "assert not bool");

    if(!L_BOOL(L_CAR(v)))
        rt_assert(0, le_internal, "error raised");

    return lisp_create_null();
}
Exemplo n.º 10
0
lv_t *p_warn(lexec_t *exec, lv_t *v) {
    assert(v && exec);
    rt_assert(c_list_length(v) == 1, le_arity, "warn arity");
    rt_assert(L_CAR(v)->type == l_bool, le_type, "warn not bool");

    if(!L_BOOL(L_CAR(v)))
        rt_assert(0, le_warn, "warning raised");

    return lisp_create_null();
}
Exemplo n.º 11
0
/**
 * print a value to a fd, in a debug form
 */
void lisp_dump_value(int fd, lv_t *v, int level) {
    switch(v->type) {
    case l_null:
        dprintf(fd, "()");
        break;
    case l_int:
        dprintf(fd, "%" PRIu64, L_INT(v));
        break;
    case l_float:
        dprintf(fd, "%0.16g", L_FLOAT(v));
        break;
    case l_bool:
        dprintf(fd, "%s", L_BOOL(v) ? "#t": "#f");
        break;
    case l_sym:
        dprintf(fd, "%s", L_SYM(v));
        break;
    case l_str:
        dprintf(fd, "\"%s\"", L_STR(v));
        break;
    case l_char:
        dprintf(fd, "#\%02x", L_CHAR(v));
        break;
    case l_pair:
        dprintf(fd, "(");
        lv_t *vp = v;
        while(vp && L_CAR(vp)) {
            lisp_dump_value(fd, L_CAR(vp), level + 1);
            if(L_CDR(vp) && (L_CDR(vp)->type != l_pair)) {
                dprintf(fd, " . ");
                lisp_dump_value(fd, L_CDR(vp), level + 1);
                vp = NULL;
            } else {
                vp = L_CDR(vp);
                dprintf(fd, "%s", vp ? " " : "");
            }
        }
        dprintf(fd, ")");
        break;
    case l_fn:
        if(L_FN(v) == NULL)
            dprintf(fd, "<lambda@%p>", v);
        else
            dprintf(fd, "<built-in@%p>", v);
        break;
    default:
        // missing a type check.
        assert(0);
    }
}
Exemplo n.º 12
0
lv_t *lisp_args_overlay(lexec_t *exec, lv_t *formals, lv_t *args) {
    lv_t *pf, *pa;
    lv_t *env_layer;

    assert(formals->type == l_pair ||
           formals->type == l_null ||
           formals->type == l_sym);
    assert(args->type == l_pair || args->type == l_null || args->type == l_sym);

    env_layer = lisp_create_hash();
    pf = formals;
    pa = args;

    /* no args */
    if(pf->type == l_null) {
        rt_assert(c_list_length(pa) == 0, le_arity, "too many arguments");
        return env_layer;
    }

    /* single arg gets the whole list */
    if(pf->type == l_sym) {
        c_hash_insert(env_layer, pf, lisp_dup_item(pa));
        return env_layer;
    }

    /* walk through the formal list, matching to args */
    while(pf && L_CAR(pf)) {
        rt_assert(pa && L_CAR(pa), le_arity, "not enough arguments");
        c_hash_insert(env_layer, L_CAR(pf), L_CAR(pa));
        pf = L_CDR(pf);
        pa = L_CDR(pa);

        if(pf && pf->type == l_sym) {
            /* improper list */
            if(!pa) {
                c_hash_insert(env_layer, pf, lisp_create_null());
            } else {
                c_hash_insert(env_layer, pf, lisp_dup_item(pa));
            }
            return env_layer;
        }

        rt_assert(!pf || pf->type == l_pair, le_type, "unexpected formal type");
    }

    rt_assert(!pa, le_arity, "too many arguments");

    return env_layer;
}
Exemplo n.º 13
0
/**
 * c helper for equalp
 */
int c_equalp(lv_t *a1, lv_t *a2) {
    int result = 0;

    if(a1->type != a2->type)
        return 0;

    switch(a1->type) {
    case l_int:
        result = (mpz_cmp(L_INT(a1), L_INT(a2)) == 0);
        break;
    case l_float:
        result = (mpfr_cmp(L_FLOAT(a1), L_FLOAT(a2)) == 0);
        break;
    case l_bool:
        if((L_BOOL(a1) == 0 && L_BOOL(a2) == 0) ||
           (L_BOOL(a1) != 0 && L_BOOL(a1) != 0))
            result = 1;
        break;
    case l_sym:
        if(strcmp(L_SYM(a1), L_SYM(a2)) == 0)
            result = 1;
        break;
    case l_str:
        if(strcmp(L_STR(a1), L_STR(a2)) == 0)
            result = 1;
        break;
    case l_hash:
        result = (L_HASH(a1) == L_HASH(a2));
        break;
    case l_null:
        result = 1;
        break;
    case l_fn:
        result = (L_FN(a1) == L_FN(a1));
        break;
    case l_pair:
        /* this is perhaps not right */
        if(!(c_equalp(L_CAR(a1), L_CAR(a2))))
            return 0;
        if(L_CDR(a1) && L_CDR(a2))
            return c_equalp(L_CDR(a1), L_CDR(a2));
        if(!L_CDR(a1) && !L_CDR(a2))
            return 1;
        result = 0;
        break;
    }

    return result;
}
Exemplo n.º 14
0
/**
 * begin special form
 *
 * (begin (expr1 expr2 expr3))
 */
lv_t *lisp_begin(lexec_t *exec, lv_t *v) {
    lv_t *current;
    lv_t *retval;

    assert(exec);
    rt_assert(v->type == l_pair, le_type, "cannot begin non-list");

    current = v;
    while(v && (L_CAR(v))) {
        retval = lisp_eval(exec, L_CAR(v));
        v = L_CDR(v);
    }

    return retval;
}
Exemplo n.º 15
0
lv_t *p_symbolp(lexec_t *exec, lv_t *v) {
    assert(v && exec);
    rt_assert(c_list_length(v) == 1, le_arity, "wrong arity");
    lv_t *a0 = L_CAR(v);

    return s_is_type(a0, l_sym);
}
Exemplo n.º 16
0
lv_t *p_inspect(lexec_t *exec, lv_t *v) {
    lv_t *arg;
    int show_line = 1;
    char buffer[256];

    assert(v && exec);
    rt_assert(c_list_length(v) == 1, le_arity, "inspect arity");

    arg = L_CAR(v);
    memset(buffer, 0, sizeof(buffer));

    strcat(buffer, "type: ");

    if(arg->type == l_fn) {
        if(L_FN(arg)) {
            strcat(buffer, "built-in function");
            show_line = 0;
        } else {
            strcat(buffer, "lambda, declared at");
        }
    } else {
        strcat(buffer, lisp_types_list[arg->type] + 2);
    }

    if(show_line)
        sprintf(buffer + strlen(buffer), " %s:%d:%d",
                arg->file, arg->row, arg->col);

    if(arg->bound)
        sprintf(buffer + strlen(buffer), ", bound to: %s",
                L_SYM(arg->bound));

    return lisp_create_string(buffer);
}
Exemplo n.º 17
0
lv_t *p_consp(lexec_t *exec, lv_t *v) {
    assert(v && v->type == l_pair);
    rt_assert(c_list_length(v) == 1, le_arity, "wrong arity");
    lv_t *a0 = L_CAR(v);

    return s_is_type(a0, l_pair);
}
Exemplo n.º 18
0
lv_t *p_pairp(lexec_t *exec, lv_t *v) {
    assert(v && v->type == l_pair);
    rt_assert(c_list_length(v) == 1, le_arity, "wrong arity");
    lv_t *a0 = L_CAR(v);

    return lisp_create_bool(a0->type == l_pair);
}
Exemplo n.º 19
0
lv_t *c_env_version(int version) {
    environment_list_t *current = s_env_prim;
    lv_t *p_layer = lisp_create_hash();
    lv_t *newenv;
    char filename[40];
    lexec_t *exec;

    newenv = lisp_create_pair(lisp_create_hash(),
                              lisp_create_pair(p_layer, NULL));


    exec = safe_malloc(sizeof(lexec_t));
    memset(exec, 0, sizeof(lexec_t));
    exec->env = newenv;

    snprintf(filename, sizeof(filename), "env/r%d.scm", version);

    /* now, load up a primitive environment */
    while(current && current->name) {
        c_hash_insert(p_layer, lisp_create_string(current->name),
                      lisp_create_native_fn(current->fn));
        current++;
    }

    /* now, run the setup environment */
    p_load(exec, lisp_create_pair(lisp_create_string(filename), NULL));

    /* and return just the generated environment */
    return lisp_create_pair(L_CAR(exec->env), NULL);
}
Exemplo n.º 20
0
lv_t *c_env_lookup(lv_t *env, lv_t *key) {
    lv_t *current;
    lv_t *result;

    assert(env->type == l_pair &&
           L_CAR(env) &&
           L_CAR(env)->type == l_hash);

    current=env;
    while(current) {
        if((result = c_hash_fetch(L_CAR(current), key)))
            return result;
        current = L_CDR(current);
    }

    return NULL;
}
Exemplo n.º 21
0
/**
 * eval a list of items, one after the other, returning the
 * value of the last eval
 */
lv_t *c_sequential_eval(lexec_t *exec, lv_t *v) {
    lv_t *current = v;
    lv_t *result;

    assert(exec);
    assert(v->type == l_pair || v->type == l_null);

    if(v->type == l_null)
        return v;

    while(current && L_CAR(current)) {
        result = lisp_eval(exec, L_CAR(current));
        current = L_CDR(current);
    }

    return result;
}
Exemplo n.º 22
0
lv_t *lisp_define(lexec_t *exec, lv_t *sym, lv_t *v) {
    assert(exec);

    /* this is probably not a good or completely safe
     * check of an environment */
    rt_assert(exec->env->type == l_pair &&
              L_CAR(exec->env) &&
              L_CAR(exec->env)->type == l_hash, le_type,
              "Not a valid environment");

    rt_assert(sym->type == l_sym, le_type, "cannot define non-symbol");

    rt_assert(c_hash_insert(L_CAR(exec->env), sym, v), le_internal,
        "error inserting hash element");

    return lisp_create_null();
}
Exemplo n.º 23
0
void repl(int level) {
    char prompt[30];
    char *cmd;
    int quit = 0;
    int line = 1;
    lv_t *parsed_value;
    lv_t *env_sym;
    lv_t *result;
    lv_t *arg;
    lv_t *str;
    char sym_buf[20];
    lexec_t *exec;

    exec = lisp_context_new(5); /* get r5rs environment */

    while(!quit) {
        snprintf(prompt, sizeof(prompt), "%d:%d> ", level, line);

        // r!
        cmd = readline(prompt);

        if(!cmd) {
            printf("\n");
            quit = 1;
            break;
        }

        if(!*cmd)
            continue;

        parsed_value = lisp_parse_string(cmd);
        if(!parsed_value) {
            fprintf(stderr, "synax error\n");
            continue;
        }

        // e!
        result = lisp_execute(exec, parsed_value);

        // p!
        if(result && !is_nil(result)) {
            sprintf(sym_buf, "$%d", line);
            env_sym = lisp_create_symbol(sym_buf);
            c_hash_insert(L_CAR(exec->env), env_sym, result);

            dprintf(1, "%s = ", sym_buf);

            str = lisp_str_from_value(result);
            printf("%s\n", L_STR(str));
        }

        // and l.  ;)
        add_history(cmd);
        free(cmd);
        line++;
    }
}
Exemplo n.º 24
0
lv_t *p_listp(lexec_t *exec, lv_t *v) {
    assert(v && exec);
    rt_assert(c_list_length(v) == 1, le_arity, "wrong arity");
    lv_t *a0 = L_CAR(v);

    if((a0->type == l_pair) || (a0->type == l_null))
        return lisp_create_bool(1);
    return lisp_create_bool(0);
}
Exemplo n.º 25
0
/**
 * lisp wrapper around c_equalp
 */
lv_t *p_equalp(lexec_t *exec, lv_t *v) {
    int result;

    assert(v && exec);
    rt_assert(c_list_length(v) == 2, le_arity, "wrong arity");

    lv_t *a1 = L_CAR(v);
    lv_t *a2 = L_CADR(v);

    return(lisp_create_bool(c_equalp(a1, a2)));
}
Exemplo n.º 26
0
lv_t *p_cdr(lexec_t *exec, lv_t *v) {
    assert(v && exec);

    rt_assert(c_list_length(v) == 1, le_arity, "cdr arity");
    rt_assert(L_CAR(v)->type == l_pair, le_type, "cdr on non-list");

    if(L_CDAR(v) == NULL)
        return lisp_create_null();

    return L_CDAR(v);
}
Exemplo n.º 27
0
/**
 * determine if an error object is a particular
 * subtype
 */
lv_t *c_error_type(lexec_t *exec, lv_t *v, lisp_errsubtype_t s) {
    assert(exec && v);
    assert(v->type == l_pair);

    rt_assert(c_list_length(v) == 1, le_arity, "expecting 1 arg");

    lv_t *a0 = L_CAR(v);

    if((a0->type == l_err) && (L_ERR(a0) == s))
        return lisp_create_bool(1);

    return lisp_create_bool(0);
}
Exemplo n.º 28
0
/**
 * (error-object? obj)
 *
 * returns #t if obj is an error object, else #f
 */
lv_t *p_error_objectp(lexec_t *exec, lv_t *v) {
    assert(exec && v);
    assert(v->type == l_pair);

    rt_assert(c_list_length(v) == 1, le_arity, "expecting 1 arg");

    lv_t *a0 = L_CAR(v);

    if(a0->type == l_err)
        return lisp_create_bool(1);

    return lisp_create_bool(0);
}
Exemplo n.º 29
0
/**
 * (write obj)
 * (write obj port)
 *
 * write a representation of obj to the given port
 * (or current-output-port if unspecified)
 *
 * returns nil
 */
lv_t *p_write(lexec_t *exec, lv_t *v) {
    lv_t *str;

    assert(v && exec);

    rt_assert(c_list_length(v) == 1, le_arity, "display arity");

    str = lisp_str_from_value(exec, L_CAR(v), 0);
    fprintf(stdout, "%s", L_STR(str));
    fflush(stdout);

    return lisp_create_null();
}
Exemplo n.º 30
0
/**
 * (reverse list)
 */
lv_t *p_reverse(lexec_t *exec, lv_t *v) {
    lv_t *r, *vptr;

    assert(exec && v);
    assert((v->type == l_pair) || (v->type == l_null));

    rt_assert(c_list_length(v) == 1, le_arity, "expecting 1 arg");

    vptr = L_CAR(v);
    if(vptr->type == l_null)
        return lisp_create_null();

    rt_assert(vptr->type == l_pair, le_type, "expecting list");

    r = NULL;
    while(vptr && L_CAR(vptr)) {
        r = lisp_create_pair(lisp_dup_item(L_CAR(vptr)), r);
        vptr = L_CDR(vptr);
        rt_assert(!vptr || (vptr->type == l_pair), le_type,
                  "expecting proper list");
    }

    return r;
}