Created
December 29, 2011 09:47
-
-
Save sasagawa888/1533261 to your computer and use it in GitHub Desktop.
poly.c
This file contains bidirectional Unicode text that may be interpreted or compiled differently than what appears below. To review, open the file in an editor that reveals hidden Unicode characters.
Learn more about bidirectional Unicode characters
| /* (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)); | |
| } | |
Sign up for free
to join this conversation on GitHub.
Already have an account?
Sign in to comment