垃圾收集初步

#include <ctype.h>
#include <assert.h>
#include <stdlib.h>
#include <stdio.h>
#include <memory.h>
#include <stdarg.h>
#include <string.h>
#include <setjmp.h>
#include <time.h>
#include <process.h>

#define NULLVALUE 999999
#define MAX 1000
int vec_global=0;

typedef void * (*funp )(void * _left);
enum tokens {
NUMBER = 'n',
NAME
};

typedef enum Enum
{
EMPTY=1,INT,CHAR,FUN,DEFUN,DEFMACRO,VAR,COND,QUOTE,LIST,QUOTE2,
IF,PROGN,EVAL,SETQ,SETF,PARA,EQ,CONSTREAM,TAIL,CALLCC,SYMBOL,JMPBUF
}Enum;
typedef enum forth
{
ADD=100,MINUS,GETFIRST,DIGIT,TEST,RET,RAND,CALL,GO,PTR,PUSH,
END,GET,POP,PRINT,NOTHING,SETRET,POPRET,BACK,GETTOP,FUNCALL,LAMBDA
}forth;

typedef struct Type
{
enum Enum em;
funp f_data;
union
{
int i_data;
// char c_data;
char s_data[30];
struct Type * n_data;
} u_data;
struct Type * next;
}Type;

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

#define NUM 1000
Type *mem_manager_unused;
Type *mem_manager_used;
int global_count=200000;
int mem_count=0;
/*
Type* new_object2()
{
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 *c_car(void *);
void *c_cdr(void *);
Type* new_object()
{
Type *temp;
temp=c_car(mem_manager_unused);
mem_manager_unused=c_cdr(mem_manager_unused);

return temp;
}
Type* init_object()
{
int i=0;
Type *result;

mem_manager_unused=(Type *)malloc (global_count *sizeof (Type ) );

for(i=0;i<global_count;i++,i++)
{
((Type*)&mem_manager_unused[i])->u_data.n_data=&mem_manager_unused[i+1];
((Type*)&mem_manager_unused[i])->next=&mem_manager_unused[i+2];
(&mem_manager_unused[i])->em=LIST;
//add by chenbing 2011.1.13
}
}
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_type2(void *_right)
{
Type *left;
Type *right=_right;
if(right->em==EMPTY)
return right; //空值不需要拷贝
left= new_object() ;
memcpy(left,right,sizeof( Type) );
return left;
}

void * c_cons (void * _left,void * _right)
{
Type *type_data;
type_data= new_object() ;
type_data->em=LIST;
type_data->u_data.n_data=_left;
type_data->next=_right;
return type_data;
}
void * c_constream (void * _left,void * _right)
{
Type *type_data;
type_data= new_object() ;
type_data->em=CONSTREAM;
type_data->u_data.n_data=_left;
type_data->next=_right;
return type_data;
}
void *eval (void ** );
void *c_car (void *);
void * c_car_address (void * _left)
{
Type * left=_left;
if(left->em==EMPTY)
return empty_type();
assert(left->em==LIST);
return &(left->u_data.n_data);
}
void * c_car (void * _left)
{
Type * left=_left;
if(left->em==EMPTY)
return empty_type();
assert(left->em==LIST||left->em==CONSTREAM); //modidify at 2010.1.8
return left->u_data.n_data;
}
void * c_cdr (void * _left)
{
Type * left=_left;
if(left->em==EMPTY)
return empty_type();
assert(left->em==LIST);
return left->next;
}
void *c_cadr(void *_left);
void * wrap_c_cons(void * _left)
{
Type *left=_left;
return c_cons ( c_car (left ) , c_cadr (left) );
}
void * wrap_c_cdr (void *_left)
{
Type *left=c_car (_left ) ;
return c_cdr ( left);
}
void * wrap_c_cadr (void *_left)
{
Type *left=c_car (_left ) ;
return c_cadr ( left);
}
void * wrap_c_car (void *_left)
{
Type *left=c_car (_left ) ;
return c_car ( left);
}
void * int_type(int i);
int c_eq(void *_left,void *_right)
{
Type*left=_left;
Type *right=_right;

if(c_atom (left )&&c_atom (right) )
{
if (left->u_data.i_data==right->u_data.i_data)
return 1;
return 0;
}
else
return 0;
}

void * wrap_c_eq(void * _left)
{
Type *left=_left;

Type *type_data;
type_data= new_object() ;
type_data->em=INT;
type_data->u_data.i_data=
c_eq ( c_car (left ) , c_cadr (left) );
return type_data;
}
void * wrap_c_atom(void * _left)
{
Type *left=_left;

Type *type_data;
type_data= new_object() ;
type_data->em=INT;
type_data->u_data.i_data=
c_atom ( left );
return type_data;
}
void * wrap_c_list(void * _left)
{
return _left;
}

int c_not (int i)
{
if(i==1)
return 0;
else return 1;
}
int c_atom(void *_left)
{
Type *left=_left;
if(left->em==LIST)
return 0;
return 1;
}

void * c_appdix (void * _left,void * _right)
{
Type * left=_left;
Type * right=_right;

if( left->em==EMPTY)
return c_cons (right ,empty_type() );
else
return c_cons ( c_car ( left) ,
c_appdix ( c_cdr (left ) ,right ) );

}
void * c_list (void *left , ...)
{
Type * ele_left;
Type * ele_right;
va_list ap;
ele_left=left;
ele_left=c_cons ( ele_left , empty_type()) ;
va_start(ap, left);

while (1)
{
ele_right=va_arg(ap, void *);
if(ele_right)
ele_left=c_appdix ( ele_left,ele_right );
else
{
break;
}

}
va_end(ap);
return ele_left;
}

//some aux function
void *c_caar(void *_left)
{
return c_car(c_car(_left));
}
void * c_cddr(void *_left)
{
return c_cdr(c_cdr(_left));
}
void *c_caddr(void *_left)
{
return c_car( c_cddr(_left) );
}

void *c_cdar(void *_left)
{
return c_cdr(c_car(_left));
}
void *c_cadr(void *_left)
{
return c_car(c_cdr(_left));
}

void *c_cadar(void *_left)
{
return c_car(c_cdr(c_car(_left)));
}
void *c_cadadr(void *_left)
{
return c_car(c_cdr(c_car(c_cdr(_left))));
}
void * int_type(int i)
{
Type *result= new_object() ;
result->em=INT;
result->u_data.i_data=i;
return result;
}
void * set_type(Enum type)
{
Type *result= new_object() ;
result->em=type;
return result;
}
void * left_print(void * _left)
{
Type *left=_left;
Type *temp;
if(!left)
{
return empty_type();
}
if ( left->em==EMPTY)
{
return empty_type();
}
else if(left->em==INT&&left->u_data.i_data==NULLVALUE)
printf("%s ","nil");
else if(left->em==INT)
printf("%d ",left->u_data.i_data);
else if(left->em==VAR)
printf("%s ",left->u_data.s_data);
else if(left->em==FUN)
printf("%s ",left->u_data.s_data);
else if(left->em==QUOTE)
printf("%s ","quote");
else if(left->em==DEFUN)
printf("%s ","defun");
else if(left->em==FUNCALL)
printf("%s ","funcall");
else if(left->em==DEFMACRO)
printf("%s ","defmacro");
else if(left->em==SETQ)
printf("%s ","setq");
else if(left->em==SETF)
printf("%s ","setf");
else if(left->em==IF)
printf("%s ","if");
else if (left->em==LIST)
{

printf(" ( ");
for ( temp=left; temp->em!=EMPTY ;temp= c_cdr (temp) )
{
left_print ( c_car (temp) );
}
printf(" ) ");
}
return left;
}
void * right_print(void * _left)
{
Type *left=_left;
if ( left->em==EMPTY)
{
return empty_type();
}
else if(left->em==INT&&left->u_data.i_data==NULLVALUE)
printf("%s ","nil");
else if(left->em==INT)
printf("%d ",left->u_data.i_data);
else if(left->em==VAR)
printf("%s ",left->u_data.s_data);
else if(left->em==FUN)
printf("%s ",left->u_data.s_data);
else if(left->em==QUOTE)
printf("%s ","quote");
else if(left->em==DEFUN)
printf("%s ","defun");
else if(left->em==DEFMACRO)
printf("%s ","defmacro");
else if(left->em==FUNCALL)
printf("%s ","funcall");
else if(left->em==SETQ)
printf("%s ","setq");
else if(left->em==SETF)
printf("%s ","setf");
else if(left->em==IF)
printf("%s ","if");
else if (left->em==LIST)
{
right_print( c_cdr (left) );
right_print( c_car (left) );
}
return left;
}
void * wrap_print(void * _left)
{
printf (" /n ");
return left_print( c_car (_left) ); //modify by chebing 2011.3.11
}

void * original_big(void * _left)
{
int result;
Type *left=c_car (_left ) ,*right=c_cadr (_left) ;
result=(( Type *)left)->u_data.i_data-(( Type *)right)->u_data.i_data;
return result>=0?int_type(1):int_type(-1);
}
void * original_small(void * _left)
{
int result;
Type *left=c_car (_left ) ,*right=c_cadr (_left) ;
result=(( Type *)left)->u_data.i_data-(( Type *)right)->u_data.i_data;
return result<0?int_type(1):int_type(-1);
}
void * original_divi(void * _left)
{
Type * result=new_object () ;
Type *left=c_car (_left ) ,*right=c_cadr (_left) ;
result->em=INT;
result->u_data.i_data=(( Type *)left)->u_data.i_data/(( Type *)right)->u_data.i_data;
return result;
}
void * original_add1(void * _left)
{
Type *left=_left;
Type *result= new_object() ;
result->em=INT;
result->u_data.i_data=(( Type *)left)->u_data.i_data+1;
return result;
}
void * original_add(void * _left)
{
Type *temp;
Type *left=_left;
Type *result= new_object() ;
result->em=INT;
result->u_data.i_data=0;
for(temp=left;temp->em!=EMPTY;temp=c_cdr (temp) )
result->u_data.i_data+=(( Type *)c_car(temp))->u_data.i_data;
return result;
}
void * original_minus(void * _left)
{
Type *temp;
Type *left=_left;
Type *result= new_object() ;
result->em=INT;
result->u_data.i_data=(( Type *)c_car(left))->u_data.i_data;
for(temp=c_cdr (left );temp->em!=EMPTY;temp=c_cdr (temp) )
result->u_data.i_data-=(( Type *)c_car(temp))->u_data.i_data;
return result;
}
void * original_minus1(void * _left)
{
Type *left=_left;
Type *result= new_object() ;
result->em=INT;
result->u_data.i_data=(( Type *)left)->u_data.i_data-1;
return result;
}

typedef struct Fun_info
{
char name[20];
funp address;
}Fun_info;
typedef struct Type_info
{
char name[20];
Enum type;
}Type_info;

void *c_defun (void *name,void *arg,void *expr ,void **mem)
{
*mem=c_cons ( c_cons ( c_list (name,arg,expr,0) ,empty_type() ),*mem);
return name;
}
void c_lambda_put (void *name,void *_env)
{
global_lambda=c_cons ( c_list ( name ,_env ,0 ),global_lambda);
}
void* c_lambda_get (void *_name)
{
Type *left ,*right, *temp ,*name ;
temp=global_lambda;
name=_name;
while( temp->em!=EMPTY)
{
left=c_car ( temp);
right=c_car (left );
if ( !strcmp ( name->u_data.s_data , right ->u_data.s_data ) )
{
return c_cadr (left);
}

temp=c_cdr (temp);
}
return NULL;

}
int c_atom (void *);
void * orignal_add1(void * _left);

Fun_info orignal_fun[]={{"print",wrap_print},
{"1+",original_add1},{"1-",original_minus1},{"+",original_add},{">",original_big},
{"-",original_minus},{"cons",wrap_c_cons},{"/",original_divi},{"<",original_small},
{"car",wrap_c_car},{"cdr",wrap_c_cdr},{"cadr",wrap_c_cadr},{"caddr",c_caddr},{"atom",wrap_c_atom},
{"list",wrap_c_list},{"eq",wrap_c_eq},{"",0}};

Type_info orignal_type[]={{"constream",CONSTREAM},{"para",PARA},
{"tail",TAIL},{"symbol",SYMBOL},{"defun",DEFUN},{"defmacro",DEFMACRO},{"end",END},
{"if",IF},{"progn",PROGN},{"setf",SETF},{"get",GET},{"pop",POP},{"gettop",GETTOP},{"nothing",NOTHING},
{"setq",SETQ},{"cond",COND},{"push",PUSH},{"funcall",FUNCALL},{"setret",SETRET},{"popret",POPRET},
{"lambda",LAMBDA},{"callcc",CALLCC},{"",0}};

void * fun_type(char *name)
{
int sign;
Type *result= new_object() ;
result->em=FUN;
sign=0;

while(1)
{
if(!strcmp("",orignal_fun[sign].name))
{
break;
}
else if(!strcmp(name,orignal_fun[sign].name))
{
result->f_data=orignal_fun[sign].address;
break;
}
else
sign++;
}
strcpy(result->u_data.s_data,name);
return result;
}
//similar to the macro dispatch
void * eval(void * _left,void ** _env) ;
void * eval_cond (void *_left,void **_env)
{
Type *left=_left;
if ( left->em==EMPTY)
return empty_type();
if( c_atom ( c_caar (left) ))
{
if(c_not( c_eq ( c_caar (left) ,int_type(0) ) ))
return eval ( c_cadar (left ),_env ) ;
return eval_cond ( c_cdr (left) ,_env);
}
else
{
if(c_not( c_eq ( eval ( c_caar (left) ,_env) ,int_type( 0) ) ))
return eval ( c_cadar (left ) ,_env) ;
return eval_cond ( c_cdr (left) ,_env);
}
}
void* left_print (void *);
void * eval_progn (void *_left,void **_env)
{
Type *left=_left;
if ( (( Type *)c_cadr (left))->em==EMPTY)
return eval ( c_car (left ),_env ) ;
else
{
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 * random_name ()
{
int i=0;
char name[9]="/0";

for(i=0;i<8;i++)
{
name[i]=rand()%26+'a';
}
return var_type(name);

}
/*
Type * out=NULL;
jmp_buf global ;
wrap_longjmp (void *_temp,void *_result)
{
jmp_buf *temp_buf;
Type * temp=_temp;
global_jmpbuf= c_cdr(global_jmpbuf );
temp_buf=c_car (temp );
out= _result;
longjmp ( global ,out);
}
void * wrap_setjmp (void *left,void **_env)
{
int retn;
jmp_buf *temp_buf=(jmp_buf*)malloc (sizeof (jmp_buf) );

if(setjmp(global))
{
return out;
}
else
{
((Type*) temp_buf)->em=JMPBUF;
global_jmpbuf=c_cons ( temp_buf,global_jmpbuf);
return wrap_eval ( c_cons (
eval ( c_cadr (left) ,_env) , c_cons (global_jmpbuf,empty_type() )
)
,_env ) ;
}
}
*/
void *add_quote (void *_left)
{
Type *left=_left;
if(left->em==EMPTY)
{
return empty_type();
}
else
{
return c_cons ( c_list ( set_type(QUOTE), c_car (left) ,0) ,
add_quote ( c_cdr (left) )
);
}
}
typedef struct Wrap_struct
{
void *_left;
void **_env;
int * address;
int count;
}Wrap_struct;
int _signal[10]={0};
void eval_special (void *_struct)
{
Type *result=NULL;
Wrap_struct *w=_struct;
w->address[w->count]=1;
result=eval (w->_left,w->_env);
printf("/n/n");
left_print(result);
w->address[w->count]=0;
}
void * eval_para(void *_left,void **_env);
void hand_thread (void *_left,void **_env,int _count)
{
unsigned pid;
Wrap_struct ww;
Type *ee;
Type *left=_left;
if (left->em==EMPTY)
{
;
}
else
{
ee=new_object() ;
ee=*_env;
ww._left=c_car(left);
ww._env=ⅇ
ww.count=_count;
ww.address=_signal;
_beginthreadex(NULL,0,
(unsigned (__stdcall *) (void *))eval_special,(void *)&ww ,0,&pid);
hand_thread( c_cdr (left) ,_env ,_count+1);
}
}
void * eval(void *_left,void **_env)
{

Type *temp,*right;
Type *left=_left;
Type *head=NULL;
int *label,count=0;
if(left->em==EMPTY)
return empty_type();
else if(left->em==VAR )
{
if(temp=c_find_var_value(left ,*_env) )
{
if(temp->em==LIST&&!strcmp( ((Type*)c_car(temp))->u_data.s_data,"delay")!=0)
{
return eval ( c_cons( set_type(FUNCALL),c_cdr(temp)) ,_env); //add by chenbing 2011.3.11
}
else
{
return temp;
}
}
else
{
return left;
}
}
else if (left->em==INT&&left->u_data.i_data==NULLVALUE)
return empty_type();
else if (left->em==INT)
return left;
assert(left->em==LIST);
head=c_car (left );
switch(head->em)
{
case PARA:
hand_thread ( c_cdr (left) ,_env ,0 );
while(count>=0)
{
count++;
}
while(1)
{
label=_signal;
while((!(*label))&&(label-_signal<10))
{
label++;
}
if(!(label-_signal-10))
{
break;
}
}
return empty_type();
break;
case EMPTY:
return empty_type();
case JMPBUF:
return left;
case SYMBOL:
return eval ( eval(c_cadr (left ),_env) ,_env);
break;
case CALLCC:
// return wrap_setjmp(left,_env); // can't support this function now.
break;
case FUNCALL:
temp= eval(c_cadr (left ),_env);
/*
if(temp->em==LIST)
{
wrap_longjmp(temp,c_caddr (left ));
}
else
*/
{
(right=c_lambda_get (temp))?right:*_env ;
// left= eval ( c_caddr (left) ,_env ); //calc first unless the _env changed , a little trick here using the quote
/*
if((( Type *) c_cadr(c_cddr ( left)))->em ==EMPTY )
{
left= eval ( c_caddr (left) ,_env );
return wrap_eval ( c_list ( temp,c_list ( set_type(QUOTE),left ,0) ,0 ) ,
&right );
}
else
{
left= eval_para ( c_cddr (left) ,_env );
left_print (add_quote ( left) );
return wrap_eval ( c_cons ( temp,add_quote ( left) ) ,
&right );
}
*/
left= eval_para ( c_cddr (left) ,_env );
return wrap_eval ( c_cons ( temp,add_quote ( left) ) ,
&right );
}
break;
case LAMBDA:
temp= c_defun ( random_name( ) ,c_cadr (left ),
c_caddr (left ) ,&global_once);
c_lambda_put(temp,*_env);
return temp;
/*
return c_defun ( random_name( ) ,c_cadr (left ),
contain_expr ( c_caddr (left ),c_cadr (left ),*_env ) );
*/
break;
case TAIL:
if ( ((Type*) c_cadr (left ))->em==LIST)
{
return eval ( c_cdr ( c_cadr (left) ),_env );
}
else
{
return eval ( c_cdr ( eval ( c_cadr (left) ,_env) ),_env );
}
break;
case CONSTREAM:
return c_cons ( eval ( c_cadr (left ) ,_env) , sub_expr ( c_caddr (left ) ,*_env ) );
break;
case SETQ:
eval_setq ( c_cdr (left),_env ) ;
break;
case SETF:
return eval_setf ( c_cdr (left),_env ) ;
break;
case IF:
if (c_eq ( eval ( c_cadr ( left ) ,_env ) , int_type(1) ) )
return eval ( c_caddr ( left) ,_env) ;
else
return eval (c_cadr (c_cddr ( left ) ),_env);
break;
case PROGN:
return eval_progn ( c_cdr (left),_env);
break;
case QUOTE2:
return eval_simple ( c_cadr (left),_env ) ;
break;
case INT:
if((( Type *) c_caddr ( left))->em ==EMPTY )
return c_cons (head, c_cons (eval ( c_cadr (left) ,_env),empty_type()) );
return c_cons (head, eval (c_cdr (left),_env ) );
break;
case COND:
return eval_cond ( c_cdr (left) ,_env);
break;
case FUN:
/*
if((( Type *) c_caddr ( left))->em ==EMPTY )
return head->f_data( eval ( c_cadr (left),_env ) );
return head->f_data( eval ( c_cdr (left) ,_env) );
*/
return head->f_data ( eval_para ( c_cdr (left ) ,_env ) ) ;
break;
case DEFUN:
temp=c_defun (c_cadr (left ), c_caddr (left ),c_cadr (c_cddr (left ) ) ,&global_once);
c_lambda_put(temp,*_env);
return temp;
break;
case VAR:
if(temp=c_find_var_value ( head, *_env) )
{
if((( Type *) c_caddr ( left))->em ==EMPTY )
return c_cons (temp, c_cons (eval ( c_cadr (left),_env ),empty_type()) );
return c_cons( temp ,eval ( c_cdr (left),_env ));
}
else
return wrap_eval (left,_env);
break;
case DEFMACRO:
return c_defun (c_cadr (left ), c_caddr (left ),c_cadr (c_cddr (left ) ) ,&global_twice);
break;
case QUOTE:
return c_cadr (left);
break;
case LIST:
printf("/n/n");
return left;
// return eval (head ,_env );
break;
}
return NULL;

}
/*
case LIST:
if((( Type *) c_caddr ( left))->em ==EMPTY )
return c_cons (eval ( c_car (left ),_env ),
c_cons (eval ( c_cadr (left) ,_env),empty_type()) );
return c_cons (eval ( c_car (left ) ,_env), eval (c_cdr (left),_env ) );
break;
*/

void ** c_bindvars(void *_left,void * _right,void **_env)
{
Type *left=_left;
Type *right=_right;
Type *m_env=c_car ( *_env );
if(left->em!=EMPTY)
{
m_env=c_cons (c_cons ( c_bindvar( left , right ) ,empty_type() ) , m_env );
*_env =c_cons ( m_env , c_cdr (*_env ) );
return _env;
}
else
{
return _env;
}
}
void c_unbindvars(void **_env)
{
Type *result= c_car (*_env ) ;
result=c_cdr (result );
*_env=c_cons (result , c_cdr (*_env ) );
}

void * eval_para_delay(void *_left,void **_env)
{
Type *left=_left;
if (left->em==EMPTY)
return empty_type();
else
return c_cons (
c_list ( 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 * eval_para(void *_left,void **_env)
{
Type *left=_left;
if (left->em==EMPTY)
return empty_type();
else
return c_cons (
eval (c_car (left) ,_env),
eval_para ( c_cdr (left) ,_env )
);
}
void * wrap_eval(void *_left,void **_env)
{
Type *tempname;
Type *tempvalue;
Type *result=NULL;
Type *left=_left;
Type *head=NULL;

if(left->em==VAR )
return c_find_var_value(left,*_env) ;
else if (left->em==INT)
return left ;
assert(left->em==LIST);
head=c_car (left );
if((tempname=c_find_defun_arg(head ,global_twice)))
{
tempvalue=c_cdr (left );
// tempvalue=eval_para_delay_delay( c_cdr (left ),_env ) ;
result= eval( eval ( c_find_defun_expr(head ,global_twice) ,_env) ,
c_bindvars( tempname, tempvalue,_env ) );
c_unbindvars( _env );
}
else if((tempname=c_find_defun_arg(head,global_once)))
{
tempvalue=eval_para_delay( c_cdr (left ),_env );
// tempvalue=eval_para( c_cdr (left ),_env );
result= eval ( c_find_defun_expr(head,global_once),
c_bindvars( tempname, tempvalue,_env )
) ;
c_unbindvars( _env );
}
else
{
result= eval ( left ,_env) ;
}
return result;
}
static enum tokens token; /* current input symbol */
static int number; /* if NUMBER: numerical value */
static char name[20];
static char alpha_ex[]="abcdefghijklmnopqrstuvwxyz_!";
int isalpha_ex(char *test)
{
int i=0;
for(i=0;alpha_ex[i]!='/0';i++)
if(alpha_ex[i]==test)
return 1;
return 0;

}
static enum tokens scan (const char * buf)
/* return token = next input symbol */
{
static const char * bp;
int sign=0;
memset(name,0,sizeof(name));

if (buf)
bp = buf; /* new input line */

while (isspace(* bp & 0xff))
++ bp;
if (isdigit(* bp & 0xff) || * bp == '.')
{
errno = 0;
token = NUMBER, number = strtod(bp, (char **) & bp);

}
else if (isalpha_ex(* bp & 0xff) || * bp == '.')
{
errno = 0;
token = NAME;
while(isalpha_ex(* bp & 0xff))
name[sign++]=*bp++;
}
else
token = * bp ? * bp ++ : 0;
return token;
}
funp select_fun (void *_name)
{
int sign=0;
while(1)
{
if(!strcmp("",orignal_fun[sign].name))
{
return NULL;
}
else if(!strcmp(name,orignal_fun[sign].name))
{
return orignal_fun[sign].address;
break;
}
else
sign++;
}
}
char * select_fun2 (funp address)
{
int sign=0;
while(1)
{
if(!orignal_fun[sign].address)
{
return NULL;
}
else if(address==orignal_fun[sign].address)
{
return orignal_fun[sign].name;
break;
}
else
sign++;
}
}
Enum select_type (void *_name)
{
char *name=_name;
int sign=0;
while(1)
{
if(!strcmp("",orignal_type[sign].name))
{
return (Enum) NULL;
}
else if(!strcmp(name,orignal_type[sign].name))
{
return orignal_type[sign].type;
break;
}
else
sign++;
}
}
char * select_type2 (Enum type)
{

int sign=0;
while(1)
{
if(!orignal_type[sign].type)
{
return NULL;
}
else if(type==orignal_type[sign].type)
{
return orignal_type[sign].name;
break;
}
else
sign++;
}
}
static void * factor (void)
{
Type *result;
Type * ele_left;
Type * ele_right;
funp pfun;
Enum type;
scan(0);
switch (token)
{
case NAME:
if ( pfun=select_fun (name) )
{
result= new_object ();
result->em=FUN;
result->f_data=pfun;
strcpy(result->u_data.s_data,name);
return result;
}
else if (type=select_type (name) )
{
return set_type (type );
}
else if(!strcmp("nil",name))
{
return empty2_type();
}
else 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 fun_type("+");
case '/':
return fun_type("/");
break;
case '>':
return fun_type(">");
break;
case '<':
return fun_type("<");
case '-':
return fun_type("-");
break;
case '/'':
return c_list ( set_type(QUOTE),factor(),0 );
case '/`':
return c_list ( set_type(QUOTE2),factor(),0 );
case '/,':
return set_type(EVAL);

}
return NULL;
}
static jmp_buf onError;
void garbage()
{

}
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 (time (NULL) );
init_object();

m_env=empty_type();
global_lambda=empty_type();

/*
for(i=0;i<MAX;i++)
{
compi[i].address=0;
}
*/

if (setjmp(onError))
++ errors;

//advance high-tech
/*
(defmacro demo (expr)
(print expr)
)
(defmacro mymachine (exprs)
`(if ,(eq exprs nil)
nil
(progn
(demo ,(car exprs))
(mymachine ,(cdr exprs) )
)
)
)
*/
ele_left=c_list (
set_type(DEFMACRO),var_type("demo"), c_list( var_type("expr"),0),
c_list ( fun_type("print") ,var_type("expr"),0) ,
0);
wrap_eval ( ele_left,&m_env) ;
ele_left=c_list(
set_type(DEFMACRO),var_type("mymachine"), c_list( var_type("exprs"),0),
c_list( set_type(QUOTE2),
c_list ( set_type(IF), set_type(EVAL),
c_list( fun_type("eq"), var_type("exprs"),empty2_type(),
0),
empty2_type(),
c_list(set_type(PROGN),
c_list(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);
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);
}