Exemplo n.º 1
0
void 
process()
{
	sprozitev();
	let();
	tajmer();	
}
Exemplo n.º 2
0
static bool pbind_vars(obj* vars, obj lt){
	obj utype;
	switch(lt->type){
    default:
        break;
	case tSymbol:
		if(vars) add_assoc(vars, lt, nil); 
		return true;
	case tRef:
		assert(0);
		let(&(uref(lt)), nil);
		return true;
	case INT:
		assert(0);
	//	return equal(lt,rt);
	case tOp:
		utype = search_assoc(curr_interp->types, ult(lt));
		if(utype){
			return pbind_vars(vars, urt(lt));
		}
		pbind_vars(vars, ult(lt));
		return pbind_vars(vars, urt(lt));
	case LIST:
		list x=ul(lt);
		for(; (x); x=rest(x)){
			pbind_vars(vars, first(x));
		}
		return true;
	}
	print(lt);
	assert(0);
	return nil;
}
Exemplo n.º 3
0
static obj func_def(obj name, obj params, obj expr) {
	assert(type(name)==tSymbol);
	obj* func = lfind_var(name);
	if(! *func) {
		obj (*fn)(obj) = searchFunc(name, infnbind);
		if(fn) let(func, tag(fn));
	}
	list lam = list3(retain(params), retain(expr), retain(env));
    if(*func){
        if(type(*func)==tClosure){			// free if complete overload, in the future
            lam = merge(lam, retain(ul(*func)));
        } else if(type(*func)==tInternalFn){
            lam = merge(lam, list3(retain(*func), nil, nil));
        }
    }
	return retain(*let(func, render(tClosure, lam)));
}
 vector<string> letterCombinations(string digits) {
     // Start typing your C/C++ solution below
     // DO NOT write int main() function
     char* dig[]={" ","","abc","def","ghi","jkl","mno","pqrs","tuv","wxyz"};
     vector<string> let(dig, dig+10);
     vector<string> res;
     string str;
     recLetComb(digits,0,res,str,let);
     return res;
 }
Exemplo n.º 5
0
static obj do_assign(obj lt, obj rt){
	switch(type(lt)) {
	case tRef:
		return retain(*let(&(uref(lt)), rt));
	case tSymbol:
		return retain(*let(lfind_var(lt),rt));
    default:
        break;
	case tInd:{
		obj *var;
		var = lfind_var(ult(lt));
		if(!*var) error("the vector does not exist.");
		if((*var)->refcount > 1){
			obj nv = copy(*var);
			release(*var);
			*var = nv;
			myPrintf("performance alert: copy");
		}
		obj inds = eval(urt(lt));
		doLInd(var, ul(inds), rt);
		release(inds);
		return retain(rt);
        }
    case LIST:
		return applyCC(do_assign, lt, rt);
		
		if(type(rt)!=LIST) error("list<-nonlist");
		list s = ul(rt);
		for(list l = ul(lt); l; l=rest(l), s=rest(s)){
			if(! s) error("number is not enough for rhs.");
			do_assign(first(l),first(s));
		}
		if(s) error("too much for rhs.");
		return nil;
	}
	print(lt);
	assert(0);
	return nil;
}
Exemplo n.º 6
0
static bool bind_vars(obj* vars, obj lt, obj rt){
	obj utype;
	switch(lt->type){
    default:
        break;
	case tSymbol:
		if(macromode){
			if(obj rr = search_assoc(car(macro_env), lt)){
				//macromode = false;
				if(vars) add_assoc(vars, rr, rt);
				//macromode = true;
				return true;
			}
		}
		if(vars) add_assoc(vars, lt, rt);
		return true;
	case tRef:
		let(&(uref(lt)), rt);
		return true;
	case INT:
		return equal(lt, rt);
	case tOp:
		utype = search_assoc(curr_interp->types, ult(lt));
		if(utype){
			if(vrInt(utype) != rt->type) return false;
			return bind_vars(vars, urt(lt), uref(rt));
		}
		if(rt->type!=tOp) return false;
		if(! bind_vars(vars, ult(lt), ult(rt))) return false;
		return bind_vars(vars, urt(lt), urt(rt));
	case LIST:
		if(rt->type!=LIST) return false;
		list x=ul(lt), a=ul(rt);
		for(; (x && a); x=rest(x),a=rest(a)){
			if(!bind_vars(vars, first(x), first(a))) return false;
		}
		if(x||a) return false;
		return true;
	}
	print(lt);
	assert(0);
	return nil;
}
Exemplo n.º 7
0
/*------------------------------------------------------------------
  dp_pass0  линейный проход в растре r на множестве ncut
            точек cut_list; vers_list - результаты для отдельных
            сегментов; LC - cell слева от растра
------------------------------------------------------------------*/
void dp_pass0(cell *CP, raster *rp, struct cut_elm *cutp,
              seg_vers **versp, int16_t n)
{
  int16_t i,j,x;
  int16_t i1,i2;
  uchar let;
  int16_t cc;
  struct cut_elm *cut;
  SVERS *vers;
  int16_t pass;
//  seg_vers *cur_vers;

  if ((ncut=n)<2)  return;
  LC=CP; r=rp; cut_list=cutp; vers_list=versp;
  iemax=ncut-1;  right_dust=0;  fl_b=0;  connect_=1;
  ie1=iemax;  vers=&cut_list[ie1].versm;
  ie2=ir=(let(vers) || dust(vers)) ? ie1-1 : ie1;
  ib1=ib2=0;      vers=&cut_list[1].versm;
  if (let(vers))  ib2=1;
  else
    if (cut_list->gvarm & c_cg_cutdone)  ib2=on_path(0,ie2,cut_list);
  iec=ib2;  ibc=ie2;
  w1=sym_width-(sym_width>>2);  w2=sym_width+(sym_width>>2);  h2=r->h<<1;
  cut=cut_list+ie1;
/*
//отщепляем правые dust'ы
  if (dust(&cut->versm) && cut->duflm==0)
  {
    right_dust=1;  iemax--;  cut--;
//    if (dust(&cut->versm) && cut->duflm==0)  iemax--;
    ir=ie1=ie2=iemax;
  }
*/
//крайние хорошие распознаем с сопутствующими dust'ами
  if (ie1 != ie2 && cut->duflm)
    addij(LC,r,cut_list,vers_list,ncut,ie2,ie1,0);
  if (ib1 != ib2)
  {
    cut=cut_list+ib2;
    if (cut->duflm)
		addij(LC,r,cut_list,vers_list,ncut,ib1,ib2,0);
    if ((let=cut->versm.vers[0].let)==(uchar)'ь' &&
			!is_russian_baltic_conflict(let) ||		// 17.07.2001 E.P.
			let==(uchar)'Ь'
	   )
      fl_b=1;
  }

  if (ib2>=ie2)
  {
    addij(LC,r,cut_list,vers_list,ncut,ib1,ie1,0);
    goto test_right_dust;
  }

  do
  {
    if (!fl_b && iec != iemax)
    {
#ifndef MY_DEBUG
    if (det_trace)
#endif
      cg_show_rast(LC,r,"left to right",cut_list); //растр - на экран

      cc=l2r(&ib1,&ib2,&il);
      if (cc)  goto finish;

      if (il<iemax && iec>il &&
          (cut=cut_list+il)->dh==0 &&
          (x=cut->x-cut_list->x) < h2 && x > sym_width>>1 &&
          cut->versm.vers[0].prob>=190 &&
          !not_connect_sect(0,il,cut_list))
      {                 //оставим, как есть, и попробуем дальше
        i1=i2=il;
        cc=l2r(&i1,&i2,&i);
        if (cc)         //дальше - хорошо, вернемся к подозрительному участку
        {
  if (debug_on)
#ifndef MY_DEBUG
    if (det_trace)
#endif
    {
      sprintf(snap_text,"right side reached, return %d-%d",0,il);
      cg_show_rast(LC,r,snap_text,cut_list); //растр - на экран
    }
          ib1=i1;  ib2=i2;  i1=i2=il;  il=i;
          cc=r2l(&i,&i2,&i1,0);
          goto finish;
        }
      }
    }
    if (ibc != 0 && abs(cut_list[ie2].x-cut_list[ib2].x)>minw)
    {
    //слева не вышло, пробуем справа налево

  if (debug_on)
#ifndef MY_DEBUG
    if (det_trace)
#endif
    {
      sprintf(snap_text,"left: reliable=%d advance=%d; try right",ib2,il);
      cg_show_rast(LC,r,snap_text,cut_list); //растр - на экран
    }

      cc=r2l(&ir,&ie2,&ie1,2);
      if (cc)  goto finish;

      if (ir>0 && ibc<ir &&
          (cut=cut_list+ir)->dh==0 &&
          (x=cut_list[iemax].x-cut->x) < h2 && x > sym_width>>1 &&
          cut_list[iemax].versm.vers[0].prob>=190 &&
          !not_connect_sect(ir,iemax,cut_list))
      {                 //оставим, как есть, и попробуем дальше
        i1=i2=ie2;
        cc=r2l(&i,&i2,&i1,2);
        if (cc)         //дальше - хорошо, вернемся к подозрительному участку
        {
  if (debug_on)
#ifndef MY_DEBUG
    if (det_trace)
#endif
    {
      sprintf(snap_text,"left side reached, return %d-%d",ir,iemax);
      cg_show_rast(LC,r,snap_text,cut_list); //растр - на экран
    }
          ie1=i1;  ie2=i2;  i1=i2=ir;  ir=i;
          cc=l2r(&i1,&i2,&i);
          goto finish;
        }
      }
    }
    if (abs(cut_list[ie2].x-cut_list[ib2].x)<=minw)
    {
      j=on_path(ie2,iemax,cut_list);
      if (j==0)  break;
      if (ib2==0)  addij(LC,r,cut_list,vers_list,ncut,0,j,0);
      else         one_cut(cut_list[ib2].px,ib2,ie2,j);
      goto test_right_dust;
    }

    if (il==ie2 && (iec>il || iec==iemax) &&
        ir==ib2 && (ibc<ir || ibc==0)     &&
        cut_list[ie2].versm.vers[0].prob>MINlet)
      goto finish;
    if (il==ie2 && (iec>il || iec==iemax) || ir==ib2 && (ibc<ir || ibc==0))
      if (cut_list[ie2].versm.vers[0].prob>=190)  goto finish;
    if (il==ir)
    {
      version *vers0;
      char *ilet;
      if (connect_ && cut_list[il].dh==0)
      {
        addij(LC,r,cut_list,vers_list,ncut,ib2,ie2,0);
        if (cut_list[ie2].versm.vers[0].prob>trs2)  goto finish;
      }
      if (ir != ie2 && cut_list[ie2].x-cut_list[ir].x > w2)
      {
        i1=i2=ir;
        if ( l2r(&i1,&i2,&i) || i>0 && on_path(i,iemax,cut_list) &&
             cut_list[i].versm.vers[0].prob>=190)
        {
          j=on_path(ir,iemax,cut_list);
          vers0=&cut_list[j].versm.vers[0];
          if ( (let=vers0->let)==(uchar)'т' &&
			  !is_russian_baltic_conflict(let) && 	// 17.07.2001 E.P.
			  !is_russian_turkish_conflict(let) 	// 21.05.2002 E.P.
			  )
            ie1=j;
          else
            if ( (ilet=strchr(letters_right_to_bad,let))!=0 &&
			    !is_russian_baltic_conflict(let) // 17.07.2001 E.P.
			   )
              if (vers0->prob < prob_right_to_bad[(uchar*)ilet-letters_right_to_bad])
                ie1=j;          //может быть частью буквы
          ie2=ir;
        }
      }
      if (il != ib2 && cut_list[il].x-cut_list[ib2].x > w2)
      {
        i2=il;  i1 = (ie2==il) ? ie1 : i2;
        if (r2l(&i,&i2,&i1,0) || on_path(i,ib2,cut_list) &&
            cut_list[i2].versm.vers[0].prob>=190)
        {
          cut=cut_list+il;
          vers0=&cut->versm.vers[0];
          if ((let=vers0->let)==(uchar)'т' &&
			  !is_russian_baltic_conflict(let) && 	// 17.07.2001 E.P.
			  !is_russian_turkish_conflict(let) 	// 21.05.2002 E.P.
			  )
            ib1=cut->px;
          else
            if ( (ilet=strchr(letters_right_to_bad,let)) !=0 &&
			    !is_russian_baltic_conflict(let) // 17.07.2001 E.P.
			   )
              if (vers0->prob < prob_right_to_bad[(uchar*)ilet-letters_right_to_bad])
                ie1=cut->px;          //может быть частью буквы
          ib2=il;
        }
      }
      if (ib2==ie2)  goto finish;
    }
//    if (il>ir)  break;
//    if (iec==iemax || ibc==0 || iec<ibc)  break;
    if (iec==iemax && ibc==0)  break;
    connect_ = 1-connect_;
  }
  while (!connect_);

  if (right_dust)
    if (glue_right_dust())
    {
      spec_pairs();  return;
    }

  if (debug_on)
#ifndef MY_DEBUG
    if (det_trace)
#endif
    {
      sprintf(snap_text,"right: reliable=%d advance=%d; ",ie2,ir);
      cg_show_rast(LC,r,snap_text,cut_list); //растр - на экран
    }

  //не сошлись, запускаем ДП между ними

  if (ie1-ib1 <= 2)
    if (!good_path(cut_list,ncut))  { ib1=ib2=0; ie2=ie1=ncut-1; }

DP:
  if (ie1-ib1 <= 2)
  {
    spec_pairs();  return;
  }

  il=ib1; ir=ie1;

  for (pass=1; pass<=4; pass++)
  {
    dp_bound(cut_list,vers_list,pass,&il,&ir);
    if (ir<=il)
    {
      if (ib1 != 0 || ie1 != ncut-1)  spec_pairs();   //неполное ДП
      return;
    }
#ifndef MY_DEBUG
    if (det_trace)
#endif
    {
      sprintf(snap_text,"try DP %d-%d pass=%d",il,ir,pass);
      cg_show_rast(LC,r,snap_text,cut_list); //растр - на экран
    }
    for ( i=il+1; i<=ir; i++ )
    {
      if ( !ben_cut(cut_list+i) )  //разрешен на данном проходе
      {
        snap_newpoint(i);
        for (j=i-1; j>=il; j--)
          if ( !ben_cut(cut_list+j) )
            if (addij(LC,r,cut_list,vers_list,ncut,j,i,0) & 8)  break                                                               ;
      }                                                     //8-широк                                                               ий
    }
  }  //pass

  if (ib1==0 && ie1==ncut-1)  return;   //полное ДП - больше нечего делать

  if (good_path(cut_list,ncut))  { spec_pairs();  return; }

//ДП по всему участку

  il=0;  ir=ncut-1;
  for (pass=1; pass<=4; pass++)
  {
    dp_bound(cut_list,vers_list,pass,&il,&ir);
    if (ir<=il)  return;
    if (il>=ib1 && ir<=ie1)  return; //на этом интервале уже считали
/*
    {
      struct cut_elm *cute=cut_list+ir;
      for (cut=cut_list+(il+1); cut<cute; cut++)
        if ((cut->var & 0x7F)==40)  break;
      if (cut==cute)  return;  //новых точек не будет
    }
*/
#ifndef MY_DEBUG
    if (det_trace)
#endif
    {
      sprintf(snap_text,"try DP %d-%d pass=%d",il,ir,pass);
      cg_show_rast(LC,r,snap_text,cut_list); //растр - на экран
    }
    for ( i=il+1; i<=ir; i++ )
    {
      if ( !ben_cut(cut_list+i) )  //разрешен на данном проходе
      {
        snap_newpoint(i);
        for (j=i-1; j>=il; j--)
          if ( !ben_cut(cut_list+j) )
            if (addij(LC,r,cut_list,vers_list,ncut,j,i,0) & 8)  break                                                               ;
      }                                                     //8-широк                                                               ий
    }
  }  //pass
  return;

test_right_dust:
  if (right_dust)  glue_right_dust();
  if (!good_path(cut_list,ncut))  { ib1=ib2=0; ie2=ie1=ncut-1; goto DP; }
  spec_pairs();
  return;

finish:
  if (right_dust)  glue_right_dust();
  spec_pairs();
  return;
}
Exemplo n.º 8
0
void int32_v (FILE *fd, char *symb, int32_t value)
{ let (fd, symb); fprintf (fd, " = 0x%Xl\n", value); }
Exemplo n.º 9
0
void int_vx (FILE *fd, char *symb, int value)
{ let (fd, symb); fprintf (fd, " = 0x%X\n", value); }
Exemplo n.º 10
0
void int_v (FILE *fd, char *symb, int value)
{ let (fd, symb); fprintf (fd, " = %d\n", value); }
Exemplo n.º 11
0
void str_v (FILE *fd, char *symb, const char *value)
{ let (fd, symb); fprintf (fd, " = \"%s\"\n", value); }
Exemplo n.º 12
0
uptr_t exec_special(uptr_t *env, uptr_t form) {
  uptr_t fn = CAR(form);
  uptr_t args = CDR(form);

  switch(SVAL(fn)) {
  case S_LET:
    return let(env, args);

  case S_FN:
    return form;

  case S_LOOP:
    return loop(env, args);

  case S_DO: {
    uptr_t *body_p = refer(args), rval = NIL;

    while (*body_p) {
      rval = eval(env, CAR(*body_p));
      *body_p = CDR(*body_p);
    }
    release(1); // body_p
    return rval;
  }

  case S_RECUR: {
    uptr_t rval, *fn_p = refer(fn);
    rval = build_cons(*fn_p, eval_list(env, args));
    release(1); // fn_p
    return rval;
  }

  case S_QUOTE:
    return CAR(args);

  case S_CAR:
    return CAR(eval(env, CAR(args)));

  case S_CDR:
    return CDR(eval(env, CAR(args)));

  case S_AND: {
    if (IS_NIL(args)) return PS_TRUE;
    uptr_t *rem_args = refer(args),
      rval = NIL;
    while ((rval = eval(env, CAR(*rem_args))) && (*rem_args = CDR(*rem_args)));
    release(1);
    return rval;
  }

  case S_OR: {
    if (IS_NIL(args)) return NIL;
    uptr_t *rem_args = refer(args),
      rval = NIL;
    while (!(rval = eval(env, CAR(*rem_args))) && (*rem_args = CDR(*rem_args)));
    release(1);
    return rval;
  }

  case S_NOT: {
    if (IS_NIL(args)) return NIL;
    uptr_t rval = eval(env, CAR(args));
    return rval ? NIL : PS_TRUE;
  }

  case S_IF: {
    uptr_t rval = NIL, *clauses = refer(args);

    if (eval(env, CAR(*clauses)) && CDR(*clauses))
      rval = eval(env, CADR(*clauses));
    else if (CDDR(*clauses))
      rval = eval(env, CADDR(*clauses));

    release(1); // clauses
    return rval;
  }

  case S_WHEN: {
    uptr_t rval = NIL, *cond_p = refer(CAR(args)), *body_p = refer(CDR(args));

    if (eval(env, *cond_p))
      while(*body_p) {
        rval = eval(env, CAR(*body_p));
        *body_p = CDR(*body_p);
      }

    release(2); // cond_p, body_p
    return rval;
  }

  case S_CONS: {
    uptr_t rval = NIL, *args_p = refer(args);
    rval = build_cons(eval(env, CAR(*args_p)), eval(env, CADR(*args_p)));
    release(1); // args_p
    return rval;
  }

  case S_PRINT:
    print_form(eval(env, CAR(args)));
    printf_P(PSTR("\n"));
    return NIL;

  case S_DEF: {
    uptr_t *args_p = refer(args),
      *binding = refer(eval(env, CADR(args)));
    assoc(env, CAR(*args_p), *binding);
    release(2); // args_p, binding
    return *binding; // Yeah, it's been "released", but the pointer is still valid.
  }

  case S_EVAL:
    return eval(env, eval(env, CAR(args)));

#define _COMPR(rval) {                                                  \
      if (IS_NIL(args)) return NIL;                                     \
                                                                        \
      uptr_t *args_p = refer(args);                                     \
      while(CDR(*args_p) && (eval(env, CAR(*args_p)) _COMP_OPR eval(env, CADR(*args_p)))) \
        *args_p = CDR(*args_p);                                         \
                                                                        \
      if (IS_NIL(CDR(*args_p)))                                         \
        rval = eval(env, CAR(*args_p));                                 \
      release(1);                                                       \
    }

#define _COMP_OPR ==
  case S_EQL: {
    uptr_t rval = NIL;
    _COMPR(rval);
    return rval;
  }

  case S_NEQL: {
    uptr_t rval = NIL;
    _COMPR(rval);
    return rval ? NIL : PS_TRUE;
  }
#undef _COMP_OPR

#define _COMP_OPR <
  case S_LT: {
    uptr_t rval = NIL;
    _COMPR(rval);
    return rval;
  }
#undef _COMP_OPR

#define _COMP_OPR <=
  case S_LTE: {
    uptr_t rval = NIL;
    _COMPR(rval);
    return rval;
  }
#undef _COMP_OPR

#define _COMP_OPR >
  case S_GT: {
    uptr_t rval = NIL;
    _COMPR(rval);
    return rval;
  }
#undef _COMP_OPR

#define _COMP_OPR >=
  case S_GTE: {
    uptr_t rval = NIL;
    _COMPR(rval);
    return rval;
  }
#undef _COMP_OPR

#define _ARITH(coll) {                                          \
      uptr_t *rem_args = refer(args);                           \
      coll = TO_INT(eval(env, CAR(*rem_args)));                 \
      *rem_args = CDR(*rem_args);                               \
      while (*rem_args) {                                       \
        coll _ARITH_OPR TO_INT(eval(env, CAR(*rem_args)));      \
        *rem_args = CDR(*rem_args);                             \
      }                                                         \
      release(1);                                               \
    }

#define _ARITH_OPR +=
  case S_PLUS: {
    if (! args) return INTERN_INT(0);
    if (! CDR(args)) return eval(env, CAR(args));
    int rval;
    _ARITH(rval);
    return INTERN_INT(rval);
  }
#undef _ARITH_OPR

#define _ARITH_OPR -=
  case S_MINUS: {
    if (! args) return NIL;
    if (! CDR(args)) return INTERN_INT(0 - TO_INT(eval(env, CAR(args))));
    int rval;
    _ARITH(rval);
    return INTERN_INT(rval);
  }
#undef _ARITH_OPR

#define _ARITH_OPR *=
  case S_MULT: {
    if (! args) return INTERN_INT(1);
    if (! CDR(args)) return eval(env, CAR(args));
    int rval;
    _ARITH(rval);
    return INTERN_INT(rval);
  }
#undef _ARITH_OPR

#define _ARITH_OPR /=
  case S_DIV: {
    if (! args) return NIL;
    if (! CDR(args)) return INTERN_INT(eval(env, CAR(args)) == INTERN_INT(1) ? 1 : 0);
    int rval;
    _ARITH(rval);
    return INTERN_INT(rval);
  }
#undef _ARITH_OPR

#define _ARITH_OPR &=
  case S_BAND: {
    if (! args) return NIL;
    if (! CDR(args)) return eval(env, CAR(args));
    uint8_t rval;
    _ARITH(rval);
    return INTERN_INT((int)rval);
  }
#undef _ARITH_OPR

#define _ARITH_OPR |=
  case S_BOR: {
    if (! args) return NIL;
    if (! CDR(args)) return eval(env, CAR(args));
    uint8_t rval;
    _ARITH(rval);
    return INTERN_INT((int)rval);
  }
#undef _ARITH_OPR

#define _ARITH_OPR ^=
  case S_BXOR: {
    if (! args) return NIL;
    if (! CDR(args)) return eval(env, CAR(args));
    uint8_t rval;
    _ARITH(rval);
    return INTERN_INT((int)rval);
  }
#undef _ARITH_OPR

#define _ARITH_OPR <<=
  case S_BSL: {
    if (! args) return NIL;
    if (! CDR(args)) return eval(env, CAR(args));
    uint8_t rval;
    _ARITH(rval);
    return INTERN_INT((int)rval);
  }
#undef _ARITH_OPR

#define _ARITH_OPR >>=
  case S_BSR: {
    if (! args) return NIL;
    if (! CDR(args)) return eval(env, CAR(args));
    uint8_t rval;
    _ARITH(rval);
    return INTERN_INT((int)rval);
  }
#undef _ARITH_OPR

  case S_SREG: {
    uptr_t *args_p = refer(args),
      reg = eval(env, CAR(*args_p));
    if (IS_REG(reg))
      *BYTE_PTR(reg) = eval(env, CADR(*args_p));
    else {
      printf_P(PSTR("Invalid register: "));
      print_form(reg);
      printf_P(PSTR("\n"));
    }
    release(1); // args_p
    return NIL;
  }

  case S_SLP:
    _delay_ms(TO_INT(eval(env, CAR(args))));
    return NIL;

  default:
    printf_P(PSTR("ERROR: "));
    print_form(fn);
    printf_P(PSTR(" is not a function.\n"));
    return NIL;
  }
}
Exemplo n.º 13
0
obj eval(obj exp){
ev:	assert(!! exp);
    obj rr,lt, rt;
	switch (exp->type) {
	case tInd:
		return doInd(eval(ult(exp)), ul(eval(urt(exp))));
	case LIST:
		return List2v(evalList(ul(exp)));
	case tArray:
		return map_obj(eval, exp);
	case tAnd:
		return prod_eval(ul(exp), mult);
	case MULT:
		return prod_eval(ul(exp), mult);
	case ARITH:
		return prod_eval(ul(exp), add);
	case POW:
		return prod_eval(ul(exp), power);
	case DIVIDE:
		return prod_eval(ul(exp), divide);
	case tRef:
		return retain(uref(exp));
	case tSymbol:
		if( macromode) {
			if(obj rr = search_assoc(car(macro_env), exp)){
				macromode = false;
				// macro lexical scope should be pushed to the stack here
				rr = exec(rr);
				macromode = true;
				return rr;
			}
		}
		return eval_symbol(exp);
	case tMinus:
		lt = eval(uref(exp));
		rr = uMinus(lt);	// releasing
		if(rr) {release(lt); return rr;}
		static obj symumn = Symbol("-");
		rr = udef_op0(symumn, lt);
		if(rr) {release(lt); return rr;}
		error("uMinus: not defined to that type");
	case tReturn:
		if(! uref(exp)) return encap(tSigRet, nil);
		return  encap(tSigRet, eval(uref(exp)));
	case tBreak:
		return retain(exp);
	case CONDITION:
		return evalCond(exp);
	case tOp:
		if(type(ult(exp)) ==tSymbol) {
			lt = search_assoc(curr_interp->types, ult(exp));
			if(lt) return encap((ValueType)vrInt(lt), eval(urt(exp)));}
		lt = eval(ult(exp));
		push(lt);
		switch(lt->type){
		case tCont:
			assert(0);
		case tSpecial:
			rr = ufn(lt)(urt(exp));
			break;
		case tSyntaxLam:
			rr = macro_exec(lt, urt(exp));
			break;
		case tInternalFn:
        case tClosure:
			rt = eval(urt(exp));
			rr = eval_function(lt, rt);
			break;
        default:
			rt = eval(urt(exp));
			rr = call_fn(mult, lt, rt);
			release(rt);
		}
		release(pop(&is));
		return rr;
	case tClosure:
		assert(0);
	case tCurry:
		return eval_curry(exp, em0(exp));
/*		obj vars = Assoc();
		bind_vars(&vars, em0(exp), em2(exp));
		rr = eval_curry(exp, vars);
		release(vars);
		return rr;
*/	case tArrow:
//		return enclose(exp);
/*		if(macromode){
			if(obj rr = search_assoc(car(macro_env), exp)){
			}
		}
*/ 		return render(tClosure, list3(retain(em0(exp)), retain(em1(exp)), retain(env)));
	case tDefine:
		return func_def(em0(exp), em1(exp), em2(exp));
	case tSyntaxDef:
		let(lfind_var(em0(exp)),  render(tSyntaxLam, list3(retain(em1(exp)), retain(em2(exp)), nil)));
		return nil;
	case tExec:
		return exec(exp);
	case tAssign:
		lt = car(exp);
		if(type(lt)==tOp){
			return func_def(ult(lt), urt(lt), cdr(exp));
		} else if(type(lt)==tMinus){
			static obj symumn = Symbol("-");
			return func_def(symumn, uref(lt), cdr(exp));
		} else return do_assign(lt, eval(cdr(exp)));
	case tIf:
		rr = eval(em0(exp));
		if (type(rr) != INT) error("if: Boolean Expected");
		if (vrInt(rr)) {
			rr = em1(exp);
		} else {
			rr = em2(exp);
		}
		return eval(rr);
	case tWhile:
		for(;;) {
			rr = eval(car(exp));
			if (type(rr) != INT) error("while: Boolean expected");
			if(!vrInt(rr)) break;
			rr = exec(cdr(exp));
			if(rr && type(rr)==tSigRet) return rr;
			if(rr && type(rr)==tBreak) {release(rr); break;}
			if(rr) release(rr);
		}
		return nil;
	default:
		return retain(exp);
	}
}
Exemplo n.º 14
0
static
obj syntax(obj rt){
	let(lfind_var(car(car(rt))),  render(tSyntaxLam, list3(cdr(car(rt)), cdr(rt), nil)));
	return nil;
}