conservatory
/
stk
4
0
Fork 0
Code Issues Pull Requests Packages Projects Releases Wiki Activity
stk/Src/print.c

538 lines
14 KiB
C
Raw Blame History

/*
* p r i n t . c -- writing stuff
*
* Copyright © 1993-1999 Erick Gallesio - I3S-CNRS/ESSI <eg@unice.fr>
*
*
* 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.
*
* Author: Erick Gallesio [eg@unice.fr]
* Creation date: ??-Oct-1993 ??:??
* Last file update: 14-Sep-1999 09:23 (eg)
*
*/
#include "stk.h"
#include "extend.h"
#include "module.h"
#ifdef USE_STKLOS
# include "stklos.h"
#endif
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)) {
Putc(' ', port);
STk_print(CAR(tmp), port, mode);
}
if (NNULLP(tmp)) {
Puts(" . ", port);
STk_print(tmp, port, mode);
}
}
static void printsymbol(char *s, SCM port, int mode)
{
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)) {
Putc('|', port); Puts(s, port); Putc('|', port);
return;
}
}
}
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 */
Puts((char *) p, port);
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);
}
}
#ifdef USE_STKLOS
static void internal_display_instance(SCM instance, SCM port)
{
sprintf(STk_tkbuffer, "#[instance %lx]", (unsigned long) instance);
Puts(STk_tkbuffer, port);
}
static void display_instance(SCM instance, SCM port, int type)
{
char *fct_name = ""; /* for GCC !! */
SCM fct;
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;
}
fct = STk_STklos_value(Intern(fct_name));
if (fct == UNBOUND)
internal_display_instance(instance, port);
else
Apply2(fct, instance, port);
}
#endif
SCM STk_print(SCM exp, SCM port, int mode)
{
switch TYPE(exp) {
case tc_nil:
Puts("()", port);
break;
case tc_undefined:
Puts("#[undefined]", port);
break;
case tc_boolean:
Puts(EQ(exp, Truth) ? "#t" : "#f", port);
break;
case tc_eof:
Puts("#[eof]", port);
break;
case tc_cons:
Putc('(', port); printlist(exp, port, mode); Putc(')', port);
break;
case tc_integer:
case tc_bignum:
case tc_flonum:
{
char buffer[100];
char *s = STk_number2Cstr(exp, 10L, buffer);
Puts(s, port);
if (TYPE(exp) == tc_bignum) free(s);
}
break;
case tc_symbol:
printsymbol(PNAME(exp), port, mode);
break;
case tc_keyword:
if (mode != DSP_MODE) Putc(':', port);
Puts(KEYVAL(exp)+1, port);
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:
Puts("#[subr ", port);
Puts((*exp).storage_as.subr.name, port);
Putc(']', port);
break;
case tc_closure:
if (mode != TK_MODE) {
Puts("#[closure arglist=", port);
STk_print(CLOSPARAMS(exp), port, mode);
sprintf(STk_tkbuffer, " %lx]", (unsigned long) exp);
}
else
sprintf(STk_tkbuffer, "#p%lx", (unsigned long) exp);
Puts(STk_tkbuffer, port);
break;
case tc_char:
if (mode!=DSP_MODE){
Puts("#\\", port);
Puts((char *) STk_char2string((unsigned char) CHAR(exp)), port);
}
else Putc(CHAR(exp), port);
break;
case tc_string:
printstring(exp, port, mode);
break;
case tc_vector:
{
int j, n = exp->storage_as.vector.dim;
Puts("#(", port);
for(j=0; j < n; j++) {
STk_print(VECT(exp)[j], port, mode);
if ((j + 1) < n) Putc(' ', port);
}
Putc(')', port);
}
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);
Puts(STk_tkbuffer, port);
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);
Puts(STk_tkbuffer, port);
break;
case tc_isport:
sprintf(STk_tkbuffer, "#[input-string-port %lx%s]",
(unsigned long) exp,
(PORT_FLAGS(port) & PORT_CLOSED) ? "(closed)" : "");
Puts(STk_tkbuffer, port);
break;
case tc_osport:
sprintf(STk_tkbuffer, "#[output-string-port %lx%s]",
(unsigned long) exp,
(PORT_FLAGS(port) & PORT_CLOSED) ? "(closed)" : "");
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);
break;
case tc_macro:
sprintf(STk_tkbuffer, "#[macro %lx]",
(unsigned long) exp);
Puts(STk_tkbuffer, port);
break;
case tc_localvar:
sprintf(STk_tkbuffer,"#[local %s @%d,%d]",
PNAME(exp->storage_as.localvar.symbol),
exp->storage_as.localvar.level,
exp->storage_as.localvar.position);
Puts(STk_tkbuffer, port);
break;
case tc_globalvar:
sprintf(STk_tkbuffer, "#[global %s]", PNAME(VCELL(exp)));
Puts(STk_tkbuffer, port);
break;
case tc_modulevar:
sprintf(STk_tkbuffer, "#[modulevar %s:%s]",
PNAME(MOD_NAME(CDR(CAR(exp)))),
PNAME(CAR(CAR(exp))));
Puts(STk_tkbuffer, port);
break;
case tc_cont:
sprintf(STk_tkbuffer, "#[continuation %lx]", (unsigned long) exp);
Puts(STk_tkbuffer, port);
break;
case tc_env:
if (mode != TK_MODE)
sprintf(STk_tkbuffer, "#[environment %lx]", (unsigned long) exp);
else
sprintf(STk_tkbuffer, "#p%lx", (unsigned long) exp);
Puts(STk_tkbuffer, port);
break;
case tc_address:
{
char * fmt = (mode == DSP_MODE) ? "%lx" : "#p%lx";
sprintf(STk_tkbuffer, fmt, (unsigned long) exp->storage_as.env.data);
Puts(STk_tkbuffer, port);
}
break;
case tc_autoload: /* should never occur!!!!! */
sprintf(STk_tkbuffer, "#[autoload %lx]", (unsigned long) exp);
Puts(STk_tkbuffer, port);
break;
case tc_Cpointer:
STk_Cpointer_display(exp, port, mode);
break;
case tc_module:
sprintf(STk_tkbuffer, "#[module %s]", PNAME(STk_module_name(exp)));
Puts(STk_tkbuffer, port);
break;
case tc_frame:
sprintf(STk_tkbuffer, "#[frame %lx]", (unsigned long) exp);
Puts(STk_tkbuffer, port);
break;
case tc_values:
Puts("#[values", port);
if (!NULLP(CAR(exp))) {
Putc(' ', port);
printlist(CAR(exp), port, mode);
}
Putc(']', port);
break;
#ifdef USE_STKLOS
case tc_instance:
display_instance(exp, port, mode);
break;
case tc_next_method:
sprintf(STk_tkbuffer, "#[next-method %lx]", (unsigned long) exp);
Puts(STk_tkbuffer, port);
break;
#endif
#ifdef USE_TK
case tc_tkcommand:
if (mode != TK_MODE) Puts("#[Tk-command ", port);
Puts(exp->storage_as.tk.data->Id, port);
if (mode != TK_MODE) Putc(']', port);
break;
case tc_tclobject:
if (mode == TK_MODE)
STk_print(CAR(exp), port, WRT_MODE);
else
sprintf(STk_tkbuffer, "#[Tcl-obj %lx]", (unsigned long) exp);
Puts(STk_tkbuffer, port);
break;
#endif
case tc_quote:
Puts("#quote", port);
break;
case tc_lambda:
Puts("#lambda", port);
break;
case tc_if:
Puts("#if", port);
break;
case tc_setq:
Puts("#setq", port);
break;
case tc_cond:
Puts("#cond", port);
break;
case tc_and:
Puts("#and", port);
break;
case tc_or:
Puts("#or", port);
break;
case tc_let:
Puts("#let", port);
break;
case tc_letstar:
Puts("#let*", port);
break;
case tc_letrec:
Puts("#letrec", port);
break;
case tc_begin:
Puts("#begin", port);
break;
case tc_promise:
sprintf(STk_tkbuffer, "#[promise %lx (%sforced)]",
(unsigned long) exp,
exp->storage_as.promise.resultknown ? "" : "not ");
Puts(STk_tkbuffer, port);
break;
case tc_apply:
Puts("#apply", port);
break;
case tc_call_cc:
Puts("#call/cc", port);
break;
case tc_dynwind:
Puts("#dynamic-wind", port);
break;
case tc_extend_env:
Puts("#extend-environment", port);
break;
case tc_unbound:
Puts("#[unbound]", port);
break;
default:
if (EXTENDEDP(exp))
STk_extended_display(exp, port, mode);
else {
sprintf(STk_tkbuffer, "#[unknown %d %lx]", TYPE(exp), (unsigned long) exp);
Puts(STk_tkbuffer, port);
}
}
return UNDEFINED;
}
/*=============================================================================
*
* Printing of circular structures
*
*=============================================================================*/
static SCM cycles = NULL;
static int index_label = 0;
static void pass1(SCM exp); /* pass 1: mark cells */
static void pass2(SCM exp, SCM port); /* pass 2: print */
static void print_cycle(SCM exp, SCM port)
{
SCM value, tmp;
if ((tmp = STk_assv(exp, cycles)) != Ntruth) {
if (INTEGERP(value = CDR(tmp))) {
Fprintf(port, "#%ld#", INTEGER(value));
return;
}
}
/* This is not a cycle. Do a normal print */
pass2(exp, port);
}
static void printlist_star(SCM exp, SCM port)
{
SCM value, tmp;
tmp = NIL; /* for GCC */
Putc('(', port);
for ( ; ; ) {
print_cycle(CAR(exp), port);
if (NULLP(exp=CDR(exp))) break;
if (NCONSP(exp) || (tmp = STk_assv(exp, cycles)) != Ntruth) {
if (NCONSP(exp) || (value = CDR(tmp)) == Truth || INTEGERP(value)) {
/* either ". X" or ". #0=(...)" or ". #0#" */
Puts(" . ", port);
print_cycle(exp, port);
break;
}
}
Putc(' ', port);
}
Putc(')', port);
}
static void printvector_star(SCM exp, SCM port)
{
int j, n = exp->storage_as.vector.dim;
Puts("#(", port);
for(j=0; j < n; j++) {
print_cycle(VECT(exp)[j], port);
if ((j + 1) < n) Putc(' ', port);
}
Putc(')', port);
}
static void pass1(SCM exp)
{
SCM tmp;
Top:
if (NCONSP(exp) && NVECTORP(exp)) return;
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;
}
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;}
}
}
else {
/* This item was already seen. Note that this is the second time */
CDR(tmp) = Truth;
}
}
static void pass2(SCM exp, SCM port)
{
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 */
Fprintf(port, "#%d=", index_label);
CDR(tmp) = STk_makeinteger(index_label++);
}
}
if (CONSP(exp)) printlist_star(exp, port);
else printvector_star(exp, port);
}
}
PRIMITIVE STk_print_star(SCM exp, SCM port)
{
if (NCONSP(exp) && NVECTORP(exp)) return STk_print(exp, port, WRT_MODE);
if (cycles == NULL) STk_gc_protect(&cycles);
cycles = NIL;
index_label = 0;
pass1(exp); pass2(exp, port);
return UNDEFINED;
}
Reference in New Issue View Git Blame Copy Permalink