Setepenre pushed to branch master at Stefan / Typer
Commits: 20316043 by Pierre Delaunay at 2016-06-03T16:05:02-04:00 Macro decls
Changes to be committed: * src/lparse.ml - partial macro-decls handling
- - - - - f14a2378 by Pierre Delaunay at 2016-06-06T13:13:55-04:00 add property map and remove some warnings
Changes to be committed: * src/debruijn.ml * src/env.ml * src/lparse.ml
- - - - -
3 changed files:
- src/debruijn.ml - src/env.ml - src/lparse.ml
Changes:
===================================== src/debruijn.ml ===================================== --- a/src/debruijn.ml +++ b/src/debruijn.ml @@ -46,15 +46,22 @@ let debruijn_warning = msg_warning "DEBRUIJN" (* Type definitions * ---------------------------------- *)
-(* easier to debug with type annotations *) -type env_elem = (int * vdef option * varbind * ltype) -type env_type = env_elem myers
+type property_key = (int * string) (* rev_dbi * Var name *) +module PropertyMap + = Map.Make (struct type t = property_key let compare = compare end)
-(* This exist because I don't want that file to depend on anything *) module StringMap = Map.Make (struct type t = string let compare = String.compare end)
+(* (* rev_dbi * Var name *) => (name * lexp) *) +type property_elem = lexp StringMap.t +type property_env = property_elem PropertyMap.t + +(* easier to debug with type annotations *) +type env_elem = (int * vdef option * varbind * ltype) +type env_type = env_elem myers + type db_idx = int (* DeBruijn index. *) type db_ridx = int (* DeBruijn reverse index (i.e. counting from the root). *)
@@ -64,24 +71,7 @@ type scope = db_ridx StringMap.t (* Map<String, db_ridx>*) type senv_length = int (* it is not the map true length *) type senv_type = senv_length * scope
-(* - * outer_size represent the size of the context before entering a "temporary" scope - * (i.e, function call, case, lambda...) - * it is used to determine if a variable is bound or not - * - * if var_idx > outer_ctx_size - current_ctx_size then - * free_variable - * else - * bound_variable - * - * r_offset was used when parsing declarations. It represented the index of - * the declaration being parsed - * - * Both were used in an older version I left them as we may need to determine - * if a variable is free or not later on - *) -(* name -> index * index -> info * (outer_size, r_offset) *) -type lexp_context = senv_type * env_type * (int * int) +type lexp_context = senv_type * env_type * property_env
(* internal definitions * ---------------------------------- *) @@ -94,7 +84,7 @@ let _get_env(ctx: lexp_context): env_type = let (_, ev, _) = ctx in ev (* Public methods: DO USE * ---------------------------------- *)
-let make_lexp_context = (_make_senv_type, _make_myers, (0, 0)) +let make_lexp_context = (_make_senv_type, _make_myers, PropertyMap.empty)
let get_roffset ctx = let (_, _, (_, rof)) = ctx in rof
@@ -102,7 +92,7 @@ let get_size ctx = let ((n, _), _, _) = ctx in n
(* return its current DeBruijn index *) let rec senv_lookup (name: string) (ctx: lexp_context): int = - let ((n, map), _, (csize, rof)) = ctx in + let ((n, map), _, _) = ctx in let raw_idx = n - (StringMap.find name map) - 1 in (* if raw_idx > (n - csize) then raw_idx - rof (* Shift if the variable is not bound *) @@ -125,7 +115,6 @@ let env_add_var_info var (ctx: lexp_context) = (a, cons (var) env, f)
let env_extend (ctx: lexp_context) (def: vdef) (v: varbind) (t: lexp) = - let ((n, map), e, f) = ctx in env_add_var_info (1, Some def, v, t) (senv_add_var def ctx)
@@ -194,6 +183,12 @@ let replace_by ctx name by = match ctx with | Mnil -> debruijn_error dummy_location ("Replace error. This expression does not exist: " ^ name) + | Mcons((_, None, _, _) as elem, tl1, i, tl2) -> + (* Skip some elements if possible *) + if idx <= i then replace_by' tl1 by (elem::acc) + else replace_by' tl2 by (elem::acc) + (* replace_by' tl1 by (elem::acc) *) + | Mcons((_, Some (b, n), _, _) as elem, tl1, i, tl2) -> if n = name then (cons by tl1), acc
===================================== src/env.ml ===================================== --- a/src/env.ml +++ b/src/env.ml @@ -80,7 +80,7 @@ let rec value_print (vtp: value_type) = | Vdummy -> print_string "value_print_dummy" | Vin _ -> print_string "in_channel" | Vout _ -> print_string "out_channel" - | _ -> print_string "debug print" + (* | _ -> print_string "debug print" *)
let value_location (vtp: value_type) = match vtp with @@ -100,6 +100,8 @@ let value_name v = | Closure _ -> "Closure" | Vsexp _ -> "Vsexp" | Vdummy -> "Vdummy" + | Vin _ -> "Vin" + | Vout _ -> "Vout"
(* Runtime Environ *) type env_cell = (string option * value_type) ref
===================================== src/lparse.ml ===================================== --- a/src/lparse.ml +++ b/src/lparse.ml @@ -659,15 +659,44 @@ and lexp_parse_inductive ctors ctx i = * to be processed *) and lexp_decls_macro (loc, mname) sargs ctx: pdecl list = (* lookup for mname_ *) - let _ = try senv_lookup mname ctx + let idx = try senv_lookup mname ctx with Not_found -> lexp_warning loc ("Macro "" ^ mname ^ "" was not found!"); 0 in - (* FIXME *) - (* (eval macro) -> Sexp *) - (* pexp_decls -> [pdecl] *)
- lexp_warning loc "Macro decls are not implemented yet!"; - [] + (* get Macro declaration *) + let lxp = try env_lookup_expr ctx ((loc, mname), idx) + with Not_found -> + lexp_fatal loc (mname ^ " was found but " ^ (string_of_int idx) ^ + " is not a correct index.") in + + (* get stored function *) + 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 new function *) + 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 + + (* get a list of declaration *) + let decls = eval elexp rctx in + + (* convert typer list to ocaml *) + let decls = tlist2olist [] decls in + + (* extract sexp from result *) + let decls = List.map (fun g -> + match g with + | Vsexp(sxp) -> sxp + | _ -> lexp_fatal loc "Macro expects sexp list") decls in + + (* read as pexp_declaraton *) + pexp_decls_all decls
(* Parse let declaration *) and lexp_p_decls decls ctx = _lexp_decls decls ctx 0 @@ -690,7 +719,7 @@ and _lexp_decls decls ctx i: (((vdef * lexp * ltype) list list) * lexp_context) let ctx = List.fold_left (fun vctx expr -> _global_lexp_trace := []; match expr with - | Pexpr((l, s), pxp) as e ->( + | 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 @@ -747,7 +776,7 @@ and _lexp_decls decls ctx i: (((vdef * lexp * ltype) list list) * lexp_context)
env_extend vctx (l, s) (LetDef lxp) ltp)
- | Ptype((l, s), ptp) as e -> + | Ptype((l, s), ptp) -> (if !recursive_mode then () else last_decls := s; offset := 1); @@ -762,11 +791,12 @@ and _lexp_decls decls ctx i: (((vdef * lexp * ltype) list list) * lexp_context) glob := SMap.add s (l, s, None, ltp) !glob; env_extend vctx (l, s) ForwardRef ltp
- | Pmcall((l, n), sargs) -> + | Pmcall((l, n), sargs) -> ( let pdecls = lexp_decls_macro (l, n) sargs vctx in - vctx + let _, _ =_lexp_decls pdecls vctx (i + 1) in + vctx)
- | _ -> vctx) ctx decls in + (* | _ -> vctx*)) ctx decls in
(* (if List.length !mut != 0 then names := !mut::!names); *)
View it on GitLab: https://gitlab.com/monnier/typer/compare/ac1f5998844723a451b0c3db76704a053a5...