/src/c/printer/write_ugly.d
D | 468 lines | 446 code | 10 blank | 12 comment | 10 complexity | d0f3a5614a4db449676cff80a0e3e435 MD5 | raw file
- /* -*- Mode: C; c-basic-offset: 2; indent-tabs-mode: nil -*- */
- /* vim: set filetype=c tabstop=2 shiftwidth=2 expandtab: */
- /*
- * write_ugly.d - ugly printer
- *
- * Copyright (c) 1984 Taiichi Yuasa and Masami Hagiya
- * Copyright (c) 1990 Giuseppe Attardi
- * Copyright (c) 2001 Juan Jose Garcia Ripoll
- *
- * See file 'LICENSE' for the copyright details.
- *
- */
- #include <string.h>
- #include <stdlib.h>
- #include <stdio.h>
- #ifndef _MSC_VER
- # include <unistd.h>
- #endif
- #include <ecl/ecl.h>
- #include <ecl/internal.h>
- 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',
- _ecl_funcall2(@'ext::maybe-quote', path->pathname.directory),
- @':name', path->pathname.name,
- @':type', path->pathname.type,
- @':version', path->pathname.version,
- @':defaults', ECL_NIL);
- 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 == ECL_NIL) {
- if (readably) {
- write_readable_pathname(path, stream);
- return;
- }
- namestring = ecl_namestring(path, 1);
- if (namestring == ECL_NIL) {
- writestr_stream("#<Unprintable pathname>", 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,
- ecl_make_fixnum(print_base),
- ecl_symbol_value(@'*print-radix*'),
- ECL_T /* decimal syntax */);
- si_do_write_sequence(s, stream, ecl_make_fixnum(0), ECL_NIL);
- 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, ecl_make_fixnum(i), ecl_make_fixnum(10), ECL_NIL, ECL_NIL);
- si_do_write_sequence(s, stream, ecl_make_fixnum(0), ECL_NIL);
- 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, ecl_make_fixnum(print_base),
- ecl_symbol_value(@'*print-radix*'),
- ECL_NIL /* decimal syntax */);
- ecl_string_push_extend(s, '/');
- si_integer_to_string(s, r->ratio.den,
- ecl_make_fixnum(print_base),
- ECL_NIL, ECL_NIL);
- si_do_write_sequence(s, stream, ecl_make_fixnum(0), ECL_NIL);
- 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, ecl_make_fixnum(-3), ecl_make_fixnum(8));
- si_do_write_sequence(s, stream, ecl_make_fixnum(0), ECL_NIL);
- si_put_buffer_string(s);
- }
- static void
- write_character(cl_object x, cl_object stream)
- {
- int i = ECL_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(ECL_CODE_CHAR(i));
- writestr_stream((char*)name->base_string.self, stream);
- } else {
- ecl_write_char(i, stream);
- }
- }
- }
- static void
- write_package(cl_object x, cl_object stream)
- {
- if (ecl_print_readably()) FEprint_not_readable(x);
- writestr_stream("#<", stream);
- si_write_ugly_object(x->pack.name, stream);
- writestr_stream(" package>", stream);
- }
- static void
- write_hashtable(cl_object x, cl_object stream)
- {
- if (ecl_print_readably() && !Null(ecl_symbol_value(@'*read-eval*'))) {
- cl_object make =
- cl_list(9, @'make-hash-table',
- @':size', cl_hash_table_size(x),
- @':rehash-size', cl_hash_table_rehash_size(x),
- @':rehash-threshold', cl_hash_table_rehash_threshold(x),
- @':test', cl_list(2, @'quote', cl_hash_table_test(x)));
- cl_object init =
- cl_list(3, @'ext::hash-table-fill', make,
- cl_list(2, @'quote', si_hash_table_content(x)));
- writestr_stream("#.", stream);
- si_write_ugly_object(init, stream);
- } else {
- _ecl_write_unreadable(x, "hash-table", ECL_NIL, 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", ECL_NIL, stream);
- }
- }
- static void
- write_stream(cl_object x, cl_object stream)
- {
- const char *prefix;
- cl_object tag;
- union cl_lispunion str;
- #ifdef ECL_UNICODE
- ecl_character buffer[10];
- #else
- ecl_base_char buffer[10];
- #endif
- switch ((enum ecl_smmode)x->stream.mode) {
- case ecl_smm_input_file:
- prefix = "closed input file";
- tag = IO_STREAM_FILENAME(x);
- break;
- case ecl_smm_input:
- prefix = "closed input stream";
- tag = IO_STREAM_FILENAME(x);
- break;
- case ecl_smm_output_file:
- prefix = "closed output file";
- tag = IO_STREAM_FILENAME(x);
- break;
- case ecl_smm_output:
- prefix = "closed output stream";
- tag = IO_STREAM_FILENAME(x);
- break;
- #ifdef ECL_MS_WINDOWS_HOST
- case ecl_smm_input_wsock:
- prefix = "closed input win32 socket stream";
- tag = IO_STREAM_FILENAME(x);
- break;
- case ecl_smm_output_wsock:
- prefix = "closed output win32 socket stream";
- tag = IO_STREAM_FILENAME(x);
- break;
- case ecl_smm_io_wsock:
- prefix = "closed i/o win32 socket stream";
- tag = IO_STREAM_FILENAME(x);
- break;
- case ecl_smm_io_wcon:
- prefix = "closed i/o win32 console stream";
- tag = IO_STREAM_FILENAME(x);
- break;
- #endif
- case ecl_smm_io_file:
- prefix = "closed io file";
- tag = IO_STREAM_FILENAME(x);
- break;
- case ecl_smm_io:
- prefix = "closed io stream";
- tag = IO_STREAM_FILENAME(x);
- break;
- case ecl_smm_probe:
- prefix = "closed probe stream";
- tag = IO_STREAM_FILENAME(x);
- break;
- case ecl_smm_synonym:
- prefix = "closed synonym stream to";
- tag = SYNONYM_STREAM_SYMBOL(x);
- break;
- case ecl_smm_broadcast:
- prefix = "closed broadcast stream";
- tag = ECL_NIL;
- break;
- case ecl_smm_concatenated:
- prefix = "closed concatenated stream";
- tag = ECL_NIL;
- break;
- case ecl_smm_two_way:
- prefix = "closed two-way stream";
- tag = ECL_NIL;
- break;
- case ecl_smm_echo:
- prefix = "closed echo stream";
- tag = ECL_NIL;
- break;
- case ecl_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 ecl_smm_string_output:
- prefix = "closed string-output stream";
- tag = ECL_NIL;
- break;
- case ecl_smm_sequence_input:
- prefix = "closed sequence-input stream";
- tag = ECL_NIL;
- break;
- case ecl_smm_sequence_output:
- prefix = "closed sequence-output stream";
- tag = ECL_NIL;
- break;
- default:
- ecl_internal_error("illegal stream mode");
- }
- if (!x->stream.closed)
- prefix = prefix + 7;
- _ecl_write_unreadable(x, prefix, tag, stream);
- }
- static void
- write_instance(cl_object x, cl_object stream)
- {
- _ecl_funcall3(@'print-object', x, stream);
- }
- static void
- write_readtable(cl_object x, cl_object stream)
- {
- _ecl_write_unreadable(x, "readtable", ECL_NIL, stream);
- }
- static void
- write_cfun(cl_object x, cl_object stream)
- {
- _ecl_write_unreadable(x, "compiled-function", x->cfun.name, stream);
- }
- static void
- write_codeblock(cl_object x, cl_object stream)
- {
- _ecl_write_unreadable(x, "codeblock", x->cblock.name, stream);
- }
- static void
- write_cclosure(cl_object x, cl_object stream)
- {
- _ecl_write_unreadable(x, "compiled-closure", ECL_NIL, 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", ecl_make_fixnum(x->frame.size), stream);
- }
- static void
- write_weak_pointer(cl_object x, cl_object stream)
- {
- _ecl_write_unreadable(x, "weak-pointer", ECL_NIL, 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_rwlock(cl_object x, cl_object stream)
- {
- _ecl_write_unreadable(x, "rwlock", x->rwlock.name, stream);
- }
- static void
- write_condition_variable(cl_object x, cl_object stream)
- {
- _ecl_write_unreadable(x, "semaphore", ECL_NIL, stream);
- }
- static void
- write_semaphore(cl_object x, cl_object stream)
- {
- _ecl_write_unreadable(x, "semaphore", ECL_NIL, stream);
- }
- static void
- write_barrier(cl_object x, cl_object stream)
- {
- _ecl_write_unreadable(x, "barrier", ECL_NIL, stream);
- }
- static void
- write_mailbox(cl_object x, cl_object stream)
- {
- _ecl_write_unreadable(x, "mailbox", ECL_NIL, stream);
- }
- #endif /* ECL_THREADS */
- static void
- write_illegal(cl_object x, cl_object stream)
- {
- _ecl_write_unreadable(x, "illegal pointer", ECL_NIL, stream);
- }
- typedef void (*printer)(cl_object x, cl_object stream);
- static printer dispatch[FREE+1] = {
- 0 /* t_start = 0 */,
- _ecl_write_list, /* t_list = 1 */
- write_character, /* t_character = 2 */
- write_integer, /* t_fixnum = 3 */
- write_integer, /* t_bignum = 4 */
- write_ratio, /* t_ratio */
- /* write_float, */ /* t_shortfloat */
- write_float, /* t_singlefloat */
- write_float, /* t_doublefloat */
- #ifdef ECL_LONG_FLOAT
- write_float, /* t_longfloat */
- #endif
- write_complex, /* t_complex */
- _ecl_write_symbol, /* t_symbol */
- write_package, /* t_package */
- write_hashtable, /* t_hashtable */
- _ecl_write_array, /* t_array */
- _ecl_write_vector, /* t_vector */
- #ifdef ECL_UNICODE
- _ecl_write_string, /* t_string */
- #endif
- _ecl_write_base_string, /* t_base_string */
- _ecl_write_bitvector, /* t_bitvector */
- write_stream, /* t_stream */
- write_random, /* t_random */
- write_readtable, /* t_readtable */
- write_pathname, /* t_pathname */
- _ecl_write_bytecodes, /* t_bytecodes */
- _ecl_write_bclosure, /* t_bclosure */
- write_cfun, /* t_cfun */
- write_cfun, /* t_cfunfixed */
- write_cclosure, /* t_cclosure */
- write_instance, /* t_instance */
- #ifdef ECL_THREADS
- write_process, /* t_process */
- write_lock, /* t_lock */
- write_rwlock, /* t_rwlock */
- write_condition_variable, /* t_condition_variable */
- write_semaphore, /* t_semaphore */
- write_barrier, /* t_barrier */
- write_mailbox, /* t_mailbox */
- #endif
- write_codeblock, /* t_codeblock */
- write_foreign, /* t_foreign */
- write_frame, /* t_frame */
- write_weak_pointer, /* t_weak_pointer */
- #ifdef ECL_SSE2
- _ecl_write_sse, /* t_sse_pack */
- #endif
- /* t_end */
- };
- cl_object
- si_write_ugly_object(cl_object x, cl_object stream)
- {
- if (x == OBJNULL) {
- if (ecl_print_readably())
- FEprint_not_readable(x);
- writestr_stream("#<OBJNULL>", stream);
- } else {
- int t = ecl_t_of(x);
- printer f = (t >= t_end)? write_illegal : dispatch[t];
- f(x, stream);
- }
- @(return x);
- }