/*
* Create cons graph for given list that can be rendered by Graphviz.
*
* Example usage:
*
* /mickey -e '(display (:list->dot (quote (define (square x) (* x x * 123)))))' | dot -Tpng -o graph.png && open graph.png
*
*/
cons_t* proc_list_to_dot_helper(cons_t *p, environment_t* e)
{
static const char* line_style = "[\"ol\"=\"box\"]";
static const char* shape = "record";
if ( nullp(p) ) return string("");
std::string s;
if ( pairp(p) ) {
if ( !nullp(car(p)) ) {
const char* port = "";
if ( pairp(car(p)) ) port = ":head";
s += format(" \"%p\":head -> \"%p\"%s %s;\n", p, car(p), port, line_style);
s += proc_list_to_dot_helper(car(p), e)->string;
}
if ( !nullp(cdr(p)) ) {
const char* port = "";
if ( pairp(cdr(p)) ) port = ":head";
s += format(" \"%p\":tail -> \"%p\"%s %s;\n", p, cdr(p), port, line_style);
s += proc_list_to_dot_helper(cdr(p), e)->string;
}
s += format(" \"%p\" [label=\"<head>|<tail>\", shape=\"%s\"];\n", p, shape);
} else
s += format(" \"%p\" [label=\"%s\", shape=\"none\"];\n",
p, sprint(p).c_str());
return string(s.c_str());
}
static obj_t *
lang_begin(obj_t **frame, obj_t **tailp)
{
obj_t *expr = *frame_ref(frame, 0);
*tailp = tail_token;
obj_t *iter;
for (iter = expr; pairp(iter); iter = pair_cdr(iter)) {
// Eval each expression except the last.
if (!pairp(pair_cdr(iter))) {
break;
}
obj_t **expr_frame = frame_extend(frame, 1,
FR_SAVE_PREV | FR_CONTINUE_ENV);
*frame_ref(expr_frame, 0) = pair_car(iter);
eval_frame(expr_frame);
}
if (nullp(iter)) {
// Empty (begin) expression
return unspec_wrap();
}
else if (!nullp(pair_cdr(iter))) {
fatal_error("begin -- not a well-formed list", frame);
}
return pair_car(iter);
}
static obj_t *
lang_define(obj_t **frame, obj_t **tailp)
{
obj_t *expr = *frame_ref(frame, 0);
obj_t *first, *name, *result;
*tailp = NULL;
first = pair_car(expr);
if (symbolp(first)) {
// Binding an expression
// XXX: check for expr length?
obj_t *to_eval = pair_car(pair_cdr(expr));
// Get the value of the expression before binding.
obj_t **expr_frame = frame_extend(
frame, 1, FR_CONTINUE_ENV | FR_SAVE_PREV);
*frame_ref(expr_frame, 0) = to_eval;
result = eval_frame(expr_frame);
name = first;
}
else if (pairp(first)) {
// short hand for (define name (lambda ...))
// x: the formals, v: the body
obj_t *formals, *body;
name = pair_car(first);
formals = pair_cdr(first);
body = pair_cdr(expr);
result = closure_wrap(frame, frame_env(frame), formals, body);
}
else {
fatal_error("define -- first argument is neither a "
"symbol nor a pair", frame);
}
environ_def(frame, frame_env(frame), name, result);
return unspec_wrap();
}
size_t arg_length(cons_t* p)
{
size_t n = 0;
while ( pairp(p) ) {
p = cdr(p);
++n;
}
return n;
}
cons_t* evlis(cons_t* p, environment_t* e)
{
cons_t *r = list();
/*
* We use a tail pointer `t´ to avoid using the slow append()
*/
for ( cons_t *t = r; pairp(p); p = cdr(p) ) {
t->car = eval(car(p), e);
t->cdr = cons(nil());
t = cdr(t);
}
return r;
}
bool has_rest_args(cons_t* p)
{
/*
* We now use proper dot notation so that
* function signatures are parsed either
* as a pure list, e.g. (arg1 arg2 arg3)
* or as a non-proper list that is not
* terminated with a nil, e.g.
* (arg1 arg2 . rest-args)
*/
while ( pairp(p) )
p = cdr(p);
return !nullp(p);
}
void mark_expr(node *o, unsigned char persistence) {
if ( nullp(o) ) {
return;
}
if (pairp(o) or consp(o)) {
mark_expr(o->car, persistence);
mark_expr(o->cdr, persistence);
} else if (lambdap(o)) {
mark_expr(o->args, persistence);
mark_expr(o->body, persistence);
}
if (o->marked <= 1) {
o->marked = persistence;
}
return;
}
static obj_t *
expand_quasiquote(obj_t **frame, obj_t *content,
enum quasiquote_return_flag *flag)
{
if (!pairp(content)) {
return content;
}
// Manually compare each item with unquote/unquote-splicing
obj_t *qq = symbol_quasiquote;
obj_t *uq = symbol_unquote;
obj_t *spl = symbol_unquote_splicing;
if (pair_car(content) == qq) {
if (flag)
flag = QQ_DEFAULT;
return content;
// XXX: NESTED QQ...
/*
obj_t *body = pair_cadr(content);
frame = frame_extend(frame, 1, FR_SAVE_PREV | FR_CONTINUE_ENV);
*frame_ref(frame, 0) = content;
obj_t *res = expand_quasiquote(frame, body, NULL); // nested QQ
obj_t *wrap = pair_wrap(frame, res, nil_wrap());
return pair_wrap(frame, qq, wrap);
*/
}
else if (pair_car(content) == uq) {
obj_t *uq_body = pair_cadr(content);
frame = frame_extend(frame, 1, FR_SAVE_PREV | FR_CONTINUE_ENV);
*frame_ref(frame, 0) = uq_body;
if (flag)
*flag = QQ_UNQUOTE;
return eval_frame(frame);
}
else if (pair_car(content) == spl) {
obj_t *spl_body = pair_cadr(content);
obj_t *retval;
frame = frame_extend(frame, 1, FR_SAVE_PREV | FR_CONTINUE_ENV);
*frame_ref(frame, 0) = spl_body;
retval = eval_frame(frame);
if (flag)
*flag = QQ_SPLICING;
return retval;
}
else {
// Copy the pair content.
content = pair_copy_list(frame, content);
// Append a dummy header for unquote-splicing to use.
content = pair_wrap(frame, nil_wrap(), content);
// Mark the content.
frame = frame_extend(frame, 1, FR_SAVE_PREV | FR_CONTINUE_ENV);
*frame_ref(frame, 0) = content;
// For linking unquote-splicing, we look at the next item of
// the iterator. That's why we need a dummy header here.
obj_t *iter, *next, *got;
enum quasiquote_return_flag ret_flag;
for (iter = content; pairp(iter); iter = pair_cdr(iter)) {
// `next` will always be null or pair, since `content` is a list.
loop_begin:
next = pair_cdr(iter);
if (nullp(next)) // we are done.
break;
// XXX: this is strange. why do we need to initialize it?
ret_flag = QQ_DEFAULT;
got = expand_quasiquote(frame, pair_car(next), &ret_flag);
if (ret_flag & QQ_SPLICING) {
// Special handling for unquote-splicing
// WARNING: messy code below!
got = pair_copy_list(frame, got);
if (nullp(got)) {
pair_set_cdr(iter, pair_cdr(next));
}
else {
pair_set_cdr(iter, got); // iter -> got
while (pairp(pair_cdr(got))) {
got = pair_cdr(got);
}
pair_set_cdr(got, pair_cdr(next)); // got -> (next->next)
iter = got; // make sure the next iteration is correct
goto loop_begin; // And this...
}
}
else {
// Not unquote-splicing, easy...
pair_set_car(next, got);
}
}
if (flag)
*flag = QQ_DEFAULT;
return pair_cdr(content);
}
}
int scm_cdr(int lis){
if(pairp(lis))
return(GET_CDR(lis));
else
exception("cdr", NOT_PAIR, lis);
}
void load_library_index()
{
if ( library_map != NULL )
return;
std::string filename = library_file(library_index_file);
environment_t *env = null_environment();
program_t *p = parse(slurp(open_file(filename)), env);
cons_t *index = p->root;
if ( !pairp(index) || !symbolp(caar(index)) )
invalid_index_format(filename + ": no list with symbols");
for ( ; !nullp(index); index = cdr(index) ) {
if ( symbol_name(caar(index)) == "define-library-index" ) {
if ( library_map != NULL )
invalid_index_format(filename + ": only one define-library-index allowed");
if ( !listp(cdar(index)) ) {
invalid_index_format(filename
+ ": define-library-index is not a list");
}
size_t len = length(cdar(index));
library_map = (library_map_t*) malloc((1+len)*sizeof(library_map_t));
size_t i = 0;
for ( cons_t *lib = cdar(index); !nullp(lib); lib = cdr(lib), ++i ) {
cons_t *name = caar(lib);
cons_t *file = cadar(lib);
if ( !listp(name) || !stringp(file) )
invalid_index_format(filename + ": not list/string pair");
library_map[i].library_name = strdup(sprint(name).c_str());
library_map[i].source_file = strdup(file->string);
}
// important to signal end of list:
library_map[i].library_name = NULL;
library_map[i].source_file = NULL;
continue;
} else if ( symbol_name(caar(index)) == "define-repl-imports" ) {
if ( repl_libraries != NULL )
invalid_index_format(filename + ": only one define-repl-imports allowed");
if ( !listp(cdar(index)) ) {
invalid_index_format(filename
+ ": define-repl-imports is not a list");
}
size_t len = length(cdar(index));
repl_libraries = (const char**) malloc((1+len)*sizeof(char*));
const char **s = repl_libraries;
for ( cons_t *lib = cdar(index); !nullp(lib); lib = cdr(lib), ++s ) {
cons_t *name = car(lib);
*s = strdup(sprint(name).c_str());
}
*s = NULL;
continue;
} else
invalid_index_format(filename + ": unknown label "
+ sprint(caar(index)));
}
}