mirrors/ecl
1
Fork 0
mirror of https://gitlab.com/embeddable-common-lisp/ecl.git synced 2026-01-15 13:52:16 -08:00
Code Issues Projects Releases Packages Wiki Activity

Split printer into separate files, factorizing those for unreadable printing

Browse source
This commit is contained in:
Juan Jose Garcia Ripoll 2010-10-28 23:05:25 +02:00
parent 4eee8dce57
commit 79d8e9b569
16 changed files with 1500 additions and 1496 deletions
Download patch file Download diff file Expand all files Collapse all files

5
src/c/Makefile.in
View file

@ -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\

6
src/c/error.d
View file

@ -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 *
*************/

1491
src/c/print.d
View file

File diff suppressed because it is too large Load diff

82
src/c/printer/print_unreadable.d Normal file
View file

@ -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 <ecl/ecl.h>
#include <ecl/internal.h>
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)
}

206
src/c/printer/write_array.d Normal file
View file

@ -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 <ecl/ecl.h>
#include <ecl/internal.h>
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? "#<vector " : "#<array ", stream);
_ecl_write_addr(x, stream);
ecl_write_char('>', 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; j++) {
si_write_object(MAKE_FIXNUM(adims[j]), stream);
if (j < n-1)
ecl_write_char(' ', stream);
}
ecl_write_char(')', stream);
} else {
si_write_object(Cnil, stream);
}
ecl_write_char(' ', stream);
} else if (!vector) {
_ecl_write_fixnum(n, stream);
ecl_write_char('A', stream);
}
if (print_level >= 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("#<bit-vector ", stream);
_ecl_write_addr(x, stream);
ecl_write_char('>', 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);
}
}

76
src/c/printer/write_code.d Normal file
View file

@ -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 <ecl/ecl.h>
#include <ecl/internal.h>
#include <ecl/bytecodes.h>
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("#<bytecompiled-closure ", stream);
if (name != Cnil)
si_write_ugly_object(name, stream);
else
_ecl_write_addr(x, stream);
ecl_write_char('>', 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("#<bytecompiled-function ", stream);
if (name != Cnil)
si_write_ugly_object(name, stream);
else
_ecl_write_addr(x, stream);
ecl_write_char('>', stream);
}
}

118
src/c/printer/write_list.d Normal file
View file

@ -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 <ecl/ecl.h>
#include <ecl/internal.h>
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);
}

142
src/c/printer/write_object.d Normal file
View file

@ -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 <ecl/ecl.h>
#include <ecl/internal.h>
#include <ecl/bytecodes.h>
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 <element, flag> 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);
}

96
src/c/printer/write_sse.d Normal file
View file

@ -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 <ecl/ecl.h>
#include <ecl/internal.h>
#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("#<SSE", stream);
write_sse_pack(x, stream);
ecl_write_char('>', stream);
}
#endif

206
src/c/printer/write_symbol.d Normal file
View file

@ -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 <ecl/ecl.h>
#include <ecl/internal.h>
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));
}

513
src/c/printer/write_ugly.d Normal file
View file

@ -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 <string.h>
#include <stdlib.h>
#include <stdio.h>
#ifndef _MSC_VER
# include <unistd.h>
#endif
#include <ecl/ecl.h>
#include <ecl/internal.h>
#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("#<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,
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("#<OBJNULL>", 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("#<compiled-function ", stream);
if (x->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("#<codeblock ", stream);
if (x->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("#<compiled-closure ", stream);
_ecl_write_addr(x, stream);
ecl_write_char('>', 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)
}

2
src/c/symbols_list.h
View file

@ -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}};

2
src/c/symbols_list2.h
View file

@ -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}};

20
src/h/external.h
View file

@ -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

14
src/h/internal.h
View file

@ -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);

17
src/lsp/iolib.lsp
View file

@ -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