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

 * HISTORY
 * 3-Apr-88	Dale Amon at CMU-CSD
 *	Added extern support to xlisp 2.0
 *
 * 18-Oct-87	Dale Amon at CMU-CSD
 *	Added print support for EXTERN nodes
 */


#include "string.h"
#include "xlisp.h"

/* external variables */
extern LVAL s_printcase,k_downcase,k_const,k_nmacro;
extern LVAL s_ifmt,s_ffmt;
extern FUNDEF funtab[];
extern char buf[];

LOCAL void putsymbol(LVAL fptr, char *str, int escflag);
LOCAL void putsubr(LVAL fptr, char *tag, LVAL val);
LOCAL void putfixnum(LVAL fptr, FIXTYPE n);
LOCAL void putflonum(LVAL fptr, FLOTYPE n);
LOCAL void putchcode(LVAL fptr, int ch, int escflag);
LOCAL void putstring(LVAL fptr, LVAL str);
LOCAL void putqstring(LVAL fptr, LVAL str);
void putatm(LVAL fptr, char *tag, LVAL val);
LOCAL void putclosure(LVAL fptr, LVAL val);
LOCAL void putoct(LVAL fptr, int n);


/* xlprint - print an xlisp value */
void xlprint(LVAL fptr, LVAL vptr, int flag)
{
    LVAL nptr,next;
    int n,i;

    /* print nil */
    if (vptr == NIL) {
	putsymbol(fptr,"NIL",flag);
	return;
    }

    /* check value type */
    switch (ntype(vptr)) {
    case SUBR:
	    putsubr(fptr,"Subr",vptr);
	    break;
    case FSUBR:
	    putsubr(fptr,"FSubr",vptr);
	    break;
    case CONS:
	    xlputc(fptr,'(');
	    for (nptr = vptr; nptr != NIL; nptr = next) {
	        xlprint(fptr,car(nptr),flag);
		if (next = cdr(nptr))
		    if (consp(next))
			xlputc(fptr,' ');
		    else {
			xlputstr(fptr," . ");
			xlprint(fptr,next,flag);
			break;
		    }
	    }
	    xlputc(fptr,')');
	    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:
	    putatm(fptr,"Object",vptr);
	    break;
    case VECTOR:
	    xlputc(fptr,'#'); xlputc(fptr,'(');
	    for (i = 0, n = getsize(vptr); n-- > 0; ) {
		xlprint(fptr,getelement(vptr,i++),flag);
		if (n) xlputc(fptr,' ');
	    }
	    xlputc(fptr,')');
	    break;
    case CLOSURE:
	    putclosure(fptr,vptr);
	    break;
    case EXTERN:
	    if (getdesc(vptr)) {
		(*(getdesc(vptr)->print_meth))(fptr, getinst(vptr));
	    }
	    break;
    case FREE_NODE:
	    putatm(fptr,"Free",vptr);
	    break;
    default:
	    putatm(fptr,"Foo",vptr);
	    break;
    }
}

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

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

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

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

    /* check to see if symbol needs escape characters */
    if (tentry(*str) == k_const) {
	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 == '#' || *str == '.' || isnumber(str,NULL))
	xlputc(fptr,'\\');

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

/* putstring - output a string */
LOCAL void putstring(LVAL fptr, LVAL str)
{
    unsigned char *p;
    int ch;

    /* output each character */
    for (p = getstring(str); (ch = *p) != '\0'; ++p)
	xlputc(fptr,ch);
}

/* putqstring - output a quoted string */
LOCAL void putqstring(LVAL fptr, LVAL str)
{
    unsigned char *p;
    int ch;

    /* get the string pointer */
    p = getstring(str);

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

    /* output each character in the string */
    for (p = getstring(str); (ch = *p) != '\0'; ++p)

	/* check for a control character */
	if (ch < 040 || ch == '\\' || ch > 0176) {
	    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 '\\':
		    xlputc(fptr,'\\');
		    break;
	    default:
		    putoct(fptr,ch);
		    break;
	    }
	}

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

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

/* putatm - output an atom */
void putatm(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(LVAL fptr, char *tag, LVAL val)
{
    sprintf(buf,"#<%s-%s: #",tag,funtab[getoffset(val)].fd_name);
    xlputstr(fptr,buf);
    sprintf(buf,AFMT,val); xlputstr(fptr,buf);
    xlputc(fptr,'>');
}

/* putclosure - output a closure */
LOCAL void putclosure(LVAL fptr, LVAL val)
{
    LVAL name;
    if (name = getname(val))
	sprintf(buf,"#<Closure-%s: #",getstring(getpname(name)));
    else
	strcpy(buf,"#<Closure: #");
    xlputstr(fptr,buf);
    sprintf(buf,AFMT,val); xlputstr(fptr,buf);
    xlputc(fptr,'>');
/*
    xlputstr(fptr,"\nName:   "); xlprint(fptr,getname(val),TRUE);
    xlputstr(fptr,"\nType:   "); xlprint(fptr,gettype(val),TRUE);
    xlputstr(fptr,"\nLambda: "); xlprint(fptr,getlambda(val),TRUE);
    xlputstr(fptr,"\nArgs:   "); xlprint(fptr,getargs(val),TRUE);
    xlputstr(fptr,"\nOargs:  "); xlprint(fptr,getoargs(val),TRUE);
    xlputstr(fptr,"\nRest:   "); xlprint(fptr,getrest(val),TRUE);
    xlputstr(fptr,"\nKargs:  "); xlprint(fptr,getkargs(val),TRUE);
    xlputstr(fptr,"\nAargs:  "); xlprint(fptr,getaargs(val),TRUE);
    xlputstr(fptr,"\nBody:   "); xlprint(fptr,getbody(val),TRUE);
    xlputstr(fptr,"\nEnv:    "); xlprint(fptr,closure_getenv(val),TRUE);
    xlputstr(fptr,"\nFenv:   "); xlprint(fptr,getfenv(val),TRUE);
*/
}

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

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

/* putchcode - output a character */
LOCAL void putchcode(LVAL fptr, int ch, int escflag)
{
    if (escflag) {
	switch (ch) {
	case '\n':
	    xlputstr(fptr,"#\\Newline");
	    break;
	case ' ':
	    xlputstr(fptr,"#\\Space");
	    break;
	case '\t':
	    xlputstr(fptr, "#\\Tab");
	    break;
	default:
	    sprintf(buf,"#\\%c",ch);
	    xlputstr(fptr,buf);
	    break;
	}
    }
    else
	xlputc(fptr,ch);
}

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