poly.c

poly.c

/*  (simple Scheme interpreter)
written by kenichi sasagawa 2011/12start

*/ 

#include <stdio.h>
#include <string.h>
#include <stdlib.h>
#include <ctype.h>
#include <setjmp.h>
#include <windows.h>
#include <signal.h>
#include "poly.h"

cell memory[CELLSIZE];
cell argstk[STACKSIZE];
token stok = {GO,OTHER};
jmp_buf buf,cont;

void main(void) {
	printf("educational Scheme system Poly Ver0.03 (written by sasagawa888)\n");
    initcell();
    initsubr();
    int ret = setjmp(buf);
        
    repl:
	
    if(ret == 0)
    	while(1){
        	freestack();
			printf("Poly> "); fflush(stdout); fflush(stdin);
    		readstk();
            evalstk(makeNIL());
            printstk();
            printf("\n"); fflush(stdout);
        }
    else
    	if(ret == 1){
        	ret = 0;
            goto repl;
        }
        else
    		return;
}

//-------デバッグ用------------------    
void cellprint(int addr){
	switch(GET_FLAG(addr)){
    	case FRE:	printf("FRE "); break;
        case USE:	printf("USE "); break;
    }
	switch(GET_TAG(addr)){
    	case EMP:	printf("EMP "); break;
        case INTN:	printf("INT "); break;
        case FLTN:	printf("FLT "); break;
        case SYM:	printf("SYM "); break;
        case LIS:	printf("LIS "); break;
        case BOL:	printf("BOL "); break;
        case BIG:	printf("BIG "); break;
        case RAT:	printf("RAT "); break;
        case ADDR:	printf("ADDR "); break;
        case SUBR:	printf("SUBR "); break;
        case SYNT:	printf("SYMT "); break;
        case CLOS:	printf("CLOS "); break;
    }
    printf("car=%d ", GET_CAR(addr));
    printf("cdr=%d ", GET_CDR(addr));
    printf("real=%d ", GET_BIND(addr));
    printf("imag=%d ", GET_IMAG_INT(addr));
    printf("env=%d ", GET_ENV(addr));
    printf("name=%s \n", GET_NAME(addr));
}   

//ヒープダンプ	
void memorydump(int start, int end){
	int i;
    
    for(i=start; i<= end; i++){
    	printf("%d ", i);
    	cellprint(i);
    }
}


//arglistダンプ
void argstkdump(int start, int end){
	int i;
    
    for(i=start; i<= end; i++){
    	printf("addr = %d  ",i);
        printf("store = %d  \n",argstk[i]);
    }
}

//---------cell操作---------------------
void initcell(void){
	int addr,addr1;
    
    for(addr=0; addr <= HEAPSIZE; addr++){
    	memory[addr].flag = FRE;
        memory[addr].cdr = addr+1;
    }
    H = 0;
    F = HEAPSIZE;
    
    //0番地はnil、環境レジスタを設定する。初期環境
    E = makeNIL();
    E = cons(cons(makesym("#t"),makebool("#t")),E);
    E = cons(cons(makesym("#f"),makebool("#f")),E);
	
    A = 0;
    S = PALASTK;
    P = CONTSTK;
}

int freshcell(void){
	int res;
    
    res = H;
    H = memory[H].cdr;
    SET_CDR(res,0);
	F--;
    return(res);
}

//スタックの文字列メモリの解放
void freestack(void){
	int i;
    
    for(i=CONTSTK; i<=CELLSIZE; i++){
    	free(memory[i].name);
        memory[i].name = NULL;
    }
}

//ｘからｙへコピー
void copycell(int x, int y){
switch(GET_TAG(x)){
    	case INTN: {SET_TAG(y,INTN);
        			SET_REAL_INT(y,GET_REAL_INT(x));
                    break;}
        case SYM:  {SET_TAG(y,SYM);
        			SET_NAME(y,GET_NAME(x));
                    break;}
        case LIS:  {SET_TAG(y,LIS);
        			SET_BIND(y,GET_BIND(x));
                    break;}
        case BOL:  {SET_TAG(y,BOL);
        			SET_NAME(y,GET_NAME(x));
                    break;}
        case SUBR: {SET_TAG(y,SUBR);
        			SET_BIND(y,GET_BIND(x));
                    break;}
        case CLOS: {SET_TAG(y,CLOS);
        			SET_BIND(y,GET_BIND(x));
                    break;}
    	}
}
        			
int makeint(int intn){
	int addr;
    
    addr = freshcell();
    SET_TAG(addr,INTN);
    SET_REAL_INT(addr,intn);
    return(addr);
}

int makesym(char *name){
	int addr;
    
    addr = freshcell();
    SET_TAG(addr,SYM);
    SET_NAME(addr,name);
    return(addr);
}

//空リストを作る。Schemeでの空リストはリストなので注意。
int makeNIL(void){
	int addr;
    
    addr = freshcell();
    SET_TAG(addr,SYM);
    SET_NAME(addr,"nil");
    return(addr);
}

int makeclosure(void){
	int addr;
    
    addr = freshcell();
    SET_TAG(addr,CLOS);
    return(addr);
}


int makebool(char *name){
	int addr;
    
    addr = freshcell();
    SET_TAG(addr,BOL);
    SET_NAME(addr,name);
    return(addr);
}

//----------環境の操作-------------------------
// ((x . v1)(y . v2) ...) についてcontスタックから値を入れ替える。
//必ずsymは存在しているという前提
void bindsym(int sym, int env){
    popcont(assoc(sym,env));	
}
//lambdaの中にlambdaがあって環境に追加するときに使う。
//同じ変数名があったとしても書き変えない。
int assocsym(int sym, int env){
	int res;
    
	res = cons(cons(sym,makeNIL()),env);
    bindsym(sym,res);
    return(res);
}

//環境に既にあればそれに束縛し、なければ新たな束縛を作る。
int definesym(int sym, int env){
	if(findsym(sym,env)){
    	bindsym(sym,env);
        return(0);
    }
    else
    	return(assocsym(sym,env));
}

//環境envからシンボルの値を探す。みつからなければ０を返す。
int findsym(int sym, int env){
	int addr;
    
    addr = assoc(sym,env);
    if(addr == 0)
    	return(0);
    else
    	return(cdr(addr));
}

//--------------クロージャ環境の操作--------------
int makeenv(int pala, int env){
	while(!(nullp(pala))){
    	env = cons(cons(car(pala),makeNIL()),env);
        pala = cdr(pala);
    }
    return(env);
}


void bindenv(int pala, int env){
	int len,addr;
    
    len = length(pala);
    addr = P - len;
	while(len > 0){
    	pushpala(findsym(car(pala),env));
    	darumacont(assoc(car(pala),env),addr);
        pala = cdr(pala);
        len--;
    }
} 

void unbindenv(int pala, int env){
	int len,addr;
    
    len = length(pala);
    addr = S - len;
    while(len > 0){
    	darumapala(assoc(car(pala),env),addr);
        pala = cdr(pala);
        len--;
    }
}        			

//---------スタック操作-------------------------

void pushpala(int x){
	switch(GET_TAG(x)){
    	case INTN: {SET_TAG(S,INTN);
        			SET_REAL_INT(S,GET_REAL_INT(x));
                    break;}
        case SYM:  {SET_TAG(S,SYM);
        			SET_NAME(S,GET_NAME(x));
                    break;}
        case LIS:  {SET_TAG(S,LIS);
        			SET_BIND(S,x);
                    break;}
        case BOL:  {SET_TAG(S,BOL);
        			SET_NAME(S,GET_NAME(x));
                    break;}
        case SUBR: {SET_TAG(S,SUBR);
        			SET_BIND(S,x);
                    break;}
        case CLOS: {SET_TAG(S,CLOS);
        			SET_BIND(S,x);
                    break;}
    }
    S++;
    if(S > CS) 
    	CS = S;
}



void poppala(int x){
	switch(GET_TAG(--S)){
    	case INTN: {SET_TAG(x,INTN);
        			SET_REAL_INT(cdr(x),GET_REAL_INT(S));
                    break;}
        case SYM:  {SET_TAG(x,SYM);
        			SET_NAME(cdr(x),GET_NAME(S));
                    break;}
        case LIS:  {SET_CDR(x,GET_BIND(S));
                    break;}
        case BOL:  {SET_TAG(cdr(x),BOL);
        			SET_NAME(cdr(x),GET_NAME(S));
                    break;}
        case SUBR: {SET_CDR(x,GET_BIND(S));
                    break;}
        case CLOS: {SET_CDR(x,GET_BIND(S));
                    break;}
    	}
	free(memory[S].name);
    memory[S].name = NULL;
}

void darumapala(int x, int addr){
		switch(GET_TAG(addr)){
    	case INTN: {SET_TAG(cdr(x),INTN);
        			SET_REAL_INT(cdr(x),GET_REAL_INT(addr));
                    break;}
        case SYM:  {SET_TAG(cdr(x),SYM);
        			SET_NAME(cdr(x),GET_NAME(addr));
                    break;}
        case LIS:  {SET_CDR(x,GET_BIND(addr));
                    break;}
        case BOL:  {SET_TAG(cdr(x),BOL);
        			SET_NAME(cdr(x),GET_NAME(addr));
                    break;}
        case SUBR: {SET_CDR(x,GET_BIND(addr));
                    break;}
        case CLOS: {SET_CDR(x,GET_BIND(addr));
                    break;}
    	}
	free(memory[addr].name);
    memory[addr].name = NULL;
	while(addr < S){
    	copycell(addr+1,addr);
    	addr++;
    }
    free(memory[addr-1].name);
    memory[addr].name = NULL;
	S--;
}


void pushcont(int x){
	free(memory[P].name);
    memory[P].name = NULL;
	switch(GET_TAG(x)){
    	case INTN: {SET_TAG(P,INTN);
        			SET_REAL_INT(P,GET_REAL_INT(x));
                    break;}
        case SYM:  {SET_TAG(P,SYM);
        			SET_NAME(P,GET_NAME(x));
                    break;}
        case LIS:  {SET_TAG(P,LIS);
        			SET_BIND(P,x);
                    break;}
        case BOL:  {SET_TAG(P,BOL);
        			SET_NAME(P,GET_NAME(x));
                    break;}
        case SUBR: {SET_TAG(P,SUBR);
        			SET_BIND(P,x);
                    break;}
        case SYNT: {SET_TAG(P,SYNT);
        			SET_BIND(P,x);
                    break;}
        case CLOS: {SET_TAG(P,CLOS);
        			SET_BIND(P,x);
                    break;}
    }
    P++;
    if(P > CP) 
    	CP = P;
}



void popcont(int x){
	switch(GET_TAG(--P)){
    	case INTN: {SET_TAG(cdr(x),INTN);
        			SET_REAL_INT(cdr(x),GET_REAL_INT(P));
                    break;}
        case SYM:  {SET_TAG(cdr(x),SYM);
        			SET_NAME(cdr(x),GET_NAME(P));
                    break;}
        case LIS:  {SET_TAG(x,LIS);
        			SET_CDR(x,GET_BIND(P));
                    break;}
        case BOL:  {SET_TAG(cdr(x),BOL);
        			SET_NAME(cdr(x),GET_NAME(P));
                    break;}
        case SUBR: {SET_CDR(x,GET_BIND(P));
                    break;}
        case SYNT: {SET_CDR(x,GET_BIND(P));
                    break;}
        case CLOS: {SET_CDR(x,GET_BIND(P));
                    break;}
        }
    free(memory[P].name);
}

void darumacont(int x, int addr){
	switch(GET_TAG(addr)){
    	case INTN: {SET_TAG(cdr(x),INTN);
        			SET_REAL_INT(cdr(x),GET_REAL_INT(addr));
                    break;}
        case SYM:  {SET_TAG(cdr(x),SYM);
        			SET_NAME(cdr(x),GET_NAME(addr));
                    break;}
        case LIS:  {SET_TAG(x,LIS);
        			SET_CDR(x,GET_BIND(addr));
                    break;}
        case BOL:  {SET_TAG(cdr(x),BOL);
        			SET_NAME(cdr(x),GET_NAME(addr));
                    break;}
        case SUBR: {SET_CDR(x,GET_BIND(addr));
                    break;}
        case SYNT: {SET_CDR(x,GET_BIND(addr));
                    break;}
        case CLOS: {SET_CDR(x,GET_BIND(addr));
                    break;}
        }
    free(memory[addr].name);
    memory[addr].name = NULL;
    while(addr < P){
    	copycell(addr+1,addr);
    	addr++;
    }
    free(memory[addr-1].name);
    memory[addr].name = NULL;
    P--;
}

	
//----------subrとcontstkとのやりとり--------
void pushint(int n){
	SET_TAG(P,INTN);
    SET_REAL_INT(P,n);
    P++;
}

void pushsym(char *name){
	SET_TAG(P,SYM);
    SET_NAME(P,name);
    P++;
}

void pushaddr(int n){
	SET_TAG(P,ADDR);
    SET_REAL_INT(P,n);
    P++;
}

//subrが実引数を継続スタックからpopするのに使う。
int poparg(void){
	switch(GET_TAG(--P)){
    	case INTN:	return(P);
        case SYM:	return(P);
        case LIS:	return(GET_BIND(P));
        case BOL:	return(P);
        case ADDR:	return(GET_REAL_INT(P));
        case SUBR:	return(GET_BIND(P));
        case SYNT:	return(GET_BIND(P));
        case CLOS:	return(GET_BIND(P));
    }
}

//--------------リスト操作---------------------

int car(int lis){
	return(GET_CAR(lis));
}

int caar(int lis){
	return(car(car(lis)));
}

int cdar(int lis){
	return(cdr(car(lis)));
}

int cdr(int lis){
	return(GET_CDR(lis));
}

int cddr(int list){
	return(cdr(cdr(list)));
}

int cadr(int lis){
	return(car(cdr(lis)));
}

int caddr(int lis){
	return(car(cdr(cdr(lis))));
}


int cons(int car, int cdr){
	int addr;
    
    addr = freshcell();
   	SET_TAG(addr,LIS);
    SET_CAR(addr,car);
    SET_CDR(addr,cdr);
    return(addr);
}

int assoc(int sym, int lis){
	if(nullp(lis))
    	return(0);
    else
    if(eqp(sym, caar(lis)))
    	return(car(lis));
    else
    	assoc(sym,cdr(lis));
}

int length(int lis){
	int len = 0;
    
    while(!(nullp(lis))){
    	len++;
        lis = cdr(lis);
    }
    return(len);
} 

int list(int arglist){
	if(nullp(arglist))
    	return(makeNIL());
    else
    	return(cons(car(arglist),list(cdr(arglist))));    
}

int reverse(int lis){
	int addr;
    
    addr = NIL;
	while(!(nullp(lis))){
    	addr = cons(car(lis),addr);
        lis = cdr(lis);
    }
	return(addr);
}

int reverse2(int lis){
	int x,addr;
    
    addr = NIL;
	while(!(nullp(lis))){
        x = cdr(lis);
        SET_CDR(lis,addr);
        addr = lis;
        lis = x;
    }
	return(addr);
}
    	

int atomp(int x){
    if((numberp(x)) || (symbolp(x)))
    	return(1);
    else
    	return(0);
}

int integerp(int x){
	if(IS_INTEGER(x))
    	return(1);
    else
    	return(0);
}
	

int numberp(int x){	
    if(IS_INTEGER(x) || (IS_FLOAT(x)) || (IS_COMPLEX(x)))
    	return(1);
    else
    	return(0);
}

//nilは内部的にはシンボルだが表面上は
//リストと扱う。
int symbolp(int x){
    if((IS_SYMBOL(x)) && (!(IS_NIL(x))))
    	return(1);
    else
    	return(0);
}

//nilを空リストと解釈している。
int listp(int x){	
    if(IS_LIST(x) && (!(improperp(x))))
    	return(1);
    else
    if(IS_NIL(x))
    	return(1);
    else
    	return(0);
}

int improperp(int x){
	while(!(nullp(x))){
    	if(atomp(cdr(x)))
        	return(1);
        x = cdr(x);
    }
    return(0);
}

int pairp(int x){
	if(IS_LIST(x))
    	return(1);
    else
    if(IS_NIL(x))
    	return(1);
    else
    	return(0);
}

int nullp(int x){
	if(IS_NIL(x))
    	return(1);
    else
    	return(0);
}


// = とりあえず整数だけ
int numeqp(int num1, int num2){
	if((IS_INTEGER(num1)) && (IS_INTEGER(num2))
    	&& ((GET_REAL_INT(num1)) == (GET_REAL_INT(num2))))
        return(1);
    else
    	return(0);
}

int eqp(int x1, int x2){
	if(numeqp(x1,x2))
        return(1);
    else if(symbolp(x1) && symbolp(x2)
    	&& (SAME_NAME(x1,x2)))
        return(1);
    else if(IS_BOOL(x1) && IS_BOOL(x2)
    	&& (SAME_NAME(x1,x2)))
        return(1);
    else if(nullp(x1) && nullp(x2))
    	return(1);
    else if(x1 == x2)
    	return(1);
    else
    	return(0);
}


//eqv? eq? は同じと解釈している。
int eqvp(int x1, int x2){
	if(numeqp(x1,x2))
        return(1);
    else if(symbolp(x1) && symbolp(x2)
    	&& (SAME_NAME(x1,x2)))
        return(1);
    else if(IS_BOOL(x1) && IS_BOOL(x2)
    	&& (SAME_NAME(x1,x2)))
        return(1);
    else if(nullp(x1) && nullp(x2))
    	return(1);
    else if(x1 == x2)
    	return(1);
    else
    	return(0);
}

int equalp(int x1, int x2){
	if(nullp(x1) && nullp(x2))
    	return(1);
	else if(atomp(x1) && atomp(x2))
    	return(eqvp(x1,x2));
    else if(equalp(car(x1),car(x2)) && equalp(cdr(x1),cdr(x2)))
    	return(1);
    else
    	return(0);
}
    	



int subrp(int x){
	if(IS_SUBR(x))
    	return(1);
    else
    	return(0);
}

int closurep(int x){
	if(IS_CLOSURE(x))
    	return(1);
    else
    	return(0);
}

//-------read()--------

void gettoken(void){
	char c;
    int pos;
    
    if(stok.flag == BACK){
    	stok.flag = GO;
        return;
    }
    
    if(stok.ch == ')'){
    	stok.type = RPAREN;
        stok.ch = NUL;
        return;
    }
    
    if(stok.ch == '('){
    	stok.type = LPAREN;
        stok.ch = NUL;
        return;
    }
    
    c = getchar();
    while((c == SPACE) || (c == EOL) || (c == TAB))
    	c=getchar();
    
    switch(c){
    	case '(':	stok.type = LPAREN; break;
        case ')':	stok.type = RPAREN; break;
        case '\'':	stok.type = QUOTE; break;
        case '.':	stok.type = DOT; break;
        default: {
        	pos = 0; stok.buf[pos++] = c;
        	while(((c=getchar()) != EOL) && (pos < BUFSIZE) && 
            		(c != SPACE) && (c != '(') && (c != ')'))
            	stok.buf[pos++] = c;
                
            stok.buf[pos] = NUL;
            stok.ch = c;
            if(numbertoken(stok.buf)){
            	stok.type = INTEGER;
                break;
            }
            if(symboltoken(stok.buf)){
            	stok.type = SYMBOL;
                break;
            }
            stok.type = OTHER;  
        }
    }
}

int numbertoken(char buf[]){
	int i;
    char c;
    
    if(((buf[0] == '+') || (buf[0] == '-'))){
		if(buf[1] == NUL)
        	return(0); // case {+,-} => symbol
    	i = 1;
    	while((c=buf[i]) != NUL)
        	if(isdigit(c))
            	i++;  // case {+123..., -123...}
            else
            	return(0); 
    }
    else {       
    	i = 0;    // {1234...}
    	while((c=buf[i]) != NUL)
    		if(isdigit(c))
        		i++;
        	else 
        		return(0);
    }
    return(1);
}

int symboltoken(char buf[]){
	int i;
    char c;
    
    if(isdigit(buf[0]))
    	return(0);
    
    i = 0;
    while((c=buf[i]) != NUL)
    	if((isalpha(c)) || (isdigit(c)) || (issymch(c)))
        	i++;
        else 
        	return(0);
    
    return(1);
}

int issymch(char c){
	switch(c){
    	case '!':
        case '?':
        case '+':
        case '-':
        case '*':
        case '/': return(1);
        defalut:  return(0);
    }
}  

void readstk(void){
	pushcont(read());
}
   
int read(void){
    gettoken();
    switch(stok.type){
    	case INTEGER:	return(makeint(atoi(stok.buf)));
        case SYMBOL:	return(makesym(stok.buf));
        case QUOTE:		return(cons(makesym("quote"), cons(read(),makeNIL())));
        case LPAREN:	return(readlist());
    }
    error(CANT_READ_ERR,"read",NIL);
}

int readlist(void){
    int car,cdr;
    
    gettoken();      
    if(stok.type == RPAREN)
    	return(makeNIL());
    else
    if(stok.type == DOT){
    	cdr = read();
        if(atomp(cdr))
        	gettoken();
        return(cdr);
    }
    else{
    	stok.flag = BACK;
    	car = read();
        cdr = readlist();
        return(cons(car,cdr));
    }
}

//-----print------------------
void printstk(void){
	print(poparg());
}

void print(int x){    
	switch(GET_TAG(x)){
    	case INTN:	printf("%d", GET_REAL_INT(x)); break;
        case SYM:  	if(IS_NIL(x))
        				printf("()");
        			else
        				printf("%s", GET_NAME(x)); break;
        case BOL:	printf("%s", GET_NAME(x)); break;
        case SUBR:	printf("<subr>"); break;
        case SYNT:	printf("<syntax>"); break;
        case CLOS:	printf("<closure>"); break;
        case LIS: {	printf("(");
    				printlist(x); break;}
    }
}	
	

void printlist(int x){
	if(IS_NIL(x))
    	printf(")");
    else
    if((!(pairp(cdr(x)))) && (! (nullp(cdr(x))))){
    	print(car(x));
        printf(" . ");
        print(cdr(x));
        printf(")");
    }
    else {
    	print(GET_CAR(x));    
        if(! (IS_NIL(GET_CDR(x))))
        	printf(" ");
       	printlist(GET_CDR(x));
    }
}

//--------eval--------------- 
void evalstk(int env){
	int x;
    
    x = poparg();
    if(symbolp(x)){
    	pushcont(getvar(x,env)); return;
    }
	if(atomp(x)){
    	pushcont(x); return;
    }
    if(pairp(x) && (length(x) >= 1)){
    	apply(car(x),cdr(x),env);
    	return;
    }
    error(CANT_FIND_ERR,"eval",x);
}

void apply(int sym, int args, int env){
	int exenv,clos,res,entity,fn,pala,body;
    
    pushcont(sym);
    evalstk(env);
    fn = poparg();
    switch(GET_TAG(fn)){
    	case SYNT: {((GET_SUBR(fn))(args, env));
        			return;
        			}
    	case SUBR: {pushcont(fn);
        			while(!(nullp(args))){
    					pushcont(car(args));
        				evalstk(env);
        				args = cdr(args); }
        			((GET_SUBR(fn))());
                    return;
                    }
        case CLOS: {pushcont(fn);
        			pala = car(GET_BIND(fn));
                    body = cadr(GET_BIND(fn));
        			exenv = GET_ENV(fn);
                    if(length(pala) != length(args))
                    	error(ARG_CLOS_ERR,GET_NAME(sym),NIL);
                    while(!(nullp(args))){
    					pushcont(car(args));
        				evalstk(env);
        				args = cdr(args); }
                    bindenv(pala,exenv);
                    clos = poparg();
                    pushcont(body);
                    evalstk(exenv);
                    unbindenv(pala,exenv);
                    return;
        			}
        default:	error(CANT_FIND_ERR,"apply",sym);
        }
}




int getvar(int x, int env){
	int res;
    
    res = findsym(x,env);
    if((res=findsym(x,env)) != 0)
    	return(res);
    else
    if((res=findsym(x,E)) != 0)
    	return(res);
    else
    	error(CANT_FIND_ERR,"eval",x);
}


//-------エラー処理------
void error(int errnum, char *fun, int arg){
	switch(errnum){
    	case CANT_FIND_ERR:{printf("%s can't find difinition of ", fun);
        					print(arg); break; }
        
        case CANT_READ_ERR:{printf("%s can't read expression", fun);
        					break; }
        
        case ARG_INT_ERR:  {printf("%s require integer but got ", fun);
        					print(arg); break; }
                            
        case ARG_SYM_ERR:  {printf("%s require symbol but got ", fun);
        					print(arg); break; }
                            
        case ARG_NUM_ERR:  {printf("%s require number but got ", fun);
        					print(arg); break; }
        
        case ARG_ATOM_ERR:  {printf("%s require atom but got ", fun);
        					print(arg); break; }
                       
        case ARG_LIS_ERR:  {printf("%s require list but got ", fun);
        					print(arg); break; }
        
        case ARG_LEN0_ERR: {printf("%s require 0 arg ", fun);
                           	break; }
                            
        case ARG_LEN1_ERR: {printf("%s require 1 arg ", fun);
                           	break; }
        
        case ARG_LEN2_ERR: {printf("%s require 2 args ", fun);
                           	break; }
        
        case ARG_LEN3_ERR: {printf("%s require 3 args ", fun);
                           	break; }
        
        case ARG_CLOS_ERR: {printf("%s got unexpected args ",fun);
        					break; }
                              
        case MALFORM_ERR:  {printf("%s got malformed args " ,fun);
        					print(arg); break; }
    }
    P = CONTSTK;
    //printf("  P= %d\n", P);
    //memorydump(P,P+10);
	printf("\n");
    longjmp(buf,1);
}

void checkarg(int test, char *fun, int arg){
	switch(test){
    	case INTEGER_TEST:	if(integerp(arg)) return; else error(ARG_NUM_ERR, fun, arg);
        case SYMBOL_TEST:	if(symbolp(arg)) return; else error(ARG_SYM_ERR, fun, arg);
		case NUMBER_TEST:	if(numberp(arg)) return; else error(ARG_NUM_ERR, fun, arg);
        case ATOM_TEST:		if(atomp(arg)) return; else error(ARG_ATOM_ERR, fun, arg);
        case LIST_TEST:		if(listp(arg)) return; else  error(ARG_LIS_ERR, fun, arg);
        case LEN0_TEST:		if(subrp(arg)) return; else error(ARG_LEN0_ERR, fun, arg);
        case LEN1_TEST:		if(subrp(arg)) return; else error(ARG_LEN1_ERR, fun, arg);
        case LEN2_TEST:		if(subrp(arg)) return; else error(ARG_LEN2_ERR, fun, arg);
        case LEN3_TEST:		if(subrp(arg)) return; else error(ARG_LEN3_ERR, fun, arg);
    }
}

//--------組込み関数
//subrを環境に登録する。
void defsubr(char *symname, int func){
	bindfunc(symname, SUBR, func);
}

void defsyntax(char *symname, int func){
	bindfunc(symname, SYNT, func);
}

void bindfunc(char *name, tag tag, int func){
	int sym,val;
	
    sym = makesym(name);
	val = freshcell();
    SET_TAG(val,tag);
    switch(tag){
    	case SUBR:
        case SYNT:		SET_SUBR(val,func); break;
    }
    SET_CDR(val,0);
    E = cons(cons(sym,val),E);
}

void initsubr(void){
	defsubr("mdmp",(int)f_memorydump);
    defsubr("exit",(int)f_exit);
    defsubr("addr",(int)f_addr);
    defsubr("reg",(int)f_register);
    defsubr("list/cc",(int)f_listcc);
    defsubr("list?",(int)f_listp);
    defsubr("pair?",(int)f_pairp);
    defsubr("atom?",(int)f_atomp);
    defsubr("eq?",(int)f_eqp);
    defsubr("eqv?",(int)f_eqvp);
    defsubr("equal?",(int)f_equalp);
    defsubr("boolean?",(int)f_boolp);
    defsubr("procedure?",(int)f_procedurep);
    defsubr("symbol?",(int)f_symbolp);
    defsubr("+",(int)f_plus);
    defsubr("-",(int)f_minus);
    defsubr("*",(int)f_mult);
    defsubr("=",(int)f_numeqp);
    defsubr("<=",(int)f_eqsmallerp);
    defsubr("display",(int)f_display);
    defsubr("car",(int)f_car);
    defsubr("cdr",(int)f_cdr);
    defsubr("cons",(int)f_cons);
    defsubr("caar",(int)f_caar);
    defsubr("caaar",(int)f_caaar);
    defsubr("cdar",(int)f_cadr);
    defsubr("cddr",(int)f_cddr);
    defsubr("cadr",(int)f_cdar);
    defsubr("assoc",(int)f_assoc);
    defsubr("reverse",(int)f_reverse);
    defsubr("reverse!",(int)f_reverse2);
    defsubr("newline",(int)f_newline);
    
    defsyntax("quote",(int)s_quote);
    defsyntax("define",(int)s_define);
    defsyntax("if",(int)s_if);
    defsyntax("lambda",(int)s_lambda);
    defsyntax("begin",(int)s_begin);
    defsyntax("set!",(int)s_setq);
}

void f_exit(void){
	int addr;
    
    for(addr=0; addr<= HEAPSIZE; addr++)
    	free(memory[addr].name);
	
	printf("- good by. -\n");
    longjmp(buf,2); 
}

void f_memorydump(void){
	int arg,n,subr;
    
    arg = poparg();
    checkarg(INTEGER_TEST,"mdmp",arg);
    n = GET_REAL_INT(arg);
    subr = poparg();
    checkarg(LEN1_TEST,"mdmp",subr);
	memorydump(n,n+10);
    pushcont(BOOLT);
}

void f_addr(void){
	int arg,subr;
    
    arg = poparg();
    checkarg(INTEGER_TEST,"addr",arg);
    subr = poparg();
    checkarg(LEN1_TEST,"addr",subr);
    pushaddr(GET_REAL_INT(arg));
}

void f_register(void){
	int subr;
    
    subr = poparg();
    checkarg(LEN0_TEST,"reg",subr);
	printf("H(heap)         = %d\n", H);
    printf("F(free)         = %d\n", F);
    printf("E(environment)  = %d\n", E);
    printf("S(env stack)    = %d\n", S);
    printf("CS(consume of S)= %d\n", CS);
    printf("A(arg-stack)    = %d\n", A);
    printf("P(cont stack)   = %d\n", P);
    printf("CP(consume of P)= %d\n", CP);
    pushcont(BOOLT);
}

void f_listcc(void){
	int subr,addr,cont,res;
    
    subr = poparg();
    checkarg(LEN0_TEST,"reg",subr);
    res = NIL;
    addr = CONTSTK;
    while(addr < P){
    	cont = freshcell();
        copycell(addr,cont);	
    	res = cons(cont,res);
        addr++;
    }
    pushcont(res);
}

//-------型判定---------------
void f_listp(void){
	int arg,subr;
    
    arg = poparg();
    subr = poparg();
    checkarg(LEN1_TEST,"list?",subr);
    if(listp(arg))
    	pushcont(BOOLT);
    else
    	pushcont(BOOLF);
}

void f_pairp(void){
	int arg,subr;
    
    arg = poparg();
    subr = poparg();
    checkarg(LEN1_TEST,"pair?",subr);
    if(pairp(arg))
    	pushcont(BOOLT);
    else
    	pushcont(BOOLF);
}


void f_boolp(void){
	int arg,subr;
    
    arg = poparg();
    subr = poparg();
    checkarg(LEN1_TEST,"boolean?",subr);
    if(IS_BOOL(arg))
    	pushcont(BOOLT);
    else
    	pushcont(BOOLF);
}

void f_symbolp(void){
	int arg,subr;
    
    arg = poparg();
    subr = poparg();
    checkarg(LEN1_TEST,"symbol?",subr);
    if(symbolp(arg))
    	pushcont(BOOLT);
    else
    	pushcont(BOOLF);
}

void f_procedurep(void){
	int arg,subr;
    
    arg = poparg();
    subr = poparg();
    checkarg(LEN1_TEST,"procedure?",subr);
    if((IS_SUBR(arg)) || (IS_CLOSURE(arg)))
    	pushcont(BOOLT);
    else
    	pushcont(BOOLF);
}

void f_atomp(void){
	int arg,subr;
    
    arg = poparg();
    subr = poparg();
    checkarg(LEN1_TEST,"atom?",subr);
    if(atomp(arg))
    	pushcont(BOOLT);
    else
    	pushcont(BOOLF);
}

void f_eqp(void){
	int arg1,arg2,subr;
    
    arg2 = poparg();
    arg1 = poparg();
    subr = poparg();
    checkarg(LEN2_TEST,"eq?",subr);
    if(eqp(arg1,arg2))
    	pushcont(BOOLT);
    else
    	pushcont(BOOLF);
}

void f_eqvp(void){
	int arg1,arg2,subr;
    
    arg2 = poparg();
    arg1 = poparg();
    subr = poparg();
    checkarg(LEN2_TEST,"eqv?",subr);
    if(eqvp(arg1,arg2))
    	pushcont(BOOLT);
    else
    	pushcont(BOOLF);
}

void f_equalp(void){
	int arg1,arg2,subr;
    
    arg2 = poparg();
    arg1 = poparg();
    subr = poparg();
    checkarg(LEN2_TEST,"equal?",subr);
    if(equalp(arg1,arg2))
    	pushcont(BOOLT);
    else
    	pushcont(BOOLF);
}

//---------算術演算-----------
void f_plus(void){
	int arg,n,res;
    
     
    res = 0;
    arg = poparg();
    while(!(IS_SUBR(arg))){
    	checkarg(INTEGER_TEST,"+",arg);
    	n = GET_REAL_INT(arg);
        res = res + n;
        arg = poparg();
    }
    pushint(res);
}

void f_minus(void){
	int arg,n,res;
    
    res = 0;
    arg = poparg();
    while(!(IS_SUBR(arg))){
    	checkarg(INTEGER_TEST,"-",arg);
    	n = GET_REAL_INT(arg);
    	res = res - n;
        arg = poparg();
    }
    res = res + n + n;
    pushint(res);
}

void f_mult(void){
	int arg,n,res;
    
    res = 1;
    arg = poparg();
    while(!(IS_SUBR(arg))){
    	checkarg(INTEGER_TEST,"*",arg);
    	n = GET_REAL_INT(arg);
    	res = res * n;
        arg = poparg();
    }
    pushint(res);
}

void f_numeqp(void){
	int arg1,arg2,num1,num2,subr;
    
    arg1 = poparg();
    checkarg(INTEGER_TEST,"=",arg1);
    arg2 = poparg();
    checkarg(INTEGER_TEST,"=",arg2);
    subr = poparg();
    checkarg(LEN2_TEST,"=",subr);
    num1 = GET_REAL_INT(arg1);
    num2 = GET_REAL_INT(arg2);
    
    if(num1 == num2)
    	pushcont(BOOLT);
    else
    	pushcont(BOOLF);
}

void f_eqsmallerp(void){
	int arg1,arg2,num1,num2,subr;
    
    arg2 = poparg();
    checkarg(INTEGER_TEST,"<=",arg2);
    arg1 = poparg();
    checkarg(INTEGER_TEST,"<=",arg1);
    subr = poparg();
    checkarg(LEN2_TEST,"<=",subr);
    num1 = GET_REAL_INT(arg1);
    num2 = GET_REAL_INT(arg2);
    
    if(num1 <= num2)
    	pushcont(BOOLT);
    else
    	pushcont(BOOLF);
}

void f_display(void){
	int arg,subr;
    
    arg = poparg();
    subr = poparg();
    checkarg(LEN1_TEST,"display",subr);
	print(arg);
    pushcont(BOOLT);
}

//--------リスト-----
void f_car(void){
	int arg,subr;
    
    arg = poparg();
    checkarg(LIST_TEST,"car", arg);
    subr = poparg();
    checkarg(LEN1_TEST,"car",subr);
    pushcont(car(arg));
}

void f_cdr(void){
	int arg,subr;
    
    arg = poparg();
    checkarg(LIST_TEST,"cdr", arg);
    subr = poparg();
    checkarg(LEN1_TEST,"cdr",subr);
    pushcont(cdr(arg));
}

void f_cons(void){
	int arg1,arg2,subr;
    
	arg2 = poparg();
    arg1 = poparg();
    subr = poparg();
    checkarg(LEN2_TEST,"cons",subr);
	pushcont(cons(arg1,arg2));
}

void f_caar(void){
	int arg,subr;
    
    arg = poparg();
    checkarg(LIST_TEST,"caar", arg);
    subr = poparg();
    checkarg(LEN1_TEST,"caar",subr);
    pushcont(caar(arg));
}

void f_caaar(void){
	int arg,subr;
    
    arg = poparg();
    checkarg(LIST_TEST,"caaar", arg);
    subr = poparg();
    checkarg(LEN1_TEST,"caaar",subr);
    pushcont(caar(car(arg)));
}

void f_cdar(void){
	int arg,subr;
    
    arg = poparg();
    checkarg(LIST_TEST,"cdar", arg);
    subr = poparg();
    checkarg(LEN1_TEST,"cdar",subr);
    pushcont(cdar(arg));
}


void f_cddr(void){
	int arg,subr;
    
    arg = poparg();
    checkarg(LIST_TEST,"cddr", arg);
    subr = poparg();
    checkarg(LEN1_TEST,"cddr",subr);
    pushcont(cddr(arg));
}

void f_cadr(void){
	int arg,subr;
    
    arg = poparg();
    checkarg(LIST_TEST,"cadr", arg);
    subr = poparg();
    checkarg(LEN1_TEST,"cadr",subr);
    pushcont(cadr(arg));
}

void f_assoc(void){
	int arg1,arg2,subr;
    
    arg2 = poparg();
    checkarg(LIST_TEST,"assoc",arg2);
    arg1 = poparg();
    checkarg(ATOM_TEST,"assoc",arg1);
    subr = poparg();
    checkarg(LEN2_TEST,"assoc",subr);
    pushcont(assoc(arg1,arg2));
}


void f_reverse(void){
	int arg,subr;
    
    arg = poparg();
    checkarg(LIST_TEST,"reverse", arg);
    subr = poparg();
    checkarg(LEN1_TEST,"reverse",subr);
    pushcont(reverse(arg));
}

//破壊的リバース
void f_reverse2(void){
	int arg,subr;
    
    arg = poparg();
    checkarg(LIST_TEST,"reverse!", arg);
    subr = poparg();
    checkarg(LEN1_TEST,"reverse!",subr);
    pushcont(reverse2(arg));
}

void f_newline(void){
	int subr;

    subr = poparg();
    checkarg(LEN0_TEST,"newline",subr);
	printf("\n");
    pushcont(BOOLT);
}


//------syntax---------------
void s_quote(int arg, int env){
	pushcont(car(arg));
}

void s_define(int arg, int env){
	int exenv,sym,lam;
    
    //(define sym (lambda ...))
    if((symbolp(car(arg))) && (!(nullp(cdr(arg))))){
		pushcont(cadr(arg));
    	evalstk(env);
    	exenv = definesym(car(arg),E);
    	if(exenv != 0)
    		E = exenv;
    	pushcont(car(arg));
        return;
    }
    //(define (sym x y ..) ...)
    if((pairp(car(arg))) && (!(nullp(cdr(arg))))){
    	sym = caar(arg);
        lam = cons(makesym("lambda"),cons(cdar(arg),cdr(arg)));
        pushcont(lam);
        evalstk(env);
        exenv = definesym(sym,E);
    	if(exenv != 0)
    		E = exenv;
    	pushcont(sym);
        return;
    } 
	error(MALFORM_ERR,"define",arg);   		
}

void s_if(int arg, int env){
	int cond;
    
    pushcont(car(arg));
    evalstk(env);
    cond = poparg();
            
    if(!(IS_F(cond))){	
    	pushcont(cadr(arg));
        evalstk(env);
    }
    else{
    	pushcont(caddr(arg));
        evalstk(env);
    }
}

//bodyが複数の場合にはbeginを入れるようにしている。
void s_lambda(int arg, int env){
	int exenv,res;
    
	res = makeclosure();
    if(length(cdr(arg)) >= 2)// (lambda (arg) (body1 body2 ..))
    	arg = cons(car(arg),cons(cons(makesym("begin"),cdr(arg)),NIL));
    SET_BIND(res,arg);
    exenv = makeenv(car(arg),env);
    SET_ENV(res,exenv);
    pushcont(res);
}

void s_begin(int arg, int env){
	int res;
    
	while(!(nullp(arg))){
    	pushcont(car(arg));
        evalstk(env);
        res = poparg();
        arg = cdr(arg);
    	}
    pushcont(res);
}

void s_setq(int arg, int env){
	int addr;
    
    addr = findsym(car(arg),env);
    if(addr == 0){
    	addr = findsym(car(arg),E);
        if(addr == 0)
        	error(CANT_FIND_ERR,"set!",car(arg));
        else{
        	pushcont(cadr(arg));
            evalstk(env);
        	bindsym(car(arg),E);
        }
    }
    else{
    	pushcont(cadr(arg));
        evalstk(env);
    	bindsym(car(arg),env);
    }
    pushcont(car(arg));
}