340 lines
7.5 KiB
C
340 lines
7.5 KiB
C
/*************************************************************************
|
|
*
|
|
* lispPrint.c --
|
|
*
|
|
* Stuff that prints out the internals of lists.
|
|
*
|
|
* (c) 1996 California Institute of Technology
|
|
* Department of Computer Science
|
|
* Pasadena, CA 91125.
|
|
*
|
|
* Permission to use, copy, modify, and distribute this software
|
|
* and its documentation for any purpose and without fee is hereby
|
|
* granted, provided that the above copyright notice appear in all
|
|
* copies. The California Institute of Technology makes no representations
|
|
* about the suitability of this software for any purpose. It is
|
|
* provided "as is" without express or implied warranty. Export of this
|
|
* software outside of the United States of America may require an
|
|
* export license.
|
|
*
|
|
* $Header$
|
|
*
|
|
*************************************************************************/
|
|
|
|
#include <stdio.h>
|
|
|
|
#include "lisp/lisp.h"
|
|
#include "lispInt.h"
|
|
#include "textio/textio.h"
|
|
#include "utils/malloc.h"
|
|
#include "lispargs.h"
|
|
#include "utils/signals.h"
|
|
#include "utils/hash.h"
|
|
|
|
#define IsSpace(c) ((c) == ' ')
|
|
|
|
/*
|
|
Print t into s, expanding control characters.
|
|
flag = 1: put quotes around if spaces present
|
|
flag = 0: don't
|
|
*/
|
|
static
|
|
void
|
|
LispBufPrintName (s,t,flag)
|
|
char *s, *t;
|
|
int flag;
|
|
{
|
|
int i,j, spc;
|
|
i=0;
|
|
spc=0;
|
|
for (j=0; t[j]; j++)
|
|
if (IsSpace (t[j])) {
|
|
spc=1;
|
|
break;
|
|
}
|
|
if (spc && flag) s[i++] = '\"';
|
|
for (j=0; t[j]; j++)
|
|
if (t[j] >= 32)
|
|
s[i++] = t[j];
|
|
else {
|
|
s[i++] = '^';
|
|
s[i++] = t[j]+64;
|
|
}
|
|
if (spc && flag)
|
|
s[i++] = '\"';
|
|
s[i]='\0';
|
|
}
|
|
|
|
/*------------------------------------------------------------------------
|
|
*
|
|
* LispPrint --
|
|
*
|
|
* Print the object out to the text stream.
|
|
*
|
|
* Results:
|
|
* None.
|
|
*
|
|
* Side effects:
|
|
* Output appears in text window.
|
|
*
|
|
*------------------------------------------------------------------------
|
|
*/
|
|
|
|
static char obuf[128];
|
|
static HashTable PrintTable, GenTable;
|
|
static int num_refs;
|
|
|
|
static void
|
|
_LispPrint (fp,l)
|
|
FILE *fp;
|
|
LispObj *l;
|
|
{
|
|
HashEntry *h;
|
|
int i;
|
|
if (SigInterruptPending) return;
|
|
h = HashLookOnly (&PrintTable, l);
|
|
if (h) {
|
|
i = (int) HashGetValue (h);
|
|
if (i) {
|
|
/* i > 0 */
|
|
if (fp == stdout) TxPrintf ("#%d", i);
|
|
else fprintf (fp, "#%d", i);
|
|
return;
|
|
}
|
|
else {
|
|
/* not printed; set the print tag */
|
|
HashSetValue (h, ++num_refs);
|
|
if (fp == stdout) TxPrintf ("#%d:", num_refs);
|
|
else fprintf (fp, "#%d:", num_refs);
|
|
}
|
|
}
|
|
switch (LTYPE(l)) {
|
|
case S_INT:
|
|
if (fp == stdout) TxPrintf ("%d", LINTEGER(l));
|
|
else fprintf (fp,"%d", LINTEGER(l));
|
|
break;
|
|
case S_FLOAT:
|
|
if (fp == stdout) TxPrintf ("%lf", LFLOAT(l));
|
|
else fprintf (fp, "%lf", LFLOAT(l));
|
|
break;
|
|
case S_STRING:
|
|
LispBufPrintName (obuf, LSTR(l),0);
|
|
if (fp == stdout) TxPrintf ("\"%s\"", obuf);
|
|
else fprintf (fp, "\"%s\"", obuf);
|
|
break;
|
|
case S_BOOL:
|
|
if (fp == stdout) TxPrintf ("#%c", LINTEGER(l) ? 't' : 'f');
|
|
else fprintf (fp, "#%c", LINTEGER(l) ? 't' : 'f');
|
|
break;
|
|
case S_SYM:
|
|
LispBufPrintName (obuf, LSYM(l),1);
|
|
if (fp == stdout) TxPrintf ("%s", obuf);
|
|
else fprintf (fp, "%s", obuf);
|
|
break;
|
|
case S_LIST:
|
|
if (fp == stdout) TxPrintf ("(");
|
|
else fprintf (fp, "(");
|
|
if (LLIST(l)) {
|
|
Sexp *s;
|
|
s = LLIST(l);
|
|
_LispPrint (fp,CAR(s));
|
|
while ((LTYPE(CDR(s)) == S_LIST) && LLIST(CDR(s))) {
|
|
if (fp == stdout) TxPrintf (" ");
|
|
else fprintf (fp, " ");
|
|
h = HashLookOnly (&PrintTable, CDR(s));
|
|
if (h) {
|
|
i = (int) HashGetValue (h);
|
|
if (i) {
|
|
/* i > 0 */
|
|
if (fp == stdout) TxPrintf ("#%d", i);
|
|
else fprintf (fp, "#%d", i);
|
|
goto done;
|
|
}
|
|
else {
|
|
/* not printed; set the print tag */
|
|
HashSetValue (h, ++num_refs);
|
|
if (fp == stdout) TxPrintf ("#%d:", num_refs);
|
|
else fprintf (fp, "#%d:", num_refs);
|
|
}
|
|
}
|
|
s = LLIST(CDR(s));
|
|
_LispPrint (fp,CAR(s));
|
|
}
|
|
if (LTYPE(CDR(s)) != S_LIST) {
|
|
if (fp == stdout) TxPrintf (" . ");
|
|
else fprintf (fp, " . ");
|
|
_LispPrint (fp,CDR(s));
|
|
}
|
|
}
|
|
done:
|
|
if (fp == stdout) TxPrintf (")");
|
|
else fprintf (fp, ")");
|
|
break;
|
|
case S_LAMBDA:
|
|
if (fp == stdout) TxPrintf ("(lambda ");
|
|
else fprintf (fp, "(lambda ");
|
|
_LispPrint (fp,ARG2(LUSERDEF(l)));
|
|
if (fp == stdout) TxPrintf (" ");
|
|
else fprintf (fp, " ");
|
|
_LispPrint (fp,ARG4(LUSERDEF(l)));
|
|
if (fp == stdout) TxPrintf (")");
|
|
else fprintf (fp, ")");
|
|
break;
|
|
case S_LAMBDA_BUILTIN:
|
|
case S_MAGIC_BUILTIN:
|
|
if (fp == stdout) TxPrintf ("#proc");
|
|
else fprintf (fp, "#proc");
|
|
break;
|
|
default:
|
|
break;
|
|
}
|
|
}
|
|
|
|
|
|
static void
|
|
_LispGenTable (l)
|
|
LispObj *l;
|
|
{
|
|
HashEntry *h;
|
|
int i;
|
|
if (SigInterruptPending) return;
|
|
h = HashLookOnly (&GenTable, l);
|
|
if (h) {
|
|
i = (int) HashGetValue (h);
|
|
i++;
|
|
HashSetValue (h, i);
|
|
return;
|
|
}
|
|
h = HashFind (&GenTable, l);
|
|
HashSetValue (h, 0);
|
|
switch (LTYPE(l)) {
|
|
case S_INT:
|
|
case S_FLOAT:
|
|
case S_STRING:
|
|
case S_BOOL:
|
|
case S_SYM:
|
|
case S_LAMBDA_BUILTIN:
|
|
case S_MAGIC_BUILTIN:
|
|
break;
|
|
case S_LIST:
|
|
if (LLIST(l)) {
|
|
Sexp *s;
|
|
s = LLIST(l);
|
|
_LispGenTable (CAR(s));
|
|
while ((LTYPE(CDR(s)) == S_LIST) && LLIST(CDR(s))) {
|
|
h = HashLookOnly (&GenTable, CDR(s));
|
|
if (h) {
|
|
i = (int) HashGetValue (h);
|
|
i++;
|
|
HashSetValue (h, i);
|
|
return;
|
|
}
|
|
h = HashFind (&GenTable, CDR(s));
|
|
HashSetValue (h, 0);
|
|
s = LLIST(CDR(s));
|
|
_LispGenTable (CAR(s));
|
|
}
|
|
if (LTYPE(CDR(s)) != S_LIST) {
|
|
_LispGenTable (CDR(s));
|
|
}
|
|
}
|
|
break;
|
|
case S_LAMBDA:
|
|
_LispGenTable (ARG2(LUSERDEF(l)));
|
|
_LispGenTable (ARG4(LUSERDEF(l)));
|
|
break;
|
|
default:
|
|
break;
|
|
}
|
|
}
|
|
|
|
|
|
void
|
|
LispPrint (fp, l)
|
|
FILE *fp;
|
|
LispObj *l;
|
|
{
|
|
HashEntry *h;
|
|
HashSearch hs;
|
|
int i;
|
|
|
|
num_refs = 0;
|
|
HashInit (&PrintTable, 128, HT_WORDKEYS);
|
|
HashInit (&GenTable, 128, HT_WORDKEYS);
|
|
_LispGenTable (l);
|
|
HashStartSearch (&hs);
|
|
while (h = HashNext (&GenTable, &hs)) {
|
|
i = (int) HashGetValue (h);
|
|
if (i) {
|
|
h = HashFind (&PrintTable, h->h_key.h_ptr);
|
|
HashSetValue (h, 0);
|
|
}
|
|
}
|
|
_LispPrint (fp,l);
|
|
HashKill (&PrintTable);
|
|
HashKill (&GenTable);
|
|
}
|
|
|
|
|
|
/*------------------------------------------------------------------------
|
|
*
|
|
* LispPrintType --
|
|
*
|
|
* Print the type of the object out to the text stream.
|
|
*
|
|
* Results:
|
|
* None.
|
|
*
|
|
* Side effects:
|
|
* Output appears in text window.
|
|
*
|
|
*------------------------------------------------------------------------
|
|
*/
|
|
|
|
void
|
|
LispPrintType (fp,l)
|
|
FILE *fp;
|
|
LispObj *l;
|
|
{
|
|
switch (LTYPE(l)) {
|
|
case S_INT:
|
|
if (fp == stdout) TxPrintf ("#integer");
|
|
else fprintf (fp, "#integer");
|
|
break;
|
|
case S_FLOAT:
|
|
if (fp == stdout) TxPrintf ("#float");
|
|
else fprintf (fp, "#float");
|
|
break;
|
|
case S_STRING:
|
|
if (fp == stdout) TxPrintf ("#string");
|
|
else fprintf (fp, "#string");
|
|
break;
|
|
case S_BOOL:
|
|
if (fp == stdout) TxPrintf ("#boolean");
|
|
else fprintf (fp, "#boolean");
|
|
break;
|
|
case S_SYM:
|
|
if (fp == stdout) TxPrintf ("#symbol");
|
|
else fprintf (fp, "#symbol");
|
|
break;
|
|
case S_LIST:
|
|
if (fp == stdout) TxPrintf ("#list");
|
|
else fprintf (fp, "#list");
|
|
break;
|
|
case S_LAMBDA:
|
|
if (fp == stdout) TxPrintf ("#proc-userdef");
|
|
else fprintf (fp, "#proc-userdef");
|
|
break;
|
|
case S_LAMBDA_BUILTIN:
|
|
if (fp == stdout) TxPrintf ("#proc-builtin");
|
|
else fprintf (fp, "#proc-builtin");
|
|
break;
|
|
case S_MAGIC_BUILTIN:
|
|
if (fp == stdout) TxPrintf ("#proc-magic");
|
|
else fprintf (fp, "#proc-magic");
|
|
break;
|
|
default:
|
|
break;
|
|
}
|
|
}
|