Skip to content

Instantly share code, notes, and snippets.

@sasagawa888
Created December 29, 2011 09:47
Show Gist options
  • Save sasagawa888/1533261 to your computer and use it in GitHub Desktop.
Save sasagawa888/1533261 to your computer and use it in GitHub Desktop.
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;
}
}
//xからyへコピー
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からシンボルの値を探す。みつからなければ0を返す。
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