/*
 * 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());
}
Exemple #2
0
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);
}
Exemple #3
0
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;
}
Exemple #5
0
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;
}
Exemple #8
0
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);
    }
}
Exemple #9
0
int scm_cdr(int lis){
	if(pairp(lis))
    	return(GET_CDR(lis));
    else
    	exception("cdr", NOT_PAIR, lis);
}
Exemple #10
0
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)));
  }
}