core: Display me debuggor.

Having display in the core is handy for debugging.
This is a courtesy commit intended to prevent bitrot.

* GNUmakefile (mes.o): Depend on display.
* mes.c: Include display.
* display.c: New file.

diff --git a/GNUmakefile b/GNUmakefile
index 12a5dca6030d47b86bc608d499ef31d636b9f546..b1a81af35cf1378e8b15565119fb808f4350722e 100644 (file)
--- a/GNUmakefile
+++ b/GNUmakefile
@@ -29,6 +29,7 @@ all: mes module/mes/read-0.mo
 mes.o: GNUmakefile
 mes.o: mes.c
 mes.o: mes.c mes.h mes.i mes.environment.i mes.symbols.i
+mes.o: display.c display.h display.i display.environment.i
 mes.o: lib.c lib.h lib.i lib.environment.i
 mes.o: math.c math.h math.i math.environment.i
 mes.o: posix.c posix.h posix.i posix.environment.i

diff --git a/display.c b/display.c
new file mode 100644 (file)
index 0000000..b417556
--- /dev/null
+++ b/display.c
@@ -0,0 +1,177 @@
+/* -*-comment-start: "//";comment-end:""-*-
+ * Mes --- Maxwell Equations of Software
+ * Copyright © 2016 Jan Nieuwenhuizen <janneke@gnu.org>
+ *
+ * This file is part of Mes.
+ *
+ * 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.
+ *
+ * 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 Mes.  If not, see <http://www.gnu.org/licenses/>.
+ */
+
+scm char_eof = {CHAR, .name="*eof*", .value=-1};
+scm char_nul = {CHAR, .name="nul", .value=0};
+scm char_alarm = {CHAR, .name="alarm", .value=8};
+scm char_backspace = {CHAR, .name="backspace", .value=8};
+scm char_tab = {CHAR, .name="tab", .value=9};
+scm char_newline = {CHAR, .name="newline", .value=10};
+scm char_vtab = {CHAR, .name="vtab", .value=11};
+scm char_page = {CHAR, .name="page", .value=12};
+scm char_return = {CHAR, .name="return", .value=13};
+scm char_space = {CHAR, .name="space", .value=32};
+
+SCM display_helper (FILE*, SCM , bool, char const*, bool);
+
+SCM
+display (SCM x) ///((arity . n))
+{
+  SCM e = car (x);
+  SCM p = cdr (x);
+  int fd = 1;
+  if (TYPE (p) == PAIR && TYPE (car (p)) == NUMBER) fd = HITS (car (p));
+  FILE *f = fd == 1 ? stdout : stderr;
+  return display_helper (f, e, false, "", false);
+}
+
+SCM
+newline (SCM p) ///((arity . n))
+{
+  int fd = 1;
+  if (TYPE (p) == PAIR && TYPE (car (p)) == NUMBER) fd = VALUE (car (p));
+  FILE *f = fd == 1 ? stdout : stderr;
+  fputs ("\n", f);
+  return cell_unspecified;
+}
+
+SCM
+display_ (FILE* f, SCM x)
+{
+  return display_helper (f, x, false, "", false);
+}
+
+SCM
+display_helper (FILE* f, SCM x, bool cont, char const *sep, bool quote)
+{
+  SCM r;
+  fprintf (f, "%s", sep);
+  switch (TYPE (x))
+    {
+    case CHAR:
+      {
+        char const *name = 0;
+        if (VALUE (x) == char_nul.value) name = char_nul.name;
+        else if (VALUE (x) == char_alarm.value) name = char_alarm.name;
+        else if (VALUE (x) == char_backspace.value) name = char_backspace.name;
+        else if (VALUE (x) == char_tab.value) name = char_tab.name;
+        else if (VALUE (x) == char_newline.value) name = char_newline.name;
+        else if (VALUE (x) == char_vtab.value) name = char_vtab.name;
+        else if (VALUE (x) == char_page.value) name = char_page.name;
+        else if (VALUE (x) == char_return.value) name = char_return.name;
+        else if (VALUE (x) == char_space.value) name = char_space.name;
+        if (name) fprintf (f, "#\\%s", name);
+        else fprintf (f, "#\\%c", VALUE (x));
+        break;
+      }
+    case CLOSURE:
+      {
+        fprintf (f, "#<procedure #f ");
+        display_ (f, (cadr (CLOSURE (x))));
+        fprintf (f, ">");
+        return cell_unspecified;
+      }
+    case MACRO:
+      fprintf (f, "(*macro* ");
+      display_helper (f, g_cells[x].macro, cont, sep, quote);
+      fprintf (f, ")");
+      break;
+    case NUMBER: fprintf (f, "%d", VALUE (x)); break;
+    case PAIR:
+      {
+        if (car (x) == cell_circular) {
+          fprintf (f, "(*circ* . #-1#)");
+          return cell_unspecified;
+        }
+        if (car (x) == cell_closure) {
+          fprintf (f, "(*closure* . #-1#)");
+          return cell_unspecified;
+        }
+        if (car (x) == cell_symbol_quote && TYPE (cdr (x)) != PAIR) {
+          fprintf (f, "'");
+          x = cdr (x);
+          if (TYPE (x) != FUNCTION)
+            x = car (x);
+          return display_helper (f, x, cont, "", true);
+        }
+        if (!cont) fprintf (f, "(");
+        if (x && x!= cell_nil) display_ (f, car (x));
+        if (cdr (x) && TYPE (cdr (x)) == PAIR)
+          display_helper (f, cdr (x), true, " ", false);
+        else if (cdr (x) && cdr (x) != cell_nil) {
+          fprintf (f, " . ");
+          display_ (f, cdr (x));
+        }
+        if (!cont) fprintf (f, ")");
+        break;
+      }
+    case VECTOR:
+      {
+        fprintf (f, "#(");
+        for (int i = 0; i < LENGTH (x); i++) {
+          if (TYPE (VECTOR (x)+i) == VECTOR
+              || (TYPE (VECTOR (x)+i) == REF
+                  && TYPE (REF (VECTOR (x)+i)) == VECTOR))
+            fprintf (f, "%s#(...)", i ? " " : "");
+          else
+            display_helper (f,VECTOR (x)+i, false, i ? " " : "", false);
+        }
+        fprintf (f, ")");
+        break;
+      }
+    case REF: display_helper (f, g_cells[x].ref, cont, "", true); break;
+    case FUNCTION:
+      {
+        fprintf (f, "#<procedure ");
+        SCM p = STRING (x);
+        if (p < 0 || p >= g_free.value || TYPE (p) != PAIR)
+          fprintf (f, "%s", NAME (x));
+        else
+          display_ (f, STRING (x));
+        fprintf (f, " ");
+        switch (FUNCTION (x).arity)
+          {
+          case -1: fprintf (f, "(. x)"); break;
+          case 0: fprintf (f, "()"); break;
+          case 1: fprintf (f, "(x)"); break;
+          case 2: fprintf (f, "(x y)"); break;
+          case 3: fprintf (f, "(x y z)"); break;
+          }
+        fprintf (f, ">");
+        break;
+      }
+    case BROKEN_HEART: fprintf (f, "<3"); break;
+    case KEYWORD:
+      fprintf (f, "#:");
+    default:
+      if (STRING (x))
+        {
+          SCM p = STRING (x);
+          assert (p);
+          while (p != cell_nil) {
+            assert (TYPE (car (p)) == CHAR);
+            fputc (VALUE (car (p)), f);
+            p = cdr (p);
+          }
+        }
+      else if (TYPE (x) != PAIR && NAME (x)) fprintf (f, "%s", NAME (x));
+    }
+  return cell_unspecified;
+}

diff --git a/mes.c b/mes.c
index d61a8b59aed7082a8391bbb40ea0ab9a3f6a064f..ae616a1a5da2f1c582b83ff4c2c8280b8c13ba7b 100644 (file)
--- a/mes.c
+++ b/mes.c
@@ -132,6 +132,7 @@ SCM r1 = 0; // param 1
 SCM r2 = 0; // param 2
 SCM r3 = 0; // param 3
 
+#include "display.h"
 #include "lib.h"
 #include "math.h"
 #include "mes.h"
@@ -967,11 +968,13 @@ mes_builtins (SCM a)
 {
 #include "mes.i"
 
+#include "display.i"
 #include "lib.i"
 #include "math.i"
 #include "posix.i"
 #include "reader.i"
 
+#include "display.environment.i"
 #include "lib.environment.i"
 #include "math.environment.i"
 #include "mes.environment.i"
@@ -1015,6 +1018,7 @@ lookup_macro (SCM x, SCM a)
 }
 
 FILE *g_stdin;
+#include "display.c"
 #include "lib.c"
 #include "math.c"
 #include "posix.c"