/* xlprint - xlisp print routine */
/* Copyright (c) 1989, by David Michael Betz.                            */
/* You may give out copies of this software; for conditions see the file */
/* COPYING included with this distribution.                              */

#include <string.h>
#include "xlisp.h"
#include "osdef.h"
#ifdef ANSI
#include "xlproto.h"
#include "xlsproto.h"
#else
#include "xlfun.h"
#include "xlsfun.h"
#endif ANSI
#include "xlvar.h"

/* forward declarations */
#ifdef ANSI
void putoct(LVAL,int),putchcode(LVAL,int,int),putflonum(LVAL,FLOTYPE),
     putfixnum(LVAL,FIXTYPE),putclosure(LVAL,LVAL),putsubr(LVAL,char *,LVAL),
     putatm(LVAL,char *,LVAL),putqstring(LVAL,LVAL),putstring(LVAL,LVAL),
     putsymbol(LVAL,char *,int);
#else
void putoct(),putchcode(),putflonum(),
     putfixnum(),putclosure(),putsubr(),
     putatm(),putqstring(),putstring(),
     putsymbol();
#endif ANSI

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

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

#ifndef XLISP_ONLY
/*************************************************************************/
/*         Lines below added to allow for common lisp arrays             */
/*         Luke Tierney, March 1, 1988                                   */
/*************************************************************************/

if (displacedarrayp(vptr)) {
	putarray(fptr, vptr, flag);
	return;
}
	
/*************************************************************************/
/*        Lines above added to allow for common lisp arrays              */
/*        Luke Tierney, March 1, 1988                                    */
/*************************************************************************/
#endif /* XLISP_ONLY */
    /* 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,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:
#ifndef XLISP_ONLY
    	if (mobject_p(vptr)) { print_mobject(vptr, fptr); break; } /* L. Tierney */
#else
	    putatm(fptr,"Object",vptr);
	    break;
#endif /* XLISP_ONLY */
    case VECTOR:
	    xlputc(fptr,'#'); xlputc(fptr,'(');
	    for (i = 0, n = getsize(vptr) - 1; i <= n; ++i) {
		xlprint(fptr,getelement(vptr,i),flag);
		if (i != n) xlputc(fptr,' ');
	    }
	    xlputc(fptr,')');
	    break;
    case STRUCT:
	    xlprstruct(fptr,vptr,flag);
	    break;
    case CLOSURE:
	    putclosure(fptr,vptr);
	    break;
	case COMPLEX:   /* L. Tierney */
	    xlputc(fptr, '#');
	    xlputc(fptr, (getvalue(s_printcase) == k_downcase) ? 'c' : 'C'); 
	    xlputc(fptr, '(');
	    xlprint(fptr, getelement(vptr, 0), flag);
	    xlputc(fptr,' ');
	    xlprint(fptr, getelement(vptr, 1), flag);
	    xlputc(fptr, ')');
	    break;
	case ALLOCATED_DATA:  /* L. Tierney */
	    putatm(fptr,"Data",vptr);
	    break;
    case FREE:
	    putatm(fptr,"Free",vptr);
	    break;
    default:
	    putatm(fptr,"Foo",vptr);
	    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,ch;
    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 ((ch = *str++) != '\0') {
	/* don't escape colon until we add support for packages */
	if (ch == '\\' || ch == '|' /* || ch == ':' */)
	    xlputc(fptr,'\\');
	xlputc(fptr,(downcase && isupper(ch) ? tolower(ch) : ch));
    }
}

/* putstring - output a string */
LOCAL void putstring(fptr,str)
  LVAL fptr,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(fptr,str)
  LVAL fptr,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 */
	/* added double quote - Luke Tierney */
	/* removed newline - Luke Tierney */
	if (ch != '\n' && (ch < 040 || ch == '\\' || ch > 0176 || ch == '"')) {
	    xlputc(fptr,'\\');
	    switch (ch) {
	    case '"':                      /* added double quote - Luke Tierney */
		    xlputc(fptr,'"');
		    break;
	    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 */
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 *//* modified for nil names - L. Tierney */
LOCAL void putsubr(fptr,tag,val)
  LVAL fptr; char *tag; LVAL val;
{
    char *name = funtab[getoffset(val)].fd_name;
    if (! name) name = "(internal)";
    sprintf(buf,"#<%s-%s: #",tag,name);
    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))
	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,getenv(val),TRUE);
    xlputstr(fptr,"\nFenv:   "); xlprint(fptr,getfenv(val),TRUE);
*/
}

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

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

/* putchcode - output a character */
LOCAL void putchcode(fptr,ch,escflag)
  LVAL fptr; int ch,escflag;
{
    if (escflag) {
	switch (ch) {
	case '\n':
	    xlputstr(fptr,"#\\Newline");
	    break;
	case ' ':
	    xlputstr(fptr,"#\\Space");
	    break;
#ifdef MACINTOSH /* lines added by Luke Tierney, March 12, 1988 */
	case 0x12: xlputstr(fptr, "#\\Check"); break;
	case 0x14: xlputstr(fptr, "#\\Apple"); break;
#endif MACINTOSH /* lines added by Luke Tierney, March 12, 1988 */
	default:
	    sprintf(buf,"#\\%c",ch);
	    xlputstr(fptr,buf);
	    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);
}