mirror of
https://gitlab.com/embeddable-common-lisp/ecl.git
synced 2026-01-10 11:12:58 -08:00
Remove pointer write_ch_fun. Clean up a bit the procedure for preparing the
printer and printing circular objects.
This commit is contained in:
parent
e9204d8d37
commit
0d168a1aa5
6 changed files with 129 additions and 236 deletions
|
|
@ -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') {
|
||||
|
|
|
|||
38
src/c/load.d
38
src/c/load.d
|
|
@ -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)
|
||||
@)
|
||||
|
|
|
|||
|
|
@ -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';
|
||||
|
|
|
|||
303
src/c/print.d
303
src/c/print.d
|
|
@ -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);
|
||||
}
|
||||
|
||||
|
|
|
|||
|
|
@ -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);
|
||||
|
|
|
|||
|
|
@ -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];
|
||||
|
|
|
|||
Loading…
Add table
Add a link
Reference in a new issue