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,6 +18,7 @@
 # define TO_DATA(x) ((data*)((char*)(x)-sizeof(int)))
 # define TO_SEXP(x) ((sexp*)((char*)(x)-2*sizeof(int)))
 
+# define UNBOXED(x) (((int) (x)) & 0x0001)
 # define UNBOX(x)   (((int) (x)) >> 1)
 # define BOX(x)     ((((int) (x)) << 1) | 0x0001)
 
@@ -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,12 +235,12 @@ 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, ...) {

src/Driver.ml

@@ -15,6 +15,7 @@ let parse infile =
                                   "for";
                                   "fun"; "local"; "return";
                                   "length";
+                                  "string";
                                   "case"; "of"; "esac"; "when"] s
        inherit Util.Lexers.skip [
 	 Matcher.Skip.whitespaces " \t\n";

src/Language.ml

@@ -37,6 +37,20 @@ module Value =
     let update_string s i x = String.init (String.length s) (fun j -> if j = i then x else s.[j])
     let update_array  a i x = List.init   (List.length a)   (fun j -> if j = i then x else List.nth a j)
                                           
+    let string_val v =
+      let buf      = Buffer.create 128 in
+      let append s = Buffer.add_string buf s in
+      let rec inner = function
+      | Int    n    -> append (string_of_int n)
+      | String s    -> append "\""; append s; append "\""
+      | Array  a    -> let n = List.length a in
+                       append "["; List.iteri (fun i a -> (if i < n-1 then append ", "); inner a) a; append "]"
+      | Sexp (t, a) -> let n = List.length a in
+                       append "`"; append t; append " ("; List.iteri (fun i a -> (if i < n-1 then append ", "); inner a) a; append ")"
+      in
+      inner v;
+      Buffer.contents buf
+                      
   end
        
 (* States *)
@@ -118,6 +132,7 @@ module Builtin =
                     )         
     | ".length"     -> (st, i, o, Some (Value.of_int (match List.hd args with Value.Array a -> List.length a | Value.String s -> String.length s)))
     | ".array"      -> (st, i, o, Some (Value.of_array args))
+    | ".stringval"  -> let [a] = args in (st, i, o, Some (Value.of_string @@ Value.string_val a))
     | "isArray"     -> let [a] = args in (st, i, o, Some (Value.of_int @@ match a with Value.Array  _ -> 1 | _ -> 0))
     | "isString"    -> let [a] = args in (st, i, o, Some (Value.of_int @@ match a with Value.String _ -> 1 | _ -> 0))                     
        
@@ -139,6 +154,7 @@ module Expr =
     (* binary operator    *) | Binop     of string * t * t
     (* element extraction *) | Elem      of t * t
     (* length             *) | Length    of t
+    (* string conversion  *) | StringVal of t
     (* function call      *) | Call      of string * t list with show
 
     (* Available binary operators:
@@ -189,6 +205,9 @@ module Expr =
       match expr with
       | Const  n    -> (st, i, o, Some (Value.of_int n))
       | String s    -> (st, i, o, Some (Value.of_string s))
+      | StringVal s ->
+         let (st, i, o, Some s) = eval env conf s in
+         (st, i, o, Some (Value.of_string @@ Value.string_val s))
       | Var    x -> (st, i, o, Some (State.eval st x))
       | Array xs ->
          let (st, i, o, vs) = eval_list env conf xs in
@@ -248,8 +267,8 @@ module Expr =
               |] 
 	     )
 	     primary);
-      primary: b:base is:(-"[" i:parse -"]" {`Elem i} | "." %"length" {`Len}) *
-                           {List.fold_left (fun b -> function `Elem i -> Elem (b, i) | `Len -> Length b) b is};
+      primary: b:base is:(-"[" i:parse -"]" {`Elem i} | -"." (%"length" {`Len} | %"string" {`Str})) *
+                           {List.fold_left (fun b -> function `Elem i -> Elem (b, i) | `Len -> Length b | `Str -> StringVal b) b is};
       base:
         n:DECIMAL                                         {Const n}
       | s:STRING                                          {String (String.sub s 1 (String.length s - 2))}

src/SM.ml

@@ -183,6 +183,7 @@ let compile (defs, p) =
   | Expr.Sexp (t, xs)     -> List.flatten (List.map expr xs) @ [SEXP (t, List.length xs)]
   | Expr.Elem (a, i)      -> expr a @ expr i @ [CALL (".elem", 2, false)]
   | Expr.Length e         -> expr e @ [CALL (".length", 1, false)]
+  | Expr.StringVal e      -> expr e @ [CALL (".stringval", 1, false)]
   in
   let rec compile_stmt l env = function  
   | Stmt.Assign (x, [], e)  -> env, false, expr e @ [ST x]