lisa with awk build in

 (setq result (match  'data 'chen))
(print result)
(defun  awk  (lst )
 (if  (eq lst nil)
        nil
                (cons  (+   1
                                    (car (cdr (car lst))))
                       (awk (cdr  lst)))))
(awk  result)
(defun  awk  (lst )
  (if  (eq lst nil)
           nil
                   (cons  (+   (car (cdr (car lst)))
                                   (car (cdr (cdr (car lst)))))
                                  (awk (cdr  lst)))))
(awk  result)

 

^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^

(  setq  result    (  match     (  quote  data   )   (  quote  chen   )  )  ) 205  0  data
    (  data  10 1000  )   (    (  data  10 1000  )  ) (data  10  1000)

data
    (  data  20 3000  )   (    (  data  10 1000  )   (  data  20 3000  )  ) (data  20  3000)

data
    (  data  100 2000  )   (    (  data  10 1000  )   (  data  20 3000  )   (  data  100 2000  )  ) (data  100  2000)

result  246  1 

  (  print   result   ) 251  1   
    (    (  data  10 1000  )   (  data  20 3000  )   (  data  100 2000  )  )   (    (  data  10 1000  )   (  data  20 3000  )   (  data  100 2000  )  ) 273  23 

  (  defun   awk    (  lst   )   (  if    (  eq   lst  nil  ) nil   (  cons     (  +   1   (  car     (  cdr     (  car   lst   )  )  )  )   (  awk    (  cdr   lst   )  )  )  )  ) 345  23  awk  401  24 

  (  awk  result   ) 406  24    (  11 21 101  ) 626  232 

  (  defun   awk    (  lst   )   (  if    (  eq   lst  nil  ) nil   (  cons     (  +     (  car     (  cdr     (  car   lst   )  )  )   (  car     (  cdr     (  cdr     (  car   lst   )  )  )  )  )   (  awk    (  cdr   lst   )  )  )  )  ) 714  232  awk  782  233 

  (  awk  result   ) 787  233    (  1010 3020 2100  ) 1058  480 

^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^

#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  <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;
  int  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  *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(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==NULLVALUE)
  printf("%s ","nil");
 else if(left->em==FORMAL)
  printf("formal ");
 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  * 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;
 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_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;
}
char  *error_label="error";
char *matchhere (char *regex ,char *text);

typedef  int bool ;
#define  true  1
#define  false 0
bool  match(char *regex ,char *text)
{
 bool  label=false;
 while(*text!='\0')
 {
  char  *rtn;
  rtn=matchhere(regex ,text);
  if (rtn ==error_label)
  {
  }
  else
  {
   char  match_text[100]="\0";
   memcpy(match_text , text ,  sizeof(char )* (rtn -text) );
   printf("%s \n  ",  match_text);
   label=true;
   //              return rtn;
  }
  text++;
 }
 return label;
}

char *matchhere (char *regex ,char *text)
{
 if(*regex=='\0')
 {
  return text;
 }
 if(*text=='\0')
 {
  return  error_label;
 }
 if(*regex=='.')
 {
  return matchhere(regex+1 ,text +1);
 }
 if (*regex=='*')
 {

  char * rtn;
  while( *text!='\0'  &&  ( rtn =matchhere ( regex+1 , text++ )  ) ==error_label)
  {                       

  }
  return  rtn;
 }
 if (*regex==*text)
 {
  return  matchhere (  regex +1 ,text +1);
 }
 else
 {
  return  error_label;
 }
}
typedef struct  parse
{
 //  enum tokens  (*fun_scan)(void  *this ,const char *buf);
 const char *bp;
 enum  tokens token;
 int  number;
 char name[20];
 //  void *  (*fun_factor)(void  * this);
}parse;

static enum tokens scan (void *this ,const char * buf);
static void * factor (void *this );

void  *original_match(void  *_left)
{
 parse  second;
 Type  *ele_left,*ele_right,*result;
 Type  *left=c_car (_left);
 Type  *right=c_cadr (_left);
 char filename[200]="\0";
 sprintf(filename , "%s" ,right->u_data.s_data);
 FILE  *fp=fopen (filename,"rt");
 char  buffer[256]="\0";
 char  regex[100]="\0";
 sprintf(regex,"%s",left->u_data.s_data);
 bool rtn=false;
 result=NULL;
 while( fgets (buffer,200,fp) )
 {
  rtn=match ( regex ,buffer);
  if(rtn==true)
  {

   scan(&second,buffer);
   while(second.token=='(')
   {
    ele_left=factor(&second);
    ele_left=c_cons (  ele_left , empty_type()) ;
    while (1)
    {
     ele_right=factor(&second);
     if(ele_right)
      ele_left=c_appdix (  ele_left,ele_right );
     else
     {

      left_print ( ele_left);
      if (result==NULL)
      {
       result=c_cons ( ele_left,empty_type()) ;
      }
      else
      {
       result=c_appdix ( result , ele_left );
      }
      left_print (result);
      break;

     }
    }
   }
   printf("%s\n",buffer);
  }
 }
 fclose (fp);
 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,*temp;
 void *mother;
 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,*temp;
 void *mother;
 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[]={{"match",original_match},{"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=(void **)&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)) ,(void**)&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) ) ,(void **)&right);  
   break;
  case  LAMBDA:
   // left=c_copy_type(left);
   temp= c_defun ( random_name( ) ,c_cadr (left ),
     c_caddr (left ) ,(void **)&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) ,(void **)&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 ) ) ,(void **)&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 ) ) ,(void **)&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),(void **)&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;
   static int number; 
   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 (void *this ,const char * buf)
 /* return token = next input symbol */
{
 // static const char * bp;   

 parse  *object=(parse  *)this;
 int sign=0,errno;
 memset(object->name,0,sizeof(object->name));

 if (buf)
  object->bp = buf;   /* new input line */
 const char *bp=object->bp;

 

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

 }
 else if (isalpha_ex(* bp & 0xff) || * bp == '.')
 {
  errno = 0;
  object->token = NAME;
  while(isalpha_ex(* bp & 0xff))
   object->name[sign++]=*bp++;
 }
 else
  object->token = * bp ? * bp ++ : 0;
 object->bp=bp;
 return object->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 *this )
{
 Type  *result;
 Type * ele_left;
 Type *  ele_right;
 parse  *object  =(parse *)this;
 char *name=object->name;
 char temp[2]="\0";
 funp  pfun;
 Enum  type;
 scan(object ,0);
 switch (object->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 (object->number);
   break;
  case '(':
   ele_left=factor(object);
   if(!ele_left)
   {
    return  c_cons (empty_type(),empty_type());
   }
   ele_left=c_cons (  ele_left , empty_type()) ; 

   while (1)
   {
    ele_right=factor(object); 
    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(object),0 );
  case  '\`':
   return  c_list ( set_type(QUOTE2),factor(object),0 );
  case  '\,':
   return   set_type(EVAL);
  default:
   {
    temp[0]=(char)object->token;
    return  fun_type( temp);
   }

 

 }
 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,(void **)&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,(void **)&m_env) ;

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

 parse  first;
 scan(&first,buf);
 while (first.token== '(')
 { 
  ele_left=factor(&first);
  ele_left=c_cons (  ele_left , empty_type()) ; 
  while (1)
  {
   ele_right=factor(&first); 
   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,(void**)&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;   
   }
  }
  first.token=scan(&first,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);
}