#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_var{ Type *name; Type *value; }env_var;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;
#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= new_object(); result->em=EMPTY; result->u_data.i_data=999999; return result;}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;
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}};
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_set_global_var_value (void *name,void *value ,void ** _env ) { Type *result= new_object() ; Type *var=c_cadr(*_env); env_var *label=(env_var *)malloc (sizeof (env_var) ); label->name=c_copy_type2(name); label->value=value; result=c_cons (c_cons ( label ,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;}
int dirty_work=0;void * c_bindvar_help(void *name,void *value){ env_var *data=(env_var *)malloc (sizeof (env_var) ); if(!strcmp ( ( (Type*)name)->u_data.s_data,"b" )) dirty_work++; data->name=c_copy_type2(name); data->value=value; return data;}
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; if(lst->em==EMPTY) return NULL; if(!strcmp(left->u_data.s_data, ( (env_var *)c_car (lst ) )->name->u_data.s_data)) { return ((env_var *)c_car (lst ) )->value ; } else { return c_find_var_value_help (left, c_cdr (lst) ); } }void *c_find_var_value (void *_left,void *_env) { Type *left=_left,*result; Type *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) ; } return NULL;}
void *c_find_global_var_value (void *_name ,void *env) { env_var *label; Type *_env=c_cadr (env ); while(_env->em!=EMPTY) { label=c_car ( c_car (_env) ) ; if(!strcmp(label->name->u_data.s_data, (( Type *)_name)->u_data.s_data)) { return label->value; } _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[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_global_var_value(left ,*_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 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_caddr (left) ) ,_env); } break; case LAMBDA: return c_defun ( random_name( ) ,c_cadr (left ), sub_expr ( c_caddr (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 left_print ( head->f_data( eval ( c_cadr (left),_env ) )); return left_print ( 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_global_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 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;}static void * factor (void){ Type *result; int sign; Type * ele_left; Type * ele_right; scan(0); switch (token) { case NAME: sign=0; while(1) { if(!strcmp("",orignal_fun[sign].name)) { break; } else if(!strcmp(name,orignal_fun[sign].name)) { result= new_object() ; result->em=FUN; result->f_data=orignal_fun[sign].address; strcpy(result->u_data.s_data,name); return result; break; } else sign++; } if(!strcmp("constream",name)) { return set_type(CONSTREAM); } if(!strcmp("tail",name)) { return set_type(TAIL); } if(!strcmp("symbol",name)) { return set_type(SYMBOL); } if(!strcmp("defun",name)) { return set_type(DEFUN); } else if(!strcmp("defmacro",name)) { return set_type(DEFMACRO); } else if(!strcmp("if",name)) { return set_type(IF); } else if(!strcmp("progn",name)) { return set_type(PROGN); } else if(!strcmp("nil",name)) { return empty2_type(); } else if(!strcmp("setq",name)) { return set_type(SETQ); } else if(!strcmp("setf",name)) { return set_type(SETF); } else if(!strcmp("cond",name)) { return set_type(COND); } else if(!strcmp("ptr",name)) { return set_type(PTR); } else if(!strcmp("push",name)) { return set_type(PUSH); } else if(!strcmp("funcall",name)) { return set_type(FUNCALL); } else if(!strcmp("lambda",name)) { return set_type(LAMBDA); } else if(!strcmp("callcc",name)) { return set_type(CALLCC); } else if(!strcmp("get",name)) { return set_type(GET); } else if(!strcmp("pop",name)) { return set_type(POP); } else if(!strcmp("gettop",name)) { return set_type(GETTOP); } else if(!strcmp("nothing",name)) { return set_type(NOTHING); } else if(!strcmp("setret",name)) { return set_type(SETRET); } else if(!strcmp("popret",name)) { return set_type(POPRET); } else if(!strcmp("end",name)) { return set_type(END); } else if(!strcmp("para",name)) { return set_type(PARA); } 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=NULL; //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);}
