1. camlspotter
  2. olfend

Source

olfend / interm.ml

(* Very weak sort of static typing *)

open Spotlib.Spot
(* open Sexplib.Sexp *)
open Sexplib.Conv
open Typed
open Types

module IdentSet = Typed.IdentSet
module PathSet = Typed.PathSet

module TE = Typed.Expr
module TT = Typed.Top

module Expr = struct
  type t = 
    | Var of Path.t
    | Abs of Ident.t list * t
    | Let of Ident.t * t * t
    | Fix of Ident.t (* args *) * t (* Fix always takes Abs immediately *)
    | App of t list
    | If  of t * t * t
    | Const of Const.t
    | Prim  of Prim.t * t list (* Always in fully applied form *)
    | Tuple of t list
    | Constructed of Path.t * Tag.t * t list (* Always in fully applied form *)
    | Fielded     of Path.t * Tag.t * t      (* Fully applied *)
    | Record      of (Path.t * Tag.t * t) list
  with sexp

  let rec free_idents =  (* Path A.x is considered as an ident A *)
    let open IdentSet in
    function
      | Var (Path.Ident id | Path.Dot (Path.Ident id, _, _))  -> one id
      | Var _ -> assert false
      | Abs (ids, t) -> free_idents t - of_list ids
      | Let (id, t1, t2) -> free_idents t1 + (free_idents t2 - one id)
      | Fix (id, t) -> free_idents t - one id
      | App ts | Prim (_, ts) | Tuple ts -> unions (List.map free_idents ts)
      | If (t1, t2, t3) -> unions (List.map free_idents [t1; t2; t3])
      | Const _ -> empty
      | Constructed (_, _, ts) -> unions (List.map free_idents ts)
      | Fielded (_, _, t) -> free_idents t
      | Record path_tag_expr_list -> unions (List.map (fun (_,_,e) -> free_idents e) path_tag_expr_list)
  
  let rec of_typed e = match e.desc with
    | TE.Var p -> Var p
    | TE.Abs (pats, t) ->
        let params = List.map (fun _ -> Ident.create "*pat*") pats in
        let lang = Pattern.compile (List.map (fun x -> Pattern.Src x) params) [List.map (fun p -> p.desc) pats, t] in
        if Pattern.debug then Format.eprintf "%a@." Sexplib.Sexp.pp_hum (Pattern.sexp_of_lang lang);
        Abs (params, of_lang lang)

    | TE.Let (pat, _env, t1, t2) ->
        let ident = Ident.create "*pat*" in
        let lang = Pattern.compile [Pattern.Src ident] [[pat.desc], t2] in
        if Pattern.debug then Format.eprintf "%a@."
          Sexplib.Sexp.pp_hum (Pattern.sexp_of_lang lang);
        Let (ident, of_typed t1, of_lang lang)

    | TE.Letrec (id, _env, t1, t2) -> Let (id, Fix (id, of_typed t1), of_typed t2)

    (* Field partial app *)
    | TE.Field _ -> of_typed (TE.eta_expand e 1)

    | TE.App ({ desc= TE.Field (p, tag) } :: ts) ->
        let arity = 1 in
        let nargs = List.length ts in
        if arity > nargs then of_typed (TE.eta_expand e (arity - nargs))
        else 
          let ts = List.map of_typed ts in
          let args, rest = List.split_at arity ts in
          begin match args with
          | [arg] -> 
              let i = Fielded (p, tag, arg) in
              if rest = [] then i else App (i :: rest)
          | _ -> assert false
          end
    
    (* Primitive full application *)
    | TE.Prim ((_, 0) as p) -> Prim (p, []) (* 0-ary primitive? *)

    (* Primitive partial application *)    
    | TE.Prim (_, arity) -> of_typed (TE.eta_expand e arity)
    
    | TE.App ({ desc= TE.Prim ((_, arity) as p)} :: ts) ->
        (* CR jfuruse: quite near to the prim case *)
        let nargs = List.length ts in
        if arity > nargs then of_typed (TE.eta_expand e (arity - nargs))
        else 
          let ts = List.map of_typed ts in
          let prim_args, rest = List.split_at arity ts in
          let p = Prim (p, prim_args) in
          if rest = [] then p else App (p :: rest)
    
    (* Constr full application *)
    | TE.Constr (p, tag, 0) -> Constructed (p, tag, [])

    (* Constr partial application *)
    | TE.Constr (_p, _tag, arity) -> of_typed (TE.eta_expand e arity)

    | TE.App ({ desc= TE.Constr (p, tag, arity) } :: ts) ->
        (* CR jfuruse: quite near to the prim case *)
        let nargs = List.length ts in
        if arity > nargs then of_typed (TE.eta_expand e (arity - nargs))
        else 
          let ts = List.map of_typed ts in
          let constr_args, rest = List.split_at arity ts in
          let c = Constructed (p, tag, constr_args) in
          if rest = [] then c else App (c :: rest)
    
    | TE.App [t] -> of_typed t
    | TE.App ({desc = TE.App ts} :: ts2) ->  (* ((a b c) d e f) => (a b c d e f) *)
        of_typed { desc= TE.App (ts @ ts2); typ= e.typ }
    | TE.App ts -> App (List.map of_typed ts)
  
    | TE.If (t1, t2, t3) -> If (of_typed t1, of_typed t2, of_typed t3)
    | TE.Const c -> Const c
    | TE.Tuple args -> Tuple (List.map of_typed args)

    | TE.Match (t, cases) ->
        let id = Ident.create "*val*" in
        let lang = Pattern.compile [Pattern.Src id] (List.map (fun (p,act) -> [p.desc], act) cases) in
(* Format.eprintf "%a@." Sexplib.Sexp.pp_hum (Pattern.sexp_of_lang lang); *)
        Let (id, of_typed t, of_lang lang)

    | TE.Record path_tag_expr_list ->
        Record (List.map (fun (p,tag,e) -> p, tag, of_typed e) path_tag_expr_list) 

  and of_lang lang = 
    let open Pattern in 
    (* env carries already ident-assigned accessor cache *)
    let rec of_lang env = function
      | Fail -> Prim (("match_failure", 1), [ Const (Const.Int 0) ])
      | Switch (acc, cases) ->
          let rev_lets, id, env = of_acc env acc in
          wrap_rev_lets (of_cases env id cases) rev_lets
      | Leaf act -> of_typed act
      | Swap (_, lang) -> of_lang env lang
      | Bind ([], lang) -> of_lang env lang
      | Bind ((id,acc)::id_accs, lang) ->
          let rev_lets, id', env = of_acc env acc in
          let e = of_lang env (Bind (id_accs, lang)) in
          wrap_rev_lets (Let (id, Var (Path.of_ident id'), e)) rev_lets

    and of_acc env = function
      | Src id -> [], id, env
      | (Acc (acc', n) as acc) ->
          try [], List.assoc acc env, env with Not_found ->
            let rev_lets, id', env = of_acc env acc' in
            let id = Ident.create "*acc*" in
            (id, Prim (("field", 2), [Var (Path.of_ident id'); Const (Const.Int n)])) :: rev_lets, 
            id, 
            (acc, id) :: env

    and of_cases env id cases =
      let rec of_cases = function
        | (`Const c, lang)::cs ->
            If ( Prim ( ("eq", 2), [Var (Path.of_ident id); Const c]),
                 of_lang env lang,
                 of_cases cs )
        | ((`Tag (_pathopt, t, _), lang)::cs ) ->
            If ( Prim ( ("eq_tag", 2), [Var (Path.of_ident id); Const (Const.Int (Tag.to_int t))] ),
                 of_lang env lang,
                 of_cases cs )
        | [`Default, lang] -> of_lang env lang
        | [] -> Prim (("match_failure", 1), [ Const (Const.Int 1) ]) (* Strange??? *)
        | _ -> assert false
      in
      of_cases cases

    and wrap_rev_lets e = function
      | [] -> e
      | (id,def)::xs -> wrap_rev_lets (Let (id, def, e)) xs
    in
    of_lang [] lang
          
  let format ppf t = Sexplib.Sexp.pp_hum ppf (sexp_of_t t)
end

module Top = struct
  type t = 
    | Expr of Expr.t
    | Let of (Ident.t * Poly.t) list * Expr.t
    | Load of Ident.t
    | NOP (* CR jfuruse: geez. for type *)
  with sexp

  module E = Expr

  let of_typed top = match top with
    | TT.Let (pat, env, t) -> 
        let id_ptyps = List.map (function
          | (id, pty) -> id, pty) env 
        in
        begin match id_ptyps with
        | [] -> Expr (E.of_typed t)
        | [id,ptyp] -> 
            Let ([id, ptyp], 
                 E.of_typed {desc= TE.Let (pat, env, t, { desc= TE.Var (Path.of_ident id); typ= pat.typ (* CR jfuruse: incorrect *)}); typ= pat.typ })
        | _ -> 
            Let (id_ptyps,
                 E.of_typed { desc= TE.Let (pat, env, t,
                                            { desc= TE.Tuple (List.map (fun (id,_ptyp) -> { desc= TE.Var (Path.of_ident id); typ= Predef.Type.int (* CR jfuruse: dummy *) }) id_ptyps);
                                            typ= Predef.Type.int (* CR jfuruse: dummy *) });
                            typ= Predef.Type.int (* CR jfuruse: dummy *)  })
        end
    | TT.Letrec (id, env, t) -> 
        let id_ptyps = List.map (function
          | (id, pty) -> id, pty) env 
        in
        Let (id_ptyps, E.Let (id, E.Fix(id, E.of_typed t), E.Var (Path.of_ident id)))
    | TT.Expr (t, _pty) -> Expr (E.of_typed t)
    | TT.Open _ -> NOP
    | TT.Prim (id, pty, [name]) -> 
        let ty = match pty with
          | Types.Poly (_, ty) -> ty (* CR jfuruse: must be closed *)
        in
        Let ([id, pty], 
             E.of_typed { desc= TE.Prim (name,
                                         let (arity, _, _) = Type.arity [] ty in arity (* must not be modified...! *));
                        typ= ty })
    | TT.Prim _ -> assert false
    | TT.Type _ -> NOP

  let of_globals tyEnv = List.rev_map (fun (id, _digest) -> Load id) tyEnv.Typed.TyEnv.env.Env.globals

  let defined_ident_list = function
    | Let (ident_ptyps, _) -> ident_ptyps
    | Expr _      -> []
    | Load _id    -> []
    | NOP -> []

  let format ppf t = Sexplib.Sexp.pp_hum ppf (sexp_of_t t)
end