mirror/guile
mirror/guile
1
Fork 0
mirror of https://git.savannah.gnu.org/git/guile.git synced 2025-05-20 11:40:18 +02:00
Code Activity

* struct.c (struct_printer): New variable that holds a handle on

Browse source 
the Scheme variable *struct-printer*.  This variable can be set by
Scheme code to override the printing of structures.
(scm_print_struct): If struct_printer is set, call it.  If it is
not set, or returns #f, print the structure in the old fashion.
Include "eval.h" for scm_apply.
This commit is contained in:
Marius Vollmer 1997-06-04 22:40:58 +00:00
parent fa7e927466
commit 916d65b1d1
1 changed files with 11 additions and 27 deletions
Download patch file Download diff file Expand all files Collapse all files

38
libguile/struct.c
View file

@ -44,6 +44,7 @@
#include "_scm.h" #include "_scm.h"
#include "chars.h" #include "chars.h"
#include "genio.h" #include "genio.h"
#include "eval.h"
#include "struct.h" #include "struct.h"
@ -55,6 +56,7 @@
static SCM required_vtable_fields = SCM_BOOL_F; static SCM required_vtable_fields = SCM_BOOL_F;
static int struct_num = 0; static int struct_num = 0;
static SCM struct_printer_var;
SCM_PROC (s_struct_make_layout, "make-struct-layout", 1, 0, 0, scm_make_struct_layout); SCM_PROC (s_struct_make_layout, "make-struct-layout", 1, 0, 0, scm_make_struct_layout);
@ -196,7 +198,7 @@ init_struct (handle, tail_elts, inits)
case 'p': case 'p':
if ((prot != 'r' && prot != 'w') || inits == SCM_EOL) if ((prot != 'r' && prot != 'w') || inits == SCM_EOL)
*mem = SCM_EOL; *mem = SCM_BOOL_F;
else else
{ {
*mem = SCM_CAR (inits); *mem = SCM_CAR (inits);
@ -602,34 +604,15 @@ scm_print_struct (exp, port, pstate)
SCM port; SCM port;
scm_print_state *pstate; scm_print_state *pstate;
{ {
#if 0 /* XXX - too verbose */ SCM prt = SCM_CDR (struct_printer_var);
SCM * data; if (SCM_FALSEP(prt) ||
SCM layout; SCM_FALSEP(scm_apply (prt, exp, scm_cons (port, scm_listofnull))))
int p;
int n_fields;
unsigned char * fields_desc;
unsigned char field_type;
layout = SCM_STRUCT_LAYOUT (exp);
data = SCM_STRUCT_DATA (exp);
fields_desc = (unsigned char *)SCM_CHARS (layout);
n_fields = data[scm_struct_i_n_words] - scm_struct_n_extra_words;
scm_gen_write (scm_regular_string, "#<struct ", sizeof ("#<struct ") - 1, port);
for (p = 0; p < n_fields; p++)
{ {
if (fields_desc[2*p] == 'p') scm_gen_write (scm_regular_string, "#<struct ", sizeof ("#<struct ") - 1,
scm_iprin1 (data[p], port, pstate); port);
if (p < n_fields-1) scm_intprint (exp, 16, port);
scm_gen_putc (' ', port); scm_gen_putc ('>', port);
} }
scm_gen_putc ('>', port);
#else
scm_gen_write (scm_regular_string, "#<struct ", sizeof ("#<struct ") - 1, port);
scm_intprint (exp, 16, port);
scm_gen_putc ('>', port);
#endif
} }
void void
@ -638,6 +621,7 @@ scm_init_struct ()
required_vtable_fields = SCM_CAR (scm_intern_obarray ("pruosr", sizeof ("pruosr") - 1, SCM_BOOL_F)); required_vtable_fields = SCM_CAR (scm_intern_obarray ("pruosr", sizeof ("pruosr") - 1, SCM_BOOL_F));
scm_permanent_object (required_vtable_fields); scm_permanent_object (required_vtable_fields);
scm_sysintern ("struct-vtable-offset", SCM_MAKINUM (scm_struct_i_vtable_offset)); scm_sysintern ("struct-vtable-offset", SCM_MAKINUM (scm_struct_i_vtable_offset));
struct_printer_var = scm_sysintern("*struct-printer*", SCM_BOOL_F);
#include "struct.x" #include "struct.x"
} }