Rococo terminator ( 有过很多考虑,很多取舍,目前维持这种状态)

(mymachine (
(defun  mycons ( x  y)
(lambda (p ) (funcall p  x  y) )
)

(defun  mycar  (n)
(funcall  n   (lambda( x y)  x) )
)

(defun  mycdr  (n)
(funcall  n   (lambda( x y)  y) )
)

(defun  mycadr  (n)
(mycar  (mycdr  n) )
)

(defun printlst (n)
(if  (eq   n  nil)
        nil
      (progn
          (print  (mycar  n) )
          (printlst (mycdr n) )
       )
)
)
 

(defun  emerge  (x  y)
(if (eq  x  nil)
      y
   (if  (eq  y  nil )
         x
      (if  (>  (mycar  x )  (mycar  y) )
             (mycons  (mycar  y)   (emerge  x  (mycdr y) ) )
            (mycons  (mycar  x )  ( emerge  (mycdr x)  y ) )         
      )
   )
)
)

(defun  ptr  ( x  num )
(if  (eq  num  0)
    x
   (ptr  (mycdr  x )   (-  num  1 ) )
)
)

(defun  myget  (x    count )
(if  (eq  count  0)
         nil
     (mycons  (mycar  x)  (myget (mycdr x ) (-  count  1) ) )
)
)

(defun divi  (x  num )
(if  (eq  num  2)
         (if  (>  (mycar  x )  (mycadr  x) )
            (mycons  (mycadr  x ) (mycons (mycar  x) nil) )
            x
          )
   (emerge  (divi  (myget (ptr  x  0 ) (/ num  2) )  (/ num  2) )
              (divi  (myget  (ptr  x  (/  num  2) ) (/ num  2 ) ) (/  num  2) )  )
)
)

(setq  y (mycons 23 (mycons 345 nil) )  )
(printlst (divi  y  2) )
(setq  y (mycons 345 (mycons 23  nil) )  )
(printlst (divi  y  2))

(setq  y (mycons 345  (mycons 23 (mycons 10  (mycons 89 (mycons 34 (mycons 2 (mycons 77

(mycons 864 nil)))))))))
(printlst (divi  y  8) )
(setq  z   (mycons 23 (mycons 34 (mycons 11 (mycons 98 (mycons 456 (mycons 875 (mycons 76

(mycons 21 nil)))))))))
(printlst (divi  z  8) )
))

 
$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$4

#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>
#include  <math.h>

#define  NULLVALUE  999999

/*
#define  MAX  1000
int  vec_global=0;
*/

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

 

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,FORMAL
}forth;

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

typedef  struct WrapType
{
  struct WrapType * mem_next;
 Type  value;
}WrapType;

Type *global_once=NULL;
Type *global_twice=NULL;
Type  *global_null=NULL;
Type *global_lambda=NULL;
Type *global_var=NULL;

//#define  NUM  1000
WrapType   *mem_manager_unused=NULL;

WrapType   *mem_manager_used=NULL;
WrapType   *mem_manager_used_end=NULL;

int  global_count=40000;     //modify  to  handle  macro  massive  character
void *c_car(void *);
void *c_cdr(void *);
int object=0;
 void  count_object()
 {
  printf("%d  ",object);
 }
 void  free_object();
Type*  new_object()
{
 Type *result; 
 if(!mem_manager_unused)
 {
  mem_manager_unused=mem_manager_used;
  mem_manager_used=NULL;  
 }
 result=&(mem_manager_unused->value);
 result->mother=mem_manager_unused; 
 mem_manager_unused=mem_manager_unused->mem_next;
 result->mother->mem_next=NULL;
 
 object++;
// count_object();
 return  result;
}

void free_object()
{
 int count=0;
 WrapType  *left,*right;
 left=mem_manager_used;
 if(!left)
  return ;

 while(left->mem_next)
 {
  
  left=left->mem_next;
 }

 left=mem_manager_used;
 
 while(left->mem_next)
 {
  right=left->mem_next;
  left->mem_next=mem_manager_unused;
  mem_manager_unused=left;
  left=right;
  count++;
 }
 mem_manager_used=NULL;
 printf("%d  ",count);
}

void  init_object()
{
 int  i=0;
 
 mem_manager_unused=(WrapType *)malloc  (global_count  *sizeof (WrapType ) );
 for(i=0;i<global_count-1;i++)
 {
  mem_manager_unused[i].mem_next=&mem_manager_unused[i+1];  
 } 
 mem_manager_unused[global_count-1].mem_next=NULL;
}
void  *  empty2_type(void)
{
 Type  *result= new_object();
 result->em=INT;
 result->u_data.i_data=NULLVALUE;
 return  result;
}
void  *  true_type(void)
{
 Type  *result= new_object();
 result->em=INT;
 result->u_data.i_data=1;
 return  result;
}
void  *  empty_type(void)
{
 Type  *result;
 if(!global_null)
 {
  result= new_object();
  result->em=EMPTY;
  result->u_data.i_data=NULLVALUE;
  global_null=result;
  return  result;
 }
 else
 {
  return global_null;
 }
}

void * c_copy_atom(void *_right)
{
 Type *left;
 Type  *right=_right;
 void *mother;
 if(right->em==EMPTY)
  return right;  
 left= new_object()   ;
 mother=left->mother;
 memcpy(left,right,sizeof( Type) );
 left->mother=mother;
 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;
}

int  c_atom(void *);
void * c_copy_tree(void *_right)
{
 Type  *right=_right;
 if(right->em==EMPTY)
  return right;
 if( c_atom ( c_car (right) ) )
 return  c_cons ( c_copy_atom(c_car (right)), c_copy_tree ( c_cdr (right)) );
 return 
    c_cons ( c_copy_tree(c_car (right)), c_copy_tree ( c_cdr (right)) );
}

void  * wrap_print(void *);
void * c_copy_type(void *_right)
{  
 Type  *right=_right; 
 if(right->em==EMPTY)
  return right;  
 if(right->em==LIST)
  return   c_copy_tree (right) ;
 return  c_copy_atom (right)  ;
}
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 *c_cadr(void  *_left);
void  gc_atom(void  *);
void  gc(void *);
void*  left_print (void  *);
void * wrap_c_cons(void * _left)
{ 
 Type *left=_left;
 Type  *result=  c_cons   (  c_car  (left ) , c_cadr (left) ); 
 gc_atom (   c_cdr(left)  );
 gc_atom (left);
 return  result;
}
void * wrap_c_cdr (void *_left)
{
 Type  *left=c_car (_left )  ;
 Type  *right= c_cdr ( left) ; 
 

 gc( c_car (left) );
 gc_atom(_left);
 return  right;
}
void * wrap_c_cadr (void *_left)
{
 Type  *left=c_car (_left )  ;
 return  c_cadr ( left);
}
void * wrap_c_car (void *_left)
{
 Type  *left=c_car (_left )  ;
 Type  *right=  c_car ( left) ; 
 
 gc( c_cdr (left) );
 gc_atom(_left);
 return  right;
}
void *  int_type(int  i);
int  c_atom (void *);
void  gc(void *);
int c_eq(void  *_left,void  *_right)
{
 Type*left=_left;
 Type  *right=_right;
 int  result;

 if(c_atom (left )&&c_atom (right) )
 { 
  if   (!(left->u_data.i_data-right->u_data.i_data))
   result=  1;
  else
   result= 0;
 }
 else
  result= 0;

 gc(_left);
 gc(_right);
 return  result;
}

void * wrap_c_eq(void * _left)
{ 
 Type *left=_left;
 Type  *right=c_eq   (  c_car  (left ) , c_cadr (left) )?int_type(1.00):int_type(0); 
 gc(left);
 return  right;
}
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(float  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==NULLVALUE)
  printf("%s ","nil");
 else if(left->em==FORMAL)
  printf("formal ");
 else if(left->em==INT)
  printf("%f ",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  * wrap_print (void *_left)
{
 printf("/n");
 return  left_print (_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==NULLVALUE)
  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  gc_frame(void *);
void  gc(void *);
void * wrap_left_print(void *  _left)
{
 Type *result;
 printf ("  /n  ");
 result= left_print( c_car (_left) ) ;   //modify by chebing  2011.3.11

 
 gc_atom(_left);
 return  result;
}

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;
 gc(_left);
 return result>0?int_type(1):int_type(0);
}
void * original_small(void * _left)
{
// int  result;
 float  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_mul(void * _left)
{
 Type *  result=new_object () ;
 Type  *left=c_car (_left ) ,*right=c_cadr (_left) ;
 result->em=INT;
 result->u_data.i_data=(( Type *)left)->u_data.i_data*(( Type *)right)->u_data.i_data;
 return result;
}
void * original_divi(void * _left)
{
 Type *  result=new_object () ;
 Type  *left=c_car (_left ) ,*right=c_cadr (_left) ;
 result->em=INT;
 result->u_data.i_data=(( Type *)left)->u_data.i_data/(( Type *)right)->u_data.i_data;
 return result;
}
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_sin(void * _left)
{
 Type  *left=_left;
 Type  *result= new_object()  ;
 result->em=INT;
 result->u_data.i_data=sin ( (( Type *)c_car(left))->u_data.i_data );
 return  result;
}
void * original_cos(void * _left)
{
 Type  *left=_left;
 Type  *result= new_object()  ;
 result->em=INT;
 result->u_data.i_data=cos ( (( Type *)c_car(left))->u_data.i_data );
 return  result;
}
void * original_mod(void * _left)
{
 int left=(( Type *)c_car(_left))->u_data.i_data;
 int  right=(( Type *)c_cadr(_left))->u_data.i_data;
 Type  *result= new_object()  ;
 result->em=INT;
 result->u_data.i_data=left%right;
 return  result;
}
void * original_abs(void * _left)
{
 Type  *left=_left;
 Type  *result= new_object()  ;
 result->em=INT;
 result->u_data.i_data=fabs ( (( Type *)c_car(left))->u_data.i_data );
 return  result;
}
void  gc(void *  _left);
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;
 gc(_left);
 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;
// left_print(_left);
 gc(_left);
 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 ,void **mem)
{
 *mem=c_cons (  c_list (  name ,arg,expr,0)  ,*mem);
 return  name;
}
void  c_defun_gc (void *_name)
{
 Type *left,*right,*name=_name,*mother,*temp;
 left=global_once;
 while(left && left->em!=EMPTY)
 {
  right=c_caar (left);
  if(!strcmp(((Type*)right)->u_data.s_data,
   ((  Type *)name)->u_data.s_data))
  {
 //    gc_atom (right);   
     gc_frame ( c_car (left ) );
     temp=c_cdr(left);
  
     mother=left->mother;
     gc_atom (left);
     memcpy(left,temp,sizeof (Type))  ;   //modify  by chenbing  2011.4.10
     left->mother=mother;

     return ;
  }
  left=c_cdr (left);
 } 
}

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;

}
void c_lambda_gc (void *_name)
{
 Type *left,*right,*name=_name,*mother,*temp;
 left=global_lambda;
 while(left && left->em!=EMPTY)
 {
  right=c_caar (left);
  if(!strcmp(((Type*)right)->u_data.s_data,
   ((  Type *)name)->u_data.s_data))
  {
     gc_atom (right);
 //    gc_frame ( c_car(c_cadr (left) ) ) ;    //copy  before , so  delete  it now
     gc_frame ( c_car (left ) );

    
     gc ( c_car (left) );
     temp=c_cdr(left);
  
     mother=left->mother;
     gc_atom (left);
     memcpy(left,temp,sizeof (Type))  ;   //modify  by chenbing  2011.4.10
     left->mother=mother;

     return ;
  }
  left=c_cdr (left);
 } 
}
int c_atom (void *);
void * orignal_add1(void * _left);

Fun_info orignal_fun[]={{"print",wrap_left_print},{"abs",original_abs},{"cos",original_cos},{"mod",original_mod},
{"1+",original_add1},{"1-",original_minus1},{"+",original_add},{">",original_big},{"sin",original_sin},
{"-",original_minus},{"cons",wrap_c_cons},{"/",original_divi},{"<",original_small},{"*",original_mul},
{"car",wrap_c_car},{"cdr",wrap_c_cdr},{"cadr",wrap_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},{"push",PUSH},{"funcall",FUNCALL},{"setret",SETRET},{"popret",POPRET},
{"lambda",LAMBDA},{"formal",FORMAL},{"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  )
{
 Type  *result=  new_object()   ;  
 global_var=c_cons ( c_list( c_bindvar_help(name,value) ,0), global_var);   //consist with fun  with multiarg 
 return  name;
}
void * eval_setq (void  *_left,void **_env)
{
 Type  *left=_left;
 if  ( ((  Type *)c_cadr ( c_cdr (left )))->em==EMPTY)
 {
  return c_set_global_var_value (  c_car  (left ), eval ( c_cadr (left ),_env ) );
 }
 else
 {
  c_set_global_var_value (  c_car  (left ),eval ( c_cadr (left ),_env )  );
  return 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_atom( name )  ,c_cons (  value  ,empty_type ()  )   ); 
 
// return   c_cons (name  ,c_cons (value ,empty_type ()  )   ); 
}
void  gc_atom(void *);
void * c_bindvar (void *_left,void *_right)
{
 Type  *left=_left,*right=_right,*result;
 if(left->em==EMPTY)
 {
  return  empty_type();
 }
 else
 {
  result=c_cons ( c_bindvar_help ( c_car (left),c_car (right) ) ,
   c_bindvar  ( c_cdr (left),c_cdr (right)  )
   );  
  return  result;  
 }
}

 

void  *c_find_defun_arg(void *name,void *mem)
{
 Type  *_env=mem;
 Type  *label;
 while(_env)
 {
  label=c_car ( _env );
  if(!strcmp(((Type*)c_car (label))->u_data.s_data,
   ((  Type *)name)->u_data.s_data))
  {   
   return   c_cadr(label);  
  }
  _env=c_cdr (_env) ;
 }
 return  NULL;
}
void  *c_find_defun_expr(void *name,void *mem)
{
 Type  *_env=mem;
 Type  *label;
 while(_env)
 {
  label=c_car ( _env) ;
  if(!strcmp(((Type*)c_car (label))->u_data.s_data,
   ((  Type *)name)->u_data.s_data))
  {   
   return   c_caddr(label)   ;
  }
  _env=c_cdr (_env);
 }
 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 *  eval_simple(void  *_left,void **_env)
{
 Type *left=_left;

 if (  left->em==EMPTY)
  return empty_type();
 else if  (  c_atom (left) )
  return  c_copy_type( 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 *_right)
{
 Type *left=_left,*right=_right;
 Type  * t;  
 if(right->em==EMPTY)
  return  NULL;
 t=c_car (right) ;
 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  (right)  );
 }
}
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,*env=_env,*result=NULL; 
 while(env->em!=EMPTY)
 {  
  if(result=c_find_var_value_help (left,   c_car (env) )     )
   return  result ;    
  env=c_cdr (env) ;
 } 
 env=global_var;
 while(env->em!=EMPTY)
 {    
  if(result=c_find_var_value_help (left,   c_car (env) )     )
   return  result ;    
  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 )  );
 }
}

void * random_name ()
{
 int i=0;
 char  name[8]="/0";

 for(i=0;i<7;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) )
   );
 }
}
typedef  struct  Wrap_struct
{
 void  *_left;
 void  **_env;
 int  * address;
 int  count;
}Wrap_struct;
int  _signal[10]={0};
void  eval_special (void  *_struct)
{
 Type *result=NULL;
 Wrap_struct  *w=_struct;
 w->address[w->count]=1;
 result=eval  (w->_left,w->_env);
 printf("/n/n");
 left_print(result);
 w->address[w->count]=0;
}
void *  eval_para(void  *_left,void **_env);
void hand_thread (void *_left,void **_env,int  _count)
{
 unsigned pid;
 Wrap_struct  ww;
 Type  *ee;
 Type *left=_left;
 if (left->em==EMPTY)
 {
  ;
 }
 else
 {
  ee=new_object() ;
  ee=*_env;
  ww._left=c_car(left);
  ww._env=&ee;  
  ww.count=_count;
  ww.address=_signal;  
  _beginthreadex(NULL,0,
   (unsigned (__stdcall *) (void *))eval_special,(void *)&ww ,0,&pid);
  hand_thread(  c_cdr (left)  ,_env ,_count+1); 
 }
}
void ** c_bindvars(void *_left,void * _right,void **_env);
void  c_unbindvars(void **_env);
void *  eval_para_delay(void  *_left,void **_env);
void  compare(void  *_left,void *_right);
void  count_gc();
void *  eval(void  *_left,void **_env)
{
 Type  *temp,*right,*tempname,*tempvalue,*result;
 Type  *left=_left;
 Type  *head=NULL;
 Type  *_env_temp=NULL;
 int  *label,count=0;
label:
 if(left->em==EMPTY)
  return  empty_type();
 else if (left->em==FORMAL)
  return  left;
 else if(left->em==VAR )
 {  
  if(temp=c_find_var_value(left ,*_env) )
  {  
   if(temp->em==LIST&&!strcmp( ((Type*)c_car(temp))->u_data.s_data,"delay")!=0)
   {
    right=*_env;
        result= eval ( c_cons( set_type(FUNCALL),c_cdr(temp)) ,&right);   //add  by  chenbing  2011.3.11
    compare(right,*_env);
     return result;
   }
   else
   {
    return  c_copy_type( temp );
   }
  } 
  else
  {
   return  left;
  }
 }
 else if (left->em==INT&&left->u_data.i_data==NULLVALUE)
  return  empty_type();
 else if (left->em==INT)
  return  c_copy_atom(left) ;   
 assert(left->em==LIST);
 head=c_car (left );
 switch(head->em)
 {
 case  FORMAL:
  return c_cons(head,  eval_para ( c_cdr (left) ,_env )  );
  break;
 case PARA:
  hand_thread ( c_cdr (left) ,_env ,0 );
  while(count>=0)
  {
   count++;
  }
  while(1)
  {
   label=_signal;
   while((!(*label))&&(label-_signal<10))
   {
    label++;
   }
   if(!(label-_signal-10))
   {
    break;
   }    
  }
  return  empty_type();
  break;
 case  EMPTY:
  return  empty_type();
 case  JMPBUF:
  return  left;
 case   SYMBOL:
  return eval ( eval(c_cadr (left ),_env) ,_env);
  break;
 case  CALLCC: 
    
  break;
 case  FUNCALL:
  /*
  temp= eval(c_cadr (left ),_env);  
  right=c_lambda_get (temp)  ;
  if(!right)
   right=*_env;  
  tempname=c_find_defun_arg(temp,global_once);
 // tempvalue=eval_para_delay( c_cddr (left ),_env );
  tempvalue=eval_para( c_cddr (left ),_env );  
  result=right;                 //handle for goto error  2011.4.10
  left=c_find_defun_expr(temp,global_once);
  _env=c_bindvars( tempname, tempvalue,&result ); 
  goto label;
  */
  temp= eval(c_cadr (left ),_env);  
  right=c_lambda_get (temp) ;
  if(!right)
   right=*_env;   
 // tempvalue=eval_para_delay( c_cddr (left ),_env );
  tempvalue=eval_para( c_cddr (left ),_env );   
 // _env=c_bindvars( tempname, tempvalue,&result ); 
//  return wrap_eval ( c_list (temp ,c_cons ( set_type(QUOTE),tempvalue) ,0) ,&right);   //can't handle two args
  return wrap_eval ( c_cons (temp ,add_quote(tempvalue) ,0) ,&right);   
  break;
 case  LAMBDA:
 // left=c_copy_type(left);
  temp= c_defun ( random_name( ) ,c_cadr (left ),
   c_caddr (left ) ,&global_once);
  right= c_cons ( c_copy_type( c_car (*_env ) ),c_cdr (*_env) );  
  c_lambda_put(temp,right);
  return  c_copy_type( 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:
  return  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(0) ) )
   return eval  (c_cadr (c_cddr ( left ) ),_env);   
  else
   return  eval ( c_caddr ( left) ,_env)  ;
  */

  if (c_eq (   eval (   c_cadr ( left ) ,_env ) ,  int_type(0) ) )    //modify  according to the macro application.
  {
   left=c_cadr (c_cddr ( left ) );
   goto label;   
  }
  else
  {
   left=c_caddr(left);
   goto label;   
  }
  
  break;
 case PROGN:  
  left=c_cdr(left);  
  while((( Type *)c_cadr (left))->em!=EMPTY)
  {
   temp=*_env;
   gc(eval  (c_car  (left) ,&temp) ) ;   
   compare ( temp ,*_env );
   left=c_cdr(left);
  }
  left=c_car(left);  
  goto label;
  
  /*
  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 );
 }
*/
//  return eval_progn ( c_cdr  (left),_env);
  break;
 case QUOTE2:
  return    eval_simple (  c_cadr (left) ,_env ) ;   //add for  Rocaccic application
  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)   );
  */
  return  head->f_data (  eval_para  ( c_cdr (left ) ,_env ) ) ;
  break;
 case DEFUN:  
  left=c_copy_type(left);
  temp=c_defun (c_cadr (left ), c_caddr (left ),c_cadr (c_cddr (left ) ) ,&global_once);
  c_lambda_put(temp,NULL);  
  return  c_copy_atom(temp );
  break;
 case VAR:
  if(temp=c_find_var_value ( head, *_env) )
  {
   if(temp->em==LIST&&!strcmp( ((Type*)c_car(temp))->u_data.s_data,"delay")!=0)
   {
    temp= eval ( c_cons( set_type(FUNCALL),c_cdr(temp)) ,_env);   //add  by  chenbing  2011.3.11
   }
   else
   {
    ;
   }
   if((tempname=c_find_defun_arg(temp,global_once)))
   {  
    return  eval (  c_cons ( set_type(FUNCALL) , left) ,_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
  {
   /*
   temp=c_car(left);
   tempname=c_find_defun_arg(temp,global_once);
//   tempvalue=eval_para_delay( c_cdr (left ),_env );
   tempvalue=eval_para( c_cdr (left ),_env );    
   _env=c_bindvars( tempname, tempvalue,_env );    
   left=c_find_defun_expr(temp,global_once);   
   goto label;
   */
   return wrap_eval (left,_env);
  }   
  break;
 case  DEFMACRO:
  left=c_copy_type(left);
  temp=c_defun (c_cadr (left ), c_caddr (left ),c_cadr (c_cddr (left ) ) ,&global_twice);
  return  c_copy_type(temp);
  break;
 case  QUOTE:  
  return  c_cadr (left);   
  break;
 case  LIST: 
  return temp= eval(c_car (left ),_env);
  temp= eval(c_car (left ),_env);  
  if((tempname=c_find_defun_arg(temp,global_once)))
  {  
   return  eval (  c_cons ( set_type(FUNCALL) , left) ,_env) ;
  }   
  printf("/n/n");  
  return  left;  
  //  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;
 if(left->em!=EMPTY)
 {  
  *_env=c_cons( c_bindvar( left , right ) ,*_env );  
  gc_frame(right);  
  return  _env;
 }
 else
 {
  return  _env;
 }
}
int  gcc=0;
void  count_gc()
 {
  printf("%d  ",gcc);
 }
void gc_atom(void *_left)
{
 Type *left=_left;
 WrapType *gc=NULL;
 int  count=0;

 left=_left;
 gc=left->mother;
 memset(left,0,sizeof (Type) );
 gc->mem_next=NULL;

 if(!mem_manager_used)
 {
  mem_manager_used=gc;
  mem_manager_used_end=mem_manager_used;
 }
 else
 {
  assert(gc);
  mem_manager_used_end->mem_next=gc;
  mem_manager_used_end=gc;
  
 }
 
 /*
 gc=mem_manager_used;
 while(gc->mem_next)
 {
  printf("%x  ",gc);
  count++;
  gc=gc->mem_next;
 }
 printf("%d  ",count);

*/
 gcc++;
// count_gc();
}

void  gc_frame (void  *_left)
{
 Type *left=_left;
 Type *right=c_cdr(left);
 if(left->em==EMPTY)
  return ;
 else
 {
//  left_print(left);
  gc_atom(left);
  gc_frame(right);
 } 
}

void  gc(void *  _left)
{
 Type  *left=_left,*right;
 if(!left)
 {
  return ;
 }
 if (  left->em==EMPTY)
 {
  return ;
 } 
 else if(left->em==INT&&left->u_data.i_data==NULLVALUE)
  gc_atom(left);
 else if(left->em==FORMAL)
  gc_atom(left);
 else if(left->em==INT)
  gc_atom(left);
 else if(left->em==VAR)
 {
  
  right=c_lambda_get (left) ;
  if(right&&right->em!=EMPTY)
  {
 //  c_defun_gc(left);
 //  c_lambda_gc(left);   
  }  
  gc_atom(left);
 }
 else if(left->em==FUN)
  gc_atom(left);
 else if(left->em==QUOTE)
  gc_atom(left);
 else if(left->em==DEFUN)
  gc_atom(left);
 else if(left->em==FUNCALL)
  gc_atom(left);
 else if(left->em==DEFMACRO)
  gc_atom(left);
 else if(left->em==SETQ)
  gc_atom(left);
 else if(left->em==SETF)
  gc_atom(left);
 else if(left->em==IF)
  gc_atom(left);
 else if (left->em==LIST)
 { 
  gc(c_car(left));
  gc(c_cdr(left));
  gc_atom(left);
 } 
}

void  c_unbindvar_help(void *_left)
{
 Type  *left=_left,*result;  
 result=c_cadr (left); 

 if(result->em==LIST)
  gc_frame (result);
 else
  gc_atom(result);
}
void  c_unbindvar(void *_left)
{
 Type  *left=_left,*temp; 
 if (left->em==EMPTY)
  return ;
 else
 {  
  c_unbindvar_help(c_car (left) );  //consist with the inital decision

  temp=c_cdr(left);
  gc_frame (c_car (left) ); 
//  gc_atom (left);

  c_unbindvar( temp);  //reason as  above
 }
}
void  c_unbindvars(void **_env)
{
 Type *right=c_cdr(*_env);
 gc(c_car(*_env));

 

 gc_atom(*_env);
 *_env=right;
}
void *  eval_para_delay(void  *_left,void **_env)
{ 
 Type *left=_left;
 if (left->em==EMPTY)
  return  empty_type();
 else
  return c_cons (
  c_list ( var_type("delay"), eval (c_list (set_type(LAMBDA), empty_type(),c_car (left) ,0) ,_env) ,0),
  eval_para_delay ( c_cdr (left) ,_env )
  );
}
void *  eval_para_delay_delay(void  *_left,void **_env)
{ 
 Type *left=_left;
 if (left->em==EMPTY)
  return  empty_type();
 else
  return c_cons (
  c_list ( var_type("delay"), eval (c_list (set_type(LAMBDA), empty_type(),
  c_list ( var_type("delay"), eval (c_list (set_type(LAMBDA), empty_type(),c_car (left) ,0) ,_env) ,0)
  ,0),_env),0),
  eval_para_delay_delay ( c_cdr (left) ,_env )
  );
}

void  compare(void  *_left,void *_right)
{
 Type *left=_left,*right=_right,*temp; 
 if(!(left-right) )
  return ;
 else
 {
  /*
  void  c_unbindvars(void **_env)
{
 Type *result= c_car (*_env ) ;
 result=c_cdr (result );
 *_env=c_cons (result ,  c_cdr (*_env ) );
}
*/  
  c_unbindvar (c_car (left) );
  //aux function below
  gc_frame (c_car (left) );
  temp=c_cdr(left);
  gc_atom (left);
  //
  compare(temp,right);
 }

}
void *  eval_para(void  *_left,void **_env)
{ 
 Type *temp,*env=*_env;
 Type *left=_left;
 if (left->em==EMPTY)
  return  empty_type();
 else
 {
  temp=eval( c_car (left),&env);  
  compare ( env ,*_env );
  return c_cons ( temp ,eval_para ( c_cdr (left) ,_env ) );
 }
 /*
  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,*temp;

 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_defun_arg(head ,global_twice)))
 { 
  tempvalue=  c_cdr (left )  ;    //modify by chenbing   2011.4.7
   //  tempvalue=eval_para_delay_delay( c_cdr (left ),_env ) ;
  temp=eval  (  c_find_defun_expr(head ,global_twice)  ,c_bindvars( tempname, tempvalue,_env ));
  result= eval( temp ,_env);
  gc(temp);
   
  /*
   temp=eval  (  c_find_defun_expr(head ,global_twice)  ,
    c_bindvars( tempname, tempvalue,_env ));  
   result=eval ( temp,_env) ;
  printf("chenbing/n");
   left_print (temp);
   */
//  gc(temp);
  c_unbindvars( _env );
 }   
 else if((tempname=c_find_defun_arg(head,global_once)))
 {  
  
//  tempvalue=eval_para_delay( c_cdr (left ),_env );   
  tempvalue=eval_para( c_cdr (left ),_env ); 
  result=  eval  ( c_find_defun_expr(head,global_once),
   c_bindvars( tempname, tempvalue,_env)
   )  ;
//  compare(temp,*_env);
  c_unbindvars( _env );
  
 // free_object();

//  tempvalue=eval_para_delay( c_cdr (left ),_env );
 
/*  
  tempvalue=eval_para( c_cdr (left ),_env ); 
  result=  eval  ( c_find_defun_expr(head,global_once),
   c_bindvars( tempname, tempvalue,_env)
   )  ;
//  compare (*_env, c_cdr (*_env ) );
  c_unbindvars( _env );
*/
 }   
 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;
 char temp[2]="/0";
 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 if(!strcmp("t",name))
  {
   return  true_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  c_list ( set_type(QUOTE),factor(),0 );
 case  '/`':
  return  c_list ( set_type(QUOTE2),factor(),0 );
 case  '/,':
  return   set_type(EVAL);
 default:
  {
   temp[0]=(char)token;
   return  fun_type( temp);
  }
   
   /*   
 case '+':
  return fun_type("+");
 case '/':
  return fun_type("/");
  break;
 case '*':
  return fun_type("*");
  break;  
 case '>':
  return fun_type(">");
  break;
 case '<':
  return fun_type("<");
 case '-':
  return fun_type("-");
  break;
  */

 }
 return NULL;
}
static jmp_buf onError;

int main (void)
{
 int  sign;
 Type * ele_left;
 Type *  ele_right;
 FILE *in;
 volatile int errors = 0;

 char buf [8*BUFSIZ]; 
 Type  *m_env;
 srand ((int)time (NULL) );
 init_object();

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

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

 if (setjmp(onError))
  ++ errors;

 //advance  high-tech

 ele_left=c_list (
         set_type(DEFMACRO),var_type("demo"), c_list( var_type("expr"),0),
      c_list (  fun_type("print") ,var_type("expr"),0) ,               
          0);      
 wrap_eval ( ele_left,&m_env) ;
 ele_left=c_list(
            set_type(DEFMACRO),var_type("mymachine"), c_list( var_type("exprs"),0),
      c_list( set_type(QUOTE2),
              c_list ( set_type(IF),  set_type(EVAL),
                 c_list( fun_type("eq"), var_type("exprs"),empty2_type(),
           0),
           empty2_type(),
           c_list(set_type(PROGN),
                                 c_list(fun_type("print"),
               c_list( var_type("demo"), set_type(EVAL),
                            c_list( fun_type("car"),var_type("exprs"),
                   0),
               0),
               0),
               c_list(var_type("mymachine"),set_type(EVAL),
                             c_list( fun_type("cdr"),var_type("exprs"),
                    0),
               0),
         0),
       0),
     0),
    0);
              
 wrap_eval ( ele_left,&m_env) ;

 // 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);    
    count_object();
       count_gc();
    left_print(m_env);
    ele_left=c_list ( var_type("mymachine"),c_list (ele_left,0),0);  
    ele_left=c_list ( var_type("mymachine"),c_list (ele_left,0),0);  
    gc  ( left_print  ( wrap_eval ( ele_left,&m_env)  ) );
    count_object();
       count_gc();
    left_print(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);
}