StringVal as a builtin .string

runtime/runtime.c

@@ -6,6 +6,7 @@
 # include <string.h>
 # include <stdarg.h>
 # include <alloca.h>
+# include <stdlib.h>
 
 # define STRING_TAG 0x00000000
 # define ARRAY_TAG  0x01000000
@@ -17,8 +18,9 @@
 # define TO_DATA(x) ((data*)((char*)(x)-sizeof(int)))
 # define TO_SEXP(x) ((sexp*)((char*)(x)-2*sizeof(int)))
 
-# define UNBOX(x) (((int) (x)) >> 1)
-# define BOX(x) ((((int) (x)) << 1) | 0x0001)
+# define UNBOXED(x) (((int) (x)) & 0x0001)
+# define UNBOX(x)   (((int) (x)) >> 1)
+# define BOX(x)     ((((int) (x)) << 1) | 0x0001)
 
 typedef struct {
   int tag; 
@@ -35,6 +37,104 @@ extern int Blength (void *p) {
   return BOX(LEN(a->tag));
 }
 
+char* de_hash (int n) {
+  static char *chars = "_abcdefghijklmnopqrstuvwxyzABCDEFGHIJKLMNJPQRSTUVWXYZ";
+  static char buf[6];
+  char *p = &buf[5];
+
+  /*printf ("tag: %d\n", n);*/
+  
+  *p-- = 0;
+
+  while (n != 0) {
+    /*printf ("char: %c\n", chars [n & 0x003F]);*/
+    *p-- = chars [n & 0x003F];
+    n = n >> 6;
+  }
+  
+  return ++p;
+}
+
+typedef struct {
+  char *contents;
+  int ptr;
+  int len;
+} StringBuf;
+
+static StringBuf stringBuf;
+
+# define STRINGBUF_INIT 128
+
+static void createStringBuf () {
+  stringBuf.contents = (char*) malloc (STRINGBUF_INIT);
+  stringBuf.ptr      = 0;
+  stringBuf.len      = STRINGBUF_INIT;
+}
+
+static void deleteStringBuf () {
+  free (stringBuf.contents);
+}
+
+static void extendStringBuf () {
+  int len = stringBuf.len << 1;
+
+  stringBuf.contents = (char*) realloc (stringBuf.contents, len);
+  stringBuf.len      = len;
+}
+
+static void printStringBuf (char *fmt, ...) {
+  va_list args;
+  int     written, rest;
+  char   *buf = &stringBuf.contents[stringBuf.ptr];
+
+ again:
+  va_start (args, fmt);
+  rest    = stringBuf.len - stringBuf.ptr;
+  written = vsnprintf (buf, rest, fmt, args);
+  
+  if (written >= rest) {
+    extendStringBuf ();
+    goto again;
+  }
+
+  stringBuf.ptr += written;
+}
+
+static void printValue (void *p) {
+  if (UNBOXED(p)) printStringBuf ("%d", UNBOX(p));
+  else {
+    data *a = TO_DATA(p);
+
+    switch (TAG(a->tag)) {      
+    case STRING_TAG:
+      printStringBuf ("\"%s\"", a->contents);
+      break;
+      
+    case ARRAY_TAG:
+      printStringBuf ("[");
+      for (int i = 0; i < LEN(a->tag); i++) {
+        printValue ((void*)((int*) a->contents)[i]);
+	if (i != LEN(a->tag) - 1) printStringBuf (", ");
+      }
+      printStringBuf ("]");
+      break;
+      
+    case SEXP_TAG:
+      printStringBuf ("`%s", de_hash (TO_SEXP(p)->tag));
+      printStringBuf (" (");
+      for (int i = 0; i < LEN(a->tag); i++) {
+        printValue ((void*)((int*) a->contents)[i]);
+	if (i != LEN(a->tag) - 1) printStringBuf (", ");
+      }
+      printStringBuf (")");
+      break;
+      
+    default:
+      printStringBuf ("*** invalid tag: %x ***", TAG(a->tag));
+    }
+  }
+}
+
 extern void* Belem (void *p, int i) {
   data *a = TO_DATA(p);
   i = UNBOX(i);
@@ -58,6 +158,19 @@ extern void* Bstring (void *p) {
   return r->contents;
 }
 
+extern void* Bstringval (void *p) {
+  void *s;
+  
+  createStringBuf ();
+  printValue (p);
+
+  s = Bstring (stringBuf.contents);
+  
+  deleteStringBuf ();
+
+  return s;
+}
+
 extern void* Barray (int n, ...) {
   va_list args;
   int i;
@@ -104,7 +217,7 @@ extern void* Bsexp (int n, ...) {
 
 extern int Btag (void *d, int t) {
   data *r = TO_DATA(d);
-  return ((TAG(r->tag) == SEXP_TAG && TO_SEXP(d)->tag == t) << 1) | 1;
+  return BOX(TAG(r->tag) == SEXP_TAG && TO_SEXP(d)->tag == t);
 }
 		 
 extern void Bsta (int n, int v, void *s, ...) {
@@ -122,20 +235,20 @@ extern void Bsta (int n, int v, void *s, ...) {
   k = UNBOX(va_arg(args, int));
   a = TO_DATA(s);
   
-  if (TAG(a->tag) == STRING_TAG)((char*) s)[k] = (char) (v >> 1);
+  if (TAG(a->tag) == STRING_TAG)((char*) s)[k] = (char) UNBOX(v);
   else ((int*) s)[k] = v;
 }
 
 extern int Lraw (int x) {
-  return x >> 1;
+  return UNBOX(x);
 }
 
 extern void Lprintf (char *s, ...) {
   va_list args;
 
   va_start (args, s);
-  vprintf (s, args); // vprintf (char *, va_list) <-> printf (char *, ...) 
-  va_end (args);
+  vprintf  (s, args); // vprintf (char *, va_list) <-> printf (char *, ...) 
+  va_end   (args);
 }
 
 extern void* Lstrcat (void *a, void *b) {
@@ -157,7 +270,7 @@ extern void Lfprintf (FILE *f, char *s, ...) {
 
   va_start (args, s);
   vfprintf (f, s, args);
-  va_end (args);
+  va_end   (args);
 }
 
 extern FILE* Lfopen (char *f, char *m) {