diff options
-rw-r--r-- | libguile/ChangeLog | 29 | ||||
-rw-r--r-- | libguile/gc.c | 4 | ||||
-rw-r--r-- | libguile/print.c | 52 | ||||
-rw-r--r-- | libguile/print.h | 11 | ||||
-rw-r--r-- | libguile/struct.c | 19 | ||||
-rw-r--r-- | libguile/struct.h | 20 |
6 files changed, 99 insertions, 36 deletions
diff --git a/libguile/ChangeLog b/libguile/ChangeLog index 1e30841a6..f76f8843d 100644 --- a/libguile/ChangeLog +++ b/libguile/ChangeLog @@ -1,4 +1,31 @@ -Thu Oct 2 19:33:38 1997 Mikael Djurfeldt <mdj@mdj.nada.kth.se> +1997-10-03 Mikael Djurfeldt <mdj@nada.kth.se> + + * print.h (SCM_PRINT_STATE_P): Removed SCM_NIMP test. (NIMP + macros should by convention not test for NIMPness.) + (SCM_COERCE_OPORT): Adjust indentation. + + * print.c (scm_valid_oport_value_p): Adjusted indentation; Added + SCM_NIMP test before SCM_PRINT_STATE_P. + + * struct.c, struct.h, gc.c: Renamed: + scm_struct_i_layout --> scm_vtable_index_layout + scm_struct_i_vcell --> scm_vtable_index_vcell + scm_struct_i_vtable --> scm_vtable_index_vtable + scm_struct_i_printer --> scm_vtable_index_printer + scm_struct_i_vtable_offset --> scm_vtable_offset_user + + * struct.c (scm_print_struct): Use new printer slot; Default + printing: Also output hex code of vtable so that type identity + will be indicated as well. + (scm_init_struct): Updated required_vtable_fields to "pruosrpw"; + Removed struct_printer_var; Removed struct-vtable-offset; + (vtable-index-layout, vtable-index-vtable, vtable-index-printer, + vtable-offset-user): New constants. + + * struct.h (scm_struct_i_vtable_offset): Bumped from 3 to 4. + (scm_struct_i_printer, SCM_STRUCT_PRINTER): New slot in vtables. + If this slot contains a procedure, use that to print structures of + the type represented by this vtable. * print.c (scm_iprin1): Don't print arguments of macro transformers. (They are always: exp env.); Bugfix: Unmemoize diff --git a/libguile/gc.c b/libguile/gc.c index 27bd42307..a5f66a42b 100644 --- a/libguile/gc.c +++ b/libguile/gc.c @@ -628,7 +628,7 @@ gc_mark_nimp: register int x; vtable_data = (SCM *)vcell; - layout = vtable_data[scm_struct_i_layout]; + layout = vtable_data[scm_vtable_index_layout]; len = SCM_LENGTH (layout); fields_desc = SCM_CHARS (layout); /* We're using SCM_GCCDR here like STRUCT_DATA, except @@ -652,7 +652,7 @@ gc_mark_nimp: if (!SCM_CDR (vcell)) { SCM_SETGCMARK (vcell); - ptr = vtable_data[scm_struct_i_vtable]; + ptr = vtable_data[scm_vtable_index_vtable]; goto gc_mark_loop; } } diff --git a/libguile/print.c b/libguile/print.c index 5a34f6001..6f2b83190 100644 --- a/libguile/print.c +++ b/libguile/print.c @@ -205,6 +205,29 @@ scm_make_print_state () return answer ? answer : make_print_state (); } +static char s_print_state_printer[] = "print-state-printer"; +static SCM +print_state_printer (obj, port) + SCM obj; + SCM port; +{ + /* This function can be made visible by means of struct-ref, so + we need to make sure that it gets what it wants. */ + SCM_ASSERT (SCM_NIMP (obj) && SCM_PRINT_STATE_P (obj), + obj, + SCM_ARG1, + s_print_state_printer); + SCM_ASSERT (scm_valid_oport_value_p (port), + port, + SCM_ARG2, + s_print_state_printer); + port = SCM_COERCE_OPORT (port); + scm_gen_puts (scm_regular_string, "#<print-state ", port); + scm_intprint (obj, 16, port); + scm_gen_putc ('>', port); + return SCM_UNSPECIFIED; +} + void scm_free_print_state (print_state) SCM print_state; @@ -836,10 +859,13 @@ circref: int scm_valid_oport_value_p (SCM val) { - return SCM_NIMP (val) && - (SCM_OPOUTPORTP (val) || (SCM_CONSP (val) && SCM_NIMP (SCM_CAR (val)) && - SCM_OPOUTPORTP (SCM_CAR (val)) && - SCM_PRINT_STATE_P (SCM_CDR (val)))); + return (SCM_NIMP (val) + && (SCM_OPOUTPORTP (val) + || (SCM_CONSP (val) + && SCM_NIMP (SCM_CAR (val)) + && SCM_OPOUTPORTP (SCM_CAR (val)) + && SCM_NIMP (SCM_CDR (val)) + && SCM_PRINT_STATE_P (SCM_CDR (val))))); } SCM_PROC(s_write, "write", 1, 1, 0, scm_write); @@ -958,14 +984,18 @@ scm_printer_apply (proc, exp, port, pstate) void scm_init_print () { - SCM vtable, type; - + SCM vtable, layout, printer, type; + scm_init_opts (scm_print_options, scm_print_opts, SCM_N_PRINT_OPTIONS); - vtable = scm_make_vtable_vtable (scm_make_struct_layout (scm_nullstr), SCM_INUM0, SCM_EOL); - type = scm_make_struct (vtable, - SCM_INUM0, - scm_cons (scm_make_struct_layout (scm_makfrom0str (SCM_PRINT_STATE_LAYOUT)), - SCM_EOL)); + vtable = scm_make_vtable_vtable (scm_make_struct_layout (scm_nullstr), + SCM_INUM0, + SCM_EOL); + layout = scm_make_struct_layout (scm_makfrom0str (SCM_PRINT_STATE_LAYOUT)); + printer = scm_make_subr_opt (s_print_state_printer, + scm_tc7_subr_2, + (SCM (*) ()) print_state_printer, + 0 /* Don't bind the name. */); + type = scm_make_struct (vtable, SCM_INUM0, SCM_LIST2 (layout, printer)); print_state_pool = scm_permanent_object (scm_cons (type, SCM_EOL)); scm_print_state_vtable = type; diff --git a/libguile/print.h b/libguile/print.h index 2025c8f89..00d724d51 100644 --- a/libguile/print.h +++ b/libguile/print.h @@ -56,9 +56,9 @@ extern scm_option scm_print_opts[]; /* State information passed around during printing. */ -#define SCM_PRINT_STATE_P(obj) (SCM_NIMP(obj) && SCM_STRUCTP(obj) && \ - SCM_STRUCT_VTABLE(obj) == \ - scm_print_state_vtable) +#define SCM_PRINT_STATE_P(obj) (SCM_STRUCTP(obj) \ + && (SCM_STRUCT_VTABLE(obj) \ + == scm_print_state_vtable)) #define SCM_PRINT_STATE(obj) ((scm_print_state *) SCM_STRUCT_DATA (obj)) #define RESET_PRINT_STATE(pstate) \ @@ -70,8 +70,9 @@ extern scm_option scm_print_opts[]; #define SCM_WRITINGP(pstate) ((pstate)->writingp) #define SCM_SET_WRITINGP(pstate, x) { (pstate)->writingp = (x); } -#define SCM_COERCE_OPORT(p) ((SCM_NIMP(p) && SCM_PRINT_STATE_P(SCM_CDR (p)))? \ - SCM_CAR(p) : p) +#define SCM_COERCE_OPORT(p) ((SCM_NIMP (p) && SCM_PRINT_STATE_P (SCM_CDR (p))) \ + ? SCM_CAR (p) \ + : p) #define SCM_PRINT_STATE_LAYOUT "sruwuwuwuwuwpwuwuwuruopr" typedef struct scm_print_state { diff --git a/libguile/struct.c b/libguile/struct.c index ecd1e875d..b3f0ef74c 100644 --- a/libguile/struct.c +++ b/libguile/struct.c @@ -56,7 +56,6 @@ static SCM required_vtable_fields = SCM_BOOL_F; 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); @@ -357,7 +356,7 @@ scm_make_struct (vtable, tail_array_size, init) SCM_ASSERT (SCM_INUMP (tail_array_size), tail_array_size, SCM_ARG2, s_make_struct); - layout = SCM_STRUCT_DATA (vtable)[scm_struct_i_layout]; + layout = SCM_STRUCT_DATA (vtable)[scm_vtable_index_layout]; basic_size = SCM_LENGTH (layout) / 2; tail_elts = SCM_INUM (tail_array_size); SCM_NEWCELL (handle); @@ -604,12 +603,14 @@ scm_print_struct (exp, port, pstate) SCM port; scm_print_state *pstate; { - SCM prt = SCM_CDR (struct_printer_var); - if (SCM_FALSEP(prt) || - SCM_FALSEP(scm_printer_apply (prt, exp, port, pstate))) + if (SCM_NFALSEP (scm_procedure_p (SCM_STRUCT_PRINTER (exp)))) + scm_printer_apply (SCM_STRUCT_PRINTER (exp), exp, port, pstate); + else { scm_gen_write (scm_regular_string, "#<struct ", sizeof ("#<struct ") - 1, port); + scm_intprint (SCM_STRUCT_VTABLE (exp), 16, port); + scm_gen_putc (':', port); scm_intprint (exp, 16, port); scm_gen_putc ('>', port); } @@ -618,9 +619,11 @@ scm_print_struct (exp, port, pstate) void 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 ("pruosrpw", sizeof ("pruosrpw") - 1, SCM_BOOL_F)); scm_permanent_object (required_vtable_fields); - scm_sysintern ("struct-vtable-offset", SCM_MAKINUM (scm_struct_i_vtable_offset)); - struct_printer_var = scm_sysintern("*struct-printer*", SCM_BOOL_F); + scm_sysintern ("vtable-index-layout", SCM_MAKINUM (scm_vtable_index_layout)); + scm_sysintern ("vtable-index-vtable", SCM_MAKINUM (scm_vtable_index_vtable)); + scm_sysintern ("vtable-index-printer", SCM_MAKINUM (scm_vtable_index_printer)); + scm_sysintern ("vtable-offset-user", SCM_MAKINUM (scm_vtable_offset_user)); #include "struct.x" } diff --git a/libguile/struct.h b/libguile/struct.h index e0d0f66d9..85c7c2001 100644 --- a/libguile/struct.h +++ b/libguile/struct.h @@ -53,20 +53,22 @@ #define scm_struct_n_extra_words 3 /* These are how the initial words of a vtable are allocated. */ -#define scm_struct_i_ptr -3 /* start of block (see alloc_struct) */ -#define scm_struct_i_n_words -2 /* How many words allocated to this struct? */ -#define scm_struct_i_tag -1 /* A unique tag for this type.. */ -#define scm_struct_i_layout 0 /* A symbol describing the physical arrangement of this type. */ -#define scm_struct_i_vcell 1 /* An opaque word, managed by the garbage collector. */ -#define scm_struct_i_vtable 2 /* A pointer to the handle for this vtable. */ -#define scm_struct_i_vtable_offset 3 /* Where do user fields start? */ +#define scm_struct_i_ptr -3 /* start of block (see alloc_struct) */ +#define scm_struct_i_n_words -2 /* How many words allocated to this struct? */ +#define scm_struct_i_tag -1 /* A unique tag for this type.. */ +#define scm_vtable_index_layout 0 /* A symbol describing the physical arrangement of this type. */ +#define scm_vtable_index_vcell 1 /* An opaque word, managed by the garbage collector. */ +#define scm_vtable_index_vtable 2 /* A pointer to the handle for this vtable. */ +#define scm_vtable_index_printer 3 /* A printer for this struct type. */ +#define scm_vtable_offset_user 4 /* Where do user fields start? */ #define SCM_STRUCTP(X) (SCM_TYP3(X) == scm_tc3_cons_gloc) #define SCM_STRUCT_DATA(X) ((SCM*)(SCM_CDR(X))) #define SCM_STRUCT_VTABLE_DATA(X) ((SCM *)(SCM_CAR(X) - 1)) -#define SCM_STRUCT_LAYOUT(X) (SCM_STRUCT_VTABLE_DATA(X)[scm_struct_i_layout]) -#define SCM_STRUCT_VTABLE(X) (SCM_STRUCT_VTABLE_DATA(X)[scm_struct_i_vtable]) +#define SCM_STRUCT_LAYOUT(X) (SCM_STRUCT_VTABLE_DATA(X)[scm_vtable_index_layout]) +#define SCM_STRUCT_VTABLE(X) (SCM_STRUCT_VTABLE_DATA(X)[scm_vtable_index_vtable]) +#define SCM_STRUCT_PRINTER(X) (SCM_STRUCT_VTABLE_DATA(X)[scm_vtable_index_printer]) /* Efficiency is important in the following macro, since it's used in GC */ #define SCM_LAYOUT_TAILP(X) (((X) & 32) == 0) /* R, W or O */ |