diff --git a/src/c/Makefile.in b/src/c/Makefile.in index 32c461133..6d3486ad2 100644 --- a/src/c/Makefile.in +++ b/src/c/Makefile.in @@ -44,7 +44,10 @@ OBJS = main.o symbol.o package.o list.o\ file.o read.o print.o error.o string.o cfun.o\ reader/parse_integer.o reader/parse_number.o \ printer/float_to_digits.o printer/float_to_string.o \ - printer/integer_to_string.o \ + printer/integer_to_string.o printer/write_ugly.o \ + printer/write_object.o printer/write_symbol.o \ + printer/write_array.o printer/write_list.o printer/write_code.o \ + printer/write_sse.o printer/print_unreadable.o \ typespec.o assignment.o \ predicate.o number.o\ num_pred.o num_comp.o num_arith.o num_sfun.o num_co.o\ diff --git a/src/c/error.d b/src/c/error.d index 1200e8660..0f923e4a3 100644 --- a/src/c/error.d +++ b/src/c/error.d @@ -364,6 +364,12 @@ FEundefined_function(cl_object fname) cl_error(3, @'undefined-function', @':name', fname); } +void +FEprint_not_readable(cl_object x) +{ + cl_error(3, @'print-not-readable', @':object', x); +} + /************* * Shortcuts * *************/ diff --git a/src/c/print.d b/src/c/print.d index 1bc1651f4..97c680db3 100644 --- a/src/c/print.d +++ b/src/c/print.d @@ -14,265 +14,12 @@ See file '../Copyright' for full details. */ - -#include -#include #include -#ifndef _MSC_VER -# include -#endif #include #include -#include -#if defined(ECL_CMU_FORMAT) -# define si_write_object_recursive(x,y) si_write_object(x,y) -#else -static cl_object si_write_object_recursive(cl_object, cl_object); -#endif - -/**********************************************************************/ -/* SUPPORT FOR OLD KCL PRETTY PRINTER */ -/**********************************************************************/ - -#if defined(ECL_CMU_FORMAT) -#define WRITE_MARK(s) -#define WRITE_UNMARK(s) -#define WRITE_SET_INDENT(s) -#define INDENT ' ' -#define INDENT1 ' ' -#define INDENT2 ' ' -#define write_ch ecl_write_char -#define call_print_object(x,s) funcall(3, @'print-object',(x),(s)) -#define call_structure_print_function(f,x,s) funcall(4,(f),(x),(s),MAKE_FIXNUM(0)) -#endif /* ECL_CMU_FORMAT */ - -#if !defined(ECL_CMU_FORMAT) -#define LINE_LENGTH 72 -#define MARK 0400 -#define UNMARK 0401 -#define SET_INDENT 0402 -#define INDENT 0403 -#define INDENT1 0404 -#define INDENT2 0405 -#define mod(x) ((x)%ECL_PPRINT_QUEUE_SIZE) -#define WRITE_MARK(s) write_ch(MARK,s) -#define WRITE_UNMARK(s) write_ch(UNMARK,s) -#define WRITE_SET_INDENT(s) write_ch(SET_INDENT,s) -static void flush_queue(bool force, cl_object stream); - -static void -writec_queue(int c, cl_object stream) -{ - const cl_env_ptr env = ecl_process_env(); - if (env->qc >= ECL_PPRINT_QUEUE_SIZE) - flush_queue(FALSE, stream); - if (env->qc >= ECL_PPRINT_QUEUE_SIZE) - FEerror("Can't pretty-print.", 0); - env->queue[env->qt] = c; - env->qt = mod(env->qt+1); - env->qc++; -} - -static void -flush_queue(bool force, cl_object stream) -{ - const cl_env_ptr env = ecl_process_env(); - int c, i, j, k, l, i0; -BEGIN: - while (env->qc > 0) { - c = env->queue[env->qh]; - if (c < 0400) { - ecl_write_char(c, stream); - } else if (c == MARK) - goto DO_MARK; - else if (c == UNMARK) - env->isp -= 2; - else if (c == SET_INDENT) - env->indent_stack[env->isp] = ecl_file_column(stream); - else if (c == INDENT) { - goto DO_INDENT; - } else if (c == INDENT1) { - i = ecl_file_column(stream)-env->indent_stack[env->isp]; - if (i < 8 && env->indent_stack[env->isp] < LINE_LENGTH/2) { - ecl_write_char(' ', stream); - env->indent_stack[env->isp] - = ecl_file_column(stream); - } else { - if (env->indent_stack[env->isp] < LINE_LENGTH/2) { - env->indent_stack[env->isp] - = env->indent_stack[env->isp-1] + 4; - } - goto DO_INDENT; - } - } else if (c == INDENT2) { - env->indent_stack[env->isp] = env->indent_stack[env->isp-1] + 2; - goto PUT_INDENT; - } - env->qh = mod(env->qh+1); - --env->qc; - } - return; - -DO_MARK: - k = LINE_LENGTH - 1 - ecl_file_column(stream); - for (i = 1, j = 0, l = 1; l > 0 && i < env->qc && j < k; i++) { - c = env->queue[mod(env->qh + i)]; - if (c == MARK) - l++; - else if (c == UNMARK) - --l; - else if (c == INDENT || c == INDENT1 || c == INDENT2) - j++; - else if (c < 0400) - j++; - } - if (l == 0) - goto FLUSH; - if (i == env->qc && !force) - return; - env->qh = mod(env->qh+1); - --env->qc; - if (env->isp >= ECL_PPRINT_INDENTATION_STACK_SIZE-2) - FEerror("Can't pretty-print.", 0); - env->isp+=2; - env->indent_stack[env->isp-1] = ecl_file_column(stream); - env->indent_stack[env->isp] = env->indent_stack[env->isp-1]; - goto BEGIN; - -DO_INDENT: - if (env->iisp > env->isp) - goto PUT_INDENT; - k = LINE_LENGTH - 1 - ecl_file_column(stream); - for (i0 = 0, i = 1, j = 0, l = 1; i < env->qc && j < k; i++) { - c = env->queue[mod(env->qh + i)]; - if (c == MARK) - l++; - else if (c == UNMARK) { - if (--l == 0) - goto FLUSH; - } else if (c == SET_INDENT) { - if (l == 1) - break; - } else if (c == INDENT) { - if (l == 1) - i0 = i; - j++; - } else if (c == INDENT1) { - if (l == 1) - break; - j++; - } else if (c == INDENT2) { - if (l == 1) { - i0 = i; - break; - } - j++; - } else if (c < 0400) - j++; - } - if (i == env->qc && !force) - return; - if (i0 == 0) - goto PUT_INDENT; - i = i0; - goto FLUSH; - -PUT_INDENT: - env->qh = mod(env->qh+1); - --env->qc; - ecl_write_char('\n', stream); - for (i = env->indent_stack[env->isp]; i > 0; --i) - ecl_write_char(' ', stream); - env->iisp = env->isp; - goto BEGIN; - -FLUSH: - for (j = 0; j < i; j++) { - c = env->queue[env->qh]; - if (c == INDENT || c == INDENT1 || c == INDENT2) - ecl_write_char(' ', stream); - else if (c < 0400) - ecl_write_char(c, stream); - env->qh = mod(env->qh+1); - --env->qc; - } - goto BEGIN; -} - -static void -write_ch(int c, cl_object stream) -{ - const cl_env_ptr env = ecl_process_env(); - if (env->print_pretty) - writec_queue(c, stream); - else if (c == INDENT || c == INDENT1) - ecl_write_char(' ', stream); - else if (c < 0400) - ecl_write_char(c, stream); -} - -static void -#ifdef CLOS -call_print_object(cl_object x, cl_object stream) -#else -call_structure_print_function(cl_object f, cl_object x, cl_object stream) -#endif -{ - const cl_env_ptr env = ecl_process_env(); - short ois[ECL_PPRINT_INDENTATION_STACK_SIZE]; - volatile bool p = env->print_pretty; - volatile int oqh, oqt, oqc, oisp, oiisp; - - if ((p = env->print_pretty)) { - flush_queue(TRUE, stream); - oqh = env->qh; - oqt = env->qt; - oqc = env->qc; - oisp = env->isp; - oiisp = env->iisp; - memcpy(ois, env->indent_stack, env->isp * sizeof(*ois)); - } - CL_UNWIND_PROTECT_BEGIN(env) { -#ifdef CLOS - funcall(3, @'print-object', x, stream); -#else - funcall(4, f, x, stream, MAKE_FIXNUM(0)); -#endif - } CL_UNWIND_PROTECT_EXIT { - if ((env->print_pretty = p)) { - memcpy(env->indent_stack, ois, oisp * sizeof(*ois)); - env->iisp = oiisp; - env->isp = oisp; - env->qc = oqc; - env->qt = oqt; - env->qh = oqh; - } - } CL_UNWIND_PROTECT_END; -} -#endif /* !ECL_CMU_FORMAT */ - -/**********************************************************************/ - -#define to_be_escaped(c) \ - (cl_core.standard_readtable->readtable.table[(c)&0377].syntax_type \ - != cat_constituent || \ - ecl_lower_case_p((c)&0377) || (c) == ':') - -static bool object_will_print_as_hash(cl_object x); -static cl_fixnum search_print_circle(cl_object x); -static bool potential_number_p(cl_object s, int base); - -static void FEprint_not_readable(cl_object x) ecl_attr_noreturn; - -static void -FEprint_not_readable(cl_object x) -{ - cl_error(3, @'print-not-readable', @':object', x); -} - -static cl_object -stream_or_default_output(cl_object stream) +cl_object +_ecl_stream_or_default_output(cl_object stream) { if (Null(stream)) return ECL_SYM_VAL(ecl_process_env(),@'*standard-output*'); @@ -303,7 +50,7 @@ ecl_print_level(void) level = MOST_POSITIVE_FIXNUM; } else if (ECL_FIXNUMP(object)) { level = fix(object); - unlikely_if (level < 0) { + if (level < 0) { ERROR: ECL_SETQ(ecl_process_env(), @'*print-level*', Cnil); FEerror("The value of *PRINT-LEVEL*~% ~S~%" "is not of the expected type (OR NULL (INTEGER 0 *))", @@ -392,1206 +139,6 @@ ecl_print_circle(void) return ecl_symbol_value(@'*print-circle*') != Cnil; } -static void -write_str(const char *s, cl_object stream) -{ - while (*s != '\0') - write_ch(*s++, stream); -} - -static void -write_readable_pathname(cl_object path, cl_object stream) -{ - cl_object l = - cl_list(15, @'make-pathname', - @':host', path->pathname.host, - @':device', path->pathname.device, - @':directory', - cl_funcall(2, @'ext::maybe-quote', path->pathname.directory), - @':name', path->pathname.name, - @':type', path->pathname.type, - @':version', path->pathname.version, - @':defaults', Cnil); - write_str("#.", stream); - si_write_object_recursive(l, stream); -} - -static void -write_pathname(cl_object path, cl_object stream) -{ - cl_object namestring = ecl_namestring(path, 0); - bool readably = ecl_print_readably(); - if (namestring == Cnil) { - if (readably) { - write_readable_pathname(path, stream); - return; - } - namestring = ecl_namestring(path, 1); - if (namestring == Cnil) { - write_str("#", stream); - return; - } - } - if (readably || ecl_print_escape()) - write_str("#P", stream); - si_write_ugly_object(namestring, stream); -} - -static void -write_integer(cl_object number, cl_object stream) -{ - cl_object s = si_get_buffer_string(); - int print_base = ecl_print_base(); - si_integer_to_string(s, number, - MAKE_FIXNUM(print_base), - ecl_symbol_value(@'*print-radix*'), - Ct /* decimal syntax */); - si_do_write_sequence(s, stream, MAKE_FIXNUM(0), Cnil); - si_put_buffer_string(s); -} - -static void -write_decimal(cl_fixnum i, cl_object stream) -{ - cl_object s = si_get_buffer_string(); - si_integer_to_string(s, MAKE_FIXNUM(i), MAKE_FIXNUM(10), Cnil, Cnil); - si_do_write_sequence(s, stream, MAKE_FIXNUM(0), Cnil); - si_put_buffer_string(s); -} - -static void -write_ratio(cl_object r, cl_object stream) -{ - cl_object s = si_get_buffer_string(); - int print_base = ecl_print_base(); - si_integer_to_string(s, r->ratio.num, MAKE_FIXNUM(print_base), - ecl_symbol_value(@'*print-radix*'), - Cnil /* decimal syntax */); - ecl_string_push_extend(s, '/'); - si_integer_to_string(s, r->ratio.den, - MAKE_FIXNUM(print_base), - Cnil, Cnil); - si_do_write_sequence(s, stream, MAKE_FIXNUM(0), Cnil); - si_put_buffer_string(s); -} - -static void -write_addr(cl_object x, cl_object stream) -{ - cl_fixnum i, j; - - i = (cl_index)x; - for (j = sizeof(i)*8-4; j >= 0; j -= 4) { - int k = (i>>j) & 0xf; - if (k < 10) - write_ch('0' + k, stream); - else - write_ch('a' + k - 10, stream); - } -} - -static void -write_float(cl_object f, cl_object stream) -{ - cl_object s = si_get_buffer_string(); - s = si_float_to_string_free(s, f, MAKE_FIXNUM(-3), MAKE_FIXNUM(8)); - si_do_write_sequence(s, stream, MAKE_FIXNUM(0), Cnil); - si_put_buffer_string(s); -} - - -static bool -all_dots(cl_object s) -{ - cl_index i; - for (i = 0; i < s->base_string.fillp; i++) - if (ecl_char(s, i) != '.') - return 0; - return 1; -} - -static bool -needs_to_be_escaped(cl_object s, cl_object readtable, cl_object print_case) -{ - int action = readtable->readtable.read_case; - cl_index i; - if (potential_number_p(s, ecl_print_base())) - return 1; - /* The value of *PRINT-ESCAPE* is T. We need to check whether the - * symbol name S needs to be escaped. This will happen if it has some - * strange character, or if it has a lowercase character (because such - * a character cannot be read with the standard readtable) or if the - * string has to be escaped according to readtable case and the rules - * of 22.1.3.3.2. */ - for (i = 0; i < s->base_string.fillp; i++) { - int c = ecl_char(s, i); - int syntax = ecl_readtable_get(readtable, c, 0); - if (syntax != cat_constituent || - ecl_invalid_character_p(c) || - (c) == ':') - return 1; - if ((action == ecl_case_downcase) && ecl_upper_case_p(c)) - return 1; - if (ecl_lower_case_p(c)) - return 1; - } - return 0; -} - -#define needs_to_be_inverted(s) (ecl_string_case(s) != 0) - -static void -write_symbol_string(cl_object s, int action, cl_object print_case, - cl_object stream, bool escape) -{ - cl_index i; - bool capitalize; - if (action == ecl_case_invert) { - if (!needs_to_be_inverted(s)) - action = ecl_case_preserve; - } - if (escape) - write_ch('|', stream); - capitalize = 1; - for (i = 0; i < s->base_string.fillp; i++) { - int c = ecl_char(s, i); - if (escape) { - if (c == '|' || c == '\\') { - write_ch('\\', stream); - } - } else if (action != ecl_case_preserve) { - if (ecl_upper_case_p(c)) { - if ((action == ecl_case_invert) || - ((action == ecl_case_upcase) && - ((print_case == @':downcase') || - ((print_case == @':capitalize') && !capitalize)))) - { - c = ecl_char_downcase(c); - } - capitalize = 0; - } else if (ecl_lower_case_p(c)) { - if ((action == ecl_case_invert) || - ((action == ecl_case_downcase) && - ((print_case == @':upcase') || - ((print_case == @':capitalize') && capitalize)))) - { - c = ecl_char_upcase(c); - } - capitalize = 0; - } else { - capitalize = !ecl_alphanumericp(c); - } - } - write_ch(c, stream); - } - if (escape) - write_ch('|', stream); -} - -static void -write_symbol(cl_object x, cl_object stream) -{ - cl_object print_package = ecl_symbol_value(@'si::*print-package*'); - cl_object readtable = ecl_current_readtable(); - cl_object print_case = ecl_print_case(); - cl_object package; - cl_object name; - int intern_flag; - bool print_readably = ecl_print_readably(); - - if (Null(x)) { - package = Cnil_symbol->symbol.hpack; - name = Cnil_symbol->symbol.name; - } else { - package = x->symbol.hpack; - name = x->symbol.name; - } - - if (!print_readably && !ecl_print_escape()) { - write_symbol_string(name, readtable->readtable.read_case, - print_case, stream, 0); - return; - } - /* From here on, print-escape is true which means that it should - * be possible to recover the same symbol by reading it with - * the standard readtable (which has readtable-case = :UPCASE) - */ - if (Null(package)) { - if (ecl_print_gensym() || print_readably) - write_str("#:", stream); - } else if (package == cl_core.keyword_package) { - write_ch(':', stream); - } else if ((print_package != Cnil && package != print_package) - || ecl_find_symbol(ecl_symbol_name(x), ecl_current_package(), - &intern_flag)!=x - || intern_flag == 0) - { - cl_object name = package->pack.name; - write_symbol_string(name, readtable->readtable.read_case, - print_case, stream, - needs_to_be_escaped(name, readtable, print_case)); - if (ecl_find_symbol(ecl_symbol_name(x), package, &intern_flag) != x) - ecl_internal_error("can't print symbol"); - if ((print_package != Cnil && package != print_package) - || intern_flag == INTERNAL) { - write_str("::", stream); - } else if (intern_flag == EXTERNAL) { - write_ch(':', stream); - } else { - FEerror("Pathological symbol --- cannot print.", 0); - } - } - write_symbol_string(name, readtable->readtable.read_case, print_case, stream, - needs_to_be_escaped(name, readtable, print_case) || - all_dots(name)); -} - -static void -write_character(int i, cl_object stream) -{ - if (!ecl_print_escape() && !ecl_print_readably()) { - write_ch(i, stream); - } else { - write_str("#\\", stream); - if (i < 32 || i == 127) { - cl_object name = cl_char_name(CODE_CHAR(i)); - write_str((char*)name->base_string.self, stream); - } else if (i >= 128) { - int index = 0; - char name[20]; - sprintf(name, "U%04x", i); /* cleanup */ - while(name[index]) - write_ch(name[index++], stream); - } else { - write_ch(i, stream); - } - } -} - -static void -write_array(bool vector, cl_object x, cl_object stream) -{ - cl_env_ptr env = ecl_process_env(); - const cl_index *adims; - cl_index subscripts[ARANKLIM]; - cl_fixnum n, j, m, k, i; - cl_fixnum print_length; - cl_fixnum print_level; - bool readably = ecl_print_readably(); - - if (vector) { - adims = &x->vector.fillp; - n = 1; - } else { - adims = x->array.dims; - n = x->array.rank; - } - if (readably) { - print_length = MOST_POSITIVE_FIXNUM; - print_level = MOST_POSITIVE_FIXNUM; - } else { - if (!ecl_print_array()) { - write_str(vector? "#', stream); - return; - } - print_level = ecl_print_level(); - print_length = ecl_print_length(); - } - write_ch('#', stream); - if (print_level == 0) - return; - if (readably) { - write_ch('A', stream); - write_ch('(', stream); - si_write_object_recursive(ecl_elttype_to_symbol(ecl_array_elttype(x)), stream); - write_ch(INDENT, stream); - if (n > 0) { - write_ch('(', stream); - for (j=0; j= n) { - /* We can write the elements of the array */ - print_level -= n; - ecl_bds_bind(env, @'*print-level*', MAKE_FIXNUM(print_level)); - } else { - /* The elements of the array are not printed */ - n = print_level; - print_level = -1; - } - for (j = 0; j < n; j++) - subscripts[j] = 0; - for (m = 0, j = 0;;) { - for (i = j; i < n; i++) { - if (subscripts[i] == 0) { - WRITE_MARK(stream); - write_ch('(', stream); - WRITE_SET_INDENT(stream); - if (adims[i] == 0) { - write_ch(')', stream); - WRITE_UNMARK(stream); - j = i-1; - k = 0; - goto INC; - } - } - if (subscripts[i] > 0) - write_ch(INDENT, stream); - if (subscripts[i] >= print_length) { - write_str("...)", stream); - WRITE_UNMARK(stream); - k=adims[i]-subscripts[i]; - subscripts[i] = 0; - for (j = i+1; j < n; j++) - k *= adims[j]; - j = i-1; - goto INC; - } - } - /* FIXME: This conses! */ - if (print_level >= 0) - si_write_object_recursive(ecl_aref_unsafe(x, m), stream); - else - write_ch('#', stream); - j = n-1; - k = 1; - - INC: - while (j >= 0) { - if (++subscripts[j] < adims[j]) - break; - subscripts[j] = 0; - write_ch(')', stream); - WRITE_UNMARK(stream); - --j; - } - if (j < 0) - break; - m += k; - } - if (print_level >= 0) { - ecl_bds_unwind1(env); - } - if (readably) { - write_ch(')', stream); - } -} - -#ifdef ECL_SSE2 -static int -is_all_FF(void *ptr, int size) { - int i; - for (i = 0; i < size; i++) - if (((unsigned char*)ptr)[i] != 0xFF) - return 0; - return 1; -} - -static void -write_sse_float(float v, cl_object stream) -{ - if (is_all_FF(&v, sizeof(float))) - write_str(" TRUE", stream); - else { - char buf[60]; - sprintf(buf, " %g", v); - write_str(buf, stream); - } -} - -static void -write_sse_double(double v, cl_object stream) -{ - if (is_all_FF(&v, sizeof(double))) - write_str(" TRUE", stream); - else { - char buf[60]; - sprintf(buf, " %lg", v); - write_str(buf, stream); - } -} - -static void -write_sse_pack(cl_object x, cl_object stream) -{ - int i; - cl_elttype etype = x->sse.elttype; - cl_object mode = ecl_symbol_value(@'ext::*sse-pack-print-mode*'); - - if (mode != Cnil) { - if (mode == @':float') etype = aet_sf; - else if (mode == @':double') etype = aet_df; - else etype = aet_b8; - } - - switch (x->sse.elttype) { - case aet_sf: - for (i = 0; i < 4; i++) - write_sse_float(x->sse.data.sf[i], stream); - break; - case aet_df: - write_sse_double(x->sse.data.df[0], stream); - write_sse_double(x->sse.data.df[1], stream); - break; - default: - for (i = 0; i < 16; i++) { - char buf[10]; - int pad = 1 + (i%4 == 0); - sprintf(buf, "%*c%02x", pad, ' ', x->sse.data.b8[i]); - write_str(buf, stream); - } - break; - } -} -#endif - -cl_object -si_write_ugly_object(cl_object x, cl_object stream) -{ - cl_object r, y; - cl_fixnum i; - cl_index ndx, k; - - if (x == OBJNULL) { - if (ecl_print_readably()) - FEprint_not_readable(x); - write_str("#", stream); - goto OUTPUT; - } - switch (type_of(x)) { - - case FREE: - write_str("#', stream); - break; - - case t_fixnum: - case t_bignum: - write_integer(x, stream); - break; - case t_ratio: - write_ratio(x, stream); - break; - case t_singlefloat: - case t_doublefloat: -#ifdef ECL_LONG_FLOAT - case t_longfloat: -#endif - write_float(x, stream); - break; - case t_complex: - write_str("#C(", stream); - si_write_ugly_object(x->complex.real, stream); - write_ch(' ', stream); - si_write_ugly_object(x->complex.imag, stream); - write_ch(')', stream); - break; - - case t_character: { - write_character(CHAR_CODE(x), stream); - } - break; - - case t_symbol: - write_symbol(x, stream); - break; - - case t_array: - write_array(0, x, stream); - break; - -#ifdef ECL_UNICODE - case t_string: - if (!ecl_print_escape() && !ecl_print_readably()) { - for (ndx = 0; ndx < x->string.fillp; ndx++) - write_ch(x->string.self[ndx], stream); - break; - } - write_ch('"', stream); - for (ndx = 0; ndx < x->string.fillp; ndx++) { - ecl_character c = x->string.self[ndx]; - if (c == '"' || c == '\\') - write_ch('\\', stream); - write_ch(c, stream); - } - write_ch('"', stream); - break; -#endif - case t_vector: - write_array(1, x, stream); - break; - - case t_base_string: - if (!ecl_print_escape() && !ecl_print_readably()) { - for (ndx = 0; ndx < x->base_string.fillp; ndx++) - write_ch(x->base_string.self[ndx], stream); - break; - } - write_ch('"', stream); - for (ndx = 0; ndx < x->base_string.fillp; ndx++) { - int c = x->base_string.self[ndx]; - if (c == '"' || c == '\\') - write_ch('\\', stream); - write_ch(c, stream); - } - write_ch('"', stream); - break; - - case t_bitvector: - if (!ecl_print_array() && !ecl_print_readably()) { - write_str("#', stream); - break; - } - write_str("#*", stream); - for (ndx = 0; ndx < x->vector.fillp; ndx++) - if (x->vector.self.bit[(ndx+x->vector.offset)/8] & (0200 >> (ndx+x->vector.offset)%8)) - write_ch('1', stream); - else - write_ch('0', stream); - break; - - case t_list: { - const cl_env_ptr env = ecl_process_env(); - bool circle; - cl_fixnum print_level, print_length; - if (Null(x)) { - write_symbol(x, stream); - break; - } - if (CAR(x) == @'si::#!') { - write_str("#!", stream); - x = CDR(x); - return si_write_object_recursive(x, stream); - } - if (CONSP(CDR(x)) && Null(CDDR(x))) { - if (CAR(x) == @'quote') { - write_ch('\'', stream); - x = CADR(x); - return si_write_object_recursive(x, stream); - } - if (CAR(x) == @'function') { - write_ch('#', stream); - write_ch('\'', stream); - x = CADR(x); - return si_write_object_recursive(x, stream); - } - if (CAR(x) == @'si::quasiquote') { - write_ch('`', stream); - x = CADR(x); - return si_write_object_recursive(x, stream); - } - if (CAR(x) == @'si::unquote') { - write_ch(',', stream); - x = CADR(x); - return si_write_object_recursive(x, stream); - } - if (CAR(x) == @'si::unquote-splice') { - write_str(",@@", stream); - x = CADR(x); - return si_write_object_recursive(x, stream); - } - if (CAR(x) == @'si::unquote-nsplice') { - write_str(",.", stream); - x = CADR(x); - return si_write_object_recursive(x, stream); - } - } - circle = ecl_print_circle(); - if (ecl_print_readably()) { - print_level = MOST_POSITIVE_FIXNUM; - print_length = MOST_POSITIVE_FIXNUM; - } else { - print_level = ecl_print_level(); - print_length = ecl_print_length(); - } - if (print_level == 0) { - write_ch('#', stream); - break; - } - ecl_bds_bind(env, @'*print-level*', MAKE_FIXNUM(print_level-1)); - WRITE_MARK(stream); - write_ch('(', stream); - WRITE_SET_INDENT(stream); -#if !defined(ECL_CMU_FORMAT) - if (ecl_process_env()->print_pretty && CAR(x) != OBJNULL && - type_of(CAR(x)) == t_symbol && - (r = si_get_sysprop(CAR(x), @'si::pretty-print-format')) != Cnil) - goto PRETTY_PRINT_FORMAT; -#endif - for (i = 0; ; i++) { - if (i >= print_length) { - write_str("...", stream); - break; - } - y = CAR(x); - x = CDR(x); - si_write_object_recursive(y, stream); - /* FIXME! */ - if (x == OBJNULL || ATOM(x) || - (circle && object_will_print_as_hash(x))) - { - if (x != Cnil) { - write_ch(INDENT, stream); - write_str(". ", stream); - si_write_object_recursive(x, stream); - } - break; - } - if (i == 0 && y != OBJNULL && type_of(y) == t_symbol) - write_ch(INDENT1, stream); - else - write_ch(INDENT, stream); - } - RIGHT_PAREN: - write_ch(')', stream); - WRITE_UNMARK(stream); - ecl_bds_unwind1(env); - break; -#if !defined(ECL_CMU_FORMAT) - PRETTY_PRINT_FORMAT: - j = fixint(r); - for (i = 0; ; i++) { - if (i >= print_length) { - write_str("...", stream); - break; - } - y = CAR(x); - x = CDR(x); - if (i <= j && Null(y)) - write_str("()", stream); - else - si_write_object_recursive(y, stream); - /* FIXME! */ - if (x == OBJNULL || ATOM(x) || - (circle && object_will_print_as_hash(x))) { - if (x != Cnil) { - write_ch(INDENT, stream); - write_str(". ", stream); - si_write_object_recursive(x, stream); - } - break; - } - if (i >= j) - write_ch(INDENT2, stream); - else if (i == 0) - write_ch(INDENT1, stream); - else - write_ch(INDENT, stream); - } - goto RIGHT_PAREN; -#endif - } - case t_package: - if (ecl_print_readably()) FEprint_not_readable(x); - write_str("#<", stream); - si_write_ugly_object(x->pack.name, stream); - write_str(" package>", stream); - break; - - case t_hashtable: - if (ecl_print_readably()) FEprint_not_readable(x); - write_str("#', stream); - break; - - case t_stream: - if (ecl_print_readably()) FEprint_not_readable(x); - write_str(x->stream.closed? "#stream.mode) { - case smm_input_file: - case smm_input: - write_str("input stream ", stream); - si_write_ugly_object(IO_STREAM_FILENAME(x), stream); - break; - case smm_output_file: - case smm_output: - write_str("output stream ", stream); - si_write_ugly_object(IO_STREAM_FILENAME(x), stream); - break; -#ifdef ECL_MS_WINDOWS_HOST - case smm_input_wsock: - write_str("input win32 socket stream ", stream); - si_write_ugly_object(IO_STREAM_FILENAME(x), stream); - break; - - case smm_output_wsock: - write_str("output win32 socket stream ", stream); - si_write_ugly_object(IO_STREAM_FILENAME(x), stream); - break; - - case smm_io_wsock: - write_str("i/o win32 socket stream ", stream); - si_write_ugly_object(IO_STREAM_FILENAME(x), stream); - break; -#endif - case smm_io_file: - case smm_io: - write_str("io stream ", stream); - si_write_ugly_object(IO_STREAM_FILENAME(x), stream); - break; - - case smm_probe: - write_str("probe stream ", stream); - si_write_ugly_object(IO_STREAM_FILENAME(x), stream); - break; - - case smm_synonym: - write_str("synonym stream to ", stream); - si_write_ugly_object(SYNONYM_STREAM_SYMBOL(x), stream); - break; - - case smm_broadcast: - write_str("broadcast stream ", stream); - write_addr(x, stream); - break; - - case smm_concatenated: - write_str("concatenated stream ", stream); - write_addr(x, stream); - break; - - case smm_two_way: - write_str("two-way stream ", stream); - write_addr(x, stream); - break; - - case smm_echo: - write_str("echo stream ", stream); - write_addr(x, stream); - break; - - case smm_string_input: - write_str("string-input stream from \"", stream); - y = x->stream.object0; - k = y->base_string.fillp; - for (ndx = 0; ndx < k && ndx < 16; ndx++) - write_ch(y->base_string.self[ndx], stream); - if (k > 16) - write_str("...", stream); - write_ch('"', stream); - break; - - case smm_string_output: - write_str("string-output stream ", stream); - write_addr(x, stream); - break; - - default: - ecl_internal_error("illegal stream mode"); - } - write_ch('>', stream); - break; - - case t_random: - if (ecl_print_readably()) { - write_str("#$", stream); - write_array(1, x->random.value, stream); - } else { - write_str("#random.value, stream); - write_str("#>", stream); - } - break; - -#ifndef CLOS - case t_structure: { - cl_object print_function; - unlikely_if (type_of(x->str.name) != t_symbol) - FEerror("Found a corrupt structure with an invalid type name~%" - " ~S", x->str.name); - print_function = si_get_sysprop(x->str.name, @'si::structure-print-function'); - if (Null(print_function) || !ecl_print_structure()) - { - write_str("#S", stream); -/* structure_to_list conses slot names and values into a list to be printed. - * print shouldn't allocate memory - Beppe - */ - x = structure_to_list(x); - si_write_object_recursive(x, stream); - } else { - call_structure_print_function(print_function, x, stream); - } - break; - } -#endif /* CLOS */ - case t_readtable: - if (ecl_print_readably()) FEprint_not_readable(x); - write_str("#', stream); - break; - - case t_pathname: - write_pathname(x, stream); - break; - - case t_bclosure: - if (ecl_print_readably()) { - cl_index i; - cl_object lex = x->bclosure.lex; - cl_object code_l=Cnil, data_l=Cnil; - x = x->bclosure.code; - for ( i=x->bytecodes.code_size-1 ; i<(cl_index)(-1l) ; i-- ) - code_l = ecl_cons(MAKE_FIXNUM(((cl_opcode*)(x->bytecodes.code))[i]), code_l); - for ( i=x->bytecodes.data_size-1 ; i<(cl_index)(-1l) ; i-- ) - data_l = ecl_cons(x->bytecodes.data[i], data_l); - - write_str("#Y", stream); - si_write_ugly_object( - cl_list(5, x->bytecodes.name, lex, - Cnil /* x->bytecodes.definition */, - code_l, data_l), - stream); - break; - } else { - cl_object name = x->bytecodes.name; - write_str("#', stream); - } - break; - case t_bytecodes: - if ( ecl_print_readably() ) { - cl_index i; - cl_object lex = Cnil; - cl_object code_l=Cnil, data_l=Cnil; - for ( i=x->bytecodes.code_size-1 ; i<(cl_index)(-1l) ; i-- ) - code_l = ecl_cons(MAKE_FIXNUM(((cl_opcode*)(x->bytecodes.code))[i]), code_l); - for ( i=x->bytecodes.data_size-1 ; i<(cl_index)(-1l) ; i-- ) - data_l = ecl_cons(x->bytecodes.data[i], data_l); - write_str("#Y", stream); - si_write_ugly_object( - cl_list(5, x->bytecodes.name, lex, - Cnil /* x->bytecodes.definition */, - code_l, data_l), - stream); - break; - } else { - cl_object name = x->bytecodes.name; - write_str("#', stream); - } - break; - case t_cfun: - case t_cfunfixed: - if (ecl_print_readably()) FEprint_not_readable(x); - write_str("#cfun.name != Cnil) - si_write_ugly_object(x->cfun.name, stream); - else - write_addr(x, stream); - write_ch('>', stream); - break; - case t_codeblock: - if (ecl_print_readably()) FEprint_not_readable(x); - write_str("#cblock.name != Cnil) - si_write_ugly_object(x->cblock.name, stream); - else - write_addr(x, stream); - write_ch('>', stream); - break; - case t_cclosure: - if (ecl_print_readably()) FEprint_not_readable(x); - write_str("#', stream); - break; -#ifdef CLOS - case t_instance: - call_print_object(x, stream); - break; -#endif /* CLOS */ - case t_foreign: - if (ecl_print_readably()) FEprint_not_readable(x); - write_str("#foreign.tag, stream); - write_ch(' ', stream); - write_addr((cl_object)x->foreign.data, stream); - write_ch('>', stream); - break; - case t_frame: - if (ecl_print_readably()) FEprint_not_readable(x); - write_str("#frame.size, stream); - write_ch(' ', stream); - write_addr((void*)x->frame.base, stream); - write_ch('>', stream); - break; - case t_weak_pointer: - if (ecl_print_readably()) FEprint_not_readable(x); - write_str("#', stream); - break; -#ifdef ECL_THREADS - case t_process: - if (ecl_print_readably()) FEprint_not_readable(x); - write_str("#process.name, stream); - write_ch(' ', stream); - write_addr(x, stream); - write_ch('>', stream); - break; - case t_lock: - if (ecl_print_readably()) FEprint_not_readable(x); - write_str("#lock.recursive) - write_str("(nonrecursive) ", stream); - si_write_object_recursive(x->lock.name, stream); - write_ch(' ', stream); - write_addr(x, stream); - write_ch('>', stream); - break; - case t_condition_variable: - if (ecl_print_readably()) FEprint_not_readable(x); - write_str("#', stream); - break; -#endif /* ECL_THREADS */ -#ifdef ECL_SEMAPHORES - case t_semaphore: - if (ecl_print_readably()) FEprint_not_readable(x); - write_str("#', stream); - break; -#endif -#ifdef ECL_SSE2 - case t_sse_pack: - if (ecl_print_readably()) FEprint_not_readable(x); - write_str("#', stream); - break; -#endif - default: - if (ecl_print_readably()) FEprint_not_readable(x); - write_str("#', stream); - } - OUTPUT: - @(return x) -} - -#if defined(ECL_CMU_FORMAT) -#undef si_write_object_recursive -cl_object -si_write_object(cl_object x, cl_object stream) -#else -static cl_object -si_write_object_recursive(cl_object x, cl_object stream) -#endif -{ - bool circle; -#if defined(ECL_CMU_FORMAT) - if (ecl_symbol_value(@'*print-pretty*') != Cnil) { - cl_object f = funcall(2, @'pprint-dispatch', x); - if (VALUES(1) != Cnil) { - funcall(3, f, stream, x); - return x; - } - } -#endif /* ECL_CMU_FORMAT */ - circle = ecl_print_circle(); - if (circle && !Null(x) && !FIXNUMP(x) && !CHARACTERP(x) && - (LISTP(x) || (x->d.t != t_symbol) || (Null(x->symbol.hpack)))) - { - cl_object circle_counter; - cl_fixnum code; - circle_counter = ecl_symbol_value(@'si::*circle-counter*'); - if (circle_counter == Cnil) { - cl_env_ptr env = ecl_process_env(); - cl_object hash = - cl__make_hash_table(@'eq', - MAKE_FIXNUM(1024), - cl_core.rehash_size, - cl_core.rehash_threshold, Cnil); - ecl_bds_bind(env, @'si::*circle-counter*', Ct); - ecl_bds_bind(env, @'si::*circle-stack*', hash); - si_write_object(x, cl_core.null_stream); - ECL_SETQ(env, @'si::*circle-counter*', MAKE_FIXNUM(0)); - si_write_object(x, stream); - cl_clrhash(hash); - ecl_bds_unwind_n(env, 2); - return x; - } - code = search_print_circle(x); - if (!FIXNUMP(circle_counter)) { - /* We are only inspecting the object to be printed. */ - /* Only run X if it was not referenced before */ - if (code != 0) return x; - } else if (code == 0) { - /* Object is not referenced twice */ - } else if (code < 0) { - /* Object is referenced twice. We print its definition */ - write_ch('#', stream); - write_decimal(-code, stream); - write_ch('=', stream); - } else { - /* Second reference to the object */ - write_ch('#', stream); - write_decimal(code, stream); - write_ch('#', stream); - return x; - } - } - return si_write_ugly_object(x, stream); -} - -#if !defined(ECL_CMU_FORMAT) -cl_object -si_write_object(cl_object x, cl_object stream) { - const cl_env_ptr env = ecl_process_env(); - if (ecl_symbol_value(@'*print-pretty*') == Cnil) { - env->print_pretty = 0; - } else { - env->print_pretty = 1; - env->qh = env->qt = env->qc = 0; - env->isp = env->iisp = 0; - env->indent_stack[0] = 0; - } - si_write_object_recursive(x, stream); - if (env->print_pretty) - flush_queue(TRUE, stream); -} -#endif /* !ECL_CMU_FORMAT */ - -static bool -object_will_print_as_hash(cl_object x) -{ - cl_object circle_counter = ecl_symbol_value(@'si::*circle-counter*'); - cl_object circle_stack = ecl_symbol_value(@'si::*circle-stack*'); - cl_object code = ecl_gethash_safe(x, circle_stack, OBJNULL); - if (FIXNUMP(circle_counter)) { - return !(code == OBJNULL || code == Cnil); - } else if (code == OBJNULL) { - /* Was not found before */ - _ecl_sethash(x, circle_stack, Cnil); - return 0; - } else { - return 1; - } -} - -/* To print circular structures, we traverse the structure by adding - a pair to the interpreter stack for each element visited. - flag is initially NIL and becomes T if the element is visited again. - After the visit we squeeze out all the non circular elements. - The flags is used during printing to distinguish between the first visit - to the element. - */ - -static cl_fixnum -search_print_circle(cl_object x) -{ - cl_object circle_counter = ecl_symbol_value(@'si::*circle-counter*'); - cl_object circle_stack = ecl_symbol_value(@'si::*circle-stack*'); - cl_object code; - - if (!FIXNUMP(circle_counter)) { - code = ecl_gethash_safe(x, circle_stack, OBJNULL); - if (code == OBJNULL) { - /* Was not found before */ - _ecl_sethash(x, circle_stack, Cnil); - return 0; - } else if (code == Cnil) { - /* This object is referenced twice */ - _ecl_sethash(x, circle_stack, Ct); - return 1; - } else { - return 2; - } - } else { - code = ecl_gethash_safe(x, circle_stack, OBJNULL); - if (code == OBJNULL || code == Cnil) { - /* Is not referenced or was not found before */ - /* _ecl_sethash(x, circle_stack, Cnil); */ - return 0; - } else if (code == Ct) { - /* This object is referenced twice, but has no code yet */ - cl_fixnum new_code = fix(circle_counter) + 1; - circle_counter = MAKE_FIXNUM(new_code); - _ecl_sethash(x, circle_stack, circle_counter); - ECL_SETQ(ecl_process_env(), @'si::*circle-counter*', - circle_counter); - return -new_code; - } else { - return fix(code); - } - } -} - -#define ecl_exponent_marker_p(i) \ - ((i) == 'e' || (i) == 'E' || \ - (i) == 's' || (i) == 'S' || (i) == 'f' || (i) == 'F' || \ - (i) == 'd' || (i) == 'D' || (i) == 'l' || (i) == 'L' || \ - (i) == 'b' || (i) == 'B') - -static bool -potential_number_p(cl_object strng, int base) -{ - /* See ANSI 2.3.1.1 */ - int i, l, c; - char *s; - - l = strng->base_string.fillp; - if (l == 0) - return FALSE; - s = (char*)strng->base_string.self; - c = s[0]; - - /* A potential number must begin with a digit, sign or extension character (^ _) */ - if ((ecl_digitp(c, base) < 0) && c != '+' && c != '-' && c != '^' && c != '_') - return FALSE; - - /* A potential number cannot end with a sign */ - if (s[l-1] == '+' || s[l-1] == '-') - return FALSE; - - for (i = 1; i < l; i++) { - c = s[i]; - /* It can only contain digits, signs, ratio markers, extension characters and - * number markers. Number markers are letters, but two adjacent letters fail - * to be a number marker. */ - if (ecl_digitp(c, base) >= 0 || c == '+' && c == '-' && c == '/' && c == '.' && - c == '^' && c == '_') { - continue; - } - if (ecl_alpha_char_p(c) && ((i+1) >= l) || !ecl_alpha_char_p(s[i+1])) { - continue; - } - return FALSE; - } - return TRUE; -} - @(defun write (x &key ((:stream strm) Cnil) (array ecl_symbol_value(@'*print-array*')) @@ -1626,7 +173,7 @@ potential_number_p(cl_object strng, int base) ecl_bds_bind(the_env, @'*print-readably*', readably); ecl_bds_bind(the_env, @'*print-right-margin*', right_margin); - strm = stream_or_default_output(strm); + strm = _ecl_stream_or_default_output(strm); si_write_object(x, strm); ecl_force_output(strm); @@ -1648,7 +195,7 @@ potential_number_p(cl_object strng, int base) @(defun pprint (obj &optional strm) @ - strm = stream_or_default_output(strm); + strm = _ecl_stream_or_default_output(strm); ecl_bds_bind(the_env, @'*print-escape*', Ct); ecl_bds_bind(the_env, @'*print-pretty*', Ct); ecl_write_char('\n', strm); @@ -1667,7 +214,7 @@ potential_number_p(cl_object strng, int base) @(defun write-char (c &optional strm) @ /* INV: ecl_char_code() checks the type of `c' */ - strm = stream_or_default_output(strm); + strm = _ecl_stream_or_default_output(strm); ecl_write_char(ecl_char_code(c), strm); @(return c) @) @@ -1676,7 +223,7 @@ potential_number_p(cl_object strng, int base) @ unlikely_if (!ECL_STRINGP(strng)) FEwrong_type_nth_arg(@[write-string], 1, strng, @[string]); - strm = stream_or_default_output(strm); + strm = _ecl_stream_or_default_output(strm); #ifdef ECL_CLOS_STREAMS if (!ECL_ANSI_STREAM_P(strm)) funcall(5, @'gray::stream-write-string', strm, strng, start, end); @@ -1690,7 +237,7 @@ potential_number_p(cl_object strng, int base) @ unlikely_if (!ECL_STRINGP(strng)) FEwrong_type_nth_arg(@[write-line], 1, strng, @[string]); - strm = stream_or_default_output(strm); + strm = _ecl_stream_or_default_output(strm); #ifdef ECL_CLOS_STREAMS if (!ECL_ANSI_STREAM_P(strm)) funcall(5, @'gray::stream-write-string', strm, strng, @@ -1710,7 +257,7 @@ potential_number_p(cl_object strng, int base) @(defun fresh-line (&optional strm) @ - strm = stream_or_default_output(strm); + strm = _ecl_stream_or_default_output(strm); #ifdef ECL_CLOS_STREAMS if (!ECL_ANSI_STREAM_P(strm)) { return funcall(2, @'gray::stream-fresh-line', strm); @@ -1725,7 +272,7 @@ potential_number_p(cl_object strng, int base) @(defun finish-output (&o strm) @ - strm = stream_or_default_output(strm); + strm = _ecl_stream_or_default_output(strm); #ifdef ECL_CLOS_STREAMS if (!ECL_ANSI_STREAM_P(strm)) { return funcall(2, @'gray::stream-finish-output', strm); @@ -1737,14 +284,14 @@ potential_number_p(cl_object strng, int base) @(defun force-output (&o strm) @ - strm = stream_or_default_output(strm); + strm = _ecl_stream_or_default_output(strm); ecl_force_output(strm); @(return Cnil) @) @(defun clear-output (&o strm) @ - strm = stream_or_default_output(strm); + strm = _ecl_stream_or_default_output(strm); ecl_clear_output(strm); @(return Cnil) @) @@ -1770,7 +317,7 @@ cl_object ecl_princ(cl_object obj, cl_object strm) { const cl_env_ptr the_env = ecl_process_env(); - strm = stream_or_default_output(strm); + strm = _ecl_stream_or_default_output(strm); ecl_bds_bind(the_env, @'*print-escape*', Cnil); ecl_bds_bind(the_env, @'*print-readably*', Cnil); si_write_object(obj, strm); @@ -1782,7 +329,7 @@ cl_object ecl_prin1(cl_object obj, cl_object strm) { const cl_env_ptr the_env = ecl_process_env(); - strm = stream_or_default_output(strm); + strm = _ecl_stream_or_default_output(strm); ecl_bds_bind(the_env, @'*print-escape*', Ct); si_write_object(obj, strm); ecl_force_output(strm); @@ -1793,7 +340,7 @@ ecl_prin1(cl_object obj, cl_object strm) cl_object ecl_print(cl_object obj, cl_object strm) { - strm = stream_or_default_output(strm); + strm = _ecl_stream_or_default_output(strm); ecl_terpri(strm); ecl_prin1(obj, strm); ecl_princ_char(' ', strm); @@ -1803,7 +350,7 @@ ecl_print(cl_object obj, cl_object strm) cl_object ecl_terpri(cl_object strm) { - strm = stream_or_default_output(strm); + strm = _ecl_stream_or_default_output(strm); #ifdef ECL_CLOS_STREAMS if (!ECL_ANSI_STREAM_P(strm)) { return funcall(2, @'gray::stream-terpri', strm); @@ -1819,7 +366,7 @@ ecl_write_string(cl_object strng, cl_object strm) { cl_index i; - strm = stream_or_default_output(strm); + strm = _ecl_stream_or_default_output(strm); switch(type_of(strng)) { #ifdef ECL_UNICODE case t_string: @@ -1844,14 +391,14 @@ ecl_write_string(cl_object strng, cl_object strm) void ecl_princ_str(const char *s, cl_object strm) { - strm = stream_or_default_output(strm); + strm = _ecl_stream_or_default_output(strm); writestr_stream(s, strm); } void ecl_princ_char(int c, cl_object strm) { - strm = stream_or_default_output(strm); + strm = _ecl_stream_or_default_output(strm); ecl_write_char(c, strm); if (c == '\n') { ecl_force_output(strm); diff --git a/src/c/printer/print_unreadable.d b/src/c/printer/print_unreadable.d new file mode 100644 index 000000000..73ecbd21a --- /dev/null +++ b/src/c/printer/print_unreadable.d @@ -0,0 +1,82 @@ +/* -*- mode: c; c-basic-offset: 8 -*- */ +/* + print_unreadable.d -- helper for print-unreadable-object macro +*/ +/* + Copyright (c) 2010, Juan Jose Garcia Ripoll. + + ECL is free software; you can redistribute it and/or + modify it under the terms of the GNU Library General Public + License as published by the Free Software Foundation; either + version 2 of the License, or (at your option) any later version. + + See file '../Copyright' for full details. +*/ + +#include +#include + +void +_ecl_write_addr(cl_object x, cl_object stream) +{ + cl_fixnum i, j; + + i = (cl_index)x; + for (j = sizeof(i)*8-4; j >= 0; j -= 4) { + int k = (i>>j) & 0xf; + if (k < 10) + ecl_write_char('0' + k, stream); + else + ecl_write_char('a' + k - 10, stream); + } +} + +void +_ecl_write_unreadable(cl_object x, const char *prefix, cl_object name, cl_object stream) +{ + if (ecl_print_readably()) + FEprint_not_readable(x); + ecl_write_char('#', stream); + ecl_write_char('<', stream); + writestr_stream(prefix, stream); + ecl_write_char(' ', stream); + if (!Null(name)) { + si_write_ugly_object(name, stream); + } else { + _ecl_write_addr(x, stream); + } + ecl_write_char('>', stream); +} + +cl_object +si_print_unreadable_object_function(cl_object o, cl_object stream, cl_object type, cl_object id, cl_object function) +{ + if (ecl_print_readably()) + FEprint_not_readable(o); + stream = _ecl_stream_or_default_output(stream); + if (ecl_print_level() == 0) { + ecl_write_char('#', stream); + } else { + writestr_stream("#<", stream); + if (!Null(type)) { + cl_index i, l; + type = cl_type_of(o); + if (!SYMBOLP(type)) { + type = @'standard-object'; + } + type = type->symbol.name; + for (i = 0, l = ecl_length(type); i < l; i++) + ecl_write_char(ecl_char_downcase(ecl_char(type, i)), stream); + ecl_write_char(' ', stream); + } + if (!Null(function)) { + cl_funcall(1, function); + } + if (!Null(id)) { + ecl_write_char(' ', stream); + _ecl_write_addr(o, stream); + } + ecl_write_char('>', stream); + } + @(return Cnil) +} diff --git a/src/c/printer/write_array.d b/src/c/printer/write_array.d new file mode 100644 index 000000000..260660beb --- /dev/null +++ b/src/c/printer/write_array.d @@ -0,0 +1,206 @@ +/* -*- mode: c; c-basic-offset: 8 -*- */ +/* + write_array.d -- File interface. +*/ +/* + Copyright (c) 1984, Taiichi Yuasa and Masami Hagiya. + Copyright (c) 1990, Giuseppe Attardi. + Copyright (c) 2001, Juan Jose Garcia Ripoll. + + ECL is free software; you can redistribute it and/or + modify it under the terms of the GNU Library General Public + License as published by the Free Software Foundation; either + version 2 of the License, or (at your option) any later version. + + See file '../Copyright' for full details. +*/ + +#include +#include + +static void +write_array_inner(bool vector, cl_object x, cl_object stream) +{ + cl_env_ptr env = ecl_process_env(); + const cl_index *adims; + cl_index subscripts[ARANKLIM]; + cl_fixnum n, j, m, k, i; + cl_fixnum print_length; + cl_fixnum print_level; + bool readably = ecl_print_readably(); + + if (vector) { + adims = &x->vector.fillp; + n = 1; + } else { + adims = x->array.dims; + n = x->array.rank; + } + if (readably) { + print_length = MOST_POSITIVE_FIXNUM; + print_level = MOST_POSITIVE_FIXNUM; + } else { + if (!ecl_print_array()) { + writestr_stream(vector? "#', stream); + return; + } + print_level = ecl_print_level(); + print_length = ecl_print_length(); + } + ecl_write_char('#', stream); + if (print_level == 0) + return; + if (readably) { + ecl_write_char('A', stream); + ecl_write_char('(', stream); + si_write_object(ecl_elttype_to_symbol(ecl_array_elttype(x)), stream); + ecl_write_char(' ', stream); + if (n > 0) { + ecl_write_char('(', stream); + for (j=0; j= n) { + /* We can write the elements of the array */ + print_level -= n; + ecl_bds_bind(env, @'*print-level*', MAKE_FIXNUM(print_level)); + } else { + /* The elements of the array are not printed */ + n = print_level; + print_level = -1; + } + for (j = 0; j < n; j++) + subscripts[j] = 0; + for (m = 0, j = 0;;) { + for (i = j; i < n; i++) { + if (subscripts[i] == 0) { + ecl_write_char('(', stream); + if (adims[i] == 0) { + ecl_write_char(')', stream); + j = i-1; + k = 0; + goto INC; + } + } + if (subscripts[i] > 0) + ecl_write_char(' ', stream); + if (subscripts[i] >= print_length) { + writestr_stream("...)", stream); + k=adims[i]-subscripts[i]; + subscripts[i] = 0; + for (j = i+1; j < n; j++) + k *= adims[j]; + j = i-1; + goto INC; + } + } + /* FIXME: This conses! */ + if (print_level >= 0) + si_write_object(ecl_aref_unsafe(x, m), stream); + else + ecl_write_char('#', stream); + j = n-1; + k = 1; + + INC: + while (j >= 0) { + if (++subscripts[j] < adims[j]) + break; + subscripts[j] = 0; + ecl_write_char(')', stream); + --j; + } + if (j < 0) + break; + m += k; + } + if (print_level >= 0) { + ecl_bds_unwind1(env); + } + if (readably) { + ecl_write_char(')', stream); + } +} + +void +_ecl_write_array(cl_object x, cl_object stream) +{ + write_array_inner(0, x, stream); +} + +void +_ecl_write_vector(cl_object x, cl_object stream) +{ + write_array_inner(1, x, stream); +} + +#ifdef ECL_UNICODE +void +_ecl_write_string(cl_object x, cl_object stream) +{ + cl_index ndx; + if (!ecl_print_escape() && !ecl_print_readably()) { + for (ndx = 0; ndx < x->string.fillp; ndx++) + ecl_write_char(x->string.self[ndx], stream); + } else { + ecl_write_char('"', stream); + for (ndx = 0; ndx < x->string.fillp; ndx++) { + ecl_character c = x->string.self[ndx]; + if (c == '"' || c == '\\') + ecl_write_char('\\', stream); + ecl_write_char(c, stream); + } + ecl_write_char('"', stream); + } +} +#endif + +void +_ecl_write_base_string(cl_object x, cl_object stream) +{ + cl_index ndx; + if (!ecl_print_escape() && !ecl_print_readably()) { + for (ndx = 0; ndx < x->base_string.fillp; ndx++) + ecl_write_char(x->base_string.self[ndx], stream); + } else { + ecl_write_char('"', stream); + for (ndx = 0; ndx < x->base_string.fillp; ndx++) { + int c = x->base_string.self[ndx]; + if (c == '"' || c == '\\') + ecl_write_char('\\', stream); + ecl_write_char(c, stream); + } + ecl_write_char('"', stream); + } +} + +void +_ecl_write_bitvector(cl_object x, cl_object stream) +{ + if (!ecl_print_array() && !ecl_print_readably()) { + writestr_stream("#', stream); + } else { + cl_index ndx; + writestr_stream("#*", stream); + for (ndx = 0; ndx < x->vector.fillp; ndx++) + if (x->vector.self.bit[(ndx+x->vector.offset)/8] & (0200 >> (ndx+x->vector.offset)%8)) + ecl_write_char('1', stream); + else + ecl_write_char('0', stream); + } +} diff --git a/src/c/printer/write_code.d b/src/c/printer/write_code.d new file mode 100644 index 000000000..1ff4f9c2c --- /dev/null +++ b/src/c/printer/write_code.d @@ -0,0 +1,76 @@ +/* -*- mode: c; c-basic-offset: 8 -*- */ +/* + write_list.d -- ugly printer for bytecodes and functions +*/ +/* + Copyright (c) 1984, Taiichi Yuasa and Masami Hagiya. + Copyright (c) 1990, Giuseppe Attardi. + Copyright (c) 2001, Juan Jose Garcia Ripoll. + + ECL is free software; you can redistribute it and/or + modify it under the terms of the GNU Library General Public + License as published by the Free Software Foundation; either + version 2 of the License, or (at your option) any later version. + + See file '../Copyright' for full details. +*/ + +#include +#include +#include + +void +_ecl_write_bclosure(cl_object x, cl_object stream) +{ + if (ecl_print_readably()) { + cl_index i; + cl_object lex = x->bclosure.lex; + cl_object code_l=Cnil, data_l=Cnil; + x = x->bclosure.code; + for ( i=x->bytecodes.code_size-1 ; i<(cl_index)(-1l) ; i-- ) + code_l = ecl_cons(MAKE_FIXNUM(((cl_opcode*)(x->bytecodes.code))[i]), code_l); + for ( i=x->bytecodes.data_size-1 ; i<(cl_index)(-1l) ; i-- ) + data_l = ecl_cons(x->bytecodes.data[i], data_l); + + writestr_stream("#Y", stream); + si_write_ugly_object(cl_list(5, x->bytecodes.name, lex, + Cnil /* x->bytecodes.definition */, + code_l, data_l), + stream); + } else { + cl_object name = x->bytecodes.name; + writestr_stream("#', stream); + } +} + +void +_ecl_write_bytecodes(cl_object x, cl_object stream) +{ + if (ecl_print_readably()) { + cl_index i; + cl_object lex = Cnil; + cl_object code_l=Cnil, data_l=Cnil; + for ( i=x->bytecodes.code_size-1 ; i<(cl_index)(-1l) ; i-- ) + code_l = ecl_cons(MAKE_FIXNUM(((cl_opcode*)(x->bytecodes.code))[i]), code_l); + for ( i=x->bytecodes.data_size-1 ; i<(cl_index)(-1l) ; i-- ) + data_l = ecl_cons(x->bytecodes.data[i], data_l); + writestr_stream("#Y", stream); + si_write_ugly_object(cl_list(5, x->bytecodes.name, lex, + Cnil /* x->bytecodes.definition */, + code_l, data_l), + stream); + } else { + cl_object name = x->bytecodes.name; + writestr_stream("#', stream); + } +} diff --git a/src/c/printer/write_list.d b/src/c/printer/write_list.d new file mode 100644 index 000000000..d9f107274 --- /dev/null +++ b/src/c/printer/write_list.d @@ -0,0 +1,118 @@ +/* -*- mode: c; c-basic-offset: 8 -*- */ +/* + write_list.d -- ugly printer for lists +*/ +/* + Copyright (c) 1984, Taiichi Yuasa and Masami Hagiya. + Copyright (c) 1990, Giuseppe Attardi. + Copyright (c) 2001, Juan Jose Garcia Ripoll. + + ECL is free software; you can redistribute it and/or + modify it under the terms of the GNU Library General Public + License as published by the Free Software Foundation; either + version 2 of the License, or (at your option) any later version. + + See file '../Copyright' for full details. +*/ + +#include +#include + +void +_ecl_write_list(cl_object x, cl_object stream) +{ + const cl_env_ptr env = ecl_process_env(); + bool circle; + cl_fixnum print_level, print_length; + cl_index i; + cl_object y; + if (Null(x)) { + _ecl_write_symbol(x, stream); + return; + } + if (CAR(x) == @'si::#!') { + writestr_stream("#!", stream); + x = CDR(x); + si_write_object(x, stream); + return; + } + if (CONSP(CDR(x)) && Null(CDDR(x))) { + if (CAR(x) == @'quote') { + ecl_write_char('\'', stream); + x = CADR(x); + si_write_object(x, stream); + return; + } + if (CAR(x) == @'function') { + ecl_write_char('#', stream); + ecl_write_char('\'', stream); + x = CADR(x); + si_write_object(x, stream); + return; + } + if (CAR(x) == @'si::quasiquote') { + ecl_write_char('`', stream); + x = CADR(x); + si_write_object(x, stream); + return; + } + if (CAR(x) == @'si::unquote') { + ecl_write_char(',', stream); + x = CADR(x); + si_write_object(x, stream); + return; + } + if (CAR(x) == @'si::unquote-splice') { + writestr_stream(",@@", stream); + x = CADR(x); + si_write_object(x, stream); + return; + } + if (CAR(x) == @'si::unquote-nsplice') { + writestr_stream(",.", stream); + x = CADR(x); + si_write_object(x, stream); + return; + } + } + circle = ecl_print_circle(); + if (ecl_print_readably()) { + print_level = MOST_POSITIVE_FIXNUM; + print_length = MOST_POSITIVE_FIXNUM; + } else { + print_level = ecl_print_level(); + print_length = ecl_print_length(); + } + if (print_level == 0) { + ecl_write_char('#', stream); + return; + } + ecl_bds_bind(env, @'*print-level*', MAKE_FIXNUM(print_level-1)); + ecl_write_char('(', stream); + for (i = 0; ; i++) { + if (i >= print_length) { + writestr_stream("...", stream); + break; + } + y = CAR(x); + x = CDR(x); + si_write_object(y, stream); + /* FIXME! */ + if (x == OBJNULL || ATOM(x) || + (circle && _ecl_will_print_as_hash(x))) + { + if (x != Cnil) { + ecl_write_char(' ', stream); + writestr_stream(". ", stream); + si_write_object(x, stream); + } + break; + } + if (i == 0 && y != OBJNULL && type_of(y) == t_symbol) + ecl_write_char(' ', stream); + else + ecl_write_char(' ', stream); + } + ecl_write_char(')', stream); + ecl_bds_unwind1(env); +} diff --git a/src/c/printer/write_object.d b/src/c/printer/write_object.d new file mode 100644 index 000000000..099e63b9f --- /dev/null +++ b/src/c/printer/write_object.d @@ -0,0 +1,142 @@ +/* -*- mode: c; c-basic-offset: 8 -*- */ +/* + write_object.d -- basic printer routine. +*/ +/* + Copyright (c) 1984, Taiichi Yuasa and Masami Hagiya. + Copyright (c) 1990, Giuseppe Attardi. + Copyright (c) 2001, Juan Jose Garcia Ripoll. + + ECL is free software; you can redistribute it and/or + modify it under the terms of the GNU Library General Public + License as published by the Free Software Foundation; either + version 2 of the License, or (at your option) any later version. + + See file '../Copyright' for full details. +*/ + +#include +#include +#include + +bool +_ecl_will_print_as_hash(cl_object x) +{ + cl_object circle_counter = ecl_symbol_value(@'si::*circle-counter*'); + cl_object circle_stack = ecl_symbol_value(@'si::*circle-stack*'); + cl_object code = ecl_gethash_safe(x, circle_stack, OBJNULL); + if (FIXNUMP(circle_counter)) { + return !(code == OBJNULL || code == Cnil); + } else if (code == OBJNULL) { + /* Was not found before */ + _ecl_sethash(x, circle_stack, Cnil); + return 0; + } else { + return 1; + } +} + +/* To print circular structures, we traverse the structure by adding + a pair to the interpreter stack for each element visited. + flag is initially NIL and becomes T if the element is visited again. + After the visit we squeeze out all the non circular elements. + The flags is used during printing to distinguish between the first visit + to the element. + */ + +static cl_fixnum +search_print_circle(cl_object x) +{ + cl_object circle_counter = ecl_symbol_value(@'si::*circle-counter*'); + cl_object circle_stack = ecl_symbol_value(@'si::*circle-stack*'); + cl_object code; + + if (!FIXNUMP(circle_counter)) { + code = ecl_gethash_safe(x, circle_stack, OBJNULL); + if (code == OBJNULL) { + /* Was not found before */ + _ecl_sethash(x, circle_stack, Cnil); + return 0; + } else if (code == Cnil) { + /* This object is referenced twice */ + _ecl_sethash(x, circle_stack, Ct); + return 1; + } else { + return 2; + } + } else { + code = ecl_gethash_safe(x, circle_stack, OBJNULL); + if (code == OBJNULL || code == Cnil) { + /* Is not referenced or was not found before */ + /* _ecl_sethash(x, circle_stack, Cnil); */ + return 0; + } else if (code == Ct) { + /* This object is referenced twice, but has no code yet */ + cl_fixnum new_code = fix(circle_counter) + 1; + circle_counter = MAKE_FIXNUM(new_code); + _ecl_sethash(x, circle_stack, circle_counter); + ECL_SETQ(ecl_process_env(), @'si::*circle-counter*', + circle_counter); + return -new_code; + } else { + return fix(code); + } + } +} + +cl_object +si_write_object(cl_object x, cl_object stream) +{ + bool circle; + if (ecl_symbol_value(@'*print-pretty*') != Cnil) { + cl_object f = funcall(2, @'pprint-dispatch', x); + if (VALUES(1) != Cnil) { + funcall(3, f, stream, x); + return x; + } + } + circle = ecl_print_circle(); + if (circle && !Null(x) && !FIXNUMP(x) && !CHARACTERP(x) && + (LISTP(x) || (x->d.t != t_symbol) || (Null(x->symbol.hpack)))) + { + cl_object circle_counter; + cl_fixnum code; + circle_counter = ecl_symbol_value(@'si::*circle-counter*'); + if (circle_counter == Cnil) { + cl_env_ptr env = ecl_process_env(); + cl_object hash = + cl__make_hash_table(@'eq', + MAKE_FIXNUM(1024), + cl_core.rehash_size, + cl_core.rehash_threshold, Cnil); + ecl_bds_bind(env, @'si::*circle-counter*', Ct); + ecl_bds_bind(env, @'si::*circle-stack*', hash); + si_write_object(x, cl_core.null_stream); + ECL_SETQ(env, @'si::*circle-counter*', MAKE_FIXNUM(0)); + si_write_object(x, stream); + cl_clrhash(hash); + ecl_bds_unwind_n(env, 2); + return x; + } + code = search_print_circle(x); + if (!FIXNUMP(circle_counter)) { + /* We are only inspecting the object to be printed. */ + /* Only run X if it was not referenced before */ + if (code != 0) return x; + } else if (code == 0) { + /* Object is not referenced twice */ + } else if (code < 0) { + /* Object is referenced twice. We print its definition */ + ecl_write_char('#', stream); + _ecl_write_fixnum(-code, stream); + ecl_write_char('=', stream); + } else { + /* Second reference to the object */ + ecl_write_char('#', stream); + _ecl_write_fixnum(code, stream); + ecl_write_char('#', stream); + return x; + } + } + return si_write_ugly_object(x, stream); +} diff --git a/src/c/printer/write_sse.d b/src/c/printer/write_sse.d new file mode 100644 index 000000000..0d0d004b8 --- /dev/null +++ b/src/c/printer/write_sse.d @@ -0,0 +1,96 @@ +/* -*- mode: c; c-basic-offset: 8 -*- */ +/* + write_list.d -- ugly printer for SSE types +*/ +/* + Copyright (c) 1984, Taiichi Yuasa and Masami Hagiya. + Copyright (c) 1990, Giuseppe Attardi. + Copyright (c) 2001, Juan Jose Garcia Ripoll. + + ECL is free software; you can redistribute it and/or + modify it under the terms of the GNU Library General Public + License as published by the Free Software Foundation; either + version 2 of the License, or (at your option) any later version. + + See file '../Copyright' for full details. +*/ + +#include +#include + +#ifdef ECL_SSE2 +static int +is_all_FF(void *ptr, int size) { + int i; + for (i = 0; i < size; i++) + if (((unsigned char*)ptr)[i] != 0xFF) + return 0; + return 1; +} + +static void +write_sse_float(float v, cl_object stream) +{ + if (is_all_FF(&v, sizeof(float))) + writestr_stream(" TRUE", stream); + else { + char buf[60]; + sprintf(buf, " %g", v); + writestr_stream(buf, stream); + } +} + +static void +write_sse_double(double v, cl_object stream) +{ + if (is_all_FF(&v, sizeof(double))) + writestr_stream(" TRUE", stream); + else { + char buf[60]; + sprintf(buf, " %lg", v); + writestr_stream(buf, stream); + } +} + +static void +write_sse_pack(cl_object x, cl_object stream) +{ + int i; + cl_elttype etype = x->sse.elttype; + cl_object mode = ecl_symbol_value(@'ext::*sse-pack-print-mode*'); + + if (mode != Cnil) { + if (mode == @':float') etype = aet_sf; + else if (mode == @':double') etype = aet_df; + else etype = aet_b8; + } + + switch (x->sse.elttype) { + case aet_sf: + for (i = 0; i < 4; i++) + write_sse_float(x->sse.data.sf[i], stream); + break; + case aet_df: + write_sse_double(x->sse.data.df[0], stream); + write_sse_double(x->sse.data.df[1], stream); + break; + default: + for (i = 0; i < 16; i++) { + char buf[10]; + int pad = 1 + (i%4 == 0); + sprintf(buf, "%*c%02x", pad, ' ', x->sse.data.b8[i]); + writestr_stream(buf, stream); + } + break; + } +} + +static void +write_sse(cl_object x, cl_object stream) +{ + if (ecl_print_readably()) FEprint_not_readable(x); + writestr_stream("#', stream); +} +#endif diff --git a/src/c/printer/write_symbol.d b/src/c/printer/write_symbol.d new file mode 100644 index 000000000..5732178b0 --- /dev/null +++ b/src/c/printer/write_symbol.d @@ -0,0 +1,206 @@ +/* -*- mode: c; c-basic-offset: 8 -*- */ +/* + write_symbol.d -- print a symbol. +*/ +/* + Copyright (c) 1984, Taiichi Yuasa and Masami Hagiya. + Copyright (c) 1990, Giuseppe Attardi. + Copyright (c) 2001, Juan Jose Garcia Ripoll. + + ECL is free software; you can redistribute it and/or + modify it under the terms of the GNU Library General Public + License as published by the Free Software Foundation; either + version 2 of the License, or (at your option) any later version. + + See file '../Copyright' for full details. +*/ + +#include +#include + +static bool +potential_number_p(cl_object strng, int base) +{ + /* See ANSI 2.3.1.1 */ + int i, l, c; + char *s; + + l = strng->base_string.fillp; + if (l == 0) + return FALSE; + s = (char*)strng->base_string.self; + c = s[0]; + + /* A potential number must begin with a digit, sign or + extension character (^ _) */ + if ((ecl_digitp(c, base) < 0) && c != '+' && c != '-' && c != '^' && c != '_') + return FALSE; + + /* A potential number cannot end with a sign */ + if (s[l-1] == '+' || s[l-1] == '-') + return FALSE; + + for (i = 1; i < l; i++) { + c = s[i]; + /* It can only contain digits, signs, ratio markers, + * extension characters and number markers. Number + * markers are letters, but two adjacent letters fail + * to be a number marker. */ + if (ecl_digitp(c, base) >= 0 || c == '+' && c == '-' && c == '/' && c == '.' && + c == '^' && c == '_') { + continue; + } + if (ecl_alpha_char_p(c) && ((i+1) >= l) || !ecl_alpha_char_p(s[i+1])) { + continue; + } + return FALSE; + } + return TRUE; +} + +#define needs_to_be_inverted(s) (ecl_string_case(s) != 0) + +static bool +all_dots(cl_object s) +{ + cl_index i; + for (i = 0; i < s->base_string.fillp; i++) + if (ecl_char(s, i) != '.') + return 0; + return 1; +} + +static bool +needs_to_be_escaped(cl_object s, cl_object readtable, cl_object print_case) +{ + int action = readtable->readtable.read_case; + cl_index i; + if (potential_number_p(s, ecl_print_base())) + return 1; + /* The value of *PRINT-ESCAPE* is T. We need to check whether the + * symbol name S needs to be escaped. This will happen if it has some + * strange character, or if it has a lowercase character (because such + * a character cannot be read with the standard readtable) or if the + * string has to be escaped according to readtable case and the rules + * of 22.1.3.3.2. */ + for (i = 0; i < s->base_string.fillp; i++) { + int c = ecl_char(s, i); + int syntax = ecl_readtable_get(readtable, c, 0); + if (syntax != cat_constituent || + ecl_invalid_character_p(c) || + (c) == ':') + return 1; + if ((action == ecl_case_downcase) && ecl_upper_case_p(c)) + return 1; + if (ecl_lower_case_p(c)) + return 1; + } + return 0; +} + +static void +write_symbol_string(cl_object s, int action, cl_object print_case, + cl_object stream, bool escape) +{ + cl_index i; + bool capitalize; + if (action == ecl_case_invert) { + if (!needs_to_be_inverted(s)) + action = ecl_case_preserve; + } + if (escape) + ecl_write_char('|', stream); + capitalize = 1; + for (i = 0; i < s->base_string.fillp; i++) { + int c = ecl_char(s, i); + if (escape) { + if (c == '|' || c == '\\') { + ecl_write_char('\\', stream); + } + } else if (action != ecl_case_preserve) { + if (ecl_upper_case_p(c)) { + if ((action == ecl_case_invert) || + ((action == ecl_case_upcase) && + ((print_case == @':downcase') || + ((print_case == @':capitalize') && !capitalize)))) + { + c = ecl_char_downcase(c); + } + capitalize = 0; + } else if (ecl_lower_case_p(c)) { + if ((action == ecl_case_invert) || + ((action == ecl_case_downcase) && + ((print_case == @':upcase') || + ((print_case == @':capitalize') && capitalize)))) + { + c = ecl_char_upcase(c); + } + capitalize = 0; + } else { + capitalize = !ecl_alphanumericp(c); + } + } + ecl_write_char(c, stream); + } + if (escape) + ecl_write_char('|', stream); +} + +void +_ecl_write_symbol(cl_object x, cl_object stream) +{ + cl_object print_package = ecl_symbol_value(@'si::*print-package*'); + cl_object readtable = ecl_current_readtable(); + cl_object print_case = ecl_print_case(); + cl_object package; + cl_object name; + int intern_flag; + bool print_readably = ecl_print_readably(); + + if (Null(x)) { + package = Cnil_symbol->symbol.hpack; + name = Cnil_symbol->symbol.name; + } else { + package = x->symbol.hpack; + name = x->symbol.name; + } + + if (!print_readably && !ecl_print_escape()) { + write_symbol_string(name, readtable->readtable.read_case, + print_case, stream, 0); + return; + } + /* From here on, print-escape is true which means that it should + * be possible to recover the same symbol by reading it with + * the standard readtable (which has readtable-case = :UPCASE) + */ + if (Null(package)) { + if (ecl_print_gensym() || print_readably) + writestr_stream("#:", stream); + } else if (package == cl_core.keyword_package) { + ecl_write_char(':', stream); + } else if ((print_package != Cnil && package != print_package) + || ecl_find_symbol(ecl_symbol_name(x), ecl_current_package(), + &intern_flag)!=x + || intern_flag == 0) + { + cl_object name = package->pack.name; + write_symbol_string(name, readtable->readtable.read_case, + print_case, stream, + needs_to_be_escaped(name, readtable, print_case)); + if (ecl_find_symbol(ecl_symbol_name(x), package, &intern_flag) != x) + ecl_internal_error("can't print symbol"); + if ((print_package != Cnil && package != print_package) + || intern_flag == INTERNAL) { + writestr_stream("::", stream); + } else if (intern_flag == EXTERNAL) { + ecl_write_char(':', stream); + } else { + FEerror("Pathological symbol --- cannot print.", 0); + } + } + write_symbol_string(name, readtable->readtable.read_case, print_case, stream, + needs_to_be_escaped(name, readtable, print_case) || + all_dots(name)); +} + diff --git a/src/c/printer/write_ugly.d b/src/c/printer/write_ugly.d new file mode 100644 index 000000000..2389006f6 --- /dev/null +++ b/src/c/printer/write_ugly.d @@ -0,0 +1,513 @@ +/* -*- mode: c; c-basic-offset: 8 -*- */ +/* + print.d -- Print. +*/ +/* + Copyright (c) 1984, Taiichi Yuasa and Masami Hagiya. + Copyright (c) 1990, Giuseppe Attardi. + Copyright (c) 2001, Juan Jose Garcia Ripoll. + + ECL is free software; you can redistribute it and/or + modify it under the terms of the GNU Library General Public + License as published by the Free Software Foundation; either + version 2 of the License, or (at your option) any later version. + + See file '../Copyright' for full details. +*/ + +#include +#include +#include +#ifndef _MSC_VER +# include +#endif +#include +#include + +#define call_print_object(x,s) funcall(3, @'print-object',(x),(s)) +#define call_structure_print_function(f,x,s) funcall(4,(f),(x),(s),MAKE_FIXNUM(0)) + +static void +write_readable_pathname(cl_object path, cl_object stream) +{ + cl_object l = + cl_list(15, @'make-pathname', + @':host', path->pathname.host, + @':device', path->pathname.device, + @':directory', + cl_funcall(2, @'ext::maybe-quote', path->pathname.directory), + @':name', path->pathname.name, + @':type', path->pathname.type, + @':version', path->pathname.version, + @':defaults', Cnil); + writestr_stream("#.", stream); + si_write_object(l, stream); +} + +static void +write_pathname(cl_object path, cl_object stream) +{ + cl_object namestring = ecl_namestring(path, 0); + bool readably = ecl_print_readably(); + if (namestring == Cnil) { + if (readably) { + write_readable_pathname(path, stream); + return; + } + namestring = ecl_namestring(path, 1); + if (namestring == Cnil) { + writestr_stream("#", stream); + return; + } + } + if (readably || ecl_print_escape()) + writestr_stream("#P", stream); + si_write_ugly_object(namestring, stream); +} + +static void +write_integer(cl_object number, cl_object stream) +{ + cl_object s = si_get_buffer_string(); + int print_base = ecl_print_base(); + si_integer_to_string(s, number, + MAKE_FIXNUM(print_base), + ecl_symbol_value(@'*print-radix*'), + Ct /* decimal syntax */); + si_do_write_sequence(s, stream, MAKE_FIXNUM(0), Cnil); + si_put_buffer_string(s); +} + +void +_ecl_write_fixnum(cl_fixnum i, cl_object stream) +{ + cl_object s = si_get_buffer_string(); + si_integer_to_string(s, MAKE_FIXNUM(i), MAKE_FIXNUM(10), Cnil, Cnil); + si_do_write_sequence(s, stream, MAKE_FIXNUM(0), Cnil); + si_put_buffer_string(s); +} + +static void +write_ratio(cl_object r, cl_object stream) +{ + cl_object s = si_get_buffer_string(); + int print_base = ecl_print_base(); + si_integer_to_string(s, r->ratio.num, MAKE_FIXNUM(print_base), + ecl_symbol_value(@'*print-radix*'), + Cnil /* decimal syntax */); + ecl_string_push_extend(s, '/'); + si_integer_to_string(s, r->ratio.den, + MAKE_FIXNUM(print_base), + Cnil, Cnil); + si_do_write_sequence(s, stream, MAKE_FIXNUM(0), Cnil); + si_put_buffer_string(s); +} + +static void +write_complex(cl_object x, cl_object stream) +{ + writestr_stream("#C(", stream); + si_write_ugly_object(x->complex.real, stream); + ecl_write_char(' ', stream); + si_write_ugly_object(x->complex.imag, stream); + ecl_write_char(')', stream); +} + +static void +write_float(cl_object f, cl_object stream) +{ + cl_object s = si_get_buffer_string(); + s = si_float_to_string_free(s, f, MAKE_FIXNUM(-3), MAKE_FIXNUM(8)); + si_do_write_sequence(s, stream, MAKE_FIXNUM(0), Cnil); + si_put_buffer_string(s); +} + +static void +write_character(cl_object x, cl_object stream) +{ + int i = CHAR_CODE(x); + if (!ecl_print_escape() && !ecl_print_readably()) { + ecl_write_char(i, stream); + } else { + writestr_stream("#\\", stream); + if (i < 32 || i == 127) { + cl_object name = cl_char_name(CODE_CHAR(i)); + writestr_stream((char*)name->base_string.self, stream); + } else if (i >= 128) { + int index = 0; + char name[20]; + sprintf(name, "U%04x", i); /* cleanup */ + while(name[index]) + ecl_write_char(name[index++], stream); + } else { + ecl_write_char(i, stream); + } + } +} + +static void +write_free(cl_object x, cl_object stream) +{ + _ecl_write_unreadable(x, "free", Cnil, stream); +} + +static void +write_hashtable(cl_object x, cl_object stream) +{ + _ecl_write_unreadable(x, "hash-table", Cnil, stream); +} + +static void +write_random(cl_object x, cl_object stream) +{ + if (ecl_print_readably()) { + writestr_stream("#$", stream); + _ecl_write_vector(x->random.value, stream); + } else { + _ecl_write_unreadable(x->random.value, "random-state", Cnil, stream); + } +} + +static void +write_stream(cl_object x, cl_object stream) +{ + const char *prefix; + cl_object tag; +#ifdef ECL_UNICODE + ecl_character buffer[20]; +#else + ecl_base_char buffer[20]; +#endif + union cl_lispunion str; + switch ((enum ecl_smmode)x->stream.mode) { + case smm_input_file: + case smm_input: + prefix = "closed input stream"; + tag = IO_STREAM_FILENAME(x); + break; + case smm_output_file: + case smm_output: + prefix = "closed output stream"; + tag = IO_STREAM_FILENAME(x); + break; +#ifdef ECL_MS_WINDOWS_HOST + case smm_input_wsock: + prefix = "closed input win32 socket stream"; + tag = IO_STREAM_FILENAME(x); + break; + case smm_output_wsock: + prefix = "closed output win32 socket stream"; + tag = IO_STREAM_FILENAME(x); + break; + case smm_io_wsock: + prefix = "closed i/o win32 socket stream"; + tag = IO_STREAM_FILENAME(x); + break; +#endif + case smm_io_file: + case smm_io: + prefix = "closed io stream"; + tag = IO_STREAM_FILENAME(x); + break; + case smm_probe: + prefix = "closed probe stream"; + tag = IO_STREAM_FILENAME(x); + break; + case smm_synonym: + prefix = "closed synonym stream to"; + tag = SYNONYM_STREAM_SYMBOL(x); + break; + case smm_broadcast: + prefix = "closed broadcast stream"; + tag = Cnil; + break; + case smm_concatenated: + prefix = "closed concatenated stream"; + tag = Cnil; + break; + case smm_two_way: + prefix = "closed two-way stream"; + tag = Cnil; + break; + case smm_echo: + prefix = "closed echo stream"; + tag = Cnil; + break; + case smm_string_input: { + cl_object text = x->stream.object0; + cl_index ndx, l = ecl_length(text); + for (ndx = 0; (ndx < 8) && (ndx < l); ndx++) { + buffer[ndx] = ecl_char(text, ndx); + } + if (l > ndx) { + buffer[ndx-1] = '.'; + buffer[ndx-2] = '.'; + buffer[ndx-3] = '.'; + } + buffer[ndx++] = 0; + prefix = "closed string-input stream from"; + tag = &str; +#ifdef ECL_UNICODE + tag->string.t = t_string; + tag->string.self = buffer; +#else + tag->base_string.t = t_base_string; + tag->base_string.self = buffer; +#endif + tag->base_string.dim = ndx; + tag->base_string.fillp = ndx-1; + break; + } + case smm_string_output: + prefix = "closed string-output stream"; + tag = Cnil; + break; + default: + ecl_internal_error("illegal stream mode"); + } + if (!x->stream.closed) + prefix = prefix + 7; + _ecl_write_unreadable(x, prefix, tag, stream); +} + +#ifndef CLOS +static void +write_structure(cl_object x, cl_object stream) +{ + cl_object print_function; + unlikely_if (type_of(x->str.name) != t_symbol) + FEerror("Found a corrupt structure with an invalid type name~%" + " ~S", x->str.name); + print_function = si_get_sysprop(x->str.name, @'si::structure-print-function'); + if (Null(print_function) || !ecl_print_structure()) { + writestr_stream("#S", stream); + /* structure_to_list conses slot names and values into + * a list to be printed. print shouldn't allocate + * memory - Beppe + */ + x = structure_to_list(x); + si_write_object(x, stream); + } else { + call_structure_print_function(print_function, x, stream); + } +} +#endif /* !CLOS */ + +static void +write_readtable(cl_object x, cl_object stream) +{ + _ecl_write_unreadable(x, "readtable", Cnil, stream); +} + +static void +write_foreign(cl_object x, cl_object stream) +{ + _ecl_write_unreadable(x, "foreign", x->foreign.tag, stream); +} + +static void +write_frame(cl_object x, cl_object stream) +{ + _ecl_write_unreadable(x, "frame", MAKE_FIXNUM(x->frame.size), stream); +} + +static void +write_weak_pointer(cl_object x, cl_object stream) +{ + _ecl_write_unreadable(x, "weak-pointer", Cnil, stream); +} + +#ifdef ECL_THREADS +static void +write_process(cl_object x, cl_object stream) +{ + _ecl_write_unreadable(x, "process", x->process.name, stream); +} + +static void +write_lock(cl_object x, cl_object stream) +{ + const char *prefix = x->lock.recursive? + "lock" : "lock (nonrecursive)"; + _ecl_write_unreadable(x, prefix, x->lock.name, stream); +} + +static void +write_condition_variable(cl_object x, cl_object stream) +{ + _ecl_write_unreadable(x, "semaphore", Cnil, stream); +} + +# ifdef ECL_SEMAPHORES +static void +write_semaphore(cl_object x, cl_object stream) +{ + _ecl_write_unreadable(x, "semaphore", Cnil, stream); +} +# endif +#endif /* ECL_THREADS */ + +static void +write_illegal(cl_object x, cl_object stream) +{ + _ecl_write_unreadable(x, "illegal pointer", Cnil, stream); +} + +cl_object +si_write_ugly_object(cl_object x, cl_object stream) +{ + cl_object r, y; + cl_fixnum i; + cl_index ndx, k; + + if (x == OBJNULL) { + if (ecl_print_readably()) + FEprint_not_readable(x); + writestr_stream("#", stream); + goto OUTPUT; + } + switch (type_of(x)) { + case FREE: + write_free(x, stream); + break; + case t_fixnum: + case t_bignum: + write_integer(x, stream); + break; + case t_ratio: + write_ratio(x, stream); + break; + case t_singlefloat: + case t_doublefloat: +#ifdef ECL_LONG_FLOAT + case t_longfloat: +#endif + write_float(x, stream); + break; + case t_complex: + write_complex(x, stream); + break; + case t_character: + write_character(x, stream); + break; + case t_symbol: + _ecl_write_symbol(x, stream); + break; + case t_array: + _ecl_write_array(x, stream); + break; +#ifdef ECL_UNICODE + case t_string: + _ecl_write_string(x, stream); + break; +#endif + case t_vector: + _ecl_write_vector(x, stream); + break; + case t_base_string: + _ecl_write_base_string(x, stream); + break; + case t_bitvector: + _ecl_write_bitvector(x, stream); + break; + case t_list: + _ecl_write_list(x, stream); + break; + case t_package: + if (ecl_print_readably()) FEprint_not_readable(x); + writestr_stream("#<", stream); + si_write_ugly_object(x->pack.name, stream); + writestr_stream(" package>", stream); + break; + case t_hashtable: + write_hashtable(x, stream); + break; + case t_stream: + write_stream(x, stream); + break; + case t_random: + write_random(x, stream); + break; +#ifndef CLOS + case t_structure: + write_structure(x, stream); + break; +#endif /* CLOS */ + case t_readtable: + write_readtable(x, stream); + break; + case t_pathname: + write_pathname(x, stream); + break; + case t_bclosure: + _ecl_write_bclosure(x, stream); + break; + case t_bytecodes: + _ecl_write_bytecodes(x, stream); + break; + case t_cfun: + case t_cfunfixed: + if (ecl_print_readably()) FEprint_not_readable(x); + writestr_stream("#cfun.name != Cnil) + si_write_ugly_object(x->cfun.name, stream); + else + _ecl_write_addr(x, stream); + ecl_write_char('>', stream); + break; + case t_codeblock: + if (ecl_print_readably()) FEprint_not_readable(x); + writestr_stream("#cblock.name != Cnil) + si_write_ugly_object(x->cblock.name, stream); + else + _ecl_write_addr(x, stream); + ecl_write_char('>', stream); + break; + case t_cclosure: + if (ecl_print_readably()) FEprint_not_readable(x); + writestr_stream("#', stream); + break; +#ifdef CLOS + case t_instance: + call_print_object(x, stream); + break; +#endif /* CLOS */ + case t_foreign: + write_foreign(x, stream); + break; + case t_frame: + write_frame(x, stream); + break; + case t_weak_pointer: + write_weak_pointer(x, stream); + break; +#ifdef ECL_THREADS + case t_process: + write_process(x, stream); + break; + case t_lock: + write_lock(x, stream); + break; + case t_condition_variable: + write_condition_variable(x, stream); + break; +#endif /* ECL_THREADS */ +#ifdef ECL_SEMAPHORES + case t_semaphore: + write_semaphore(x, stream); + break; +#endif +#ifdef ECL_SSE2 + case t_sse_pack: + _ecl_write_sse(x, stream); + break; +#endif + default: + write_illegal(x, stream); + } + OUTPUT: + @(return x) +} diff --git a/src/c/symbols_list.h b/src/c/symbols_list.h index 728c06113..4ebf61cad 100755 --- a/src/c/symbols_list.h +++ b/src/c/symbols_list.h @@ -1963,5 +1963,7 @@ cl_symbols[] = { {SYS_ "FLOAT-TO-STRING-FREE", SI_ORDINARY, si_float_to_string_free, 4, OBJNULL}, {SYS_ "INTEGER-TO-STRING", SI_ORDINARY, si_integer_to_string, 5, OBJNULL}, +{SYS_ "PRINT-UNREADABLE-OBJECT-FUNCTION", SI_ORDINARY, si_print_unreadable_object_function, 5, OBJNULL}, + /* Tag for end of list */ {NULL, CL_ORDINARY, NULL, -1, OBJNULL}}; diff --git a/src/c/symbols_list2.h b/src/c/symbols_list2.h index 20e9b0e53..ea1c2f1aa 100755 --- a/src/c/symbols_list2.h +++ b/src/c/symbols_list2.h @@ -1963,5 +1963,7 @@ cl_symbols[] = { {SYS_ "FLOAT-TO-STRING-FREE","si_float_to_string_free"}, {SYS_ "INTEGER-TO-STRING","si_integer_to_string"}, +{SYS_ "PRINT-UNREADABLE-OBJECT-FUNCTION","si_print_unreadable_object_function"}, + /* Tag for end of list */ {NULL,NULL}}; diff --git a/src/h/external.h b/src/h/external.h index 81bcf102d..f24897cf8 100755 --- a/src/h/external.h +++ b/src/h/external.h @@ -86,12 +86,6 @@ struct cl_env_struct { /* ... the formatter ... */ cl_object fmt_aux_stream; - /* ... the pretty printer ... */ - bool print_pretty; - short *queue; - short *indent_stack; - int qh, qt, qc, isp, iisp; - /* ... arithmetics ... */ /* Note: if you change the size of these registers, change also BIGNUM_REGISTER_SIZE in config.h */ @@ -581,6 +575,7 @@ extern ECL_API void FEassignment_to_constant(cl_object v) ecl_attr_noreturn; extern ECL_API void FEundefined_function(cl_object fname) ecl_attr_noreturn; extern ECL_API void FEinvalid_function(cl_object obj) ecl_attr_noreturn; extern ECL_API void FEinvalid_function_name(cl_object obj) ecl_attr_noreturn; +extern ECL_API void FEprint_not_readable(cl_object obj) ecl_attr_noreturn; extern ECL_API cl_object CEerror(cl_object c, const char *err_str, int narg, ...); extern ECL_API void FEillegal_index(cl_object x, cl_object i) ecl_attr_noreturn; extern ECL_API void FElibc_error(const char *msg, int narg, ...) ecl_attr_noreturn; @@ -1435,6 +1430,17 @@ extern ECL_API void ecl_write_string(cl_object strng, cl_object strm); extern ECL_API void ecl_princ_str(const char *s, cl_object sym); extern ECL_API void ecl_princ_char(int c, cl_object sym); +extern ECL_API cl_fixnum ecl_print_level(void); +extern ECL_API cl_fixnum ecl_print_length(void); +extern ECL_API int ecl_print_base(void); +extern ECL_API bool ecl_print_radix(void); +extern ECL_API cl_object ecl_print_case(void); +extern ECL_API bool ecl_print_gensym(void); +extern ECL_API bool ecl_print_array(void); +extern ECL_API bool ecl_print_readably(void); +extern ECL_API bool ecl_print_escape(void); +extern ECL_API bool ecl_print_circle(void); + /* printer/integer_to_string.d */ extern ECL_API cl_object si_integer_to_string(cl_object buffer, cl_object integer, cl_object base, cl_object radix, cl_object decimalp); @@ -1447,6 +1453,8 @@ extern ECL_API cl_object si_float_to_digits(cl_object digits, cl_object number, /* printer/float_to_string.d */ extern ECL_API cl_object si_float_to_string_free(cl_object buffer, cl_object number, cl_object e_min, cl_object e_max); +/* printer/print_unreadable.d */ +extern ECL_API cl_object si_print_unreadable_object_function(cl_object o, cl_object stream, cl_object type, cl_object id, cl_object fn); /* profile.c */ #ifdef PROFILE diff --git a/src/h/internal.h b/src/h/internal.h index 26166ef3f..84d0759bd 100644 --- a/src/h/internal.h +++ b/src/h/internal.h @@ -290,6 +290,20 @@ extern cl_object FEnot_funcallable_vararg(cl_narg narg, ...); /* print.d */ +extern cl_object _ecl_stream_or_default_output(cl_object stream); +extern void _ecl_write_addr(cl_object x, cl_object stream); +extern void _ecl_write_array(cl_object o, cl_object stream); +extern void _ecl_write_vector(cl_object o, cl_object stream); +extern void _ecl_write_string(cl_object o, cl_object stream); +extern void _ecl_write_base_string(cl_object o, cl_object stream); +extern void _ecl_write_list(cl_object o, cl_object stream); +extern void _ecl_write_bclosure(cl_object o, cl_object stream); +extern void _ecl_write_bytecodes(cl_object o, cl_object stream); +extern void _ecl_write_symbol(cl_object o, cl_object stream); +extern void _ecl_write_fixnum(cl_fixnum o, cl_object stream); +extern void _ecl_write_sse(cl_fixnum o, cl_object stream); +extern void _ecl_write_unreadable(cl_object x, const char *prefix, cl_object name, cl_object stream); +extern bool _ecl_will_print_as_hash(cl_object o); extern cl_object _ecl_ensure_buffer(cl_object buffer, cl_fixnum length); extern void _ecl_string_push_c_string(cl_object s, const char *c); diff --git a/src/lsp/iolib.lsp b/src/lsp/iolib.lsp index 36c9e6e1f..e7f9ec9db 100644 --- a/src/lsp/iolib.lsp +++ b/src/lsp/iolib.lsp @@ -258,23 +258,6 @@ the one used internally by ECL compiled files." `#'(lambda (*standard-output* &rest args) (si::formatter-aux *standard-output* ,control-string args))) -(defun print-unreadable-object-function (object stream type identity function) - (if *print-readably* - (error 'print-not-readable :object object) - (when (and *print-level* (zerop *print-level*)) - (write-string "#" stream) - (return-from print-unreadable-object-function nil))) - (write-string "#<" stream) - (when type - (prin1 (type-of object) stream) - (write-string " " stream)) - (when function (funcall function)) - (when identity - (when (or function (not type)) (write-string " " stream)) - (princ (si:pointer object) stream)) - (write-string ">" stream) - nil) - (defmacro print-unreadable-object ((object stream &key type identity) &body body) (if body