diff --git a/runtime/runtime.c b/runtime/runtime.c index 8fb1e1b49..c766c4465 100644 --- a/runtime/runtime.c +++ b/runtime/runtime.c @@ -6,6 +6,7 @@ # include # include # include +# include # 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) { diff --git a/src/Driver.ml b/src/Driver.ml index 71d0e2df7..773d96daa 100644 --- a/src/Driver.ml +++ b/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"; diff --git a/src/Language.ml b/src/Language.ml index c9c84aaf8..a0547f7b6 100644 --- a/src/Language.ml +++ b/src/Language.ml @@ -36,7 +36,21 @@ 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 *) @@ -116,10 +130,11 @@ module Builtin = | Value.Sexp (_, a) -> List.nth a i ) ) - | ".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)) - | "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)) + | ".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)) end @@ -131,15 +146,16 @@ module Expr = notation, it came from GT. *) @type t = - (* integer constant *) | Const of int - (* array *) | Array of t list - (* string *) | String of string - (* S-expressions *) | Sexp of string * t list - (* variable *) | Var of string - (* binary operator *) | Binop of string * t * t - (* element extraction *) | Elem of t * t - (* length *) | Length of t - (* function call *) | Call of string * t list with show + (* integer constant *) | Const of int + (* array *) | Array of t list + (* string *) | String of string + (* S-expressions *) | Sexp of string * t list + (* variable *) | Var of string + (* 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: !! --- disjunction @@ -187,8 +203,11 @@ module Expr = let rec eval env ((st, i, o, r) as conf) expr = match expr with - | Const n -> (st, i, o, Some (Value.of_int n)) - | String s -> (st, i, o, Some (Value.of_string s)) + | 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))} diff --git a/src/SM.ml b/src/SM.ml index 11894b921..62c394a35 100644 --- a/src/SM.ml +++ b/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]