Esempio n. 1
0
void set_variable_value(OBJ name,OBJ value,OBJ env)
{
	OBJ frame;
	OBJ names;
	OBJ values;

	while(!nullp(env))
	{
		frame = env_frame(env);
		names = car(frame);
		values = cdr(frame);
		while(!nullp(names))
		{
			if(eq(car(names),name))
			{
				car(values) = value;
					return;
			}
			names = cdr(names);
			values = cdr(values);
		}
		env = env_base(env);
	}
	fprintf(stderr, "can't set! unbound variable, %s\n", obj_symbol_data(name));
}
Esempio n. 2
0
static obj_t *
lang_if(obj_t **frame, obj_t **tailp)
{
    obj_t *expr = *frame_ref(frame, 0);
    obj_t *pred, *todo, *otherwise;
    *tailp = tail_token;

    pred = pair_car(expr);
    todo = pair_cadr(expr);
    otherwise = pair_cddr(expr);
    if (nullp(otherwise)) {
        otherwise = unspec_wrap();
    }
    else if (!nullp(pair_cdr(otherwise))) {
        fatal_error("if -- too many arguments", frame);
    }
    else {
        otherwise = pair_car(otherwise);
    }

    {
        // start to evaluate the predicate.
        obj_t **pred_frame = frame_extend(
                frame, 1, FR_CONTINUE_ENV | FR_SAVE_PREV);
        *frame_ref(pred_frame, 0) = pred;
        pred = eval_frame(pred_frame);
    }
    if (to_boolean(pred)) {
        return todo;
    }
    else {
        return otherwise;
    }
}
Esempio n. 3
0
/*
 * 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());
}
Esempio n. 4
0
static void cell_write(SExp s, int b_escape, struct StreamBase* strm) {
	// 省略表示系のチェック
	if (consp(CDR(s)) && nullp(CDDR(s))) {
		SExp t = CAR(s);
		const char* str = NULL;
		if (eq(t, intern("quote"))) {
			str = "'";
		} else if (eq(t, intern("quasiquote"))) {
			str = "`";
		}
		if (str != NULL) {
			strm_puts(strm, str, 0);
			swrite(CADR(s), b_escape, strm);
			return;
		}
	}

	{
		int first = TRUE;
		SExp p;
		strm_puts(strm, "(", 0);
		for (p = s; consp(p); p = CDR(p)) {
			if (!first)	strm_puts(strm, " ", 0);
			first = FALSE;
			swrite(CAR(p), b_escape, strm);
		}
		if (!nullp(p)) {
			strm_puts(strm, " . ", 0);
			swrite(p, b_escape, strm);
		}
		strm_puts(strm, ")", 0);
	}
}
Esempio n. 5
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);
}
Esempio n. 6
0
static void
log_cleanup()
{
  nullp(&prefix);
  nullp(&filename);
  if (output != stdout)
    fclose(output);
}
Esempio n. 7
0
varargs string wrap(string str, int width, int indent) {

  if (nullp(str)) return "";
  if (nullp(width)) width = SZ;
  if (nullp(indent)) indent = 0;

  return terminal_colour(str, TERMINAL_D->query_term_info("wrap"), width, indent)+"\n";
} 
Esempio n. 8
0
Cell* op_plus::eval_op(Cell* operand) const
{
  // keep adding until reaches nil pointer
  int int_sum = 0;
  double double_sum = 0.0;
  bool double_exist = false;

  //to store the result of car cell if it is a list
  Cell* operand_ptr;

  //check if operand is not empty
  while(!nullp(operand))
  {
    if (nullp(car(operand)))
    {
       if (operand_ptr != NULL)
          delete operand_ptr;
       throw runtime_error("'+' can only deal with integer and double.");
    }
    else if (listp(car(operand)))
    {
       operand_ptr = eval(car(operand));
    }
    else if (symbolp(car(operand)))
    {
       operand_ptr = search_symbol(get_symbol(car(operand)),true);
    }
    else
    {
       operand_ptr = car(operand);
    }

    if (intp(operand_ptr))
    {
       int_sum += get_int(operand_ptr);
    }
    else if (doublep(operand_ptr))
    {
       double_sum += get_double(operand_ptr);
       double_exist = true;
    }
    else
    {
       delete operand_ptr;
       throw runtime_error("'+' can only deal with integer and double.");
    }

    operand = cdr(operand);
  }
  
  if (double_exist)
    return make_double(double_sum+int_sum);
  else
    return make_int(int_sum);
};
Esempio n. 9
0
static obj_t *
lang_quote(obj_t **frame, obj_t **tailp)
{
    obj_t *expr = *frame_ref(frame, 0);
    *tailp = NULL;

    if (nullp(expr) || !nullp(pair_cdr(expr))) {
        fatal_error("quote -- wrong number of argument", frame);
    }
    return pair_car(expr);
}
Esempio n. 10
0
void judge_nil_cell(Cell* const c, string oper)
{
  if (!nullp(c)) {
    return;
  }

  if (nullp(c) && oper != "begin") {
    throw operate_on_nil_error(oper + " operator requires non-nil operand");
  }

  if (nullp(c) || oper == "begin") {
    throw operate_on_nil_error("empty list cannot be evaluated");
  }
}
Esempio n. 11
0
static obj_t *
lang_quasiquote(obj_t **frame, obj_t **tailp)
{
    obj_t *expr = *frame_ref(frame, 0);
    obj_t *content;
    *tailp = NULL;
    if (nullp(expr) || !nullp(pair_cdr(expr))) {
        fatal_error("quasiquote -- wrong number of argument", frame);
    }

    // Expand...
    content = pair_car(expr);
    return expand_quasiquote(frame, content, NULL);
}
Esempio n. 12
0
OBJ lookup_variable_value(OBJ name,OBJ env)
{
	OBJ find;

	while(!nullp(env))
	{
		find = assq(name,env_frame(env));
		if(!nullp(find))
			return cdr(find);
		env = env_base(env);
	}
	if(find == OBJ_NULL)
		fprintf(stderr,"undefined variable:%s\n",obj_symbol_data(name));
	return OBJ_NULL;
}
Esempio n. 13
0
//
// list creation/access
//
node *lastcell(node *list) {
    node *ptr = list;
    while (consp(ptr) and not nullp(cdr(ptr))) {
        nextptr(ptr);
    }
    return ptr;
}
Esempio n. 14
0
static environment_t* only(environment_t* e, cons_t* ids)
{
  assert_type(PAIR, ids);

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

  for ( dict_t::const_iterator i = e->symbols.begin();
        i != e->symbols.end(); ++i )
  {
    std::string name = (*i).first;

    // only import specified names
    // TODO: Fix slow O(n^2) algo below
    for ( cons_t *id = ids; !nullp(id); id = cdr(id) ) {
      assert_type(SYMBOL, car(id));

      if ( symbol_name(car(id)) == name ) {
        r->symbols[name] = (*i).second;
        break;
      }
    }
  }

  return r;
}
Esempio n. 15
0
int	last(int lis){
    
    while(!nullp(cdr(lis)))
    	lis = cdr(lis);
    
    return(car(lis));
}
Esempio n. 16
0
cons_t* proc_mul(cons_t *p, environment_t *env)
{
  rational_t product;
  product.numerator = 1;
  product.denominator = 1;
  bool exact = true;

  for ( ; !nullp(p); p = cdr(p) ) {
    cons_t *i = listp(p)? car(p) : p;

    if ( integerp(i) ) {
      product *= i->number.integer;
      if ( !i->number.exact ) exact = false;
    } else if ( rationalp(i) ) {
      if ( !i->number.exact ) exact = false;
      product *= i->number.rational;
    } else if ( realp(i) ) {
      // automatically convert; perform rest of computation in floats
      exact = false;
      return proc_mulf(cons(real(product), p), env);
    } else
      raise(runtime_exception("Cannot multiply integer with " + to_s(type_of(i)) + ": " + sprint(i)));
  }

  return rational(product, exact);
}
Esempio n. 17
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);
}
Esempio n. 18
0
string print_vars(mixed *vars) {
    string *result = allocate(sizeof(vars));
    int i;

    for (i=0; i<sizeof(vars); i++) {
	if (mapp(vars[i]))
	    result[i] = "([ ... ])";
	else if (functionp(vars[i]))
	    result[i] = "(: ... :)";
	else if (intp(vars[i]))
	{
	    if (vars[i]) result[i]=vars[i]+"";
	    else if (nullp(vars[i])) result[i]="NULL";
	    else if (undefinedp(vars[i])) result[i]="UNDEFINED";
	    else result[i]="0";
	}
	else if (stringp(vars[i]))
	    result[i] = "\""+vars[i]+"\"";
	else if (arrayp(vars[i]))
	    result[i] = "({ ... })";
	else if (floatp(vars[i]))
	    result[i] = vars[i]+"";
	else if (bufferp(vars[i]))
	    result[i] = "<BUFFER>";
    }
    return implode(result, ", ");
}
Esempio n. 19
0
File: mlis.c Progetto: kzfm1024/misc
int f_cond(int arglist){
    int arg1,arg2,arg3;
    
    if(nullp(arglist))
        return(NIL);
    
    arg1 = car(arglist);
    checkarg(LIST_TEST, "cond", arg1);
    arg2 = car(arg1);
    arg3 = cdr(arg1);
    
    if(! (nullp(eval(arg2))))
        return(f_begin(arg3));
    else
        return(f_cond(cdr(arglist)));
}
Esempio n. 20
0
cons_t* proc_lcm(cons_t* p, environment_t* e)
{
  switch ( length(p) ) {
  case 0:
    return integer(1);

  case 1:
    assert_type(INTEGER, car(p));
    return integer(abs(car(p)->number.integer));

  case 2: {
    assert_type(INTEGER, cadr(p));

    int a = abs(car(p)->number.integer),
        b = abs(cadr(p)->number.integer);

    return integer(lcm(a, b));
  }

  default: {
    /*
     * We have at least 3 numbers; handle recursively, since
     * lcm(a, b, c) = lcm(lcm(a, b), c)
     */
    cons_t *r = car(p);
    p = cdr(p);

    while ( !nullp(p) ) {
      r = proc_lcm(list(r, car(p)), e);
      p = cdr(p);
    }

    return integer(r->number.integer);
  } }
}
Esempio n. 21
0
static environment_t* except(environment_t* e,  cons_t* ids)
{
  assert_type(PAIR, ids);

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

  for ( dict_t::const_iterator i = e->symbols.begin();
        i != e->symbols.end(); ++i )
  {
    std::string name = (*i).first;

    // do not import specified name
    // TODO: Fix slow O(n^2) algo below
    for ( cons_t *id = ids; !nullp(id); id = cdr(id) ) {
      assert_type(SYMBOL, car(id));

      if ( symbol_name(car(id)) == name )
        goto DO_NOT_IMPORT;
    }

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

DO_NOT_IMPORT:
    continue;
  }

  return r;
}
Esempio n. 22
0
static int
parse_headword(chasen_cell_t *cell, int default_weight, lexicon_t *lex)
{
    chasen_cell_t *headword;

    if (atomp(cell)) {
	headword = cell;
	lex->weight = (unsigned short)default_weight;
    } else if (atomp(cha_car(cell))) {
	headword = cha_car(cell);
	if (nullp(cha_cdr(cell)))
	    lex->weight = (unsigned short)default_weight;
	else if (!atomp(cha_car(cha_cdr(cell))))
	    return err_msg("has invalid form", cell);
	else {
	    int weight;
	    weight = (int)(atof(s_atom_val(cha_car(cha_cdr(cell))))
			   * MRPH_DEFAULT_WEIGHT);
	    if (weight < 0) {
		weight = 0;
		return err_msg(": weight must be between 0 and 6553.5", cell);
	    } else if (weight > MRPH_WEIGHT_MAX) {
		weight = MRPH_WEIGHT_MAX;
		return err_msg(": weight must be between 0 and 6553.5", cell);
	    }
	    lex->weight = (unsigned short)weight;
	}
    } else {
	return err_msg("has invalid form", cell);
    }
    if (get_string(headword, lex->headword, MIDASI_LEN) < 0)
	return -1;

    return lex->weight;
}
Esempio n. 23
0
cons_t* proc_add(cons_t *p, environment_t* env)
{
  /*
   * Integers have an IDENTITY, so we can do this,
   * but a more correct approach would be to take
   * the value of the FIRST number we find and
   * return that.
   */
  rational_t sum;
  sum.numerator = 0;
  sum.denominator = 1;
  bool exact = true;

  for ( ; !nullp(p); p = cdr(p) ) {
    cons_t *i = listp(p)? car(p) : p;

    if ( integerp(i) ) {
      if ( !i->number.exact ) exact = false;
      sum += i->number.integer;
    } else if ( rationalp(i) ) {
      if ( !i->number.exact ) exact = false;
      sum += i->number.rational;
    } else if ( realp(i) ) {
      // automatically convert; perform rest of computation in floats
      exact = false;
      return proc_addf(cons(real(sum), p), env);
    } else
      raise(runtime_exception(
        "Cannot add integer with " + to_s(type_of(i)) + ": " + sprint(i)));
  }

  return rational(sum, exact);
}
/*
 * (set-video-mode <width> <height> <bits per pixel>?) or
 * (set-video-mode <width> <height> <bits per pixel> <mode flags>+)
 *
 * where <symbols> are:
 *  swsurface
 *  hwsurface
 *  asyncblit
 *  anyformat
 *  hwpalette
 *  doublebuf
 *  fullscreen
 *  opengl
 *  openglblit
 *  resizable
 *  noframe
 *
 */
cons_t* set_video_mode(cons_t* p, environment_t*)
{
  assert_length_min(p, 2);
  assert_type(INTEGER, car(p));
  assert_type(INTEGER, cadr(p));

  // dimension
  int x = car(p)->integer;
  int y = cadr(p)->integer;

  // default values
  int bits = 32;
  uint32_t mode = 0;

///////////////////
  raise(runtime_exception("Testing"));
///////////////////

  // bits per pixel
  if ( integerp(caddr(p)) )
    bits = caddr(p)->integer;

  // options
  cons_t *opts = symbolp(caddr(p))? cddr(p) :
                 symbolp(cadddr(p))? cdddr(p) : nil();;

  for ( cons_t *s = opts; !nullp(s); s = cdr(s) ) {
    assert_type(SYMBOL, car(s));

    std::string sym = symbol_name(s);
    int size = sizeof(sdl_flags) / sizeof(key_value_t<std::string, uint32_t>);

    for ( int n=0; n < size; ++n )
      if ( sym == sdl_flags[n].key ) {
///////////////////
printf("flag %s\n", sym.c_str());
printf("value %d and %d\n", sdl_flags[n].value, SDL_HWSURFACE);
///////////////////
        mode |= sdl_flags[n].value;
        goto NEXT_FLAG;
      }

    raise(runtime_exception("Unknown SDL video mode flag: " + sym));

NEXT_FLAG:
    continue;
  }

  mode = SDL_HWSURFACE;
///////////////////
  printf("video mode\n"); fflush(stdout);
///////////////////

  SDL_Surface *screen = SDL_SetVideoMode(x, y, bits, mode);

  if ( screen == NULL )
    raise(runtime_exception(SDL_GetError()));

  return pointer(new pointer_t("sdl-surface", (void*)screen));
}
Esempio n. 25
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;
}
Esempio n. 26
0
cons_t* proc_import(cons_t* p, environment_t* e)
{
  assert_length_min(p, 1);
  assert_type(PAIR, car(p));

  /*
   * Handle all import sets in (import <import set> ...)
   */
  for ( ; !nullp(p); p = cdr(p) ) {
    environment_t *impenv = import_set(car(p));

    /*
     * Now we need to bring the imported environment to the environment,
     * so that the new definitions are available there.
     *
     * We do this by copying the definitions.
     */
    merge(e, impenv);

    /*
     * But we also need to connect the lower level imported environment to
     * definitions found in its outer environment.
     *
     * This is because the exported functions in impenv must be able to see
     * definitions in the toplevel, controlling, environment.
     *
     * Consider the (mickey environment) module, which has a "syntactic"
     * procedure bound?.
     *
     * If we (import (scheme write)) then we get the procedure display.  But
     * if we now (import (mickey environment)) and call (bound? display)
     * then bound? will not be able to see any definition of display, and
     * will wrongly return #f.
     *
     * Note that I'm not entirely certain that this is the correct way of
     * handling things, since closures must be evaluated in the environment
     * they were defined in.
     *
     * TODO: Think hard about this and write some tests.
     *
     * Note that this behaviour might be different for libraries that are
     * imported as scheme source code.  They must be first evaluated in
     * their own closed environment (to bind definitions) before being
     * connected to the outer one.
     *
     * I think what we need is a global pointer to the ACTUAL top-level
     * environment.
     *
     */
    impenv->outer = e;
  }

  /*
   * TODO: Should we return the final environment, so we can easily run
   * cond-expand on it from outside define-library?  E.g., (cond-expand
   * (import (foo bar)))
   */
  return unspecified(nil());
}
Esempio n. 27
0
static void generate_app(struct vec *v,OBJ ast)
{
	OBJ procedure;
	OBJ primitive;
	OBJ cell;
	OBJ formals;

	if(obj_app_type(ast) == 0) /* procedure */
	{
		generate_begin(v,obj_app_params(ast));
		procedure = obj_app_data(ast);
		formals = obj_procedure_formals(procedure);
		while(obj_pairp(formals))
		{
			emit(v,PUSH);
			emitv(v,car(formals));
			emit(v,SET_CDR);
			emit(v,POP);
			formals = cdr(formals);
		}
		if(!nullp(formals))
		{
			emit(v,PUSH);
			emitv(v,formals);
			/* fixme: something should do to support other form formals */
		}
		emit(v,PUSH);
		emitv(v,procedure);
		emit(v,obj_app_tail(ast)?TAIL_CALL:CALL);
	}
	else if(obj_app_type(ast) == 1) /* primitive */
	{
		generate_begin(v,obj_app_params(ast));
		primitive = obj_app_data(ast);
		switch(obj_primitive_type(primitive))
		{
		case DATA:
			emit(v,obj_primitive_opcode(primitive));
			emitv(v,obj_primitive_data(primitive));
			break;
		case FUNCALL:
			emit(v,obj_primitive_opcode(primitive));
			emitv(v,obj_primitive_proc(primitive));
			break;
		default:
			emit(v,obj_primitive_opcode(primitive));
		}
	}
	else if(obj_app_type(ast) == 2) /* uninitialized procedure */
	{
		cell = obj_app_data(ast);
		generate_begin(v,obj_app_params(ast));
		emit(v,PUSH);
		emitv(v,cell);
		emit(v,UNINIT_REF);
		emit(v,BIND);
		emit(v,obj_app_tail(ast)?TAIL_CALL:CALL);
	}
}
Esempio n. 28
0
int assv(int obj, int lis){
	while(!nullp(lis))
    	if(eqvp(obj,caar(lis)))
        	return(car(lis));
        else
        	lis = cdr(lis);
    return(BOOLF);
}
Esempio n. 29
0
//
// argument/struture access
//
node *nextarg(node **pargs) {
    if (not consp(*pargs) or nullp(*pargs)) {
        setflag("too few arguments\n");
    }
    node *arg = car(*pargs);
    *pargs = cdr(*pargs);
    return arg;
}
Esempio n. 30
0
File: mlis.c Progetto: 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)));
}