Starting to develop FCF in SM

src/Driver.ml

@@ -56,7 +56,7 @@ let main =
 	 let output =
 	   if interpret
 	   then Language.eval prog input
-	   else [] (* SM.run (SM.compile prog) input *) (* TODO! *)
+	   else SM.run (SM.compile prog) input
 	 in
 	 List.iter (fun i -> Printf.printf "%d\n" i) output
     | `Fail er -> Printf.eprintf "Error: %s\n" er

src/Language.ml

@@ -134,12 +134,6 @@ module State =
     (* empty state *)
     let empty = I
 
-    (* initialize empty state *)
-    let init st vars list =
-      match st with
-      | I -> G (vars @ Builtin.names, List.fold_left (fun s (name, value) -> bind name value s) (from_list list) (Builtin.bindings ()))
-      | _ -> invalid_arg "state already initialzied"
-    
     (* Scope operation: checks if a name is in a scope *)
     let in_scope x s = List.exists (fun (y, _) -> y = x) s
 
@@ -195,10 +189,13 @@ module State =
       | L (_, _, e) -> enter e xs
 
     (* Push a new local scope *)
-    let push st s xs = L (xs, s, st)
+    let push st s xs =
+      match st with
+      | I -> G (xs @ Builtin.names, List.fold_left (fun s (name, value) -> bind name value s) s (Builtin.bindings ()))
+      | _ -> L (xs, s, st)
 
     (* Drop a local scope *)
-    let drop (L (_, _, e)) = e
+    let drop = function L (_, _, e) -> e | G _ -> I
 
     (* Observe a variable in a state and print it to stderr *)
     let observe st x =
@@ -296,7 +293,7 @@ module Expr =
     (* return statement           *) | Return    of t option
     (* ignore a value             *) | Ignore    of t
     (* unit value                 *) | Unit
-    (* entering the scope         *) | Scope     of [`Global | `Local] * (string * [`Fun of string list * t | `Variable of t option]) list * t
+    (* entering the scope         *) | Scope     of (string * [`Fun of string list * t | `Variable of t option]) list * t
     (* lambda expression          *) | Lambda    of string list * t
     (* leave a scope              *) | Leave
     (* intrinsic (for evaluation) *) | Intrinsic of (t config -> t config)
@@ -383,7 +380,7 @@ module Expr =
       match expr with
       | Lambda (args, body) ->
          eval (st, i, o, Value.Closure (args, body, st) ::vs) Skip k        
-      | Scope (kind, defs, body) ->
+      | Scope (defs, body) ->
          let vars, body, bnds =
            List.fold_left
              (fun (vs, bd, bnd) -> function
@@ -393,13 +390,7 @@ module Expr =
              ([], body, [])
              (List.rev defs)
          in
-         eval
+         eval (State.push st (State.from_list bnds) vars, i, o, vs) k (Seq (body, Leave))
-           ((match kind with
-             | `Local  -> State.push st (State.from_list bnds) vars
-             | `Global -> State.init st vars bnds
-            ), i, o, vs)
-           k
-           (match kind with `Global -> body | `Local -> Seq (body, Leave))
       | Unit ->
          eval (st, i, o, Value.Empty :: vs) Skip k
       | Ignore s ->
@@ -595,7 +586,7 @@ 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[kind][def][infix][atr][e]: <(d, infix')> : def[infix] expr:e[infix'][atr] {Scope (kind, d, expr)};
+      scope[def][infix][atr][e]: <(d, infix')> : def[infix] expr:e[infix'][atr] {Scope (d, expr)};
 
       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);
 
@@ -642,7 +633,7 @@ module Expr =
       | %"infix" s:STRING                         => {notRef atr} => {ignore atr (Var (infix_name @@ unquote s))}
       | %"fun" "(" args:!(Util.list0)[ostap (STRING)] ")" body:parse[def][infix][Void]  => {notRef atr} => {ignore atr (Lambda (args, body))}
       | "[" es:!(Util.list0)[parse def infix Val] "]" => {notRef atr} => {ignore atr (Array es)}
-      | -"{" scope[`Local][def][infix][atr][parse def] -"}" 
+      | -"{" scope[def][infix][atr][parse def] -"}" 
       | "{" es:!(Util.list0)[parse def infix Val] "}" => {notRef atr} => {ignore atr (match es with
                                                                                       | [] -> Const 0
                                                                                       | _  -> List.fold_right (fun x acc -> Sexp ("cons", [x; acc])) es (Const 0))
@@ -655,22 +646,22 @@ module Expr =
 
       | {isVoid atr} => %"skip" {Skip}
 
-      | %"if" e:parse[def][infix][Val] %"then" the:scope[`Local][def][infix][atr][parse def]
+      | %"if" e:parse[def][infix][Val] %"then" the:scope[def][infix][atr][parse def]
-                                elif:(%"elif" parse[def][infix][Val] %"then" scope[`Local][def][infix][atr][parse def])*
+                                elif:(%"elif" parse[def][infix][Val] %"then" scope[def][infix][atr][parse def])*
-                                   %"else" els:scope[`Local][def][infix][atr][parse def] %"fi"
+                                   %"else" els:scope[def][infix][atr][parse def] %"fi"
                                                                      {If (e, the, List.fold_right (fun (e, t) elif -> If (e, t, elif)) elif els)}
-      | %"if" e:parse[def][infix][Val] %"then" the:scope[`Local][def][infix][Void][parse def]
+      | %"if" e:parse[def][infix][Val] %"then" the:scope[def][infix][Void][parse def]
-                             elif:(%"elif" parse[def][infix][Val] %"then" scope[`Local][def][infix][atr][parse def])*
+                             elif:(%"elif" parse[def][infix][Val] %"then" scope[def][infix][atr][parse def])*
                              => {isVoid atr} => %"fi"
                                                                      {If (e, the, List.fold_right (fun (e, t) elif -> If (e, t, elif)) elif Skip)}
 
-      | %"while" e:parse[def][infix][Val] %"do" s:scope[`Local][def][infix][Void][parse def]
+      | %"while" e:parse[def][infix][Val] %"do" s:scope[def][infix][Void][parse def]
                                             => {isVoid atr} => %"od" {While (e, s)}
 
-      | %"for" i:parse[def][infix][Void] "," c:parse[def][infix][Val] "," s:parse[def][infix][Void] %"do" b:scope[`Local][def][infix][Void][parse def] => {isVoid atr} => %"od"
+      | %"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"
                                                                      {Seq (i, While (c, Seq (b, s)))}
 
-      | %"repeat" s:scope[`Local][def][infix][Void][parse def] %"until" e:basic[def][infix][Val]
+      | %"repeat" s:scope[def][infix][Void][parse def] %"until" e:basic[def][infix][Val]
                                                   => {isVoid atr} => {Repeat (s, e)}
       | %"return" e:basic[def][infix][Val]?            => {isVoid atr} => {Return e}
 
@@ -806,7 +797,7 @@ let eval expr i =
 
 (* Top-level parser *)
 ostap (
-  parse[infix]: !(Expr.scope `Global (definitions global) infix Expr.Void (Expr.parse (definitions local)));
+  parse[infix]: !(Expr.scope (definitions global) infix Expr.Void (Expr.parse (definitions local)));
   local: %"local" {`Local};
   global: %"global" {`Global};
   definitions[kind][infix]:

src/SM.ml

@@ -155,8 +155,26 @@ let run p i =
    Takes a program in the source language and returns an equivalent program for the
    stack machine
 *)
-let compile (defs, p) =
+  
-  let label s = "L" ^ s in
+let label s = "L" ^ s 
+
+class env =
+object (self : 'self)
+  val label_index = 0
+  val scope_index = 0
+  val globals     = ([] : string list)  
+            
+  method get_label = (label @@ string_of_int label_index), {< label_index = label_index + 1 >}
+                   
+  method push_scope (k : [`Global | `Local]) = self
+             
+  method pop_scope (k : [`Global | `Local]) = self
+             
+  method add_var (k : [`Global | `Local]) (name : string) = match k with `Global -> self | `Local -> self
+  method add_fun (k : [`Global | `Local]) (name : string) = match k with `Global -> self | `Local -> self
+end
+  
+let compile p =
   let rec pattern env lfalse = function
   | Pattern.Wildcard        -> env, false, [DROP]
   | Pattern.Named   (_, p)  -> pattern env lfalse p
@@ -231,6 +249,23 @@ let compile (defs, p) =
      let env, flag2, s2 = compile_list l   env es in
      add_code (env, flag1, s1) les flag2 s2
   and compile_expr l env = function
+    | Expr.Scope (ds, e)   ->
+       let k = `Global in
+     let env = env#push_scope k in
+     let env, e =
+       List.fold_left
+         (fun (env, e) ->
+           function
+           | name, `Fun _             -> env#add_fun k name, e 
+           | name, `Variable None     -> env#add_var k name, e
+           | name, `Variable (Some v) -> env#add_var k name, Expr.Seq (Expr.Assign (Expr.Ref name, v), e)
+         )
+         (env, e)
+         ds
+     in
+     let env, flag, code = compile_expr l env e in
+     env#pop_scope k, flag, code
+ 
   | Expr.Unit               -> env, false, [CONST 0]
                                
   | Expr.Ignore   s         -> let ls, env = env#get_label in
@@ -265,9 +300,6 @@ let compile (defs, p) =
 
   | Expr.Assign (x, e)      -> let lassn, env = env#get_label in
                                add_code (compile_list lassn env [x; e]) lassn false [match x with Expr.ElemRef _ -> STA | _ -> STI]                              
-                               (* (match x with
-                                *  | Expr.Ref x -> add_code (compile_expr lassn env e) lassn false [ST x]
-                                *  | _          -> add_code (compile_list lassn env [x; e]) lassn false [match x with Expr.ElemRef _ -> STA | _ -> STI]) *)
                              
   | Expr.Skip               -> env, false, []
 
@@ -334,12 +366,7 @@ let compile (defs, p) =
      in
      env, true, se @ (if fe then [LABEL lexp] else []) @ [DUP] @ (List.flatten @@ List.rev code) @ [JMP l] 
   in
-  let compile_def env (name, def) =
+  let compile_fundef env (name, args, stmt) =
-    let args, stmt =
-      match def with
-      | `Fun (args, stmt) -> args, stmt
-      | _ -> invalid_arg "local definition"
-    in
     let lend, env       = env#get_label in
     let env, flag, code = compile_expr lend env stmt in
     env,
@@ -348,18 +375,7 @@ let compile (defs, p) =
     (if flag then [LABEL lend] else []) @
     [END]
   in
-  let env =
+  let env       = new env in
-    object
-      val ls = 0
-      method get_label = (label @@ string_of_int ls), {< ls = ls + 1 >}
-    end
-  in
-  let env, def_code =
-    List.fold_left
-      (fun (env, code) (name, others) -> let env, code' = compile_def env (label name, others) in env, code'::code)
-      (env, [])
-      defs
-  in
   let lend, env = env#get_label in
   let _, flag, code = compile_expr lend env p in
-  (if flag then code @ [LABEL lend] else code) @ [END] @ (List.concat def_code) 
+  (if flag then code @ [LABEL lend] else code) @ [END] 

src/X86.ml

@@ -558,7 +558,7 @@ let genasm (ds, stmt) =
   let env, code =
     compile
       (new env)
-      ((LABEL "main") :: (BEGIN ("main", [], [])) :: SM.compile (ds, stmt))
+      ((LABEL "main") :: (BEGIN ("main", [], [])) :: [] (* TODO! SM.compile (ds, stmt) *))
   in
   let gc_start, gc_end = "__gc_data_start", "__gc_data_end" in
   let data = [Meta "\t.data";