(setq chenbing (lambda (x) ( + x 5) ) )(funcall chenbing 15)
(setq chen(lambda () (lambda (yin ) (progn (print 'a) (lambda () (lambda (yang ) (progn (print 'b) (funcall yin yang ))))))) )
(defun wrapeval (cont count)(if (> count 0) (wrapeval (funcall (funcall cont ) (funcall cont ) ) (- count 1) ) nil))
(wrapeval chen 5)
$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$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 MAX 1000int vec_global=0;
typedef void * (*funp )(void * _left);enum tokens { NUMBER = 'n', NAME};
char * sdl_fun[]={"print","1+","1-","+","cons","cadr","caddr"};typedef enum Enum{ EMPTY=1,INT,CHAR,FUN,DEFUN,DEFMACRO,VAR,COND,QUOTE,LIST,QUOTE2, IF,PROGN,EVAL,SETQ,SETF,PARA,EQ,CONSTREAM,TAIL,CALLCC,SYMBOL,JMPBUF}Enum;typedef enum forth{ ADD=100,MINUS,GETFIRST,DIGIT,TEST,RET,RAND,CALL,GO,PTR,PUSH, END,GET,POP,PRINT,NOTHING,SETRET,POPRET,BACK,GETTOP,FUNCALL,LAMBDA}forth;
typedef struct Type{ enum Enum em; funp f_data; union { int i_data; // char c_data; char s_data[30]; struct Type * n_data; } u_data; struct Type * next; struct env *m_env;}Type;
typedef struct env_defun{ Type *name; Type *arg; Type *expr;}env_defun;typedef struct env_defmacro{ Type *name; Type *arg; Type *expr;}env_defmacro;Type *global_defun=NULL;Type *global_defmacro=NULL;Type *global_jmpbuf=NULL;Type *global_null=NULL;
#define NUM 1000Type *mem_manager;int global_count=20000;int mem_count=0;Type* new_object(){ Type *temp; if(global_count<2*mem_count) { temp=mem_manager; global_count=2*global_count; mem_manager=(Type *)malloc (global_count *sizeof (Type ) ); memmove(mem_manager,temp,mem_count*sizeof (Type ) ); free(temp); } return &mem_manager[mem_count++];}void * empty2_type(void){ Type *result= new_object(); result->em=INT; result->u_data.i_data=999999; return result;}void * empty_type(void){ Type *result; if(!global_null) { result= new_object(); result->em=EMPTY; result->u_data.i_data=999999; global_null=result; return result; } else { return global_null; }}void * c_copy_type2(void *_right){ Type *left; Type *right=_right; if(right->em==EMPTY) return right; //空值不需要拷贝 left= new_object() ; memcpy(left,right,sizeof( Type) ); return left; }
void * c_cons (void * _left,void * _right){ Type *type_data; type_data= new_object() ; type_data->em=LIST; type_data->u_data.n_data=_left; type_data->next=_right; return type_data; }void * c_constream (void * _left,void * _right){ Type *type_data; type_data= new_object() ; type_data->em=CONSTREAM; type_data->u_data.n_data=_left; type_data->next=_right; return type_data; }void *eval (void ** );void *c_car (void *);void * c_car_address (void * _left){ Type * left=_left; if(left->em==EMPTY) return empty_type(); assert(left->em==LIST); return &(left->u_data.n_data); }void * c_car (void * _left){ Type * left=_left; if(left->em==EMPTY) return empty_type(); assert(left->em==LIST||left->em==CONSTREAM); //modidify at 2010.1.8 return left->u_data.n_data; }void * c_cdr (void * _left){ Type * left=_left; if(left->em==EMPTY) return empty_type(); assert(left->em==LIST); return left->next;}
void * wrap_c_cons(void * _left){ Type *left=_left; return c_cons ( c_car (left ) , c_cdr (left) );}
void * int_type(int i);int c_eq(void *_left,void *_right){ Type*left=_left; Type *right=_right;
if(c_atom (left )&&c_atom (right) ) { if (left->u_data.i_data==right->u_data.i_data) return 1; return 0; } else return 0;}void *c_cadr(void *_left);void * wrap_c_eq(void * _left){ Type *left=_left;
Type *type_data; type_data= new_object() ; type_data->em=INT; type_data->u_data.i_data= c_eq ( c_car (left ) , c_cadr (left) ); return type_data;}void * wrap_c_atom(void * _left){ Type *left=_left;
Type *type_data; type_data= new_object() ; type_data->em=INT; type_data->u_data.i_data= c_atom ( left ); return type_data;}void * wrap_c_list(void * _left){ return _left;}
int c_not (int i){ if(i==1) return 0; else return 1;}int c_atom(void *_left){ Type *left=_left; if(left->em==LIST) return 0; return 1;}
void * c_appdix (void * _left,void * _right){ Type * left=_left; Type * right=_right;
if( left->em==EMPTY) return c_cons (right ,empty_type() ); else return c_cons ( c_car ( left) , c_appdix ( c_cdr (left ) ,right ) );
}void * c_list (void *left , ...){ Type * ele_left; Type * ele_right; va_list ap; ele_left=left; ele_left=c_cons ( ele_left , empty_type()) ; va_start(ap, left);
while (1) { ele_right=va_arg(ap, void *); if(ele_right) ele_left=c_appdix ( ele_left,ele_right ); else { break; }
} va_end(ap); return ele_left;}
//some aux functionvoid *c_caar(void *_left){ return c_car(c_car(_left));}void * c_cddr(void *_left){ return c_cdr(c_cdr(_left));}void *c_caddr(void *_left){ return c_car( c_cddr(_left) );}
void *c_cdar(void *_left){ return c_cdr(c_car(_left));}void *c_cadr(void *_left){ return c_car(c_cdr(_left));}
void *c_cadar(void *_left){ return c_car(c_cdr(c_car(_left)));}void *c_cadadr(void *_left){ return c_car(c_cdr(c_car(c_cdr(_left))));}void * int_type(int i){ Type *result= new_object() ; result->em=INT; result->u_data.i_data=i; return result;}void * set_type(Enum type){ Type *result= new_object() ; result->em=type; return result;}void * left_print(void * _left){ Type *left=_left; Type *temp; if(!left) { return empty_type(); } if ( left->em==EMPTY) { return empty_type(); } else if(left->em==INT&&left->u_data.i_data==999999) printf("%s ","nil"); else if(left->em==INT) printf("%d ",left->u_data.i_data); else if(left->em==VAR) printf("%s ",left->u_data.s_data); else if(left->em==FUN) printf("%s ",left->u_data.s_data); else if(left->em==QUOTE) printf("%s ","quote"); else if(left->em==DEFUN) printf("%s ","defun"); else if(left->em==FUNCALL) printf("%s ","funcall"); else if(left->em==DEFMACRO) printf("%s ","defmacro"); else if(left->em==SETQ) printf("%s ","setq"); else if(left->em==SETF) printf("%s ","setf"); else if(left->em==IF) printf("%s ","if"); else if (left->em==LIST) {
printf(" ( "); for ( temp=left; temp->em!=EMPTY ;temp= c_cdr (temp) ) { left_print ( c_car (temp) ); } printf(" ) "); } return left;}void * right_print(void * _left){ Type *left=_left; if ( left->em==EMPTY) { return empty_type(); } else if(left->em==INT&&left->u_data.i_data==999999) printf("%s ","nil"); else if(left->em==INT) printf("%d ",left->u_data.i_data); else if(left->em==VAR) printf("%s ",left->u_data.s_data); else if(left->em==FUN) printf("%s ",left->u_data.s_data); else if(left->em==QUOTE) printf("%s ","quote"); else if(left->em==DEFUN) printf("%s ","defun"); else if(left->em==DEFMACRO) printf("%s ","defmacro"); else if(left->em==FUNCALL) printf("%s ","funcall"); else if(left->em==SETQ) printf("%s ","setq"); else if(left->em==SETF) printf("%s ","setf"); else if(left->em==IF) printf("%s ","if"); else if (left->em==LIST) { right_print( c_cdr (left) ); right_print( c_car (left) ); } return left;}void * wrap_print(void * _left){ printf (" /n "); return left_print(_left);}
void * original_big(void * _left){ int result; Type *left=c_car (_left ) ,*right=c_cadr (_left) ; result=(( Type *)left)->u_data.i_data-(( Type *)right)->u_data.i_data; return result>=0?int_type(1):int_type(-1);}void * original_add1(void * _left){ Type *left=_left; Type *result= new_object() ; result->em=INT; result->u_data.i_data=(( Type *)left)->u_data.i_data+1; return result;}void * original_add(void * _left){ Type *temp; Type *left=_left; Type *result= new_object() ; result->em=INT; result->u_data.i_data=0; for(temp=left;temp->em!=EMPTY;temp=c_cdr (temp) ) result->u_data.i_data+=(( Type *)c_car(temp))->u_data.i_data; return result;}void * original_minus(void * _left){ Type *temp; Type *left=_left; Type *result= new_object() ; result->em=INT; result->u_data.i_data=(( Type *)c_car(left))->u_data.i_data; for(temp=c_cdr (left );temp->em!=EMPTY;temp=c_cdr (temp) ) result->u_data.i_data-=(( Type *)c_car(temp))->u_data.i_data; return result;}void * original_minus1(void * _left){ Type *left=_left; Type *result= new_object() ; result->em=INT; result->u_data.i_data=(( Type *)left)->u_data.i_data-1; return result;}
typedef struct Fun_info{ char name[20]; funp address;}Fun_info;typedef struct Type_info{ char name[20]; Enum type;}Type_info;
void *c_defun (void *name,void *arg,void *expr){ env_defun *defunvar=(env_defun*)malloc (sizeof (env_defun) ); defunvar->name=name; defunvar->arg=arg; defunvar->expr=expr; global_defun=c_cons ( c_cons ( defunvar ,empty_type() ),global_defun); return name;}int c_atom (void *);void * orignal_add1(void * _left);
Fun_info orignal_fun[]={{"print",wrap_print},{"1+",original_add1},{"1-",original_minus1},{"+",original_add},{">",original_big},{"-",original_minus},{"cons",wrap_c_cons},{"car",c_car},{"cdr",c_cdr},{"cadr",c_cadr},{"caddr",c_caddr},{"atom",wrap_c_atom},{"list",wrap_c_list},{"eq",wrap_c_eq},{"",0}};
Type_info orignal_type[]={{"constream",CONSTREAM},{"para",PARA},{"tail",TAIL},{"symbol",SYMBOL},{"defun",DEFUN},{"defmacro",DEFMACRO},{"end",END},{"if",IF},{"progn",PROGN},{"setf",SETF},{"get",GET},{"pop",POP},{"gettop",GETTOP},{"nothing",NOTHING},{"setq",SETQ},{"cond",COND},{"ptr",PTR},{"push",PUSH},{"funcall",FUNCALL},{"setret",SETRET},{"popret",POPRET},{"lambda",LAMBDA},{"callcc",CALLCC},{"",0}};
void * fun_type(char *name){ int sign; Type *result= new_object() ; result->em=FUN; sign=0;
while(1) { if(!strcmp("",orignal_fun[sign].name)) { break; } else if(!strcmp(name,orignal_fun[sign].name)) { result->f_data=orignal_fun[sign].address; break; } else sign++; } strcpy(result->u_data.s_data,name); return result;}//similar to the macro dispatchvoid * eval(void * _left,void ** _env) ;void * eval_cond (void *_left,void **_env){ Type *left=_left; if ( left->em==EMPTY) return empty_type(); if( c_atom ( c_caar (left) )) { if(c_not( c_eq ( c_caar (left) ,int_type(0) ) )) return eval ( c_cadar (left ),_env ) ; return eval_cond ( c_cdr (left) ,_env); } else { if(c_not( c_eq ( eval ( c_caar (left) ,_env) ,int_type( 0) ) )) return eval ( c_cadar (left ) ,_env) ; return eval_cond ( c_cdr (left) ,_env); }}void* left_print (void *);void * eval_progn (void *_left,void **_env){ Type *left=_left; if ( (( Type *)c_cadr (left))->em==EMPTY) return eval ( c_car (left ),_env ) ; else { eval (c_car (left) ,_env) ; return eval_progn (c_cdr (left ),_env ); } }
void * c_bindvar_help(void *name,void *value);void c_set_global_var_value (void *name,void *value ,void ** _env ) { Type *result= new_object() ; Type *var=c_cadr(*_env); result=c_cons (c_cons ( c_cons ( c_bindvar_help(name,value) ,empty_type() ),empty_type() ),var); *_env= c_cons ( c_car (*_env ) , c_cons ( result , empty_type() ) ) ; }void eval_setq (void *_left,void **_env){ Type *left=_left; if ( (( Type *)c_cadr ( c_cdr (left )))->em==EMPTY) { c_set_global_var_value ( c_car (left ), eval ( c_cadr (left ),_env ) , _env ); } else { c_set_global_var_value ( c_car (left ),eval ( c_cadr (left ),_env ) , _env ); eval_setq ( c_cddr (left),_env ); }}void * eval_setf (void *_left,void **_env){ /* Type *left=_left; if ( (( Type *)c_cadr ( c_cdr (left )))->em==EMPTY) { return c_bindvar_ex ( c_car (left ),eval ( c_cadr (left ) ,_env) ); } c_bindvar_ex ( c_car (left ),eval ( c_cadr (left ) ,_env) ); return eval_setf ( c_cddr (left) ,_env); */ return NULL;}
void *var_type (char * name){ Type *result= new_object() ; result->em=VAR; strcpy(result->u_data.s_data,name); return result;}
void * c_bindvar_help(void *name,void *value){ return c_cons ( c_copy_type2 (name) ,c_cons (value ,empty_type () ) ); }
void * c_bindvar (void *_left,void *_right){ Type *left=_left,*right=_right; if(left->em==EMPTY) { return empty_type(); } else { return c_cons ( c_bindvar_help ( c_car (left),c_car (right) ) , c_bindvar ( c_cdr (left),c_cdr (right) ) ); }}
void *c_find_defun_arg(void *name){ Type *_env=global_defun; env_defun *label; while(_env) { label=c_car ( c_car (_env) ); if(!strcmp(label->name->u_data.s_data, (( Type *)name)->u_data.s_data)) { return label->arg; } _env=c_cdr (_env) ; } return NULL;}void *c_find_defun_expr(void *name){
Type *_env=global_defun;
env_defun *label; while(_env) { label=c_car ( c_car(_env) ); if(!strcmp(label->name->u_data.s_data, (( Type *)name)->u_data.s_data)) { return label->expr; } _env=c_cdr (_env); } return NULL;
}void *c_find_defmacro_arg(void *name){ Type *_env=global_defmacro; env_defun *label; while(_env) { label=c_car ( c_car (_env) ); if(!strcmp(label->name->u_data.s_data, (( Type *)name)->u_data.s_data)) { return label->arg; } _env=c_cdr (_env); } return NULL;
}void *c_find_defmacro_expr(void *name){ Type * _env=global_defmacro;
env_defmacro *label; while(_env) { label=c_car ( c_car (_env) ) ; if(!strcmp(label->name->u_data.s_data, (( Type *)name)->u_data.s_data)) { return label->expr; } _env=c_cdr (_env) ; } return NULL;}
void *c_defmacro (void *name,void *arg,void *expr){ env_defmacro *defunvar=(env_defmacro*)malloc (sizeof (env_defmacro) ); defunvar->name=name; defunvar->arg=arg; defunvar->expr=expr; global_defmacro=c_cons (c_cons ( defunvar ,empty_type() ) ,global_defmacro ); return NULL;
}
void * wrap_eval(void *_left,void **_env);void * eval_simple(void *_left,void **_env){ Type *left=_left;
if ( left->em==EMPTY) return empty_type(); else if ( c_atom (left) ) return left; else if ( ( ( Type *) c_car (left ) )->em==EVAL) return c_cons ( eval ( c_cadr (left ),_env ) , eval_simple ( c_cddr (left ) ,_env) ); else return c_cons ( eval_simple( c_car (left ) ,_env), eval_simple ( c_cdr (left ) ,_env) );
}void *c_find_var_value_help (void *_left,void *_lst){ Type *left=_left,*lst=_lst; Type * t; if(lst->em==EMPTY) return NULL; t=c_car (lst) ; if(!strcmp(left->u_data.s_data, ( (Type *)c_car (t))->u_data.s_data)) { return c_cadr (t ) ; } else { return c_find_var_value_help (left, c_cdr (lst) ); }
}
void *c_find_var_value2 (void *_left,void *env) { Type *left=_left,*result ,*m_env,*_env; Type *__env=env; while(__env->em!=EMPTY) { _env=c_car (__env); while (_env->em!=EMPTY) { m_env=c_car (_env) ; while(m_env->em!=EMPTY) { if(result=c_find_var_value_help (left, c_car ( c_car (m_env) ) ) ) return result; m_env=c_cdr (m_env) ; } _env=c_cdr (_env); } __env=c_cdr (__env); } return NULL;}
void *c_find_var_value (void *_left,void *env) { Type *left=_left,*result ,*m_env; Type *_env=env; while (_env->em!=EMPTY) { m_env=c_car (_env) ; while(m_env->em!=EMPTY) { if(result=c_find_var_value_help (left, c_car ( c_car (m_env) ) ) ) return result; m_env=c_cdr (m_env) ; } _env=c_cdr (_env); } return NULL;}
void *sub_expr (void *_left,void *_env){ Type *left=_left,*temp; if(left->em==EMPTY) return empty_type(); if( ((Type*)c_car (_left))->em==VAR) { temp=c_find_var_value( c_car(left ) ,_env); if(!temp) { return c_cons (c_car (_left ) , sub_expr (c_cdr (_left) , _env ) ); } else { return c_cons ( temp , sub_expr (c_cdr (_left) , _env ) ); }
} else if( ((Type*)c_car (_left))->em==LIST) { return c_cons ( sub_expr (c_car (_left) , _env ) , sub_expr (c_cdr (_left) , _env ) ); } else { return c_cons (c_car (_left ) , sub_expr (c_cdr (_left) , _env ) ); }}int compare (void *_left ,void *_right){ Type *left=_left,*right=_right,*temp=NULL; if(right->em==EMPTY ) { return 0; } else { temp=c_car (right); if( !strcmp (left->u_data.s_data,temp->u_data.s_data) ) { return 1; } else { return compare (left,c_cdr (right) ); }
}}void *contain_expr (void *_left,void *_execption,void *_env){ Type *left=_left,*temp,*execption=_execption; if(left->em==EMPTY) return empty_type(); else if(left->em==VAR) { temp=left ; /* if( compare (temp ,execption ) ) { temp=temp; } else { temp->m_env=_env; } */ temp->m_env= c_cons ( _env , temp->m_env ); return temp; } else if( ((Type*)c_car (_left))->em==VAR) { temp= c_car(left ) ; /* if( compare (temp ,execption ) ) { temp=temp; } else { temp->m_env=_env; } */ temp->m_env= c_cons ( _env , temp->m_env ); return c_cons ( temp , contain_expr (c_cdr (_left) ,execption, _env ) ); } else if( ((Type*)c_car (_left))->em==LIST) { return c_cons ( contain_expr (c_car (_left) , execption, _env ) , contain_expr (c_cdr (_left) , execption, _env ) ); } else { return c_cons (c_car (_left ) , contain_expr (c_cdr (_left) ,execption, _env ) ); }}void * random_name (){ int i=0; char name[9]="/0"; srand (time (NULL) ); for(i=0;i<8;i++) { name[i]=rand()&+'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 * eval(void *_left,void **_env){
Type *temp; Type *left=_left; Type *head=NULL; if(left->em==EMPTY) return empty_type(); else if(left->em==VAR ) { if( temp=c_find_var_value2( left ,left->m_env)) { return temp; } else if(temp=c_find_var_value(left ,*_env) ) { return temp; } else { return left; } } else if (left->em==INT) return left; assert(left->em==LIST); head=c_car (left ); switch(head->em) { case EMPTY: return empty_type(); case JMPBUF: return left; case SYMBOL: return eval ( eval(c_cadr (left ),_env) ,_env); break; case CALLCC: return wrap_setjmp(left,_env); break; case FUNCALL: temp= eval(c_cadr (left ),_env); if(temp->em==LIST) { wrap_longjmp(temp,c_caddr (left )); } else { return wrap_eval ( c_cons ( temp, c_cddr (left) ) ,_env); } break; case LAMBDA: // return c_defun ( random_name( ) ,c_cadr (left ), sub_expr ( c_caddr (left ),*_env ) ); return c_defun ( random_name( ) ,c_cadr (left ), contain_expr ( c_caddr (left ),c_cadr (left ),*_env ) ); break; case TAIL: if ( ((Type*) c_cadr (left ))->em==LIST) { return eval ( c_cdr ( c_cadr (left) ),_env ); } else { return eval ( c_cdr ( eval ( c_cadr (left) ,_env) ),_env ); } break; case CONSTREAM: return c_cons ( eval ( c_cadr (left ) ,_env) , sub_expr ( c_caddr (left ) ,*_env ) ); break; case SETQ: eval_setq ( c_cdr (left),_env ) ; break; case SETF: return eval_setf ( c_cdr (left),_env ) ; break; case IF: if (c_eq ( eval ( c_cadr ( left ) ,_env ) , int_type(1) ) ) return eval ( c_caddr ( left) ,_env) ; else return eval (c_cadr (c_cddr ( left ) ),_env); break; case PROGN: return eval_progn ( c_cdr (left),_env); break; case QUOTE2: return eval_simple ( c_cadr (left),_env ) ; break;
case INT: if((( Type *) c_caddr ( left))->em ==EMPTY ) return c_cons (head, c_cons (eval ( c_cadr (left) ,_env),empty_type()) ); return c_cons (head, eval (c_cdr (left),_env ) ); break; case COND: return eval_cond ( c_cdr (left) ,_env); break; case FUN: if((( Type *) c_caddr ( left))->em ==EMPTY ) return head->f_data( eval ( c_cadr (left),_env ) ); return head->f_data( eval ( c_cdr (left) ,_env) ); break; case DEFUN: return c_defun (c_cadr (left ), c_caddr (left ),c_cadr (c_cddr (left ) )); break; case VAR: if( temp=c_find_var_value2( head ,head->m_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 if(temp=c_find_var_value ( head, *_env) ) { if((( Type *) c_caddr ( left))->em ==EMPTY ) return c_cons (temp, c_cons (eval ( c_cadr (left),_env ),empty_type()) ); return c_cons( temp ,eval ( c_cdr (left),_env )); } else return wrap_eval (left,_env); break; case DEFMACRO: return c_defmacro (c_cadr (left ), c_caddr (left ),c_cadr (c_cddr (left ) ) ); break; case QUOTE: return c_cadr (left) ; break; case LIST: 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; /* handle this (defun again ( x y) (print (+ x y) ) ) (again 10 (again (again 1 2) 40) ) */ } return NULL;
}
void ** c_bindvars(void *_left,void * _right,void **_env){ Type *left=_left; Type *right=_right; Type *m_env=c_car ( *_env ); if(left->em!=EMPTY) { m_env=c_cons (c_cons ( c_bindvar( left , right ) ,empty_type() ) , m_env ); *_env =c_cons ( m_env , c_cdr (*_env ) ); return _env; } else { return _env; }}void c_unbindvars(void **_env){ Type *result= c_car (*_env ) ; result=c_cdr (result ); *_env=c_cons (result , c_cdr (*_env ) );}typedef struct wrap_struct{ void *_left; void **_env;}wrap_struct;void eval_special (void *_struct){ Type *result=NULL; wrap_struct *w=_struct; result=eval (w->_left,w->_env); printf("/n/n"); left_print(result);}void * wrap_eval(void *_left,void **_env){ Type *tempname; Type *tempvalue; Type *result=NULL; Type *left=_left; Type *head=NULL;
int count=0; unsigned pid; wrap_struct w,ww; Type *e,*ee;
if(left->em==VAR ) return c_find_var_value(left,*_env) ; else if (left->em==INT) return left ; assert(left->em==LIST); head=c_car (left ); if((tempname=c_find_defmacro_arg(head))) { tempvalue=c_cdr (left ); result= eval ( eval ( c_find_defmacro_expr(head) ,_env) , c_bindvars( tempname, tempvalue,_env )) ; c_unbindvars( _env ); } else if((tempname=c_find_defun_arg(head))) { tempvalue=eval( c_cdr (left ),_env ); result= eval ( c_find_defun_expr(head), c_bindvars( tempname, tempvalue,_env ) ) ; c_unbindvars( _env ); } else { if( head->em==PARA) { e=new_object() ; e=*_env; w._left=c_cadr(left); w._env=&e; _beginthreadex(NULL,0, (unsigned (__stdcall *) (void *))eval_special,(void *)&w ,0,&pid); ee=new_object() ; ee=*_env; ww._left=c_caddr(left); ww._env=ⅇ _beginthreadex(NULL,0, (unsigned (__stdcall *) (void *))eval_special,(void *)&ww ,0,&pid); while(count>=0) { count++; } } else { result= eval ( left ,_env) ; } }
return result;}static enum tokens token; /* current input symbol */static int number; /* if NUMBER: numerical value */static char name[20]; static char alpha_ex[]="abcdefghijklmnopqrstuvwxyz_!";int isalpha_ex(char *test){ int i=0; for(i=0;alpha_ex[i]!='/0';i++) if(alpha_ex[i]==test) return 1; return 0;
}static enum tokens scan (const char * buf)/* return token = next input symbol */{ static const char * bp; int sign=0; memset(name,0,sizeof(name));
if (buf) bp = buf; /* new input line */
while (isspace(* bp & 0xff)) ++ bp; if (isdigit(* bp & 0xff) || * bp == '.') { errno = 0; token = NUMBER, number = strtod(bp, (char **) & bp);
} else if (isalpha_ex(* bp & 0xff) || * bp == '.') { errno = 0; token = NAME; while(isalpha_ex(* bp & 0xff)) name[sign++]=*bp++; } else token = * bp ? * bp ++ : 0; return token;}funp select_fun (void *_name){ int sign=0; while(1) { if(!strcmp("",orignal_fun[sign].name)) { return NULL; } else if(!strcmp(name,orignal_fun[sign].name)) { return orignal_fun[sign].address; break; } else sign++; } }char * select_fun2 (funp address){ int sign=0; while(1) { if(!orignal_fun[sign].address) { return NULL; } else if(address==orignal_fun[sign].address) { return orignal_fun[sign].name; break; } else sign++; } }Enum select_type (void *_name){ char *name=_name; int sign=0; while(1) { if(!strcmp("",orignal_type[sign].name)) { return (Enum) NULL; } else if(!strcmp(name,orignal_type[sign].name)) { return orignal_type[sign].type; break; } else sign++; } }char * select_type2 (Enum type){
int sign=0; while(1) { if(!orignal_type[sign].type) { return NULL; } else if(type==orignal_type[sign].type) { return orignal_type[sign].name; break; } else sign++; } }static void * factor (void){ Type *result; int sign; Type * ele_left; Type * ele_right; funp pfun; Enum type; scan(0); switch (token) { case NAME: if ( pfun=select_fun (name) ) { result= new_object (); result->em=FUN; result->f_data=pfun; strcpy(result->u_data.s_data,name); return result; } else if (type=select_type (name) ) { return set_type (type ); } else if(!strcmp("nil",name)) { return empty2_type(); } else { return var_type (name); } case NUMBER: return int_type (number); break; case '(': ele_left=factor(); if(!ele_left) { return c_cons (empty_type(),empty_type()); } ele_left=c_cons ( ele_left , empty_type()) ;
while (1) { ele_right=factor(); if(ele_right) { ele_left=c_appdix ( ele_left,ele_right ); } else { break; }
} return ele_left; break; case ')': return NULL; break; case '+': return fun_type("+"); break; case '>': return fun_type(">"); break; case '-': return fun_type("-"); break; case '/'': return c_list ( set_type(QUOTE),factor(),0 ); case '/`': return c_list ( set_type(QUOTE2),factor(),0 ); case '/,': return set_type(EVAL);
} return NULL;}static jmp_buf onError;int main (void){ int i,sign; Type * ele_left; Type * ele_right; FILE *in; volatile int errors = 0;
char buf [8*BUFSIZ]; Type *m_env; 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();
/* for(i=0;i<MAX;i++) { compi[i].address=0; } */
if (setjmp(onError)) ++ errors;
global_jmpbuf=empty_type(); sign=0; in=fopen("c://test.txt","r"); while(1) { buf[sign]=fgetc(in); if(feof(in)) break; sign++; }
scan(buf); while (token== '(') {
ele_left=factor(); ele_left=c_cons ( ele_left , empty_type()) ;
while (1) { ele_right=factor(); if(ele_right) ele_left=c_appdix ( ele_left,ele_right ); else { left_print(ele_left); // right_print(ele_left); left_print ( wrap_eval ( ele_left,&m_env) ); printf("/n/n"); // right_eval ( ele_left) ; // right_print ( stack_pop() ); /* printf( " /n "); temp=right_compile(c_cons( ele_left,empty_type() ) ,-99 ) ; if( ((Type *) c_car (ele_left ) )->em!=DEFUN) {
// right_interpret (temp); // serial(temp); // right_interpret ( unserial() ); right_install (temp); } else { for(i=0;i<unsolve_count;i++) { for(j=0;j<compi_count;j++) { if(!CODE[ unsolve[i].address ]&&!strcmp(unsolve[i].name,compi[j].name)) { CODE[ unsolve[i].address ]=compi[j].address; } } } if(!SYS)SYS=temp;
} */ break; } } token=scan(0); } // right_interpret ( ); return errors > 0;}
void error (const char * fmt, ...){ va_list ap;
va_start(ap, fmt); vfprintf(stderr, fmt, ap), putc('/n', stderr); va_end(ap); longjmp(onError, 1);}
