1996-09-27 06:29:02 -04:00
|
|
|
|
/*
|
|
|
|
|
* p r i n t . c -- writing stuff
|
|
|
|
|
*
|
1999-09-05 07:16:41 -04:00
|
|
|
|
* Copyright <EFBFBD> 1993-1999 Erick Gallesio - I3S-CNRS/ESSI <eg@unice.fr>
|
1996-09-27 06:29:02 -04:00
|
|
|
|
*
|
|
|
|
|
*
|
1999-09-05 07:16:41 -04:00
|
|
|
|
* Permission to use, copy, modify, distribute,and license this
|
|
|
|
|
* software and its documentation for any purpose is hereby granted,
|
|
|
|
|
* provided that existing copyright notices are retained in all
|
|
|
|
|
* copies and that this notice is included verbatim in any
|
|
|
|
|
* distributions. No written agreement, license, or royalty fee is
|
|
|
|
|
* required for any of the authorized uses.
|
|
|
|
|
* This software is provided ``AS IS'' without express or implied
|
|
|
|
|
* warranty.
|
1998-04-10 06:59:06 -04:00
|
|
|
|
*
|
1996-09-27 06:29:02 -04:00
|
|
|
|
* Author: Erick Gallesio [eg@unice.fr]
|
|
|
|
|
* Creation date: ??-Oct-1993 ??:??
|
1999-09-27 07:20:21 -04:00
|
|
|
|
* Last file update: 14-Sep-1999 09:23 (eg)
|
1996-09-27 06:29:02 -04:00
|
|
|
|
*
|
|
|
|
|
*/
|
|
|
|
|
|
|
|
|
|
#include "stk.h"
|
|
|
|
|
#include "extend.h"
|
1998-04-10 06:59:06 -04:00
|
|
|
|
#include "module.h"
|
|
|
|
|
#ifdef USE_STKLOS
|
|
|
|
|
# include "stklos.h"
|
|
|
|
|
#endif
|
1996-09-27 06:29:02 -04:00
|
|
|
|
|
|
|
|
|
static char valid_symbol_chars[]=
|
|
|
|
|
"abcdefghijklmnopqrstuvwxyz0123456789+-.*/<=>!?:$%_&~^";
|
|
|
|
|
|
|
|
|
|
static void printlist(SCM exp, SCM port, int mode)
|
|
|
|
|
{
|
|
|
|
|
SCM tmp;
|
|
|
|
|
|
|
|
|
|
STk_print(CAR(exp), port, mode);
|
|
|
|
|
for (tmp=CDR(exp); CONSP(tmp); tmp=CDR(tmp)) {
|
1999-02-02 06:13:40 -05:00
|
|
|
|
Putc(' ', port);
|
1996-09-27 06:29:02 -04:00
|
|
|
|
STk_print(CAR(tmp), port, mode);
|
|
|
|
|
}
|
|
|
|
|
if (NNULLP(tmp)) {
|
1999-02-02 06:13:40 -05:00
|
|
|
|
Puts(" . ", port);
|
1996-09-27 06:29:02 -04:00
|
|
|
|
STk_print(tmp, port, mode);
|
|
|
|
|
}
|
|
|
|
|
}
|
|
|
|
|
|
1998-04-10 06:59:06 -04:00
|
|
|
|
|
1999-02-02 06:13:40 -05:00
|
|
|
|
static void printsymbol(char *s, SCM port, int mode)
|
1996-09-27 06:29:02 -04:00
|
|
|
|
{
|
|
|
|
|
if (mode==WRT_MODE) { /* See if we need to enclose pname between a "|" pair */
|
|
|
|
|
register char *p;
|
|
|
|
|
for (p = s; *p; p++) {
|
|
|
|
|
if (!strchr(valid_symbol_chars, *p)) {
|
1999-02-02 06:13:40 -05:00
|
|
|
|
Putc('|', port); Puts(s, port); Putc('|', port);
|
1996-09-27 06:29:02 -04:00
|
|
|
|
return;
|
|
|
|
|
}
|
|
|
|
|
}
|
|
|
|
|
}
|
1999-02-02 06:13:40 -05:00
|
|
|
|
Puts(s, port);
|
|
|
|
|
}
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
static void printstring(SCM s, SCM port, int mode)
|
|
|
|
|
{
|
|
|
|
|
register unsigned char *p = (unsigned char *) CHARS(s);
|
|
|
|
|
register size_t len = STRSIZE(s);
|
|
|
|
|
|
|
|
|
|
if (mode == DSP_MODE) {
|
|
|
|
|
if (strlen(p) == len)
|
|
|
|
|
/* No null in the string. We can use a Puts, instead of the slow Putc */
|
1999-09-27 07:20:21 -04:00
|
|
|
|
Puts((char *) p, port);
|
1999-02-02 06:13:40 -05:00
|
|
|
|
else
|
|
|
|
|
for (len = STRSIZE(s); len; len--, p++) Putc(*p, port);
|
|
|
|
|
} else {
|
|
|
|
|
char *buff = STk_tkbuffer;
|
|
|
|
|
|
|
|
|
|
*buff++ = '"';
|
|
|
|
|
for ( ; len; len--, p++) {
|
|
|
|
|
if (buff >= STk_tkbuffer + TKBUFFERN-2) {
|
|
|
|
|
*buff = '\0';
|
|
|
|
|
Puts(STk_tkbuffer, port);
|
|
|
|
|
buff = STk_tkbuffer;
|
|
|
|
|
}
|
|
|
|
|
switch (*p) {
|
|
|
|
|
case '\0' : *buff++ = '\\'; *buff++ = '0'; break;
|
|
|
|
|
case '\a' : *buff++ = '\\'; *buff++ = 'a'; break;
|
|
|
|
|
case '\b' : *buff++ = '\\'; *buff++ = 'b'; break;
|
|
|
|
|
case '\f' : *buff++ = '\\'; *buff++ = 'f'; break;
|
|
|
|
|
case '\n' : *buff++ = '\\'; *buff++ = 'n'; break;
|
|
|
|
|
case '\r' : *buff++ = '\\'; *buff++ = 'r'; break;
|
|
|
|
|
case '\t' : *buff++ = '\\'; *buff++ = 't'; break;
|
|
|
|
|
case '\v' : *buff++ = '\\'; *buff++ = 'v'; break;
|
|
|
|
|
case '"' :
|
|
|
|
|
case '\\' : *buff++ = '\\'; /* NO BREAK */
|
|
|
|
|
default : *buff++ = *p;
|
|
|
|
|
}
|
|
|
|
|
}
|
|
|
|
|
*buff++ = '"';
|
|
|
|
|
*buff = '\0';
|
|
|
|
|
Puts(STk_tkbuffer, port);
|
|
|
|
|
}
|
1996-09-27 06:29:02 -04:00
|
|
|
|
}
|
|
|
|
|
|
1998-04-10 06:59:06 -04:00
|
|
|
|
|
1996-09-27 06:29:02 -04:00
|
|
|
|
#ifdef USE_STKLOS
|
1998-06-09 07:07:40 -04:00
|
|
|
|
static void internal_display_instance(SCM instance, SCM port)
|
1998-04-10 06:59:06 -04:00
|
|
|
|
{
|
|
|
|
|
sprintf(STk_tkbuffer, "#[instance %lx]", (unsigned long) instance);
|
1999-02-02 06:13:40 -05:00
|
|
|
|
Puts(STk_tkbuffer, port);
|
1998-04-10 06:59:06 -04:00
|
|
|
|
}
|
|
|
|
|
|
1998-06-09 07:07:40 -04:00
|
|
|
|
static void display_instance(SCM instance, SCM port, int type)
|
1996-09-27 06:29:02 -04:00
|
|
|
|
{
|
1999-09-05 07:16:41 -04:00
|
|
|
|
char *fct_name = ""; /* for GCC !! */
|
1998-04-10 06:59:06 -04:00
|
|
|
|
SCM fct;
|
1996-09-27 06:29:02 -04:00
|
|
|
|
|
1998-04-10 06:59:06 -04:00
|
|
|
|
switch (type) {
|
|
|
|
|
case DSP_MODE: fct_name = "display-object"; break;
|
|
|
|
|
case WRT_MODE: fct_name = "write-object"; break;
|
|
|
|
|
case TK_MODE: fct_name = "tk-write-object"; break;
|
|
|
|
|
case PANIC_MODE: internal_display_instance(instance, port); return;
|
|
|
|
|
}
|
1996-09-27 06:29:02 -04:00
|
|
|
|
|
1998-04-10 06:59:06 -04:00
|
|
|
|
fct = STk_STklos_value(Intern(fct_name));
|
1998-06-09 07:07:40 -04:00
|
|
|
|
if (fct == UNBOUND)
|
1998-04-10 06:59:06 -04:00
|
|
|
|
internal_display_instance(instance, port);
|
|
|
|
|
else
|
1999-09-05 07:16:41 -04:00
|
|
|
|
Apply2(fct, instance, port);
|
1996-09-27 06:29:02 -04:00
|
|
|
|
}
|
|
|
|
|
#endif
|
|
|
|
|
|
1998-04-10 06:59:06 -04:00
|
|
|
|
|
1996-09-27 06:29:02 -04:00
|
|
|
|
SCM STk_print(SCM exp, SCM port, int mode)
|
|
|
|
|
{
|
|
|
|
|
switch TYPE(exp) {
|
|
|
|
|
case tc_nil:
|
1999-02-02 06:13:40 -05:00
|
|
|
|
Puts("()", port);
|
1996-09-27 06:29:02 -04:00
|
|
|
|
break;
|
|
|
|
|
case tc_undefined:
|
1999-02-02 06:13:40 -05:00
|
|
|
|
Puts("#[undefined]", port);
|
1996-09-27 06:29:02 -04:00
|
|
|
|
break;
|
|
|
|
|
case tc_boolean:
|
1999-02-02 06:13:40 -05:00
|
|
|
|
Puts(EQ(exp, Truth) ? "#t" : "#f", port);
|
1996-09-27 06:29:02 -04:00
|
|
|
|
break;
|
|
|
|
|
case tc_eof:
|
1999-02-02 06:13:40 -05:00
|
|
|
|
Puts("#[eof]", port);
|
1996-09-27 06:29:02 -04:00
|
|
|
|
break;
|
|
|
|
|
case tc_cons:
|
1999-02-02 06:13:40 -05:00
|
|
|
|
Putc('(', port); printlist(exp, port, mode); Putc(')', port);
|
1996-09-27 06:29:02 -04:00
|
|
|
|
break;
|
|
|
|
|
case tc_integer:
|
|
|
|
|
case tc_bignum:
|
|
|
|
|
case tc_flonum:
|
|
|
|
|
{
|
|
|
|
|
char buffer[100];
|
|
|
|
|
|
1998-04-10 06:59:06 -04:00
|
|
|
|
char *s = STk_number2Cstr(exp, 10L, buffer);
|
1999-02-02 06:13:40 -05:00
|
|
|
|
Puts(s, port);
|
1996-09-27 06:29:02 -04:00
|
|
|
|
if (TYPE(exp) == tc_bignum) free(s);
|
|
|
|
|
}
|
|
|
|
|
break;
|
|
|
|
|
case tc_symbol:
|
1999-02-02 06:13:40 -05:00
|
|
|
|
printsymbol(PNAME(exp), port, mode);
|
1996-09-27 06:29:02 -04:00
|
|
|
|
break;
|
|
|
|
|
case tc_keyword:
|
1999-02-02 06:13:40 -05:00
|
|
|
|
if (mode != DSP_MODE) Putc(':', port);
|
|
|
|
|
Puts(KEYVAL(exp)+1, port);
|
1996-09-27 06:29:02 -04:00
|
|
|
|
break;
|
|
|
|
|
case tc_subr_0:
|
|
|
|
|
case tc_subr_1:
|
|
|
|
|
case tc_subr_2:
|
|
|
|
|
case tc_subr_3:
|
|
|
|
|
case tc_subr_0_or_1:
|
|
|
|
|
case tc_subr_1_or_2:
|
|
|
|
|
case tc_subr_2_or_3:
|
|
|
|
|
case tc_lsubr:
|
|
|
|
|
case tc_ssubr:
|
|
|
|
|
case tc_fsubr:
|
|
|
|
|
case tc_syntax:
|
1999-02-02 06:13:40 -05:00
|
|
|
|
Puts("#[subr ", port);
|
|
|
|
|
Puts((*exp).storage_as.subr.name, port);
|
|
|
|
|
Putc(']', port);
|
1996-09-27 06:29:02 -04:00
|
|
|
|
break;
|
|
|
|
|
case tc_closure:
|
1998-04-10 06:59:06 -04:00
|
|
|
|
if (mode != TK_MODE) {
|
1999-02-02 06:13:40 -05:00
|
|
|
|
Puts("#[closure arglist=", port);
|
1998-04-10 06:59:06 -04:00
|
|
|
|
STk_print(CLOSPARAMS(exp), port, mode);
|
|
|
|
|
sprintf(STk_tkbuffer, " %lx]", (unsigned long) exp);
|
|
|
|
|
}
|
1996-09-27 06:29:02 -04:00
|
|
|
|
else
|
|
|
|
|
sprintf(STk_tkbuffer, "#p%lx", (unsigned long) exp);
|
1999-02-02 06:13:40 -05:00
|
|
|
|
Puts(STk_tkbuffer, port);
|
1996-09-27 06:29:02 -04:00
|
|
|
|
break;
|
|
|
|
|
case tc_char:
|
|
|
|
|
if (mode!=DSP_MODE){
|
1999-02-02 06:13:40 -05:00
|
|
|
|
Puts("#\\", port);
|
|
|
|
|
Puts((char *) STk_char2string((unsigned char) CHAR(exp)), port);
|
1996-09-27 06:29:02 -04:00
|
|
|
|
}
|
1999-02-02 06:13:40 -05:00
|
|
|
|
else Putc(CHAR(exp), port);
|
1996-09-27 06:29:02 -04:00
|
|
|
|
break;
|
|
|
|
|
case tc_string:
|
1999-02-02 06:13:40 -05:00
|
|
|
|
printstring(exp, port, mode);
|
1996-09-27 06:29:02 -04:00
|
|
|
|
break;
|
|
|
|
|
case tc_vector:
|
|
|
|
|
{
|
|
|
|
|
int j, n = exp->storage_as.vector.dim;
|
|
|
|
|
|
1999-02-02 06:13:40 -05:00
|
|
|
|
Puts("#(", port);
|
1996-09-27 06:29:02 -04:00
|
|
|
|
for(j=0; j < n; j++) {
|
|
|
|
|
STk_print(VECT(exp)[j], port, mode);
|
1999-02-02 06:13:40 -05:00
|
|
|
|
if ((j + 1) < n) Putc(' ', port);
|
1996-09-27 06:29:02 -04:00
|
|
|
|
}
|
1999-02-02 06:13:40 -05:00
|
|
|
|
Putc(')', port);
|
1996-09-27 06:29:02 -04:00
|
|
|
|
}
|
|
|
|
|
break;
|
|
|
|
|
case tc_iport:
|
|
|
|
|
if (mode != TK_MODE)
|
|
|
|
|
sprintf(STk_tkbuffer, "#[input-port '%s'%s]", PORT_NAME(exp),
|
|
|
|
|
(PORT_FLAGS(exp) & PORT_CLOSED) ? "(closed)" : "");
|
|
|
|
|
else
|
|
|
|
|
sprintf(STk_tkbuffer, "#file%lx", (unsigned long) exp);
|
1999-02-02 06:13:40 -05:00
|
|
|
|
Puts(STk_tkbuffer, port);
|
1996-09-27 06:29:02 -04:00
|
|
|
|
break;
|
|
|
|
|
case tc_oport:
|
|
|
|
|
if (mode != TK_MODE)
|
|
|
|
|
sprintf(STk_tkbuffer, "#[output-port '%s'%s]", PORT_NAME(exp),
|
|
|
|
|
(PORT_FLAGS(exp) & PORT_CLOSED) ? "(closed)" : "");
|
|
|
|
|
else
|
|
|
|
|
sprintf(STk_tkbuffer, "#file%lx", (unsigned long) exp);
|
1999-02-02 06:13:40 -05:00
|
|
|
|
Puts(STk_tkbuffer, port);
|
1996-09-27 06:29:02 -04:00
|
|
|
|
break;
|
|
|
|
|
case tc_isport:
|
|
|
|
|
sprintf(STk_tkbuffer, "#[input-string-port %lx%s]",
|
|
|
|
|
(unsigned long) exp,
|
|
|
|
|
(PORT_FLAGS(port) & PORT_CLOSED) ? "(closed)" : "");
|
1999-02-02 06:13:40 -05:00
|
|
|
|
Puts(STk_tkbuffer, port);
|
1996-09-27 06:29:02 -04:00
|
|
|
|
break;
|
|
|
|
|
case tc_osport:
|
|
|
|
|
sprintf(STk_tkbuffer, "#[output-string-port %lx%s]",
|
|
|
|
|
(unsigned long) exp,
|
|
|
|
|
(PORT_FLAGS(port) & PORT_CLOSED) ? "(closed)" : "");
|
1999-02-02 06:13:40 -05:00
|
|
|
|
Puts(STk_tkbuffer, port);
|
|
|
|
|
break;
|
|
|
|
|
case tc_ivport:
|
|
|
|
|
sprintf(STk_tkbuffer, "#[input-virtual-port %lx%s]",
|
|
|
|
|
(unsigned long) exp,
|
|
|
|
|
(PORT_FLAGS(port) & PORT_CLOSED) ? "(closed)" : "");
|
|
|
|
|
Puts(STk_tkbuffer, port);
|
|
|
|
|
break;
|
|
|
|
|
case tc_ovport:
|
|
|
|
|
sprintf(STk_tkbuffer, "#[output-virtual-port %lx%s]",
|
|
|
|
|
(unsigned long) exp,
|
|
|
|
|
(PORT_FLAGS(port) & PORT_CLOSED) ? "(closed)" : "");
|
|
|
|
|
Puts(STk_tkbuffer, port);
|
1996-09-27 06:29:02 -04:00
|
|
|
|
break;
|
|
|
|
|
case tc_macro:
|
|
|
|
|
sprintf(STk_tkbuffer, "#[macro %lx]",
|
|
|
|
|
(unsigned long) exp);
|
1999-02-02 06:13:40 -05:00
|
|
|
|
Puts(STk_tkbuffer, port);
|
1996-09-27 06:29:02 -04:00
|
|
|
|
break;
|
|
|
|
|
case tc_localvar:
|
1999-09-05 07:16:41 -04:00
|
|
|
|
sprintf(STk_tkbuffer,"#[local %s @%d,%d]",
|
1996-09-27 06:29:02 -04:00
|
|
|
|
PNAME(exp->storage_as.localvar.symbol),
|
|
|
|
|
exp->storage_as.localvar.level,
|
|
|
|
|
exp->storage_as.localvar.position);
|
1999-02-02 06:13:40 -05:00
|
|
|
|
Puts(STk_tkbuffer, port);
|
1996-09-27 06:29:02 -04:00
|
|
|
|
break;
|
|
|
|
|
case tc_globalvar:
|
|
|
|
|
sprintf(STk_tkbuffer, "#[global %s]", PNAME(VCELL(exp)));
|
1999-02-02 06:13:40 -05:00
|
|
|
|
Puts(STk_tkbuffer, port);
|
1996-09-27 06:29:02 -04:00
|
|
|
|
break;
|
1998-04-10 06:59:06 -04:00
|
|
|
|
case tc_modulevar:
|
|
|
|
|
sprintf(STk_tkbuffer, "#[modulevar %s:%s]",
|
|
|
|
|
PNAME(MOD_NAME(CDR(CAR(exp)))),
|
|
|
|
|
PNAME(CAR(CAR(exp))));
|
1999-02-02 06:13:40 -05:00
|
|
|
|
Puts(STk_tkbuffer, port);
|
1998-04-10 06:59:06 -04:00
|
|
|
|
break;
|
|
|
|
|
|
1996-09-27 06:29:02 -04:00
|
|
|
|
case tc_cont:
|
|
|
|
|
sprintf(STk_tkbuffer, "#[continuation %lx]", (unsigned long) exp);
|
1999-02-02 06:13:40 -05:00
|
|
|
|
Puts(STk_tkbuffer, port);
|
1996-09-27 06:29:02 -04:00
|
|
|
|
break;
|
|
|
|
|
case tc_env:
|
1998-04-10 06:59:06 -04:00
|
|
|
|
if (mode != TK_MODE)
|
|
|
|
|
sprintf(STk_tkbuffer, "#[environment %lx]", (unsigned long) exp);
|
|
|
|
|
else
|
|
|
|
|
sprintf(STk_tkbuffer, "#p%lx", (unsigned long) exp);
|
1999-02-02 06:13:40 -05:00
|
|
|
|
Puts(STk_tkbuffer, port);
|
1996-09-27 06:29:02 -04:00
|
|
|
|
break;
|
|
|
|
|
case tc_address:
|
|
|
|
|
{
|
|
|
|
|
char * fmt = (mode == DSP_MODE) ? "%lx" : "#p%lx";
|
|
|
|
|
sprintf(STk_tkbuffer, fmt, (unsigned long) exp->storage_as.env.data);
|
1999-02-02 06:13:40 -05:00
|
|
|
|
Puts(STk_tkbuffer, port);
|
1996-09-27 06:29:02 -04:00
|
|
|
|
}
|
|
|
|
|
break;
|
|
|
|
|
case tc_autoload: /* should never occur!!!!! */
|
|
|
|
|
sprintf(STk_tkbuffer, "#[autoload %lx]", (unsigned long) exp);
|
1999-02-02 06:13:40 -05:00
|
|
|
|
Puts(STk_tkbuffer, port);
|
1996-09-27 06:29:02 -04:00
|
|
|
|
break;
|
|
|
|
|
case tc_Cpointer:
|
|
|
|
|
STk_Cpointer_display(exp, port, mode);
|
|
|
|
|
break;
|
1998-04-10 06:59:06 -04:00
|
|
|
|
case tc_module:
|
|
|
|
|
sprintf(STk_tkbuffer, "#[module %s]", PNAME(STk_module_name(exp)));
|
1999-02-02 06:13:40 -05:00
|
|
|
|
Puts(STk_tkbuffer, port);
|
1998-04-10 06:59:06 -04:00
|
|
|
|
break;
|
|
|
|
|
case tc_frame:
|
|
|
|
|
sprintf(STk_tkbuffer, "#[frame %lx]", (unsigned long) exp);
|
1999-02-02 06:13:40 -05:00
|
|
|
|
Puts(STk_tkbuffer, port);
|
1998-04-10 06:59:06 -04:00
|
|
|
|
break;
|
|
|
|
|
case tc_values:
|
1999-02-02 06:13:40 -05:00
|
|
|
|
Puts("#[values", port);
|
1998-04-10 06:59:06 -04:00
|
|
|
|
if (!NULLP(CAR(exp))) {
|
1999-02-02 06:13:40 -05:00
|
|
|
|
Putc(' ', port);
|
1998-04-10 06:59:06 -04:00
|
|
|
|
printlist(CAR(exp), port, mode);
|
|
|
|
|
}
|
1999-02-02 06:13:40 -05:00
|
|
|
|
Putc(']', port);
|
1998-04-10 06:59:06 -04:00
|
|
|
|
break;
|
1996-09-27 06:29:02 -04:00
|
|
|
|
#ifdef USE_STKLOS
|
|
|
|
|
case tc_instance:
|
|
|
|
|
display_instance(exp, port, mode);
|
|
|
|
|
break;
|
|
|
|
|
case tc_next_method:
|
1998-04-10 06:59:06 -04:00
|
|
|
|
sprintf(STk_tkbuffer, "#[next-method %lx]", (unsigned long) exp);
|
1999-02-02 06:13:40 -05:00
|
|
|
|
Puts(STk_tkbuffer, port);
|
1996-09-27 06:29:02 -04:00
|
|
|
|
break;
|
|
|
|
|
#endif
|
|
|
|
|
#ifdef USE_TK
|
|
|
|
|
case tc_tkcommand:
|
1999-02-02 06:13:40 -05:00
|
|
|
|
if (mode != TK_MODE) Puts("#[Tk-command ", port);
|
|
|
|
|
Puts(exp->storage_as.tk.data->Id, port);
|
|
|
|
|
if (mode != TK_MODE) Putc(']', port);
|
1996-09-27 06:29:02 -04:00
|
|
|
|
break;
|
1998-04-10 06:59:06 -04:00
|
|
|
|
case tc_tclobject:
|
|
|
|
|
if (mode == TK_MODE)
|
|
|
|
|
STk_print(CAR(exp), port, WRT_MODE);
|
|
|
|
|
else
|
|
|
|
|
sprintf(STk_tkbuffer, "#[Tcl-obj %lx]", (unsigned long) exp);
|
1999-02-02 06:13:40 -05:00
|
|
|
|
Puts(STk_tkbuffer, port);
|
1998-04-10 06:59:06 -04:00
|
|
|
|
break;
|
1996-09-27 06:29:02 -04:00
|
|
|
|
#endif
|
|
|
|
|
case tc_quote:
|
1999-02-02 06:13:40 -05:00
|
|
|
|
Puts("#quote", port);
|
1996-09-27 06:29:02 -04:00
|
|
|
|
break;
|
|
|
|
|
case tc_lambda:
|
1999-02-02 06:13:40 -05:00
|
|
|
|
Puts("#lambda", port);
|
1996-09-27 06:29:02 -04:00
|
|
|
|
break;
|
|
|
|
|
case tc_if:
|
1999-02-02 06:13:40 -05:00
|
|
|
|
Puts("#if", port);
|
1996-09-27 06:29:02 -04:00
|
|
|
|
break;
|
|
|
|
|
case tc_setq:
|
1999-02-02 06:13:40 -05:00
|
|
|
|
Puts("#setq", port);
|
1996-09-27 06:29:02 -04:00
|
|
|
|
break;
|
|
|
|
|
case tc_cond:
|
1999-02-02 06:13:40 -05:00
|
|
|
|
Puts("#cond", port);
|
1996-09-27 06:29:02 -04:00
|
|
|
|
break;
|
|
|
|
|
case tc_and:
|
1999-02-02 06:13:40 -05:00
|
|
|
|
Puts("#and", port);
|
1996-09-27 06:29:02 -04:00
|
|
|
|
break;
|
|
|
|
|
case tc_or:
|
1999-02-02 06:13:40 -05:00
|
|
|
|
Puts("#or", port);
|
1996-09-27 06:29:02 -04:00
|
|
|
|
break;
|
|
|
|
|
case tc_let:
|
1999-02-02 06:13:40 -05:00
|
|
|
|
Puts("#let", port);
|
1996-09-27 06:29:02 -04:00
|
|
|
|
break;
|
|
|
|
|
case tc_letstar:
|
1999-02-02 06:13:40 -05:00
|
|
|
|
Puts("#let*", port);
|
1996-09-27 06:29:02 -04:00
|
|
|
|
break;
|
|
|
|
|
case tc_letrec:
|
1999-02-02 06:13:40 -05:00
|
|
|
|
Puts("#letrec", port);
|
1996-09-27 06:29:02 -04:00
|
|
|
|
break;
|
|
|
|
|
case tc_begin:
|
1999-02-02 06:13:40 -05:00
|
|
|
|
Puts("#begin", port);
|
1996-09-27 06:29:02 -04:00
|
|
|
|
break;
|
|
|
|
|
case tc_promise:
|
|
|
|
|
sprintf(STk_tkbuffer, "#[promise %lx (%sforced)]",
|
|
|
|
|
(unsigned long) exp,
|
|
|
|
|
exp->storage_as.promise.resultknown ? "" : "not ");
|
1999-02-02 06:13:40 -05:00
|
|
|
|
Puts(STk_tkbuffer, port);
|
1996-09-27 06:29:02 -04:00
|
|
|
|
break;
|
|
|
|
|
case tc_apply:
|
1999-02-02 06:13:40 -05:00
|
|
|
|
Puts("#apply", port);
|
1996-09-27 06:29:02 -04:00
|
|
|
|
break;
|
|
|
|
|
case tc_call_cc:
|
1999-02-02 06:13:40 -05:00
|
|
|
|
Puts("#call/cc", port);
|
1996-09-27 06:29:02 -04:00
|
|
|
|
break;
|
|
|
|
|
case tc_dynwind:
|
1999-02-02 06:13:40 -05:00
|
|
|
|
Puts("#dynamic-wind", port);
|
1996-09-27 06:29:02 -04:00
|
|
|
|
break;
|
|
|
|
|
case tc_extend_env:
|
1999-02-02 06:13:40 -05:00
|
|
|
|
Puts("#extend-environment", port);
|
1996-09-27 06:29:02 -04:00
|
|
|
|
break;
|
|
|
|
|
case tc_unbound:
|
1999-02-02 06:13:40 -05:00
|
|
|
|
Puts("#[unbound]", port);
|
1996-09-27 06:29:02 -04:00
|
|
|
|
break;
|
|
|
|
|
default:
|
|
|
|
|
if (EXTENDEDP(exp))
|
|
|
|
|
STk_extended_display(exp, port, mode);
|
|
|
|
|
else {
|
|
|
|
|
sprintf(STk_tkbuffer, "#[unknown %d %lx]", TYPE(exp), (unsigned long) exp);
|
1999-02-02 06:13:40 -05:00
|
|
|
|
Puts(STk_tkbuffer, port);
|
1996-09-27 06:29:02 -04:00
|
|
|
|
}
|
|
|
|
|
}
|
|
|
|
|
return UNDEFINED;
|
|
|
|
|
}
|
1998-04-10 06:59:06 -04:00
|
|
|
|
|
|
|
|
|
|
1998-06-09 07:07:40 -04:00
|
|
|
|
/*=============================================================================
|
|
|
|
|
*
|
|
|
|
|
* Printing of circular structures
|
|
|
|
|
*
|
|
|
|
|
*=============================================================================*/
|
1998-04-10 06:59:06 -04:00
|
|
|
|
|
1998-06-09 07:07:40 -04:00
|
|
|
|
static SCM cycles = NULL;
|
|
|
|
|
static int index_label = 0;
|
1998-04-10 06:59:06 -04:00
|
|
|
|
|
1998-06-09 07:07:40 -04:00
|
|
|
|
static void pass1(SCM exp); /* pass 1: mark cells */
|
|
|
|
|
static void pass2(SCM exp, SCM port); /* pass 2: print */
|
1998-04-10 06:59:06 -04:00
|
|
|
|
|
|
|
|
|
|
1998-06-09 07:07:40 -04:00
|
|
|
|
static void print_cycle(SCM exp, SCM port)
|
|
|
|
|
{
|
|
|
|
|
SCM value, tmp;
|
|
|
|
|
|
|
|
|
|
if ((tmp = STk_assv(exp, cycles)) != Ntruth) {
|
|
|
|
|
if (INTEGERP(value = CDR(tmp))) {
|
1999-02-02 06:13:40 -05:00
|
|
|
|
Fprintf(port, "#%ld#", INTEGER(value));
|
1998-06-09 07:07:40 -04:00
|
|
|
|
return;
|
|
|
|
|
}
|
1998-04-10 06:59:06 -04:00
|
|
|
|
}
|
1998-06-09 07:07:40 -04:00
|
|
|
|
/* This is not a cycle. Do a normal print */
|
|
|
|
|
pass2(exp, port);
|
1998-04-10 06:59:06 -04:00
|
|
|
|
}
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
static void printlist_star(SCM exp, SCM port)
|
|
|
|
|
{
|
1998-06-09 07:07:40 -04:00
|
|
|
|
SCM value, tmp;
|
1998-04-10 06:59:06 -04:00
|
|
|
|
|
1999-09-05 07:16:41 -04:00
|
|
|
|
tmp = NIL; /* for GCC */
|
1999-02-02 06:13:40 -05:00
|
|
|
|
Putc('(', port);
|
1998-04-10 06:59:06 -04:00
|
|
|
|
|
|
|
|
|
for ( ; ; ) {
|
1998-06-09 07:07:40 -04:00
|
|
|
|
print_cycle(CAR(exp), port);
|
1998-04-10 06:59:06 -04:00
|
|
|
|
|
1998-06-09 07:07:40 -04:00
|
|
|
|
if (NULLP(exp=CDR(exp))) break;
|
|
|
|
|
|
1998-09-30 07:11:02 -04:00
|
|
|
|
if (NCONSP(exp) || (tmp = STk_assv(exp, cycles)) != Ntruth) {
|
|
|
|
|
if (NCONSP(exp) || (value = CDR(tmp)) == Truth || INTEGERP(value)) {
|
1998-06-09 07:07:40 -04:00
|
|
|
|
/* either ". X" or ". #0=(...)" or ". #0#" */
|
1999-02-02 06:13:40 -05:00
|
|
|
|
Puts(" . ", port);
|
1998-06-09 07:07:40 -04:00
|
|
|
|
print_cycle(exp, port);
|
|
|
|
|
break;
|
|
|
|
|
}
|
1998-04-10 06:59:06 -04:00
|
|
|
|
}
|
1999-02-02 06:13:40 -05:00
|
|
|
|
Putc(' ', port);
|
1998-04-10 06:59:06 -04:00
|
|
|
|
}
|
1999-02-02 06:13:40 -05:00
|
|
|
|
Putc(')', port);
|
1998-04-10 06:59:06 -04:00
|
|
|
|
}
|
|
|
|
|
|
1998-06-09 07:07:40 -04:00
|
|
|
|
|
1998-04-10 06:59:06 -04:00
|
|
|
|
static void printvector_star(SCM exp, SCM port)
|
|
|
|
|
{
|
1998-06-09 07:07:40 -04:00
|
|
|
|
int j, n = exp->storage_as.vector.dim;
|
1998-04-10 06:59:06 -04:00
|
|
|
|
|
1999-02-02 06:13:40 -05:00
|
|
|
|
Puts("#(", port);
|
1998-06-09 07:07:40 -04:00
|
|
|
|
for(j=0; j < n; j++) {
|
|
|
|
|
print_cycle(VECT(exp)[j], port);
|
1999-02-02 06:13:40 -05:00
|
|
|
|
if ((j + 1) < n) Putc(' ', port);
|
1998-04-10 06:59:06 -04:00
|
|
|
|
}
|
1999-02-02 06:13:40 -05:00
|
|
|
|
Putc(')', port);
|
1998-04-10 06:59:06 -04:00
|
|
|
|
}
|
|
|
|
|
|
1998-06-09 07:07:40 -04:00
|
|
|
|
|
1998-04-10 06:59:06 -04:00
|
|
|
|
static void pass1(SCM exp)
|
|
|
|
|
{
|
1998-06-09 07:07:40 -04:00
|
|
|
|
SCM tmp;
|
1998-04-10 06:59:06 -04:00
|
|
|
|
|
1998-06-09 07:07:40 -04:00
|
|
|
|
Top:
|
1998-04-10 06:59:06 -04:00
|
|
|
|
if (NCONSP(exp) && NVECTORP(exp)) return;
|
|
|
|
|
|
1998-06-09 07:07:40 -04:00
|
|
|
|
if ((tmp = STk_assv(exp, cycles)) == Ntruth) {
|
|
|
|
|
/* We have never seen this cell so far */
|
|
|
|
|
cycles = Cons(Cons(exp, Ntruth), cycles);
|
|
|
|
|
|
|
|
|
|
if (CONSP(exp)) { /* it's a cons */
|
|
|
|
|
pass1(CAR(exp));
|
|
|
|
|
exp = CDR(exp);
|
|
|
|
|
goto Top;
|
1998-04-10 06:59:06 -04:00
|
|
|
|
}
|
1998-06-09 07:07:40 -04:00
|
|
|
|
else { /* it's a vector */
|
|
|
|
|
int i, len = VECTSIZE(exp)-1;
|
|
|
|
|
for (i = 0; i < len; i++) pass1(VECT(exp)[i]);
|
|
|
|
|
if (len >= 0) {exp = VECT(exp)[len]; goto Top;}
|
|
|
|
|
}
|
|
|
|
|
}
|
1998-04-10 06:59:06 -04:00
|
|
|
|
else {
|
1998-06-09 07:07:40 -04:00
|
|
|
|
/* This item was already seen. Note that this is the second time */
|
|
|
|
|
CDR(tmp) = Truth;
|
1998-04-10 06:59:06 -04:00
|
|
|
|
}
|
|
|
|
|
}
|
|
|
|
|
|
1998-06-09 07:07:40 -04:00
|
|
|
|
|
|
|
|
|
static void pass2(SCM exp, SCM port)
|
1998-04-10 06:59:06 -04:00
|
|
|
|
{
|
1998-06-09 07:07:40 -04:00
|
|
|
|
if (NCONSP(exp) && NVECTORP(exp))
|
|
|
|
|
STk_print(exp, port, WRT_MODE); /* Normal print */
|
|
|
|
|
else {
|
|
|
|
|
SCM value, tmp;
|
|
|
|
|
|
|
|
|
|
/* Eventually print a definition label */
|
|
|
|
|
if ((tmp = STk_assv(exp, cycles)) != Ntruth) {
|
|
|
|
|
if ((value=CDR(tmp)) == Truth) {
|
|
|
|
|
/* First use of this label. Assign it a value */
|
1999-02-02 06:13:40 -05:00
|
|
|
|
Fprintf(port, "#%d=", index_label);
|
1998-06-09 07:07:40 -04:00
|
|
|
|
CDR(tmp) = STk_makeinteger(index_label++);
|
|
|
|
|
}
|
|
|
|
|
}
|
1998-04-10 06:59:06 -04:00
|
|
|
|
|
1998-06-09 07:07:40 -04:00
|
|
|
|
if (CONSP(exp)) printlist_star(exp, port);
|
|
|
|
|
else printvector_star(exp, port);
|
1998-04-10 06:59:06 -04:00
|
|
|
|
}
|
|
|
|
|
}
|
|
|
|
|
|
1998-06-09 07:07:40 -04:00
|
|
|
|
PRIMITIVE STk_print_star(SCM exp, SCM port)
|
1998-04-10 06:59:06 -04:00
|
|
|
|
{
|
1998-06-09 07:07:40 -04:00
|
|
|
|
if (NCONSP(exp) && NVECTORP(exp)) return STk_print(exp, port, WRT_MODE);
|
|
|
|
|
|
|
|
|
|
if (cycles == NULL) STk_gc_protect(&cycles);
|
|
|
|
|
cycles = NIL;
|
1998-04-10 06:59:06 -04:00
|
|
|
|
index_label = 0;
|
|
|
|
|
|
1998-06-09 07:07:40 -04:00
|
|
|
|
pass1(exp); pass2(exp, port);
|
|
|
|
|
|
1998-04-10 06:59:06 -04:00
|
|
|
|
return UNDEFINED;
|
|
|
|
|
}
|