Implement Scheme printer procedures in C

c/builtins.c

@@ -485,6 +485,7 @@ MATH_FUNC_1ARG(atan)
 extern void stringfuncs_init(void);
 extern void table_init(void);
 extern void iostream_init(void);
+extern void print_init(void);
 
 static struct builtinspec builtin_info[] = {
     { "environment", fl_global_env },
@@ -541,4 +542,5 @@ void builtins_init(void)
     stringfuncs_init();
     table_init();
     iostream_init();
+    print_init();
 }

c/flisp.c

@@ -2562,7 +2562,6 @@ static void lisp_init(size_t initial_heapsize)
     curheap = fromspace;
     lim = curheap + heapsize - sizeof(struct cons);
     consflags = bitvector_new(heapsize / sizeof(struct cons), 1);
-    htable_new(&pr.cycle_traversed, 32);
     comparehash_init();
     N_STACK = 262144;
     Stack = malloc(N_STACK * sizeof(value_t));
@@ -2706,7 +2705,7 @@ int fl_load_boot_image(void)
         FL_CATCH
         {
             ios_puts("fatal error during bootstrap:\n", ios_stderr);
-            fl_print(ios_stderr, fl_lasterror);
+            write_defaults_indent(ios_stderr, fl_lasterror);
             ios_putc('\n', ios_stderr);
             return 1;
         }

c/flmain.c

@@ -25,6 +25,8 @@
 
 #include "flisp.h"
 
+extern void write_defaults_indent(struct ios *f, value_t v);
+
 static value_t argv_list(int argc, char *argv[])
 {
     int i;
@@ -54,7 +56,7 @@ int main(int argc, char *argv[])
         FL_CATCH_EXTERN
         {
             ios_puts("fatal error:\n", ios_stderr);
-            fl_print(ios_stderr, fl_lasterror);
+            write_defaults_indent(ios_stderr, fl_lasterror);
             ios_putc('\n', ios_stderr);
             return 1;
         }

c/iostream.c

@@ -30,7 +30,7 @@
 #include "argcount.h"
 
 static value_t iostreamsym, rdsym, wrsym, apsym, crsym, truncsym;
-static value_t instrsym, outstrsym;
+value_t instrsym, outstrsym;
 struct fltype *iostreamtype;
 
 void print_iostream(value_t v, struct ios *f)
@@ -302,20 +302,6 @@ value_t fl_iopos(value_t *args, uint32_t nargs)
     return size_wrap((size_t)res);
 }
 
-value_t fl_write(value_t *args, uint32_t nargs)
-{
-    struct ios *s;
-
-    if (nargs < 1 || nargs > 2)
-        argcount("write", nargs, 1);
-    if (nargs == 2)
-        s = toiostream(args[1], "write");
-    else
-        s = toiostream(symbol_value(outstrsym), "write");
-    fl_print(s, args[0]);
-    return args[0];
-}
-
 value_t fl_ioread(value_t *args, uint32_t nargs)
 {
     struct fltype *ft;
@@ -530,7 +516,6 @@ static struct builtinspec iostreamfunc_info[] = {
     { "buffer", fl_buffer },
     { "read", fl_read },
     { "read-u8", builtin_read_u8 },
-    { "write", fl_write },
     { "io.flush", fl_ioflush },
     { "io.close", fl_ioclose },
     { "io.eof?", fl_ioeof },

c/print.h

@@ -1,7 +1,11 @@
 extern void *memrchr(const void *s, int c, size_t n);
+extern value_t instrsym;
+extern value_t outstrsym;
 
 struct printer_options {
     int display;      // Use `display` repr instead of `write` repr
+    int newline;      // Write a newline at the end.
+    int shared;       // 0=no cycle detection, 1=minimal cycles, 2=max cycles
     int indent;       // Write indented lines instead of one long line.
     int width;        // maximum line length when indenting, ignored when not
     fixnum_t length;  // truncate lists after N items and write "..."
@@ -391,6 +395,7 @@ void fl_print_child(struct ios *f, value_t v)
 {
     char *name;
 
+    // fprintf(stderr, "fl_print_child\n");
     if (pr.opts.level >= 0 && pr.level >= pr.opts.level &&
         (iscons(v) || isvector(v) || isclosure(v))) {
         outc('#', f);
@@ -862,14 +867,29 @@ void print_with_options(struct ios *f, value_t v,
                         struct printer_options *opts)
 {
     memcpy(&pr.opts, opts, sizeof(pr.opts));
+
+    // TODO
+    if (pr.opts.width < 80)
+        pr.opts.width = 80;
+
+    // TODO
+    pr.opts.level = -1;
+    pr.opts.length = -1;
+
     pr.level = 0;
     pr.cycle_labels = 0;
-    if (!pr.opts.display)
+    if (pr.opts.shared)
         print_traverse(v);
     pr.line = pr.column = 0;
 
     fl_print_child(f, v);
 
+    if (pr.opts.newline) {
+        ios_putc('\n', f);
+        pr.line++;
+        pr.column = 0;
+    }
+
     if (pr.opts.level >= 0 || pr.opts.length >= 0) {
         memset(consflags, 0,
                4 * bitvector_nwords(heapsize / sizeof(struct cons)));
@@ -881,6 +901,30 @@ void print_with_options(struct ios *f, value_t v,
     }
 }
 
+void display_defaults(struct ios *f, value_t v)
+{
+    struct printer_options opts;
+
+    memset(&opts, 0, sizeof(opts));
+    opts.display = 1;
+    opts.shared = 1;
+    opts.length = -1;
+    opts.level = -1;
+    print_with_options(f, v, &opts);
+}
+
+void write_defaults_indent(struct ios *f, value_t v)
+{
+    struct printer_options opts;
+
+    memset(&opts, 0, sizeof(opts));
+    opts.shared = 1;
+    opts.indent = 1;
+    opts.length = -1;
+    opts.level = -1;
+    print_with_options(f, v, &opts);
+}
+
 void fl_print(struct ios *f, value_t v)
 {
     struct printer_options opts;
@@ -899,9 +943,7 @@ void fl_print(struct ios *f, value_t v)
     if (isfixnum(pl))
         opts.width = numval(pl);
     else
-        opts.width = 80;
-    if (opts.width < 20)
-        opts.width = 20;
+        opts.width = -1;
 
     // *print-length*
     pl = symbol_value(printlengthsym);
@@ -919,3 +961,117 @@ void fl_print(struct ios *f, value_t v)
 
     print_with_options(f, v, &opts);
 }
+
+static value_t writelike(struct printer_options *opts, const char *proc_name,
+                         value_t *args, uint32_t nargs)
+{
+    value_t val;
+    struct ios *ios;
+
+    if (nargs < 1 || nargs > 2)
+        argcount(proc_name, nargs, 1);
+    val = args[0];
+    if (nargs == 2)
+        ios = fl_toiostream(args[1], proc_name);
+    else
+        ios = fl_toiostream(symbol_value(outstrsym), proc_name);
+    print_with_options(ios, val, opts);
+    return val;
+}
+
+static value_t builtin_display(value_t *args, uint32_t nargs)
+{
+    struct printer_options opts;
+
+    memset(&opts, 0, sizeof(opts));
+    opts.display = 1;
+    opts.shared = 1;
+    return writelike(&opts, "display", args, nargs);
+}
+
+static value_t builtin_displayln(value_t *args, uint32_t nargs)
+{
+    struct printer_options opts;
+
+    memset(&opts, 0, sizeof(opts));
+    opts.display = 1;
+    opts.shared = 1;
+    opts.newline = 1;
+    return writelike(&opts, "displayln", args, nargs);
+}
+
+static value_t builtin_write(value_t *args, uint32_t nargs)
+{
+    struct printer_options opts;
+
+    memset(&opts, 0, sizeof(opts));
+    opts.shared = 1;
+    opts.display = (symbol_value(printreadablysym) == FL_F);
+    return writelike(&opts, "write", args, nargs);
+}
+
+static value_t builtin_writeln(value_t *args, uint32_t nargs)
+{
+    struct printer_options opts;
+
+    memset(&opts, 0, sizeof(opts));
+    opts.shared = 1;
+    opts.newline = 1;
+    return writelike(&opts, "writeln", args, nargs);
+}
+
+static value_t builtin_write_shared(value_t *args, uint32_t nargs)
+{
+    struct printer_options opts;
+
+    memset(&opts, 0, sizeof(opts));
+    opts.shared = 2;
+    return writelike(&opts, "write-shared", args, nargs);
+}
+
+static value_t builtin_write_simple(value_t *args, uint32_t nargs)
+{
+    struct printer_options opts;
+
+    memset(&opts, 0, sizeof(opts));
+    return writelike(&opts, "write-simple", args, nargs);
+}
+
+static value_t builtin_newline(value_t *args, uint32_t nargs)
+{
+    struct ios *ios;
+
+    if (nargs > 1)
+        argcount("newline", nargs, 1);
+    if (nargs == 1)
+        ios = fl_toiostream(args[0], "newline");
+    else
+        ios = fl_toiostream(symbol_value(outstrsym), "newline");
+    ios_putc('\n', ios);
+    return FL_T;
+}
+
+static struct builtinspec printfunc_info[] = {
+    { "display", builtin_display },
+    { "displayln", builtin_displayln },
+    { "write", builtin_write },
+    { "writeln", builtin_writeln },
+    { "write-shared", builtin_write_shared },
+    { "write-simple", builtin_write_simple },
+    { "newline", builtin_newline },
+
+    { "xdisplay", builtin_display },
+    { "xdisplayln", builtin_displayln },
+    { "xwrite", builtin_write },
+    { "xwriteln", builtin_writeln },
+    { "xwrite-shared", builtin_write_shared },
+    { "xwrite-simple", builtin_write_simple },
+    { "xnewline", builtin_newline },
+    { NULL, NULL }
+};
+
+void print_init(void)
+{
+    htable_new(&pr.cycle_traversed, 32);
+    assign_global_builtins(printfunc_info);
+}

c/string.c

@@ -36,6 +36,8 @@
 
 #include "argcount.h"
 
+extern void display_defaults(struct ios *f, value_t v);
+
 value_t fl_stringp(value_t *args, uint32_t nargs)
 {
     argcount("string?", nargs, 1);
@@ -164,20 +166,14 @@ value_t fl_string(value_t *args, uint32_t nargs)
     value_t arg, buf;
     struct ios *s;
     uint32_t i;
-    value_t oldpr, oldpp, outp;
+    value_t outp;
 
     if (nargs == 1 && fl_isstring(args[0]))
         return args[0];
     buf = fl_buffer(NULL, 0);
     fl_gc_handle(&buf);
     s = value2c(struct ios *, buf);
-    oldpr = symbol_value(printreadablysym);
-    oldpp = symbol_value(printprettysym);
-    set(printreadablysym, FL_F);
-    set(printprettysym, FL_F);
-    FOR_ARGS(i, 0, arg, args) { fl_print(s, args[i]); }
-    set(printreadablysym, oldpr);
-    set(printprettysym, oldpp);
+    FOR_ARGS(i, 0, arg, args) { display_defaults(s, args[i]); }
     outp = stream_to_string(&buf);
     fl_free_gc_handles(1);
     return outp;

scheme-tests/unittest.scm

@@ -297,10 +297,10 @@
     (io.tostring! b)))
 
 (let ((c #\a))
-  (assert (equal? (with-output-to-string #f (lambda () (print (list c c))))
+  (assert (equal? (with-output-to-string #f (lambda () (xwrite (list c c))))
                   "(#\\a #\\a)")))
 
 (assert-fail (eval '(set! (car (cons 1 2)) 3)))
 
-(princ "all tests pass\n")
+(xdisplay "all tests pass\n")
 #t