core: Remove display.
authorJan Nieuwenhuizen <janneke@gnu.org>
Sat, 24 Dec 2016 00:23:50 +0000 (01:23 +0100)
committerJan Nieuwenhuizen <janneke@gnu.org>
Sat, 24 Dec 2016 00:23:50 +0000 (01:23 +0100)
* posix.c (stderr_): New function.
* display.c: Remove.
* mes.c: Remove includes.  Use stderr_ instead of display_.
 (gc_loop): Preserve function's name.
 (arity_): New function.
* GNUmakefile (mes.o): Remove dependency on display.
* module/mes/read-0.mes: Use core:stderr instead of display, newline.
  (newline): New function.
* module/mes/base-0.mes: Use core:stderr instead of display.
  Include (mes display).
* module/mes/display.mes: New file.
* lib.c (assert_defined): Move from mes.c.
  (string_to_cstring): Move from posix.c
* build-aux/mes-snarf.scm (function-environment): Initialize function
  name with scheme string.

GNUmakefile
build-aux/mes-snarf.scm
display.c [deleted file]
lib.c
mes.c
module/mes/base-0.mes
module/mes/display.mes [new file with mode: 0644]
module/mes/read-0.mes
posix.c

index c68ad0863c72ec5b269ede4c6aec6ce71fd3aa19..df4bd28d33a66a0bae25610e4f44c307b5a17f4c 100644 (file)
@@ -29,7 +29,6 @@ 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
index 53c21f147e1936ed4ce60b21a5e597f1c4f25aa4..97499e3954e410cd10364659fe1cfa35024ffd68 100755 (executable)
@@ -106,6 +106,7 @@ exec ${GUILE-guile} --no-auto-compile -L $HOME/src/mes/build-aux -L build-aux -e
 (define (function->environment f i)
   (string-append
    (format #f "scm_~a.string = cstring_to_list (scm_~a.name);\n" (.name f) (.name f))
+   (format #f "g_cells[cell_~a].string = MAKE_STRING (scm_~a.string);\n" (.name f) (.name f))
    (format #f "a = acons (make_symbol (scm_~a.string), ~a, a);\n" (.name f) (function-cell-name f))
    ;;(format #f "a = add_environment (a, ~S, ~a);\n" (function-scm-name f) (function-cell-name f))
    ))
diff --git a/display.c b/display.c
deleted file mode 100644 (file)
index 4b21c54..0000000
--- a/display.c
+++ /dev/null
@@ -1,166 +0,0 @@
-/* -*-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 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/lib.c b/lib.c
index 57bafd9e04edb7dfa9282ed26676abb7e561da2c..06a6f8e2a9a7986b4635274a160ef1b5a48edeb5 100644 (file)
--- a/lib.c
+++ b/lib.c
@@ -55,3 +55,30 @@ exit_ (SCM x) ///((name . "exit"))
   assert (TYPE (x) == NUMBER);
   exit (VALUE (x));
 }
+
+char const*
+string_to_cstring (SCM s)
+{
+  static char buf[1024];
+  char *p = buf;
+  s = STRING (s);
+  while (s != cell_nil)
+    {
+      *p++ = VALUE (car (s));
+      s = cdr (s);
+    }
+  *p = 0;
+  return buf;
+}
+
+SCM
+assert_defined (SCM x, SCM e)
+{
+  if (e == cell_undefined)
+    {
+      fprintf (stderr, "eval: unbound variable:");
+      stderr_ (x);
+      assert (!"unbound variable");
+    }
+  return e;
+}
diff --git a/mes.c b/mes.c
index dd8115495732f1ae91044957b08ad76a8494cde3..dd73f2d4d966d99538432ca67fa517915a6158ad 100644 (file)
--- a/mes.c
+++ b/mes.c
@@ -111,6 +111,7 @@ scm scm_symbol_call_with_values = {SYMBOL, "call-with-values"};
 scm scm_symbol_current_module = {SYMBOL, "current-module"};
 scm scm_symbol_primitive_load = {SYMBOL, "primitive-load"};
 scm scm_symbol_read_input_file = {SYMBOL, "read-input-file"};
+scm scm_symbol_display = {SYMBOL, "display"};
 
 scm scm_symbol_car = {SYMBOL, "car"};
 scm scm_symbol_cdr = {SYMBOL, "cdr"};
@@ -118,17 +119,6 @@ scm scm_symbol_null_p = {SYMBOL, "null?"};
 scm scm_symbol_eq_p = {SYMBOL, "eq?"};
 scm scm_symbol_cons = {SYMBOL, "cons"};
 
-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 g_free = {NUMBER, .value=0};
 scm *g_cells;
 scm *g_news = 0;
@@ -151,7 +141,6 @@ 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"
@@ -187,7 +176,6 @@ SCM r3 = 0; // param 3
 #define MAKE_REF(n) make_cell (tmp_num_ (REF), n, 0);
 #define MAKE_STRING(x) make_cell (tmp_num_ (STRING), x, 0);
 
-SCM display_ (FILE* f, SCM x);
 SCM vm_call (function0_t f, SCM p1, SCM p2, SCM a);
 
 SCM
@@ -344,19 +332,6 @@ assq_ref_cache (SCM x, SCM a)
   return cdr (x);
 }
 
-SCM
-assert_defined (SCM x, SCM e)
-{
-  if (e == cell_undefined)
-    {
-      fprintf (stderr, "eval: unbound variable:");
-      display_ (stderr, x);
-      fprintf (stderr, "\n");
-      assert (!"unbound variable");
-    }
-  return e;
-}
-
 enum eval_apply_t {EVLIS, APPLY, EVAL, MACRO_EXPAND, BEGIN, IF, CALL_WITH_VALUES};
 enum eval_apply_t g_target;
 
@@ -452,9 +427,9 @@ eval_apply ()
   if (type)
     {
       fprintf (stderr, "cannot apply: %s: ", type);
-      display_ (stderr, e);
+      stderr_ (e);
       fprintf (stderr, " [");
-      display_ (stderr, r1);
+      stderr_ (r1);
       fprintf (stderr, "]\n");
       assert (!"cannot apply");
     }
@@ -747,6 +722,13 @@ make_vector (SCM n)
   return x;
 }
 
+SCM
+arity_ (SCM x)
+{
+  assert (TYPE (x) == FUNCTION);
+  return MAKE_NUMBER (FUNCTION (x).arity);
+}
+
 SCM
 values (SCM x) ///((arity . n))
 {
@@ -924,6 +906,7 @@ gc_loop (SCM scan)
   while (scan < g_free.value)
     {
       if (NTYPE (scan) == CLOSURE
+          || NTYPE (scan) == FUNCTION
           || NTYPE (scan) == KEYWORD
           || NTYPE (scan) == MACRO
           || NTYPE (scan) == PAIR
@@ -1057,13 +1040,11 @@ 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"
@@ -1179,7 +1160,6 @@ dump ()
   return 0;
 }
 
-#include "display.c"
 #include "lib.c"
 #include "math.c"
 #include "posix.c"
@@ -1197,7 +1177,7 @@ main (int argc, char *argv[])
   SCM program = (argc > 1 && !strcmp (argv[1], "--load"))
     ? bload_env (r0) : load_env (r0);
   if (argc > 1 && !strcmp (argv[1], "--dump")) return dump ();
-  display_ (stderr, begin_env (program, r0));
+  stderr_ (begin_env (program, r0));
   fputs ("", stderr);
   gc (stack);
   if (g_debug) fprintf (stderr, "\nstats: [%d]\n", g_free.value);
index 21d127d6a83262f5a3faf2d38763cbc19400186f..2ac994324acedce7990565bff6d1537a02191979 100644 (file)
         'o))
 (define-macro (load file)
   (list 'begin
+          (list core:stderr "read ")
+          (list core:stderr file)
+          (list core:stderr "\n")
      (list 'push! '*input-ports* (list current-input-port))
      (list 'set-current-input-port (list open-input-file file))
      (list 'primitive-load)
          (list
           'begin
           (list 'set! '*modules* (list cons (list string->symbol (module->file module)) '*modules*))
-          ;; (list display "loading file=" (list current-error-port))
-          ;; (list display (module->file module) (list current-error-port))
-          ;; (list newline (list current-error-port))
+          ;; (list core:stderr "read ")
+          ;; (list core:stderr file)
+          ;; (list core:stderr "\n")
           (list 'load (list string-append '*mes-prefix* (module->file module)))))))
 
 (mes-use-module (srfi srfi-0))
 (mes-use-module (mes base))
 (mes-use-module (mes quasiquote))
 (mes-use-module (mes scm))
+(mes-use-module (mes display))
diff --git a/module/mes/display.mes b/module/mes/display.mes
new file mode 100644 (file)
index 0000000..0daf1fe
--- /dev/null
@@ -0,0 +1,113 @@
+;;; -*-scheme-*-
+
+;;; 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/>.
+
+;;; Commentary:
+
+;;; Code:
+
+(mes-use-module (mes scm))
+
+(define (newline . rest)
+  (apply display (cons "\n" rest)))
+
+(define (display x . rest)
+  (let* ((port (if (null? rest) (current-output-port) (car rest)))
+         (write? (and (pair? rest) (pair? (cdr rest)))))
+    
+    (define-macro (cut f slot port)
+      `(lambda (slot) (,f slot ,port)))
+
+    (define (d x cont? sep)
+      (for-each (cut write-char <> port) (string->list sep))
+      (cond
+       ((char? x)
+        (write-char #\# port)
+        (write-char #\\ port)
+        (let ((name (and=> (assq x '((#\*eof* . *eof*)
+                                     (#\nul . nul)
+                                     (#\alarm . alarm)
+                                     (#\backspace . backspace)
+                                     (#\tab . tab)
+                                     (#\newline . newline)
+                                     (#\vtab . vtab)
+                                     (#\page . page)
+                                     (#\return . return)
+                                     (#\space . space)))
+                           cdr)))
+          (if name (display name)
+              (write-char x port))))
+       ((closure? x)
+        (display "<#procedure #f " port)
+        (display (cadr (core:cdr x)) port)
+        (display ">" port))
+       ((macro? x)
+        (display "<#macro " port)
+        (display (core:cdr x) port)
+        (display ">" port))
+       ((number? x) (display (number->string x) port))
+       ((pair? x)
+        (if (not cont?) (write-char #\( port))
+        (cond ((eq? (car x) '*circular*)
+               (display "(*circ* . #-1#)" port))
+              ((eq? (car x) '*closure*)
+               (display "(*closure* . #-1#)" port))
+              (#t
+               (display (car x) port write?)
+               (if (pair? (cdr x)) (d (cdr x) #t " ")
+                   (if (and (cdr x) (not (null? (cdr x))))
+                       (begin
+                         (display " . " port)
+                         (display (cdr x) port write?))))
+               (if (not cont?) (write-char #\) port)))))
+       ((or (keyword? x) (special? x) (string? x) (symbol? x))
+        (if (and (string? x) write?) (write-char #\" port))
+        (if (keyword? x) (display "#:" port))
+        (for-each (cut write-char <> port) (string->list x))
+        (if (and (string? x) write?) (write-char #\" port)))
+       ((vector? x)
+        (display "#(" port)
+        (for-each (lambda (i)
+                    (let ((x (vector-ref x i)))
+                      (if (vector? x)
+                          (begin
+                            (display (if (= i 0) "" " ") port)
+                            (display "#(...)" port))
+                          (d x #f (if (= i 0) "" " ")))))
+                  (iota (vector-length x)))
+        (display ")" port))
+       ((function? x)
+        (display "<#procedure " port)
+        (display (core:car x) port)
+        (display " " port)
+        (display
+         (case (core:arity x)
+           ((-1) "(. x)")
+           ((0) "()")
+           ((1) "(x)")
+           ((2) "(x y)")
+           ((3) "(x y z)"))
+         port)
+        (display ">" port))
+       ((broken-heart? x)
+        (display "<3" port))
+       (#t
+        (display "TODO type=") (display (cell:type-name x)) (newline)))
+      *unspecified*)
+    (d x #f "")))
index 25c6ef992d529cd35ffd0a96d99f71fcbf7306f7..535b34aeffebbdefe4c44905555eb7a9098b67ca 100644 (file)
   (define <cell:keyword> 3)
   (define <cell:string> 9)
 
+  (define (newline) (core:stderr (integer->char 10)))
+  (define (display x . reset) #f)
+  
   (define (list->symbol lst) (make-symbol lst))
 
   (define (symbol->list s)
                                (egap . 12)
                                (nruter . 13)
                                (ecaps . 32)))) => cdr)
-              (#t (display (quote char-not-supported:)) (display n) (newline) (exit 1))))
+              (#t (core:stderr (quote char-not-supported:)) (core:stderr n) (newline) (exit 1))))
       (if (not (and (> p 96) (< p 123))) (integer->char (lookup-char (list->symbol (cons (integer->char c) n))))
           (read-name (read-byte) (peek-byte) (cons (integer->char c) n))))
 
         (read-byte)
         (read-string (read-byte) (peek-byte) (append-char s 10)))
        ((eq? c 34) s)
-       ((eq? c -1) (display (quote EOF-in-string)) (newline) (exit 1))
+       ((eq? c -1) (core:stderr (quote EOF-in-string)) (newline) (exit 1))
        (#t (read-string (read-byte) (peek-byte) (append-char s c)))))
     (list->string (read-string (read-byte) (peek-byte) (list))))
 
diff --git a/posix.c b/posix.c
index e0d6631178897051e7ab650e619af3569c3b8bc7..0695a97e5ecc93a686e86fa1f4c5456b8408fcd7 100644 (file)
--- a/posix.c
+++ b/posix.c
 
 #include <fcntl.h>
 
-char const*
-string_to_cstring (SCM s)
+SCM
+stderr_ (SCM x)
 {
-  static char buf[1024];
-  char *p = buf;
-  s = STRING (s);
-  while (s != cell_nil)
-    {
-      *p++ = VALUE (car (s));
-      s = cdr (s);
-    }
-  *p = 0;
-  return buf;
+  SCM display;
+  if ((display = assq_ref_cache (cell_symbol_display, r0)) != cell_undefined)
+    apply_env (assq_ref_cache (cell_symbol_display, r0), cons (x, cons (MAKE_NUMBER (2), cell_nil)), r0);
+  else if (TYPE (x) == SPECIAL || TYPE (x) == STRING || TYPE (x) == SYMBOL)
+    fprintf (stderr, string_to_cstring (x));
+  else
+    fprintf (stderr, "display: undefined\n");
+  return cell_unspecified;
 }
 
 SCM