%{
#include <stdio.h>
#include <string.h>
#define YYSTYPE CELL *
#define yylex()	yylex(); gyyvsp = yyvsp; gyyvs = yyvs;

#define CSIZE	8
#define AASSIZE	256
#define HSIZE	1024
#define ISHIFT	7
#define SMASK	0x00000078
#define IMASK	0xffffff80
#define PMASK	0xfffffff8
#define TMASK	0x00000007

#define PRIM	0x00
#define PROC	0x08
#define SQUOTE	0x10
#define DEF	0x18
#define DEFF	0x20
#define ASSIGN	0x28
#define LAMBDA	0x30
#define BRANCH	0x38
#define SP_AND	0x40
#define SP_OR	0x48

#define PAIR 0x0
#define FP   0x1
#define VCT  0x2
#define SP   0x3
#define INUM 0x4
#define FNUM 0x5
#define SYM  0x6
#define STR  0x7

#define V_body(vec)	((VAL *)(vec + 1))
#define Pr(x)	((VAL)&prim[x])
#define Type(x) ((int)((x)->head) & TMASK)
#define Pointer(x)	((int)((x)->head) & PMASK)
#define Sp(x)	((int)((x)->head) & SMASK)
#define S_T(x)	((int)((x)->head) & (SMASK|TMASK))
#define Index(x)	((int)((x)->head) & IMASK) >> ISHIFT
#define Inum(x)	((int)((x)->tail))
#define Fnum(x)	((FNODE *)(x))->fnum
#define Str(x)	((char *)((x)->tail))
#define TypeEQ(x, type)	(Type(x) == type)
#define Space(i)	(&hbase[HSIZE*s + i])
#define ToSpace(i)	(&hbase[HSIZE*(1^s) + i])

#define PRIME 997

typedef struct celltype {
	struct celltype *head;
	struct celltype *tail;
} CELL;

typedef CELL *VAL;

typedef struct fnodetype {
	int	type;
	float	fnum;
} FNODE;

typedef struct {
    char    *key;
    VAL     value;
} Item_type;

Item_type Htbl[PRIME];

VAL aastk[AASSIZE];
int aastktp = 0;

typedef struct {
	int  index;
	char str[20];
} PRTYPE;

enum prim_e {
	PNOT,
	PNE,
	PG,
	PL,
	PGE,
	PLE,
	PADD,
	PSUB,
	PMUL,
	PDIV,
	PNEG,
	PSEQ,
	PEQVP,
	PCONS,
	PREM,
	PVSET,
	PMKVR,
	PVREF,
	LAST
};

PRTYPE Prim[LAST+1] = {
	{PNOT	,"not"		},
	{PNE	,"!="		},
	{PG	,">"		},
	{PL	,"<"		},
	{PGE	,">="		},
	{PLE	,"<="		},
	{PADD	,"+"		},
	{PSUB	,"-"		},
	{PMUL	,"*"		},
	{PDIV	,"/"		},
	{PNEG	,"-"		},
	{PSEQ	,"sequence"	},
	{PEQVP	,"eqv?"		},
	{PCONS	,"cons"		},
	{PREM	,"remainder"	},
	{PVSET	,"vector-set!"	},
	{PMKVR	,"make-vectorR"	},
	{PVREF	,"vector-ref"	},
	{0	,""		}
};

void init(void);
VAL mk_pr(int primn, VAL arg1, VAL arg2);
VAL mk_sp(int spn, VAL arg1, VAL arg2);
VAL mk_sym(char *sym);
VAL mk_spnode(int spn, VAL x);
VAL cons(VAL x, VAL xl);
VAL cell_alloc(int n);
void apush(VAL x);
VAL apop(void);
void print_val(VAL node);
void gc(void);
void trace(VAL *vp);
void copy(VAL *vp);
void fatalerror(void);

int s = 0;
int nac = 0;

VAL hbase;
VAL true;
VAL false;
VAL nil;
VAL tmp;
extern int f;
PRTYPE *prim;
VAL *gyyvs, *gyyvsp;
%}

%token	INT FLOAT STRING ID
%token	FN ARROW
%token	IF THEN ELSE
%token	BGIN END
%token	SET
%token	LET LETREC IN
%token	DEFINE DEFUN
%token	QUOTE

%nonassoc	ID FE DLS SI
%right	','
%right	SET EQ
%nonassoc	THEN
%right	ELSE
%right	ARROW
%left	OR
%left	AND
%right	NOT
%left	'=' NE
%left	'>' '<' GE LE
%left	'+' '-'
%left	'*' '/' '%'
%right	CONS
%right	UMINUS QUOTE
%right	'(' '['
%right	RV
%%
stmt	: expr ';'		{if (!f) printf("Parsed expr : ");
				 print_val($1);
				 printf("\n");
				 if (!f) printf(">");}
	| stmt expr ';'		{if (!f) printf("Parsed expr : ");
				 print_val($2);
				 printf("\n");
				 if (!f) printf(">");}
	| error ';'		{yyerrok; printf(">");}
	;
expr	: nfexpr		{$$ = $1;}
	| fexpr	%prec FE	{$$ = $1;}
	;
nfexpr	: INT			{$$ = $1;}
	| FLOAT			{$$ = $1;}
	| STRING		{$$ = $1;}
	| expr AND expr		{$$ = mk_sp(SP_AND, $1, $3);}
	| expr OR expr		{$$ = mk_sp(SP_OR, $1, $3);}
	| expr CONS expr	{$$ = mk_pr(PCONS, $1, $3);}
	| expr '=' expr		{$$ = mk_pr(PEQVP, $1, $3);}
	| expr NE expr		{$$ = mk_pr(PNE, $1, $3);}
	| expr '>' expr		{$$ = mk_pr(PG, $1, $3);}
	| expr '<' expr		{$$ = mk_pr(PL, $1, $3);}
	| expr GE expr		{$$ = mk_pr(PGE, $1, $3);}
	| expr LE expr		{$$ = mk_pr(PLE, $1, $3);}
	| expr '+' expr		{$$ = mk_pr(PADD, $1, $3);}
	| expr '-' expr		{$$ = mk_pr(PSUB, $1, $3);}
	| expr '*' expr		{$$ = mk_pr(PMUL, $1, $3);}
	| expr '/' expr		{$$ = mk_pr(PDIV, $1, $3);}
	| expr '%' expr		{$$ = mk_pr(PREM, $1, $3);}
	| NOT expr		{$$ = mk_pr(PNOT, $2, NULL);}
	| '-' expr %prec UMINUS	{$$ = mk_pr(PNEG, $2, NULL);}
	| '(' nfexpr ')'	{$$ = $2;}
	| assign		{$$ = $1;}
	| define		{$$ = $1;}
	| list			{$$ = $1;}
	| quote			{$$ = $1;}
	;
fexpr	: ID			{$$ = $1;}
	| fcall			{$$ = $1;}
	| lambda 		{$$ = $1;}
	| branch		{$$ = $1;}
	| binding		{$$ = $1;}
	| sequence		{$$ = $1;}
	| refvec %prec RV	{$$ = $1;}
	| '(' fexpr ')'		{$$ = $2;}
	;
fcall	: fexpr '(' oprs ')' 	{$$ = cons($1, $3);}
	;
oprs	:			{$$ = NULL;}
	| oprl			{$$ = $1;}
	;
oprl	: expr			{$$ = cons($1, NULL);}
	| expr ',' oprl		{$$ = cons($1, $3);}
        ;
lambda	: FN param ARROW expr	{$$ = mk_sp(LAMBDA, $2, $4);}
	;
param	: ID			{$$ = $1;}
	| '(' args ')'		{$$ = $2;}
	;
args	:			{$$ = NULL;}
	| argl			{$$ = $1;}
        ;
argl	: ID			{$$ = cons($1, NULL);}
	| ID CONS ID		{$$ = cons($1, $3);}
	| ID ',' argl		{$$ = cons($1, $3);}
        ;
branch  : IF expr THEN expr	{$$ = mk_sp(BRANCH, $2, $4);}
	| IF expr THEN expr ELSE expr
	{$$ = mk_spnode(BRANCH, cons($2, cons($4, cons($6, NULL))));}
	;
assign	: ID SET expr 		{$$ = mk_sp(ASSIGN, $1, $3);}
	| fexpr index SET expr	
		{$$ = cons(Pr(PVSET), cons($1, cons($2, cons($4, NULL))));}
	;
binding	: LET bindl IN expr END	{tmp = mk_sp(LAMBDA, $2->head, $4);
				 $$ = cons(tmp, $2->tail);}
	| LETREC rbindl IN expr END 
	{tmp = mk_sp(LAMBDA, $2->head->head,
			mk_pr(PSEQ, $2->head->tail, $4));
	 $$ = cons(tmp, $2->tail);}
	;
bindl	: binds			{$$ = $1;}
	;
binds	: bind			{apush(cons($1->head, NULL));
				 tmp = cons($1->tail, NULL);
				 $$ = cons(apop(), tmp);}
	| bind ',' binds	{apush(cons($1->head, $3->head));
				 tmp = cons($1->tail, $3->tail);
				 $$ = cons(apop(), tmp);}
	;
bind	: ID '=' expr %prec EQ	{$$ = cons($1, $3);}
	;
rbindl	: rbinds		{tmp = cons($1->head->head,
					    cons(Pr(PSEQ), $1->head->tail));
				 $$ = cons(tmp, $1->tail);}
	;
rbinds	: rbind			{apush(cons($1->head, NULL));
				 tmp = cons($1->tail, NULL);
				 apush(cons(apop(), tmp));
				 tmp = cons(NULL, NULL);
				 $$ = cons(apop(), tmp);}
	| rbind ',' rbinds	{apush(cons($1->head, $3->head->head));
				 tmp = cons($1->tail, $3->head->tail);
				 apush(cons(apop(), tmp));
				 tmp = cons(NULL, $3->tail);
				 $$ = cons(apop(), tmp);}
	;
rbind	: ID '=' expr %prec EQ	{$$ = cons($1, mk_sp(ASSIGN, $1, $3));}
	;
sequence: BGIN exprseq END	{$$ = cons(Pr(PSEQ), $2);}
	;
exprseq	: expr ';'		{$$ = cons($1, NULL);}
	| expr ';' exprseq 	{$$ = cons($1, $3);}
	;
define  : DEFINE deflist 	{$$ = cons(Pr(PSEQ), $2);}
	| DEFUN ID param '=' expr %prec EQ
                                {tmp = cons($2, $3); $$ = mk_sp(DEFF, tmp, $5);}
	;
deflist : def %prec DLS		{$$ = cons($1, NULL);}
	| def ',' deflist	{$$ = cons($1, $3);}
	;
def	: ID			{$$ = mk_sp(DEF, $1, NULL);}
        | ID '=' expr %prec EQ	{$$ = mk_sp(DEF, $1, $3);}
        | defvec		{$$ = $1;}
        ; 
defvec  : ID dindex		{$$ = mk_sp(DEF, $1, cons(Pr(PMKVR), $2));}
        ;
dindex	: index	%prec SI	{$$ = cons($1, NULL);}
	| index dindex		{$$ = cons($1, $2);}
	;
refvec  : fexpr index		{$$ = mk_pr(PVREF, $1, $2);}
        | refvec index 		{$$ = mk_pr(PVREF, $1, $2);}
        ;
index	: '[' expr ']'		{$$ = $2;}
	;
list	: '{' lelem '}'		{$$ = $2;}
	;
lelem	:			{$$ = NULL;}
	| exprs			{$$ = $1;}
	;
exprs	: expr			{$$ = cons($1, NULL);}
	| expr ',' exprs        {$$ = cons($1, $3);}
	;
quote	: QUOTE expr		{$$ = mk_sp(SQUOTE, $2, NULL);}
	;
%%

#include "lex.yy.c"

yyerror(char *s)
{
	if (yychar != YYEOF)
		fprintf(stderr, "%s\n", s);
	else
		printf("See you again!! \\(T_T)/\n");
}

Item_type *search(char *id)
{
    int h,i;
    Item_type *p;

    h = Hash(id);
    for (i = 0; i < PRIME; i++) {
        p = &Htbl[h];
        if (!p->key) {
            p->key = malloc(strlen(id)+1);
            strcpy(p->key, id);
            return p;
        }
        if (!strcmp(p->key, id))
            return p;
        h = (h + 1) % PRIME;
    }
    fprintf(stderr, "Hash table overflow\n");
    fatalerror();
}

int Hash(char *s)
{
    char *p;
    unsigned h = 0, g;

    for (p = s; *p; p++) {
        h = (h << 4) + (*p);
        if (g = h&0xf000) {
            h = h ^ (g >> 8);
            h = h ^ g;
        }
    }
    return h % PRIME;
}

void init(void)
{
	int i;
	PRTYPE tmp;

	setbuf(stdout, NULL);
	hbase = malloc((HSIZE*2 + 1)*CSIZE);
/* 8byte Alingnment */
	hbase = (VAL)(((int)hbase + (CSIZE - 1)) & PMASK);
	prim = Prim;
/* 8byte Alingnment */
	if ((int)prim & TMASK) {
		prim = (PRTYPE *)(((int)Prim + CSIZE) & PMASK);
		for (i = LAST-1; i >= 0; i--) {
			tmp = Prim[i];
			prim[i] = tmp;
		}
	}
	true = mk_sym("#t");
	false = mk_sym("#f");
	nil = mk_sym("nil");
	for (i = 0; i < LAST; i++) {
		if (i != prim[i].index) {
			printf("i=%d,index=%d\n",i,prim[i].index);
			exit(2);
		}
		prim[i].index = SP | PRIM | (i << ISHIFT);
	}
	if (!f) printf(">");
	return;
}

VAL mk_pr(int primn, VAL arg1, VAL arg2)
{
/*printf("mk_pr,%x\n",arg2);*/
	if (!arg2)
		return(cons(Pr(primn), cons(arg1, NULL)));
	apush(arg1);
	return(cons(Pr(primn), cons(apop(), cons(arg2, NULL))));
}

VAL mk_sp(int spn, VAL arg1, VAL arg2)
{
/*printf("mk_sp,%x\n",arg1);*/
	if (!arg2)
		return(mk_spnode(spn, cons(arg1, NULL)));
	apush(arg1);
	return(mk_spnode(spn, cons(apop(), cons(arg2, NULL))));
}

VAL mk_sym(char *symstr)
{
	Item_type *p;

	if ((p = search(symstr))->value)
		return p->value;
	p->value = cell_alloc(1);
/*printf("mk_sym,%x\n",p->value);*/
	p->value->head = (VAL)SYM;
	p->value->tail = (VAL)p->key;
	return(p->value);
}

VAL mk_spnode(int spn, VAL x)
{
	VAL sp_node;

	apush(x);
	sp_node = cell_alloc(1);
	sp_node->head = (VAL)(SP | spn);
	sp_node->tail = apop();
/*printf("mk_spnode,%x\n",sp_node);
printf(" tail=%x\n",sp_node->tail);*/
	return(sp_node);
}

VAL cons(VAL x, VAL xl)
{
	VAL new_node;

	apush(xl);
	apush(x);
	new_node = cell_alloc(1);
	new_node->head = apop();
	new_node->tail = apop();
/*
printf("Cons,%x\n",new_node);
printf(" head=%x\n",new_node->head);
printf(" tail=%x\n",new_node->tail);
*/
	return(new_node);
}

VAL cell_alloc(int n)
{
	int pnac = nac;

/* printf("\n\nCELLALLOC %d\n",n); */
	if (nac+n <= HSIZE)
		nac += n;
	else {
		gc();
		pnac = nac;
		nac += n;
		if (nac > HSIZE) {
			fprintf(stderr, "Insufficient node space!!\n");
			fatalerror();
		}
	}
/*printf("  rval=%x\n", Space(pnac));*/

	return Space(pnac);
}

void apush(VAL x)
{
	aastk[aastktp++] = x;
/*printf("apush%8d,%8X\n",aastktp,x);*/
	if (aastktp == AASSIZE)
		fprintf(stderr,"ArgStack Overflow\n");
	return;
}

VAL apop(void)
{
/*printf("apop%8d\n",aastktp);*/
	return aastk[--aastktp];
}

void gc(void)
{
	int i;
	VAL x;

	nac = 0;
	for (i = 0; i < PRIME; i++)		/* clear hash	*/
		Htbl[i].value = NULL;
	for (i = 0; i < aastktp; i++)
		trace(&aastk[i]);
	for (i = 1; i <= gyyvsp - gyyvs; i++)
			trace(&gyyvs[i]);
	for (i = 0; i < PRIME; i++)		/* free garbage	symbol	*/
		if (!Htbl[i].value && Htbl[i].key)
			free(Htbl[i].key);
	for (i = 0; i < HSIZE; i++) {		/* free garbage string	*/
		x = Space(i);
		if (TypeEQ(x, STR))
			free(x->tail);
		x->head = NULL;
		x->tail = NULL;
	}
	s = 1 ^ s;
	printf("GC: %d cells copied, %d cells free\n", nac, HSIZE - nac);
}

void trace(VAL *vp)
{
	if (*vp)
		if (TypeEQ(*vp, FP))
			*vp = (VAL)Pointer(*vp);
		else
			copy(vp);
}

void copy(VAL *vp)
{
	int i;
	VAL Tonode = ToSpace(nac);

	if (S_T(*vp) == SP | PRIM)
		return;
	if (++nac == HSIZE) {
		fprintf(stderr, "Insufficient node space!!\n");
		fatalerror();
	}
	Tonode->head = (*vp)->head;
	Tonode->tail = (*vp)->tail;
	if (TypeEQ(*vp, SYM))
		search(Str(*vp))->value = Tonode;
	(*vp)->head = (VAL)((int)Tonode | FP);
	*vp = Tonode;
	if (TypeEQ(*vp, PAIR)) {
		trace(&Tonode->head);
		trace(&Tonode->tail);
	}
	if (TypeEQ(*vp, SP))
		trace(&Tonode->tail);
}

void fatalerror(void)
{
	fprintf(stderr, "Fatal error\n");
	exit(1);
}

void print_val(VAL node)
{

	int i;
/*printf("print,%x\n",node);*/
	if (!node) {
		printf("()");
		return;
	}
	switch (Type(node)) {
		case INUM:
			printf("%d", node->tail);
			break;
		case FNUM:
 			printf("%f", Fnum(node));
 			break;
		case STR:
			printf("\"%s\"", node->tail);
			break;
		case SYM:
			printf("%s", node->tail);
			break;
		case VCT:
			printf("#(");
			print_val(*V_body(node));
			for (i = 1; i < Inum(node); i++) {
				printf(" ");
				print_val(V_body(node)[i]);
			}
			printf(")");
			break;
		case SP:
			switch(Sp(node)) {
				case PRIM:
					printf("%s", prim[Index(node)].str);
					break;
				case SQUOTE:
					printf("(quote ");
					print_val(node->tail->head);
					printf(")");
					break;
				case DEF:
					printf("(define ");
					node = node->tail;
					print_val(node->head);
					if (node->tail) {
						printf(" ");
						print_val(node->tail->head);
					}
					printf(")");
					break;
				case DEFF:
					printf("(define ");
					node = node->tail;
					print_val(node->head);
					printf(" ");
					print_val(node->tail->head);
					printf(")");
					break;
				case ASSIGN:
					printf("(set! ");
					node = node->tail;
					print_val(node->head);
					printf(" ");
					print_val(node->tail->head);
					printf(")");
					break;
				case LAMBDA:
					printf("(lambda ");
					node = node->tail;
					print_val(node->head);
					printf(" ");
					print_val(node->tail->head);
					printf(")");
					break;
				case BRANCH:
					printf("(if ");
					node = node->tail;
					print_val(node->head);
					printf(" ");
					print_val(node->tail->head);
					if (node->tail->tail) {
						printf(" ");
						print_val(node->tail->tail->head);
					}
					printf(")");
					break;
				case SP_AND:
					printf("(and ");
					node = node->tail;
					print_val(node->head);
					printf(" ");
					print_val(node->tail->head);
					printf(")");
					break;
				case SP_OR:
					printf("(or ");
					node = node->tail;
					print_val(node->head);
					printf(" ");
					print_val(node->tail->head);
					printf(")");
					break;
			}
			break;
		case PAIR:
			printf("(");
			if (node->head)
				print_val(node->head);
			else
				printf("()");
			while (node->tail) {
				printf(" ");
				node = node->tail;
				if (Type(node) == PAIR)
					print_val(node->head);
				else {
					printf(". ");
					print_val(node);
					break;
				}
			}
			printf(")");
			break;
		default:
printf("moon");
	}
}