Setepenre pushed to branch master at Stefan / Typer
Commits: 0ae8be8b by Pierre Delaunay at 2016-09-12T20:55:36-04:00 Changes to be committed: * src/lparse.ml: Fix `case` handling
`case` now looks up the pattern type and add them to the environement. Which allows us to write things like:
`case m | Macro_ f => f args;`
(before a dummy type was added, thus an error occured because f was not considered a function)
* src/util.ml: improved `print_trace` behavior print the last 50 call recorded instead of the first 50
* btl/types.typer * src/eval.ml - expand_macro is now defined in typer
- - - - -
7 changed files:
- btl/types.typer - src/builtin.ml - src/debruijn.ml - src/eval.ml - src/fmt.ml - src/lparse.ml - src/util.ml
Changes:
===================================== btl/types.typer ===================================== --- a/btl/types.typer +++ b/btl/types.typer @@ -107,7 +107,10 @@ float_ = Built-in "float_" (Float -> Sexp); Macro = inductive_ (dMacro) (Macro_ (List Sexp -> Sexp)); Macro_ = inductive-cons Macro Macro_ ;
-expand_macro_ = Built-in "expand_macro_" (Macro -> List Sexp -> Sexp); +% expand_macro_ = Built-in "expand_macro_" (Macro -> List Sexp -> Sexp); +expand_macro_ : Macro -> List Sexp -> Sexp; +expand_macro_ m args = case m + | Macro_ f => (f args);
sexp_dispatch_ = Built-in "sexp_dispatch_" ( (a : Type) ≡>
===================================== src/builtin.ml ===================================== --- a/src/builtin.ml +++ b/src/builtin.ml @@ -72,7 +72,7 @@ let predef_map = ref default_predef_map 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" + | None -> builtin_error dloc ("""^ name ^ "" was not predefined")
let get_predef_option (name: string) ctx = let r = (get_size ctx) - !builtin_size - 1 in @@ -158,8 +158,8 @@ let make_symbol loc depth args_val ctx =
(* lexp Imm list *) let olist2tlist_lexp lst ctx = - let tcons = get_predef "cons" ctx in - let tnil = get_predef "nil" ctx in + let tcons = get_predef "cons" ctx in + let tnil = get_predef "nil" ctx in
let rlst = List.rev lst in List.fold_left (fun tail elem ->
===================================== src/debruijn.ml ===================================== --- a/src/debruijn.ml +++ b/src/debruijn.ml @@ -144,8 +144,7 @@ let env_lookup_expr ctx (v : vref): lexp option = let (r, _, lxp, _) = _env_lookup ctx v in match lxp with | LetDef lxp -> Some (L.push_susp lxp (S.shift (idx + 1 - r))) - (* FIXME: why Sort here? *) - | _ -> None + | _ -> None
let env_lookup_by_index index (ctx: lexp_context): env_elem = (Myers.nth index (_get_env ctx))
===================================== src/eval.ml ===================================== --- a/src/eval.ml +++ b/src/eval.ml @@ -236,7 +236,6 @@ and typer_builtins_impl = [ ("run-io" , run_io); ("read" , read_impl); ("write" , write_impl); - ("expand_macro_" , expand_macro_impl) ]
and expand_macro_impl loc depth (args_val : value_type list) ctx =
===================================== src/fmt.ml ===================================== --- a/src/fmt.ml +++ b/src/fmt.ml @@ -137,6 +137,20 @@ let print_first n l f = else () in loop 0 l
+let print_last n l f = + let len = List.length l in + let start = if (len - n) < 0 then 0 else (len - n) in + + let rec loop i l = + match l with + | [] -> () + | hd::tl -> + if (len > n) && (i <= start) then loop (i + 1) tl + else ((f i hd); loop (i + 1) tl) in + + loop 0 l + + (* Colors *) let red = "\x1b[31m" let green = "\x1b[32m"
===================================== src/lparse.ml ===================================== --- a/src/lparse.ml +++ b/src/lparse.ml @@ -306,6 +306,9 @@ and _lexp_p_check (p : pexp) (t : ltype) (ctx : lexp_context) i: lexp = let lxp, _ = lexp_case (Some t) (loc, target, patterns) ctx i in lxp
+ (* handle pcall here * ) + | Pcall (fname, _args) -> *) + | _ -> let (e, inferred_t) = _lexp_p_infer p ctx (i + 1) in e (* match e with @@ -401,7 +404,9 @@ and lexp_call (func: pexp) (sargs: sexp list) ctx i = * Anonymous : lambda *)
(* retrieve function's body *) + let body, ltp = _lexp_p_infer func ctx (i + 1) in + (* pexp_print func; print_string "\t"; lexp_print ltp; print_string "\n"; *) let ltp = nosusp ltp in
let rec handle_fun_args largs sargs ltp = match sargs with @@ -429,7 +434,9 @@ and lexp_call (func: pexp) (sargs: sexp list) ctx i = sexp_print sarg; print_string "\n"; lexp_fatal (sexp_location sarg) "Expected non-explicit arg" - | _ -> lexp_fatal (sexp_location sarg) + | t -> + lexp_print t; print_string "\n"; + lexp_fatal (sexp_location sarg) "Explicit arg to non-function") in
let handle_funcall () = @@ -483,7 +490,7 @@ and lexp_call (func: pexp) (sargs: sexp list) ctx i = | Vstring(s) -> String(dloc, s) | Vfloat(f) -> Float(dloc, f) (* I have vdum here WHY *) - | v -> debug_msg (value_print v); + | v -> debug_msg (value_print v); print_string "\n"; lexp_fatal loc "Macro_ expects '(List Sexp) -> Sexp'" in
let pxp = pexp_parse sxp in @@ -498,10 +505,12 @@ and lexp_call (func: pexp) (sargs: sexp list) ctx i =
(* determine function type *) match func, ltp with + (* FIXME: this branch is never used because of missing shift somewhere *) + (* while special form have a type macro this does not recognize them as such *) | macro, _ when OL.conv_p ltp macro_type -> ( match macro with - (* Special form *) | Pvar(l, name) when is_builtin_macro name -> + print_string name; 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 @@ -512,6 +521,21 @@ and lexp_call (func: pexp) (sargs: sexp list) ctx i = (* FIXME: Handle special-forms here as well! *) | _ -> handle_funcall ()
+(* return the inductive type declaration from the constructor *) +and lexp_get_inductive_type loc ctor_name ctx : (string * lexp option) = + let cons_idx = senv_lookup ctor_name ctx in + let cons = match env_lookup_expr ctx ((loc, ctor_name), cons_idx) with + | Some lxp -> lxp + | None -> lexp_warning loc ("constructor "" ^ ctor_name ^ "" not found"); dltype in + + (* get inductive type index *) + match cons with + | Cons(((_, name), idx), _) -> + (* get inductive type declaration *) + name, env_lookup_expr ctx ((loc, name), idx + cons_idx) + + | _ -> lexp_warning loc (ctor_name ^ " is not a constructor"); + "", None
(* Read a pattern and create the equivalent representation *) and lexp_read_pattern pattern exp target ctx: @@ -541,33 +565,68 @@ and lexp_read_pattern pattern exp target ctx: (name, loc, []), nctx)
| Ppatcons (ctor_name, args) -> - let (loc, name) = ctor_name in + let (loc, cons_name) = ctor_name in + + (* We need the constructor type info *) + let inductive_name, inductive_ref = match lexp_get_inductive_type loc cons_name ctx with + | name, Some lxp -> name, lxp + | _ -> "", dltype in + + (*get cons argument types *) + let cons_args = match inductive_ref with + | Inductive(_, _, _, map) -> try SMap.find cons_name map + with Not_found -> lexp_warning loc + (inductive_name ^ " does not hold a " ^ cons_name ^ " constructor"); [] + | _ -> [] in + + (* remove non explicit argument *) + let rec remove_nexplicit args acc = + match args with + | [] -> List.rev acc + | (Aexplicit, _, ltp)::tl -> remove_nexplicit tl (ltp::acc) + | hd::tl -> remove_nexplicit tl acc in + + let cons_args = remove_nexplicit cons_args [] in
(* read pattern args *) - let args, nctx = lexp_read_pattern_args args ctx in - (name, loc, args), nctx + let args, nctx = lexp_read_pattern_args args cons_args ctx in + (cons_name, loc, args), nctx
(* Read patterns inside a constructor *) -and lexp_read_pattern_args args ctx: +and lexp_read_pattern_args args (args_type : lexp list) ctx: (((arg_kind * vdef option) list) * lexp_context)=
- let rec loop args acc ctx = - match args with - | [] -> (List.rev acc), ctx - | hd::tl -> ( + let length_type = List.length args_type in + let length_pat = List.length args in + + let make_list elem size = + let rec loop i acc = + if i < size then loop (i + 1) (elem::acc) else acc + in loop 0 [] in + + let args_type = if length_type != length_pat then + make_list dltype length_pat else args_type in + + (if length_type != length_pat then lexp_warning dloc "Size Mismatch"); + + let rec loop args args_type acc ctx = + match args, args_type with + | [], _ -> (List.rev acc), ctx + | hd::tl, ltp::type_tl -> ( let (_, pat) = hd in match pat with (* Nothing to do *) - | Ppatany (loc) -> loop tl ((Aexplicit, None)::acc) ctx + | Ppatany (loc) -> loop tl type_tl ((Aexplicit, None)::acc) ctx | Ppatvar ((loc, name) as var) -> + (* FIXME dltype does not cut it here *) (* Add var *) - let nctx = env_extend ctx var Variable dltype in + let nctx = env_extend ctx var Variable ltp in let nacc = (Aexplicit, Some var)::acc in - loop tl nacc nctx + loop tl type_tl nacc nctx | _ -> lexp_error dloc "Constructor inside a Constructor"; - loop tl ((Aexplicit, None)::acc) ctx) + loop tl type_tl ((Aexplicit, None)::acc) ctx)
- in loop args [] ctx + in loop args args_type [] ctx
(* Parse inductive type definition. *) and lexp_parse_inductive ctors ctx i =
===================================== src/util.ml ===================================== --- a/src/util.ml +++ b/src/util.ml @@ -112,7 +112,7 @@ let print_trace name max elem_to_string print_elem trace = print_string (Fmt.make_sep '-');
let racc = List.rev trace in - Fmt.print_first max racc (fun j (i, l, g) -> + Fmt.print_last max racc (fun j (i, l, g) -> print_string " ["; print_loc l; print_string "] "; Fmt._print_ct_tree i; print_string "+- "; print_string (elem_to_string g); print_string ": ";
View it on GitLab: https://gitlab.com/monnier/typer/commit/0ae8be8b45a9e7957dc2c14a377a667d9016...