Rococo（稳定版）

(mymachine  (

(mymachine  (

(mymachine  (

(mymachine  (

(mymachine  (

 

(print  'chenbing) 

))

))

))

))

))

￥￥￥￥￥￥￥￥￥￥￥￥￥￥￥￥￥￥￥￥￥￥￥￥￥￥￥￥￥￥￥￥

#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>

#include  <math.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,FORMAL

}forth;

 

typedef struct   Type

{

enum Enum  em;

funp  f_data;

union 

{

//int i_data;

float  i_data;

//  char c_data;

char s_data[30];  

struct Type    * n_data;

} u_data;

struct Type * next;

struct WrapType *mother;

}Type;

 

 

typedef  struct WrapType

{

struct WrapType * mem_next;

Type  value;

}WrapType;

 

 

Type *global_once=NULL;

Type *global_twice=NULL;

Type  *global_null=NULL;

Type *global_lambda=NULL;

Type *global_var=NULL;

 

 

#define  NUM  1000

WrapType   *mem_manager_unused=NULL;

 

WrapType   *mem_manager_used=NULL;

WrapType   *mem_manager_used_end=NULL;

 

int  global_count=1000;     //modify  to  handle  macro  massive  character

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 *);

int object=0;

 void  count_object()

 {

printf("%d  ",object);

 }

 void  free_object();

Type*  new_object()

{

Type *result;

if(!mem_manager_unused)

{

//free_object();

mem_manager_unused=mem_manager_used;

mem_manager_used=NULL;

}

result=&(mem_manager_unused->value);

result->mother=mem_manager_unused;

mem_manager_unused=mem_manager_unused->mem_next;

result->mother->mem_next=NULL;

object++;

//count_object();

return  result;

}

 

void free_object()

{

int count=0;

WrapType  *left,*right;

left=mem_manager_used;

if(!left)

return ;

 

 

while(left->mem_next)

{

left=left->mem_next;

}

 

left=mem_manager_used;

while(left->mem_next)

{

right=left->mem_next;

left->mem_next=mem_manager_unused;

mem_manager_unused=left;

left=right;

count++;

}

mem_manager_used=NULL;

printf("%d  ",count);

}

 

void  init_object()

{

int  i=0;

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

for(i=0;i<global_count-1;i++)

{

mem_manager_unused[i].mem_next=&mem_manager_unused[i+1];

}

mem_manager_unused[global_count-1].mem_next=NULL;

}

void  *  empty2_type(void)

{

Type  *result= new_object();

result->em=INT; 

result->u_data.i_data=NULLVALUE;

return  result;

}

void  *  true_type(void)

{

Type  *result= new_object();

result->em=INT; 

result->u_data.i_data=1;

return  result;

}

void  *  empty_type(void)

{

Type  *result;

if(!global_null)

{

result= new_object();

result->em=EMPTY; 

result->u_data.i_data=NULLVALUE;

global_null=result;

return  result;

}

else

{

return global_null;

}

}

 

void * c_copy_atom(void *_right)

{ 

Type *left;

Type  *right=_right;

void *mother;

if(right->em==EMPTY)

return right;   

left= new_object()   ;

mother=left->mother;

memcpy(left,right,sizeof( Type) ); 

left->mother=mother;

return  left; 

}

void * c_cons (void * _left,void *  _right)

{ 

Type  *type_data; 

type_data= new_object()   ;

type_data->em=LIST;  

type_data->u_data.n_data=_left;

type_data->next=_right;

return  type_data; 

}

 

int  c_atom(void *);

void * c_copy_tree(void *_right)

{ 

Type  *right=_right;

if(right->em==EMPTY)

return right;

if( c_atom ( c_car (right) ) )

return  c_cons ( c_copy_atom(c_car (right)), c_copy_tree ( c_cdr (right)) );

return  

 c_cons ( c_copy_tree(c_car (right)), c_copy_tree ( c_cdr (right)) );

}

 

void  * wrap_print(void *);

void * c_copy_type(void *_right)

{

Type  *right=_right;

if(right->em==EMPTY)

return right;   

if(right->em==LIST)

return   c_copy_tree (right) ;

return  c_copy_atom (right)  ;

}

void * c_constream (void * _left,void *  _right)

{ 

Type  *type_data; 

type_data=  new_object()   ;

type_data->em=CONSTREAM;  

type_data->u_data.n_data=_left;

type_data->next=_right;

return  type_data; 

}

void  *eval (void ** );

void  *c_car (void  *);

void * c_car_address (void * _left)

{ 

Type * left=_left;

if(left->em==EMPTY)

return empty_type();

assert(left->em==LIST);  

return &(left->u_data.n_data); 

}

void * c_car (void * _left)

{ 

Type * left=_left;

if(left->em==EMPTY)

return empty_type();

assert(left->em==LIST||left->em==CONSTREAM);  //modidify at  2010.1.8  

return left->u_data.n_data; 

}

void * c_cdr (void * _left)

{  

Type * left=_left;

if(left->em==EMPTY)

return empty_type();

assert(left->em==LIST);  

return    left->next;

}

void *c_cadr(void  *_left);

void  gc_atom(void  *);

void*  left_print (void  *);

void * wrap_c_cons(void * _left)

{  

Type *left=_left;

Type  *result=  c_cons   (  c_car  (left ) , c_cadr (left) );

gc_atom (   c_cdr(left)  );

gc_atom (left);

return  result;

}

void * wrap_c_cdr (void *_left)

{

Type  *left=c_car (_left )  ;

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_atom (void *);

void  gc(void *);

int c_eq(void  *_left,void  *_right)

{

Type*left=_left;

Type  *right=_right;

int  result;

 

if(c_atom (left )&&c_atom (right) )

{

if   (!(left->u_data.i_data-right->u_data.i_data))

result=  1;

else 

result= 0;

}

else

result= 0;

 

//gc(_left);

//gc(_right);

return  result;

}

 

void * wrap_c_eq(void * _left)

{  

Type *left=_left;

return c_eq   (  c_car  (left ) , c_cadr (left) )?int_type(1.00):int_type(0);

}

void * wrap_c_atom(void * _left)

{  

Type *left=_left;

 

Type  *type_data; 

type_data=  new_object()  ;

type_data->em=INT;

type_data->u_data.i_data=

c_atom   ( left );

return  type_data;

}

void * wrap_c_list(void * _left)

{

return  _left;

}

 

int  c_not (int  i)

{

if(i==1)

return 0;

else return 1;

}

int  c_atom(void  *_left)

{

Type  *left=_left;

if(left->em==LIST)

return  0; 

return   1;

}

 

 

void * c_appdix (void * _left,void *  _right)

{

Type * left=_left;

Type * right=_right;

 

 

 

if( left->em==EMPTY)

return  c_cons (right ,empty_type() );

else

return c_cons  (  c_car ( left) , 

c_appdix ( c_cdr (left ) ,right ) );

 

}

void * c_list (void *left , ...)

{

Type * ele_left;

Type *  ele_right;

va_list ap;

ele_left=left;

ele_left=c_cons (  ele_left , empty_type()) ;

va_start(ap, left); 

 

while (1)

{ 

ele_right=va_arg(ap, void *);  

if(ele_right)

ele_left=c_appdix (  ele_left,ele_right );

else

{    

break;

} 

 

}

va_end(ap); 

return  ele_left;

}

 

//some  aux  function

void  *c_caar(void  *_left)

{

return c_car(c_car(_left));

}

void  * c_cddr(void  *_left)

{

return  c_cdr(c_cdr(_left));

}

void  *c_caddr(void  *_left)

{

return c_car( c_cddr(_left) );

}

 

void  *c_cdar(void  *_left)

{

return c_cdr(c_car(_left));

}

void *c_cadr(void  *_left)

{

return c_car(c_cdr(_left));

}

 

void  *c_cadar(void  *_left)

{

return  c_car(c_cdr(c_car(_left)));

}

void *c_cadadr(void  *_left)

{

return  c_car(c_cdr(c_car(c_cdr(_left))));

}

void *  int_type(float  i)

{

Type  *result=  new_object()  ;

result->em=INT;

result->u_data.i_data=i;

return  result;

}

void  *  set_type(Enum type)

{

Type  *result= new_object()   ;

result->em=type; 

return  result;

}

void * left_print(void *  _left)

{

Type  *left=_left;

Type  *temp; 

if(!left)

{

return empty_type();

}

if (  left->em==EMPTY)

{ 

return empty_type();

}  

else if(left->em==INT&&left->u_data.i_data==NULLVALUE)

printf("%s ","nil");

else if(left->em==FORMAL)

printf("formal ");

else if(left->em==INT)

printf("%f ",left->u_data.i_data);

else if(left->em==VAR)

printf("%s  ",left->u_data.s_data);

else if(left->em==FUN)

printf("%s   ",left->u_data.s_data);

else if(left->em==QUOTE)

printf("%s  ","quote");

else if(left->em==DEFUN)

printf("%s   ","defun");

else if(left->em==FUNCALL)

printf("%s   ","funcall");

else if(left->em==DEFMACRO)

printf("%s   ","defmacro");

else if(left->em==SETQ)

printf("%s  ","setq");

else if(left->em==SETF)

printf("%s  ","setf");

else if(left->em==IF)

printf("%s  ","if");

else if (left->em==LIST)

{

 

printf("  (  ");

for (  temp=left;  temp->em!=EMPTY ;temp= c_cdr (temp) )

{

left_print (   c_car (temp) ); 

}

printf(" ) ");

}

return  left;

}

void  * wrap_print (void *_left)

{

printf("/n");

return  left_print (_left);

}

void * right_print(void *  _left)

{

Type  *left=_left; 

if (  left->em==EMPTY)

{ 

return empty_type();

}  

else if(left->em==INT&&left->u_data.i_data==NULLVALUE)

printf("%s ","nil");

else if(left->em==INT)

printf("%d ",left->u_data.i_data);

else if(left->em==VAR)

printf("%s  ",left->u_data.s_data);

else if(left->em==FUN)

printf("%s   ",left->u_data.s_data);

else if(left->em==QUOTE)

printf("%s  ","quote");

else if(left->em==DEFUN)

printf("%s   ","defun");

else if(left->em==DEFMACRO)

printf("%s   ","defmacro");

else if(left->em==FUNCALL)

printf("%s   ","funcall");

else if(left->em==SETQ)

printf("%s  ","setq");

else if(left->em==SETF)

printf("%s  ","setf");

else if(left->em==IF)

printf("%s  ","if");

else if (left->em==LIST)

{  

right_print( c_cdr (left)  );

right_print( c_car (left)  );

}

return  left;

}

void  gc_frame(void *);

void  gc(void *);

void * wrap_left_print(void *  _left)

{

Type *result;

printf ("  /n  ");

result=left_print( c_car (_left) );   //modify by chebing  2011.3.11

 

//gc(_left);

return  result;

}

 

void * original_big(void * _left)

{ 

int  result;

Type  *left=c_car (_left ) ,*right=c_cadr (_left) ;

result=(( Type *)left)->u_data.i_data-(( Type *)right)->u_data.i_data;

gc(_left);

return result>0?int_type(1):int_type(0);

}

void * original_small(void * _left)

{ 

//int  result;

float  result;

Type  *left=c_car (_left ) ,*right=c_cadr (_left) ;

result=(( Type *)left)->u_data.i_data-(( Type *)right)->u_data.i_data;

return result<0?int_type(1):int_type(-1);

}

void * original_mul(void * _left)

{ 

Type *  result=new_object () ;

Type  *left=c_car (_left ) ,*right=c_cadr (_left) ;

result->em=INT;

result->u_data.i_data=(( Type *)left)->u_data.i_data*(( Type *)right)->u_data.i_data;

return result;

}

void * original_divi(void * _left)

{ 

Type *  result=new_object () ;

Type  *left=c_car (_left ) ,*right=c_cadr (_left) ;

result->em=INT;

result->u_data.i_data=(( Type *)left)->u_data.i_data/(( Type *)right)->u_data.i_data;

return result;

}

void * original_add1(void * _left)

{ 

Type  *left=_left;

Type  *result= new_object()  ; 

result->em=INT;

result->u_data.i_data=(( Type *)left)->u_data.i_data+1;

return  result;

}

void * original_sin(void * _left)

{ 

Type  *left=_left;

Type  *result= new_object()  ; 

result->em=INT;

result->u_data.i_data=sin ( (( Type *)c_car(left))->u_data.i_data );

return  result;

}

void * original_cos(void * _left)

{ 

Type  *left=_left;

Type  *result= new_object()  ; 

result->em=INT;

result->u_data.i_data=cos ( (( Type *)c_car(left))->u_data.i_data );

return  result;

}

void * original_mod(void * _left)

{ 

int left=(( Type *)c_car(_left))->u_data.i_data;

int  right=(( Type *)c_cadr(_left))->u_data.i_data;

Type  *result= new_object()  ; 

result->em=INT;

result->u_data.i_data=left%right;

return  result;

}

void * original_abs(void * _left)

{ 

Type  *left=_left;

Type  *result= new_object()  ; 

result->em=INT;

result->u_data.i_data=fabs ( (( Type *)c_car(left))->u_data.i_data );

return  result;

}

void  gc(void *  _left);

void * original_add(void * _left)

{ 

Type *temp;

Type  *left=_left;

Type  *result=  new_object()   ; 

result->em=INT;

result->u_data.i_data=0;

for(temp=left;temp->em!=EMPTY;temp=c_cdr (temp) )

result->u_data.i_data+=(( Type *)c_car(temp))->u_data.i_data;

gc(_left);

return  result;

}

void * original_minus(void * _left)

{ 

Type *temp;

Type  *left=_left;

Type  *result=  new_object()   ; 

result->em=INT;

result->u_data.i_data=(( Type *)c_car(left))->u_data.i_data;

for(temp=c_cdr (left );temp->em!=EMPTY;temp=c_cdr (temp) )

result->u_data.i_data-=(( Type *)c_car(temp))->u_data.i_data;

//left_print(_left);

gc(_left);

return  result;

}

void * original_minus1(void * _left)

{ 

Type  *left=_left;

Type  *result=  new_object()   ; 

result->em=INT;

result->u_data.i_data=(( Type *)left)->u_data.i_data-1;

return  result;

}

 

typedef  struct Fun_info

{

char  name[20];

funp  address;

}Fun_info;

typedef  struct Type_info

{

char  name[20];

Enum  type;

}Type_info;

 

void  *c_defun (void *name,void *arg,void *expr ,void **mem)

{

*mem=c_cons ( c_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_left_print},{"abs",original_abs},{"cos",original_cos},{"mod",original_mod},

{"1+",original_add1},{"1-",original_minus1},{"+",original_add},{">",original_big},{"sin",original_sin},

{"-",original_minus},{"cons",wrap_c_cons},{"/",original_divi},{"<",original_small},{"*",original_mul},

{"car",wrap_c_car},{"cdr",wrap_c_cdr},{"cadr",wrap_c_cadr},{"caddr",c_caddr},{"atom",wrap_c_atom},

{"list",wrap_c_list},{"eq",wrap_c_eq},{"",0}};

 

Type_info orignal_type[]={{"constream",CONSTREAM},{"para",PARA},

{"tail",TAIL},{"symbol",SYMBOL},{"defun",DEFUN},{"defmacro",DEFMACRO},{"end",END},

{"if",IF},{"progn",PROGN},{"setf",SETF},{"get",GET},{"pop",POP},{"gettop",GETTOP},{"nothing",NOTHING},

{"setq",SETQ},{"cond",COND},{"push",PUSH},{"funcall",FUNCALL},{"setret",SETRET},{"popret",POPRET},

{"lambda",LAMBDA},{"formal",FORMAL},{"callcc",CALLCC},{"",0}};

 

void  *  fun_type(char *name)

{ 

int  sign;

Type  *result= new_object()   ;

result->em=FUN;

sign=0;

 

while(1)

{

if(!strcmp("",orignal_fun[sign].name))

{

break;

}

else if(!strcmp(name,orignal_fun[sign].name))

{

result->f_data=orignal_fun[sign].address;

break;

}         

else

sign++;

}

strcpy(result->u_data.s_data,name);

return  result;

}

//similar  to  the  macro  dispatch

void *  eval(void  * _left,void ** _env) ;

void * eval_cond (void  *_left,void **_env)

{

Type *left=_left;

if (  left->em==EMPTY)

return empty_type();

if(   c_atom (  c_caar (left) ))

{

if(c_not( c_eq (  c_caar (left) ,int_type(0) ) ))

return  eval  ( c_cadar (left ),_env ) ;   

return  eval_cond ( c_cdr (left) ,_env);

}

else

{

if(c_not( c_eq ( eval ( c_caar (left) ,_env) ,int_type( 0) ) ))

return  eval  ( c_cadar (left ) ,_env) ;

return  eval_cond ( c_cdr (left) ,_env);

}

}

void*  left_print  (void  *);

void * eval_progn (void  *_left,void **_env)

{

Type  *left=_left;

if (  (( Type *)c_cadr (left))->em==EMPTY)

return  eval  ( c_car  (left ),_env ) ;

else

{

eval  (c_car  (left) ,_env) ; 

return eval_progn  (c_cdr (left ),_env );

} 

}

 

void *  c_bindvar_help(void *name,void *value);

void * c_set_global_var_value (void *name,void  *value  ) 

{

Type  *result=  new_object()   ;

global_var=c_appdix ( c_list( c_bindvar_help(name,value) ,0), global_var);

return  name;

}

void * eval_setq (void  *_left,void **_env)

{

Type  *left=_left;

if  ( ((  Type *)c_cadr ( c_cdr (left )))->em==EMPTY)

{

return c_set_global_var_value (  c_car  (left ), eval ( c_cadr (left ),_env ) );

}

else

{

c_set_global_var_value (  c_car  (left ),eval ( c_cadr (left ),_env )  );

return eval_setq  (  c_cddr (left),_env );

}

}

void * eval_setf (void  *_left,void  **_env)

{

/*

Type  *left=_left;

if  ( ((  Type *)c_cadr ( c_cdr (left )))->em==EMPTY)

{

return c_bindvar_ex (  c_car  (left ),eval ( c_cadr (left ) ,_env) );

}

c_bindvar_ex (  c_car  (left ),eval ( c_cadr (left ) ,_env) );

return eval_setf  (  c_cddr (left) ,_env);

*/

return  NULL;

}

 

void  *var_type (char * name)

{ 

Type  *result=  new_object()   ;

result->em=VAR;

strcpy(result->u_data.s_data,name);

return  result;

}

void *  c_bindvar_help(void *name,void *value)

{

return   c_cons (c_copy_atom( name )  ,c_cons (  value  ,empty_type ()  )   );

//return   c_cons (name  ,c_cons (value ,empty_type ()  )   );

}

void  gc_atom(void *);

void * c_bindvar (void *_left,void *_right)

{

Type  *left=_left,*right=_right,*result;

if(left->em==EMPTY)

{

return  empty_type();

}

else

{

result=c_cons ( c_bindvar_help ( c_car (left),c_car (right) ) ,

c_bindvar  ( c_cdr (left),c_cdr (right)  ) 

);

return  result;

}

}

 

 

 

void  *c_find_defun_arg(void *name,void *mem)

{

Type  *_env=mem;

Type  *label;

while(_env)

{

label=c_car ( 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 *_right)

{

Type *left=_left,*right=_right;

Type  * t;

if(right->em==EMPTY)

return  NULL;

t=c_car (right) ;

if(!strcmp(left->u_data.s_data, ( (Type *)c_car (t))->u_data.s_data))

{

return     c_cadr (t ) ;

}

else

{

return  c_find_var_value_help (left, c_cdr  (right)  );

}

}

void  *c_find_var_value2 (void *_left,void  *env) 

{

Type  *left=_left,*result ,*m_env,*_env;

Type *__env=env;

while(__env->em!=EMPTY)

{

_env=c_car (__env);

while (_env->em!=EMPTY)

{

m_env=c_car (_env) ;

while(m_env->em!=EMPTY)

{

if(result=c_find_var_value_help (left,  c_car ( c_car (m_env) )   )  )

{

 

return  result;

}

m_env=c_cdr (m_env) ;

}

_env=c_cdr (_env);

}

__env=c_cdr (__env);

}

return  NULL;

}

 

 

void  *c_find_var_value (void *_left,void  *_env) 

{

Type  *left=_left,*env=_env,*result=NULL;

while(env->em!=EMPTY)

{

if(result=c_find_var_value_help (left,   c_car (env) )     )

return  result ;     

env=c_cdr (env) ;

}

return  NULL;

}

 

void  *sub_expr (void *_left,void *_env)

{

Type *left=_left,*temp; 

if(left->em==EMPTY)

return  empty_type();

if(   ((Type*)c_car (_left))->em==VAR) 

{

temp=c_find_var_value( c_car(left ) ,_env);

if(!temp)

{

return c_cons (c_car (_left ) , sub_expr (c_cdr (_left) ,  _env )  );

}

else

{

return c_cons ( temp  , sub_expr (c_cdr (_left) ,  _env )  );

}

 

}

else if(   ((Type*)c_car (_left))->em==LIST) 

{

return c_cons ( sub_expr (c_car (_left) ,  _env )

, sub_expr (c_cdr (_left) ,  _env )  ); 

}

else

{

return c_cons (c_car (_left ) , sub_expr (c_cdr (_left) ,  _env )  ); 

}

}

 

 

void * random_name ()

{

int i=0;

char  name[8]="/0";

 

for(i=0;i<7;i++)

{

name[i]=rand()%26+'a';

}

return  var_type(name);

 

}

/*

Type * out=NULL;

jmp_buf global ;

wrap_longjmp (void  *_temp,void *_result)

{

jmp_buf  *temp_buf;

Type * temp=_temp;

global_jmpbuf= c_cdr(global_jmpbuf );

temp_buf=c_car (temp );

out= _result;

longjmp ( global ,out);

}

void * wrap_setjmp (void  *left,void  **_env)

{

int  retn;

jmp_buf  *temp_buf=(jmp_buf*)malloc  (sizeof (jmp_buf) );

 

if(setjmp(global))

{ 

return  out;

}

else

{

((Type*) temp_buf)->em=JMPBUF;

global_jmpbuf=c_cons ( temp_buf,global_jmpbuf);

return wrap_eval ( c_cons ( 

eval ( c_cadr (left)  ,_env) , c_cons (global_jmpbuf,empty_type() ) 

) 

,_env ) ;

}

}

*/

void  *add_quote (void  *_left)

{

Type  *left=_left;

if(left->em==EMPTY)

{

return  empty_type();

}

else

{

return c_cons (   c_list (  set_type(QUOTE), c_car (left) ,0) ,

add_quote ( c_cdr (left) )

);

}

}

typedef  struct  Wrap_struct

{

void  *_left;

void  **_env;

int  * address;

int  count;

}Wrap_struct;

int  _signal[10]={0};

void  eval_special (void  *_struct)

{

Type *result=NULL;

Wrap_struct  *w=_struct;

w->address[w->count]=1;

result=eval  (w->_left,w->_env);

printf("/n/n");

left_print(result);

w->address[w->count]=0;

}

void *  eval_para(void  *_left,void **_env);

void hand_thread (void *_left,void **_env,int  _count)

{

unsigned pid;

Wrap_struct  ww;

Type  *ee;

Type *left=_left;

if (left->em==EMPTY)

{

;

}

else

{

ee=new_object() ;

ee=*_env;

ww._left=c_car(left);

ww._env=&ee;   

ww.count=_count;

ww.address=_signal;

_beginthreadex(NULL,0, 

(unsigned (__stdcall *) (void *))eval_special,(void *)&ww ,0,&pid);

hand_thread(  c_cdr (left)  ,_env ,_count+1);

}

}

void ** c_bindvars(void *_left,void * _right,void **_env);

void  c_unbindvars(void **_env);

void *  eval_para_delay(void  *_left,void **_env);

void  compare(void  *_left,void *_right);

void  count_gc();

void *  eval(void  *_left,void **_env)

{

 

 

Type  *temp,*right,*tempname,*tempvalue,*result;

Type  *left=_left; 

Type  *head=NULL;

int  *label,count=0;

label:

if(left->em==EMPTY)

return  empty_type();

else if (left->em==FORMAL)

return  left;

else if(left->em==VAR )

{

if(temp=c_find_var_value(left ,*_env) )

{

if(temp->em==LIST&&!strcmp( ((Type*)c_car(temp))->u_data.s_data,"delay")!=0)

{

right=*_env;

    result= eval ( c_cons( set_type(FUNCALL),c_cdr(temp)) ,&right);   //add  by  chenbing  2011.3.11

compare(right,*_env);

return result;

}

else

{

return  c_copy_type( temp );

}

}

else

{

return  left;

}

}

else if (left->em==INT&&left->u_data.i_data==NULLVALUE)

return  empty_type();

else if (left->em==INT)

return  c_copy_atom(left) ;    

assert(left->em==LIST);

head=c_car (left ); 

switch(head->em)

{

case  FORMAL:

return c_cons(head,  eval_para ( c_cdr (left) ,_env )  );

break;

case PARA:

hand_thread ( c_cdr (left) ,_env ,0 );

while(count>=0)

{

count++;

}

while(1)

{

label=_signal;

while((!(*label))&&(label-_signal<10))

{

label++;

}

if(!(label-_signal-10))

{

break;

}

}

return  empty_type();

break;

case  EMPTY:

return  empty_type();

case  JMPBUF:

return  left;

case   SYMBOL:

return eval ( eval(c_cadr (left ),_env) ,_env);

break;

case  CALLCC:  

   

break;

case  FUNCALL:

temp= eval(c_cadr (left ),_env);

right=c_lambda_get (temp)  ;

if(!right)

right=*_env;

//left= eval_para ( c_cddr (left) ,_env );

tempname=c_find_defun_arg(temp,global_once);

tempvalue=eval_para_delay( c_cddr (left ),_env ); 

left=c_find_defun_expr(temp,global_once);

_env=c_bindvars( tempname, tempvalue,&right );

goto label; 

//c_unbindvars( &right);

return  result;

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:

return  eval_setq ( c_cdr (left),_env ) ;

break;

case  SETF:

return eval_setf ( c_cdr (left),_env ) ;

break;

case IF:

/*

if (c_eq ( eval (   c_cadr ( left ) ,_env ) ,  int_type(1) ) )

return  eval ( c_caddr ( left) ,_env)  ;

else 

return eval  (c_cadr (c_cddr ( left ) ),_env);

*/

//if (  eval (   c_cadr ( left ) ,_env )  )

if (c_eq (   eval (   c_cadr ( left ) ,_env ) ,  int_type(0) ) )    //modify  according to the macro application.

{

left=c_cadr (c_cddr ( left ) );

goto label;

}

else

{

left=c_caddr(left);

goto label;

}

break;

case PROGN:

left=c_cdr(left);

while((( Type *)c_cadr (left))->em!=EMPTY)

{

temp=*_env;

eval  (c_car  (left) ,&temp) ;

count_object();

count_gc();

compare ( temp ,*_env );

left=c_cdr(left);

}

left=c_car(left);

goto label;

/*

Type  *left=_left;

if (  (( Type *)c_cadr (left))->em==EMPTY)

return  eval  ( c_car  (left ),_env ) ;

else

{

eval  (c_car  (left) ,_env) ; 

return eval_progn  (c_cdr (left ),_env );

} 

*/

//return eval_progn ( c_cdr  (left),_env);

break;

case QUOTE2:

return   eval_simple ( c_cadr (left),_env ) ;

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,NULL);

return  c_copy_atom(temp );

break;

case VAR:

if(temp=c_find_var_value ( head, *_env) )

{

if(temp->em==LIST&&!strcmp( ((Type*)c_car(temp))->u_data.s_data,"delay")!=0)

{

temp= eval ( c_cons( set_type(FUNCALL),c_cdr(temp)) ,_env);   //add  by  chenbing  2011.3.11

}

else

{

;

}

if((tempname=c_find_defun_arg(temp,global_once)))

{

return  eval (  c_cons ( set_type(FUNCALL) , left) ,_env) ;

}    

 

if((( Type *) c_caddr ( left))->em ==EMPTY )

return c_cons (temp, c_cons (eval  (  c_cadr (left),_env ),empty_type())   );

return c_cons( temp ,eval ( c_cdr (left),_env ));

}

else

{

/*

temp=c_car(left);

tempname=c_find_defun_arg(temp,global_once);

//tempvalue=eval_para_delay( c_cdr (left ),_env ); 

tempvalue=eval_para( c_cdr (left ),_env );

_env=c_bindvars( tempname, tempvalue,_env );

left=c_find_defun_expr(temp,global_once);

goto label;

*/

return wrap_eval (left,_env);

}

break; 

case  DEFMACRO:

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:

temp= eval(c_car (left ),_env);

if((tempname=c_find_defun_arg(temp,global_once)))

{

return  eval (  c_cons ( set_type(FUNCALL) , left) ,_env) ;

}    

printf("/n/n");

return  left;   

//return  eval (head ,_env );

break;

}

return  NULL;

 

}

/*

case  LIST:

if((( Type *) c_caddr ( left))->em ==EMPTY )

return c_cons (eval  ( c_car  (left ),_env ), 

c_cons (eval  (  c_cadr (left) ,_env),empty_type())   );

return   c_cons (eval  ( c_car  (left ) ,_env), eval (c_cdr (left),_env ) );

break;  

*/

 

void ** c_bindvars(void *_left,void * _right,void **_env)

{

Type *left=_left;

Type *right=_right;

if(left->em!=EMPTY)

{

*_env=c_cons( c_bindvar( left , right ) ,*_env );

gc_frame(right);

return  _env;

}

else

{

return  _env;

}

}

int  gcc=0;

void  count_gc()

 {

printf("%d  ",gcc);

 }

void gc_atom(void *_left)

{

Type *left=_left;

WrapType *gc=NULL;

int  count=0;

 

left=_left;

gc=left->mother;

memset(left,0,sizeof (Type) );

gc->mem_next=NULL;

 

 

if(!mem_manager_used)

{

mem_manager_used=gc;

mem_manager_used_end=mem_manager_used;

}

else

{

assert(gc);

mem_manager_used_end->mem_next=gc;

mem_manager_used_end=gc;

}

/*

gc=mem_manager_used;

while(gc->mem_next)

{

printf("%x  ",gc);

count++;

gc=gc->mem_next;

}

printf("%d  ",count);

 

*/

gcc++;

//count_gc();

}

 

void  gc_frame (void  *_left)

{

Type *left=_left;

Type *right=c_cdr(left);

if(left->em==EMPTY)

return ;

else

{

//left_print(left);

gc_atom(left);

gc_frame(right);

}

}

 

void  gc(void *  _left)

{

Type  *left=_left,*right;

Type  *temp; 

if(!left)

{

return ;

}

if (  left->em==EMPTY)

{ 

return ;

}  

else if(left->em==INT&&left->u_data.i_data==NULLVALUE)

gc_atom(left);

else if(left->em==FORMAL)

gc_atom(left);

else if(left->em==INT)

gc_atom(left);

else if(left->em==VAR)

{

/*

temp=c_find_defun_arg(left,global_once);

if(temp)

{

gc(temp);

}

*/

 

gc_atom(left);

}

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)

gc_atom(left);

else if (left->em==LIST)

{

gc(c_car(left));

gc(c_cdr(left));

gc_atom(left);

}

return  left;

}

 

void  c_unbindvar_help(void *_left)

{

Type  *left=_left,*result;

result=c_cadr (left);

 

if(result->em==LIST)

gc_frame (result);

else

gc_atom(result);

}

void  c_unbindvar(void *_left)

{

Type  *left=_left,*temp;

if (left->em==EMPTY)

return ;

else

{

c_unbindvar_help(c_car (left) );  //consist with the inital decision

 

temp=c_cdr(left);

gc_frame (c_car (left) );

//gc_atom (left);

 

c_unbindvar( temp);  //reason as  above

}

}

void  c_unbindvars(void **_env)

{

Type *right=c_cdr(*_env);

//compare(*_env,right );

gc(c_car(*_env));

 

gc_atom(*_env);

 

*_env=right;

//printf("/n");

//left_print(*_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  compare(void  *_left,void *_right)

{

Type *left=_left,*right=_right,*temp;

if(!(left-right) )

return ;

else

{

/*

void  c_unbindvars(void **_env)

{

Type *result= c_car (*_env ) ;

result=c_cdr (result );

*_env=c_cons (result ,  c_cdr (*_env ) );

}

*/

c_unbindvar (c_car (left) );

//aux function below

gc_frame (c_car (left) );

temp=c_cdr(left);

gc_atom (left);

//

compare(temp,right);

}

 

}

void *  eval_para(void  *_left,void **_env)

{

Type *temp,*env=*_env;

Type *left=_left;

if (left->em==EMPTY)

return  empty_type();

else

{

temp=eval( c_car (left),&env);

compare ( env ,*_env );

return c_cons ( temp ,eval_para ( c_cdr (left) ,_env ) );

}

/*

return c_cons (

eval (c_car (left) ,_env),

eval_para ( c_cdr (left) ,_env )

);

*/

 

}

void *  wrap_eval(void  *_left,void **_env)

{

Type *tempname;

Type *tempvalue;

Type *result=NULL;

Type  *left=_left;  

Type  *head=NULL,*temp;

 

 

if(left->em==VAR )

return   c_find_var_value(left,*_env)  ;

else if (left->em==INT)

return  left ;

assert(left->em==LIST);

head=c_car (left );

if((tempname=c_find_defun_arg(head ,global_twice)))

{  

tempvalue=c_copy_type (  c_cdr (left )  );    //modify by chenbing   2011.4.7

 //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)

)  ;

//compare(temp,*_env);

c_unbindvars( _env );

//free_object();

 

//tempvalue=eval_para_delay( c_cdr (left ),_env );

/*

tempvalue=eval_para( c_cdr (left ),_env );  

result=  eval  ( c_find_defun_expr(head,global_once),

c_bindvars( tempname, tempvalue,_env)

)  ;

//compare (*_env, c_cdr (*_env ) );

c_unbindvars( _env );

*/

}    

else

{

result=  eval  (  left ,_env)  ; 

}

return  result;

}

static enum tokens token; /* current input symbol */

static int number;  /* if NUMBER: numerical value */

static char  name[20]; 

static  char alpha_ex[]="abcdefghijklmnopqrstuvwxyz_!";

int isalpha_ex(char *test)

{

int  i=0;

for(i=0;alpha_ex[i]!='/0';i++)

if(alpha_ex[i]==test)

return  1;

return  0;

 

}

static enum tokens scan (const char * buf)

/* return token = next input symbol */

{ 

static const char * bp;    

int sign=0;

memset(name,0,sizeof(name));

 

if (buf)

bp = buf;   /* new input line */

 

 

 

while (isspace(* bp & 0xff))

++ bp;

if (isdigit(* bp & 0xff) || * bp == '.')

{ 

errno = 0;

token = NUMBER, number = strtod(bp, (char **) & bp);

 

}

else if (isalpha_ex(* bp & 0xff) || * bp == '.')

{

errno = 0;

token = NAME; 

while(isalpha_ex(* bp & 0xff))

name[sign++]=*bp++;

}

else

token = * bp ? * bp ++ : 0;

return token;

}

funp select_fun (void *_name)

{

intsign=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)

{

intsign=0;

while(1)

{

if(!orignal_fun[sign].address)

{

return  NULL;

}

else if(address==orignal_fun[sign].address)

{

return orignal_fun[sign].name;

break;

}         

else

sign++;

}

}

Enum select_type (void *_name)

{

char  *name=_name;

int sign=0;

while(1)

{

if(!strcmp("",orignal_type[sign].name))

{

return (Enum) NULL;

}

else if(!strcmp(name,orignal_type[sign].name))

{

return orignal_type[sign].type;

break;

}         

else

sign++;

}

}

char * select_type2 (Enum  type)

{

 

int sign=0;

while(1)

{

if(!orignal_type[sign].type)

{

return  NULL;

}

else if(type==orignal_type[sign].type)

{

return orignal_type[sign].name;

break;

}         

else

sign++;

}

}

static void * factor (void)

{ 

Type  *result;

Type * ele_left;

Type *  ele_right;

char temp[2]="/0";

funp  pfun;

Enum  type;

scan(0);

switch (token) 

{

case  NAME: 

if ( pfun=select_fun (name) )

{

result=  new_object ();

result->em=FUN;

result->f_data=pfun;

strcpy(result->u_data.s_data,name);

return  result;

}

else if (type=select_type (name) )

{

return  set_type (type );

}

else if(!strcmp("nil",name))

{

return  empty2_type();

}

else if(!strcmp("t",name))

{

return  true_type();

}

else

{

return var_type (name);  

}

case NUMBER:

return int_type (number);

break;

case '(': 

ele_left=factor();

if(!ele_left)

{

return  c_cons (empty_type(),empty_type());

}

ele_left=c_cons (  ele_left , empty_type()) ;  

 

while (1)

{ 

ele_right=factor();  

if(ele_right)

{

ele_left=c_appdix (  ele_left,ele_right );

}

else

{    

break;

} 

 

}

return  ele_left;

break;

case ')':

return NULL;

break;

case  '/'':

return  c_list ( set_type(QUOTE),factor(),0 );

case  '/`':

return  c_list ( set_type(QUOTE2),factor(),0 );

case  '/,':

return   set_type(EVAL);

default:

{

temp[0]=(char)token;

return  fun_type( temp);

}

 

/*

case '+':

return fun_type("+");

case '/':

return fun_type("/");

break; 

case '*':

return fun_type("*");

break;  

case '>':

return fun_type(">");

break; 

case '<':

return fun_type("<");

case '-':

return fun_type("-");

break;

*/

 

}

return NULL;

}

static jmp_buf onError;

 

int main (void)

{ 

int  sign;

Type * ele_left;

Type *  ele_right; 

FILE *in;

volatile int errors = 0;

 

char buf [8*BUFSIZ];

Type  *m_env;

srand (time (NULL) ); 

init_object();

 

m_env=empty_type();

global_lambda=empty_type();

global_var=empty_type();

 

 

/*

for(i=0;i<MAX;i++)

{

compi[i].address=0;

}

*/

 

if (setjmp(onError))

++ errors;

 

//advance  high-tech

 

ele_left=c_list ( 

      set_type(DEFMACRO),var_type("demo"), c_list( var_type("expr"),0),

  c_list (  fun_type("print") ,var_type("expr"),0) ,

      0);    

wrap_eval ( ele_left,&m_env) ;

ele_left=c_list(

         set_type(DEFMACRO),var_type("mymachine"), c_list( var_type("exprs"),0),

 c_list( set_type(QUOTE2),

         c_list ( set_type(IF),  set_type(EVAL), 

          c_list( fun_type("eq"), var_type("exprs"),empty2_type(),

  0),

  empty2_type(),

  c_list(set_type(PROGN),

                        c_list(fun_type("print"),

c_list( var_type("demo"), set_type(EVAL),

             c_list( fun_type("car"),var_type("exprs"),

 0),

0),

0),

c_list(var_type("mymachine"),set_type(EVAL),

              c_list( fun_type("cdr"),var_type("exprs"),

  0),

0),

0),

0),

0),

0);

 

wrap_eval ( ele_left,&m_env) ;

 

//global_jmpbuf=empty_type(); 

sign=0;

in=fopen("c://test.txt","r");

while(1)

{

buf[sign]=fgetc(in);

if(feof(in))

break;

sign++;

}

 

scan(buf);

while (token== '(')

{  

 

ele_left=factor();

ele_left=c_cons (  ele_left , empty_type()) ;  

 

while (1)

{ 

ele_right=factor();  

if(ele_right)

ele_left=c_appdix (  ele_left,ele_right );

else

{ 

left_print(ele_left);

//   right_print(ele_left);

count_object();

   count_gc();

left_print(m_env);

//gc  ( left_print  ( wrap_eval ( ele_left,&m_env)  ) );

 

gc  ( left_print  ( wrap_eval ( c_list ( var_type("mymachine"),c_list (ele_left,0),0) ,&m_env)  ) );

 

left_print(m_env);

printf("/n/n");

//   right_eval ( ele_left)  ; 

//   right_print  ( stack_pop() );

/*

printf(  "  /n  ");

temp=right_compile(c_cons( ele_left,empty_type() )  ,-99 )  ; 

if( ((Type *) c_car (ele_left ) )->em!=DEFUN)

{

 

//  right_interpret (temp);

// serial(temp);

// right_interpret (  unserial()  );    

right_install (temp);

}

else

{

for(i=0;i<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);

}