[Typer] [Git][monnier/typer][master] Moved builtin macro implementation

Setepenre pushed to branch master at Stefan / Typer

Commits: f530a2dd by Pierre Delaunay at 2016-06-26T11:23:25-04:00 Moved builtin macro implementation

Changes to be committed: * btl/types.typer: change type of some accessors * src/builtin.ml : - fix predef shifting - moved builtin macro implementation there * src/debruijn.ml: remove dead code * src/lparse.ml - builtin macro are now recognized inside (handle_macro_call)

- - - - -

6 changed files:

- .travis.yml - btl/types.typer - src/builtin.ml - src/debruijn.ml - src/eval.ml - src/lparse.ml

Changes:

===================================== .travis.yml ===================================== --- a/.travis.yml +++ b/.travis.yml @@ -8,7 +8,7 @@ sudo: true before_script: - sudo apt-get -qq update - sudo apt-get install opam - - opam init + - opam init --auto-setup - opam config setup -a - opam config env

===================================== btl/types.typer ===================================== --- a/btl/types.typer +++ b/btl/types.typer @@ -151,13 +151,13 @@ read = Built-in "read" (FileHandle -> Int -> IO String); % -----------------------------------------------------

Attribute = Built-in "Attribute"; -new-attribute = Built-in "new-attribute" (Type -> Attribute); +new-attribute = Built-in "new-attribute" (Macro);

-add-attribute = Built-in "add-attribute" (Sexp -> Sexp -> Sexp -> List Sexp); +add-attribute = Built-in "add-attribute" (Macro); attribute = Macro_ add-attribute;

get-attribute = Built-in "get-attribute" Macro; -has-attribute = Built-in "has-attribute" (String -> Attribute -> Bool); +has-attribute = Built-in "has-attribute" (Macro);

% ----------------------------------------------------- % Context Accessors

===================================== src/builtin.ml ===================================== --- a/src/builtin.ml +++ b/src/builtin.ml @@ -52,7 +52,10 @@ type predef_table = (lexp option ref) SMap.t let predef_name = [ "cons"; "nil"; - "Unit" + "Unit"; + "True"; + "False"; + "Bool"; ]

let builtin_size = ref 0 @@ -62,11 +65,17 @@ let predef_map : predef_table = List.fold_left (fun m name -> SMap.add name (ref None) m) SMap.empty predef_name

-let get_predef name = +let get_predef_raw (name: string) : lexp = match !(SMap.find name predef_map) with | Some exp -> exp | None -> builtin_error dloc "Try to access an empty predefined"

+let get_predef name ctx = + let r = (get_size ctx) - !builtin_size in + let v = mkSusp (get_predef_raw name) (S.shift r) in + v + + let set_predef name lexp = SMap.find name predef_map := lexp

@@ -272,16 +281,6 @@ let write_impl loc depth args_val ctx = fprintf channel "%s" msg; Vdummy

- -(* - * Should we have a function that - * -> returns a new context inside typer ? (So we need to add a ctx type too) - * -> returns current context ? - * -> pexp_eval expr - * -> lexp_eval expr - * -> ou seulement: 'eval expr ctx' - *) - let is_lbuiltin idx ctx = let bsize = 1 in let csize = get_size ctx in @@ -290,3 +289,85 @@ let is_lbuiltin idx ctx = true else false + +(* -------------------------------------------------------------------------- + * Built-in Macro + * -------------------------------------------------------------------------- *) + +(* Those are function that are evaluated during lexp_parse *) + +let get_attribute_impl loc largs ctx ftype = + + let (vi, vn), (ai, an) = match largs with + | [Var((_, vn), vi); Var((_, an), ai)] -> (vi, vn), (ai, an) + | _ -> builtin_error loc "get-attribute expects two arguments" in + + let lxp = get_property ctx (vi, vn) (ai, an) in + let ltype = env_lookup_expr ctx ((loc, an), ai) in + lxp, ltype + +let new_attribute_impl loc largs ctx ftype = + + let eltp = match largs with + | [eltp] -> eltp + | _ -> builtin_warning loc "new-attribute expects one argument"; type0 in + + eltp, ftype + +let has_attribute_impl loc largs ctx ftype = + + let (vi, vn), (ai, an) = match largs with + | [Var((_, vn), vi); Var((_, an), ai)] -> (vi, vn), (ai, an) + | _ -> builtin_error loc "has-attribute expects two arguments" in + + let b = has_property ctx (vi, vn) (ai, an) in + + let rvar = if b then get_predef "True" ctx else get_predef "False" ctx in + rvar, (get_predef "Bool" ctx) + +let declexpr_impl loc largs ctx ftype = + + let (vi, vn) = match largs with + | [Var((_, vn), vi)] -> (vi, vn) + | _ -> builtin_error loc "declexpr expects one argument" in + + let lxp = env_lookup_expr ctx ((loc, vn), vi) in + let ltp = env_lookup_type ctx ((loc, vn), vi) in + lxp, ftype + + +let decltype_impl loc largs ctx ftype = + + let (vi, vn) = match largs with + | [Var((_, vn), vi)] -> (vi, vn) + | _ -> builtin_error loc "decltype expects one argument" in + + let ltype = env_lookup_type ctx ((loc, vn), vi) in + (* mkSusp prop (S.shift (var_i + 1)) *) + ltype, type0 + +let builtin_macro = [ + ("decltype", decltype_impl); + ("declexpr", declexpr_impl); + ("get-attribute", get_attribute_impl); + ("new-attribute", new_attribute_impl); + ("has-attribute", has_attribute_impl); +] + +type macromap = + (location -> lexp list -> lexp_context -> lexp -> (lexp * lexp)) SMap.t + +let macro_impl_map : macromap = + List.fold_left (fun map (name, funct) -> + SMap.add name funct map) SMap.empty builtin_macro + +let get_macro_impl loc name = + try SMap.find name macro_impl_map + with Not_found -> builtin_error loc ("Builtin macro" ^ name ^ " not found") + +let is_builtin_macro name = + try SMap.find name macro_impl_map; true + with Not_found -> false + + +

===================================== src/debruijn.ml ===================================== --- a/src/debruijn.ml +++ b/src/debruijn.ml @@ -123,20 +123,6 @@ let _name_error loc estr str = debruijn_error loc ("DeBruijn index refers to wrong name. " ^ "Expected: "" ^ estr ^ "" got "" ^ str ^ """)

-(* -let env_set_var_info ctx (def: vref) (v: lexp option) (t: lexp) = - let ((dv_size, _), info_env, _) = ctx in - let ((loc, ename), dbi) = def in - - try(let rf = (Myers.nth dbi info_env) in - let (_, (_, name), _, _) = !rf in - - (* Check if names match *) - _name_error loc ename name; - - rf := (0, (loc, ename), v, t)) - with - Not_found -> debruijn_error loc "DeBruijn index out of bounds!" *)

(* generic lookup *) let _env_lookup ctx (v: vref): env_elem = @@ -284,15 +270,3 @@ let dump_properties ctx = print_string (make_sep '-');

- - - - - - - - - - - -

===================================== src/eval.ml ===================================== --- a/src/eval.ml +++ b/src/eval.ml @@ -84,7 +84,7 @@ let rec _eval lxp ctx i: (value_type) = | Lambda ((_, n), lxp) -> Closure(n, lxp, ctx) | Builtin ((_, str)) -> Vbuiltin(str)

- (* Return a value stored in env *) + (* Return a value stored in env *) | Var((loc, name), idx) as e -> eval_var ctx e ((loc, name), idx)

@@ -101,13 +101,12 @@ let rec _eval lxp ctx i: (value_type) = | Case (loc, target, pat, dflt) -> (eval_case ctx i loc target pat dflt)

- | _ -> print_string "debug catch-all eval: "; - elexp_print lxp; print_string "\n"; Vdummy + | Type -> Vcons((tloc, "Unit"), [])

and get_predef_eval name ctx = let r = (get_rte_size ctx) - !builtin_size in - let v = mkSusp (get_predef name) (S.shift r) in + let v = mkSusp (get_predef_raw name) (S.shift r) in _eval (erase_type v) ctx 0

and eval_var ctx lxp v = @@ -250,7 +249,7 @@ and bind_impl loc depth args_val ctx = | Vcommand (cmd) -> cmd | _ -> builtin_error loc "bind first arguments must be a monad" in

- (* bind return another Vcommand *) + (* bind returns another Vcommand *) Vcommand (fun () -> (* get callback *) let body, ctx = match cb with

===================================== src/lparse.ml ===================================== --- a/src/lparse.ml +++ b/src/lparse.ml @@ -456,52 +456,60 @@ and lexp_call (fun_name: pexp) (sargs: sexp list) ctx i = Call(vf, new_args), ltp in

let handle_macro_call (loc, name) = - (* look up for definition *) - let idx = try senv_lookup name ctx - with Not_found -> - lexp_fatal loc ("Could not find Variable: " ^ name) in - - (* Get the macro *) - let lxp = try env_lookup_expr ctx ((loc, name), idx) - with Not_found -> - lexp_fatal loc (name ^ " was found but " ^ (string_of_int idx) ^ - " is not a correct index.") in - - let lxp = match unsusp_all lxp with - | Call(Var((_, "Macro_"), _), [(_, fct)]) -> fct - | _ -> - print_string "\n"; - print_string (lexp_to_string lxp); print_string "\n"; - lexp_print lxp; print_string "\n"; - lexp_fatal loc "Macro is ill formed" in - - (* Build function to be called *) - let arg = olist2tlist_lexp sargs ctx in - - let lxp = Call(lxp, [(Aexplicit, arg)]) in - let elexp = EL.erase_type lxp in - let rctx = (from_lctx ctx 0) in - - _global_eval_trace := []; - - let vxp = try eval elexp rctx - with e -> - print_eval_trace (); - raise e in - - let sxp = match vxp with - | Vsexp(sxp) -> sxp - (* Those are sexp converted by the eval function *) - | Vint(i) -> Integer(dloc, i) - | Vstring(s) -> String(dloc, s) - | Vfloat(f) -> Float(dloc, f) - (* I have vdum here WHY *) - | v -> debug_msg (value_print v); - lexp_fatal loc "Macro_ expects '(List Sexp) -> Sexp'" in + (* check for builtin *) + match is_builtin_macro name with + | true -> + let pargs = List.map pexp_parse sargs in + let largs = _lexp_parse_all pargs ctx i in + (get_macro_impl loc name) loc largs ctx ltp

+ (* user defined macro *) + | false ->( + (* look up for definition *) + let idx = try senv_lookup name ctx + with Not_found -> + lexp_fatal loc ("Could not find Variable: " ^ name) in

- let pxp = pexp_parse sxp in - _lexp_p_infer pxp ctx (i + 1) in + (* Get the macro *) + let lxp = try env_lookup_expr ctx ((loc, name), idx) + with Not_found -> + lexp_fatal loc (name ^ " was found but " ^ (string_of_int idx) ^ + " is not a correct index.") in + + let lxp = match unsusp_all lxp with + | Call(Var((_, "Macro_"), _), [(_, fct)]) -> fct + | _ -> + print_string "\n"; + print_string (lexp_to_string lxp); print_string "\n"; + lexp_print lxp; print_string "\n"; + lexp_fatal loc "Macro is ill formed" in + + (* Build function to be called *) + let arg = olist2tlist_lexp sargs ctx in + + let lxp = Call(lxp, [(Aexplicit, arg)]) in + let elexp = EL.erase_type lxp in + let rctx = (from_lctx ctx 0) in + + _global_eval_trace := []; + + let vxp = try eval elexp rctx + with e -> + print_eval_trace (); + raise e in + + let sxp = match vxp with + | Vsexp(sxp) -> sxp + (* Those are sexp converted by the eval function *) + | Vint(i) -> Integer(dloc, i) + | Vstring(s) -> String(dloc, s) + | Vfloat(f) -> Float(dloc, f) + (* I have vdum here WHY *) + | v -> debug_msg (value_print v); + lexp_fatal loc "Macro_ expects '(List Sexp) -> Sexp'" in + + let pxp = pexp_parse sxp in + _lexp_p_infer pxp ctx (i + 1)) in

(* determine function type *) match fun_name, ltp with @@ -513,59 +521,8 @@ and lexp_call (fun_name: pexp) (sargs: sexp list) ctx i = let new_args = List.map (fun g -> (Aexplicit, g)) largs in Call(body, new_args), ltp

- (* Context acessor *) - | Pvar(l, "decltype"), _ -> - let pargs = List.map pexp_parse sargs in - let largs = _lexp_parse_all pargs ctx i in - let (vi, vn) = match largs with - | [Var((_, vn), vi)] -> (vi, vn) - | _ -> lexp_fatal l "decltype expects one argument" in - - let ltype = env_lookup_type ctx ((dloc, vn), vi) in - (* mkSusp prop (S.shift (var_i + 1)) *) - ltype, dltype - - | Pvar(l, "declexpr"), _ -> - let pargs = List.map pexp_parse sargs in - let largs = _lexp_parse_all pargs ctx i in - let (vi, vn) = match largs with - | [Var((_, vn), vi)] -> (vi, vn) - | _ -> lexp_fatal l "declexpr expects one argument" in - - let lxp = env_lookup_expr ctx ((dloc, vn), vi) in - let ltp = env_lookup_type ctx ((dloc, vn), vi) in - lxp, ltp - - (* attributes are special case they does not exist after lexp_parsing - * in that respect they are quite similar to macros *) - | Pvar(l, "get-attribute"), _ -> - let pargs = List.map pexp_parse sargs in - let largs = _lexp_parse_all pargs ctx i in - let (vi, vn), (ai, an) = match largs with - | [Var((_, vn), vi); Var((_, an), ai)] -> (vi, vn), (ai, an) - | _ -> lexp_fatal l "get-attribute expects two arguments" in - - let lxp = get_property ctx (vi, vn) (ai, an) in - let ltype = env_lookup_expr ctx ((dloc, an), ai) in - lxp, ltype - - (* - | Pvar(l, "has-attribute"), _ -> *) - - - | Pvar(l, "new-attribute"), _ -> - let pargs = List.map pexp_parse sargs in - let largs = _lexp_parse_all pargs ctx i in - - let eltp = match largs with - | [eltp] -> eltp - | _ -> lexp_warning l "new-attribute expects one argument"; - dltype in - - eltp, ltp - | (Pvar (l, n), Var((_, "Macro"), _)) -> - (* FIXME: check db_idx points too a Macro type *) + (* FIXME: check db_idx points to a Macro type *) handle_macro_call (l, n)

(* Call to Vanilla or constructor *) @@ -1032,8 +989,7 @@ let default_lctx = try List.iter (fun name -> let idx = senv_lookup name lctx in - let v = Var((dloc, name), idx) in (* - let value = (env_lookup_expr lctx v) in *) + let v = Var((dloc, name), idx) in set_predef name (Some v)) predef_name; (* -- DONE -- *) lctx

View it on GitLab: https://gitlab.com/monnier/typer/commit/f530a2dd9a0dcf5222be0c4966f3690239d2...