Setepenre pushed to branch master at Stefan / Typer
Commits: 343b33b5 by Pierre Delaunay at 2016-05-08T00:10:52-04:00 fix node_. 2 arguments instead of one
Changes to be committed: * btl/types.typer * samples/qquote_temp.typer - started to implement qquote in typer * src/builtin.ml * src/eval.ml: - moved `sexp_dispatch` from builtin.ml to eval.ml (circular dependency). The good news being: Lparse.ml only need type0, type_int, etc from builtin.ml which means eval.ml is not going to need builtin.ml for much longer.
- - - - - 90b0c510 by Pierre Delaunay at 2016-05-09T07:49:44-04:00 Added elexp.ml which erase types of lexp expr Fix macro handling
Changes to be committed: * new file: src/elexp.ml - (erase_type) convert lexp -> elexp - (elexp_location) - (elexp_print) * src/lparse.ml: - eval evaluated '(Macro_ fun)' instead of '(fun List)'
- - - - -
11 changed files:
- .gitignore - .travis.yml - btl/types.typer - + samples/qquote_temp.typer - src/builtin.ml - + src/elexp.ml - src/env.ml - src/eval.ml - src/lexp.ml - src/lparse.ml - tests/macro_test.ml
Changes:
===================================== .gitignore ===================================== --- a/.gitignore +++ b/.gitignore @@ -19,3 +19,4 @@ test__.ml _temp_hack test__.typer *.orig +_tags \ No newline at end of file
===================================== .travis.yml ===================================== --- a/.travis.yml +++ b/.travis.yml @@ -3,7 +3,7 @@ language: ocaml addons: apt: packages: - - opam + - ocaml
script: make tests
===================================== btl/types.typer ===================================== --- a/btl/types.typer +++ b/btl/types.typer @@ -51,6 +51,11 @@ Bool = inductive_ (Boolean) (True) (False); True = inductive-cons Bool True; False = inductive-cons Bool False;
+Option : Type -> Type; +Option = inductive_ (Option (a : Type)) (None) (Some a); +Some = inductive-cons Option Some; +None = inductive-cons Option None; + string_eq : String -> String -> Bool; string_eq = Built-in "string_eq";
@@ -104,7 +109,7 @@ symbol_ = Built-in "symbol_"; string_ : String -> Sexp; string_ = Built-in "string_";
-node_ : (List Sexp) -> Sexp; +node_ : Sexp -> (List Sexp) -> Sexp; node_ = Built-in "node_";
integer_ : Int -> Sexp; @@ -117,9 +122,9 @@ Macro : Type; Macro = inductive_ (dMacro) (Macro_ ((List Sexp) -> Sexp)); Macro_ = inductive-cons Macro Macro_ ;
-% Type is not accurate yet -sexp_dispatch_ : Sexp -> (Sexp -> Sexp) -> (Sexp -> Sexp) -> (Sexp -> Sexp) - -> (Sexp -> Sexp) -> (Sexp -> Sexp) -> (Sexp -> Sexp) -> (Sexp -> Sexp); +sexp_dispatch_ : Sexp -> (Sexp -> List Sexp -> Sexp) -> (String -> Sexp) -> + (String -> Sexp) -> (Int -> Sexp) -> (Float -> Sexp) -> (List Sexp -> Sexp) + -> Sexp; sexp_dispatch_ = Built-in "sexp_dispatch_";
@@ -136,5 +141,3 @@ sexp_dispatch_ = Built-in "sexp_dispatch_";
- -
===================================== samples/qquote_temp.typer ===================================== --- /dev/null +++ b/samples/qquote_temp.typer @@ -0,0 +1,45 @@ + + +sqr = Macro_ (lambda (x : List Sexp) -> + let hd = head Sexp x in + (node_ (symbol_ "_*_") (cons hd (cons hd nil)))); + + +symbol = lambda (y : String) -> (symbol_ y) ; +string = lambda (y : String) -> (string_ y) ; +integer = lambda (y : Int) -> (integer_ y) ; +float = lambda (y : Float) -> (float_ y) ; +block = lambda (y : List Sexp) -> (block_ y) ; + +qquote : List Sexp -> List Sexp; + +node = (lambda (op : Sexp) -> + lambda (y : List Sexp) -> + case y + | nil => node_ op nil + | _ => node_ op (qquote y)); + + +qquote = lambda (x : List Sexp) -> + let target = head Sexp x; + tl = tail Sexp x; + + rhd = sexp_dispatch_ target + node symbol string integer float block; + + rtl = case tl + | nil => nil + | _ => qquote tl; + + in + cons rhd rtl; + + +nd = node_ (symbol_ "_+_") (cons (symbol_ "x") (cons (symbol_ "x") nil)); +tst = cons nd nil; + +% tst = (cons (symbol_ "x") (cons (symbol_ "x") nil)); + +main = qquote tst; + +main = Macro_ lamda \ No newline at end of file
===================================== src/builtin.ml ===================================== --- a/src/builtin.ml +++ b/src/builtin.ml @@ -45,7 +45,6 @@ let builtin_error loc msg = raise (internal_error msg) ;;
- (* Builtin types *) let dloc = dummy_location let slevel0 = SortLevel (SLn 0) @@ -73,7 +72,8 @@ let type_float = Builtin((dloc, "Float"), type0) let type_string = Builtin((dloc, "String"), type0)
(* Builtin of builtin * string * ltype *) -let _generic_binary_iop name f loc (args_val: value_type list) (ctx: runtime_env) = +let _generic_binary_iop name f loc (args_val: value_type list) + (ctx: runtime_env) =
let l, r = match args_val with | [l; r] -> l, r @@ -108,27 +108,46 @@ let make_symbol loc args_val ctx = | _ -> builtin_error loc ("symbol_ expects one string as argument")
-let make_node loc args_val ctx = +(* lexp Imm list *) +let olist2tlist_lexp lst ctx = + (* Get Constructor *) + let considx = senv_lookup "cons" ctx in + let nilidx = senv_lookup "nil" ctx in + + let tcons = Var((dloc, "cons"), considx) in + let tnil = Var((dloc, "nil"), nilidx) in + + let rlst = List.rev lst in + List.fold_left (fun tail elem -> + Call(tcons, [(Aexplicit, (Imm(elem))); + (Aexplicit, tail)])) tnil rlst
- let tlist = match args_val with - | [lst] -> lst - | _ -> builtin_error loc "node_ expects one 'List Sexp'" in +(* typer list as seen during runtime *) +let olist2tlist_rte lst = + let tnil = Vcons((dloc, "nil"), []) in + let rlst = List.rev lst in + List.fold_left (fun tail elem -> + Vcons((dloc, "cons"), [Vsexp(elem); tail])) tnil rlst
- (* Typer list to Ocaml list *) - let rec tlist2olist acc expr = - match expr with - | Vcons((_, "cons"), [hd; tl]) -> - tlist2olist (hd::acc) tl - | Vcons((_, "nil"), []) -> List.rev acc - | _ -> builtin_error loc "node_ expects one 'List Sexp'" in
+(* Typer list to Ocaml list *) +let rec tlist2olist acc expr = + match expr with + | Vcons((_, "cons"), [hd; tl]) -> + tlist2olist (hd::acc) tl + | Vcons((_, "nil"), []) -> List.rev acc + | _ -> + value_print expr; + builtin_error dloc "List conversion failure'"
- let args_val = tlist2olist [] tlist in +let make_node loc args_val ctx = + + let op, tlist = match args_val with + | [Vsexp(op); lst] -> op, lst + | _ -> builtin_error loc + "node_ expects one 'Sexp' and one 'List Sexp'" in
- let op, args = match args_val with - | Vsexp(s)::tl -> s, tl - | _::tl -> builtin_error loc ("node_ expects sexp as operator") - | _ -> builtin_error loc ("node_ expects at least 2 arguments") in + let args = tlist2olist [] tlist in
let s = List.map (fun g -> match g with | Vsexp(sxp) -> sxp @@ -140,32 +159,26 @@ let make_node loc args_val ctx =
Vsexp(Node(op, s))
-(* Takes one sexp and 6 function returning a sexp *) -(* Sexp -> (Sexp -> Sexp) -> (Sexp -> Sexp) -> (Sexp -> Sexp) - -> (Sexp -> Sexp) -> (Sexp -> Sexp) -> (Sexp -> Sexp) - -> (Sexp -> Sexp) *) -let sexp_dispatch loc args ctx = - - let sxp, nd, sym, str, it, flt, blk = match args with - | [Vsexp(sxp); nd; sym; str; it; flt; blk] -> - sxp, nd, sym, str, it, flt, blk - | _ -> builtin_error loc "sexp_dispatch expects 5 arguments" in +let make_string loc args_val ctx = + let lxp = match args_val with + | [r] -> r + | _ -> builtin_error loc ("string_ expects 1 argument") in
- match sxp with - | Node _ -> nd - | Symbol _ -> sym - | String _ -> str - | Integer _ -> it - | Float _ -> flt - | Block _ -> blk - | _ -> builtin_error loc "sexp_dispatch error" + match lxp with + | Vstring(str) -> Vsexp(String(loc, str)) + | _ -> builtin_error loc ("string_ expects one string as argument")
+let make_integer loc args_val ctx = + let lxp = match args_val with + | [r] -> r + | _ -> builtin_error loc ("integer_ expects 1 argument") in
+ match lxp with + | Vint(str) -> Vsexp(Integer(loc, str)) + | _ -> builtin_error loc ("integer_ expects one string as argument")
-let make_block loc args_val ctx = Vdummy -let make_string loc args_val ctx = Vdummy -let make_integer loc args_val ctx = Vdummy let make_float loc args_val ctx = Vdummy +let make_block loc args_val ctx = Vdummy
let ttrue = Vcons((dloc, "True"), []) let tfalse = Vcons((dloc, "False"), []) @@ -202,34 +215,7 @@ let sexp_eq loc args_val ctx = *)
-(* Built-in list of types/functions *) -let typer_builtins_impl = [ - ("_+_" , iadd_impl); - ("_*_" , imult_impl); - ("block_" , make_block); - ("symbol_" , make_symbol); - ("string_" , make_string); - ("integer_" , make_integer); - ("float_" , make_float); - ("node_" , make_node); - ("sexp_dispatch_", sexp_dispatch); - ("string_eq" , string_eq); - ("int_eq" , int_eq); - ("sexp_eq" , sexp_eq); -] - -(* Make built-in lookup table *) -let _builtin_lookup = - List.fold_left (fun lkup (name, f) -> - SMap.add name f lkup) - SMap.empty typer_builtins_impl - -let get_builtin_impl str loc = - try SMap.find str _builtin_lookup - with Not_found -> - builtin_error loc "Requested Built-in does not exist" - -let btl_folder = ref "./btl/" +
let is_lbuiltin idx ctx =
===================================== src/elexp.ml ===================================== --- /dev/null +++ b/src/elexp.ml @@ -0,0 +1,199 @@ +(* + * Typer Compiler + * + * --------------------------------------------------------------------------- + * + * Copyright (C) 2011-2016 Free Software Foundation, Inc. + * + * Author: Pierre Delaunay pierre.delaunay@hec.ca + * Keywords: languages, lisp, dependent types. + * + * This file is part of Typer. + * + * Typer is free software; you can redistribute it and/or modify it under the + * terms of the GNU General Public License as published by the Free Software + * Foundation, either version 3 of the License, or (at your option) any + * later version. + * + * Typer is distributed in the hope that it will be useful, but WITHOUT ANY + * WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS + * FOR A PARTICULAR PURPOSE. See the GNU General Public License for + * more details. + * + * You should have received a copy of the GNU General Public License along + * with this program. If not, see http://www.gnu.org/licenses/. + * + * --------------------------------------------------------------------------- + * + * Description: + * Type Erased Lexp expression + * + * --------------------------------------------------------------------------- *) + + +open Sexp (* Sexp type *) +open Pexp (* Aexplicit *) + +module L = Lexp +module U = Util + +type vdef = L.vdef +type vref = L.vref +type label = symbol + +module SMap = U.SMap + +let elexp_warning = U.msg_warning "ELEXP" + +type elexp = + | Imm of sexp + + | Builtin of vdef + | Var of vref + + | Let of U.location * (vdef * elexp) list * elexp + | Lambda of vdef * elexp + | Call of elexp * elexp list + | Cons of symbol + | Case of U.location * elexp * + (U.location * (vdef option) list * elexp) SMap.t * elexp option + + (* Type definition *) + | Arrow + | SortLevel + | Sort + (* Inductive takes a slot in the env that is why it need to be here *) + | Inductive of U.location * label + +let rec erase_type (lxp: L.lexp): elexp = + + match lxp with + | L.Imm(s) -> Imm(s) + | L.Builtin(v, _) -> Builtin(v) + | L.Var(v) -> Var(v) + | L.Cons(_, s) -> Cons(s) + + | L.Lambda(kind, vdef, _, body) -> + if kind == Aexplicit then + Lambda(vdef, erase_type body) + else + erase_type body + + | L.Let(l, decls, body) -> + Let(l, (clean_decls decls), (erase_type body)) + + | L.Call(fct, args) -> + Call((erase_type fct), (filter_arg_list args)) + + | L.Case(l, target, _, _, cases, default) -> + Case(l, (erase_type target), (clean_map cases), + (clean_maybe default)) + + (* To be thrown out *) + | L.Arrow _ -> Arrow + | L.SortLevel _ -> SortLevel + | L.Sort _ -> Sort + | L.Susp _ -> Arrow + (* Still useful to some extend *) + | L.Inductive(l, label, _, _) -> Inductive(l, label) + + +and filter_arg_list lst = + let rec filter_arg_list lst acc = + match lst with + | (kind, lxp)::tl -> + let acc = if kind == Aexplicit then + (erase_type lxp)::acc else acc in + filter_arg_list tl acc + | [] -> List.rev acc in + filter_arg_list lst [] + +and clean_decls decls = + List.map (fun (v, lxp, _) -> (v, (erase_type lxp))) decls + +and clean_maybe lxp = + match lxp with + | Some lxp -> Some (erase_type lxp) + | None -> None + +and clean_map cases = + let clean_arg_list lst = + let rec clean_arg_list lst acc = + match lst with + | (kind, var)::tl -> + let acc = if kind == Aexplicit then + var::acc else acc in + clean_arg_list tl acc + | [] -> List.rev acc in + clean_arg_list lst [] in + + SMap.mapi (fun key (l, args, expr) -> + (l, (clean_arg_list args), (erase_type expr))) cases + + +let rec elexp_location e = + match e with + | Imm s -> sexp_location s + | Var ((l,_), _) -> l + | Builtin ((l, _)) -> l + | Let (l,_,_) -> l + | Lambda ((l,_),_) -> l + | Call (f,_) -> elexp_location f + | Cons ((l,_)) -> l + | Case (l,_,_,_) -> l + + | Arrow _ -> U.dummy_location + | Inductive _ -> U.dummy_location + | Sort _ -> U.dummy_location + | SortLevel _ -> U.dummy_location + + +let rec elexp_print lxp = print_string (elexp_str lxp) +and elexp_str lxp = + let maybe_str lxp = + match lxp with + | Some lxp -> " | _ => " ^ (elexp_str lxp) + | None -> "" in + + let str_decls d = + List.fold_left (fun str ((_, s), lxp) -> + str ^ " " ^ s ^ " = " ^ (elexp_str lxp)) "" d in + + let str_pat lst = + List.fold_left (fun str v -> + str ^ " " ^ (match v with + | None -> "_" + | Some (_, s) -> s)) "" lst in + + let str_cases c = + SMap.fold (fun key (_, lst, lxp) str -> + str ^ " | " ^ key ^ " " ^ (str_pat lst) ^ " => " ^ (elexp_str lxp)) + c "" in + + let str_args lst = + List.fold_left (fun str lxp -> + str ^ " " ^ (elexp_str lxp)) "" lst in + + match lxp with + | Imm(s) -> sexp_to_str s + | Builtin((_, s)) -> s + | Var((_, s), _) -> s + | Cons((_, s)) -> s + + | Lambda((_, s), b) -> "lambda " ^ s ^ " -> " ^ (elexp_str b) + + | Let(_, d, b) -> + "let" ^ (str_decls d) ^ " in " ^ (elexp_str b) + + | Call(fct, args) -> + "(" ^ (elexp_str fct) ^ (str_args args) ^ ")" + + | Case(_, t, cases, default) -> + "case " ^ (elexp_str t) ^ (str_cases cases) ^ (maybe_str default) + + | Inductive(_, (_, s)) -> + "inductive_ " ^ s + + | _ -> "Why do you still have those ? " + +
===================================== src/env.ml ===================================== --- a/src/env.ml +++ b/src/env.ml @@ -54,6 +54,7 @@ type value_type = | Vstring of string | Vcons of symbol * value_type list | Vbuiltin of string + | Vfloat of float | Closure of lexp * (((string option * value_type) ref myers) * (int * int)) | Vsexp of sexp (* Values passed to macros. *) (* Unable to eval during macro expansion, only throw if the value is used *) @@ -64,7 +65,8 @@ let rec value_print (vtp: value_type) = | Closure (lxp, _) -> print_string ("Closure(" ^ (_lexp_to_str (!debug_ppctx) lxp) ^ ")") | Vsexp sxp -> sexp_print sxp - | Vint(i) -> print_int i; + | Vint(i) -> print_int i + | Vfloat(f) -> print_float f | Vstring(s) -> print_string (""" ^ s ^ """) | Vcons ((_, n), []) -> print_string n | Vcons ((_, n), args) ->
===================================== src/eval.ml ===================================== --- a/src/eval.ml +++ b/src/eval.ml @@ -43,6 +43,8 @@ open Grammar open Debruijn open Env
+module ET = Elexp + (* eval error are always fatal *) let eval_error loc msg = msg_error "EVAL" loc msg; @@ -58,7 +60,7 @@ let _global_eval_trace = ref [] let _global_eval_ctx = ref make_runtime_ctx 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 *) @@ -200,7 +202,86 @@ and _eval_decls (decls: ((vdef * lexp * ltype) list)) (n, ctx) decls in
ctx - +(* -------------------------------------------------------------------------- *) +(* Builtin Implementation (Some require eval) *) + +and typer_builtins_impl = [ + ("_+_" , iadd_impl); + ("_*_" , imult_impl); + ("block_" , make_block); + ("symbol_" , make_symbol); + ("string_" , make_string); + ("integer_" , make_integer); + ("float_" , make_float); + ("node_" , make_node); + ("sexp_dispatch_", sexp_dispatch); + ("string_eq" , string_eq); + ("int_eq" , int_eq); + ("sexp_eq" , sexp_eq); + ("eval_" , typer_eval); +] + +and typer_eval loc args ctx = + let arg = match args with + | [a] -> a + | _ -> eval_error loc "eval_ expects a single argument" in + (* I need to be able to lexp sexp but I don't have lexp ctx *) + match arg with + (* Nodes that can be evaluated *) + | Closure (body, ctx) -> _eval body ctx 1 + (* Leaf *) + | _ -> arg + +and get_builtin_impl str loc = + (* Make built-in lookup table *) + (match (SMap.is_empty !_builtin_lookup) with + | true -> + _builtin_lookup := (List.fold_left (fun lkup (name, f) -> + SMap.add name f lkup) SMap.empty typer_builtins_impl) + | _ -> ()); + + try SMap.find str !_builtin_lookup + with Not_found -> + eval_error loc "Requested Built-in does not exist" + +(* Sexp -> (Sexp -> List Sexp -> Sexp) -> (String -> Sexp) -> + (String -> Sexp) -> (Int -> Sexp) -> (Float -> Sexp) -> (List Sexp -> Sexp) + -> Sexp *) +and sexp_dispatch loc args ctx = + let eval a b = _eval a b 1 in + let sxp, nd, sym, str, it, flt, blk, rctx = match args with + | [sxp; Closure(nd, rctx); Closure(sym, _); + Closure(str, _); Closure(it, _); + Closure(flt, _); Closure(blk, _)] -> + sxp, nd, sym, str, it, flt, blk, rctx + | _ -> eval_error loc "sexp_dispatch expects 7 arguments" in + + let sxp = match sxp with + | Vsexp(sxp) -> sxp + | _ -> value_print sxp; + eval_error loc "sexp_dispatch expects a Sexp as 1st arg" in + + match sxp with + | Node (op, s) ->( + let rctx = add_rte_variable None (Vsexp(op)) rctx in + let rctx = add_rte_variable None (olist2tlist_rte s) rctx in + match eval nd rctx with + | Closure(nd, _) -> eval nd rctx + | _ -> eval_error loc "Node has 2 arguments") + + | Symbol (_ , s) -> + eval sym (add_rte_variable None (Vstring(s)) rctx) + | String (_ , s) -> + eval str (add_rte_variable None (Vstring(s)) rctx) + | Integer (_ , i) -> + eval it (add_rte_variable None (Vint(i)) rctx) + | Float (_ , f) -> + eval flt (add_rte_variable None (Vfloat(f)) rctx) (* + | Block (_ , s, _) -> + eval blk (add_rte_variable None (olist2tlist_rte s)) *) + | _ -> eval_error loc "sexp_dispatch error" + +(* -------------------------------------------------------------------------- *) and print_eval_result i lxp = print_string " Out["; ralign_print_int i 2;
===================================== src/lexp.ml ===================================== --- a/src/lexp.ml +++ b/src/lexp.ml @@ -247,7 +247,7 @@ let rec lexp_location e = | SortLevel (SLn _) -> U.dummy_location | Imm s -> sexp_location s | Var ((l,_),_) -> l - | Builtin _ -> U.dummy_location + | Builtin ((l, _), _) -> l | Let (l,_,_) -> l | Arrow (_,_,_,l,_) -> l | Lambda (_,(l,_),_,_) -> l
===================================== src/lparse.ml ===================================== --- a/src/lparse.ml +++ b/src/lparse.ml @@ -62,6 +62,7 @@ let lexp_fatal = msg_fatal "LPARSE"
let _global_lexp_ctx = ref make_lexp_context let _global_lexp_trace = ref [] +let btl_folder = ref "./btl/"
(* The main job of lexp (currently) is to determine variable name (index) * and to regroup type specification with their variable @@ -338,11 +339,6 @@ and lexp_case (rtype: lexp option) (loc, target, patterns) ctx i = and lexp_call (fun_name: pexp) (sargs: sexp list) ctx i = let loc = pexp_location fun_name in
- (* Process Arguments *) - let pargs = List.map pexp_parse sargs in - let largs = _lexp_parse_all pargs ctx i in - let new_args = List.map (fun g -> (Aexplicit, g)) largs in - let from_lctx ctx = try (from_lctx ctx) with e -> lexp_fatal loc "Could not convert lexp context into rte context" in @@ -366,6 +362,11 @@ and lexp_call (fun_name: pexp) (sargs: sexp list) ctx i = (* let ret_type = get_return_type 0 ltp new_args in *)
let handle_named_call (loc, name) = + (* Process Arguments *) + let pargs = List.map pexp_parse sargs in + let largs = _lexp_parse_all pargs ctx i in + let new_args = List.map (fun g -> (Aexplicit, g)) largs in + try (* Check if the function was defined *) let idx = senv_lookup name ctx in let vf = (make_var name idx loc) in @@ -414,32 +415,23 @@ and lexp_call (fun_name: pexp) (sargs: sexp list) ctx i = lexp_fatal loc (name ^ " was found but " ^ (string_of_int idx) ^ " is not a correct index.") in
- let rctx = (from_lctx ctx) in - let sxp = match eval lxp rctx with - (* This give me a closure to be evaluated with sargs *) - | Vcons(_, [Closure(body, rctx)]) ->( - (* Build typer list from ocaml list *) - let rsargs = List.rev sargs in - - (* Get Constructor *) - let considx = senv_lookup "cons" ctx in - let nilidx = senv_lookup "nil" ctx in + let lxp = match lxp with + | Call(Var((_, "Macro_"), _), [(Aexplicit, fct)]) -> fct + | _ -> lexp_fatal loc "Macro ill formed" in
- let tcons = Var((dloc, "cons"), considx) in - let tnil = Var((dloc, "nil"), nilidx) in - - let arg = List.fold_left (fun tail elem -> - Call(tcons, [(Aexplicit, (Imm(elem))); - (Aexplicit, tail)])) tnil rsargs in - - let rctx = add_rte_variable None (eval arg rctx) rctx in - let r = eval body rctx in - match r with - | Vsexp(s) -> s - | _ -> Epsilon) + (* Build function to be called *) + let arg = olist2tlist_lexp sargs ctx in + let lxp = Call(lxp, [(Aexplicit, arg)]) in
+ let rctx = (from_lctx ctx) in + let sxp = match eval lxp rctx 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) | v -> value_print v; print_string "\n"; - lexp_fatal loc "Macro_ expects sexp" in + lexp_fatal loc "Macro_ expects '(List Sexp) -> Sexp'" in
let pxp = pexp_parse sxp in _lexp_p_infer pxp ctx (i + 1) in @@ -475,7 +467,12 @@ and lexp_call (fun_name: pexp) (sargs: sexp list) ctx i = (* determine function type *) match fun_name, ltp with (* Anonymous *) - | ((Plambda _), _) -> Call(body, new_args), ltp + | ((Plambda _), _) -> + (* Process Arguments *) + let pargs = List.map pexp_parse sargs in + let largs = _lexp_parse_all pargs ctx i in + let new_args = List.map (fun g -> (Aexplicit, g)) largs in + Call(body, new_args), ltp
| (Pvar (l, n), Var((_, "Macro"), _)) -> (* FIXME: check db_idx points too a Macro type *) @@ -779,7 +776,7 @@ let default_lctx () = let lctx = env_extend lctx (dloc, "Built-in") (Some lxp) type0 in
(* Read BTL files *) - let pres = prelex_file "./btl/types.typer" in + let pres = prelex_file (!btl_folder ^ "types.typer") in let sxps = lex default_stt pres in let nods = sexp_parse_all_to_list default_grammar sxps (Some ";") in
===================================== tests/macro_test.ml ===================================== --- a/tests/macro_test.ml +++ b/tests/macro_test.ml @@ -50,7 +50,7 @@ let _ = (add_test "MACROS" "macros base" (fun () -> let dcode = " sqr = Macro_ (lambda (x : List Sexp) -> let hd = head Sexp x in - (node_ (cons (symbol_ "_*_") (cons hd (cons hd nil))))); + (node_ (symbol_ "_*_") (cons hd (cons hd nil)))); " in
let rctx, lctx = eval_decl_str dcode lctx rctx in
View it on GitLab: https://gitlab.com/monnier/typer/compare/d4cfc3a4a1b443b397d2db6881a940ca1a6...
Afficher les réponses par date