Remove pointer write_ch_fun. Clean up a bit the procedure for preparing the

printer and printing circular objects.
This commit is contained in:
jjgarcia 2002-09-07 15:12:39 +00:00
parent e9204d8d37
commit 0d168a1aa5
6 changed files with 129 additions and 236 deletions

View file

@ -366,11 +366,10 @@ fmt_integer(cl_object x, bool colon, bool atsign,
fmt_temporary_string->string.fillp = 0;
fmt_temporary_stream->stream.int0 = file_column(fmt_stream);
fmt_temporary_stream->stream.int1 = file_column(fmt_stream);
setupPRINT(x, fmt_temporary_stream);
setupPRINT(fmt_temporary_stream);
PRINTescape = FALSE;
PRINTbase = radix;
write_object(x, 0);
cleanupPRINT();
write_object(x);
l = fmt_temporary_string->string.fillp;
mincol -= l;
while (mincol-- > 0)
@ -385,8 +384,7 @@ fmt_integer(cl_object x, bool colon, bool atsign,
PRINTstream = fmt_temporary_stream;
PRINTradix = FALSE;
PRINTbase = radix;
write_ch_fun = writec_PRINTstream;
write_object(x, 0);
write_object(x);
l = l1 = fmt_temporary_string->string.fillp;
s = 0;
if (fmt_tempstr(s) == '-')
@ -609,8 +607,7 @@ fmt_radix(bool colon, bool atsign)
PRINTstream = fmt_temporary_stream;
PRINTradix = FALSE;
PRINTbase = 10;
write_ch_fun = writec_PRINTstream;
write_object(x, 0);
write_object(x);
s = 0;
i = fmt_temporary_string->string.fillp;
if (i == 1 && fmt_tempstr(s) == '0') {

View file

@ -75,15 +75,6 @@ cl_object @'si::*init-function-prefix*';
@(return make_string_copy(dlerror()))
}
if (!Null(verbose)) {
setupPRINT(filename, symbol_value(@'*standard-output*'));
write_str(";;; Address = ");
PRINTescape = FALSE;
write_addr((cl_object)block->cblock.handle);
write_str("\n");
cleanupPRINT();
flush_stream(PRINTstream);
}
/* Finally, perform initialization */
GO_ON:
read_VV(block, block->cblock.entry);
@ -123,11 +114,8 @@ GO_ON:
break;
eval(x, &bytecodes, Cnil);
if (print != Cnil) {
setupPRINT(x, symbol_value(@'*standard-output*'));
write_object(x, 0);
write_str("\n");
cleanupPRINT();
flush_stream(PRINTstream);
@write(1, x);
@terpri(0);
}
}
if (strm != source)
@ -186,15 +174,8 @@ GO_ON:
}
NOT_A_FILENAME:
if (verbose != Cnil) {
setupPRINT(filename, symbol_value(@'*standard-output*'));
if (file_column(PRINTstream) != 0)
write_str("\n");
write_str(";;; Loading ");
PRINTescape = FALSE;
write_object(filename, 0);
write_str("\n");
cleanupPRINT();
flush_stream(PRINTstream);
@fresh-line(0);
@format(3, Cnil, make_simple_string(";;; Loading ~s~%"), filename);
}
old_bds_top = bds_top;
bds_bind(@'*package*', symbol_value(@'*package*'));
@ -216,15 +197,8 @@ NOT_A_FILENAME:
frs_pop();
bds_unwind(old_bds_top);
if (print != Cnil) {
setupPRINT(filename, symbol_value(@'*standard-output*'));
if (file_column(PRINTstream) != 0)
write_str("\n");
write_str(";;; Finished loading ");
PRINTescape = FALSE;
write_object(filename, 0);
write_str("\n");
cleanupPRINT();
flush_stream(PRINTstream);
@fresh-line(0);
@format(3, Cnil, make_simple_string(";;; Loading ~s~%"), filename);
}
@(return pathname)
@)

View file

@ -139,7 +139,6 @@ make_pd()
npd->lwp_PRINTlevel = -1;
npd->lwp_PRINTlength = -1;
npd->lwp_PRINTarray = FALSE;
npd->lwp_write_ch_fun = writec_PRINTstream;
npd->lwp_READtable = symbol_value(@'*readtable*');
npd->lwp_READdefault_float_format = 'S';

View file

@ -62,7 +62,9 @@ bool PRINTgensym;
int PRINTlevel;
int PRINTlength;
bool PRINTarray;
void (*write_ch_fun)(int); /* virtual output (for pretty-print) */
cl_object PRINTpackage;
bool PRINTstructure;
cl_object PRINTstream;
#endif /* THREADS */
/******************************* ------- ******************************/
@ -75,11 +77,6 @@ void (*write_ch_fun)(int); /* virtual output (for pretty-print) */
islower((c)&0377) || (c) == ':')
cl_object PRINTpackage;
bool PRINTstructure;
#define write_ch (*write_ch_fun)
cl_object @'si::pretty-print-format';
cl_object @'si::sharp-exclamation';
@ -114,9 +111,7 @@ static int qc;
static int isp;
static int iisp;
cl_fixnum CIRCLEbase;
cl_object PRINTstream;
static cl_fixnum CIRCLEbase;
#endif /* THREADS */
static void flush_queue (bool force);
@ -125,6 +120,24 @@ static void travel_push_object (cl_object x);
static cl_index searchPRINTcircle(cl_object x);
static bool doPRINTcircle(cl_object x);
static cl_object
stream_or_default_output(cl_object stream)
{
if (Null(stream))
return symbol_value(@'*standard-output*');
else if (stream == Ct)
return symbol_value(@'*terminal-io*');
return stream;
}
void
writec_PRINTstream(int c)
{
if (c == INDENT || c == INDENT1)
writec_stream(' ', PRINTstream);
else if (c < 0400)
writec_stream(c, PRINTstream);
}
static void
writec_queue(int c)
@ -262,10 +275,12 @@ FLUSH:
goto BEGIN;
}
void
writec_PRINTstream(int c)
static void
write_ch(int c)
{
if (c == INDENT || c == INDENT1)
if (PRINTpretty)
writec_queue(c);
else if (c == INDENT || c == INDENT1)
writec_stream(' ', PRINTstream);
else if (c < 0400)
writec_stream(c, PRINTstream);
@ -480,8 +495,6 @@ call_structure_print_function(cl_object x, int level)
bool eflag;
bds_ptr old_bds_top;
void (*wf)(int) = write_ch_fun;
bool e = PRINTescape;
bool r = PRINTradix;
int b = PRINTbase;
@ -574,8 +587,6 @@ call_structure_print_function(cl_object x, int level)
PRINTradix = r;
PRINTescape = e;
write_ch_fun = wf;
if (eflag) unwind(nlj_fr, nlj_tag);
}
@ -731,9 +742,8 @@ write_character(register int i)
}
}
void
write_object(cl_object x, int level)
static void
_write_object(cl_object x, int level)
{
cl_object r, y;
cl_fixnum i, j;
@ -782,14 +792,14 @@ write_object(cl_object x, int level)
if (PRINTradix) {
write_base();
PRINTradix = FALSE;
write_object(x->ratio.num, level);
_write_object(x->ratio.num, level);
write_ch('/');
write_object(x->ratio.den, level);
_write_object(x->ratio.den, level);
PRINTradix = TRUE;
} else {
write_object(x->ratio.num, level);
_write_object(x->ratio.num, level);
write_ch('/');
write_object(x->ratio.den, level);
_write_object(x->ratio.den, level);
}
return;
@ -811,9 +821,9 @@ write_object(cl_object x, int level)
case t_complex:
write_str("#C(");
write_object(x->complex.real, level);
_write_object(x->complex.real, level);
write_ch(' ');
write_object(x->complex.imag, level);
_write_object(x->complex.imag, level);
write_ch(')');
return;
@ -879,7 +889,7 @@ write_object(cl_object x, int level)
}
/* FIXME: This conses! */
if (n == x->array.rank)
write_object(aref(x, m), level+n);
_write_object(aref(x, m), level+n);
else
write_ch('#');
j = n-1;
@ -926,14 +936,14 @@ write_object(cl_object x, int level)
write_ch(UNMARK);
return;
}
write_object(aref(x, 0), level+1);
_write_object(aref(x, 0), level+1);
for (ndx = 1; ndx < x->vector.fillp; ndx++) {
write_ch(INDENT);
if (PRINTlength>=0 && ndx>=PRINTlength){
write_str("...");
break;
}
write_object(aref(x, ndx), level+1);
_write_object(aref(x, ndx), level+1);
}
}
write_ch(')');
@ -1009,13 +1019,13 @@ write_object(cl_object x, int level)
}
y = CAR(x);
x = CDR(x);
write_object(y, level+1);
_write_object(y, level+1);
/* FIXME! */
if (x == OBJNULL || ATOM(x)) {
if (x != Cnil) {
write_ch(INDENT);
write_str(". ");
write_object(x, level);
_write_object(x, level);
}
break;
}
@ -1030,7 +1040,7 @@ write_object(cl_object x, int level)
} else {
write_ch(INDENT);
write_str(". ");
write_object(x, level);
_write_object(x, level);
goto RIGHT_PAREN;
}
}
@ -1058,13 +1068,13 @@ write_object(cl_object x, int level)
if (i <= j && Null(y))
write_str("()");
else
write_object(y, level+1);
_write_object(y, level+1);
/* FIXME! */
if (x == OBJNULL || ATOM(x)) {
if (x != Cnil) {
write_ch(INDENT);
write_str(". ");
write_object(x, level);
_write_object(x, level);
}
break;
}
@ -1079,7 +1089,7 @@ write_object(cl_object x, int level)
case t_package:
write_str("#<");
write_object(x->pack.name, level);
_write_object(x->pack.name, level);
write_str(" package>");
break;
@ -1093,32 +1103,32 @@ write_object(cl_object x, int level)
switch ((enum smmode)x->stream.mode) {
case smm_closed:
write_str("#<closed stream ");
write_object(x->stream.object1, level);
_write_object(x->stream.object1, level);
break;
case smm_input:
write_str("#<input stream ");
write_object(x->stream.object1, level);
_write_object(x->stream.object1, level);
break;
case smm_output:
write_str("#<output stream ");
write_object(x->stream.object1, level);
_write_object(x->stream.object1, level);
break;
case smm_io:
write_str("#<io stream ");
write_object(x->stream.object1, level);
_write_object(x->stream.object1, level);
break;
case smm_probe:
write_str("#<probe stream ");
write_object(x->stream.object1, level);
_write_object(x->stream.object1, level);
break;
case smm_synonym:
write_str("#<synonym stream to ");
write_object(x->stream.object0, level);
_write_object(x->stream.object0, level);
break;
case smm_broadcast:
@ -1165,7 +1175,7 @@ write_object(cl_object x, int level)
case t_random:
write_str("#$");
write_object(MAKE_FIXNUM(x->random.value), level);
_write_object(MAKE_FIXNUM(x->random.value), level);
break;
#ifndef CLOS
@ -1186,7 +1196,7 @@ write_object(cl_object x, int level)
* print shouldn't allocate memory - Beppe
*/
x = structure_to_list(x);
write_object(x, level);
_write_object(x, level);
} else
call_structure_print_function(x, level);
break;
@ -1201,14 +1211,14 @@ write_object(cl_object x, int level)
case t_pathname:
if (PRINTescape)
write_str("#P");
write_object(namestring(x), level);
_write_object(namestring(x), level);
break;
case t_bytecodes: {
cl_object name = x->bytecodes.data[0];
write_str("#<interpreted-function ");
if (name != Cnil)
write_object(name, level);
_write_object(name, level);
else
write_addr(x);
write_ch('>');
@ -1217,7 +1227,7 @@ write_object(cl_object x, int level)
case t_cfun:
write_str("#<compiled-function ");
if (x->cfun.name != Cnil)
write_object(x->cfun.name, level);
_write_object(x->cfun.name, level);
else
write_addr(x);
write_ch('>');
@ -1225,7 +1235,7 @@ write_object(cl_object x, int level)
case t_codeblock:
write_str("#<codeblock ");
if (x->cblock.name != Cnil)
write_object(x->cblock.name, level);
_write_object(x->cblock.name, level);
else
write_addr(x);
write_ch('>');
@ -1238,13 +1248,13 @@ write_object(cl_object x, int level)
#ifdef THREADS
case t_cont:
write_str("#<cont ");
write_object(x->cn.cn_thread, level);
_write_object(x->cn.cn_thread, level);
write_ch('>');
break;
case t_thread:
write_str("#<thread ");
write_object(x->thread.entry, level);
_write_object(x->thread.entry, level);
write_ch(' ');
write_addr(x);
write_ch('>');
@ -1260,7 +1270,7 @@ write_object(cl_object x, int level)
case t_gfun:
write_str("#<dispatch-function ");
if (x->gfun.name != Cnil)
write_object(x->gfun.name, level);
_write_object(x->gfun.name, level);
else
write_addr(x);
write_ch('>');
@ -1394,11 +1404,12 @@ BEGIN:
}
}
void setupPRINT(cl_object x, cl_object strm)
void
setupPRINT(cl_object strm)
{
cl_object y;
PRINTstream = strm;
PRINTstream = stream_or_default_output(strm);
PRINTescape = symbol_value(@'*print-escape*') != Cnil;
PRINTpretty = symbol_value(@'*print-pretty*') != Cnil;
PRINTcircle = symbol_value(@'*print-circle*') != Cnil;
@ -1433,22 +1444,23 @@ void setupPRINT(cl_object x, cl_object strm)
} else
PRINTlength = fix(y);
PRINTarray = symbol_value(@'*print-array*') != Cnil;
/* setupPRINTcircle(x); */
PRINTpackage = symbol_value(@'si::*print-package*');
if (PRINTpackage == Cnil) PRINTpackage = OBJNULL;
PRINTstructure = symbol_value(@'si::*print-structure*') != Cnil;
CIRCLEbase = -1;
}
void
write_object(cl_object x)
{
if (PRINTpretty) {
qh = qt = qc = 0;
isp = iisp = 0;
indent_stack[0] = 0;
write_ch_fun = writec_queue;
} else
write_ch_fun = writec_PRINTstream;
PRINTpackage = symbol_value(@'si::*print-package*');
if (PRINTpackage == Cnil) PRINTpackage = OBJNULL;
PRINTstructure = symbol_value(@'si::*print-structure*') != Cnil;
}
void cleanupPRINT(void)
{
}
if (PRINTcircle)
setupPRINTcircle(x);
_write_object(x, 0);
if (CIRCLEbase >= 0) {
cl_stack_set_index(CIRCLEbase);
CIRCLEbase = -1;
@ -1457,6 +1469,15 @@ void cleanupPRINT(void)
flush_queue(TRUE);
}
void
write_object_with_escape(cl_object x, bool escape)
{
bool oldescape = PRINTescape;
PRINTescape = escape;
write_object(x);
PRINTescape = oldescape;
}
bool
potential_number_p(cl_object strng, int base)
{
@ -1503,11 +1524,7 @@ potential_number_p(cl_object strng, int base)
(gensym symbol_value(@'*print-gensym*'))
(array symbol_value(@'*print-array*')))
@
if (Null(strm))
strm = symbol_value(@'*standard-output*');
else if (strm == Ct)
strm = symbol_value(@'*terminal-io*');
PRINTstream = strm;
PRINTstream = stream_or_default_output(strm);
PRINTescape = escape != Cnil;
PRINTpretty = pretty != Cnil;
PRINTcircle = circle != Cnil;
@ -1534,19 +1551,12 @@ potential_number_p(cl_object strng, int base)
else
PRINTlength = fix((length));
PRINTarray = array != Cnil;
if (PRINTpretty) {
qh = qt = qc = 0;
isp = iisp = 0;
indent_stack[0] = 0;
write_ch_fun = writec_queue;
} else
write_ch_fun = writec_PRINTstream;
PRINTpackage = symbol_value(@'si::*print-package*');
if (PRINTpackage == Cnil) PRINTpackage = OBJNULL;
PRINTstructure = symbol_value(@'si::*print-structure*') != Cnil;
setupPRINTcircle(x);
write_object(x, 0);
cleanupPRINT();
CIRCLEbase = -1;
write_object(x);
flush_stream(PRINTstream);
@(return x)
@)
@ -1565,21 +1575,11 @@ potential_number_p(cl_object strng, int base)
@(defun pprint (obj &optional strm)
@
if (Null(strm))
strm = symbol_value(@'*standard-output*');
else if (strm == Ct)
strm = symbol_value(@'*terminal-io*');
setupPRINT(obj, strm);
setupPRINT(strm);
PRINTescape = TRUE;
PRINTpretty = TRUE;
qh = qt = qc = 0;
isp = iisp = 0;
indent_stack[0] = 0;
write_ch_fun = writec_queue;
writec_PRINTstream('\n');
setupPRINTcircle(obj);
write_object(obj, 0);
cleanupPRINT();
write_object(obj);
flush_stream(PRINTstream);
@(return)
@)
@ -1593,10 +1593,7 @@ potential_number_p(cl_object strng, int base)
@(defun write_char (c &optional strm)
@
/* INV: char_code() checks the type of `c' */
if (Null(strm))
strm = symbol_value(@'*standard-output*');
else if (strm == Ct)
strm = symbol_value(@'*terminal-io*');
strm = stream_or_default_output(strm);
writec_stream(char_code(c), strm);
@(return c)
@)
@ -1605,11 +1602,8 @@ potential_number_p(cl_object strng, int base)
cl_index s, e, i;
@
get_string_start_end(strng, start, end, &s, &e);
strm = stream_or_default_output(strm);
assert_type_string(strng);
if (Null(strm))
strm = symbol_value(@'*standard-output*');
else if (strm == Ct)
strm = symbol_value(@'*terminal-io*');
for (i = s; i < e; i++)
writec_stream(strng->string.self[i], strm);
@ -1621,10 +1615,7 @@ potential_number_p(cl_object strng, int base)
cl_index s, e, i;
@
get_string_start_end(strng, start, end, &s, &e);
if (Null(strm))
strm = symbol_value(@'*standard-output*');
else if (strm == Ct)
strm = symbol_value(@'*terminal-io*');
strm = stream_or_default_output(strm);
assert_type_string(strng);
for (i = s; i < e; i++)
@ -1642,10 +1633,7 @@ potential_number_p(cl_object strng, int base)
@(defun fresh_line (&optional strm)
@
if (Null(strm))
strm = symbol_value(@'*standard-output*');
else if (strm == Ct)
strm = symbol_value(@'*terminal-io*');
strm = stream_or_default_output(strm);
if (file_column(strm) == 0)
@(return Cnil)
writec_stream('\n', strm);
@ -1655,20 +1643,14 @@ potential_number_p(cl_object strng, int base)
@(defun force_output (&o strm)
@
if (Null(strm))
strm = symbol_value(@'*standard-output*');
else if (strm == Ct)
strm = symbol_value(@'*terminal-io*');
strm = stream_or_default_output(strm);
flush_stream(strm);
@(return Cnil)
@)
@(defun clear_output (&o strm)
@
if (Null(strm))
strm = symbol_value(@'*standard-output*');
else if (strm == Ct)
strm = symbol_value(@'*terminal-io*');
strm = stream_or_default_output(strm);
clear_output_stream(strm);
@(return Cnil)
@)
@ -1738,71 +1720,25 @@ init_print(void)
PRINTlevel = -1;
PRINTlength = -1;
PRINTarray = FALSE;
write_ch_fun = writec_PRINTstream;
}
cl_object
princ(cl_object obj, cl_object strm)
{
if (Null(strm))
strm = symbol_value(@'*standard-output*');
else if (strm == Ct)
strm = symbol_value(@'*terminal-io*');
if (obj == OBJNULL)
goto SIMPLE_CASE;
switch (type_of(obj)) {
case t_symbol:
PRINTcase = symbol_value(@'*print-case*');
PRINTpackage = symbol_value(@'si::*print-package*');
if (PRINTpackage == Cnil) PRINTpackage = OBJNULL;
SIMPLE_CASE:
case t_string:
case t_character:
PRINTstream = strm;
PRINTescape = FALSE;
write_ch_fun = writec_PRINTstream;
write_object(obj, 0);
break;
default:
setupPRINT(obj, strm);
PRINTescape = FALSE;
write_object(obj, 0);
cleanupPRINT();
}
return(obj);
setupPRINT(strm);
PRINTescape = FALSE;
write_object(obj);
return obj;
}
cl_object
prin1(cl_object obj, cl_object strm)
{
if (Null(strm))
strm = symbol_value(@'*standard-output*');
else if (strm == Ct)
strm = symbol_value(@'*terminal-io*');
if (obj == OBJNULL)
goto SIMPLE_CASE;
switch (type_of(obj)) {
SIMPLE_CASE:
case t_string:
case t_character:
PRINTstream = strm;
PRINTescape = TRUE;
write_ch_fun = writec_PRINTstream;
write_object(obj, 0);
break;
default:
setupPRINT(obj, strm);
PRINTescape = TRUE;
setupPRINTcircle(obj);
write_object(obj, 0);
cleanupPRINT();
}
setupPRINT(strm);
PRINTescape = TRUE;
write_object(obj);
flush_stream(PRINTstream);
return(obj);
return obj;
}
cl_object
@ -1817,10 +1753,7 @@ print(cl_object obj, cl_object strm)
cl_object
terpri(cl_object strm)
{
if (Null(strm))
strm = symbol_value(@'*standard-output*');
else if (strm == Ct)
strm = symbol_value(@'*terminal-io*');
strm = stream_or_default_output(strm);
writec_stream('\n', strm);
flush_stream(strm);
return(Cnil);
@ -1831,10 +1764,7 @@ write_string(cl_object strng, cl_object strm)
{
cl_index i;
if (Null(strm))
strm = symbol_value(@'*standard-output*');
else if (strm == Ct)
strm = symbol_value(@'*terminal-io*');
strm = stream_or_default_output(strm);
assert_type_string(strng);
for (i = 0; i < strng->string.fillp; i++)
writec_stream(strng->string.self[i], strm);
@ -1845,25 +1775,18 @@ write_string(cl_object strng, cl_object strm)
THE ULTRA-SPECIAL-DINNER-SERVICE OPTIMIZATION
*/
void
princ_str(const char *s, cl_object sym)
princ_str(const char *s, cl_object strm)
{
/* sym = symbol_value(sym); Beppe */
if (Null(sym))
sym = symbol_value(@'*standard-output*');
else if (sym == Ct)
sym = symbol_value(@'*terminal-io*');
writestr_stream(s, sym);
strm = stream_or_default_output(strm);
writestr_stream(s, strm);
}
void
princ_char(int c, cl_object sym)
princ_char(int c, cl_object strm)
{
/* sym = symbol_value(sym); Beppe */
if (Null(sym))
sym = symbol_value(@'*standard-output*');
else if (sym == Ct)
sym = symbol_value(@'*terminal-io*');
writec_stream(c, sym);
strm = stream_or_default_output(strm);
writec_stream(c, strm);
if (c == '\n')
flush_stream(sym);
flush_stream(strm);
}

View file

@ -630,6 +630,7 @@ extern void init_predicate(void);
/* print.c */
#ifndef THREADS
extern bool PRINTescape;
extern bool PRINTpretty;
extern bool PRINTcircle;
@ -640,14 +641,13 @@ extern bool PRINTgensym;
extern int PRINTlevel;
extern int PRINTlength;
extern bool PRINTarray;
extern void (*write_ch_fun)(int);
extern cl_object PRINTpackage;
extern bool PRINTstructure;
extern cl_fixnum CIRCLEbase;
extern cl_object PRINTstream;
#endif
extern int interactive_writec_stream(int c, cl_object stream);
extern void flush_interactive_stream(cl_object stream);
extern void writec_PRINTstream(int c);
extern void write_ch(int c);
extern void write_str(char *s);
extern void write_decimal(int i);
extern void write_addr(cl_object x);
@ -655,8 +655,9 @@ extern void edit_double(int n, double d, int *sp, char *s, int *ep);
extern void write_double(double d, int e, bool shortp);
extern void write_fixnum(cl_fixnum i);
extern void write_bignum(cl_object x);
extern void write_object(cl_object x, int level);
extern void setupPRINT(cl_object x, cl_object strm);
extern void write_object(cl_object x);
extern void write_object_with_escape(cl_object, bool escape);
extern void setupPRINT(cl_object strm);
extern void cleanupPRINT(void);
extern bool potential_number_p(cl_object strng, int base);
extern cl_object princ(cl_object obj, cl_object strm);

View file

@ -106,7 +106,6 @@ typedef struct lpd {
bool lwp_PRINTpackage;
bool lwp_PRINTstructure;
int (*lwp_write_ch_fun)();
int (*lwp_output_ch_fun)();
short lwp_queue[Q_SIZE];
short lwp_indent_stack[IS_SIZE];