mes: Add write, core:write.
authorJan Nieuwenhuizen <janneke@gnu.org>
Mon, 1 Jan 2018 20:10:15 +0000 (21:10 +0100)
committerJan Nieuwenhuizen <janneke@gnu.org>
Mon, 1 Jan 2018 20:10:15 +0000 (21:10 +0100)
* src/lib.c (display_helper, fdisplay_): Add parameter, write_p.
  Update callers.  When write_p: write quoted strings.
  (write_, write_port_): New function.
* module/mes/read-0.mes (write): New function.

module/mes/read-0.mes
src/lib.c

index 019e7c582243e02d835bf069f82d24d6edd84051..5f25dc9dfc2552042685124e2c5fa2d819df0665 100644 (file)
   (define (newline . rest) (core:display (list->string (list (integer->char 10)))))
   (define (display x . rest) (if (null? rest) (core:display x)
                                  (core:display-port x (car rest))))
-  
+  (define (write x . rest) (if (null? rest) (core:write x)
+                               (core:write-port x (car rest))))
+
   (define (list->symbol lst) (core:lookup-symbol lst))
 
   (define (symbol->list s)
index a8f13dd9f12c046b8ee9285c4f9d2cbc45c736e5..f97ce2134a8c637c73fc8289d492b0c71c2afca4 100644 (file)
--- a/src/lib.c
+++ b/src/lib.c
  */
 
 int g_depth;
-SCM fdisplay_ (SCM, int);
-
-SCM display_helper (SCM x, int cont, char* sep, int fd);
+SCM fdisplay_ (SCM, int, int);
 
 SCM
-display_helper (SCM x, int cont, char* sep, int fd)
+display_helper (SCM x, int cont, char* sep, int fd, int write_p)
 {
   fputs (sep, fd);
   if (g_depth == 0) return cell_unspecified;
@@ -41,7 +39,7 @@ display_helper (SCM x, int cont, char* sep, int fd)
     case TCLOSURE:
       {
         fputs ("#<closure ", fd);
-        display_helper (CDR (x), cont, "", fd);
+        display_helper (CDR (x), cont, "", fd, 0);
         fputs (">", fd);
         break;
       }
@@ -62,7 +60,7 @@ display_helper (SCM x, int cont, char* sep, int fd)
     case TMACRO:
       {
         fputs ("#<macro ", fd);
-        display_helper (CDR (x), cont, "", fd);
+        display_helper (CDR (x), cont, "", fd, 0);
         fputs (">", fd);
         break;
       }
@@ -78,14 +76,14 @@ display_helper (SCM x, int cont, char* sep, int fd)
           fputs ("*circ* . #-1#", fd);
         else
           {
-            if (x && x != cell_nil) fdisplay_ (CAR (x), fd);
+            if (x && x != cell_nil) fdisplay_ (CAR (x), fd, write_p);
             if (CDR (x) && TYPE (CDR (x)) == TPAIR)
-              display_helper (CDR (x), 1, " ", fd);
+              display_helper (CDR (x), 1, " ", fd, write_p);
             else if (CDR (x) && CDR (x) != cell_nil)
               {
                 if (TYPE (CDR (x)) != TPAIR)
                   fputs (" . ", fd);
-                fdisplay_ (CDR (x), fd);
+                fdisplay_ (CDR (x), fd, write_p);
               }
           }
         if (!cont) fputs (")", fd);
@@ -95,12 +93,14 @@ display_helper (SCM x, int cont, char* sep, int fd)
     case TSTRING:
     case TSYMBOL:
       {
+        if (write_p && TYPE (x) == TSTRING) fputc ('"', fd);
         SCM t = CAR (x);
         while (t && t != cell_nil)
           {
             fputc (VALUE (CAR (t)), fd);
             t = CDR (t);
           }
+        if (write_p && TYPE (x) == TSTRING) fputc ('"', fd);
         break;
       }
     default:
@@ -120,28 +120,42 @@ SCM
 display_ (SCM x)
 {
   g_depth = 5;
-  return display_helper (x, 0, "", g_stdout);
+  return display_helper (x, 0, "", g_stdout, 0);
 }
 
 SCM
 display_error_ (SCM x)
 {
   g_depth = 5;
-  return display_helper (x, 0, "", STDERR);
+  return display_helper (x, 0, "", STDERR, 0);
 }
 
 SCM
 display_port_ (SCM x, SCM p)
 {
   assert (TYPE (p) == TNUMBER);
-  return fdisplay_ (x, VALUE (p));
+  return fdisplay_ (x, VALUE (p), 0);
+}
+
+SCM
+write_ (SCM x)
+{
+  g_depth = 5;
+  return display_helper (x, 0, "", g_stdout, 1);
+}
+
+SCM
+write_port_ (SCM x, SCM p)
+{
+  assert (TYPE (p) == TNUMBER);
+  return fdisplay_ (x, VALUE (p), 1);
 }
 
 SCM
-fdisplay_ (SCM x, int fd) ///((internal))
+fdisplay_ (SCM x, int fd, int write_p) ///((internal))
 {
   g_depth = 5;
-  return display_helper (x, 0, "", fd);
+  return display_helper (x, 0, "", fd, write_p);
 }
 
 SCM