core: Implement stack and frame.

* src/lib.c (frame_printer make_frame_type, make_frame,
make_stack_type, make_stack, stack_length, stack_ref): New function.

scaffold/mini-mes.c

@@ -50,6 +50,8 @@ SCM g_macros = 0;
 SCM g_ports = 0;
 SCM g_stack = 0;
 SCM *g_stack_array = 0;
+#define FRAME_SIZE 5
+#define FRAME_PROCEDURE 4
 // a/env
 SCM r0 = 0;
 // param 1
@@ -58,6 +60,8 @@ SCM r1 = 0;
 SCM r2 = 0;
 // continuation
 SCM r3 = 0;
+// current-module
+SCM m0 = 0;
 
 enum type_t {TCHAR, TCLOSURE, TCONTINUATION, TFUNCTION, TKEYWORD, TMACRO, TNUMBER, TPAIR, TPORT, TREF, TSPECIAL, TSTRING, TSTRUCT, TSYMBOL, TVALUES, TVARIABLE, TVECTOR, TBROKEN_HEART};
 
@@ -136,8 +140,11 @@ struct scm scm_symbol_unbound_variable = {TSYMBOL, "unbound-variable",0};
 
 struct scm scm_symbol_hashq_table = {TSYMBOL, "<hashq-table>",0};
 struct scm scm_symbol_record_type = {TSYMBOL, "<record-type>",0};
+struct scm scm_symbol_frame = {TSYMBOL, "<frame>",0};
 struct scm scm_symbol_module = {TSYMBOL, "<module>",0};
+struct scm scm_symbol_stack = {TSYMBOL, "<stack>",0};
 struct scm scm_symbol_buckets = {TSYMBOL, "buckets",0};
+struct scm scm_symbol_procedure = {TSYMBOL, "procedure",0};
 struct scm scm_symbol_size = {TSYMBOL, "size",0};
 
 struct scm scm_symbol_argv = {TSYMBOL, "%argv",0};
@@ -807,6 +814,19 @@ make_tmps (struct scm* cells)
 #endif
 #include "lib.c"
 
+SCM frame_printer (SCM frame)
+{
+}
+SCM make_stack (SCM stack)
+{
+}
+SCM stack_length (SCM stack)
+{
+}
+SCM stack_ref (SCM stack, SCM index)
+{
+}
+
 // Jam Collector
 SCM g_symbol_max;
 

src/gc.c

@@ -202,6 +202,7 @@ gc_ () ///((internal))
   g_symbols = gc_copy (g_symbols);
   g_macros = gc_copy (g_macros);
   g_ports = gc_copy (g_ports);
+  m0 = gc_copy (m0);
   for (long i=g_stack; i<STACK_SIZE; i++)
     g_stack_array[i]= gc_copy (g_stack_array[i]);
   gc_loop (1);

src/lib.c

@@ -268,6 +268,84 @@ exit_ (SCM x) ///((name . "exit"))
   exit (VALUE (x));
 }
 
+#if !MES_MINI
+SCM
+frame_printer (SCM frame)
+{
+  fdputs ("#<", g_stdout); display_ (struct_ref_ (frame, 2));
+  fdputc (' ', g_stdout);
+  fdputs ("procedure: ", g_stdout); display_ (struct_ref_ (frame, 3));
+  fdputc ('>', g_stdout);
+}
+
+SCM
+make_frame_type () ///((internal))
+{
+  SCM record_type = cell_symbol_record_type; // FIXME
+  SCM fields = cell_nil;
+  fields = cons (cell_symbol_procedure, fields);
+  fields = cons (fields, cell_nil);
+  fields = cons (cell_symbol_frame, fields);
+  return make_struct (record_type, fields, cell_unspecified);
+}
+
+SCM
+make_frame (SCM stack, long index)
+{
+  SCM frame_type = make_frame_type ();
+  long array_index = (STACK_SIZE-(index*FRAME_SIZE));
+  SCM procedure = g_stack_array[array_index+FRAME_PROCEDURE];
+  if (!procedure)
+    procedure = cell_f;
+  SCM values = cell_nil;
+  values = cons (procedure, values);
+  values = cons (cell_symbol_frame, values);
+  return make_struct (frame_type, values, cell_frame_printer);
+}
+
+SCM
+make_stack_type () ///((internal))
+{
+  SCM record_type = cell_symbol_record_type; // FIXME
+  SCM fields = cell_nil;
+  fields = cons (cstring_to_symbol ("frames"), fields);
+  fields = cons (fields, cell_nil);
+  fields = cons (cell_symbol_stack, fields);
+  return make_struct (record_type, fields, cell_unspecified);
+}
+
+SCM
+make_stack (SCM stack) ///((arity . n))
+{
+  SCM stack_type = make_stack_type ();
+  long size = (STACK_SIZE-g_stack) / FRAME_SIZE;
+  SCM frames = make_vector__ (size);
+  for (long i=0; i<size; i++)
+    {
+      SCM frame = make_frame (stack, i);
+      vector_set_x_ (frames, i, frame);
+    }
+  SCM values = cell_nil;
+  values = cons (frames, values);
+  values = cons (cell_symbol_stack, values);
+  return make_struct (stack_type, values, cell_unspecified);
+}
+
+SCM
+stack_length (SCM stack)
+{
+  SCM frames = struct_ref_ (stack, 3);
+  return vector_length (frames);
+}
+
+SCM
+stack_ref (SCM stack, SCM index)
+{
+  SCM frames = struct_ref_ (stack, 3);
+  return vector_ref (frames, index);
+}
+#endif // !MES_MINI
+
 SCM
 xassq (SCM x, SCM a) ///for speed in core only
 {

src/mes.c

@@ -46,6 +46,8 @@ SCM g_continuations = 0;
 SCM g_symbols = 0;
 SCM g_stack = 0;
 SCM *g_stack_array = 0;
+#define FRAME_SIZE 5
+#define FRAME_PROCEDURE 4
 // a/env
 SCM r0 = 0;
 // param 1
@@ -202,8 +204,11 @@ struct scm scm_symbol_unbound_variable = {TSYMBOL, "unbound-variable",0};
 
 struct scm scm_symbol_hashq_table = {TSYMBOL, "<hashq-table>",0};
 struct scm scm_symbol_record_type = {TSYMBOL, "<record-type>",0};
+struct scm scm_symbol_frame = {TSYMBOL, "<frame>",0};
 struct scm scm_symbol_module = {TSYMBOL, "<module>",0};
+struct scm scm_symbol_stack = {TSYMBOL, "<stack>",0};
 struct scm scm_symbol_buckets = {TSYMBOL, "buckets",0};
+struct scm scm_symbol_procedure = {TSYMBOL, "procedure",0};
 struct scm scm_symbol_size = {TSYMBOL, "size",0};
 
 struct scm scm_symbol_argv = {TSYMBOL, "%argv",0};
@@ -701,16 +706,15 @@ gc_peek_frame () ///((internal))
   r2 = g_stack_array[g_stack+1];
   r1 = g_stack_array[g_stack+2];
   r0 = g_stack_array[g_stack+3];
-  m0 = g_stack_array[g_stack+4];
+  return g_stack_array[g_stack+FRAME_PROCEDURE];
-  return m0;
 }
 
 SCM
 gc_pop_frame () ///((internal))
 {
-  gc_peek_frame ();
+  SCM x = gc_peek_frame ();
   g_stack += 5;
-  return m0;
+  return x;
 }
 
 SCM