(defun emerge (x y)(if (eq x nil) y (if (eq y nil ) x (if (> (car x ) (car y) ) (cons (car y) (emerge x (cdr y) ) ) (cons (car x ) ( emerge (cdr x) y ) ) ) )))
(defun ptr ( x num )(if (eq num 0) x (ptr (cdr x ) (- num 1 ) )))
(defun myget (x count )(if (eq count 0) nil (cons (car x) (myget (cdr x ) (- count 1) ) )))
(defun divi (x num )(if (eq num 2) (if (> (car x ) (cadr x) ) (cons (cadr x ) (list (car x) ) ) x ) (emerge (divi (myget (ptr x 0 ) (/ num 2) ) (/ num 2) ) (divi (myget (ptr x (/ num 2) ) (/ num 2 ) ) (/ num 2) ) )))
(car (list 1 2) )(cadr (list 1 2) )
(setq y '( 23 345 ) )(divi y 2) (setq y '(345 23 ) )(divi y 2)
(setq y '(345 23 10 89 34 2 77 864) )(divi y 8) (setq z '(23 34 11 98 456 875 76 21) )(divi z 8)
$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$
#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 1000int 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 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=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 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==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(_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_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},{"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 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,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()&+'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) ) ); }}
void * eval_para(void *_left,void **_env);void * eval(void *_left,void **_env){
Type *temp,*right; Type *left=_left; Type *head=NULL; if(left->em==EMPTY) return empty_type(); else if(left->em==VAR ) { if(temp=c_find_var_value(left ,*_env) ) { 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 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: 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 ) );}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 * 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;
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_defun_arg(head ,global_twice))) { tempvalue=c_cdr (left ); 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))) { left_print ( c_car (left) ); 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 { 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; 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("-"); 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;
// 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);}
