Rococo(funcall transform to lambda ) great improvement
#include
#include
#include
#include
#include
#include
#include
#include
#include
#include
#include
#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=400000; //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 { 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,*temp,*mother; left=global_once; while(c_cdr( left )&&( (Type *)c_cdr( left ) )->em!=EMPTY) { right=c_caar (left); if(!strcmp(((Type*)right)->u_data.s_data, (( Type *)name)->u_data.s_data)) { temp=left; gc_atom (right); printf("chenbing/n"); left_print (c_car (temp) ); gc_frame ( c_car (temp ) ); mother=left->mother; memcpy(left,c_cdr(left),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; } 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=ⅇ 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) ); left_print(right); 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: printf("chenbing/n"); left_print(left); 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); } 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 { 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 { for(j=0;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); }