/*                                                      =====> SPRINT.C      */
/* TIPC Scheme '84 Runtime Support - S-Expression Printing
   (C) Cop[yright 1984,1985 by Texas Instruments Incorporated.
   All rights reserved.

   Author:  Mark E. Meyer
   Installation:  Texas Instruments Incorporated, Dallas, Texas
   Division:  Central Research Laboratories
   Cost Center:  Computer Science Laboratory
   Project:  Computer Architecture Branch
   Date Written:  13 June 1984
   Last Modification:  10 Feb 1987 by Terry Caudill

   Modification History:

    tc	2/10/87 modified PRINT-ATOM to recognize special atoms
		such as #T, #F, etc.

*/

#include "scheme.h"
/*******
#include "schars.h"
*********************/
extern char decpoint;  /* The current decimal point character */

extern int ccount;
extern int show;
extern int display;
/***********
static int ccount = 0;  /* Character count */
static int display = TRUE;  /* Whether to use | and " */
static int show = TRUE;    /* Whether to send actual characters */
static int detail = TRUE;  /* Whether to show details */

/***************************************************************/
/*         SPRINT(pg,ds,ppg,pds,dmode,smode,dtmode)            */
/*      Given a logical (0,1,2,...) page PG and a displacement */
/* DS, SPRINT prints the s-expression representing the object  */
/* at that location, through the port at (PPG,PDS).  SPRINT is */
/* recursive, and will go into an infinite loop if the         */
/* structure has a loop in it.  Only atoms and lists are       */
/* printed as they are; other data types are printed as, for   */
/* example, <ARRAY>.  SPRINT returns the number of characters  */
/* needed to print the item, not counting | around atoms and   */
/* " around strings.                                           */
/***************************************************************/
sprint(pg,ds,ppg,pds,dmode,smode,dtmode)
int pg,ds;        /* Location of item to be printed */
int ppg,pds;      /* Location of output port */
int dmode;        /* If TRUE, use | and " */
int smode;        /* If FALSE, do not print characters, only ocunt them */
int dtmode;       /* If TRUE, print details of unprintables */
 {
  setabort();
  setadr(ppg,pds,0);  /* Set port & make sure it's for output */
  ccount = 0;
  display = dmode;
  show = smode;
  detail = dtmode;
  subsprint(pg,ds);
  return(ccount);
 }


subsprint(pg,ds)
int pg,ds;
 {
  int ch;          /* a character being printed */
  int i,j,k;
  int len;         /* length of a data object */
  char *getmem();
  char *divider;   /* Buffer for division by 10 */
  char *bigchars;  /* ASCII representation of bignum */
  int lcl[2];      /* local "register" */
  char *str;       /* temporary string pointer */
  int strange;     /* number of characters in a string which must be escaped */
  double get_flo();
  char *symbol_name(); /* Retrieves print name for a symbol */

  /* Note:  the following character buffer must be long enough to hold
            the longest representation of a character.  The current
            length record holder is "#\backspace"                       */
  static char ch_buffer[14] = "#\\xxxxxxxxxxx";

/* If shift-break depressed, abort I/O */
  if (s_break)
   {
kill_output:
    printstr("\n[WARNING: Output aborted by SHIFT-BREAK]", 41);
    restart(show ? 0 : 2);
    /* Note:  control does not return from "restart" */
   }

/* If program stack low, print no deeper */
  if (stkspc() < 64)  printstr("#<DEEP!>",8);
   else
   {
/* Otherwise, act on object type */
    switch (ptype[pg]>>1)
     {
      case (LISTTYPE):
        if (pg)  /* If not NULL */
         {
          printchar('(');
          do
           {
            subsprint(CORRPAGE(get_byte((i=pg),ds)),get_word(pg,ds+1));
            pg = CORRPAGE(get_byte(pg,ds+3));
            ds = get_word(i,ds+4);
            if (pg)  /* If more items in the list */
              printchar(' ');
           }
          while (pg && ((ptype[pg]) == LISTTYPE*2));
          if (pg)  /* If last cdr not NIL */
           {
            printchar('.');
            printchar(' ');
            subsprint(pg,ds);
           }
          printchar(')');
         }
        else printstr("()",2);
        break;
      case (FIXTYPE):
        i = 5;
        if (!(divider = getmem(i)))  abort(HEAPERR);
        fix2big( ((ds<<1)>>1), divider);
        goto PRINTINT;
      case (FLOTYPE):
        printflo(get_flo(pg,ds));
        break;
      case (ARYTYPE):
        printstr("#(",2);
        len = get_word(pg, ds+1) - 3;  /* fetch length of array object */
        for (i = BLK_OVHD; i <= len; i+=PTRSIZE)
         {
          subsprint(CORRPAGE(get_byte(pg, ds+i)), get_word(pg,ds+i+1));
          if (i < len) printchar(' ');
         }
        printchar(')');
        break;
      case (CONTTYPE):
        printstr("#<CONTINUATION>",15); break;
      case (CLOSTYPE):
        printstr("#<PROCEDURE",11);
        /* fetch information operand from closure object */
        lcl[C_PAGE] = get_byte(pg,ds+3);
        lcl[C_DISP] = get_word(pg,ds+4);
        /* follow information operand list to cdr of last list cell */
        while (lcl[C_PAGE] && ptype[CORRPAGE(lcl[C_PAGE])] == LISTTYPE*2)
         {
          take_cdr(lcl);
         }
        /* if final operand is a symbol, print it */
        if (ptype[(i = CORRPAGE(lcl[C_PAGE]))] == SYMTYPE*2)
         {
          str = symbol_name(i, lcl[C_DISP]);
          printchar(' ');
          printstr(str, strlen(str));
          rlsstr(str);
         }
        printchar('>');
        break;
      case (FREETYPE):
        printstr("#<FREE>",7); break;
      case (CODETYPE):
        printstr("#<CODE>",7); break;
      case (ENVTYPE):
        printstr("#<ENVIRONMENT>",14); break;
      case (SYMTYPE):
        printatm(pg,ds,SYM_OVHD,'|');
        break;
      case (STRTYPE):
        len = get_word(pg, ds+1);
        if (len < 0) len = len + BLK_OVHD + PTRSIZE;/* check for small string */
        ccount += (len -= BLK_OVHD);
        if (show)
         {
          if (display)
           { /* write-- need to print double quotes, escape characters */
            for (i = 0, strange = 2;  i < len; i++)
             {
              ch = get_byte(pg,ds+BLK_OVHD+i);
              if (ch == '\\' || ch == '"') strange++;
             } /* end:  for (i = 0, strange = 2;  i < len; i++) */
            wrap(len + strange);
            givechar('"');
            for (i = 0; i < len; i++)
             {
              if (s_break) goto kill_output;
              ch = get_byte(pg,ds+BLK_OVHD+i);
              if (ch == '\\' || ch == '"') givechar('\\');
              givechar(ch);
             } /* end:  for (i = 0; i < len; i++) */
            givechar('"');
           }
          else /* display-- just print the string */
           {
            wrap(len);
            for (i = 0; i < len; i++)
             {
              if (s_break) goto kill_output;
              givechar(get_byte(pg,ds+BLK_OVHD+i));
             } /* end:  for (i = 0; i < len; i++) */
           } /* end:  else */
         } /* end:  if (show) */
        break;
      case (CHARTYPE):
        i = get_char(pg, ds);
        if (display)
         {
          ch_buffer[2] = i;       /* make character into string "#\?" */
          ch_buffer[3] = '\0';
          /* Check for a "special" multi-character character constant */
          for (j = 0; j < test_num; j++)
            if (i == test_char[j])
             {
              str = test_string[j];
              k = 2;
              while ((ch_buffer[k++] = *str++));
              break;
             }
          printstr(ch_buffer, strlen(ch_buffer));
         }
        else printchar(i); /* print character without escapes */
        break;
  /*  case (REFTYPE):
        printstr("#<REF>",6); break;
  */  case (BIGTYPE):
        i = get_word(pg,ds+1) - 1;
        if (!(divider = getmem(i)))  abort(HEAPERR);
        copybig(pg,ds,divider);
  PRINTINT:
        if (bigchars = getmem(j=(i*3-5)))
         {
          printstr(bigchars, big2asc(divider,bigchars));
          rlsmem(bigchars,j);
          rlsmem(divider,i);
          break;
         }
         else
         {
          rlsmem(divider,i);
          abort(HEAPERR);
         }
      case (PORTTYPE):
        printstr("#<PORT>",7); break;
     }
   }
 }


/***************************************************************/
/*                       PRINTCHAR(c)                          */
/*      Prints a single character to the file, and sends a     */
/* newline if necessary.                                       */
/***************************************************************/
printchar(c)
char c;
 {
  ccount++;
  if (show)
    if (currspc() > 0)
      return(givechar(c));
     else
     {
      givechar('\n');
      if (!isspace(c)) /* After newline, print only nonspaces */
        return(givechar(c));
       else
       {
        return(0);
       }
     }
   else
   {
    return(0);
   }
 }


/***************************************************************/
/*                      PRINTSTR(str,len)                      */
/*      This prints the string STR of length LEN, first        */
/* sending a newline if necessary.                             */
/***************************************************************/
printstr(str,len)
char *str;
int len;
 {
  int i;
  wrap(len);
  ccount += len;
  if (show)  gvchars(str,len);
 }
*************************************/


/***************************************************************/
/*                   PRINTATM(pg,ds,offs,c)                    */
/*      PRINTATM is used for printing both symbols (and        */
/* strings). The atom to be printed is located at logical page */
/* PG and displacement DS.  The argument OFFS tells how many   */
/* bytes from the top of the atom begin the characters to be   */
/* printed.  The atom printname will be bracketed with the     */
/* character CH at both ends if necessary.                     */
/*      ( CH=='|' for symbols, '"' for strings.)               */
/***************************************************************/
printatm(pg,ds,offs,ch)
int pg,ds,offs;
char ch;
 {
/*%%int i;*/
  int j;
  char *buf;
/*%%char c;*/
  int len;     /* Length of print name */
  int strange=0;   /* Number of strange characters */
  char *getmem();
  ENTER(printatm);

/* First stage: Copy pname into buffer, count needed escape    */
/* characters, and determine whether the pname is "strange".   */
  len = get_word(pg, ds+1) - offs;
  ds += offs;
  if (!(buf = getmem(offs=2*len+1)))  getmem_error(rtn_name);
  strange = (j=blk2pbuf(pg,ds,buf,len,ch,display)) & 1;
  j >>= 1;

/* Second stage: If necessary, check for numeric, dot, or      */
/* #-macro confusion.                                          */
if (!strange)
 if ((!strcmp(buf,".")) || (*buf=='#') && (pg!=SPECSYM) || (scannum(buf,10)))
   strange++;

/* Third stage: Send carriage-return if needed, and print      */
/* pname of atom, delimited if necessary.                      */
stage_3:
  ccount += len;   /* Update character count */
  if (show)
   {
    wrap(j + ((strange=(strange && display))? 2 : 0));
    if (strange)  givechar(ch);
    gvchars(buf,j);
    if (strange)  givechar(ch);
   }
  rlsmem(buf, offs);
 }

/***************************************************************/
/*                        PRINTFLO(f)                          */
/*      Given a double-length floating-point number, this      */
/* procedure formats and prints the ASCII representation of    */
/* the number.                                                 */
/***************************************************************/
printflo(f)
double f;
{
 char buf[32];
 printstr(buf, makeflo(f,buf,0,outrange(f)));
}

/***************************************************************/
/*                        OUTRANGE(f)                          */
/*      Returns a non-zero value if the value of the given     */
/* flonum F is not "close" to 1, zero otherwise.               */
/***************************************************************/
outrange(f)
double f;
{
 if (f<0)  f = -f;
 return((f<1.0e-3) || (f>=1.0e7));
}

/***************************************************************/
/*                 MAKEFLO(flo,buf,prec,ex)                    */
/*      Takes a flonum FLO and converts it to a human-readable */
/* form, storing the characters in the buffer BUF.  PREC       */
/* specifies the number of decimal places to be used (as many  */
/* as necessary, up to a maximum, if PREC is 0) and EX         */
/* specifies whether to use exponential (if nonzero) or fixed- */
/* decimal format.  MAKEFLO returns the number of characters   */
/* placed in BUF, and BUF should be at least 32 bytes.         */
/***************************************************************/
makeflo(flo,buf,prec,ex)
double flo;
char *buf;
int prec,ex;
{
 char digits[32];
 int scl = 0;
 if (flo==0.0)
  {
   *digits='0'; ex=0;
  }
  else
  {
   scale(&flo,&scl);
   flo2big(flo*1.0e15,buf);
   big2asc(buf,digits);
  }
 return(formflo(digits,buf,scl,prec,ex));
}

/***************************************************************/
/*                       SCALE(&flo,&x)                        */
/*      Given a pointer FLO to a double-length flonum and a    */
/* pointer X to an integer, SCALE puts at those two locations  */
/* a new flonum and integer such that FLO equals the new       */
/* flonum times 10 to the integer's power and the new flonum   */
/* is in the interval [ 1.0, 10.0 ).                           */
/***************************************************************/
scale(flo,x)
double *flo;
int *x;
{
 double local;
 double squar = 10.0;
 double tensquar[9];
 int scale,wassmall,i;
 scale = wassmall = i = 0;
 local = ((*flo>0) ? *flo : -*flo);
 if (local == 0)
   *x = 0;
  else
  {
   if (local < 1.0)
    {
     wassmall = -1;
     local = 1.0/local;
    }
   tensquar[0] = 10.0;
   while (++i<9)
    {
     squar *= squar;
     tensquar[i] = squar;
    }
   while (--i>=0)
    {
     scale <<=1;
     if (local>=tensquar[i])
      {
       local /= tensquar[i];
       scale++;
      }
    }
   if (wassmall)
    {
     scale = -scale;
     local = 1.0/local;
     if (local!=1.0)
      {
       local *= 10;
       scale--;
      }
    }
   *x = scale;
   *flo = ((*flo < 0.0) ? -local : local);
  }
}
/******************
/***************************************************************/
/*                        WRAP(len)                            */
/*      WRAP issues a newline if there are less than LEN       */
/* spaces left on the current output line.                     */
/***************************************************************/
wrap(len)
int len;
 {
  if (show && currspc()<len && curr_col()>1)
    givechar('\n');
 }
*****************************/