mes.c: display, newline: take optional port; add write-char, read hex #xXX.
authorJan Nieuwenhuizen <janneke@gnu.org>
Fri, 12 Aug 2016 12:17:20 +0000 (14:17 +0200)
committerJan Nieuwenhuizen <janneke@gnu.org>
Fri, 12 Aug 2016 12:17:20 +0000 (14:17 +0200)
mes.c

diff --git a/mes.c b/mes.c
index 41dda0f4201a53f694044bad26c17e8db3a85bba..a227f6a0b44c3e3cc1c88e9f3382d27d36342044 100644 (file)
--- a/mes.c
+++ b/mes.c
@@ -69,7 +69,7 @@ typedef struct scm_t {
 #define MES_C 1
 #include "mes.h"
 
-scm *display_helper (scm*, bool, char*, bool);
+scm *display_helper (FILE*, scm*, bool, char*, bool);
 bool
 symbol_eq (scm *x, char *s)
 {
@@ -515,9 +515,20 @@ vector_p (scm *x)
 }
 
 scm *
-display (scm *x)
+display (scm *x/*...*/)
 {
-  return display_helper (x, false, "", false);
+  scm *e = car (x);
+  scm *p = cdr (x);
+  int fd = 1;
+  if (p->type == PAIR && p->car->type == NUMBER) fd = p->car->value;
+  FILE *f = fd == 1 ? stdout : stderr;
+  return display_helper (f, e, false, "", false);
+}
+
+scm *
+display_ (FILE* f, scm *x) //internal
+{
+  return display_helper (f, x, false, "", false);
 }
 
 scm *
@@ -909,66 +920,69 @@ vector_to_list (scm *v)
 }
 
 scm *
-newline ()
+newline (scm *p/*...*/)
 {
-  puts ("");
+  int fd = 1;
+  if (p->type == PAIR && p->car->type == NUMBER) fd = p->car->value;
+  FILE *f = fd == 1 ? stdout : stderr;
+  fputs ("\n", f);
   return &scm_unspecified;
 }
 
 scm *
-display_helper (scm *x, bool cont, char *sep, bool quote)
+display_helper (FILE* f, scm *x, bool cont, char *sep, bool quote)
 {
   scm *r;
-  printf ("%s", sep);
-  if (x->type == CHAR && x->value == char_nul.value) printf ("#\\%s", char_nul.name);
-  else if (x->type == CHAR && x->value == char_backspace.value) printf ("#\\%s", char_backspace.name);
-  else if (x->type == CHAR && x->value == char_tab.value) printf ("#\\%s", char_tab.name);
-  else if (x->type == CHAR && x->value == char_newline.value) printf ("#\\%s", char_newline.name);
-  else if (x->type == CHAR && x->value == char_vt.value) printf ("#\\%s", char_vt.name);
-  else if (x->type == CHAR && x->value == char_page.value) printf ("#\\%s", char_page.name);
-  else if (x->type == CHAR && x->value == char_return.value) printf ("#\\%s", char_return.name);
-  else if (x->type == CHAR && x->value == char_space.value) printf ("#\\%s", char_space.name);
-  else if (x->type == CHAR) printf ("#\\%c", x->value);
+  fprintf (f, "%s", sep);
+  if (x->type == CHAR && x->value == char_nul.value) fprintf (f, "#\\%s", char_nul.name);
+  else if (x->type == CHAR && x->value == char_backspace.value) fprintf (f, "#\\%s", char_backspace.name);
+  else if (x->type == CHAR && x->value == char_tab.value) fprintf (f, "#\\%s", char_tab.name);
+  else if (x->type == CHAR && x->value == char_newline.value) fprintf (f, "#\\%s", char_newline.name);
+  else if (x->type == CHAR && x->value == char_vt.value) fprintf (f, "#\\%s", char_vt.name);
+  else if (x->type == CHAR && x->value == char_page.value) fprintf (f, "#\\%s", char_page.name);
+  else if (x->type == CHAR && x->value == char_return.value) fprintf (f, "#\\%s", char_return.name);
+  else if (x->type == CHAR && x->value == char_space.value) fprintf (f, "#\\%s", char_space.name);
+  else if (x->type == CHAR) fprintf (f, "#\\%c", x->value);
   else if (x->type == MACRO) {
-    printf ("(*macro* ");
-    display_helper (x->macro, cont, sep, quote);
-    printf (")");
+    fprintf (f, "(*macro* ");
+    display_helper (f, x->macro, cont, sep, quote);
+    fprintf (f, ")");
   }
-  else if (x->type == NUMBER) printf ("%d", x->value);
+  else if (x->type == NUMBER) fprintf (f, "%d", x->value);
   else if (x->type == PAIR) {
     if (car (x) == &symbol_circ) {
-      printf ("(*circ* . #-1#)");
+      fprintf (f, "(*circ* . #-1#)");
       return &scm_unspecified;
     }
     if (car (x) == &symbol_closure) {
-      printf ("(*closure* . #-1#)");
+      fprintf (f, "(*closure* . #-1#)");
       return &scm_unspecified;
     }
     if (car (x) == &scm_quote) {
-      printf ("'");
-      return display_helper (car (cdr (x)), cont, "", true);
+      fprintf (f, "'");
+      return display_helper (f, car (cdr (x)), cont, "", true);
     }
-    if (!cont) printf ("(");
-    display (car (x));
+    if (!cont) fprintf (f, "(");
+    display_ (f, car (x));
     if (cdr (x)->type == PAIR)
-      display_helper (cdr (x), true, " ", false);
+      display_helper (f, cdr (x), true, " ", false);
     else if (cdr (x) != &scm_nil) {
-      printf (" . ");
-      display (cdr (x));
+      fprintf (f, " . ");
+      display_ (f, cdr (x));
     }
-    if (!cont) printf (")");
+    if (!cont) fprintf (f, ")");
   }
   else if (x->type == VECTOR) {
-    printf ("#(", x->length);
+    fprintf (f, "#(", x->length);
     for (int i = 0; i < x->length; i++) {
       if (x->vector[i]->type == VECTOR)
-        printf ("%s#(...)", i ? " " : "");
+        fprintf (f, "%s#(...)", i ? " " : "");
       else
-        display_helper (x->vector[i], false, i ? " " : "", false);
+        display_helper (f, x->vector[i], false, i ? " " : "", false);
     }
-    printf (")");
+    fprintf (f, ")");
   }
-  else if (atom_p (x) == &scm_t) printf ("%s", x->name);
+  else if (atom_p (x) == &scm_t) fprintf (f, "%s", x->name);
 
   return &scm_unspecified;
 }
@@ -1001,10 +1015,23 @@ read_char ()
   return make_char (getchar ());
 }
 
+scm *
+write_char (scm *x/*...*/)
+{
+  scm *c = car (x);
+  scm *p = cdr (x);
+  int fd = 1;
+  if (p->type == PAIR && p->car->type == NUMBER) fd = p->car->value;
+  FILE *f = fd == 1 ? stdout : stderr;
+  assert (c->type == NUMBER || c->type == CHAR);
+  fputc (c->value, f);
+  return c;
+}
+
 scm*
 builtin_ungetchar (scm *c)
 {
-  assert (c->type == NUMBER);
+  assert (c->type == NUMBER || c->type == CHAR);
   ungetchar (c->value);
   return c;
 }
@@ -1060,6 +1087,7 @@ readword (int c, char* w, scm *a)
                           cons (readword (getchar (), w, a),
                                 &scm_nil));}
   if (c == ';') {readcomment (c); return readword ('\n', w, a);}
+  if (c == '#' && peek_char () == 'x') {getchar (); return read_hex ();}
   if (c == '#' && peek_char () == '\\') {getchar (); return read_character ();}
   if (c == '#' && !w && peek_char () == '(') {getchar (); return list_to_vector (readlist (a));}
   if (c == '#' && peek_char () == '(') {ungetchar (c); return lookup (w, a);}
@@ -1069,6 +1097,24 @@ readword (int c, char* w, scm *a)
   return readword (getchar (), strncat (w ? w : buf, &ch, 1), a);
 }
 
+scm *
+read_hex ()
+{
+  int n = 0;
+  int c = peek_char ();
+  while ((c >= '0' && c <= '9')
+         || (c >= 'A' && c <= 'F')
+         || (c >= 'a' && c <= 'f')) {
+    n <<= 4;
+    if (c >= 'a') n += c - 'a' + 10;
+    else if (c >= 'A') n += c - 'A' + 10;
+    else n+= c - '0';
+    getchar ();
+    c = peek_char ();
+  }
+  return make_number (n);
+}
+
 scm *
 read_character ()
 {
@@ -1370,7 +1416,7 @@ int
 main (int argc, char *argv[])
 {
   scm *a = mes_environment ();
-  display (eval (cons (&symbol_begin, read_file (readenv (a), a)), a));
-  newline ();
+  display_ (stderr, eval (cons (&symbol_begin, read_file (readenv (a), a)), a));
+  fputs ("", stderr);
   return 0;
 }