/* xlprint - xlisp print routine */
/*		Copyright (c) 1985, by David Michael Betz
		All Rights Reserved
		Permission is granted for unrestricted non-commercial use		*/

#include "xlisp.h"
#include <string.h>

/* external variables */
extern LVAL s_printcase,k_downcase,k_const,k_nmacro;
extern LVAL s_ifmt,s_ffmt;
extern LVAL obarray;
extern FUNDEF funtab[];
extern char buf[];
#ifdef PRINDEPTH
extern LVAL s_printlevel, s_printlength;		/* TAA mod */
#endif

/* forward declarations */
#ifdef ANSI
void putsymbol(LVAL fptr, char *str, int escflag);
void putstring(LVAL fptr, LVAL str);
void putqstring(LVAL fptr, LVAL str);
void putatm(LVAL fptr, char *tag, LVAL val);
void putsubr(LVAL fptr, char *tag, LVAL val);
void putclosure(LVAL fptr, LVAL val);
void putfixnum(LVAL fptr, FIXTYPE n);
void putflonum(LVAL fptr, FLOTYPE n);
void putchcode(LVAL fptr, int ch, int escflag);
void putoct(LVAL fptr, int n);
#else
FORWARD VOID putsymbol();
FORWARD VOID putstring();
FORWARD VOID putqstring();
FORWARD VOID putatm();
FORWARD VOID putsubr();
FORWARD VOID putclosure();
FORWARD VOID putfixnum();
FORWARD VOID putflonum();
FORWARD VOID putchcode();
FORWARD VOID putoct();
#endif

#ifdef PRINDEPTH
#ifdef ANSI
void xlprintl(LVAL fptr, LVAL vptr, int flag);
#else
FORWARD VOID xlprintl();
#endif

FIXTYPE plevel,plength;

/* xlprint - print an xlisp value */
VOID xlprint(fptr,vptr,flag)
  LVAL fptr,vptr; int flag;
{
	LVAL temp;
	temp = getvalue(s_printlevel);
	if (fixp(temp)) {
		plevel = getfixnum(temp);
	}
	else {
		plevel = 32767;
	}
	temp = getvalue(s_printlength);
	if (fixp(temp)) {
		plength = getfixnum(temp);
	}
	else
		plength = 32767;
	xlprintl(fptr,vptr,flag);
}
				
VOID xlprintl(fptr,vptr,flag)
#else
#define xlprintl xlprint				/* alias */
VOID xlprint(fptr,vptr,flag)
#endif
  LVAL fptr,vptr; int flag;
{
	LVAL nptr,next;
	int n,i;
#ifdef PRINDEPTH
		FIXTYPE llength;
#endif

	/* print nil */
	if (vptr == NIL) {
		xlputstr(fptr,
			(((!flag) || (getvalue(s_printcase) != k_downcase))?"NIL":"nil"));
		return;
	}

	/* check value type */
	switch (ntype(vptr)) {
	case SUBR:
			putsubr(fptr,"Subr",vptr);
			break;
	case FSUBR:
			putsubr(fptr,"FSubr",vptr);
			break;
	case CONS:
#ifdef PRINDEPTH
			if (plevel-- == 0) {			/* depth limitation */
				xlputc(fptr,'#');
				plevel++;
				break;
			}
#endif
			xlputc(fptr,'(');
#ifdef PRINDEPTH
			llength = plength;
#endif
			for (nptr = vptr; nptr != NIL; nptr = next) {
#ifdef PRINDEPTH
				if (llength-- == 0) { /* length limitiation */
					xlputstr(fptr,"... ");
					break;
				}
#endif
				xlprintl(fptr,car(nptr),flag);
				if ((next = cdr(nptr)) != 0)
					if (consp(next))
						xlputc(fptr,' ');
					else {
						xlputstr(fptr," . ");
						xlprintl(fptr,next,flag);
						break;
					}
			}
			xlputc(fptr,')');
#ifdef PRINDEPTH
			plevel++;
#endif
			break;
	case SYMBOL:
			putsymbol(fptr,(char *)getstring(getpname(vptr)),flag);
			break;
	case FIXNUM:
			putfixnum(fptr,getfixnum(vptr));
			break;
	case FLONUM:
			putflonum(fptr,getflonum(vptr));
			break;
	case CHAR:
			putchcode(fptr,getchcode(vptr),flag);
			break;
	case STRING:
			if (flag)
				putqstring(fptr,vptr);
			else
				putstring(fptr,vptr);
			break;
	case STREAM:
			putatm(fptr,"File-Stream",vptr);
			break;
	case USTREAM:
			putatm(fptr,"Unnamed-Stream",vptr);
			break;
	case OBJECT:
#ifdef OBJPRNT
			/* putobj fakes a (send obj :prin1 file) call */
			putobj(fptr,vptr);
#else
			putatm(fptr,"Object",vptr);
#endif
			break;
	case VECTOR:
#ifdef PRINDEPTH
			if (plevel-- == 0) {			/* depth limitation */
				xlputc(fptr,'#');
				plevel++;
				break;
			}
#endif
			xlputc(fptr,'#'); xlputc(fptr,'(');
#ifdef PRINDEPTH
			llength = plength;
#endif
			for (i = 0, n = getsize(vptr); n-- > 0; ) {
#ifdef PRINDEPTH
				if (llength-- == 0) { /* length limitiation */
					xlputstr(fptr,"... ");
					break;
				}
#endif
				xlprintl(fptr,getelement(vptr,i++),flag);
				if (n) xlputc(fptr,' ');
			}
			xlputc(fptr,')');
#ifdef PRINDEPTH
			plevel++;
#endif
			break;
#ifdef STRUCTS
	case STRUCT:
			xlprstruct(fptr,vptr,flag);
			break;
#endif
	case CLOSURE:
			putclosure(fptr,vptr);
			break;
	case FREE:
			putatm(fptr,"Free",vptr);
			break;
	default:
			putatm(fptr,"Unknown",vptr);		/* was 'Foo`   TAA Mod */
			break;
	}
}

/* xlterpri - terminate the current print line */
VOID xlterpri(fptr)
  LVAL fptr;
{
	xlputc(fptr,'\n');
}

/* xlputstr - output a string */
VOID xlputstr(fptr,str)
  LVAL fptr; char *str;
{
	while (*str)
		xlputc(fptr,*str++);
}

/* putsymbol - output a symbol */
LOCAL VOID putsymbol(fptr,str,escflag)
  LVAL fptr; char *str; int escflag;
{
	int downcase;
	LVAL type;
	char *p,c;

#ifdef COMMONLISP
	int i;
	LVAL sym,array;
#endif

	/* check for printing without escapes */
	if (!escflag) {
		xlputstr(fptr,str);
		return;
	}

#ifdef COMMONLISP
	/* check for uninterned symbol -- TAA fix */
	i = hash(str,HSIZE);
	array = getvalue(obarray);
	for (sym = getelement(array,i);sym; sym = cdr(sym))
		if (strcmp(str,(char*)getstring(getpname(car(sym)))) == 0)
			goto internedSymbol;
		
	xlputc(fptr,'#');		/* indicate uninterned */
	xlputc(fptr,':');

internedSymbol:
#endif
	/* check to see if symbol needs escape characters */
/*	if (tentry(*str) == k_const) {*/	/* always execute this code! TAA Mod*/
		for (p = str; *p; ++p)
			if (islower(*p)
			||	((type = tentry(*p)) != k_const
			  && (!consp(type) || car(type) != k_nmacro))) {
				xlputc(fptr,'|');
				while (*str) {
					if (*str == '\\' || *str == '|')
						xlputc(fptr,'\\');
					xlputc(fptr,*str++);
				}
				xlputc(fptr,'|');
				return;
			}
/*	} */

	/* get the case translation flag */
	downcase = (getvalue(s_printcase) == k_downcase);

	/* check for the first character being '#' */
	if (*str == '#' || isnumber(str,NULL))
		xlputc(fptr,'\\');

	/* output each character */
	while ((c = *str++) != 0) {
		/* don't escape colon until we add support for packages */
		if (c == '\\' || c == '|' /* || c == ':' */)
			xlputc(fptr,'\\');
		xlputc(fptr,(downcase && isupper(c) ? tolower(c) : c));
	}
}

/* putstring - output a string */
/* rewritten to	 print strings containing nulls TAA mod*/
LOCAL VOID putstring(fptr,str)
  LVAL fptr,str;
{
	char* p = getstring(str);
	int len = getslength(str) - 1;

	/* output each character */
	while (len-- > 0) xlputc(fptr,*p++);
}

/* putqstring - output a quoted string */
/* rewritten to	 print strings containing nulls TAA mod*/
LOCAL VOID putqstring(fptr,str)
  LVAL fptr,str;
{
	char* p = getstring(str);
	int len = getslength(str) - 1;
	int ch;

	/* output the initial quote */
	xlputc(fptr,'"');

	/* output each character in the string */
	while (len-- > 0) {
		ch = *(unsigned char *)p++;

		/* check for a control character */
		if (ch < 040 || ch == '\\' || ch == '"' || ch > 0176) { /* TAA MOD quote quote */
			xlputc(fptr,'\\');
			switch (ch) {
				case '\011':
					xlputc(fptr,'t');
					break;
				case '\012':
					xlputc(fptr,'n');
					break;
				case '\014':
					xlputc(fptr,'f');
					break;
				case '\015':
					xlputc(fptr,'r');
					break;
				case '\\':
			    case '"':
					xlputc(fptr,ch);
					break;
				default:
					putoct(fptr,ch);
					break;
			}
		}

				/* output a normal character */
		else
			xlputc(fptr,ch);
	}


	/* output the terminating quote */
	xlputc(fptr,'"');
}

/* putatm - output an atom */
LOCAL VOID putatm(fptr,tag,val)
  LVAL fptr; char *tag; LVAL val;
{
	sprintf(buf,"#<%s: #",tag); xlputstr(fptr,buf);
	sprintf(buf,AFMT,val); xlputstr(fptr,buf);
	xlputc(fptr,'>');
}

/* putsubr - output a subr/fsubr */
LOCAL VOID putsubr(fptr,tag,val)
  LVAL fptr; char *tag; LVAL val;
{
/*	  sprintf(buf,"#<%s-%s: #",tag,funtab[getoffset(val)].fd_name); */
	char *str;		/* TAA mod */
	if ((str = funtab[getoffset(val)].fd_name) != 0)
		sprintf(buf,"#<%s-%s: #",tag,str);
	else
		sprintf(buf,"#<%s: #",tag);
	xlputstr(fptr,buf);
	sprintf(buf,AFMT,val); xlputstr(fptr,buf);
	xlputc(fptr,'>');
}

/* putclosure - output a closure */
LOCAL VOID putclosure(fptr,val)
  LVAL fptr,val;
{
	LVAL name;
	if ((name = getname(val)) != 0)
		sprintf(buf,"#<Closure-%s: #",getstring(getpname(name)));
	else
		strcpy(buf,"#<Closure: #");
	xlputstr(fptr,buf);
	sprintf(buf,AFMT,val); xlputstr(fptr,buf);
	xlputc(fptr,'>');
}

/* putfixnum - output a fixnum */
LOCAL VOID putfixnum(fptr,n)
  LVAL fptr; FIXTYPE n;
{
	char *fmt;
	LVAL val;
	fmt = (((val = getvalue(s_ifmt)) != 0) && stringp(val) ? getstring(val)
		: IFMT);
	sprintf(buf,(char *)fmt,n);
	xlputstr(fptr,buf);
}

/* putflonum - output a flonum */
LOCAL VOID putflonum(fptr,n)
  LVAL fptr; FLOTYPE n;
{
	char *fmt;
	LVAL val;
	fmt = (((val = getvalue(s_ffmt)) != 0) && stringp(val) ? getstring(val)
		: "%g");
	sprintf(buf,(char *)fmt,n);
	xlputstr(fptr,buf);
}

/* putchcode - output a character */
/* modified to print control and meta characters TAA Mod */
LOCAL VOID putchcode(fptr,ch,escflag)
  LVAL fptr; int ch,escflag;
{
	if (escflag) {
		xlputstr(fptr,"#\\");
		if (ch > 127) {
			ch -= 128;
			xlputstr(fptr,"M-");
		}
		switch (ch) {
			case '\n':
				xlputstr(fptr,"Newline");
				break;
			case ' ':
				xlputstr(fptr,"Space");
				break;
			case 127:
				xlputstr(fptr,"Rubout");
				break;
			default:
				if (ch < 32) {
					ch += '@';
					xlputstr(fptr,"C-");
				}
				xlputc(fptr,ch);
				break;
		}
	}
	else xlputc(fptr,ch);
}

/* putoct - output an octal byte value */
LOCAL VOID putoct(fptr,n)
  LVAL fptr; int n;
{
	sprintf(buf,"%03o",n);
	xlputstr(fptr,buf);
}