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

328 lines
8.4 KiB
C
Raw Blame History

/*
* p r i n t . c -- writing stuff
*
* Copyright © 1993-1996 Erick Gallesio - I3S-CNRS/ESSI <eg@unice.fr>
*
*
* Permission to use, copy, and/or distribute this software and its
* documentation for any purpose and without fee is hereby granted, provided
* that both the above copyright notice and this permission notice appear in
* all copies and derived works. Fees for distribution or use of this
* software or derived works may only be charged with express written
* permission of the copyright holder.
* This software is provided ``as is'' without express or implied warranty.
*
* This software is a derivative work of other copyrighted softwares; the
* copyright notices of these softwares are placed in the file COPYRIGHTS
*
* Author: Erick Gallesio [eg@unice.fr]
* Creation date: ??-Oct-1993 ??:??
* Last file update: 9-Jun-1996 23:53
*
*/
#include "stk.h"
#include "extend.h"
static char valid_symbol_chars[]=
"abcdefghijklmnopqrstuvwxyz0123456789+-.*/<=>!?:$%_&~^";
static void printlist(SCM exp, SCM port, int mode)
{
SCM tmp;
FILE *f = PORT_FILE(port);
STk_print(CAR(exp), port, mode);
for (tmp=CDR(exp); CONSP(tmp); tmp=CDR(tmp)) {
Putc(' ', f);
STk_print(CAR(tmp), port, mode);
}
if (NNULLP(tmp)) {
Puts(" . ", f);
STk_print(tmp, port, mode);
}
}
static void printsymbol(char *s, FILE *f, 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('|', f); Puts(s, f); Putc('|', f);
return;
}
}
}
Puts(s, f);
}
#ifdef USE_STKLOS
static void display_instance(SCM instance, SCM port, int type)
{
char *fct_name;
if (type == DSP_MODE) fct_name = "display-object"; else
if (type == WRT_MODE) fct_name = "write-object"; else
/* (type == TK_MODE) */ fct_name = "tk-write-object";
Apply(VCELL(STk_intern(fct_name)), LIST2(instance, port));
}
#endif
SCM STk_print(SCM exp, SCM port, int mode)
{
FILE *f = PORT_FILE(port);
switch TYPE(exp) {
case tc_nil:
Puts("()", f);
break;
case tc_undefined:
Puts("#[undefined]", f);
break;
case tc_boolean:
Puts(EQ(exp, Truth) ? "#t" : "#f", f);
break;
case tc_eof:
Puts("#[eof]", f);
break;
case tc_cons:
Putc('(', f); printlist(exp, port, mode); Putc(')', f);
break;
case tc_integer:
case tc_bignum:
case tc_flonum:
{
char buffer[100];
char *s = STk_number2Cstr(exp, 10, buffer);
Puts(s, f);
if (TYPE(exp) == tc_bignum) free(s);
}
break;
case tc_symbol:
printsymbol(PNAME(exp), f, mode);
break;
case tc_keyword:
if (mode != DSP_MODE) Putc(':', f);
Puts(KEYVAL(exp)+1, f);
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 ", f);
Puts((*exp).storage_as.subr.name, f);
Putc(']', f);
break;
case tc_closure:
if (mode != TK_MODE)
sprintf(STk_tkbuffer, "#[closure %lx]", (unsigned long) exp);
else
sprintf(STk_tkbuffer, "#p%lx", (unsigned long) exp);
Puts(STk_tkbuffer, f);
break;
case tc_char:
if (mode!=DSP_MODE){
Puts("#\\", f);
Puts(STk_char2string(CHAR(exp)), f);
}
else Putc(CHAR(exp), f);
break;
case tc_string:
{
register char *p = CHARS(exp);
register int len = STRSIZE(exp);
if (mode!=DSP_MODE) Putc('"', f);
for ( ; len; len--, p++) {
if (mode != DSP_MODE)
switch (*p) {
case '\0' : Puts("\\0000", f); break;
case '\a' : Puts("\\a", f); break;
case '\b' : Puts("\\n", f); break;
case '\f' : Puts("\\f", f); break;
case '\n' : Puts("\\n", f); break;
case '\r' : Puts("\\r", f); break;
case '\t' : Puts("\\t", f); break;
case '\v' : Puts("\\v", f); break;
case '"' :
case '\\' : Putc('\\', f); /* NO BREAK */
default: Putc(*p, f);
}
else
Putc(*p, f);
}
if (mode!=DSP_MODE) Putc('"', f);
}
break;
case tc_vector:
{
int j, n = exp->storage_as.vector.dim;
Puts("#(", f);
for(j=0; j < n; j++) {
STk_print(VECT(exp)[j], port, mode);
if ((j + 1) < n) Putc(' ', f);
}
Putc(')', f);
}
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, f);
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, f);
break;
case tc_isport:
sprintf(STk_tkbuffer, "#[input-string-port %lx%s]",
(unsigned long) exp,
(PORT_FLAGS(port) & PORT_CLOSED) ? "(closed)" : "");
Puts(STk_tkbuffer, f);
break;
case tc_osport:
sprintf(STk_tkbuffer, "#[output-string-port %lx%s]",
(unsigned long) exp,
(PORT_FLAGS(port) & PORT_CLOSED) ? "(closed)" : "");
Puts(STk_tkbuffer, f);
break;
case tc_macro:
sprintf(STk_tkbuffer, "#[macro %lx]",
(unsigned long) exp);
Puts(STk_tkbuffer, f);
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, f);
break;
case tc_globalvar:
sprintf(STk_tkbuffer, "#[global %s]", PNAME(VCELL(exp)));
Puts(STk_tkbuffer, f);
break;
case tc_cont:
sprintf(STk_tkbuffer, "#[continuation %lx]", (unsigned long) exp);
Puts(STk_tkbuffer, f);
break;
case tc_env:
sprintf(STk_tkbuffer, "#[environment %lx]", (unsigned long) exp);
Puts(STk_tkbuffer, f);
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, f);
}
break;
case tc_autoload: /* should never occur!!!!! */
sprintf(STk_tkbuffer, "#[autoload %lx]", (unsigned long) exp);
Puts(STk_tkbuffer, f);
break;
case tc_Cpointer:
STk_Cpointer_display(exp, port, mode);
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, f);
break;
#endif
#ifdef USE_TK
case tc_tkcommand:
if (mode != TK_MODE) Puts("#[Tk-command ", f);
Puts(exp->storage_as.tk.data->Id, f);
if (mode != TK_MODE) Putc(']', f);
break;
#endif
case tc_quote:
Puts("#quote", f);
break;
case tc_lambda:
Puts("#lambda", f);
break;
case tc_if:
Puts("#if", f);
break;
case tc_setq:
Puts("#setq", f);
break;
case tc_cond:
Puts("#cond", f);
break;
case tc_and:
Puts("#and", f);
break;
case tc_or:
Puts("#or", f);
break;
case tc_let:
Puts("#let", f);
break;
case tc_letstar:
Puts("#let*", f);
break;
case tc_letrec:
Puts("#letrec", f);
break;
case tc_begin:
Puts("#begin", f);
break;
case tc_promise:
sprintf(STk_tkbuffer, "#[promise %lx (%sforced)]",
(unsigned long) exp,
exp->storage_as.promise.resultknown ? "" : "not ");
Puts(STk_tkbuffer, f);
break;
case tc_apply:
Puts("#apply", f);
break;
case tc_call_cc:
Puts("#call/cc", f);
break;
case tc_dynwind:
Puts("#dynamic-wind", f);
break;
case tc_extend_env:
Puts("#extend-environment", f);
break;
case tc_unbound:
Puts("#[unbound]", f);
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, f);
}
}
return UNDEFINED;
}
Reference in New Issue View Git Blame Copy Permalink