stk/Src/print.c

538 lines
14 KiB
C
Raw Normal View History

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;
}