core: Add struct type.

* src/struct.c: New file.
* build-aux/snarf.sh: Snarf it.
* src/mes.c: Include it.

build-aux/snarf.sh

@@ -33,4 +33,5 @@ trace "SNARF$snarf  math.c"   ${srcdest}build-aux/mes-snarf.scm $1 src/math.c
 trace "SNARF$snarf  mes.c"    ${srcdest}build-aux/mes-snarf.scm $1 src/mes.c
 trace "SNARF$snarf  posix.c"  ${srcdest}build-aux/mes-snarf.scm $1 src/posix.c
 trace "SNARF$snarf  reader.c" ${srcdest}build-aux/mes-snarf.scm $1 src/reader.c
+trace "SNARF$snarf  struct.c" ${srcdest}build-aux/mes-snarf.scm $1 src/struct.c
 trace "SNARF$snarf  vector.c" ${srcdest}build-aux/mes-snarf.scm $1 src/vector.c

mes/module/mes/display.mes

@@ -143,6 +143,13 @@
         (if (keyword? x) (display "#:" port))
         (for-each (display-cut2 display-char <> port write?) (string->list x))
         (if (and (string? x) write?) (write-char #\" port)))
+       ((struct? x)
+        (display "#<" port)
+        (for-each (lambda (i)
+                    (let ((x (strut-ref x i)))
+                      (d x #f (if (= i 0) "" " "))))
+                  (iota (struct-length x)))
+        (display ")" port))
        ((vector? x)
         (display "#(" port)
         (for-each (lambda (i)
@@ -215,7 +222,7 @@
                     ((#\s) (write (car args) port))
                     (else (display (car args) port)))
                   (simple-format (cddr lst) (cdr args)))))))
-    
+
     (if destination (simple-format lst rest)
         (with-output-to-string
           (lambda () (simple-format lst rest))))))

mes/module/mes/type-0.mes

@@ -37,6 +37,7 @@
         (cons <cell:ref> (quote <cell:ref>))
         (cons <cell:special> (quote <cell:special>))
         (cons <cell:string> (quote <cell:string>))
+        (cons <cell:struct> (quote <cell:struct>))
         (cons <cell:symbol> (quote <cell:symbol>))
         (cons <cell:values> (quote <cell:values>))
         (cons <cell:variable> (quote <cell:variable>))
@@ -86,6 +87,9 @@
 (define (string? x)
   (eq? (core:type x) <cell:string>))
 
+(define (struct? x)
+  (eq? (core:type x) <cell:struct>))
+
 (define (symbol? x)
   (eq? (core:type x) <cell:symbol>))
 

src/gc.c

@@ -70,7 +70,8 @@ gc_copy (SCM old) ///((internal))
     return g_cells[old].car;
   SCM new = g_free++;
   g_news[new] = g_cells[old];
-  if (NTYPE (new) == TVECTOR)
+  if (NTYPE (new) == TSTRUCT
+      || NTYPE (new) == TVECTOR)
     {
       NVECTOR (new) = g_free;
       for (long i=0; i<LENGTH (old); i++)

src/lib.c

@@ -166,11 +166,34 @@ display_helper (SCM x, int cont, char* sep, int fd, int write_p)
       if (TYPE (x) == TPORT)
         fdputs (">", fd);
     }
+  else if (t == TREF)
+    fdisplay_ (REF (x), fd, write_p);
+  else if (t == TSTRUCT)
+    {
+      SCM printer = STRUCT (x) + 1;
+      if (TYPE (printer) == TREF)
+        printer = REF (printer);
+      if (printer != cell_unspecified)
+        apply (printer, cons (x, cell_nil), r0);
+      else
+        {
+          fdputs ("#<", fd);
+          fdisplay_ (STRUCT (x), fd, write_p);
+          SCM t = CAR (x);
+          long size = LENGTH (x);
+          for (long i=2; i<size; i++)
+            {
+              fdputc (' ', fd);
+              fdisplay_ (STRUCT (x) + i, fd, write_p);
+            }
+          fdputc ('>', fd);
+        }
+    }
   else if (t == TVECTOR)
     {
       fdputs ("#(", fd);
       SCM t = CAR (x);
-      for (long i = 0; i < LENGTH (x); i++)
+      for (long i = 0; i<LENGTH (x); i++)
         {
           if (i)
             fdputc (' ', fd);

src/mes.c

@@ -69,13 +69,14 @@ CONSTANT TPORT          8
 CONSTANT TREF           9
 CONSTANT TSPECIAL      10
 CONSTANT TSTRING       11
-CONSTANT TSYMBOL       12
-CONSTANT TVALUES       13
-CONSTANT TVARIABLE     14
-CONSTANT TVECTOR       15
-CONSTANT TBROKEN_HEART 16
+CONSTANT TSTRUCT       12
+CONSTANT TSYMBOL       13
+CONSTANT TVALUES       14
+CONSTANT TVARIABLE     15
+CONSTANT TVECTOR       16
+CONSTANT TBROKEN_HEART 17
 #else // !__M2_PLANET__
-enum type_t {TCHAR, TCLOSURE, TCONTINUATION, TFUNCTION, TKEYWORD, TMACRO, TNUMBER, TPAIR, TPORT, TREF, TSPECIAL, TSTRING, TSYMBOL, TVALUES, TVARIABLE, TVECTOR, TBROKEN_HEART};
+enum type_t {TCHAR, TCLOSURE, TCONTINUATION, TFUNCTION, TKEYWORD, TMACRO, TNUMBER, TPAIR, TPORT, TREF, TSPECIAL, TSTRING, TSTRUCT, TSYMBOL, TVALUES, TVARIABLE, TVECTOR, TBROKEN_HEART};
 #endif // !__M2_PLANET__
 
 typedef SCM (*function0_t) (void);
@@ -252,6 +253,7 @@ struct scm scm_type_port = {TSYMBOL, "<cell:port>",0};
 struct scm scm_type_ref = {TSYMBOL, "<cell:ref>",0};
 struct scm scm_type_special = {TSYMBOL, "<cell:special>",0};
 struct scm scm_type_string = {TSYMBOL, "<cell:string>",0};
+struct scm scm_type_struct = {TSYMBOL, "<cell:struct>",0};
 struct scm scm_type_symbol = {TSYMBOL, "<cell:symbol>",0};
 struct scm scm_type_values = {TSYMBOL, "<cell:values>",0};
 struct scm scm_type_variable = {TSYMBOL, "<cell:variable>",0};
@@ -279,6 +281,7 @@ int g_function = 0;
 #include "mes.mes.h"
 #include "posix.mes.h"
 #include "reader.mes.h"
+#include "struct.mes.h"
 #include "vector.mes.h"
 #else
 #include "gc.h"
@@ -287,6 +290,7 @@ int g_function = 0;
 #include "mes.h"
 #include "posix.h"
 #include "reader.h"
+#include "struct.h"
 #include "vector.h"
 #endif
 
@@ -311,6 +315,7 @@ int g_function = 0;
 #define FUNCTION0(x) g_functions[g_cells[x].cdr].function
 #define MACRO(x) g_cells[x].cdr
 #define PORT(x) g_cells[x].cdr
+#define STRUCT(x) g_cells[x].cdr
 #define VALUE(x) g_cells[x].cdr
 #define VECTOR(x) g_cells[x].cdr
 
@@ -331,6 +336,7 @@ int g_function = 0;
 #define MACRO(x) g_cells[x].macro
 #define PORT(x) g_cells[x].port
 #define REF(x) g_cells[x].ref
+#define STRUCT(x) g_cells[x].vector
 #define VALUE(x) g_cells[x].value
 #define VECTOR(x) g_cells[x].vector
 #define FUNCTION(x) g_functions[g_cells[x].function]
@@ -626,6 +632,8 @@ check_apply (SCM f, SCM e) ///((internal))
     type = "number";
   if (TYPE (f) == TSTRING)
     type = "string";
+  if (TYPE (f) == TSTRUCT)
+    type = "#<...>";
   if (TYPE (f) == TBROKEN_HEART)
     type = "<3";
 
@@ -2043,6 +2051,7 @@ g_cells[cell_vm_return].car = cstring_to_list (scm_vm_return.car);
   a = acons (cell_type_ref, MAKE_NUMBER (TREF), a);
   a = acons (cell_type_special, MAKE_NUMBER (TSPECIAL), a);
   a = acons (cell_type_string, MAKE_NUMBER (TSTRING), a);
+  a = acons (cell_type_struct, MAKE_NUMBER (TSTRUCT), a);
   a = acons (cell_type_symbol, MAKE_NUMBER (TSYMBOL), a);
   a = acons (cell_type_values, MAKE_NUMBER (TVALUES), a);
   a = acons (cell_type_variable, MAKE_NUMBER (TVARIABLE), a);
@@ -2196,6 +2205,7 @@ a = acons (lookup_symbol_ (scm_getenv_.string), cell_getenv_, a);
 #include "math.mes.i"
 #include "lib.mes.i"
 #include "vector.mes.i"
+#include "struct.mes.i"
 #include "gc.mes.i"
 #include "reader.mes.i"
 
@@ -2205,6 +2215,7 @@ a = acons (lookup_symbol_ (scm_getenv_.string), cell_getenv_, a);
 #include "mes.mes.environment.i"
 #include "posix.mes.environment.i"
 #include "reader.mes.environment.i"
+#include "struct.mes.environment.i"
 #include "vector.mes.environment.i"
 #else
 #include "mes.i"
@@ -2214,6 +2225,7 @@ a = acons (lookup_symbol_ (scm_getenv_.string), cell_getenv_, a);
 #include "math.i"
 #include "lib.i"
 #include "vector.i"
+#include "struct.i"
 #include "gc.i"
 #include "reader.i"
 
@@ -2223,6 +2235,7 @@ a = acons (lookup_symbol_ (scm_getenv_.string), cell_getenv_, a);
 #include "mes.environment.i"
 #include "posix.environment.i"
 #include "reader.environment.i"
+#include "struct.environment.i"
 #include "vector.environment.i"
 #endif
 
@@ -2403,6 +2416,7 @@ bload_env (SCM a) ///((internal))
 }
 
 #include "vector.c"
+#include "struct.c"
 #include "gc.c"
 #include "reader.c"
 

src/struct.c

@@ -0,0 +1,71 @@
+/* -*-comment-start: "//";comment-end:""-*-
+ * GNU Mes --- Maxwell Equations of Software
+ * Copyright © 2018 Jan (janneke) Nieuwenhuizen <janneke@gnu.org>
+ *
+ * This file is part of GNU Mes.
+ *
+ * GNU Mes is free software; you can redistribute it and/or modify it
+ * under the terms of the GNU General Public License as published by
+ * the Free Software Foundation; either version 3 of the License, or (at
+ * your option) any later version.
+ *
+ * GNU Mes is distributed in the hope that it will be useful, but
+ * WITHOUT ANY WARRANTY; without even the implied warranty of
+ * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
+ * GNU General Public License for more details.
+ *
+ * You should have received a copy of the GNU General Public License
+ * along with GNU Mes.  If not, see <http://www.gnu.org/licenses/>.
+ */
+
+SCM
+make_struct (SCM type, SCM fields, SCM printer)
+{
+  long size = 2 + length__ (fields);
+  SCM v = alloc (size);
+  SCM x = make_cell__ (TSTRUCT, size, v);
+  g_cells[v] = g_cells[vector_entry (type)];
+  g_cells[v+1] = g_cells[vector_entry (printer)];
+  for (long i=2; i<size; i++)
+    {
+      SCM e = cell_unspecified;
+      if (fields != cell_nil)
+        {
+          e = CAR (fields);
+          fields = CDR (fields);
+        }
+      g_cells[v+i] = g_cells[vector_entry (e)];
+    }
+  return x;
+}
+
+SCM
+struct_length (SCM x)
+{
+  assert (TYPE (x) == TSTRUCT);
+  return MAKE_NUMBER (LENGTH (x));
+}
+
+SCM
+struct_ref (SCM x, SCM i)
+{
+  assert (TYPE (x) == TSTRUCT);
+  assert (VALUE (i) < LENGTH (x));
+  SCM e = STRUCT (x) + VALUE (i);
+  if (TYPE (e) == TREF)
+    e = REF (e);
+  if (TYPE (e) == TCHAR)
+    e = MAKE_CHAR (VALUE (e));
+  if (TYPE (e) == TNUMBER)
+    e = MAKE_NUMBER (VALUE (e));
+  return e;
+}
+
+SCM
+struct_set_x (SCM x, SCM i, SCM e)
+{
+  assert (TYPE (x) == TSTRUCT);
+  assert (VALUE (i) < LENGTH (x));
+  g_cells[STRUCT (x)+VALUE (i)] = g_cells[vector_entry (e)];
+  return cell_unspecified;
+}