PI

(defun  fixpoint  ( x  y)

 

(funcall   y    (funcall  x  x  y) )

 

)

 

(setq  fun (fixpoint  'fixpoint

(lambda (s)   

(lambda ( f check init result)

(if  (funcall check  (funcall f  init) init )

       result

     (progn

     (print init)

     (print  result)

     (funcall   s   f   check   (funcall f  init) (+ result init) )

     )

)

)

)

)

)

 

(-    0   200)

 

 

(funcall  fun  (lambda (x) (if (eq (mod (/  (+ (/  1 (abs  x) )  1 ) 2) 2) 0) 

                            (/  1 (+ 2 (/  1 (abs  x) ) ) ) 

                           (-  0  (/  1 (+ 2 (/  1 (abs  x) ) ) ))) )                          

      (lambda (x y)(if (<  (abs (-  x  y))  (/ 1  1000) ) t  nil))  1  0)

 

 

 

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

}Type;

 

 

typedef  struct WrapType

{

struct wrapType * next;

Type  value;

}WrapType;

 

 

Type *global_once=NULL;

Type *global_twice=NULL;

Type  *global_null=NULL;

Type *global_lambda=NULL;

 

 

#define  NUM  1000

WrapType   *mem_manager_unused=NULL;

WrapType   *mem_manager_used=NULL;

int  global_count=2000000;

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

result=&mem_manager_unused->value;

mem_manager_unused=mem_manager_unused->next;

mem_manager_used;

 

return  result;

}

Type*  init_object()

{

int  i=0;

Type *result;

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

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

{

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

}

mem_manager_used=(Type *)malloc  (global_count  *sizeof (WrapType ) );

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

{

mem_manager_used[i].next=&mem_manager_used[i+1];

}

}

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

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 * 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},{"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  ,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() ) ) ;

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

}

else

{

c_set_global_var_value (  c_car  (left ),eval ( c_cadr (left ),_env )  ,  _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_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=&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 *  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)

{

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

result=  eval  ( c_find_defun_expr(temp,global_once),

c_bindvars( tempname, tempvalue,&right )

)  ;

c_unbindvars( &right);

return  result;

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:

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 (c_eq ( eval (   c_cadr ( left ) ,_env ) ,  int_type(1) ) )

{

left=c_caddr(left);

goto label;

}

else

{

left=c_cadr (c_cddr ( left ) );

goto label;

 

}

break;

case PROGN:

left=c_cdr(left);

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

{

eval  (c_car  (left) ,_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  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;

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

Type *left=_left;

if (left->em==EMPTY)

return  empty_type();

else

{

temp=eval( c_car (left),_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;

 

 

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)

{

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;

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(">");

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

}