FSF in SM (only obe-level closure yet)

regression/Makefile

@@ -1,4 +1,4 @@
-TESTS=$(basename $(wildcard test*.expr))
+TESTS=$(sort $(basename $(wildcard test*.expr)))
 
 RC=../src/rc.opt
 
@@ -10,7 +10,7 @@ $(TESTS): %: %.expr
 	@echo $@
 #	@$(RC) $< && cat $@.input | ./$@ > $@.log && diff $@.log orig/$@.log
 	cat $@.input | $(RC) -i $< > $@.log && diff $@.log orig/$@.log
-	@cat $@.input | $(RC) -s $< 2> /dev/null > $@.log && diff $@.log orig/$@.log; true
+	cat $@.input | $(RC) -s $< 2> /dev/null > $@.log && diff $@.log orig/$@.log
 
 clean:
 	$(RM) test*.log *.s *~ $(TESTS)

regression/orig/test065.log

@@ -0,0 +1,2 @@
+> 2
+1

regression/test065.expr

@@ -0,0 +1,21 @@
+fun f () {
+  local x, l = {};
+  fun g () {return x}
+  
+  x := 1;
+  l := g : l;
+
+  x := 2;
+  l := g : l;
+
+  return l
+}
+
+fun p (l) {
+  case l of
+    {} -> skip
+  | h : tl -> write (h ()); p (tl)
+  esac
+}
+
+p (f ())

regression/test065.input

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

src/Driver.ml

@@ -41,10 +41,13 @@ let main =
     match (try parse infile with Language.Semantic_error msg -> `Fail msg) with
     | `Ok prog ->
        if to_compile
-       then
+       then (
          let basename = Filename.chop_suffix infile ".expr" in
          (* ignore @@ X86.build prog basename *) (* TODO! *) ()
-       else
+       )
+       else (
+         (* Printf.printf "Program:\n%s\n" (GT.show(Language.Expr.t) prog);*)
+         (*Format.printf "Program\n%s\n%!" (HTML.toHTML ((GT.html(Language.Expr.t)) prog));*)
 	 let rec read acc =
 	   try
 	     let r = read_int () in
@@ -59,6 +62,7 @@ let main =
 	   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
 (*  with Invalid_argument _ ->
     Printf.printf "Usage: rc [-i | -s] <input file.expr>\n"

src/Language.ml

@@ -2,6 +2,7 @@
    The library provides "@type ..." syntax extension and plugins like show, etc.
 *)
 module OrigList = List
+
 open GT
 
 (* Opening a library for combinator-based syntax analysis *)
@@ -22,7 +23,8 @@ module Value =
     | Local  of int
     | Arg    of int
     | Access of int
-    with show   
+    | Fun    of string
+    with show,html   
 
     @type ('a, 'b) t =
     | Empty
@@ -33,8 +35,9 @@ module Value =
     | Array   of ('a, 'b) t array
     | Sexp    of string * ('a, 'b) t array
     | Closure of string list * 'a * 'b
+    | FunRef  of string * string list * 'a * int
     | Builtin of string
-    with show
+    with show,html
 
     let to_int = function
     | Int n -> n
@@ -125,10 +128,29 @@ module State =
   struct
 
     (* State: global state, local state, scope variables *)
-    type 'a t =
+    @type 'a t =
     | I
-    | G of (string * bool) list * (string -> 'a)
+    | G of (string * bool) list * (string, 'a) arrow
-    | L of (string * bool) list * (string -> 'a) * 'a t
+    | L of (string * bool) list * (string, 'a) arrow * 'a t
+    with show,html
+
+    (* Get the depth level of a state *)
+    let rec level = function
+    | I            -> 0
+    | G _          -> 1
+    | L (_, _, st) -> 1 + level st
+
+    (* Prune state to a certain level *)
+    let prune st n =
+      let rec inner n st =
+        match st with
+        | I              -> st, 0
+        | G (xs, s)      -> st, 1
+        | L (xs, s, st') ->
+           let st'', l = inner n st' in
+           (if l >= n then st'' else st), l+1
+      in
+      fst @@ inner n st
                     
     (* Undefined state *)
     let undefined x = failwith (Printf.sprintf "Undefined variable: %s" x)
@@ -229,7 +251,7 @@ module Pattern =
     (* any sexp value   *) | SexpTag
     (* any array value  *) | ArrayTag
     (* any closure      *) | ClosureTag
-    with show, foldl
+    with show, foldl, html
 
     (* Pattern parser *)
     ostap (
@@ -273,13 +295,12 @@ module Expr =
     (* The type of configuration: a state, an input stream, an output stream,
        and a stack of values
     *)
-    type 'a value  = ('a, 'a value State.t) Value.t
+    @type 'a value  = ('a, 'a value State.t) Value.t with show,html
-    type 'a config = 'a value State.t * int list * int list * 'a value list
+    @type 'a config = 'a value State.t * int list * int list * 'a value list with show,html
-
     (* The type for expressions. Note, in regular OCaml there is no "@type..."
        notation, it came from GT.
     *)
-    type t =
+    @type t =
     (* integer constant           *) | Const     of int
     (* array                      *) | Array     of t list
     (* string                     *) | String    of string
@@ -302,11 +323,13 @@ module Expr =
     (* return statement           *) | Return    of t option
     (* ignore a value             *) | Ignore    of t
     (* unit value                 *) | Unit
-    (* entering the scope         *) | Scope     of (string * [`Fun of string list * t | `Variable of t option]) list * t
+    (* entering the scope         *) | Scope     of (string * decl) list * t
     (* lambda expression          *) | Lambda    of string list * t
     (* leave a scope              *) | Leave
-    (* intrinsic (for evaluation) *) | Intrinsic of (t config -> t config)
+    (* intrinsic (for evaluation) *) | Intrinsic of (t config, t config) arrow
-    (* control (for control flow) *) | Control   of (t config -> t * t config) 
+    (* control (for control flow) *) | Control   of (t config, t * t config) arrow
+    and decl = [`Fun of string list * t | `Variable of t option]
+    with show,html
 
     (* Reff : parsed expression should return value Reff (look for ":=");
        Val : -//- returns simple value;
@@ -394,7 +417,7 @@ module Expr =
            List.fold_left
              (fun (vs, bd, bnd) -> function
               | (name, `Variable value) -> (name, true) :: vs, (match value with None -> bd | Some v -> Seq (Ignore (Assign (Ref name, v)), bd)), bnd
-              | (name, `Fun (args, b))  -> (name, false) :: vs, bd, (name, Value.Closure (args, b, st)) :: bnd
+              | (name, `Fun (args, b))  -> (name, false) :: vs, bd, (name, Value.FunRef (name, args, b, 1 + State.level st)) :: bnd
              )
              ([], body, [])
              (List.rev defs)
@@ -416,7 +439,13 @@ module Expr =
       | StringVal s ->
          eval conf k (schedule_list [s; Intrinsic (fun (st, i, o, s::vs) -> (st, i, o, (Value.of_string @@ Value.string_val s)::vs))])
       | Var x ->
-         eval (st, i, o, (State.eval st x) :: vs) Skip k
+         let v =
+           match State.eval st x with
+           | Value.FunRef (_, args, body, level) ->
+              Value.Closure (args, body, State.prune st level)
+           | v -> v
+         in
+         eval (st, i, o, v :: vs) Skip k
       | Ref x ->
          eval (st, i, o, (Value.Var (Value.Global x)) :: vs) Skip k
       | Array xs ->
@@ -640,7 +669,7 @@ module Expr =
       | s:STRING                                  => {notRef atr} => {ignore atr (String (unquote s))}
       | c:CHAR                                    => {notRef atr} => {ignore atr (Const  (Char.code c))}
       | %"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))}
+      | %"fun" "(" args:!(Util.list0)[ostap (LIDENT)] ")" body:basic[def][infix][Void]  => {notRef atr} => {ignore atr (Lambda (args, body))}
       | "[" es:!(Util.list0)[parse def infix Val] "]" => {notRef atr} => {ignore atr (Array es)}
       | -"{" scope[def][infix][atr][parse def] -"}" 
       | "{" es:!(Util.list0)[parse def infix Val] "}" => {notRef atr} => {ignore atr (match es with

src/SM.ml

@@ -2,7 +2,7 @@ open GT
 open Language
 
 (* The type for patters *)
-@type patt = StrCmp | String | Array | Sexp | Boxed | UnBoxed with show
+@type patt = StrCmp | String | Array | Sexp | Boxed | UnBoxed | Closure with show
 
 (* The type for the stack machine instructions *)
 @type insn =
@@ -18,8 +18,9 @@ open Language
 (* a label                                   *) | LABEL   of string
 (* unconditional jump                        *) | JMP     of string
 (* conditional jump                          *) | CJMP    of string * string
-(* begins procedure definition               *) | BEGIN   of string * int * int
+(* begins procedure definition               *) | BEGIN   of string * int * int * Value.designation list
 (* end procedure definition                  *) | END
+(* create a closure                          *) | CLOSURE of string
 (* calls a function/procedure                *) | CALL    of int 
 (* returns from a function                   *) | RET     
 (* drops the top element off                 *) | DROP
@@ -112,20 +113,30 @@ let rec eval env (((cstack, stack, glob, loc, i, o) as conf) : config) = functio
     | CJMP  (c, l)            -> let x::stack' = stack in
                                  eval env (cstack, stack', glob, loc, i, o) (if (c = "z" && Value.to_int x = 0) || (c = "nz" && Value.to_int x <> 0) then env#labeled l else prg')
 
+    | CLOSURE name            -> let BEGIN (_, _, _, dgs) :: _ = env#labeled name in
+                                 let closure =
+                                   Array.of_list @@
+                                   List.map (
+                                     function
+                                     | Value.Arg    i -> loc.args.(i)
+                                     | Value.Local  i -> loc.locals.(i)
+                                     | Value.Access i -> loc.closure.(i)
+                                     | _ -> invalid_arg "wrong value in CLOSURE")
+                                     dgs
+                                 in
+                                 eval env (cstack, (Value.Closure ([], name, closure)) :: stack, glob, loc, i, o) prg'
+                                 
     | CALL   n                -> let vs, stack' = split (n+1) stack in
                                  let f::args    = List.rev vs   in
-                                 let args       = List.rev args in
                                  (match f with
-                                  | Value.Builtin f         -> eval env (env#builtin f args ((cstack, stack', glob, loc, i, o) : config)) prg'
+                                  | Value.Builtin f ->
-                                  | Value.Closure (_, f, _) -> eval env ((prg', loc)::cstack, stack, glob, loc, i, o) (env#labeled f)
+                                     eval env (env#builtin f (List.rev args) ((cstack, stack', glob, loc, i, o) : config)) prg'
+                                  | Value.Closure (_, f, closure) ->
+                                     eval env ((prg', loc)::cstack, stack', glob, {args = Array.of_list args; locals = [||]; closure = closure}, i, o) (env#labeled f)
+                                  | _ -> invalid_arg "not a closure (or a builtin) in CALL: %s\n" @@ show(value) f
                                  )
                                
-    | BEGIN (_, args, locals) -> let vs, stack' = split (args+1) stack in
+    | BEGIN (_, _, locals, _) -> eval env (cstack, stack, glob, {loc with locals  = Array.init locals (fun _ -> Value.Empty)}, i, o) prg'
-                                 let _ :: aargs = List.rev vs in
-                                 let aargs      = aargs       in
-                                 eval env (cstack, stack', glob, {args    = Array.init args (fun i -> List.nth aargs i);
-                                                                  locals  = Array.init locals (fun _ -> Value.Empty);
-                                                                  closure = [||]}, i, o) prg'
                                  
     | END                     -> (match cstack with
                                   | (prg', loc')::cstack' -> eval env (cstack', Value.Empty :: stack, glob, loc', i, o) prg'
@@ -157,6 +168,8 @@ let rec eval env (((cstack, stack, glob, loc, i, o) as conf) : config) = functio
                                  eval env (cstack, (Value.of_int @@ match x with Value.Int _ -> 0 | _ -> 1) :: stack', glob, loc, i, o) prg'
     | PATT UnBoxed            -> let x::stack' = stack in
                                  eval env (cstack, (Value.of_int @@ match x with Value.Int _ -> 1 | _ -> 0) :: stack', glob, loc, i, o) prg'
+    | PATT Closure            -> let x::stack' = stack in
+                                 eval env (cstack, (Value.of_int @@ match x with Value.Closure _ -> 1 | _ -> 0) :: stack', glob, loc, i, o) prg'
    )
 
 (* Top-level evaluation
@@ -210,8 +223,12 @@ object (self : 'self)
   val scope_index  = 0
   val local_index  = 0
   val arg_index    = 0
+  val acc_index    = 0
   val nlocals      = 0
+  val lam_index    = 0
   val st           = (State.I : Value.designation State.t)
+  val enclosing_st = (State.I : Value.designation State.t)
+  val closure      = ([] : Value.designation list)
   val fundefs      = ([] : (string * string list * Expr.t * Value.designation State.t) list)
             
   method get_label = (label @@ string_of_int label_index), {< label_index = label_index + 1 >}
@@ -232,7 +249,21 @@ object (self : 'self)
     | State.L (xs, _, x) -> {< st = x; local_index = local_index - List.length xs >}
 
   method init_fun_scope (st' : Value.designation State.t) =
-   {< st = st'; arg_index = 0; local_index = 0; nlocals = 0 >} # push_scope
+    {< st = (
+          let rec readdress_to_closure = function
+          | State.L (xs, _, tl) ->
+             State.L (xs, (fun _ -> Value.Access (~-1)), readdress_to_closure tl)
+          | st -> st
+          in
+          readdress_to_closure st'
+       );
+       enclosing_st = st';
+       arg_index    = 0;
+       local_index  = 0;
+       acc_index    = 0;
+       nlocals      = 0;
+       closure      = []
+    >} # push_scope
            
   method add_arg (name : string) = {<
     st = (match st with
@@ -265,27 +296,40 @@ object (self : 'self)
       | State.I ->
          invalid_arg "uninitialized scope"
       | State.G (names, s) ->
-         State.G (check_name_and_add names name false, State.bind name (Value.Global name') s)
+         State.G (check_name_and_add names name false, State.bind name (Value.Fun name') s)
       | State.L (names, s, p) ->
-         State.L (check_name_and_add names name false, State.bind name (Value.Global name') s, p)        
+         State.L (check_name_and_add names name false, State.bind name (Value.Fun name') s, p)        
     in
     {<
       st = st'
     >}
 
+  method add_lambda (args : string list) (body : Expr.t) =
+    let name' = self#fun_internal_name (Printf.sprintf "lambda_%d" lam_index) in
+    {< fundefs = (name', args, body, st) :: fundefs; lam_index = lam_index + 1 >}, name'
+      
   method add_fun (name : string) (args : string list) (body : Expr.t) =
     let name' = self#fun_internal_name name in
     {<
       fundefs = (name', args, body, st) :: fundefs
     >}
 
-  method lookup name = State.eval st name    
+  method lookup name =
+    match State.eval st name with
+    | Value.Access n when n = ~-1 ->
+       let index         = acc_index in
+       let enclosing_loc = State.eval enclosing_st name in
+       {< st = State.update name (Value.Access index) st; acc_index = acc_index + 1; closure = enclosing_loc :: closure >}, Value.Access index
+       
+    | other -> self, other
     
   method next_definition =
     match fundefs with
     | [] -> None
     | (name, args, body, st) :: rest -> Some ({< fundefs = rest >}, (name, args, body, st))
 
+  method closure = List.rev closure
+                 
 end
   
 let compile p =
@@ -299,6 +343,7 @@ let compile p =
   | Pattern.SexpTag         -> env, true, [PATT Sexp; CJMP ("z", lfalse)]
   | Pattern.UnBoxed         -> env, true, [PATT UnBoxed; CJMP ("z", lfalse)]
   | Pattern.Boxed           -> env, true, [PATT Boxed; CJMP ("z", lfalse)]
+  | Pattern.ClosureTag      -> env, true, [PATT Closure; CJMP ("z", lfalse)]
   | Pattern.Array    ps     ->
      let lhead, env   = env#get_label in
      let ldrop, env   = env#get_label in
@@ -347,10 +392,11 @@ let compile p =
       List.fold_left
         (fun (env, acc) (name, path) ->
            let env = env#add_name name true in
+           let env, dsg = env#lookup name in
            env,
            ([DUP] @
             List.concat (List.map (fun i -> [LD (Value.Global ".elem"); SWAP; CONST i; CALL 2]) path) @
-            [ST (env#lookup name); DROP]) :: acc
+            [ST dsg; DROP]) :: acc
         )
         (env, [])
         (List.rev bindings)
@@ -366,6 +412,10 @@ let compile 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.Lambda (args, b) ->
+     let env, name = env#add_lambda args b in
+     env, false, [CLOSURE name]
+       
   | Expr.Scope (ds, e)  ->
      let env = env#push_scope in
      let env, e, funs =
@@ -389,8 +439,8 @@ let compile p =
                                add_code (compile_expr ls env s) ls false [DROP]                             
 
   | Expr.ElemRef (x, i)     -> compile_list l env [x; i]                               
-  | Expr.Var      x         -> env, false, [LD (env#lookup x)]
+  | Expr.Var      x         -> let env, acc = env#lookup x in env, false, [match acc with Value.Fun name -> CLOSURE name | _ -> LD acc]
-  | Expr.Ref      x         -> env, false, [LDA (env#lookup x)]
+  | Expr.Ref      x         -> let env, acc = env#lookup x in env, false, [LDA acc]
   | Expr.Const    n         -> env, false, [CONST n]
   | Expr.String   s         -> env, false, [STRING s]
   | Expr.Binop (op, x, y)   -> let lop, env = env#get_label in
@@ -494,7 +544,7 @@ let compile p =
     let lend, env       = env#get_label in
     let env, flag, code = compile_expr lend env stmt in
     env#pop_scope,
-    [LABEL name; BEGIN (name, env#nargs, env#nlocals)] @
+    [LABEL name; BEGIN (name, env#nargs, env#nlocals, env#closure)] @
     code @
     (if flag then [LABEL lend] else []) @
     [END]
@@ -509,5 +559,5 @@ let compile p =
   let env             = new env in
   let lend, env       = env#get_label in
   let env, flag, code = compile_expr lend env p in
-  let prg = compile_fundefs [[BEGIN ("main", 0, env#nlocals)] @(if flag then code @ [LABEL lend] else code) @ [END]] env in
+  let prg = compile_fundefs [[BEGIN ("main", 0, env#nlocals, [])] @(if flag then code @ [LABEL lend] else code) @ [END]] env in
   print_prg prg; prg

src/X86.ml

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