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
 	transformer source with correct environment.

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