macro3

(funcall (lambda (p) (funcall p ) )   (lambda () 55) )
(funcall  (lambda (p  x) (funcall p  x) ) (lambda (x) (funcall  x) )   (lambda () (print 35)) )

(defun  myconsc  (  x  y)
(lambda  (p  )  (funcall p  x   y  ) )
)

(defun  mycarc  (z)
(funcall  z  (lambda ( a b)  a) )
)

(defun  mycdrc  (z)
(funcall  z  (lambda  (a  b  ) (funcall b )) )
)

(print (mycarc  (myconsc  4 (lambda () 5 )) ))
(print (mycdrc  (myconsc  4 (lambda () 5 )) ))

(defun  int  (n)
(myconsc  n  (lambda () (int  (+ n  1) )))
)

(setq  chen (int  10)  )
(print (mycarc  chen) )
(print (mycarc (mycdrc  chen)))
(print (mycarc (mycdrc (mycdrc  chen))))

(defmacro  demo  (expr)
(print  expr)
)
(defmacro  mymachine  (exprs)
`(if  ,(eq  exprs  nil)
      nil
     (progn
          (demo ,(car  exprs))
         (mymachine  ,(cdr  exprs) )
      )
)
)

(mymachine   (
(defmacro  demoinside  (expr)
(print  expr)
)
(defmacro  mymachineinside  (exprs)
`(if  ,(eq  exprs  nil)
      nil
     (progn
          (demoinside ,(car  exprs))
         (mymachineinside  ,(cdr  exprs) )
      )
)
)

(mymachineinside  (

(defun  myconsc  (  x  y)
(lambda  (p  )  (funcall p  x   y  ) )
)

(defun  mycarc  (z)
(funcall  z  (lambda ( a b)  a) )
)

(defun  mycdrc  (z)
(funcall  z  (lambda  (a  b  ) (funcall b )) )
)

(print (mycarc  (myconsc  4 (lambda () 5 )) ))
(print (mycdrc  (myconsc  4 (lambda () 5 )) ))

(defun  int  (n)
(myconsc  n  (lambda () (int  (+ n  1) )))
)

(setq  chen (int  10)  )
(print (mycarc  chen) )
(print (mycarc (mycdrc  chen)))
(print (mycarc (mycdrc (mycdrc  chen))))
           
 
))
))
 
$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$

#include  <ctype.h>
#include  <assert.h>
#include  <stdlib.h>
#include  <stdio.h>
#include  <memory.h>
#include <stdarg.h>
#include <string.h>
#include <setjmp.h>
#include  <time.h>
#include  <process.h>

#define  MAX  1000
int  vec_global=0;

typedef void  *  (*funp )(void * _left);
enum tokens {  
 NUMBER = 'n', 
 NAME
};

char * sdl_fun[]={"print","1+","1-","+","cons","cadr","caddr"};
typedef enum  Enum
{
 EMPTY=1,INT,CHAR,FUN,DEFUN,DEFMACRO,VAR,COND,QUOTE,LIST,QUOTE2,
 IF,PROGN,EVAL,SETQ,SETF,PARA,EQ,CONSTREAM,TAIL,CALLCC,SYMBOL,JMPBUF
}Enum;
typedef  enum  forth
{
 ADD=100,MINUS,GETFIRST,DIGIT,TEST,RET,RAND,CALL,GO,PTR,PUSH,
 END,GET,POP,PRINT,NOTHING,SETRET,POPRET,BACK,GETTOP,FUNCALL,LAMBDA
}forth;

typedef struct   Type
{
 enum Enum  em;
 funp  f_data;
 union
 {
  int i_data;
  //  char c_data;
  char s_data[30]; 
  struct Type  *   n_data;
 } u_data;
 struct Type * next;
 struct Type   *m_env;
}Type;

typedef struct env_defun
{
 Type  *name;
 Type  *arg;
 Type  *expr;
}env_defun;
typedef struct env_defmacro
{
 Type  *name;
 Type  *arg;
 Type  *expr;
}env_defmacro;
Type *global_defun=NULL;
Type  *global_defmacro=NULL;
Type  *global_jmpbuf=NULL;
Type  *global_null=NULL;

Type *global_lambda=NULL;

#define  NUM  1000
Type   *mem_manager;
int  global_count=20000;
int mem_count=0;
Type*  new_object()
{
 Type *temp;
 if(global_count<2*mem_count)
 {
  temp=mem_manager;
  global_count=2*global_count;
  mem_manager=(Type *)malloc  (global_count  *sizeof (Type ) );
  memmove(mem_manager,temp,mem_count*sizeof (Type ) );
  free(temp);
 }
 return  &mem_manager[mem_count++];
}
void  *  empty2_type(void)
{
 Type  *result= new_object();
 result->em=INT;
 result->u_data.i_data=999999;
 return  result;
}
void  *  empty_type(void)
{
 Type  *result;
 if(!global_null)
 {
  result= new_object();
  result->em=EMPTY;
  result->u_data.i_data=999999;
  global_null=result;
  return  result;
 }
 else
 {
  return global_null;
 }
}
void * c_copy_type2(void *_right)
{
 Type *left;
 Type  *right=_right;
 if(right->em==EMPTY)
  return right;   //空值不需要拷贝
 left= new_object()   ;
 memcpy(left,right,sizeof( Type) );
 return  left;
}

void * c_cons (void * _left,void *  _right)
{
 Type  *type_data;
 type_data= new_object()   ;
 type_data->em=LIST; 
 type_data->u_data.n_data=_left;
 type_data->next=_right;
 return  type_data;
}
void * c_constream (void * _left,void *  _right)
{
 Type  *type_data;
 type_data=  new_object()   ;
 type_data->em=CONSTREAM; 
 type_data->u_data.n_data=_left;
 type_data->next=_right;
 return  type_data;
}
void  *eval (void ** );
void  *c_car (void  *);
void * c_car_address (void * _left)
{
 Type * left=_left;
 if(left->em==EMPTY)
  return empty_type();
 assert(left->em==LIST); 
 return &(left->u_data.n_data);
}
void * c_car (void * _left)
{
 Type * left=_left;
 if(left->em==EMPTY)
  return empty_type();
 assert(left->em==LIST||left->em==CONSTREAM);  //modidify at  2010.1.8 
 return left->u_data.n_data;
}
void * c_cdr (void * _left)
{ 
 Type * left=_left;
 if(left->em==EMPTY)
  return empty_type();
 assert(left->em==LIST); 
 return    left->next;
}

void * wrap_c_cons(void * _left)
{ 
 Type *left=_left;
 return  c_cons   (  c_car  (left ) , c_cdr (left) );
}

void *  int_type(int  i);
int c_eq(void  *_left,void  *_right)
{
 Type*left=_left;
 Type  *right=_right;

 if(c_atom (left )&&c_atom (right) )
 {
  if   (left->u_data.i_data==right->u_data.i_data)
   return  1;
  return  0;
 }
 else
  return 0;
}
void *c_cadr(void  *_left);
void * wrap_c_eq(void * _left)
{ 
 Type *left=_left;

 Type  *type_data;
 type_data= new_object() ;
 type_data->em=INT;
 type_data->u_data.i_data=
  c_eq   (  c_car  (left ) , c_cadr (left) );
 return  type_data;
}
void * wrap_c_atom(void * _left)
{ 
 Type *left=_left;

 Type  *type_data;
 type_data=  new_object()  ;
 type_data->em=INT;
 type_data->u_data.i_data=
  c_atom   ( left );
 return  type_data;
}
void * wrap_c_list(void * _left)
{
 return  _left;
}

int  c_not (int  i)
{
 if(i==1)
  return 0;
 else return 1;
}
int  c_atom(void  *_left)
{
 Type  *left=_left;
 if(left->em==LIST)
  return  0;
 return   1;
}

void * c_appdix (void * _left,void *  _right)
{
 Type * left=_left;
 Type * right=_right;

 

 if( left->em==EMPTY)
  return  c_cons (right ,empty_type() );
 else
  return c_cons  (  c_car ( left) ,
  c_appdix ( c_cdr (left ) ,right ) );

}
void * c_list (void *left , ...)
{
 Type * ele_left;
 Type *  ele_right;
 va_list ap;
 ele_left=left;
 ele_left=c_cons (  ele_left , empty_type()) ;
 va_start(ap, left);

 while (1)
 {
  ele_right=va_arg(ap, void *); 
  if(ele_right)
   ele_left=c_appdix (  ele_left,ele_right );
  else
  {   
   break;
  }

 }
 va_end(ap);
 return  ele_left;
}

//some  aux  function
void  *c_caar(void  *_left)
{
 return c_car(c_car(_left));
}
void  * c_cddr(void  *_left)
{
 return  c_cdr(c_cdr(_left));
}
void  *c_caddr(void  *_left)
{
 return c_car( c_cddr(_left) );
}

void  *c_cdar(void  *_left)
{
 return c_cdr(c_car(_left));
}
void *c_cadr(void  *_left)
{
 return c_car(c_cdr(_left));
}

void  *c_cadar(void  *_left)
{
 return  c_car(c_cdr(c_car(_left)));
}
void *c_cadadr(void  *_left)
{
 return  c_car(c_cdr(c_car(c_cdr(_left))));
}
void *  int_type(int  i)
{
 Type  *result=  new_object()  ;
 result->em=INT;
 result->u_data.i_data=i;
 return  result;
}
void  *  set_type(Enum type)
{
 Type  *result= new_object()   ;
 result->em=type;
 return  result;
}
void * left_print(void *  _left)
{
 Type  *left=_left;
 Type  *temp;
 if(!left)
 {
  return empty_type();
 }
 if (  left->em==EMPTY)
 {
  return empty_type();
 } 
 else if(left->em==INT&&left->u_data.i_data==999999)
  printf("%s ","nil");
 else if(left->em==INT)
  printf("%d ",left->u_data.i_data);
 else if(left->em==VAR)
  printf("%s  ",left->u_data.s_data);
 else if(left->em==FUN)
  printf("%s   ",left->u_data.s_data);
 else if(left->em==QUOTE)
  printf("%s  ","quote");
 else if(left->em==DEFUN)
  printf("%s   ","defun");
 else if(left->em==FUNCALL)
  printf("%s   ","funcall");
 else if(left->em==DEFMACRO)
  printf("%s   ","defmacro");
 else if(left->em==SETQ)
  printf("%s  ","setq");
 else if(left->em==SETF)
  printf("%s  ","setf");
 else if(left->em==IF)
  printf("%s  ","if");
 else if (left->em==LIST)
 {

  printf("  (  ");
  for (  temp=left;  temp->em!=EMPTY ;temp= c_cdr (temp) )
  {
   left_print (   c_car (temp) );
  }
  printf(" ) ");
 }
 return  left;
}
void * right_print(void *  _left)
{
 Type  *left=_left;
 if (  left->em==EMPTY)
 {
  return empty_type();
 } 
 else if(left->em==INT&&left->u_data.i_data==999999)
  printf("%s ","nil");
 else if(left->em==INT)
  printf("%d ",left->u_data.i_data);
 else if(left->em==VAR)
  printf("%s  ",left->u_data.s_data);
 else if(left->em==FUN)
  printf("%s   ",left->u_data.s_data);
 else if(left->em==QUOTE)
  printf("%s  ","quote");
 else if(left->em==DEFUN)
  printf("%s   ","defun");
 else if(left->em==DEFMACRO)
  printf("%s   ","defmacro");
 else if(left->em==FUNCALL)
  printf("%s   ","funcall");
 else if(left->em==SETQ)
  printf("%s  ","setq");
 else if(left->em==SETF)
  printf("%s  ","setf");
 else if(left->em==IF)
  printf("%s  ","if");
 else if (left->em==LIST)
 { 
  right_print( c_cdr (left)  );
  right_print( c_car (left)  );
 }
 return  left;
}
void * wrap_print(void *  _left)
{
 printf ("  /n  ");
 return left_print(_left);
}

void * original_big(void * _left)
{
 int  result;
 Type  *left=c_car (_left ) ,*right=c_cadr (_left) ;
 result=(( Type *)left)->u_data.i_data-(( Type *)right)->u_data.i_data;
 return result>=0?int_type(1):int_type(-1);
}
void * original_add1(void * _left)
{
 Type  *left=_left;
 Type  *result= new_object()  ;
 result->em=INT;
 result->u_data.i_data=(( Type *)left)->u_data.i_data+1;
 return  result;
}
void * original_add(void * _left)
{
 Type *temp;
 Type  *left=_left;
 Type  *result=  new_object()   ;
 result->em=INT;
 result->u_data.i_data=0;
 for(temp=left;temp->em!=EMPTY;temp=c_cdr (temp) )
  result->u_data.i_data+=(( Type *)c_car(temp))->u_data.i_data;
 return  result;
}
void * original_minus(void * _left)
{
 Type *temp;
 Type  *left=_left;
 Type  *result=  new_object()   ;
 result->em=INT;
 result->u_data.i_data=(( Type *)c_car(left))->u_data.i_data;
 for(temp=c_cdr (left );temp->em!=EMPTY;temp=c_cdr (temp) )
  result->u_data.i_data-=(( Type *)c_car(temp))->u_data.i_data;
 return  result;
}
void * original_minus1(void * _left)
{
 Type  *left=_left;
 Type  *result=  new_object()   ;
 result->em=INT;
 result->u_data.i_data=(( Type *)left)->u_data.i_data-1;
 return  result;
}

typedef  struct Fun_info
{
 char  name[20];
 funp  address;
}Fun_info;
typedef  struct Type_info
{
 char  name[20];
 Enum  type;
}Type_info;

void  *c_defun (void *name,void *arg,void *expr)
{
 env_defun  *defunvar=(env_defun*)malloc  (sizeof  (env_defun) );
 defunvar->name=name;
 defunvar->arg=arg;
 defunvar->expr=expr;
 global_defun=c_cons ( c_cons ( defunvar ,empty_type() ),global_defun);
 return  name;
}
void c_lambda_put (void *name,void *_env)
{
 global_lambda=c_cons ( c_list ( name ,_env ,0 ),global_lambda); 
}
void* c_lambda_get (void *_name)
{
 Type  *left ,*right, *temp ,*name  ;
 temp=global_lambda;
 name=_name;
 while( temp->em!=EMPTY)
 {
  left=c_car ( temp);
  right=c_car (left );
  if ( !strcmp ( name->u_data.s_data  , right ->u_data.s_data ) )
  {
   return  c_cadr (left);
  }

  temp=c_cdr  (temp);
 }
 return  NULL;

}
int c_atom (void *);
void * orignal_add1(void * _left);

Fun_info orignal_fun[]={{"print",wrap_print},
{"1+",original_add1},{"1-",original_minus1},{"+",original_add},{">",original_big},
{"-",original_minus},{"cons",wrap_c_cons},
{"car",c_car},{"cdr",c_cdr},{"cadr",c_cadr},{"caddr",c_caddr},{"atom",wrap_c_atom},
{"list",wrap_c_list},{"eq",wrap_c_eq},{"",0}};

Type_info orignal_type[]={{"constream",CONSTREAM},{"para",PARA},
{"tail",TAIL},{"symbol",SYMBOL},{"defun",DEFUN},{"defmacro",DEFMACRO},{"end",END},
{"if",IF},{"progn",PROGN},{"setf",SETF},{"get",GET},{"pop",POP},{"gettop",GETTOP},{"nothing",NOTHING},
{"setq",SETQ},{"cond",COND},{"ptr",PTR},{"push",PUSH},{"funcall",FUNCALL},{"setret",SETRET},{"popret",POPRET},
{"lambda",LAMBDA},{"callcc",CALLCC},{"",0}};

void  *  fun_type(char *name)
{
 int  sign;
 Type  *result= new_object()   ;
 result->em=FUN;
 sign=0;

 while(1)
 {
  if(!strcmp("",orignal_fun[sign].name))
  {
   break;
  }
  else if(!strcmp(name,orignal_fun[sign].name))
  {
   result->f_data=orignal_fun[sign].address;
   break;
  }        
  else
   sign++;
 }
 strcpy(result->u_data.s_data,name);
 return  result;
}
//similar  to  the  macro  dispatch
void *  eval(void  * _left,void ** _env) ;
void * eval_cond (void  *_left,void **_env)
{
 Type *left=_left;
 if (  left->em==EMPTY)
  return empty_type();
 if(   c_atom (  c_caar (left) ))
 {
  if(c_not( c_eq (  c_caar (left) ,int_type(0) ) ))
   return  eval  ( c_cadar (left ),_env ) ;  
  return  eval_cond ( c_cdr (left) ,_env);
 }
 else
 {
  if(c_not( c_eq ( eval ( c_caar (left) ,_env) ,int_type( 0) ) ))
   return  eval  ( c_cadar (left ) ,_env) ;
  return  eval_cond ( c_cdr (left) ,_env);
 }
}
void*  left_print  (void  *);
void * eval_progn (void  *_left,void **_env)
{
 Type  *left=_left;
 if (  (( Type *)c_cadr (left))->em==EMPTY)
  return  eval  ( c_car  (left ),_env ) ;
 else
 {
  eval  (c_car  (left) ,_env) ;
  return eval_progn  (c_cdr (left ),_env );
 }
}

void *  c_bindvar_help(void *name,void *value);
void  c_set_global_var_value (void *name,void  *value  ,void ** _env )
{
 Type  *result=  new_object()   ;
 Type *var=c_cadr(*_env); 
 result=c_cons (c_cons ( c_cons (  c_bindvar_help(name,value) ,empty_type() ),empty_type() ),var);
 *_env= c_cons  (   c_car  (*_env ) ,  c_cons  (   result  ,  empty_type() ) ) ; 
}
void  eval_setq (void  *_left,void **_env)
{
 Type  *left=_left;
 if  ( ((  Type *)c_cadr ( c_cdr (left )))->em==EMPTY)
 {
  c_set_global_var_value (  c_car  (left ), eval ( c_cadr (left ),_env )  , _env );
 }
 else
 {
  c_set_global_var_value (  c_car  (left ),eval ( c_cadr (left ),_env )  ,  _env );
  eval_setq  (  c_cddr (left),_env );
 }
}
void * eval_setf (void  *_left,void  **_env)
{
 /*
 Type  *left=_left;
 if  ( ((  Type *)c_cadr ( c_cdr (left )))->em==EMPTY)
 {
 return c_bindvar_ex (  c_car  (left ),eval ( c_cadr (left ) ,_env) );
 }
 c_bindvar_ex (  c_car  (left ),eval ( c_cadr (left ) ,_env) );
 return eval_setf  (  c_cddr (left) ,_env);
 */
 return  NULL;
}

void  *var_type (char * name)
{
 Type  *result=  new_object()   ;
 result->em=VAR;
 strcpy(result->u_data.s_data,name);
 return  result;
}

void *  c_bindvar_help(void *name,void *value)
{ 
 return   c_cons ( c_copy_type2 (name)  ,c_cons (value ,empty_type ()  )   ); 
}

void * c_bindvar (void *_left,void *_right)
{
 Type  *left=_left,*right=_right;
 if(left->em==EMPTY)
 {
  return  empty_type();
 }
 else
 {
  return c_cons ( c_bindvar_help ( c_car (left),c_car (right) ) ,
   c_bindvar  ( c_cdr (left),c_cdr (right)  )
   );
 }
}

 

void  *c_find_defun_arg(void *name)
{
 Type  *_env=global_defun;
 env_defun  *label;
 while(_env)
 {
  label=c_car ( c_car (_env) );
  if(!strcmp(label->name->u_data.s_data,
   ((  Type *)name)->u_data.s_data))
  {
   return label->arg;
  }
  _env=c_cdr (_env) ;
 }
 return  NULL;
}
void  *c_find_defun_expr(void *name)
{

 Type  *_env=global_defun;

 env_defun  *label;
 while(_env)
 {
  label=c_car ( c_car(_env) );
  if(!strcmp(label->name->u_data.s_data,
   ((  Type *)name)->u_data.s_data))
  {
   return label->expr;
  }
  _env=c_cdr (_env);
 }
 return  NULL;

}
void  *c_find_defmacro_arg(void *name)
{
 Type  *_env=global_defmacro;
 env_defun  *label;
 while(_env)
 {
  label=c_car ( c_car (_env) );
  if(!strcmp(label->name->u_data.s_data,
   ((  Type *)name)->u_data.s_data))
  {
   return label->arg;
  }
  _env=c_cdr (_env);
 }
 return  NULL;

}
void  *c_find_defmacro_expr(void *name)
{
 Type * _env=global_defmacro;

 env_defmacro  *label;
 while(_env)
 {
  label=c_car ( c_car (_env) ) ;
  if(!strcmp(label->name->u_data.s_data,
   ((  Type *)name)->u_data.s_data))
  {
   return label->expr;
  }
  _env=c_cdr  (_env) ;
 }
 return  NULL;
}

void  *c_defmacro (void *name,void *arg,void *expr)
{ 
 env_defmacro  *defunvar=(env_defmacro*)malloc  (sizeof  (env_defmacro) );
 defunvar->name=name;
 defunvar->arg=arg;
 defunvar->expr=expr;
 global_defmacro=c_cons (c_cons ( defunvar ,empty_type() ) ,global_defmacro );
 return  NULL;

}

void *  wrap_eval(void  *_left,void **_env);
void *  eval_simple(void  *_left,void **_env)
{
 Type *left=_left;

 if (  left->em==EMPTY)
  return empty_type();
 else if  (  c_atom (left) )
  return  left;
 else if  ( ( (  Type *)  c_car (left ) )->em==EVAL)
  return c_cons  (  eval ( c_cadr (left ),_env ) , eval_simple ( c_cddr (left ) ,_env) );
 else
  return c_cons  ( eval_simple(  c_car (left ) ,_env), eval_simple ( c_cdr (left ) ,_env) );

}
void  *c_find_var_value_help (void  *_left,void *_lst)
{
 Type *left=_left,*lst=_lst;
 Type  * t; 
 if(lst->em==EMPTY)
  return  NULL;
 t=c_car (lst) ;
 if(!strcmp(left->u_data.s_data, ( (Type *)c_car (t))->u_data.s_data))
 {
  return     c_cadr (t ) ;
 }
 else
 {
  return  c_find_var_value_help (left, c_cdr  (lst)  );
 }

}

 

void  *c_find_var_value2 (void *_left,void  *env)
{
 Type  *left=_left,*result ,*m_env,*_env; 
 Type *__env=env;
 while(__env->em!=EMPTY)
 {
  _env=c_car (__env);
  while (_env->em!=EMPTY)
  {
   m_env=c_car (_env) ;
   while(m_env->em!=EMPTY)
   {
    if(result=c_find_var_value_help (left,  c_car ( c_car (m_env) )   )  )
    { 

     return  result;
    }
    m_env=c_cdr (m_env) ;
   }
   _env=c_cdr (_env);
  }
  __env=c_cdr (__env);
 }
 return  NULL;
}

void  *c_find_var_value (void *_left,void  *env)
{
 Type  *left=_left,*result ,*m_env; 
 Type *_env=env;
 while (_env->em!=EMPTY)
 {
  m_env=c_car (_env) ;
  while(m_env->em!=EMPTY)
  {
   if(result=c_find_var_value_help (left,  c_car ( c_car (m_env) )   )  )
    return  result;
   m_env=c_cdr (m_env) ;
  }
  _env=c_cdr (_env);
 } 
 return  NULL;
}

void  *sub_expr (void *_left,void *_env)
{
 Type *left=_left,*temp;
 if(left->em==EMPTY)
  return  empty_type();
 if(   ((Type*)c_car (_left))->em==VAR)
 {
  temp=c_find_var_value( c_car(left ) ,_env);
  if(!temp)
  {   
   return c_cons (c_car (_left ) , sub_expr (c_cdr (_left) ,  _env )  );    
  }
  else
  {
   return c_cons ( temp  , sub_expr (c_cdr (_left) ,  _env )  );   
  }  

 }
 else if(   ((Type*)c_car (_left))->em==LIST)
 {
  return c_cons ( sub_expr (c_car (_left) ,  _env )
   , sub_expr (c_cdr (_left) ,  _env )  );
 }
 else
 {
  return c_cons (c_car (_left ) , sub_expr (c_cdr (_left) ,  _env )  );
 }
}
int  compare (void  *_left ,void  *_right)
{
 Type  *left=_left,*right=_right,*temp=NULL;
 if(right->em==EMPTY )
 {
  return  0;
 }
 else
 {
  temp=c_car (right);
  if(  !strcmp (left->u_data.s_data,temp->u_data.s_data) )
  {
   return  1;
  }
  else
  {
   return compare (left,c_cdr  (right) );
  }

 }
}
void  *contain_expr (void *_left,void *_execption,void *_env)
{
 Type *left=_left,*temp,*execption=_execption;
 if(left->em==EMPTY)
  return  empty_type();
 else if(left->em==VAR)
 {
  temp=left ;
  /*
  if(  compare  (temp ,execption ) )
  {
  temp=temp;
  }
  else
  {
  temp->m_env=_env; 
  }
  */
  temp->m_env= c_cons ( _env  , temp->m_env );
  return  temp;
 }
 else if(   ((Type*)c_car (_left))->em==VAR)
 {
  temp= c_car(left ) ;
  /*
  if(  compare  (temp ,execption ) )
  {
  temp=temp;
  }
  else
  {
  temp->m_env=_env; 
  }
  */
  temp->m_env= c_cons ( _env  , temp->m_env );
  return c_cons ( temp  , contain_expr (c_cdr (_left) ,execption,  _env )  );
 }
 else if(   ((Type*)c_car (_left))->em==LIST)
 {
  return c_cons ( contain_expr (c_car (_left) , execption, _env )
   , contain_expr (c_cdr (_left) , execption, _env )  );
 }
 else
 {
  return c_cons (c_car (_left ) , contain_expr (c_cdr (_left) ,execption,  _env )  );
 }
}
void * random_name ()
{
 int i=0;
 char  name[9]="/0";

 for(i=0;i<8;i++)
 {
  name[i]=rand()%26+'a';
 }
 return  var_type(name);

}

Type * out=NULL;
jmp_buf global ;
wrap_longjmp (void  *_temp,void *_result)
{
 jmp_buf  *temp_buf;
 Type * temp=_temp;
 global_jmpbuf= c_cdr(global_jmpbuf );
 temp_buf=c_car (temp );
 out= _result;
 longjmp ( global ,out);
}
void * wrap_setjmp (void  *left,void  **_env)
{
 int  retn;
 jmp_buf  *temp_buf=(jmp_buf*)malloc  (sizeof (jmp_buf) );

 if(setjmp(global))
 {
  return  out;
 }
 else
 {
  ((Type*) temp_buf)->em=JMPBUF;
  global_jmpbuf=c_cons ( temp_buf,global_jmpbuf);
  return wrap_eval ( c_cons (
   eval ( c_cadr (left)  ,_env) , c_cons (global_jmpbuf,empty_type() )
   )
   ,_env ) ;
 }
}
void  *add_quote (void  *_left)
{
 Type  *left=_left;
 if(left->em==EMPTY)
 {
  return  empty_type();
 }
 else
 {
  return c_cons (   c_list (  set_type(QUOTE), c_car (left) ,0) ,
   add_quote ( c_cdr (left) )
   );
 }
}

void *  eval_para(void  *_left,void **_env);
void *  eval(void  *_left,void **_env)
{

 Type  *temp,*right;
 Type  *left=_left;
 Type  *head=NULL;
 if(left->em==EMPTY)
  return  empty_type();
 else if(left->em==VAR )
 {
  if(temp=c_find_var_value(left ,*_env) )
  {
   return  temp;
  } 
  else
  {
   return  left;
  }
 }
 else if (left->em==INT)
  return  left;
 assert(left->em==LIST);
 head=c_car (left );
 switch(head->em)
 {
 case  EMPTY:
  return  empty_type();
 case  JMPBUF:
  return  left;
 case   SYMBOL:
  return eval ( eval(c_cadr (left ),_env) ,_env);
  break;
 case  CALLCC: 
  return wrap_setjmp(left,_env);
  break;
 case  FUNCALL:
  left_print (left);
  temp= eval(c_cadr (left ),_env);
  if(temp->em==LIST)
  {
   wrap_longjmp(temp,c_caddr (left ));  
  }
  else
  { 
   (right=c_lambda_get (temp))?right:*_env  ;
   //  left= eval ( c_caddr (left) ,_env );    //calc  first  unless  the  _env changed , a  little  trick  here using  the  quote
   /*
   if((( Type *) c_cadr(c_cddr ( left)))->em ==EMPTY )
   {
   left= eval ( c_caddr (left) ,_env );
   return wrap_eval ( c_list ( temp,c_list ( set_type(QUOTE),left ,0) ,0 )  ,
   &right );
   }
   else
   {
   left= eval_para ( c_cddr (left) ,_env );
   left_print  (add_quote ( left) );
   return wrap_eval ( c_cons ( temp,add_quote ( left) )  ,
   &right );
   }
   */
   left= eval_para ( c_cddr (left) ,_env );
   left_print  (add_quote ( left) );
   return wrap_eval ( c_cons ( temp,add_quote ( left) )  ,
    &right );

  }
  break;
 case  LAMBDA:
  temp= c_defun ( random_name( ) ,c_cadr (left ),
   c_caddr (left ) );
  c_lambda_put(temp,*_env);
  return  temp;
  /*
  return  c_defun ( random_name( ) ,c_cadr (left ),
  contain_expr ( c_caddr (left ),c_cadr (left ),*_env ) );
  */
  break;
 case  TAIL:
  if ( ((Type*) c_cadr (left ))->em==LIST) 
  {
   return  eval  ( c_cdr (  c_cadr  (left) ),_env );
  }
  else
  {
   return  eval  ( c_cdr ( eval ( c_cadr  (left)  ,_env)  ),_env );
  }
  break;
 case  CONSTREAM:
  return c_cons ( eval  (  c_cadr (left ) ,_env) , sub_expr ( c_caddr (left )  ,*_env  )  );
  break;
 case  SETQ:
  eval_setq ( c_cdr (left),_env ) ;
  break;
 case  SETF:
  return eval_setf ( c_cdr (left),_env ) ;
  break;
 case IF:
  if (c_eq ( eval (   c_cadr ( left ) ,_env ) ,  int_type(1) ) )
   return  eval ( c_caddr ( left) ,_env)  ;
  else
   return eval  (c_cadr (c_cddr ( left ) ),_env);
  break;
 case PROGN:
  return eval_progn ( c_cdr  (left),_env);
  break;
 case QUOTE2:
  return   eval_simple ( c_cadr (left),_env ) ;
  break;

 case  INT:
  if((( Type *) c_caddr ( left))->em ==EMPTY )
   return c_cons (head, c_cons (eval  (  c_cadr (left) ,_env),empty_type())   );
  return   c_cons (head, eval (c_cdr (left),_env ) );
  break;
 case  COND:
  return eval_cond ( c_cdr  (left) ,_env); 
  break;
 case  FUN:
  if((( Type *) c_caddr ( left))->em ==EMPTY )
   return   head->f_data( eval  (  c_cadr (left),_env )   );
  return head->f_data( eval  (  c_cdr (left) ,_env)   );
  break;
 case DEFUN:
  return  c_defun (c_cadr (left ), c_caddr (left ),c_cadr (c_cddr (left ) ));
  break;
 case VAR:
  if(temp=c_find_var_value ( head, *_env) )
  {
   if((( Type *) c_caddr ( left))->em ==EMPTY )
    return c_cons (temp, c_cons (eval  (  c_cadr (left),_env ),empty_type())   );
   return c_cons( temp ,eval ( c_cdr (left),_env ));
  } 
  else
   return wrap_eval (left,_env);
  break;
 case  DEFMACRO:
  return c_defmacro (c_cadr (left ), c_caddr (left ),c_cadr (c_cddr (left ) ) );
  break;
 case  QUOTE:  
  return  c_cadr (left);   
  break;
 case  LIST:
  return  eval (head ,_env );
  break;
 }
 return  NULL;

}
/*
case  LIST:
if((( Type *) c_caddr ( left))->em ==EMPTY )
return c_cons (eval  ( c_car  (left ),_env ),
c_cons (eval  (  c_cadr (left) ,_env),empty_type())   );
return   c_cons (eval  ( c_car  (left ) ,_env), eval (c_cdr (left),_env ) );
break; 
*/

void ** c_bindvars(void *_left,void * _right,void **_env)
{
 Type *left=_left;
 Type *right=_right;
 Type *m_env=c_car ( *_env );
 if(left->em!=EMPTY)
 {
  m_env=c_cons (c_cons ( c_bindvar( left , right ) ,empty_type() )  , m_env );
  *_env =c_cons ( m_env , c_cdr (*_env ) );
  return  _env;
 }
 else
 {
  return  _env;
 }
}
void  c_unbindvars(void **_env)
{
 Type *result= c_car (*_env ) ;
 result=c_cdr (result );
 *_env=c_cons (result ,  c_cdr (*_env ) );
}
typedef  struct  wrap_struct
{
 void  *_left;
 void  **_env;
}wrap_struct;
void  eval_special (void  *_struct)
{
 Type *result=NULL;
 wrap_struct  *w=_struct;
 result=eval  (w->_left,w->_env);
 printf("/n/n");
 left_print(result);
}

void *  eval_para(void  *_left,void **_env)
{
 Type *left=_left;
 if (left->em==EMPTY)
  return  empty_type();
 else
  return c_cons (  eval (c_car (left) ,_env) ,
  eval_para ( c_cdr (left) ,_env )
  );
}
void *  wrap_eval(void  *_left,void **_env)
{
 Type *tempname;
 Type *tempvalue;
 Type *result=NULL;
 Type  *left=_left; 
 Type  *head=NULL;

 int  count=0;
 unsigned pid;
 wrap_struct  w,ww;
 Type  *e,*ee;

 

 if(left->em==VAR )
  return   c_find_var_value(left,*_env)  ;
 else if (left->em==INT)
  return  left ;
 assert(left->em==LIST);
 head=c_car (left );
 if((tempname=c_find_defmacro_arg(head)))
 { 
  tempvalue=c_cdr (left );
  result= eval ( eval  (  c_find_defmacro_expr(head)  ,_env) ,
   c_bindvars( tempname, tempvalue,_env )) ;
  c_unbindvars( _env );
 }   
 else if((tempname=c_find_defun_arg(head)))
 {

  tempvalue=eval_para( c_cdr (left ),_env ); 
  result=  eval  ( c_find_defun_expr(head),
   c_bindvars( tempname, tempvalue,_env )
   )  ;
  c_unbindvars( _env );
 }   
 else
 {
  if( head->em==PARA)
  {
   e=new_object() ;
   e=*_env;
   w._left=c_cadr(left);
   w._env=&e;
   _beginthreadex(NULL,0,
    (unsigned (__stdcall *) (void *))eval_special,(void *)&w ,0,&pid);
   ee=new_object() ;
   ee=*_env;
   ww._left=c_caddr(left);
   ww._env=&ee;  
   _beginthreadex(NULL,0,
    (unsigned (__stdcall *) (void *))eval_special,(void *)&ww ,0,&pid);
   while(count>=0)
   {
    count++;   
   }
  }
  else
  {
   result=  eval  (  left ,_env)  ;     
  }
 }

 return  result;
}
static enum tokens token; /* current input symbol */
static int number;  /* if NUMBER: numerical value */
static char  name[20];
static  char alpha_ex[]="abcdefghijklmnopqrstuvwxyz_!";
int isalpha_ex(char *test)
{
 int  i=0;
 for(i=0;alpha_ex[i]!='/0';i++)
  if(alpha_ex[i]==test)
   return  1;
 return  0;

}
static enum tokens scan (const char * buf)
/* return token = next input symbol */
{
 static const char * bp;   
 int sign=0;
 memset(name,0,sizeof(name));

 if (buf)
  bp = buf;   /* new input line */

 

 while (isspace(* bp & 0xff))
  ++ bp;
 if (isdigit(* bp & 0xff) || * bp == '.')
 {
  errno = 0;
  token = NUMBER, number = strtod(bp, (char **) & bp);

 }
 else if (isalpha_ex(* bp & 0xff) || * bp == '.')
 {
  errno = 0;
  token = NAME;
  while(isalpha_ex(* bp & 0xff))
   name[sign++]=*bp++;
 }
 else
  token = * bp ? * bp ++ : 0;
 return token;
}
funp select_fun (void *_name)
{
 int sign=0;
 while(1)
 {
  if(!strcmp("",orignal_fun[sign].name))
  {
   return  NULL;
  }
  else if(!strcmp(name,orignal_fun[sign].name))
  {
   return orignal_fun[sign].address;  
   break;
  }        
  else
   sign++;
 } 
}
char * select_fun2 (funp address)
{
 int sign=0;
 while(1)
 {
  if(!orignal_fun[sign].address)
  {
   return  NULL;
  }
  else if(address==orignal_fun[sign].address)
  {
   return orignal_fun[sign].name;  
   break;
  }        
  else
   sign++;
 } 
}
Enum select_type (void *_name)
{
 char  *name=_name;
 int sign=0;
 while(1)
 {
  if(!strcmp("",orignal_type[sign].name))
  {
   return (Enum) NULL;
  }
  else if(!strcmp(name,orignal_type[sign].name))
  {
   return orignal_type[sign].type; 
   break;
  }        
  else
   sign++;
 } 
}
char * select_type2 (Enum  type)
{

 int sign=0;
 while(1)
 {
  if(!orignal_type[sign].type)
  {
   return  NULL;
  }
  else if(type==orignal_type[sign].type)
  {
   return orignal_type[sign].name; 
   break;
  }        
  else
   sign++;
 } 
}
static void * factor (void)
{
 Type  *result; 
 Type * ele_left;
 Type *  ele_right;
 funp  pfun;
 Enum  type;
 scan(0);
 switch (token)
 {
 case  NAME:
  if ( pfun=select_fun (name) )
  {
   result=  new_object ();
   result->em=FUN;
   result->f_data=pfun;
   strcpy(result->u_data.s_data,name);
   return  result;
  }
  else if (type=select_type (name) )
  {
   return  set_type (type );
  }
  else if(!strcmp("nil",name))
  {
   return  empty2_type();
  }
  else
  {
   return var_type (name); 
  }
 case NUMBER:
  return int_type (number);
  break;
 case '(':
  ele_left=factor();
  if(!ele_left)
  {
   return  c_cons (empty_type(),empty_type());
  }
  ele_left=c_cons (  ele_left , empty_type()) ; 

  while (1)
  {
   ele_right=factor(); 
   if(ele_right)
   {
    ele_left=c_appdix (  ele_left,ele_right );
   }
   else
   {   
    break;
   }

  }
  return  ele_left;
  break;
 case ')':
  return NULL;
  break;
 case '+':
  return fun_type("+");
  break;
 case '>':
  return fun_type(">");
  break;
 case '-':
  return fun_type("-");
  break;
 case  '/'':
  return  c_list ( set_type(QUOTE),factor(),0 );
 case  '/`':
  return  c_list ( set_type(QUOTE2),factor(),0 );
 case  '/,':
  return   set_type(EVAL);

 }
 return NULL;
}
static jmp_buf onError;
int main (void)
{
 int  i,sign;
 Type * ele_left;
 Type *  ele_right;
 FILE *in;
 volatile int errors = 0;

 char buf [8*BUFSIZ]; 
 Type  *m_env;
 srand (time (NULL) );
 mem_manager=(Type *)malloc  (global_count  *sizeof (Type ) );
 for(i=0;i<global_count;i++)
 {
  mem_manager[i].m_env=empty_type();   //add  by  chenbing  2011.1.13
 }

 m_env=empty_type();
 global_lambda=empty_type();

 /* 
 for(i=0;i<MAX;i++)
 {
 compi[i].address=0;
 }
 */

 if (setjmp(onError))
  ++ errors;

 global_jmpbuf=empty_type();
 sign=0;
 in=fopen("c://test.txt","r");
 while(1)
 {
  buf[sign]=fgetc(in);
  if(feof(in))
   break;
  sign++;
 }

 scan(buf);
 while (token== '(')
 { 

  ele_left=factor();
  ele_left=c_cons (  ele_left , empty_type()) ; 

  while (1)
  {
   ele_right=factor(); 
   if(ele_right)
    ele_left=c_appdix (  ele_left,ele_right );
   else
   {
    left_print(ele_left);
    //   right_print(ele_left);
    left_print  ( wrap_eval ( ele_left,&m_env)  );
    printf("/n/n");
    //   right_eval ( ele_left)  ;
    //   right_print  ( stack_pop() );
    /*
    printf(  "  /n  ");
    temp=right_compile(c_cons( ele_left,empty_type() )  ,-99 )  ;
    if( ((Type *) c_car (ele_left ) )->em!=DEFUN)
    {

    //  right_interpret (temp);
    // serial(temp);
    // right_interpret (  unserial()  );   
    right_install (temp);
    }
    else
    {
    for(i=0;i<unsolve_count;i++)
    {
    for(j=0;j<compi_count;j++)
    {
    if(!CODE[  unsolve[i].address ]&&!strcmp(unsolve[i].name,compi[j].name))
    {
    CODE[  unsolve[i].address ]=compi[j].address;
    }
    }     
    }
    if(!SYS)SYS=temp;

    }
    */
    break;   
   }
  }
  token=scan(0);
 }
 // right_interpret ( );
 return errors > 0;
}

void error (const char * fmt, ...)
{
 va_list ap;

 va_start(ap, fmt);
 vfprintf(stderr, fmt, ap), putc('/n', stderr);
 va_end(ap);
 longjmp(onError, 1);
}