Setepenre pushed to branch master at Stefan / Typer

Commits: 29ba9a05 by Pierre Delaunay at 2016-06-14T17:05:37-04:00 remove dead code

- - - - - 1bf06575 by Pierre Delaunay at 2016-06-14T17:56:19-04:00 Handle macro decls

Changes to be committed: * src/debug_util.ml : added some debug options * src/lparse.ml : Handle macro decls * src/eval.ml : - added (run-io) - new function (get_predef_eval) retuns a evaluated predef * btl/types.typer : added (run-io)

- - - - -

5 changed files:

- btl/types.typer - src/builtin.ml - src/debug_util.ml - src/eval.ml - src/lparse.ml

Changes:

===================================== btl/types.typer ===================================== --- a/btl/types.typer +++ b/btl/types.typer @@ -134,6 +134,11 @@ bind = Built-in "bind" ( FileHandle = Built-in "FileHandle";

% define operation on file handle +run-io = Built-in "run-io" ( + (a : Type) ≡> + (b : Type) ≡> + IO a -> (a -> IO b) -> (IO b) -> Unit); + open = Built-in "open" (String -> String -> IO FileHandle); write = Built-in "write" (FileHandle -> String -> IO Unit); read = Built-in "read" (FileHandle -> Int -> IO String); @@ -143,7 +148,7 @@ 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" (Type -> Attribute);

===================================== src/builtin.ml ===================================== --- a/src/builtin.ml +++ b/src/builtin.ml @@ -51,9 +51,12 @@ type predef_table = (lexp option ref) SMap.t

let predef_name = [ "cons"; - "nil" + "nil"; + "Unit" ]

+let builtin_size = ref 0 + let predef_map : predef_table = (* add predef name, expr will be populated when parsing *) List.fold_left (fun m name -> @@ -271,6 +274,7 @@ let new_attribute loc args_val ctx = builtin_warning loc "new-attributes to be implemented"; Vdummy

+ (* * Should we have a function that * -> returns a new context inside typer ? (So we need to add a ctx type too)

===================================== src/debug_util.ml ===================================== --- a/src/debug_util.ml +++ b/src/debug_util.ml @@ -275,71 +275,55 @@ let main () = let octx = default_lctx in

(* Debug declarations merging *) + (if (get_p_option "merge-debug") then( + let merged = lexp_detect_recursive pexps in

- (** ) - let merged = lexp_detect_recursive pexps in + List.iter (fun lst -> + print_string (make_line '-' 80); + print_string "\n";

- let _ = List.iter (fun lst -> - print_string (make_line '-' 80); - print_string "\n"; + List.iter (fun v -> + match v with + | Ldecl((l, s), pxp, ptp) -> ( + lalign_print_string s 20;

- List.iter (fun v -> - match v with - | Ldecl((l, s), pxp, ptp) -> ( - lalign_print_string s 20; + let _ = match ptp with + | Some pxp -> pexp_print pxp; + | None -> print_string " " in

- let _ = match ptp with - | Some pxp -> pexp_print pxp; - | None -> print_string " " in + print_string "\n"; + lalign_print_string s 20;

- print_string "\n"; - lalign_print_string s 20; + let _ = match pxp with + | Some pxp -> pexp_print pxp; + | None -> print_string " " in

- let _ = match pxp with - | Some pxp -> pexp_print pxp; - | None -> print_string " " in + print_string "\n") + | Lmcall((l, s), _ ) -> + print_string s; print_string "\n" + ) lst;

- print_string "\n") - | Lmcall((l, s), _ ) -> - print_string s; print_string "\n" - ) lst; - - ) merged in ( **) + ) merged));

(* debug lexp parsing once merged *) let lexps, nctx = _lexp_decls pexps octx 0 in - - (* - List.iter (fun ((l, s), lxp, ltp) -> - lalign_print_string s 20; - lexp_print ltp; print_string "\n"; - - lalign_print_string s 20; - lexp_print lxp; print_string "\n"; - - ) decls; *) - (* use the new way of parsing expr *) let ctx = nctx in let flexps = List.flatten lexps in

- (* convert a lctx context into a typecheck context *) - (* they will be the same in the future *) + (if (get_p_option "lexp-merge-debug") then( + List.iter (fun ((l, s), lxp, ltp) -> + lalign_print_string s 20; + lexp_print ltp; print_string "\n"; + + lalign_print_string s 20; + lexp_print lxp; print_string "\n"; + + ) flexps)); + + (* get typecheck context *) let lctx_to_cctx (lctx: lexp_context) = let (_, env, _) = ctx in env in - (* - let (_, env, _) = lctx in - let n = Myers.length env in - - let rec loop i env cctx = - if i = (-1) then cctx else ( - let i, v, olxp, ltp = !(Myers.nth i env) in - let vlxp = match olxp with - | Some lxp -> TC.LetDef lxp - | None -> TC.ForwardRef in - let cctx = Myers.cons (i, Some v, vlxp, ltp) cctx in - loop (i - 1) env cctx) in - loop n env Myers.nil in *)

(if (get_p_option "typecheck") then( print_string (make_title " TYPECHECK "); @@ -349,9 +333,8 @@ let main () = List.iter (fun (_, lxp, _) -> let _ = TC.check cctx lxp in ()) flexps;

- print_string (make_line '-' 76); - - )); + print_string (" " ^ (make_line '-' 76)); + print_string "\n";));

(if (get_p_option "lexp") then( print_string (make_title " Lexp "); @@ -360,20 +343,8 @@ let main () = (if (get_p_option "lctx") then( print_lexp_ctx nctx; print_string "\n"));

- - (* - List.iter (fun ((_, n), lxp, _) -> - print_string n; print_string "\n") - (List.flatten lexps); *) - let clean_lxp = EL.clean_toplevel lexps in

- (* - List.iter (fun ((_, n), lxp) -> - print_string n; print_string "\n"; - ) (List.flatten clean_lxp); - *) - (* Eval declaration *) let rctx = default_rctx in print_string yellow;

===================================== src/eval.ml ===================================== --- a/src/eval.ml +++ b/src/eval.ml @@ -61,6 +61,7 @@ let _eval_max_recursion_depth = ref 255 let reset_eval_trace () = _global_eval_trace := [] let _builtin_lookup = ref SMap.empty

+ (* This is an internal definition * 'i' is the recursion depth used to print the call trace *) let rec _eval lxp ctx i: (value_type) = @@ -103,6 +104,12 @@ let rec _eval lxp ctx i: (value_type) = | _ -> print_string "debug catch-all eval: "; elexp_print lxp; print_string "\n"; Vstring("eval Not Implemented")

+ +and get_predef_eval name ctx = + let r = (get_rte_size ctx) - !builtin_size + 1in + let v = mkSusp (get_predef name) (S.shift r) in + _eval (erase_type v) ctx 0 + and eval_var ctx lxp v = let ((loc, name), idx) = v in try get_rte_variable (Some name) (idx) ctx @@ -111,38 +118,38 @@ and eval_var ctx lxp v =

and eval_call ctx i lname eargs = let loc = elexp_location lname in - let args = List.map (fun e -> - (* elexp_print e; print_string "\n"; *) - _eval e ctx (i + 1)) eargs in let f = _eval lname ctx (i + 1) in

+ (* standard function *) let rec eval_call f args ctx = - match f, args with - | Vcons (n, []), _ -> - let e = Vcons(n, args) in - (* value_print e; print_string "\n"; *) e - - (* we add an argument to the closure *) - | Closure (n, lxp, ctx), hd::tl -> - let nctx = add_rte_variable (Some n) hd ctx in - let ret = _eval lxp nctx (i + 1) in - eval_call ret tl nctx - - (* bind is lazily evaluated *) - | Vbuiltin ("bind"), _ -> - Vbind eargs - - | Vbuiltin (str), args -> - (* lookup the built-in implementation and call it *) - (get_builtin_impl str loc) loc args ctx - - (* return result of eval *) - | _, [] -> f - - | _ -> debug_msg (value_print f); - eval_error loc "Cannot eval function" in - - eval_call f args ctx + match f, args with + | Vcons (n, []), _ -> + let e = Vcons(n, args) in + (* value_print e; print_string "\n"; *) e + + (* we add an argument to the closure *) + | Closure (n, lxp, ctx), hd::tl -> + let nctx = add_rte_variable (Some n) hd ctx in + let ret = _eval lxp nctx (i + 1) in + eval_call ret tl nctx + + | Vbuiltin (str), args -> + (* lookup the built-in implementation and call it *) + (get_builtin_impl str loc) loc args ctx + + (* return result of eval *) + | _, [] -> f + + | _ -> debug_msg (value_print f); + eval_error loc "Cannot eval function" in + + (* eval function here *) + match f with + (* Does not eval args *) + | Vbuiltin ("bind") -> Vbind eargs + | _ -> + let args = List.map (fun e -> _eval e ctx (i + 1)) eargs in + eval_call f args ctx

and eval_case ctx i loc target pat dflt = (* Eval target *) @@ -231,6 +238,7 @@ and typer_builtins_impl = [ ("eval_" , typer_eval); ("open" , open_impl); ("bind" , bind_impl); + ("run-io" , run_io); ("read" , read_impl); ("write" , write_impl); ("new-attribute" , new_attribute) @@ -253,6 +261,20 @@ and bind_impl loc args_val ctx = (* eval callback *) _eval body nctx 0

+and run_io loc args_val ctx = + + let io, callback = match args_val with + | [Vbind([io; callback])] -> io, callback + | _ -> builtin_error loc "run-io expects a single Vbind argument" in + + (* eval args *) + let io = _eval io ctx 0 in + let callback = _eval callback ctx 0 in + + (* eval bind *) + let a = bind_impl loc [io; callback] ctx in + get_predef_eval "Unit" ctx + and typer_eval loc args ctx = let arg = match args with | [a] -> a

===================================== src/lparse.ml ===================================== --- a/src/lparse.ml +++ b/src/lparse.ml @@ -484,26 +484,6 @@ and lexp_call (fun_name: pexp) (sargs: sexp list) ctx i = let elexp = EL.erase_type lxp in let rctx = (from_lctx ctx 0) in

- (* - let rargs = eval (EL.erase_type arg) rctx in - let rctx = add_rte_variable None rargs rctx in - - let lxp = Susp(lxp, (SU.shift 1)) in - let body = eval (EL.erase_type lxp) rctx in - - print_string "HERE2\n"; - value_print body; *) - (* - - print_string "\n\n"; - lexp_print lxp; print_string "\n\n"; *) - - (* print_string "DH: "; - value_print (eval (EL.erase_type arg) rctx); print_string "\n"; *) - (* - print_rte_ctx rctx; print_string "\n"; - print_lexp_ctx ctx; print_string "\n";*) - _global_eval_trace := [];

let vxp = try eval elexp rctx @@ -525,34 +505,6 @@ and lexp_call (fun_name: pexp) (sargs: sexp list) ctx i = let pxp = pexp_parse sxp in _lexp_p_infer pxp ctx (i + 1) in

- (* - let handle_qq loc = - (* In quasi quote we need to traverse the sexp tree and evaluate - * (uq) calls *) - - let rec seek_n_replace sxp = - match sxp with - (* Unquote *) - | Node (Symbol(_, "uquote"), [arg]) ->( - let parg = pexp_parse arg in - let larg, _ = _lexp_p_infer parg ctx i in - let vsxp = eval larg (from_lctx ctx) in - match vsxp with - | Vint (i) -> Integer(loc, i) - | Vstring (s) -> String (loc, s) - | Vsexp(sxp) -> sxp - | _ -> - value_print vsxp; - lexp_warning loc "Sexp was expected"; Epsilon) - - | Node (op, lst) -> Node(op, (List.map seek_n_replace lst)) - | _ -> sxp in - - let sxp = match sargs with - | [sxp] -> seek_n_replace sxp - | _ -> lexp_error loc "qquote expects a sexp"; Epsilon in - Imm(sxp), type_sexp in *) - (* determine function type *) match fun_name, ltp with (* Anonymous *) @@ -797,9 +749,19 @@ and _lexp_decls decls ctx i: ((vdef * lexp * ltype) list list * lexp_context) = let all = ref [] in

let ctx = List.fold_left (fun ctx decl -> - let d, ctx = _lexp_rec_decl decl ctx i in - all := d::!all; - ctx) ctx decls in + match decl with + (* Special case *) + | [Lmcall ((l, s), sargs)] -> + (* get pexp decls *) + let pdecls = lexp_decls_macro (l, s) sargs ctx in + let decls, ctx = _lexp_decls pdecls ctx i in + all := (List.append (List.rev decls) !all); + ctx + + | _ -> + let d, ctx = _lexp_rec_decl decl ctx i in + all := d::!all; + ctx) ctx decls in

(List.rev !all), ctx

@@ -853,171 +815,9 @@ and _lexp_rec_decl decls ctx i =

(List.rev !lst), ctx

- (* -and _lexp_decls decls ctx i: (((vdef * lexp * ltype) list list) * lexp_context) = - - let names = ref [] in (* decls name in correct order *) - let glob = ref SMap.empty in - let mut = ref [] in - let offset = ref 1 in - let last_decls = ref "" in - let recursive_mode = ref false in - - let ctx = List.fold_left (fun vctx expr -> - _global_lexp_trace := []; - match expr with - | Pexpr((l, s), pxp) ->( - try let idx = senv_lookup s vctx in - let ltp = env_lookup_type vctx ((l, s), idx) in - let lxp = lexp_p_check pxp ltp vctx in - (* update declaration *) - glob := SMap.add s (l, s, Some lxp, ltp) !glob; - - (* check if recursive definition *) - (if !last_decls = s && !recursive_mode then - ( - (* print_string "RECURSIVE END\n"; *) - (* push every variable with the correct offset *) - let d = List.rev !mut in - let length = (List.length d) + 1 in - let j = ref 0 in - - let vctx = - List.fold_left (fun vctx n -> - let (l, s, lxp, ltp) = SMap.find n !glob in - let lxp = match lxp with - | Some lxp -> LetDef lxp - | None -> lexp_warning dloc "ForwardRef are not allowed"; - ForwardRef in - - j := !j + 1; - replace_by vctx s (length - !j, Some (l, s), lxp, ltp)) vctx d - - in - - (* Clean everything *) - mut := []; - last_decls := ""; - recursive_mode := false; - vctx - ) - else - ( - (if !recursive_mode then offset := !offset + 1); - (* update context *) - replace_by vctx s (1, Some (l, s), (LetDef lxp), ltp); - )); - - with Not_found -> - (* Add dummy first *) - let tctx = env_extend vctx (l, s) ForwardRef dltype in - let lxp, ltp = lexp_p_infer pxp tctx in - - names := [s]::!names; - - (if !recursive_mode then ( - offset := !offset + 1; - mut := s::!mut)); - - glob := SMap.add s (l, s, Some lxp, ltp) !glob; - - env_extend vctx (l, s) (LetDef lxp) ltp) - - | Ptype((l, s), ptp) -> - (if !recursive_mode then () else - last_decls := s; - offset := 1); - - recursive_mode := true; - names := [s]::!names; - mut := s::!mut; - - (* get type *) - let ltp, _ = lexp_p_infer ptp vctx in - (* push *) - glob := SMap.add s (l, s, None, ltp) !glob; - env_extend vctx (l, s) ForwardRef ltp - - | Pmcall((l, n), sargs) -> ( - let pdecls = lexp_decls_macro (l, n) sargs vctx in - let _, _ =_lexp_decls pdecls vctx (i + 1) in - - vctx) - - (* | _ -> vctx*)) ctx decls in - - (* - (if List.length !mut != 0 then names := !mut::!names); *) - - (* return a list containing mutually recursive def *) - let merge_list names = - List.fold_left (fun acc key -> - let (l, s, lxp, ltp) = SMap.find key !glob in - let lxp = match lxp with - | Some lxp -> lxp - | None -> dltype in - - (* - let ltp = unsusp_all ltp in - let lxp = unsusp_all lxp in *) - ((l, s), lxp, ltp)::acc) [] names in - - let decls = List.map (fun names -> - merge_list names) (List.rev !names) in - - decls, ctx -*) - and lexp_decls_toplevel decls ctx = _lexp_decls decls ctx 1

- (* let names = ref [] in - let offset = ref 0 in - let merged = ref SMap.empty in - let acc = ref [] in - - let ctx = List.fold_left (fun vctx expr -> - match expr with - | Pexpr ((l, s), pxp) ->( - try let idx = senv_lookup s vctx in - let ltp = env_lookup_type vctx ((l, s), idx) in - let lxp = lexp_p_check pxp ltp vctx in - let (_, _, _, ltp) = SMap.find s !merged in - merged := SMap.add s (l, s, Some lxp, ltp) !merged; - let r = !offset in - let r = if r = 0 then 1 else r in - offset := 0; - replace_by vctx s (r, Some (l, s), (LetDef lxp), ltp); - - with Not_found -> - (* Add dummy first *) - let tctx = env_extend vctx (l, s) ForwardRef dltype in - let lxp, ltp = lexp_p_infer pxp tctx in - names := s::!names; - merged := SMap.add s (l, s, Some lxp, ltp) !merged; - env_extend vctx (l, s) (LetDef lxp) ltp) - - | Ptype ((l, s), ptp) -> - offset := !offset + 1; - let ltp, _ = lexp_p_infer ptp vctx in - names := s::!names; - merged := SMap.add s (l, s, None, ltp) !merged; - env_extend vctx (l, s) ForwardRef ltp - - | _ -> vctx) ctx decls in - - (* merge type and expr *) - let decls = List.fold_left (fun acc key -> - let (l, s, lxp, ltp) = SMap.find key !merged in - let lxp = match lxp with - | Some lxp -> lxp - | None -> dltype in - let ltp = unsusp_all ltp in - let lxp = unsusp_all lxp in - ((l, s), lxp, ltp)::acc) [] !names in - - decls, ctx *) - and _lexp_parse_all (p: pexp list) (ctx: lexp_context) i : lexp list =

let rec loop (plst: pexp list) ctx (acc: lexp list) = @@ -1160,6 +960,8 @@ let default_lctx = List.iter (fun ((_, s), _, _) -> print_string (s ^ ", ")) decls; print_string "] \n") d; *)

+ builtin_size := get_size lctx; + (* Once default builtin are set we can populate the predef table *) try List.iter (fun name -> @@ -1194,13 +996,6 @@ let default_rctx = let rctx = eval_decls_toplevel (EL.clean_toplevel d) rctx in _global_eval_trace := []; rctx - (* - try (from_lctx (default_lctx)) - with e ->( - print_eval_trace (); - lexp_error dloc "Could not convert lexp context into rte context"; - raise e) *) -

(* String Parsing * --------------------------------------------------------- *)

View it on GitLab: https://gitlab.com/monnier/typer/compare/2fb51647589a69593283abdd1774b8c66e7...