Example #1
0
// (job 'lst . prg) -> any
any doJob(any ex) {
   any x = cdr(ex);
   any y = EVAL(car(x));
   cell c1;
   struct {  // bindFrame
      struct bindFrame *link;
      int i, cnt;
      struct {any sym; any val;} bnd[length(y)];
   } f;

   Push(c1,y);
   f.link = Env.bind,  Env.bind = (bindFrame*)&f;
   f.i = f.cnt = 0;
   while (isCell(y)) {
      f.bnd[f.cnt].sym = caar(y);
      f.bnd[f.cnt].val = val(caar(y));
      val(caar(y)) = cdar(y);
      ++f.cnt,  y = cdr(y);
   }
   x = prog(cdr(x));
   for (f.cnt = 0, y = Pop(c1);  isCell(y);  ++f.cnt, y = cdr(y)) {
      cdar(y) = val(caar(y));
      val(caar(y)) = f.bnd[f.cnt].val;
   }
   Env.bind = f.link;
   return x;
}
Example #2
0
static environment_t* rename(environment_t* e, cons_t* ids)
{
  assert_type(PAIR, ids);

  // build a new environment and return it
  environment_t *r = null_environment();

  // TODO: Below code runs in slow O(n^2) time
  for ( dict_t::const_iterator i = e->symbols.begin();
        i != e->symbols.end(); ++i )
  {
    std::string name = (*i).first;

    // find new name
    for ( cons_t *id = ids; !nullp(id); id = cdr(id) ) {
      assert_type(PAIR, car(id));
      assert_type(SYMBOL, caar(id));
      assert_type(SYMBOL, cadar(id));
      if ( symbol_name(caar(id)) == name ) {
        name = symbol_name(cadar(id));
        break;
      }
    }

    r->symbols[name] = (*i).second;
  }

  return r;
}
Example #3
0
static void putSrc(any s, any k) {
   if (!isNil(val(Dbg)) && !isExt(s) && InFile && InFile->name) {
      any x, y;
      cell c1;

      Push(c1, boxCnt(InFile->src));
      data(c1) = cons(data(c1), mkStr(InFile->name));
      x = get(s, Dbg);
      if (!k) {
         if (isNil(x))
            put(s, Dbg, cons(data(c1), Nil));
         else
            car(x) = data(c1);
      }
      else if (isNil(x))
         put(s, Dbg, cons(Nil, cons(data(c1), Nil)));
      else {
         for (y = cdr(x); isCell(y); y = cdr(y))
            if (caar(y) == k) {
               cdar(y) = data(c1);
               drop(c1);
               return;
            }
         cdr(x) = cons(cons(k, data(c1)), cdr(x));
      }
      drop(c1);
   }
}
Example #4
0
/*
 * Transform
 *
 * (case-lambda
 *   ((<form1> <body1>)
 *    (<form2> <body2>)
 *    ...)
 *
 * to
 *
 * (lambda args
 *   (cond
 *     (((if (variadic? <form1>) >= =) (length args) <form1-min-args>)
 *      (apply (lambda (<form1>) <body1>) args))
 *     ...))
 */
cons_t* proc_case_lambda(cons_t* p, environment_t* e)
{
  cons_t *cond_cases = list();

  cons_t *cases = p;

  for ( cons_t* c = cases; !nullp(c); c = cdr(c) ) {
    cons_t *formals = caar(c);
    cons_t *body = cdar(c);

    // ((if (variadic? <form1>) >= =) argc <form1-min-args>)
    cons_t* cond_if =
      cons(symbol(variadicp(formals)? ">=" : "="),
      cons(cons(symbol("length"), cons(symbol("args"))),
      cons(integer(min_args(formals)))));

    // (apply (lambda (<form1>) <body1>) args)
    cons_t *cond_then =
      cons(symbol("apply"),
      cons(cons(symbol("lambda"),
           cons(formals, body)),
      cons(symbol("args"))));

    cond_cases = append(cond_cases, list(list(cond_if, cond_then)));
  }

  cond_cases = splice(cons(symbol("cond")), cond_cases);

  return make_closure(symbol("args"), cons(cond_cases), e);
}
Example #5
0
NODE *lclose(NODE *arg) {
    FILE *tmp;
    NODE *margs;

    if ((tmp = find_file(car(arg), TRUE)) == NULL)
	err_logo(NOT_OPEN_ERROR, car(arg));
    else if (is_list (car(arg))) {
	margs = cons(caar(arg),
		     cons(make_strnode((char *)tmp, NULL, strlen((char *)tmp),
				       STRING, strnzcpy),
			  NIL));
	lmake(margs);
	free((char *)tmp);
    } else
	fclose(tmp);
    if ((is_list(car(arg)) && car(arg) == writer_name) ||
	(!is_list(car(arg)) &&
	 (compare_node(car(arg), writer_name, FALSE) == 0))) {
	    writer_name = NIL;
	    writestream = stdout;
    }
    if ((is_list(car(arg)) && car(arg) == reader_name) ||
	(!is_list(car(arg)) &&
	 (compare_node(car(arg), reader_name, FALSE) == 0))) {
	    reader_name = NIL;
	    readstream = stdin;
    }
    return(UNBOUND);
}
Example #6
0
void lock_lease_exclusive(Worker *worker, Lease *lease) {
    List *cleanup = worker->cleanup;
    List *prev = NULL;

    worker_attempt_to_acquire(worker, lease->wait_for_update);

    /* clean out any regular locks that we hold on this lease */
    while (lease->inflight > 0 && !null(cleanup)) {
        if (caar(cleanup) == (void *) LOCK_LEASE && cdar(cleanup) == lease) {
            lease->inflight--;
            if (null(prev))
                worker->cleanup = cdr(cleanup);
            else
                setcdr(prev, cdr(cleanup));
        } else {
            prev = cleanup;
        }
        cleanup = cdr(cleanup);
    }

    /* prevent any new transactions starting and signal our interest */
    lease->wait_for_update = worker;

    /* want for existing inflight transactions to finish */
    if (lease->inflight > 0)
        longjmp(worker->jmp, WORKER_BLOCKED);

    /* only add to the cleanup list once we've succeeded */
    worker_cleanup_add(worker, LOCK_LEASE_EXCLUSIVE, lease);
}
Example #7
0
int assv(int obj, int lis){
	while(!nullp(lis))
    	if(eqvp(obj,caar(lis)))
        	return(car(lis));
        else
        	lis = cdr(lis);
    return(BOOLF);
}
Example #8
0
File: mlis.c Project: kzfm1024/misc
int assoc(int sym, int lis){
    if(nullp(lis))
        return(0);
    else if(eqp(sym, caar(lis)))
        return(car(lis));
    else
        return(assoc(sym,cdr(lis)));
}
Example #9
0
// (bind 'sym|lst . prg) -> any
any doBind(any ex) {
   any x, y;

   x = cdr(ex);
   if (isNum(y = EVAL(car(x))))
      argError(ex, y);
   if (isNil(y))
      return prog(cdr(x));
   if (isSym(y)) {
      bindFrame f;

      Bind(y,f);
      x = prog(cdr(x));
      Unbind(f);
      return x;
   }
   {
      struct {  // bindFrame
         struct bindFrame *link;
         int i, cnt;
         struct {any sym; any val;} bnd[length(y)];
      } f;

      f.link = Env.bind,  Env.bind = (bindFrame*)&f;
      f.i = f.cnt = 0;
      do {
         if (isNum(car(y)))
            argError(ex, car(y));
         if (isSym(car(y))) {
            f.bnd[f.cnt].sym = car(y);
            f.bnd[f.cnt].val = val(car(y));
         }
         else {
            f.bnd[f.cnt].sym = caar(y);
            f.bnd[f.cnt].val = val(caar(y));
            val(caar(y)) = cdar(y);
         }
         ++f.cnt;
      } while (isCell(y = cdr(y)));
      x = prog(cdr(x));
      while (--f.cnt >= 0)
         val(f.bnd[f.cnt].sym) = f.bnd[f.cnt].val;
      Env.bind = f.link;
      return x;
   }
}
Example #10
0
/*FUNCTION*/
LVAL c_nthsassoc(tpLspObject pLSP,
                 LVAL p,
                 char *s,
                 int n
  ){
/*noverbatim
CUT*/
  LVAL fp;

  if( null(p) || !consp(p) )return NIL;
  for( fp = p ; fp ; fp = cdr(fp) )
    if( !car(fp) || !consp(car(fp)) || !symbolp(caar(fp)) )
            continue;
    else
      if( symcmp(caar(fp),s) && !--n )return car(fp);
  return NIL;
  }
Example #11
0
File: prim.c Project: l0stman/loot
/* Return the first element of a pair */
static exp_t *
prim_car(exp_t *args)
{
        chkargs("car", args, 1);
        if (!ispair(car(args)))
                everr("car: the argument isn't a pair", car(args));
        return caar(args);
}
Example #12
0
// Handy for pretty-printing local variables in an env
char* print_env(cell c) {
    if (!buf) {
        buf = GC_MALLOC(64);
        buf_len = 64;
    }
    buf_index = 0;
    catf("(");
    while (IS_PAIR(c)) {
        if (!IS_PAIR(car(c))) break;
        if (TYPE(caar(c)) != SYMBOL) break;
        if (!strcmp(SYM_STR(caar(c)), "GLOBALS")) break;
        catf("\n%20s . ", SYM_STR(caar(c)));
        print(cadr(c));
        c = cdr(c);
    }
    catf(")");
    return buf;
}
pointer lookup_symbol(pointer sym)
{
        pointer iter = env;
        while (iter != NULL) {
                if (sym_eq(sym, caar(iter)))
                        return car(iter);
                iter = cdr(iter);
        }
        return iter;
}
Example #14
0
// (nond ('any1 . prg1) ('any2 . prg2) ..) -> any
any doNond(any x) {
   any a;

   while (isCell(x = cdr(x))) {
      if (isNil(a = EVAL(caar(x))))
         return prog(cdar(x));
      val(At) = a;
   }
   return Nil;
}
Example #15
0
// (cond ('any1 . prg1) ('any2 . prg2) ..) -> any
any doCond(any x) {
   any a;

   while (isCell(x = cdr(x))) {
      if (!isNil(a = EVAL(caar(x)))) {
         val(At) = a;
         return prog(cdar(x));
      }
   }
   return Nil;
}
Example #16
0
// (dm sym . fun|cls2) -> sym
// (dm (sym . cls) . fun|cls2) -> sym
// (dm (sym sym2 [. cls]) . fun|cls2) -> sym
any doDm(any ex) {
   any x, y, msg, cls;

   x = cdr(ex);
   if (!isCell(car(x)))
      msg = car(x),  cls = val(Class);
   else {
      msg = caar(x);
      cls = !isCell(cdar(x))? cdar(x) :
         get(isNil(cddar(x))? val(Class) : cddar(x), cadar(x));
   }
   if (msg != T)
      redefine(ex, msg, val(Meth));
   if (isSym(cdr(x))) {
      y = val(cdr(x));
      for (;;) {
         if (!isCell(y) || !isCell(car(y)))
            err(ex, msg, "Bad message");
         if (caar(y) == msg) {
            x = car(y);
            break;
         }
         y = cdr(y);
      }
   }
   for (y = val(cls);  isCell(y) && isCell(car(y));  y = cdr(y))
      if (caar(y) == msg) {
         if (!equal(cdr(x), cdar(y)))
            redefMsg(msg, cls);
         cdar(y) = cdr(x);
         putSrc(cls, msg);
         return msg;
      }
   if (!isCell(car(x)))
      val(cls) = cons(x, val(cls));
   else
      val(cls) = cons(cons(msg, cdr(x)), val(cls));
   putSrc(cls, msg);
   return msg;
}
Example #17
0
END_TEST

START_TEST (test_pair_ops)
{
    make_singletons();
    object *o1 = cons (make_string ("testing"), make_boolean (true));
    object *o2 = cons (make_character ('a'), make_fixnum (5));
    object *o3 = cons (o1, o2);
    ck_assert (o3->type == PAIR);
    ck_assert (car(o3)->type == PAIR);
    ck_assert_str_eq (caar(o3)->data.string.value, "testing");
    ck_assert ((cdar(o3))->type == BOOLEAN);
}
Example #18
0
File: mlis.c Project: kzfm1024/misc
int f_oblist(int arglist){
    int addr,addr1,res;
    
    checkarg(LEN0_TEST, "oblist", arglist);
    res = NIL;
    addr = ep;
    while(!(nullp(addr))){
        addr1 = caar(addr);
        res = cons(addr1,res);
        addr = cdr(addr);
    }
    return(res);
}
Example #19
0
File: arc.c Project: wsxiaoys/carc
/*-------Environment-------*/
pointer environment_make2(VM, pointer rib, pointer env) {
  pointer t;
  save(vm, rib);
  save(vm, env);
  t = table_alloc(vm);
  
  while (!AR_ISNIL(rib)) {
    table_insert(vm, t, caar(rib), cdar(rib));
    rib = cdr(rib);
  }
  unsave(vm, 2);
  
  return tagged_alloc(vm, vm->s_environment, cons(t,AR_ISNIL(env)?vm->nil:rep(env)));
}
Example #20
0
void worker_cleanup(Worker *worker) {
    while (!null(worker->cleanup)) {
        enum lock_types type = (enum lock_types) caar(worker->cleanup);
        void *obj = cdar(worker->cleanup);
        worker->cleanup = cdr(worker->cleanup);

        switch (type) {
        case LOCK_DIRECTORY:
            cleanup(struct objectdir);
            break;
        case LOCK_OPENFILE:
            cleanup(struct openfile);
            break;
        case LOCK_FID:
            cleanup(Fid);
            break;
        case LOCK_WALK:
            cleanup(Walk);
            break;
        case LOCK_CLAIM:
            cleanup(Claim);
            claim_release((Claim *) obj);
            break;
        case LOCK_LEASE:
            unlock_lease_cleanup(worker, (Lease *) obj);
            break;
        case LOCK_LEASE_EXCLUSIVE:
            ((Lease *) obj)->wait_for_update = NULL;
            break;
        case LOCK_REMOTE_FID:
            if (vector_get(fid_remote_vector, (u32) obj) ==
                    (void *) 0xdeadbeef)
            {
                fid_release_remote((u32) obj);
            }
            break;
        case LOCK_RAW:
            raw_delete((u8 *) obj);
            break;
        default:
            assert(0);
        }
    }
}
Example #21
0
void worker_cleanup_remove(Worker *worker, enum lock_types type, void *object) {
    List *prev = NULL;
    List *cur = worker->cleanup;

    while (!null(cur)) {
        if (caar(cur) == (void *) type && cdar(cur) == object) {
            if (prev == NULL)
                worker->cleanup = cdr(cur);
            else
                setcdr(prev, cdr(cur));

            return;
        }

        prev = cur;
        cur = cdr(cur);
    }

    /* fail if we didn't find the requested entry */
    assert(0);
}
Example #22
0
object *car_proc(object *arguments) {
    return caar(arguments);
}
Example #23
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)));
  }
}
Example #24
0
/*
 * Parse (define-library ...) form into given environment, with the
 * following format:
 *
 * (define-library <library name>
 *   <library declaration> ...)
 *
 * where <library declaration> is any of:
 *
 * - (export <export spec> ...)
 * - (import <import set> ...)
 * - (begin <command or definition> ...)
 * - (include <filename1> <filename2> ...)
 * - (include-ci <filename1> <filename2> ...)
 * - (cond-expand <cond-expand clause> ...)
 */
static library_t* define_library(cons_t* p, const char* file)
{
  library_t *r = new library_t();
  cons_t *exports = nil();

  // find current dir for resolving include and include-ci
  std::string curdir = sdirname(file);

  // define-library
  if ( symbol_name(caar(p)) != "define-library" )
    raise(syntax_error(format(
      "Imported file does not begin with define-library: %s", file)));

  // <library name>
  r->name = verify_library_name(cadar(p));

  // A <library declaration> can be either ...
  for ( p = cdr(cdar(p)); !nullp(p); p = cdr(p) ) {
    cons_t *id   = caar(p);
    cons_t *body = cdar(p);
    std::string s = symbol_name(id);

    if ( s == "export" ) {
      exports = body;
      continue;
    }

    if ( s == "import" ) {
      // TODO: Make sure that proc_import does not override
      //       r->internals->outer
      proc_import(body, r->internals);
      continue;
    }

    if ( s == "begin" ) {
      eval(car(p), r->internals);
      continue;
    }

    if ( s == "include" ) {
      eval(splice(list(symbol("begin")),
                  include(body, r->internals, curdir.c_str())),
           r->internals);
      continue;
    }

    if ( s == "include-ci" ) {
      eval(splice(list(symbol("begin")),
                  include_ci(body, r->internals, curdir.c_str())),
           r->internals);
      continue;
    }

    if ( s == "cond-expand" ) {
      eval(cond_expand(body, r->internals), r->internals);
      continue;
    }
  }

  // copy exports into exports-environemnt
  for ( p = exports; !nullp(p); p = cdr(p) ) {

    // handle renaming
    if ( listp(car(p)) && length(car(p))==3 &&
         symbol_name(caar(p))=="rename" )
    {
      assert_type(SYMBOL, cadar(p));
      assert_type(SYMBOL, caddar(p));

      std::string internal_name = symbol_name(cadar(p));
      std::string external_name = symbol_name(caddar(p));

      r->exports->define(external_name,
                         r->internals->lookup(internal_name));
    } else if ( listp(car(p)) )
      raise(syntax_error("(export <spec> ...) only allows (rename x y)"));
    else if ( type_of(car(p)) == SYMBOL ) {
      r->exports->define(symbol_name(car(p)),
                         r->internals->lookup(symbol_name(car(p))));
    } else
      raise(syntax_error(
        "(export <spec> ...) requires <spec> to be "
        "either an identifier or a pair of them."));
  }

  return r;
}
Example #25
0
static OBJ analyze_r(const struct analyze_t *arg)
{
	OBJ op;
	OBJ ret;
	struct analyze_t new_arg;

	new_arg = *arg;
	ret = OBJ_NULL;

	if (is_self_evaluating(new_arg.sexp))
		ret = new_arg.sexp;
	else if (is_variable(new_arg.sexp))
		ret = analyze_variable_cell(new_arg.sexp,new_arg.env,new_arg.macro,new_arg.params,new_arg.macro_expand_env);
	else if(obj_pairp(new_arg.sexp))
 	{
		if(obj_pairp(car(new_arg.sexp)))
		{
			new_arg.sexp = car(new_arg.sexp);
			op = fake_eval(&new_arg);
			new_arg = *arg;
		}
		else
			op = analyze_variable_value(car(new_arg.sexp),new_arg.env,new_arg.macro,new_arg.params,new_arg.macro_expand_env);
		if(op == OBJ_NULL) /* error handle---fixme!! */
			return OBJ_NULL;
		if(obj_corep(op))
		{
			switch(obj_core_type(op))
			{
			case DEFINE:
			case DEFINE_SYNTAX:
				new_arg.sexp = cdr(new_arg.sexp);
				ret = analyze_define(&new_arg);
				break;
			case SET:
				new_arg.sexp = cdr(new_arg.sexp);
				ret = analyze_set(&new_arg);
				break;
			case IF:
				ret = analyze_if(cdr(new_arg.sexp),new_arg.env,new_arg.tail);
				break;
			case QUOTE:
				ret = obj_make_quote(cadr(new_arg.sexp));
				break;
			case BEGIN:
				new_arg.sexp = cdr(new_arg.sexp);
				ret = analyze_begin(&new_arg);
				break;
			case LAMBDA:
				new_arg.sexp = cdr(new_arg.sexp);
				ret = analyze_lambda(&new_arg);
				break;
			case SYNTAX_RULES:
				ret = analyze_syntax_rules(cdr(new_arg.sexp),new_arg.env);
				break;
			default:
				fprintf(stderr,"unknown core tag\n");
			}
		}
		else if(obj_syntaxp(op))
		{
			OBJ params;
			OBJ data;
			OBJ patten;
			OBJ template;
			int match;

			match = 0;
			data = obj_syntax_data(op);
			while(obj_pairp(data))
			{
				patten = caar(data);
Example #26
0
File: prim.c Project: mdbarr/vcsi
VCSI_OBJECT cdaar(VCSI_CONTEXT vc,
		  VCSI_OBJECT x) {
  return cdr(vc,caar(vc,x));
}
Example #27
0
//TODO check number of arguments given to builtins
object_t *eval(object_t *exp, object_t *env) {

    char comeback = 1;

    while(comeback) {
        comeback = 0;

        if(is_self_evaluating(exp)) {
            return exp;
        }

        if(list_begins_with(exp, quote_symbol)) {
            return cadr(exp);
        }

        // (define... )
        if(list_begins_with(exp, define_symbol)) {

            object_t *var = cadr(exp);

            // (define a b)
            if(issymbol(var)) {
                object_t *val = caddr(exp);
                return define_var(env, var, val);
            }

            // (define (a ...) ...) TODO use scheme macro
            if(ispair(var)) {
                object_t *name = car(cadr(exp)),
                    *formals = cdr(cadr(exp)),
                    *body = cddr(exp),
                    *lambda = cons(lambda_symbol,
                                      cons(formals, body));

                exp = cons(define_symbol,
                              cons(name, cons(lambda, empty_list)));
                comeback = 1;
                continue;
            }

            fprintf(stderr, "Syntax error.\n");
            exit(-1);
        }

        // (set! a b)
        if(list_begins_with(exp, set_symbol)) {
            object_t *var = cadr(exp);
            object_t *val = caddr(exp);
            return set_var(env, var, val);
        }

        // (if c a b)
        if(list_begins_with(exp, if_symbol)) {
            exp = eval_if(env, cadr(exp), caddr(exp), cadddr(exp));
            comeback = 1;
            continue;
        }

        // (cond ...)
        if(list_begins_with(exp, cond_symbol)) {
            object_t *tail = cons(void_symbol, empty_list);
            object_t *ifs = tail; //empty_list;
            object_t *rules = reverse_list(cdr(exp));

            while(!isemptylist(rules)) {
                object_t *rule = car(rules),
                    *condition = car(rule),
                    *consequence = cadr(rule);

                if(isemptylist(consequence)) {
                    consequence = cons(void_obj, empty_list);
                }

                ifs = cons(if_symbol,
                              cons(condition,
                                      cons(consequence,
                                              cons(ifs, empty_list))));

                rules = cdr(rules);
            }

            exp = ifs;

            comeback = 1;
            continue;
        }

        // (begin ...)
        if(list_begins_with(exp, begin_symbol)) {

            object_t *result = empty_list, *exps;

            for(exps = cdr(exp); ! isemptylist(exps); exps = cdr(exps)) {
                result = eval(car(exps), env);
            }

            return result;
        }

        if(list_begins_with(exp, lambda_symbol)) {
            object_t *fn = cons(begin_symbol,
                                    cdr(cdr(exp)));
            return make_compound_proc(empty_list, cadr(exp),
                                         fn,
                                         env);
        }

        // (let ...)
        if(list_begins_with(exp, let_symbol)) {
            //if(! issymbol(cadr(exp)))
            object_t *bindings = cadr(exp);
            object_t *body = cddr(exp);

            object_t *formals = empty_list;
            object_t *values = empty_list;

            while(!isemptylist(bindings)) {
                formals = cons(caar(bindings), formals);
                values = cons(cadr(car(bindings)), values);

                bindings = cdr(bindings);
            }

            exp = cons(cons(lambda_symbol, cons(formals, body)),
                          values);

            comeback = 1;
            continue;
        }

        if(issymbol(exp)) {
            return var_get_value(env, exp);
        }

        if(ispair(exp)) {
            object_t *exp_car = car(exp);
            object_t *fn = eval(exp_car, env); //var_get_value(env, car);
            if(!iscallable(fn)) {
                fprintf(stderr, "object_t is not callable\n");
                exit(-1);
            }

            object_t *args = cdr(exp);
            object_t *evaluated_args = evaluate_list(env, args, empty_list);

            if(isprimitiveproc(fn)) {
                return fn->value.prim_proc.fn(evaluated_args);
            } else if(iscompoundproc(fn)) {
                object_t *fn_formals = fn->value.compound_proc.formals;
                object_t *fn_body = fn->value.compound_proc.body;
                object_t *fn_env = fn->value.compound_proc.env;

                ARGS_EQ(evaluated_args, list_size(fn_formals));

                exp = fn_body;
                env = extend_environment(fn_formals, evaluated_args, fn_env);
                comeback = 1;
                continue;

            }
            assert(0);
        }

    }

    fprintf(stderr, "Unable to evaluate expression: \n");
    write(exp);
    exit(-1);
}
Example #28
0
 forlist (ptr in list) {
     if (strequal(key, name(caar(ptr))) is 0) {
         return car(ptr);
     }
 }
Example #29
0
static data_t *get_let_var(const data_t *assignment) {
	if(assignment == NULL)
		return NULL;
	return cons(caar(assignment), get_let_var(cdr(assignment)));
}
Example #30
0
// (for sym 'num ['any | (NIL 'any . prg) | (T 'any . prg) ..]) -> any
// (for sym|(sym2 . sym) 'lst ['any | (NIL 'any . prg) | (T 'any . prg) ..]) -> any
// (for (sym|(sym2 . sym) 'any1 'any2 [. prg]) ['any | (NIL 'any . prg) | (T 'any . prg) ..]) -> any
any doFor(any x) {
   any y, body, cond, a;
   cell c1;
   struct {  // bindFrame
      struct bindFrame *link;
      int i, cnt;
      struct {any sym; any val;} bnd[2];
   } f;

   f.link = Env.bind,  Env.bind = (bindFrame*)&f;
   f.i = 0;
   if (!isCell(y = car(x = cdr(x))) || !isCell(cdr(y))) {
      if (!isCell(y)) {
         f.cnt = 1;
         f.bnd[0].sym = y;
         f.bnd[0].val = val(y);
      }
      else {
         f.cnt = 2;
         f.bnd[0].sym = cdr(y);
         f.bnd[0].val = val(cdr(y));
         f.bnd[1].sym = car(y);
         f.bnd[1].val = val(car(y));
         val(f.bnd[1].sym) = Zero;
      }
      y = Nil;
      x = cdr(x),  Push(c1, EVAL(car(x)));
      if (isNum(data(c1)))
         val(f.bnd[0].sym) = Zero;
      body = x = cdr(x);
      for (;;) {
         if (isNum(data(c1))) {
            val(f.bnd[0].sym) = bigCopy(val(f.bnd[0].sym));
            digAdd(val(f.bnd[0].sym), 2);
            if (bigCompare(val(f.bnd[0].sym), data(c1)) > 0)
               break;
         }
         else {
            if (!isCell(data(c1)))
               break;
            val(f.bnd[0].sym) = car(data(c1));
            if (!isCell(data(c1) = cdr(data(c1))))
               data(c1) = Nil;
         }
         if (f.cnt == 2) {
            val(f.bnd[1].sym) = bigCopy(val(f.bnd[1].sym));
            digAdd(val(f.bnd[1].sym), 2);
         }
         do {
            if (!isNum(y = car(x))) {
               if (isSym(y))
                  y = val(y);
               else if (isNil(car(y))) {
                  y = cdr(y);
                  if (isNil(a = EVAL(car(y)))) {
                     y = prog(cdr(y));
                     goto for1;
                  }
                  val(At) = a;
                  y = Nil;
               }
               else if (car(y) == T) {
                  y = cdr(y);
                  if (!isNil(a = EVAL(car(y)))) {
                     val(At) = a;
                     y = prog(cdr(y));
                     goto for1;
                  }
                  y = Nil;
               }
               else
                  y = evList(y);
            }
         } while (isCell(x = cdr(x)));
         x = body;
      }
   for1:
      drop(c1);
      if (f.cnt == 2)
         val(f.bnd[1].sym) = f.bnd[1].val;
      val(f.bnd[0].sym) = f.bnd[0].val;
      Env.bind = f.link;
      return y;
   }
   if (!isCell(car(y))) {
      f.cnt = 1;
      f.bnd[0].sym = car(y);
      f.bnd[0].val = val(car(y));
   }
   else {
      f.cnt = 2;
      f.bnd[0].sym = cdar(y);
      f.bnd[0].val = val(cdar(y));
      f.bnd[1].sym = caar(y);
      f.bnd[1].val = val(caar(y));
      val(f.bnd[1].sym) = Zero;
   }
   y = cdr(y);
   val(f.bnd[0].sym) = EVAL(car(y));
   y = cdr(y),  cond = car(y),  y = cdr(y);
   Push(c1,Nil);
   body = x = cdr(x);
   while (!isNil(a = EVAL(cond))) {
      val(At) = a;
      if (f.cnt == 2) {
         val(f.bnd[1].sym) = bigCopy(val(f.bnd[1].sym));
         digAdd(val(f.bnd[1].sym), 2);
      }
      do {
         if (!isNum(data(c1) = car(x))) {
            if (isSym(data(c1)))
               data(c1) = val(data(c1));
            else if (isNil(car(data(c1)))) {
               data(c1) = cdr(data(c1));
               if (isNil(a = EVAL(car(data(c1))))) {
                  data(c1) = prog(cdr(data(c1)));
                  goto for2;
               }
               val(At) = a;
               data(c1) = Nil;
            }
            else if (car(data(c1)) == T) {
               data(c1) = cdr(data(c1));
               if (!isNil(a = EVAL(car(data(c1))))) {
                  val(At) = a;
                  data(c1) = prog(cdr(data(c1)));
                  goto for2;
               }
               data(c1) = Nil;
            }
            else
               data(c1) = evList(data(c1));
         }
      } while (isCell(x = cdr(x)));
      if (isCell(y))
         val(f.bnd[0].sym) = prog(y);
      x = body;
   }
for2:
   if (f.cnt == 2)
      val(f.bnd[1].sym) = f.bnd[1].val;
   val(f.bnd[0].sym) = f.bnd[0].val;
   Env.bind = f.link;
   return Pop(c1);
}