咬尾巴(非惰性)

来源:互联网 发布:linux 挂起进程 编辑:程序博客网 时间:2024/03/29 15:48

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

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

(defun  test  (n)
(if  (>  n  0)
    (print (+  n   (test  (-  n  1) ) ))
    1
)
)

(test  2)

 

))
))
 
$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$

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

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

(defun  fibs  (n)
(if  (>  n  0)
   (print (+   (fibs  (-  n  1) )
               (fibs  (-  n  2) )
           ))
      1
)
)

(fibs  5)
(fibs 6 )
(fibs  7) 

 

))
))
 
$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$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>

#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
}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;

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


#define  NUM  1000
Type   *mem_manager;
int  global_count=200000;
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=NULLVALUE;
 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_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 *c_cadr(void  *_left);
void * wrap_c_cons(void * _left)

 Type *left=_left;
 return  c_cons   (  c_car  (left ) , c_cadr (left) ); 
}
void * wrap_c_cdr (void *_left)
{
 Type  *left=c_car (_left )  ;
 return  c_cdr ( left);
}
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 )  ;
 return  c_car ( 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 * 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==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==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==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 * wrap_print(void *  _left)
{
 printf ("  /n  ");
 return left_print( c_car (_left) );   //modify by chebing  2011.3.11
}

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_small(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_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_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 ,void **mem)
{
 *mem=c_cons ( c_cons ( c_list (name,arg,expr,0) ,empty_type() ),*mem);
 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},{"/",original_divi},{"<",original_small},
{"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},{"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
 {
  left_print( c_car (left));
  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,void *mem)
{
 Type  *_env=mem;
 Type  *label;
 while(_env)
 {
  label=c_car ( 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 ( 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  *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) )
   );
 }
}
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 *  eval(void  *_left,void **_env)
{

 Type  *temp,*right;
 Type  *left=_left;
 Type  *head=NULL;
 int  *label,count=0;
 if(left->em==EMPTY)
  return  empty_type();
 else if(left->em==VAR )
 {
  if(temp=c_find_var_value(left ,*_env) )
  { 
   return  temp;
   left_print(temp);
   return  eval ( temp ,_env);   //add  by  chenbing  2011.3.11
   if(temp->em==LIST&&!strcmp( ((Type*)c_car(temp))->u_data.s_data,"delay")!=0)
   {
         return  eval ( c_cons( set_type(FUNCALL),c_cdr(temp)) ,_env);   //add  by  chenbing  2011.3.11
   }
   else
   {
    return  temp;
   }
  } 
  else
  {
   return  left;
  }
 }
 else if (left->em==INT&&left->u_data.i_data==NULLVALUE)
  return  empty_type();
 else if (left->em==INT)
  return  left;
 assert(left->em==LIST);
 head=c_car (left );
 switch(head->em)
 {
 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: 
  //  return wrap_setjmp(left,_env);   // can't support  this function now.
  break;
 case  FUNCALL:  
  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 );   
   return wrap_eval ( c_cons ( temp,add_quote ( left) )  ,
    &right );

  }
  break;
 case  LAMBDA:
  temp= c_defun ( random_name( ) ,c_cadr (left ),
   c_caddr (left ) ,&global_once);
  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)   );
  */
  return  head->f_data (  eval_para  ( c_cdr (left ) ,_env ) ) ;
  break;
 case DEFUN:  
  temp=c_defun (c_cadr (left ), c_caddr (left ),c_cadr (c_cddr (left ) ) ,&global_once);
  c_lambda_put(temp,*_env);
  return  temp;
  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_defun (c_cadr (left ), c_caddr (left ),c_cadr (c_cddr (left ) ) ,&global_twice);
  break;
 case  QUOTE:  
  return  c_cadr (left);   
  break;
 case  LIST:
  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;
 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 ) );
}


void *  eval_para_delay(void  *_left,void **_env)

 Type *left=_left;
 if (left->em==EMPTY)
  return  empty_type();
 else
  return c_cons (
  c_list ( set_type(FUNCALL), 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 *  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;


 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 );
//  tempvalue=eval_para_delay( c_cdr (left ),_env ) ;
  c_bindvars( tempname, tempvalue,_env );
  result=eval  (  c_find_defun_expr(head ,global_twice)  ,_env);
  result=eval(result ,_env);
  /*
  result= eval( eval  (  c_find_defun_expr(head ,global_twice)  ,_env) ,
   c_bindvars( tempname, tempvalue,_env ) );
  */
   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 )
   )  ;
  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;
 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("+");
 case '/':
  return fun_type("/");
  break;  
 case '>':
  return fun_type(">");
  break;
 case '<':
  return fun_type("<");
 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;

 //advance  high-tech
 /*
 (defmacro  demo  (expr)
(print  expr)
)
(defmacro  mymachine  (exprs)
`(if  ,(eq  exprs  nil)
      nil
     (progn
          (demo ,(car  exprs))
         (mymachine  ,(cdr  exprs) )
      )
)
)
*/
 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( var_type("demo"), set_type(EVAL),
                            c_list( fun_type("car"),var_type("exprs"),
                   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);
    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);
}

 

 

原创粉丝点击