Setepenre pushed to branch master at Stefan / Typer

Commits: 8ec96e19 by Pierre Delaunay at 2016-05-02T08:19:48-04:00 Add the 'quasiquote' operator (`qquote`) Removed `temp_ctx` as it is not used anymore

Changes to be committed: * src/REPL.ml: temp_ctx - qquote handling: * src/builtin.ml * src/eval.ml * src/lparse.ml * src/sexp.ml: new function (sexp_to_st) * src/prelexer.ml: new function (pretoken_to_str) * src/lexp.ml: print (Imm(sexp)) correctly

- - - - -

11 changed files:

- − TODO.md - samples/macro.typer - src/REPL.ml - src/builtin.ml - src/debug_util.ml - src/env.ml - src/eval.ml - src/lexp.ml - src/lparse.ml - src/prelexer.ml - src/sexp.ml

Changes:

===================================== TODO.md deleted ===================================== --- a/TODO.md +++ /dev/null @@ -1,31 +0,0 @@ -TODO -==== - -PROJECT: - * pretty arg parsing utils - -FILE: full_debug.ml - * better arg parsing - * Allow users to choose what to print (Pretoks/Sexp/SexpNode/Pexp/Lexp/etc..) - * --all - * --pretoks - * --sexp - * --node - * --pexp - * --lexp - - Other Option - --repl - - -case (a,b) - | (Foo, Foo) => 3.14 - | (Bar, Bar) => 3.15 -;; - - - -# Issues - -* The duplicate ';' create Sexp::Epsilon() which makes pexp_parse fail -* pexp_parse fail to parse inductive

===================================== samples/macro.typer ===================================== --- a/samples/macro.typer +++ b/samples/macro.typer @@ -1,3 +1,6 @@ +% +% The Hardcore way of building a Macro +%

sqr_fun = node_ (symbol_ "lambda_->_") (symbol_ "x") (node_ (symbol_ "_*_") (symbol_ "x") (symbol_ "x")); @@ -11,4 +14,22 @@ give_type = lambda expr ->

sqr = Macro_ (give_type sqr_fun sqr_type);

-main = (sqr 2); +m1 = (sqr 2); + +% +% The easy way +% + + +sqr = Macro_ (qq (lambda (x : Int) -> x * x)); + +m2 = (sqr 2); + +% +% Use unquote to replace a variable by its value +% + +my_fun = let a = 2 in + Macro_ (qquote lambda (x : Int) -> x * (uquote a)); + +main = (my_fun 3); \ No newline at end of file

===================================== src/REPL.ml ===================================== --- a/src/REPL.ml +++ b/src/REPL.ml @@ -144,7 +144,7 @@ let _ieval f str lctx rctx = let pxps = ipexp_parse nods in let lxps, lctx = ilexp_parse pxps lctx in let v, rctx = ieval lxps rctx in - v, lctx, (local_ctx rctx) + v, lctx, rctx ;;

let ieval_string = _ieval prelex_string

===================================== src/builtin.ml ===================================== --- a/src/builtin.ml +++ b/src/builtin.ml @@ -56,9 +56,9 @@ let type_omega = Sort (dloc, StypeOmega) let type_level = Sort (dloc, StypeLevel) let type_level = Builtin (LevelType, "TypeLevel", type_level)

-let type_int = Builtin (IntType, "Int", type0) +let type_int = Builtin (IntType , "Int" , type0) let type_float = Builtin (FloatType, "Float", type0) -let type_sexp = Builtin (SexpType, "sexp", type0) +let type_sexp = Builtin (SexpType , "Sexp" , type0)

let op_binary t = Arrow (Aexplicit, None, t, dloc, Arrow (Aexplicit, None, t, dloc, t)) @@ -142,6 +142,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 + + match sxp with + | Node _ -> nd + | Symbol _ -> sym + | String _ -> str + | Integer _ -> it + | Float _ -> flt + | Block _ -> blk + | _ -> builtin_error loc "sexp_dispatch error" +

let make_block loc args_val ctx = Vdummy let make_string loc args_val ctx = Vdummy @@ -168,8 +188,11 @@ let builtin_node = Builtin (SexpType, "node_", type_mnode)

let builtin_macro = Cons (((dloc, "Macro"), (-4)), (dloc, "Macro_")) +(* let builtin_quote = Cons (((dloc, "Macro"), (-4)), (dloc, "quote")) *) +let builtin_qq = Cons (((dloc, "Macro"), (-4)), (dloc, "qquote")) let type_macro = Builtin (MacroType, "Macro", type0) let macro_cons = Arrow (Aexplicit, None, type_sexp, dloc, type_macro) +let quote_cons = Arrow (Aexplicit, None, type0, dloc, type_sexp)

(* @@ -197,6 +220,8 @@ let typer_builtins = [ ("_+_" , builtin_iadd, iop_binary, iadd_impl); (* int -> int -> int *) ("_*_" , builtin_imult, iop_binary, imult_impl); (* int -> int -> int *) ("Macro_", builtin_macro, macro_cons, none_fun); + (*("'" , builtin_quote, quote_cons, none_fun); *) + ("qquote" , builtin_qq , quote_cons, none_fun); (* Macro primitives *) ("block_" , builtin_block , type_mblock , make_block); ("symbol_" , builtin_symbol , type_msymbol , make_symbol); @@ -208,9 +233,9 @@ let typer_builtins = [

(* Macros primitives type ? *)

- ]

+ (* Make built-in lookup table *) let _builtin_lookup = List.fold_left (fun lkup (name, _, _, f) ->

===================================== src/debug_util.ml ===================================== --- a/src/debug_util.ml +++ b/src/debug_util.ml @@ -56,8 +56,6 @@ open Env

- - let dloc = dummy_location;; let dummy_decl = Imm(String(dloc, "Dummy"));;

@@ -236,31 +234,37 @@ let main () =

let filename = List.hd (!arg_files) in

- print_string (make_title " ERRORS "); - (* get pretokens*) + print_string yellow; let pretoks = prelex_file filename in + print_string reset;

(if (get_p_option "pretok") then( print_string (make_title " PreTokens"); debug_pretokens_print_all pretoks; print_string "\n"));

(* get sexp/tokens *) + print_string yellow; let toks = lex default_stt pretoks in + print_string reset;

(if (get_p_option "tok") then( print_string (make_title " Base Sexp"); debug_sexp_print_all toks; print_string "\n"));

(* get node sexp *) + print_string yellow; let nodes = sexp_parse_all_to_list default_grammar toks (Some ";") in + print_string reset;

(if (get_p_option "sexp") then( print_string (make_title " Node Sexp "); debug_sexp_print_all nodes; print_string "\n"));

(* Parse All Declaration *) + print_string yellow; let pexps = pexp_decls_all nodes in + print_string reset;

(if (get_p_option "pexp") then( print_string (make_title " Pexp "); @@ -269,13 +273,16 @@ let main () = (* get lexp *) let ctx = default_lctx () in

+ print_string yellow; let lexps, nctx = try lexp_p_decls pexps ctx with e -> ( + print_string reset; print_lexp_ctx (!_global_lexp_ctx); print_lexp_trace (); raise e ) in + print_string reset;

(if (get_p_option "lexp") then( print_string (make_title " Lexp "); @@ -286,11 +293,14 @@ let main () =

(* Eval declaration *) let rctx = default_rctx () in - let rctx = (try eval_decls lexps rctx + print_string yellow; + let rctx = (try eval_decls lexps rctx; with e -> + print_string reset; print_rte_ctx (!_global_eval_ctx); print_eval_trace (); raise e) in + print_string reset;

(if (get_p_option "rctx") then( print_rte_ctx rctx; print_string "\n")); @@ -301,7 +311,6 @@ let main () = (try (* Check if main is present *) let main = (senv_lookup "main" nctx) in - (* Push main args here if any *)

(* get main body *) let body = (get_rte_variable (Some "main") main rctx) in

===================================== src/env.ml ===================================== --- a/src/env.ml +++ b/src/env.ml @@ -151,7 +151,7 @@ let set_rte_variable idx name (lxp: value_type) ctx =

(* This function is used when we enter a new scope *) (* it saves the size of the environment before temp var are added *) -(* it allow us to remove temporary variables when we enter a new scope *) +(* it allow us to remove temporary variables when we enter a new scope * ) let local_ctx ctx = let (l, (_, _)) = ctx in let osize = length l in @@ -181,7 +181,7 @@ let temp_ctx (ctx: runtime_env): runtime_env = (select_n ctx osize)) else ctx -;; +;; *)

(* Select the n first variable present in the env *) let nfirst_rte_var n ctx =

===================================== src/eval.ml ===================================== --- a/src/eval.ml +++ b/src/eval.ml @@ -76,6 +76,7 @@ let rec _eval lxp ctx i: (value_type) = (* ---------------- *) | Imm(Integer (_, i)) -> Vint(i) | Imm(String (_, s)) -> Vstring(s) + | Imm(sxp) -> Vsexp(sxp) | Inductive (_, _, _, _) -> Vdummy | Cons (_, label) -> Vcons (label, []) | Lambda (_, _, _, lxp) -> Closure(lxp, ctx) @@ -129,6 +130,7 @@ and eval_call ctx i lname args =

let rec eval_call f args ctx = match f, args with + (* | Vcons ((_, "quote"), _), [vsxp] -> vsxp *) | Vcons (n, []), _ -> Vcons(n, args)

(* we add an argument to the closure *) @@ -225,9 +227,6 @@ and _eval_decls (decls: ((vdef * lexp * ltype) list)) add_rte_variable (Some name) Vdummy ctx) ctx decls in

- (* local ctx saves the number of declared variable inside ctx *) - (* This is used to remove temporary variables when entering a Call *) - let ctx = local_ctx ctx in let n = (List.length decls) - 1 in

(* Read declarations once and push them *)

===================================== src/lexp.ml ===================================== --- a/src/lexp.ml +++ b/src/lexp.ml @@ -21,11 +21,14 @@ You should have received a copy of the GNU General Public License along with this program. If not, see http://www.gnu.org/licenses/. *)

open Util +open Fmt + open Sexp open Pexp + open Myers open Grammar -open Fmt + (* open Unify *) module S = Subst

@@ -593,7 +596,7 @@ and _lexp_to_str ctx exp = | String (_, s) -> tval (""" ^ s ^ """) | Integer(_, s) -> tval (string_of_int s) | Float (_, s) -> tval (string_of_float s) - | _ -> internal_error "Wrong Imm value.") + | e -> sexp_to_str e)

| Var ((loc, name), idx) -> name ^ (index idx) ;

===================================== src/lparse.ml ===================================== --- a/src/lparse.ml +++ b/src/lparse.ml @@ -338,6 +338,10 @@ and lexp_call (fun_name: pexp) (sargs: sexp list) ctx i = 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 + (* consume Arrows and args together *) let rec get_return_type name i ltp args = match ltp, args with @@ -392,11 +396,7 @@ 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 = try (from_lctx ctx) - with e -> - lexp_fatal loc "Could not convert lexp context into rte context" in - - let sxp = match eval lxp rctx with + let sxp = match eval lxp (from_lctx ctx) with (* (Macro_ sexp) is returned *) | Vcons(_, [Vsexp(sxp)]) -> sxp | v -> value_print v; print_string "\n"; @@ -407,6 +407,30 @@ and lexp_call (fun_name: pexp) (sargs: sexp list) ctx i = let lxp, ltp = _lexp_p_infer pxp ctx (i + 1) in Call(lxp, new_args), ltp 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 + | 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 + | _ -> 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 *) @@ -416,6 +440,13 @@ and lexp_call (fun_name: pexp) (sargs: sexp list) ctx i = | (Pvar (l, n), Builtin(tp, "Macro", _)) when tp = MacroType -> handle_macro_call (l, n)

+ | (Pvar (l, "qquote"), _) -> handle_qq l + + (* Call to quote * ) + | (Pvar (l, "'"), _) -> (match (handle_named_call (l, "'")), sargs with + | (Call (n, _), ltp), [sxp] -> Call(n, [(Aexplicit, Imm(sxp))]), ltp + | e, _ -> lexp_warning loc "quote operator expects one argument"; e) *) + (* Call to Vanilla or constructor *) | (Pvar v, _) -> handle_named_call v

===================================== src/prelexer.ml ===================================== --- a/src/prelexer.ml +++ b/src/prelexer.ml @@ -156,13 +156,19 @@ let prelex_string str = let fin = open_in "_temp_hack" in prelex "string" fin 1 [] []

-let rec pretokens_print pretokens = - List.iter (fun pt -> - print_string " "; - match pt with - | Preblock(_,pts,_) - -> print_string "{"; pretokens_print pts; print_string " }" - | Pretoken(_, str) -> print_string str - | Prestring(_, str) - -> print_string """; print_string str; print_string """) - pretokens + +let rec _pretokens_to_str pretok = + match pretok with + | Preblock(_,pts,_) -> "{" ^ ( + List.fold_left (fun str pts -> str ^ " " ^ (_pretokens_to_str pts)) + "" pts) ^ " }" + | Pretoken(_, str) -> str + | Prestring(_, str) -> """ ^ str ^ """ + +let pretokens_to_str pretokens = + List.fold_left (fun str pt -> str ^ (_pretokens_to_str pt)) "" pretokens + + +let pretokens_print p = print_string (pretokens_to_str p) + +

===================================== src/sexp.ml ===================================== --- a/src/sexp.ml +++ b/src/sexp.ml @@ -63,19 +63,20 @@ let emptyString = hString ""

(*************** The Sexp Printer *********************)

-let rec sexp_print sexp = +let rec sexp_to_str sexp = match sexp with - | Epsilon -> print_string "()" (* "ε" *) - | Block(_,pts,_) -> print_string "{"; pretokens_print pts; print_string " }" - | Symbol(_, name) -> print_string name - | String(_, str) -> print_string """; print_string str; print_string """ - | Integer(_, n) -> print_int n - | Float(_, x) -> print_float x - | Node(f, args) -> print_string "("; - sexp_print f; - List.iter (fun sexp -> print_string " "; sexp_print sexp) - args; - print_string ")" + | Epsilon -> "ε" (* "ε" *) + | Block(_,pts,_) -> "{" ^ (pretokens_to_str pts) ^ " }" + | Symbol(_, name) -> name + | String(_, str) -> """ ^ str ^ """ + | Integer(_, n) -> string_of_int n + | Float(_, x) -> string_of_float x + | Node(f, args) -> + let str = "(" ^ (sexp_to_str f) in + (List.fold_left (fun str sxp -> + str ^ " " ^ (sexp_to_str sxp)) str args) ^ ")" + +let sexp_print sexp = print_string (sexp_to_str sexp)

let rec sexp_location s = match s with

View it on GitLab: https://gitlab.com/monnier/typer/commit/8ec96e19a8207ae1e03dc4a3a21cb701b79e...