Merge pull request #406 from savonet/rec_fun

Added support for recursive function.

CHANGES

@@ -3,6 +3,8 @@ x.y.z ()
 
 New:
 
+- Added support for recursive functions (#406)
+
 - Add peak and peak.stereo operators (#364)
 
 - Change `track_sensitive` parameter to a boolean getter (fixed value or anonymous function).

doc/content/language.txt

@@ -73,6 +73,17 @@ end
 # The full type of foo is ()->string.
 %%
 
+Recursive functions can be defined using the <code>rec</code> keywork:
+%%(lan_rec_func.liq)
+def rec fact(n) =
+  if n == 1 then
+    1
+  else
+    n * fact(n-1)
+  end
+end
+%%
+
 
 **Type of an application.** The type of an application is the return type of function if all mandatory arguments are applied. With the function @foo@ previously defined, @foo()@ is a string. Otherwise, the application is "partial", and the expression still has a function type.
 

src/lang/lang.ml

@@ -438,6 +438,13 @@ let iter_sources f v =
         List.iter (fun (_,_,_,v) -> match v with
                      | Some v -> iter_term env v
                      | None -> ()) proto
+    | Term.RFun (fv,proto,fn) ->
+        begin
+          match (fn()).Term.term with
+            | Term.Let {Term.body=body} ->
+                iter_term env {v with Term.term = Term.Fun (fv,proto,body)}
+            | _ -> assert false
+        end
 
   and iter_value v = match v.value with
     | Source s -> f s

src/lang/lang_lexer.mll

@@ -127,6 +127,7 @@ rule token = parse
   | eof { EOF }
 
   | "def"    { PP_DEF }
+  | "rec"    { REC }
   | "fun"    { FUN }
   | '='      { GETS }
   | "end"    { END }

src/lang/lang_parser.mly

@@ -47,6 +47,21 @@
     let fv = Lang_values.free_vars ~bound body in
       mk ?pos (Fun (fv,args,body))
 
+  let mk_rec_fun ?pos doc name args body =
+    let bound = List.map (fun (_,x,_,_) -> x) args in
+    let fv = Lang_values.free_vars ~bound body in
+    let cached = ref None in
+    let rec fn () =
+      match !cached with
+        | Some t -> t
+        | None ->
+            let fnv = mk ?pos (RFun (fv,args,fn)) in
+            mk ?pos (Let {doc=doc;var=name;gen=[];
+                          def=fnv;body=body})
+    in
+      cached := Some (fn());
+      mk ?pos (RFun (fv,args,fn))
+
   let mk_enc e = mk (Encoder e)
 
   (** Time intervals *)
@@ -168,7 +183,7 @@
 %token OGG FLAC OPUS VORBIS VORBIS_CBR VORBIS_ABR THEORA SPEEX GSTREAMER
 %token WAV AVI FDKAAC MP3 MP3_VBR MP3_ABR SHINE EXTERNAL
 %token EOF
-%token BEGIN END GETS TILD QUESTION
+%token BEGIN END REC GETS TILD QUESTION
 %token <Doc.item * (string*string) list> DEF
 %token IF THEN ELSE ELSIF
 %token LPAR RPAR COMMA SEQ SEQSEQ COLON
@@ -462,6 +477,13 @@ binding:
       let body = mk_fun arglist $6 in
         $1,$2,body
     }
+  | DEF REC VARLPAR arglist RPAR g exprs END {
+      let doc = $1 in
+      let name = $3 in
+      let arglist = $4 in
+      let body = mk_rec_fun doc name arglist $7 in
+        doc,name,body
+    }
 
 arglist:
   |                   { [] }

src/lang/lang_values.ml

@@ -148,6 +148,9 @@ and in_term =
 | Var     of string
 | Seq     of term * term
 | App     of term * (string * term) list
+| RFun    of Vars.t *
+    (string*string*T.t*term option) list *
+    (unit -> term)
 | Fun     of Vars.t *
     (string*string*T.t*term option) list *
     term
@@ -180,7 +183,7 @@ let rec print_term v = match v.term with
   | Ref a ->
       Printf.sprintf "ref(%s)" (print_term a)
   | Fun (_,[],v) when is_ground v -> "{"^(print_term v)^"}"
-  | Fun _ -> "<fun>"
+  | Fun _ | RFun _ -> "<fun>"
   | Var s -> s
   | App (hd,tl) ->
       let tl =
@@ -205,8 +208,8 @@ let rec free_vars tm = match tm.term with
         (fun v (_,t) -> Vars.union v (free_vars t))
         (free_vars hd)
         l
-  | Fun (fv,_,_) ->
-      fv
+  | RFun (fv,_,_)
+  | Fun (fv,_,_) -> fv
   | Let l ->
       Vars.union
         (free_vars l.def)
@@ -252,6 +255,17 @@ let check_unused ~lib tm =
     | App (hd,l) ->
         let v = check v hd in
           List.fold_left (fun v (_,t) -> check v t) v l
+    (* A recursive function may not use its recursive let. *)
+    | RFun (fv,p,fn) ->
+      begin
+        match (fn()).term with
+          | Let {var=var;body=body} ->
+              let v =
+                check v {tm with term = Fun (fv,p,body)}
+              in
+              Vars.remove var v        
+          | _ -> assert false
+      end
     | Fun (_,p,body) ->
         let v =
           List.fold_left
@@ -303,7 +317,12 @@ let check_unused ~lib tm =
 
 (** Maps a function on all types occurring in a term.
   * Ignores variable generalizations. *)
-let rec map_types f (gen:'a list) tm = match tm.term with
+let rec map_types f (gen:'a list) tm =
+  let aux = function
+    | (lbl,var,t,None) -> lbl, var, f gen t, None
+    | (lbl,var,t,Some tm) -> lbl, var, f gen t, Some (map_types f gen tm)
+  in
+  match tm.term with
   | Unit | Bool _ | Int _ | String _ | Float _ | Encoder _ | Var _ ->
       { tm with t = f gen tm.t }
   | Ref r ->
@@ -329,12 +348,14 @@ let rec map_types f (gen:'a list) tm = match tm.term with
         term = App (map_types f gen hd,
                     List.map (fun (lbl,v) -> lbl, map_types f gen v) l) }
   | Fun (fv,p,v) ->
-      let aux = function
-        | (lbl,var,t,None) -> lbl, var, f gen t, None
-        | (lbl,var,t,Some tm) -> lbl, var, f gen t, Some (map_types f gen tm)
+      { t = f gen tm.t ;
+        term = Fun (fv, List.map aux p, map_types f gen v) }
+  | RFun (fv,p,fn) ->
+      let fn () =
+        map_types f gen (fn ())
       in
-        { t = f gen tm.t ;
-          term = Fun (fv, List.map aux p, map_types f gen v) }
+      { t = f gen tm.t ;
+        term = RFun (fv, List.map aux p, fn) }
   | Let l ->
       let gen' = l.gen@gen in
         { t = f gen tm.t ;
@@ -344,7 +365,17 @@ let rec map_types f (gen:'a list) tm = match tm.term with
 (** Folds [f] over almost all types occurring in a term,
   * skipping as much as possible while still
   * guaranteeing that [f] will see all variables. *)
-let rec fold_types f gen x tm = match tm.term with
+let rec fold_types f gen x tm =
+  let fold_proto x p =
+    List.fold_left
+      (fun x -> function
+        | (_,_,t,Some tm) ->
+            fold_types f gen (f gen x t) tm
+        | (_,_,t,None) ->
+            f gen x t)
+     x p
+  in
+  match tm.term with
   | Unit | Bool _ | Int _ | String _ | Float _ | Encoder _ | Var _ ->
       f gen x tm.t
   | List l ->
@@ -358,16 +389,15 @@ let rec fold_types f gen x tm = match tm.term with
       let x = fold_types f gen x tm in
         List.fold_left (fun x (_,tm) -> fold_types f gen x tm) x l
   | Fun (_,p,v) ->
-      fold_types f gen
-        (List.fold_left
-           (fun x -> function
-              | (_,_,t,Some tm) ->
-                  fold_types f gen (f gen x t) tm
-              | (_,_,t,None) ->
-                  f gen x t)
-           x
-           p)
-        v
+      fold_types f gen (fold_proto x p) v
+  | RFun (_,p,fn) ->
+      begin
+        match (fn()).term with
+          | Let l ->
+              let x = f gen x l.def.t in
+              fold_types f gen (fold_proto x p) l.body
+          | _ -> assert false
+      end 
   | Let {gen=gen';def=def;body=body;_} ->
       let x = fold_types f (gen'@gen) x def in
         fold_types f gen x body
@@ -542,6 +572,32 @@ let rec check ?(print_toplevel=false) ~level ~env e =
   let pos = e.t.T.pos in
   let mk t = T.make ~level ~pos t in
   let mkg t = mk (T.Ground t) in
+  let check_fun ~proto ~env e body =
+    let base_check = check ~level ~env in
+    let proto_t,env,level =
+      List.fold_left
+        (fun (p,env,level) -> function
+           | lbl,var,kind,None   ->
+               if debug then
+                 Printf.eprintf "Assigning level %d to %s (%s).\n"
+                   level var (T.print kind) ;
+               kind.T.level <- level ;
+               (false,lbl,kind)::p, (var,([],kind))::env, level+1
+           | lbl,var,kind,Some v ->
+               if debug then
+                 Printf.eprintf "Assigning level %d to %s (%s).\n"
+                   level var (T.print kind) ;
+               kind.T.level <- level ;
+               base_check v ;
+               v.t <: kind ;
+               (true,lbl,kind)::p, (var,([],kind))::env, level+1)
+        ([],env,level)
+        proto
+    in
+    let proto_t = List.rev proto_t in
+      check ~level ~env body ;
+      e.t >: mk (T.Arrow (proto_t,body.t))
+  in
   match e.term with
   | Unit      -> e.t >: mkg T.Unit
   | Bool    _ -> e.t >: mkg T.Bool
@@ -637,31 +693,16 @@ let rec check ?(print_toplevel=false) ~level ~env e =
             let p = List.map (fun (lbl,b) -> false,lbl,b.t) l in
               a.t <: T.make ~level ~pos:None (T.Arrow (p,e.t))
       end
-  | Fun (_,proto,body) ->
-      let base_check = check ~level ~env in
-      let proto_t,env,level =
-        List.fold_left
-          (fun (p,env,level) -> function
-             | lbl,var,kind,None   ->
-                 if debug then
-                   Printf.eprintf "Assigning level %d to %s (%s).\n"
-                     level var (T.print kind) ;
-                 kind.T.level <- level ;
-                 (false,lbl,kind)::p, (var,([],kind))::env, level+1
-             | lbl,var,kind,Some v ->
-                 if debug then
-                   Printf.eprintf "Assigning level %d to %s (%s).\n"
-                     level var (T.print kind) ;
-                 kind.T.level <- level ;
-                 base_check v ;
-                 v.t <: kind ;
-                 (true,lbl,kind)::p, (var,([],kind))::env, level+1)
-          ([],env,level)
-          proto
-      in
-      let proto_t = List.rev proto_t in
-        check ~level ~env body ;
-        e.t >: mk (T.Arrow (proto_t,body.t))
+  | Fun (_,proto,body) -> check_fun ~proto ~env e body
+  | RFun (_,proto,fn) -> 
+      begin
+        match (fn()).term with
+          | Let {var=var;def=def;body=body} ->
+             let env = (var,([],def.t))::env in
+             check_fun ~proto ~env def body;
+             e.t >: def.t
+          | _ -> assert false
+      end 
   | Var var ->
       let generalized,orig =
         try
@@ -801,6 +842,21 @@ let lookup env var ty =
     v
 
 let rec eval ~env tm =
+  let prepare_fun fv p env =
+    (* Unlike OCaml we always evaluate default values,
+     * and we do that early.
+     * I think the only reason is homogeneity with FFI,
+     * which are declared with values as defaults. *)
+    let p =
+      List.map
+        (function
+          | (lbl,var,_,Some v) -> lbl,var,Some (eval ~env v)
+          | (lbl,var,_,None) -> lbl,var,None)
+      p
+    in
+    let env = List.filter (fun (x,_) -> Vars.mem x fv) env in
+    (p,env)
+  in
   let mk v = { V.t = tm.t ; V.value = v } in
     match tm.term with
       | Unit -> mk (V.Unit)
@@ -831,19 +887,23 @@ let rec eval ~env tm =
           let v = eval ~env v in
           eval ~env:((x,(generalized,v))::env) b
       | Fun (fv,p,body) ->
-          (* Unlike OCaml we always evaluate default values,
-           * and we do that early.
-           * I think the only reason is homogeneity with FFI,
-           * which are declared with values as defaults. *)
-          let p =
-            List.map
-              (function
-                 | (lbl,var,_,Some v) -> lbl,var,Some (eval ~env v)
-                 | (lbl,var,_,None) -> lbl,var,None)
-              p
-          in
-          let env = List.filter (fun (x,_) -> Vars.mem x fv) env in
+          let (p,env) = prepare_fun fv p env in
             mk (V.Fun (p,[],env,body))
+      | RFun (fv,p,fn) ->
+          begin
+            match (fn ()).term with
+              | Let {var=var;body=body} ->
+                  let (p,env) = prepare_fun fv p env in
+                  let rec ffi args t =
+                    let v = mk (V.FFI (p,[],ffi)) in
+                    let env = (var,([],v))::env in
+                    let env = List.rev_append args env in
+                    let f = mk (V.Fun ([],[],env,body)) in
+                    apply ~t f []
+                  in
+                    mk (V.FFI (p,[],ffi))
+              | _ -> assert false
+          end
       | Var var ->
           lookup env var tm.t
       | Seq (a,b) ->