Setepenre pushed to branch master at Stefan / Typer

Commits: 642376ae by Pierre Delaunay at 2016-06-25T18:16:01-04:00 Context accessors and Monad handling. modified travis script

Changes to be committed: *.travis.yml * src/debruijn.ml: - new function (get_attribute) - new function (has_attribute) - modify calling convention of (add_attribute) (better consistency) * btl/types.typer - added builtin context accessors (decltype) and (declexpr) * src/eval.ml - fix monad handling * src/lparse.ml - added context accessor as builtin macro

- - - - -

9 changed files:

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

Changes:

===================================== - deleted ===================================== --- a/- +++ /dev/null

===================================== .travis.yml ===================================== --- a/.travis.yml +++ b/.travis.yml @@ -3,16 +3,11 @@ language: ocaml env: - OCAML_VERSION=4.02

-addons: - apt: - packages: - - opam - -before_script: - - opam config setup -a - - opam config env +sudo: true

before_script: + - sudo apt-get -qq update + - sudo apt-get install opam - opam config setup -a - opam config env

===================================== btl/types.typer ===================================== --- a/btl/types.typer +++ b/btl/types.typer @@ -27,6 +27,7 @@ %* %* Description: %* Define builtin types and functions +%* This file MUST be correctly typed %* %* ---------------------------------------------------------------------------

@@ -34,12 +35,14 @@ % Base Types % -----------------------------------------------------

-Type = Built-in "Type"; -Int = Built-in "Int"; -Float = Built-in "Float"; -String = Built-in "String"; -Sexp = Built-in "Sexp"; -Unit = Built-in "Unit"; +Type = Built-in "Type"; +Int = Built-in "Int"; +Float = Built-in "Float"; +String = Built-in "String"; +Sexp = Built-in "Sexp"; + +Unit = Built-in "Unit"; % Nothing +Context = Built-in "Context"; % Lexp Context

% Basic operators _+_ = Built-in "_+_" (Int -> Int -> Int); @@ -151,12 +154,17 @@ Attribute = Built-in "Attribute"; new-attribute = Built-in "new-attribute" (Type -> Attribute);

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

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

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

- - - +decltype = Built-in "decltype" Macro; +declexpr = Built-in "declexpr" Macro;

===================================== src/builtin.ml ===================================== --- a/src/builtin.ml +++ b/src/builtin.ml @@ -243,12 +243,12 @@ let open_impl loc args_val ctx = | [Vstring(file_name); Vstring(mode)] -> file_name, mode | _ -> builtin_error loc "open expects 2 strings" in

- (* open file *) (* return a file handle *) - match mode with - | "r" -> Vin(open_in file) - | "w" -> Vout(open_out file) - | _ -> builtin_error loc "wrong open mode" - + (* open file *) (* return a file handle *) + Vcommand(fun () -> + match mode with + | "r" -> Vin(open_in file) + | "w" -> Vout(open_out file) + | _ -> builtin_error loc "wrong open mode")

let read_impl loc args_val ctx =

@@ -256,7 +256,7 @@ let read_impl loc args_val ctx = | [Vin(c); _] -> c | _ -> List.iter (fun v -> value_print v; print_string "\n") args_val; - builtin_error loc "read expects a in_channel" in + builtin_error loc "read expects an in_channel" in

let line = input_line channel in Vstring(line) @@ -267,15 +267,11 @@ let write_impl loc args_val ctx = | [Vout(c); Vstring(msg)] -> c, msg | _ -> List.iter (fun v -> value_print v) args_val; - builtin_error loc "read expects a out_channel" in + builtin_error loc "read expects an out_channel" in

fprintf channel "%s" msg; Vdummy

-let new_attribute loc args_val ctx = - builtin_warning loc "new-attributes to be implemented"; - Vdummy -

(* * Should we have a function that

===================================== src/debruijn.ml ===================================== --- a/src/debruijn.ml +++ b/src/debruijn.ml @@ -158,7 +158,7 @@ let _env_lookup ctx (v: vref): env_elem = let env_lookup_type ctx (v : vref): lexp = let (_, idx) = v in let (_, _, _, ltp) = _env_lookup ctx v in - mkSusp ltp (S.shift (idx + 1)) + mkSusp ltp (S.shift (idx + 0))

let env_lookup_expr ctx (v : vref): lexp = let (_, idx) = v in @@ -208,7 +208,7 @@ let replace_by ctx name by = (* -------------------------------------------------------------------------- *)

-let add_property ctx (var_n, var_i) (att_n, att_i) (prop: lexp) +let add_property ctx (var_i, var_n) (att_i, att_n) (prop: lexp) : lexp_context =

let (a, b, property_map) = ctx in @@ -226,6 +226,31 @@ let add_property ctx (var_n, var_i) (att_n, att_i) (prop: lexp)

(a, b, property_map)

+let get_property ctx (var_i, var_n) (att_i, att_n): lexp = + let (a, b, property_map) = ctx in + let n = get_size ctx in + + (* /!\ input index are reversed or not ? I think not so I shift them *) + let pmap = try PropertyMap.find (n - var_i, var_n) property_map + with Not_found -> + debruijn_error dummy_location ("Variable "" ^ var_n ^ "" does not have any properties") in + + let prop = try PropertyMap.find (n - att_i, att_n) pmap + with Not_found -> + debruijn_error dummy_location ("Property "" ^ att_n ^ "" not found") in + mkSusp prop (S.shift (var_i + 1)) + + +let has_property ctx (var_i, var_n) (att_i, att_n): bool = + let (a, b, property_map) = ctx in + let n = get_size ctx in + + try + let pmap = PropertyMap.find (n - var_i, var_n) property_map in + let prop = PropertyMap.find (n - att_i, att_n) pmap in + true + with Not_found -> false +

let dump_properties ctx = let (a, b, property_map) = ctx in

===================================== src/env.ml ===================================== --- a/src/env.ml +++ b/src/env.ml @@ -49,6 +49,7 @@ let env_error loc msg =

let str_idx idx = "[" ^ (string_of_int idx) ^ "]"

+ type value_type = | Vint of int | Vstring of string @@ -61,7 +62,8 @@ type value_type = | Vdummy | Vin of in_channel | Vout of out_channel - | Vbind of elexp list + | Vcommand of (unit -> value_type) +

let rec value_print (vtp: value_type) = match vtp with @@ -81,11 +83,7 @@ let rec value_print (vtp: value_type) = | Vdummy -> print_string "value_print_dummy" | Vin _ -> print_string "in_channel" | Vout _ -> print_string "out_channel" - | Vbind [a; b] -> print_string "bind ("; - elexp_print a; print_string ") ("; - elexp_print b; print_string ")"; - - | Vbind _ -> print_string "bind" + | Vcommand _ -> print_string "command" (* | _ -> print_string "debug print" *)

let value_location (vtp: value_type) = @@ -108,7 +106,7 @@ let value_name v = | Vdummy -> "Vdummy" | Vin _ -> "Vin" | Vout _ -> "Vout" - | Vbind _ -> "Vbind" + | Vcommand _ -> "Vcommand"

(* Runtime Environ *) type env_cell = (string option * value_type) ref

===================================== src/eval.ml ===================================== --- a/src/eval.ml +++ b/src/eval.ml @@ -102,7 +102,7 @@ let rec _eval lxp ctx i: (value_type) = -> (eval_case ctx i loc target pat dflt)

| _ -> print_string "debug catch-all eval: "; - elexp_print lxp; print_string "\n"; Vstring("eval Not Implemented") + elexp_print lxp; print_string "\n"; Vdummy

and get_predef_eval name ctx = @@ -144,12 +144,8 @@ and eval_call ctx i lname eargs = 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 + 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 *) @@ -249,30 +245,42 @@ and bind_impl loc args_val ctx = | [io; callback] -> io, callback | _ -> builtin_error loc "bind expects two arguments" in

+ (* build Vcommand from io function *) + let cmd = match io with + | Vcommand (cmd) -> cmd + | _ -> builtin_error loc "bind first arguments must be a monad" in + + (* bind return another Vcommand *) + Vcommand (fun () -> (* get callback *) - let body, ctx = match cb with - | Closure(_, body, ctx) -> body, ctx - | _ -> builtin_error loc "A Closure was expected" in + let body, ctx = match cb with + | Closure(_, body, ctx) -> body, ctx + | _ -> builtin_error loc "A Closure was expected" in + + (* run given command *) + let underlying = cmd () in

(* add evaluated IO to arg list *) - let nctx = add_rte_variable None io ctx in + let nctx = add_rte_variable None underlying ctx in

(* eval callback *) - _eval body nctx 0 + _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 + let io, ltp = match args_val with + | [io; ltp] -> io, ltp + | _ -> builtin_error loc "run-io expects 2 arguments" in + + let cmd = match io with + | Vcommand (cmd) -> cmd + | _ -> builtin_error loc "run-io expects a monad as first argument" in

- (* eval args *) - let io = _eval io ctx 0 in - let callback = _eval callback ctx 0 in + (* run given command *) + let _ = cmd () in

- (* eval bind *) - let a = bind_impl loc [io; callback] ctx in - get_predef_eval "Unit" ctx + (* return given type *) + ltp

and typer_eval loc args ctx = let arg = match args with

===================================== src/lparse.ml ===================================== --- a/src/lparse.ml +++ b/src/lparse.ml @@ -513,7 +513,46 @@ 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

- (* attribute *) + (* 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 @@ -660,7 +699,7 @@ and lexp_decls_macro (loc, mname) sargs ctx: (pdecl list * lexp_context) =

(* extract info *) let var, att, fn = match largs with - | [Var((_, vn), vi); Var((_, an), ai); fn] -> (vn, vi), (an, ai), fn + | [Var((_, vn), vi); Var((_, an), ai); fn] -> (vi, vn), (ai, an), fn | _ -> lexp_fatal loc "add-attribute expects 3 args" in

let ctx = add_property ctx var att fn in

===================================== w_file deleted ===================================== --- a/w_file +++ /dev/null

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