Opam/install

Makefile

@@ -1,3 +1,6 @@
+EXECUTABLE = src/rc.opt
+INSTALL ?= install -v
+MKDIR ?= mkdir
 SHELL := /bin/bash
 
 .PHONY: all regression
@@ -7,7 +10,17 @@ all:
 	pushd runtime && make && popd
 	pushd stdlib && make && popd
 
-#install: ;
+STD_FILES=$(shell ls stdlib/*.[oi] stdlib/*.expr runtime/runtime.a runtime/Std.i)
+#$(info $(STD_FILES))
+
+install: all
+	$(INSTALL) $(EXECUTABLE) `opam var bin`
+	$(MKDIR) -p `opam var share`/Lama
+	$(INSTALL) $(STD_FILES) `opam var share`/Lama/
+
+uninstall:
+	$(RM) -r `opam var share`/Lama
+	$(RM) `opam var bin`/$(EXECUTABLE)
 
 regression:
 	pushd regression && make clean check && popd

opam

@@ -20,6 +20,7 @@ build: [
   [make "-f" "Makefile"]
   [make "-f" "Makefile" "regression"] {with-test}
 ]
+install: [make "install"]
     
 #remove: ["ocamlfind" "remove" "compiler-workout"]
 #flags: light-uninstall

regression/orig/test103.log

@@ -0,0 +1,3 @@
+> > > 0
+0
+5

regression/test103.expr

@@ -0,0 +1,4 @@
+repeat
+  local n = read ();
+  write (n)
+until n > 0

regression/test103.input

@@ -0,0 +1,3 @@
+0
+0
+5

runtime/runtime.c

@@ -178,7 +178,7 @@ void* Ls__Infix_58 (void *p, void *q) {
 
   push_extra_root(&p);
   push_extra_root(&q);
-  res = Bsexp (3, p, q, 848787);
+  res = Bsexp (BOX(3), p, q, 848787);
   pop_extra_root(&q);
   pop_extra_root(&p);
 
@@ -779,6 +779,8 @@ extern void* LmakeArray (int length) {
 
   r->tag = ARRAY_TAG | (n << 3);
 
+  memset (r->contents, 0, n * sizeof(int));
+  
   __post_gc ();
 
   return r->contents;
@@ -869,13 +871,13 @@ extern void* Bstringval (void *p) {
   return s;
 }
 
-extern void* Bclosure (int n, void *entry, ...) {
+extern void* Bclosure (int bn, void *entry, ...) {
-  va_list args = (va_list) BOX (NULL);
+  va_list args; 
-  int     i    = BOX(0),
+  int     i, ai;
-          ai   = BOX(0);
   register int * ebp asm ("ebp");
-  size_t * argss = NULL;
+  size_t  *argss;
-  data    *r   = (data*) BOX (NULL);
+  data    *r; 
+  int     n = UNBOX(bn);
   
   __pre_gc ();
 #ifdef DEBUG_PRINT
@@ -917,11 +919,11 @@ extern void* Bclosure (int n, void *entry, ...) {
   return r->contents;
 }
 
-extern void* Barray (int n, ...) {
+extern void* Barray (int bn, ...) {
-  va_list args = (va_list) BOX (NULL);
+  va_list args; 
-  int     i    = BOX(0),
+  int     i, ai; 
-          ai   = BOX(0);
+  data    *r; 
-  data    *r   = (data*) BOX (NULL);
+  int     n = UNBOX(bn);
     
   __pre_gc ();
   
@@ -949,13 +951,14 @@ extern void* Barray (int n, ...) {
   return r->contents;
 }
 
-extern void* Bsexp (int n, ...) {
+extern void* Bsexp (int bn, ...) {
-  va_list args = (va_list) BOX (NULL);
+  va_list args; 
-  int     i    = BOX(0);
+  int     i;    
-  int     ai   = BOX(0);
+  int     ai;  
-  size_t * p   = NULL;
+  size_t *p;  
-  sexp   *r    = (sexp*) BOX (NULL);
+  sexp   *r;  
-  data   *d    = (data *) BOX (NULL);
+  data   *d;  
+  int n = UNBOX(bn);
 
   __pre_gc () ;
   
@@ -995,27 +998,27 @@ extern void* Bsexp (int n, ...) {
 }
 
 extern int Btag (void *d, int t, int n) {
-  data *r = (data *) BOX (NULL);
+  data *r; 
   
   if (UNBOXED(d)) return BOX(0);
   else {
     r = TO_DATA(d);
 #ifndef DEBUG_PRINT
-    return BOX(TAG(r->tag) == SEXP_TAG && TO_SEXP(d)->tag == t && LEN(r->tag) == n);
+    return BOX(TAG(r->tag) == SEXP_TAG && TO_SEXP(d)->tag == UNBOX(t) && LEN(r->tag) == UNBOX(n));
 #else
     return BOX(TAG(r->tag) == SEXP_TAG &&
-	     GET_SEXP_TAG(TO_SEXP(d)->tag) == t && LEN(r->tag) == n);
+               GET_SEXP_TAG(TO_SEXP(d)->tag) == UNBOX(t) && LEN(r->tag) == UNBOX(n));
 #endif
   }
 }
 
 extern int Barray_patt (void *d, int n) {
-  data *r = BOX(NULL);
+  data *r; 
   
   if (UNBOXED(d)) return BOX(0);
   else {
     r = TO_DATA(d);
-    return BOX(TAG(r->tag) == ARRAY_TAG && LEN(r->tag) == n);
+    return BOX(TAG(r->tag) == ARRAY_TAG && LEN(r->tag) == UNBOX(n));
   }
 }
 

src/Driver.ml

@@ -44,7 +44,7 @@ class options args =
   object (self)
     val i      = ref 1
     val infile = ref (None : string option)
-    val paths  = ref [try Sys.getenv "RC_RUNTIME" with _ -> "../runtime"]
+    val paths  = ref [X86.get_std_path ()]
     val mode   = ref (`Default : [`Default | `Eval | `SM | `Compile ])
     (* Workaround until Ostap starts to memoize properly *)
     val const  = ref false

src/Language.ml

@@ -83,7 +83,7 @@ module Value =
 
     let to_int = function
     | Int n -> n
-    | _ -> failwith "int value expected"
+    | x -> failwith (Printf.sprintf "int value expected (%s)\n" (show(t) (fun _ -> "<not supported>") (fun _ -> "<not supported>") x))
 
     let to_string = function
     | String s -> s
@@ -636,23 +636,24 @@ module Expr =
     ostap (
       parse[def][infix][atr]: h:basic[def][infix][Void] -";" t:parse[def][infix][atr] {Seq (h, t)}
                               | basic[def][infix][atr];
-      scope[def][infix][atr][e]: <(d, infix')> : def[infix] expr:e[infix'][atr] {Scope (d, expr)};
+      scope[def][infix][atr][e]: <(d, infix')> : def[infix] expr:e[infix'][atr] {Scope (d, expr)} |
+                                 <(d, infix')> : def[infix] => {d <> []} => {Scope (d, materialize atr Skip)}; 
 
       basic[def][infix][atr]: !(expr (fun x -> x) (Array.map (fun (a, (atr, l)) -> a, (atr, List.map (fun (s, _, f) -> ostap (- $(s)), f) l)) infix) (primary def infix) atr);
 
       primary[def][infix][atr]:
-        s:(s:"-"? {match s with None -> fun x -> x | _ -> fun x -> Binop ("-", Const 0, x)})
+          s:(s:"-"? {match s with None -> fun x -> x | _ -> fun x -> Binop ("-", Const 0, x)})  
           b:base[def][infix][Val] is:(  "." f:LIDENT args:(-"(" !(Util.list)[parse def infix Val] -")")? {`Post (f, args)}
                                       | "." %"length"                                                    {`Len}
                                       | "." %"string"                                                    {`Str}
                                       | "[" i:parse[def][infix][Val] "]"                                 {`Elem i}                                    
                                       | "(" args:!(Util.list0)[parse def infix Val] ")"                  {`Call args}  
-                                     )+
+          )+
         => {match (List.hd (List.rev is)), atr with
             | `Elem i, Reff -> true            
             |  _,      Reff -> false
             |  _,      _    -> true} =>
-         {
+        {
           let is =
             let rec fix_is = function
             | [ ]                                                 -> []
@@ -687,7 +688,7 @@ module Expr =
           in
           ignore atr (s res)
         }
-        | base[def][infix][atr];
+      | base[def][infix][atr];
       base[def][infix][atr]:
         l:$ n:DECIMAL                              => {notRef atr} :: (not_a_reference l) => {ignore atr (Const n)}
       | l:$ s:STRING                               => {notRef atr} :: (not_a_reference l) => {ignore atr (String s)}
@@ -733,7 +734,22 @@ module Expr =
       | %"for" i:parse[def][infix][Void] "," c:parse[def][infix][Val] "," s:parse[def][infix][Void] %"do" b:scope[def][infix][Void][parse def] => {isVoid atr} => %"od"
                                                                      {materialize atr (Seq (i, While (c, Seq (b, s))))}
 
-      | %"repeat" s:scope[def][infix][Void][parse def] %"until" e:basic[def][infix][Val] => {isVoid atr} => {materialize atr (Repeat (s, e))}
+      | %"repeat" s:scope[def][infix][Void][parse def] %"until" e:basic[def][infix][Val] => {isVoid atr} => {
+          materialize atr @@
+            match s with
+            | Scope (defs, s) ->
+               let defs, s =
+                 List.fold_right (fun (name, def) (defs, s) ->
+                     match def with
+                     | (`Local, `Variable (Some expr)) ->
+                        (name, (`Local, `Variable None)) :: defs, Seq (Ignore (Assign (Ref name, expr)), s)
+                     | def -> (name, def) :: defs, s)
+                   defs
+                   ([], s)
+               in
+               Scope (defs, Repeat (s, e))
+            | _  -> Repeat (s, e)
+      }
       | %"return" e:basic[def][infix][Val]? => {isVoid atr} => {Return e}
 
       | %"case" l:$ e:parse[def][infix][Val] %"of" bs:!(Util.listBy)[ostap ("|")][ostap (!(Pattern.parse) -"->" scope[def][infix][atr][parse def])] %"esac"
@@ -941,7 +957,7 @@ module Definition =
       };
       parse[infix][expr][expr'][def]:
         m:(%"local" {`Local} | %"public" e:(%"external")? {match e with None -> `Public | Some _ -> `PublicExtern} | %"external" {`Extern})
-        locs:!(Util.list (local_var m infix expr' def)) ";" {locs, infix}
+          locs:!(Util.list (local_var m infix expr' def)) next:";" {locs, infix}
       | - <(m, orig_name, name, infix', flag)> : head[infix] -"(" -args:!(Util.list0 arg) -")"
           (l:$ "{" body:expr[def][infix'][Expr.Weak] "}" {
             if flag && List.length args != 2 then report_error ~loc:(Some l#coord) "infix operator should accept two arguments";
@@ -1084,7 +1100,7 @@ ostap (
   definitions[infix]:
     <(def, infix')> : !(Definition.parse infix (fun def infix atr -> Expr.scope def infix atr (Expr.parse def))
                                                (fun def infix atr -> Expr.basic def infix atr)
-                          definitions) <(defs, infix'')> : definitions[infix'] {
+                                               definitions) <(defs, infix'')> : definitions[infix'] {
       def @ defs, infix''
      }
   | empty {[], infix}

src/X86.ml

@@ -129,6 +129,7 @@ let compile cmd env imports code =
   | ">"  -> "g"
   | _    -> failwith "unknown operator"
   in
+  let box n = (n lsl 1) lor 1 in 
   let rec compile' env scode =
     let on_stack = function S _ -> true | _ -> false in
     let mov x s = if on_stack x && on_stack s then [Mov (x, eax); Mov (eax, s)] else [Mov (x, s)]  in
@@ -172,8 +173,8 @@ let compile cmd env imports code =
         let env, pushs = push_args env [] n in
         let pushs      =
           match f with
-          | "Barray" -> List.rev @@ (Push (L n)) :: pushs
+          | "Barray" -> List.rev @@ (Push (L (box n))) :: pushs
-          | "Bsexp"  -> List.rev @@ (Push (L n)) :: pushs
+          | "Bsexp"  -> List.rev @@ (Push (L (box n))) :: pushs
           | "Bsta"   -> pushs
           | _        -> List.rev pushs
         in
@@ -203,7 +204,7 @@ let compile cmd env imports code =
               pushr @
               push_closure @
               [Push (M ("$" ^ name));
-              Push (L closure_len);
+              Push (L (box closure_len));
               Call "Bclosure";
               Binop ("+", L (word_size * (closure_len + 2)), esp); 
               Mov (eax, s)] @
@@ -211,7 +212,7 @@ let compile cmd env imports code =
              
   	  | CONST n ->
              let s, env' = env#allocate in
-	     (env', [Mov (L ((n lsl 1) lor 1), s)])
+	     (env', [Mov (L (box n), s)])
 
           | STRING s ->
              let s, env = env#string s in
@@ -431,12 +432,12 @@ let compile cmd env imports code =
              let s1, env = env#allocate in
              let s2, env = env#allocate in
              let env, code = call env ".tag" 3 in
-             env, [Mov (L env#hash t, s1); Mov (L n, s2)] @ code
+             env, [Mov (L (box (env#hash t)), s1); Mov (L (box n), s2)] @ code
 
           | ARRAY n ->
              let s, env    = env#allocate in
              let env, code = call env ".array_patt" 2 in
-             env, [Mov (L n, s)] @ code
+             env, [Mov (L (box n), s)] @ code
 
           | PATT StrCmp -> call env ".string_patt" 2
 
@@ -454,7 +455,7 @@ let compile cmd env imports code =
           | FAIL ((line, col), value) ->                       
              let v, env = if value then env#peek, env else env#pop in
              let s, env = env#string cmd#get_infile in
-             env, [Push (L col); Push (L line); Push (M ("$" ^ s)); Push v; Call "Bmatch_failure"; Binop  ("+", L (3 * word_size), esp)]
+             env, [Push (L (box col)); Push (L (box line)); Push (M ("$" ^ s)); Push v; Call "Bmatch_failure"; Binop  ("+", L (3 * word_size), esp)]
              
           | i ->
              invalid_arg (Printf.sprintf "invalid SM insn: %s\n" (GT.show(insn) i))
@@ -688,6 +689,11 @@ let genasm cmd prog =
     (globals @ data @ [Meta "\t.text"] @ code);
   Buffer.contents asm
 
+let get_std_path () =
+  match Sys.getenv_opt "RC_RUNTIME" with
+  | Some s -> s
+  | None   -> "../runtime"
+                                      
 (* Builds a program: generates the assembler file and compiles it with the gcc toolchain *)
 let build cmd prog =
   let find_objects imports paths =
@@ -710,7 +716,7 @@ let build cmd prog =
   in
   cmd#dump_file "s" (genasm cmd prog);
   cmd#dump_file "i" (Interface.gen prog);
-  let inc  = try Sys.getenv "RC_RUNTIME" with _ -> "../runtime" in
+  let inc  = get_std_path () in
   match cmd#get_mode with
   | `Default ->
      let objs = find_objects (fst @@ fst prog) cmd#get_include_paths in