#define DEBUG 0
#include <stdio.h>
#include <stdlib.h>
#include <math.h>
#include <fcntl.h>
#include <termios.h>
#include <unistd.h>
#include <ctype.h>
#include "debug.h"
#include "prim.h"
#include "errno.h"

#include <sys/types.h> /* SOCKET STUFF */
#include <sys/socket.h>
#include <netinet/in.h>
#include <netinet/in.h>

#include <signal.h>




int eofflag, count;

extern OBJ null, nullvec, nullstr, false, true, eof;

R64 numberasreal (OBJ o) {
	return is_integer(o)?(R64)obj_integer(o):obj_real(o);
}
S64 numberasinteger (OBJ o) {
	return is_real(o)?(S64)obj_real(o):obj_integer(o);
}

/* USEFULL FUNCTIONS
 */
char *symbol2string (OBJ o) {/* CONVERT SYMBOL TO NULL TERMINATED C STRING */
 char *s;
 U32 l;
   s = (char*)calloc((l=obj_symbol_len(o))+1,1);
   memcpy(s, obj_symbol(o), l);
   return s;
}


void prim_doit (void) {
BCYN;DB("prim_doit");
	//mem_stats_dump();
	mem_heap_info();
	acc=null;

	push(acc);
	ip=cdr(ip);
}

extern void quit (void);

void prim_quit (void) {
BCYN;DB("prim_quit");
	//mem_gc(0); mem_stats_dump();
	quit();
}
/* SETUP ARGUMENT AS A SEQUENCE AND NEXT IN A LIST SINCE OP_APPLY, WHICH
 * CALLS THIS, THINKS IT JUST NEEDS TO CDR THE IP AND PUSH ACC (RETURN VALUE)
 * IE: (+ 1 2) => (()(+ 1 2))
 */
void prim_eval (void) { /* BF: LETS MAKE THIS TAIL RECURSE */
BPUR;DB("prim_eval");
	/* NEED TO COPY THIS SINCE THE COMPILER WILL MUTATE THE EXPRESSION */
	acc=pop();
	tree_copy(); /* COPY TREE IN ACC */
	push(acc);
	push(null);new_pair();/*NEXT EXP ALREADY ON STACK, MUTATE INTO SEQUENCE */
DB1("----", acc);
	/* MAKE SURE CONTINUATION IS PUSHED */
	push(env); /* SAVE CURRENT ENV */
	r2=cdr(ip);/* SAVE NEXT CURRENT OPCODE */
		env=tge;   /* WE ALWAYS EVAL IN TGE */
		/* SINCE OP_APPLY WILL IMMEDIATELY CDR THE IP,
         WE PUT THE SEQUENCE IN A PAIR */
		push(null);push(acc); new_pair(); ip=acc;
	acc=r2; /*SINCE OP_APPLY WILL IMMEDIATE PUSH THIS (THE OPCODE IN THIS CASE)*/

	push(acc);
	ip=cdr(ip);
}
void prim_read(void) { /* RETURN LIST CONTAINING OBJECT JUST PARSED */
 FILE *fp;
 static int flags;
BPUR;DB("prim_read");
	if (obj_integer(acc)==1) r2=pop();
	else r2=null;
	if (is_port(r2)) {
		fp = fopen(*(char**)mem_drt_ref(r2, 4), "r+");
		fseek(fp, lseek(obj_port(r2), 0, SEEK_CUR), SEEK_SET);
		yyrestart(fp);
PUR;DB("caling atom_parse");
			atom_parse(0);
PUR;DB("returning atom_parse");
		yyrestart(stdin);
		lseek(obj_port(r2), ftell(fp), SEEK_SET); // ADJUST PORT FILE LOCATION
		fclose(fp);
	} else  {
		fcntl (0, F_SETFL, (flags=fcntl (0, F_GETFL)) & ~O_NONBLOCK);
		atom_parse(0);
		fcntl (0, F_SETFL, (flags=fcntl (0, F_GETFL)) | O_NONBLOCK);
	}
	if (eofflag) acc=eof;
	eofflag=0;

	push(acc);
	ip=cdr(ip);
}
void prim_load (void) {
 FILE *fp;
 char *filename;
BPUR;DB("prim_load");
	acc=pop();
	fp = fopen(filename=symbol2string(acc), "r");
	free(filename);
	if (fp==NULL) {
		//printf ("*WARNING* CAN'T OPEN: "); obj_dump(acc, 0);
		acc=null;
	} else {
		yyrestart(fp);
			atom_parse(1);
		yyrestart(stdin);
		fclose(fp);
		eofflag = 0;
		/*SINCE op_apply WILL CDR THE IP*/
		push(null);push(acc);new_pair();r2=acc;
		if (is_pair(cdr(ip))) { /* NON TAIL CALL */
			/* PUSH CURRENT CONTINUATION... */
			push(env);
			acc=cdr(ip); /* ...WELL, ALMOST, op_apply WILL PUSH THIS FOR US */
			ip=r2;
		} else {
			ip=r2;
			acc=pop();/* op_apply WILL PUSH THIS BACK */
		}
	}

	push(acc);
	ip=cdr(ip);
}
void prim_char_readyp (void) {
 static int flags, c;
BPUR;DB("prim_char_readyp");
	/* RETURN #T FOR ANYTHING BUT A TERMINAL */
	if (obj_integer(acc)==1 && (is_port(r1=pop()))) {
		acc = true;
	/* SEE IF TERMINAL HAS A CHARACTER READY */
	} else {
			fcntl (0, F_SETFL, (flags=fcntl (0, F_GETFL)) | O_NONBLOCK);
				c=getchar();
			fcntl(0, F_SETFL, flags); /* SET BACK TO BLOCKING MODE */
		if (c==EOF) acc=false;
		else {
			ungetc(c, stdin);
			acc=true;
		}
	}

	push(acc);
	ip=cdr(ip);
}
extern U64 mytime (void);
void prim_read_char (void) {
 static int ch;
BPUR;DB2("prim_read_char", acc,stack);
	if (obj_integer(acc)==1 && (is_port(r2=pop()))) {
		if (0 == read (obj_port(r2), &ch, 1)) {
			acc = eof;
		} else {
			new_string(&ch, 1);
		}
	} else {
		ch = fgetc(stdin);
		if (ch==EOF) {
PUR;DB(" blocking this thread");
			/* SAVE THREAD STATE */
			push(env);
			push(cdr(ip));
			/* INSERT THREAD INTO BLOCKED LIST */
			block_current_thread (0);
			return;
		} else {
			new_string(&ch, 1);
		}
	}

	push(acc);
	ip=cdr(ip);
}

void prim_write_char (void) {
 int fp;
BPUR;DB("prim_write_char");
	count = obj_integer(acc);
	if (count==2 && (is_port(r1=pop())))
		fp = obj_port(r1);
	else
		fp = 1;
	//fputc(*obj_symbol(acc=pop()), fp);
	write(fp, obj_symbol(stack_peek(0)), 1);
	//fflush(fp); /* EFFICIENT? */

	//push(acc);
	ip=cdr(ip);
}
void prim_write (void) {
 int fp;
BPUR;DB("prim_write");
	if (obj_integer(acc)>=2) {
		r2=pop();
		fp = is_port(r2) ? obj_port(r2) : 1;
	} else
		fp = 1;
	obj_write(stack_peek(0), 0, fp);
	//fflush(fp); /* EFFICIENT? */

	//push(acc);
	ip=cdr(ip);
}
void prim_display (void) {
 int fp;
BPUR;DB("prim_display");
	if (obj_integer(acc)>=2) {
		r2=pop();
		fp = is_port(r2) ? obj_port(r2) : 1;
	} else  {
		fp = 1;
	}
	obj_display(acc=pop(), 0, fp);
	//fflush(fp);

	push(acc);
	ip=cdr(ip);
}
void prim_char_2_integer (void) {
BPUR;DB("prim_char_2_integer");
	new_integer((S64)*(unsigned char *)obj_symbol(pop()));

	push(acc);
	ip=cdr(ip);
}
void prim_char_upcase (void) {
 int len;
 char *str;
BPUR;DB("prim_char_upcase");
	r1 = pop();
	len = obj_symbol_len (r1);
	str = malloc(len);
	while (len) {
		len--;
		*(str+len) = toupper(*(obj_symbol(r1)+len));
	}
	new_string (str, obj_symbol_len(r1));
	free(str);

	push(acc);
	ip=cdr(ip);
}
void prim_integer_2_char (void) {
 static char c[2]={0};
BPUR;DB("prim_integer_2_char");
	*c = (char)obj_integer(pop());
	new_string(c, 1);

	push(acc);
	ip=cdr(ip);
}
void prim_number2string (void) {
 static char buff[80]={0};
 S64 num;
BPUR;DB1("prim_numbe2string", acc);
	switch(obj_integer(acc)>1 ? obj_integer(pop()) : 10) {
	 case 8 : num=obj_integer(pop());
	          if (num<0) sprintf(buff, "-%llo", num*-1);
	          else sprintf(buff, "%llo", num);
	          break;
	 case 16 : num=obj_integer(pop());
	          if (num<0) sprintf(buff, "-%llx", num*-1);
	          else sprintf(buff, "%llx", num);
	          break;
	 default: sprintf(buff, "%lld", obj_integer(pop()));
	}
	new_string(buff, strlen(buff));

	push(acc);
	ip=cdr(ip);
}
void prim_string2number (void) {
 char *t;
BPUR;DB1("prim_string2number", acc);
	if (obj_integer(acc) > 1) {
		switch(obj_integer(pop())) {
		 case 8 : new_integer(strtoll(t=symbol2string(pop()), NULL, 8));
		          break;
		 case 10 : new_integer(strtoll(t=symbol2string(pop()), NULL, 10));
		          break;
		 case 16 : new_integer(strtoll(t=symbol2string(pop()), NULL, 16));
		          break;
		}
	} else {
		new_integer(strtoll(t=symbol2string(pop()), NULL, 10));
	}
	free(t);

	push(acc);
	ip=cdr(ip);
}
void prim_string (void) {
 int len=0, count, i, sl;
BPUR;DB("prim_string");
	count = obj_integer(acc);
	/* ADD LENGTH OF ALL THE PASSED STRING'S (THEY BETTER BE STRINGS?) */
	for(i=0; i<count; i++) len += obj_symbol_len(stack_peek(i));
	mem_new_ary(TSTRING, len);r2=acc; /* CREATE THE EMPTY STRING */
	for(i=0; i<count; i++) { /* NOW COPY THEM INTO THE EMPTY STRING */
		acc=pop();
		sl = obj_symbol_len(acc);
		strncpy(obj_symbol(r2)+len-sl, obj_symbol(acc), sl);
		len-=sl;
	}
	acc=r2; /* NOT EMPTY ANY MORE, HUH. */

	push(acc);
	ip=cdr(ip);
}
void prim_string_length (void) {
BPUR;DB("prim_string_length");
	new_integer(obj_symbol_len(pop()));

	push(acc);
	ip=cdr(ip);
}
void prim_string_ref (void) {
 static char c[2]={0};
BPUR;DB("prim_string_ref");
	r2=pop(); 
	*c = *(obj_integer(r2) + obj_symbol(pop()));
	new_string(c, 1);

	push(acc);
	ip=cdr(ip);
}
void prim_substring (void) {
 static char *c;
 static int start, end;
BPUR;DB("prim_substring");
	end=obj_integer(pop());
   start=obj_integer(pop());
	if (start>=end) {
		acc=nullstr;
		pop();

		push(acc);
		ip=cdr(ip);
		return;
	}
	mem_new_ary(TSTRING, end-start); /* CREATE THE EMPTY STRING */
	c = start + obj_symbol(pop());
	memcpy((char*)mem_ary_ref(acc, 0), c, end-start);

	push(acc);
	ip=cdr(ip);
}
void prim_string_setb (void) {
BPUR;DB("prim_string_setb");
	r3=pop();
	r2=pop();
	r1=pop();
	strncpy (obj_symbol(r1)+obj_integer(r2), obj_symbol(r3), obj_len(r3));
	//*(obj_symbol(r1) + obj_integer(r2)) = *obj_symbol(r3);
	acc=r1;

	push(acc);
	ip=cdr(ip);
}
/* ALL PRIMITIVES EXPECT ARG COUNT IN ACC, ALL ARGUMENTS ON STACK
 * AND RETURN VALUE IN ACC
 */
void add_reals (int count, R64 r) {
BPUR;DB("add_reals");
	while (count--)
		if (is_real(r1=pop())) r += obj_real(r1);
		else r += (R64)obj_integer(r1);
	new_real(r);
}
void prim_add (void) {
 S64 t = 0;
BPUR;DB("prim_add");
	count = obj_integer(acc);
	while(count--)
		if (is_real(r1=pop())) {
			add_reals(count, obj_real(r1)+(R64)t);

			push(acc);
			ip=cdr(ip);
			return;
		} else
			t += obj_integer(r1);
	new_integer(t);

	push(acc);
	ip=cdr(ip);
}
void sub_reals (int count, R64 r) {
	while (count-- > 1)
		if (is_real(r1=pop())) r += obj_real(r1);
		else r+= (R64)obj_integer(r1);
	new_real((is_integer((r1=pop())) ? (R64)obj_integer(r1) : obj_real(r1)) - r);

	push(acc);
	ip=cdr(ip);
}
void prim_sub (void) {
 S64 t=0;
BPUR;DB("prim_sub");
	count = obj_integer(acc);
	if (count==0) {
		new_integer(0);

		push(acc);
		ip=cdr(ip);
		return;
	}

	if (count==1) {
		is_integer(r1=pop()) ? new_integer(-obj_integer(r1))
		                     : new_real(-obj_real(r1));

		push(acc);
		ip=cdr(ip);
		return;
	}

	while (count-- > 1)
		if(is_real(r1=pop())) {
			sub_reals(count, obj_real(r1)+t);

			push(acc);
			ip=cdr(ip);
			return;
		} else
			t += obj_integer(r1);

	if (is_integer(r1=pop())) new_integer(obj_integer(r1) - t);
	else new_real(obj_real(r1) - (R64)t);

	push(acc);
	ip=cdr(ip);
}
void prim_mul (void) {
 S64 t = 1;
 R64 r = 1.0;
BPUR;DB("prim_mul");
	count = obj_integer(acc);
	while(count--) {
		if (is_real(r1=pop())) {
			r *= obj_real(r1) * t;
			while(count--)
				r *= is_integer(r1=pop()) ? obj_integer(r1) : obj_real(r1);
			new_real(r);

			push(acc);
			ip=cdr(ip);
			return;
		} else t *= obj_integer(r1);
	}
	new_integer(t);

	push(acc);
	ip=cdr(ip);
}
void prim_div (void) {
 R64 r=1.0;
BPUR;DB("prim_div");
	count = obj_integer(acc);
	if (count==0) r=1;
	if (count==1) r=1.0/(is_real(r1=pop())?obj_real(r1):obj_integer(r1));
	else {
		r=(is_real(r1=pop())?obj_real(r1):(R64)obj_integer(r1));
		while (count-- > 2)
			r *= (is_real(r1=pop())?obj_real(r1):(R64)obj_integer(r1));
		r =  (is_real(r1=pop())?obj_real(r1):(R64)obj_integer(r1)) / r;
	}
	new_real(r);

	push(acc);
	ip=cdr(ip);
}
void prim_sin (void) {
BPUR;DB("prim_sin");
	new_real(sin(numberasreal(pop())));

	push(acc);
	ip=cdr(ip);
}
void prim_cos (void) {
BPUR;DB("prim_cos");
	new_real(cos(numberasreal(pop())));

	push(acc);
	ip=cdr(ip);
}
void prim_tan (void) {
BPUR;DB("prim_tan");
	new_real(tan(numberasreal(pop())));

	push(acc);
	ip=cdr(ip);
}
void prim_sqrt (void) {
BPUR;DB("prim_sqrt");
	new_real(sqrt(numberasreal(pop())));
	push(acc);
	ip=cdr(ip);
}
void prim_quotient (void) {
 S64 a,b;
BPUR;DB("prim_quotient");
	b = obj_integer(pop());
	a = obj_integer(pop());
	new_integer(a/b);

	push(acc);
	ip=cdr(ip);
}
void prim_modulo (void) {
 S64 a,b;
BPUR;DB("prim_modulo");
	b = obj_integer(pop()),
	a = obj_integer(pop());
	new_integer(((a>0^b>0?(-a/b+1)*b:0)+a)%b);

	push(acc);
	ip=cdr(ip);
}
void prim_remainder (void) {
BPUR;DB("prim_remainder");
	r2=pop();
	r1=pop();
	new_integer(obj_integer(r1) % obj_integer(r2));

	push(acc);
	ip=cdr(ip);
}
void prim_inexact2exact (void) {
BPUR;DB("prim_inexact2exact");
	new_integer(obj_real(pop())+0.5);

	push(acc);
	ip=cdr(ip);
}
void prim_logand (void) {
BPUR;DB("prim_logand");
	new_integer(obj_integer(pop()) & obj_integer(pop()));

	push(acc);
	ip=cdr(ip);
}
void prim_logor (void) {
BPUR;DB("prim_logor");
	new_integer(obj_integer(pop()) | obj_integer(pop()));

	push(acc);
	ip=cdr(ip);
}
void prim_logxor (void) {
BPUR;DB("prim_logxor");
	new_integer(obj_integer(pop()) ^ obj_integer(pop()));

	push(acc);
	ip=cdr(ip);
}
void prim_not (void) {
BPUR;DB("prim_not");
	acc = pop() != false ? false : true;

	push(acc);
	ip=cdr(ip);
}
void prim_equality (void) {
BPUR;DB("prim_equality");
	acc=(numberasreal(pop())==numberasreal(pop()) ? true : false);

	push(acc);
	ip=cdr(ip);
}
void prim_greaterthan (void) {
BPUR;DB("prim_greaterthan");
	acc=(numberasreal(pop())<numberasreal(pop()) ? true : false);

	push(acc);
	ip=cdr(ip);
}
void prim_greaterthanequal (void) {
BPUR;DB("prim_greaterthanequal");
	acc=(numberasreal(pop())<=numberasreal(pop()) ? true : false);

	push(acc);
	ip=cdr(ip);
}
void prim_lessthan (void) {
BPUR;DB("prim_lessthan");
	acc=(numberasreal(pop())>numberasreal(pop()) ? true : false);

	push(acc);
	ip=cdr(ip);
}
void prim_lessthanequal (void) {
BPUR;DB("prim_lessthanequal");
	acc=(numberasreal(pop())>=numberasreal(pop()) ? true : false);

	push(acc);
	ip=cdr(ip);
}
void prim_eqp (void) {
 int t1, t2;
BPUR;DB("prim_eqp");
	r2=pop(); r1=pop();
	acc=( (r1 == r2) ||
         ((t1=obj_type(r2)) == (t2=obj_type(r1)) &&
	       (((t1 == TSYMBOL || t1==TSTRING)
			   && obj_symbol_len(r1) == obj_symbol_len(r2)
			   && !strncmp(obj_symbol(r1), obj_symbol(r2), obj_symbol_len(r1))) ||
	        (t1 == TINTEGER && (obj_integer(r1) == obj_integer(r2))) ||
	        (t1 == TPAIR) ||
	        (t1 == TVECTOR) ||
	        (t1 == TCLOSURE)))
	    ? true : false );

	push(acc);
	ip=cdr(ip);
}
void prim_vector (void) {
 U32 count;
BPUR;DB("vector");
	new_vector(count=obj_integer(acc));
	r2=acc;
	while(count--) mem_vec_set(r2, count, pop());

	push(acc);
	ip=cdr(ip);
}
void prim_make_vector (void) {
 U32 count;
BPUR;DB("make_vector");
	if (obj_integer(acc)>1) {
		r2=pop();
		new_vector(count=obj_integer(pop()));
		while (count--) mem_vec_set(acc, count, r2);
	} else {
		new_vector(count=obj_integer(pop()));
	}

	push(acc);
	ip=cdr(ip);
}
void prim_vector_length (void) {
BPUR;DB("vector_length");
	r1=pop();
	new_integer(r1==nullvec?0:obj_vector_len(r1));

	push(acc);
	ip=cdr(ip);
}
void prim_vector_ref (void) {
BPUR;DB("vector_ref");
	if (obj_integer(acc)==2) {
		r2=pop();
		if (is_integer(r2)) {
			r1=pop();
			if (is_vector(r1))
				acc=*obj_vector_ref(r1, obj_integer(r2));
			else {
				printf ("*WARNING* prim_vector_ref: wrong argument types");
				obj_dump(r1,0);
				obj_dump(r2,0);
				acc=null;
			}
		} else {
			printf ("*WARNING* prim_vector_ref: wrong argument types");
			r1=pop();
			obj_dump(r1,0);
			obj_dump(r2,0);
			acc=null;
		}
	} else {
		printf ("*WARNING* prim_vector_ref: wrong count");
		acc=null;
	}

	push(acc);
	ip=cdr(ip);
}
void prim_vector_setb (void) {
BPUR;DB("vector_setb");
	r3=pop();
	r2=pop();
	acc=(*obj_vector_ref(pop(), obj_integer(r2))=r3);

	push(acc);
	ip=cdr(ip);
}
void prim_cons (void) {
BPUR;DB("cons");
	new_pair();

	push(acc);
	ip=cdr(ip);
}
void prim_set_carb (void) {
BPUR;DB("prim_set_carb");
	r2=pop();
	r1=pop();
	mem_vec_set(r1, 0, r2);
	acc=r2;

	push(acc);
	ip=cdr(ip);
}
void prim_set_cdrb (void) {
BPUR;DB("prim_set_cdrb");
	r2=pop();
	r1=pop();
	mem_vec_set(r1, 1, r2);
	acc=r2;

	push(acc);
	ip=cdr(ip);
}
void prim_car (void) {
BPUR;DB("prim_car");
	acc=car(pop());

	push(acc);
	ip=cdr(ip);
}
void prim_cdr (void) {
BPUR;DB("prim_cdr");
	acc=cdr(pop());

	push(acc);
	ip=cdr(ip);
}
void prim_nullp (void) {
BPUR;DB("prim_nullp");
	acc=pop()==null?true:false;

	push(acc);
	ip=cdr(ip);
}
void prim_pairp (void) {
BPUR;DB("prim_pairp");
	acc=is_pair(pop())?true:false;

	push(acc);
	ip=cdr(ip);
}
void prim_vectorp (void) {
BPUR;DB("prim_vectorp");
	acc=is_vector(pop())?true:false;

	push(acc);
	ip=cdr(ip);
}
void prim_stringp (void) {
BPUR;DB("prim_stringp");
	acc=is_string(pop())?true:false;

	push(acc);
	ip=cdr(ip);
}
void prim_symbolp (void) {
BPUR;DB("prim_symbolp");
	acc=is_symbol(pop())?true:false;

	push(acc);
	ip=cdr(ip);
}
void prim_portp (void) {
BPUR;DB("prim_portp");
	acc=pop();
	acc=(is_port(acc))?true:false;

	push(acc);
	ip=cdr(ip);
}
void prim_eof_objectp (void) {
BPUR;DB("prim_eof_objectp");
	acc=is_eof(pop())?true:false;

	push(acc);
	ip=cdr(ip);
}
void prim_random (void) {
BPUR;DB("prim_random");
	new_integer((S64)(obj_integer(pop())*random()/(double)(RAND_MAX)));

	push(acc);
	ip=cdr(ip);
}
#include <sys/stat.h> // FOR S_IRWXU
void prim_open_file (void) {
 int fp;
 char *filename;
 int flags, mode;
BPUR;DB("prim_open_file");
	mode     = S_IRWXU;
	flags    = obj_integer(pop());
	filename = symbol2string(pop());
	fp = open(filename, flags, mode);
	if (fp==-1) {
		//printf ("*WARNING* CAN'T OPEN FILE: "); obj_dump(r1,0);
      //printf (" AS: ");  obj_dump(r2,0);
		acc=null;
	} else new_port(fp, filename, flags, mode);

	push(acc);
	ip=cdr(ip);
}
void prim_lock_file (void) {
BPUR;DB("prim_lock_file");
	acc = flock(obj_port(pop()), LOCK_EX|LOCK_NB)?false:true;

	push(acc);
	ip=cdr(ip);
}
void prim_unlock_file (void) {
BPUR;DB("prim_unlock_file");
	acc = flock(obj_port(pop()), LOCK_UN|LOCK_NB)?false:true;

	push(acc);
	ip=cdr(ip);
}


void prim_tell_port (void) {
BPUR;DB("prim_tell_port");
	new_integer(lseek(obj_port(pop()), 0, SEEK_CUR));
	push(acc);
	ip=cdr(ip);
}
void prim_seek_port (void) {
 S32 n;
BPUR;DB("prim_seek_port");
	n = (long)obj_integer(r2=pop());
	r1=pop();
	if (n>=0) lseek(obj_port(r1), n, SEEK_SET);
	else lseek(obj_port(r1), -n-1, SEEK_END);
	acc=r2;

	push(acc);
	ip=cdr(ip);
}
void prim_close_port (void) {
BPUR;DB("prim_close_port");
	close_port(mem_drt_ref(pop(), 0));
	acc=null;

	push(acc);
	ip=cdr(ip);
}
void prim_call_cc (void) {
BPUR;DB("primitive_call_cc");
	r2=pop(); /* FUNCTION GETTING CONTINUATION */
	new_continuation(); push(acc); /* PASS THIS CONTINUATION... */
		/* SETUP FOR THE REMAINING OP_APPLY CODE */
		push(null); push(ip); new_pair(); ip=acc;
	acc=r2;                        /* ...TO THIS FUNCTION */

	push(acc);
	ip=cdr(ip);
}

void prim_send (void) {
 char *s;
BPUR;DB("prim_send");
	r2 = pop();
	r1 = pop();
	if (-1 == send(obj_integer(r1), obj_symbol(r2), obj_symbol_len(r2), 0)) {
		s = (char *)strerror(errno);
		new_string (s, strlen(s));
	}
	else new_string ("ok", 2);

	push(acc);
	ip=cdr(ip);
}

void prim_recv (void) {
 char s[8192];
BPUR;DB("prim_recv");
	r1 = pop();
	if (-1 == read(obj_integer(r1), s, 8192))
		new_symbol ((char*)strerror(errno), strlen(s));
	else new_string (s, strlen(s));

	push(acc);
	ip=cdr(ip);
}

void prim_open_ear (void) {
 int fd, fd2, on=1;
 struct sockaddr_in sai;
 struct sockaddr sa;
 socklen_t salen;
 char *s;
BPUR;DB("prim_open_ear");

	r1 = pop();

	fd = socket(PF_INET, SOCK_STREAM, 0);
	if (-1 == fd) {
		new_string("SOCKET ERROR", 12);

		push(acc);
		ip=cdr(ip);
		return;
	}

	if (-1 == setsockopt (fd, SOL_SOCKET, SO_REUSEADDR, &on, sizeof(int))) {
		printf ("WARNING:  setsockopt error\r\n");
	}

	sai.sin_family = AF_INET;
	sai.sin_port = htons(obj_integer(r1));
	sai.sin_addr.s_addr = htons(INADDR_ANY);
	if (-1 == bind (fd, &sai, sizeof(sai))) {
		printf ("WARNING:  bind error\r\n");
		s = (char*)strerror(errno);
		new_string (s, strlen(s));

		push(acc);
		ip=cdr(ip);
		return;
	}


	if (-1 == listen(fd, 0)) {
		new_string("LISTEN ERROR", 12);
		push(acc);
		ip=cdr(ip);
		return;
	}

	if (-1 == (fd2=accept(fd, &sa, &salen))) {
		new_string("ACCEPT ERROR", 12);
		push(acc);
		ip=cdr(ip);
		return;
	}

	fcntl (fd2, 10, SIGINT);
	
	if (-1 == close(fd)) {
		printf ("WARNING:  close error\r\n");
		s = (char*)strerror(errno);
		new_string (s, strlen(s));
		push(acc);
		ip=cdr(ip);
		return;
	}

	new_integer(fd2);
	push(acc);
	ip=cdr(ip);
}