Simon Génier pushed to branch gambit at Stefan / Typer
Commits: 1577169b by Simon Génier at 2021-03-10T15:50:13-05:00 Add a backend to compile Typer to Scheme.
- - - - -
14 changed files:
- GNUmakefile - + src/backend.ml - src/dune - src/elab.ml - src/eval.ml - + src/frontend.ml - + src/gambit.ml - src/lexer.ml - src/lexp.ml - + src/main.ml - src/myers.ml - src/option.ml - src/prelexer.ml - + src/source.ml
Changes:
===================================== GNUmakefile ===================================== @@ -54,8 +54,8 @@ typer: # ============================ # Build typer # ============================ - $(OCAMLBUILD) src/REPL.$(COMPILE_MODE) -I src $(OBFLAGS) - @$(MV) $(BUILDDIR)/src/REPL.$(COMPILE_MODE) $(BUILDDIR)/typer + $(OCAMLBUILD) src/main.$(COMPILE_MODE) -I src $(OBFLAGS) + @$(MV) $(BUILDDIR)/src/main.$(COMPILE_MODE) $(BUILDDIR)/typer
tests-build: # ============================
===================================== src/backend.ml ===================================== @@ -0,0 +1,78 @@ +(* Copyright (C) 2021 Free Software Foundation, Inc. + * + * Author: Simon Génier simon.genier@umontreal.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/. *) + +open Debruijn +open Env +open Eval +open Lexp + +type value = value_type + +class virtual backend = object + (* Processes (interpret or compile, depending on the backend) a block of + mutually recursive declarations. *) + method virtual process_decls : elab_context -> ldecls -> unit + + method interactive : interactive_backend option = None +end + +and virtual interactive_backend = object (self) + inherit backend + + method! interactive = Some (self :> interactive_backend) + + method virtual eval_expr : elab_context -> lexp -> value + + method virtual print_rte_ctx : unit + + method virtual dump_rte_ctx : unit +end + +class ast_interpreter rctx = object + inherit interactive_backend + + val mutable rctx = rctx + + method process_decls ectx ldecls = + let lctx = ectx_to_lctx ectx in + let _, eldecls = Opslexp.clean_decls lctx ldecls in + rctx <- eval_decls eldecls rctx + + method eval_expr ectx lexp = + let lctx = ectx_to_lctx ectx in + let elexp = Opslexp.erase_type lctx lexp in + debug_eval elexp rctx + + method print_rte_ctx = print_rte_ctx rctx + + method dump_rte_ctx = dump_rte_ctx rctx +end + +class gambit_compiler ectx output = object + inherit backend + + val mutable sctx = Gambit.ScmContext.of_ectx ectx + + method process_decls ectx ldecls = + let lctx = ectx_to_lctx ectx in + let sctx', sdecls = Gambit.scheme_of_decls lctx sctx ldecls in + sctx <- sctx'; + Gambit.Scm.print output sdecls +end
===================================== src/dune ===================================== @@ -1,6 +1,6 @@ ;; -*- lisp-data -*- (executable - (name REPL) + (name main) ;; (public_name typer) (libraries "zarith" "str") )
===================================== src/elab.ml ===================================== @@ -1773,7 +1773,7 @@ let sform_load usr_elctx loc sargs _ot =
let read_file file_name elctx = let pres = - try prelex_file file_name with + try prelex (Source.of_file_name file_name) with | Sys_error _ -> error ~loc ("Could not load `" ^ file_name ^ "`: file not found."); [] in @@ -1858,7 +1858,7 @@ let default_ectx
(* Read BTL files *) let read_file file_name elctx = - let pres = prelex_file file_name in + let pres = prelex (Source.of_file_name file_name) in let sxps = lex default_stt pres in let _, lctx = lexp_p_decls [] sxps elctx in lctx in
===================================== src/eval.ml ===================================== @@ -353,7 +353,8 @@ let make_float loc _depth args_val = match args_val with
let make_block loc _depth args_val = match args_val with (* From what would we like to make a block? *) - | [Vstring str] -> Vsexp (Block (loc, (Prelexer.prelex_string str), loc)) + | [Vstring str] + -> Vsexp (Block (loc, (Prelexer.prelex (Source.of_string str)), loc)) | _ -> error loc "Sexp.block expects one string as argument"
let reader_parse loc _depth args_val = match args_val with @@ -487,7 +488,14 @@ and eval_var ctx lxp v = ("Variable: " ^ L.maybename (snd name) ^ (str_idx idx) ^ " was not found ")
(* unef: unevaluated function (to make the trace readable) *) -and eval_call loc unef i f args = +and eval_call + loc + (unef : elexp) + (i : eval_debug_info) + (f : value_type) + (args : value_type list) + : value_type = + match f, args with (* return result of eval *) | _, [] -> f @@ -1145,14 +1153,13 @@ let from_lctx (lctx: lexp_context): runtime_env = | CVempty -> Myers.nil | CVlet (loname, def, _, lctx) -> let rctx = from_lctx lctx in - Myers.cons (loname, - ref (match def with - | LetDef (_, e) - -> if closed_p rctx (OL.fv e) then - eval (OL.erase_type lctx e) rctx - else Vundefined - | _ -> Vundefined)) - rctx + let value = + match def with + | LetDef (_, e) when closed_p rctx (OL.fv e) + -> eval (OL.erase_type lctx e) rctx + | _ -> Vundefined + in + Myers.cons (loname, ref value) rctx | CVfix (defs, lctx) -> let fvs = List.fold_left (fun fvs (_, e, _)
===================================== src/frontend.ml ===================================== @@ -0,0 +1,75 @@ +(* Copyright (C) 2021 Free Software Foundation, Inc. + * + * Author: Simon Génier simon.genier@umontreal.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/. *) + +open Debruijn +open Lexer +open Lexp +open Opslexp +open Prelexer +open Sexp + +let decls_of_source + (source : Source.t) + (ectx : elab_context) + : ldecls list * elab_context = + + let pretokens = prelex source in + let tokens = lex Grammar.default_stt pretokens in + let ldecls, ectx = Elab.lexp_p_decls [] tokens ectx in + (ldecls, ectx) + +(** Elaborate Typer source from an interactive session. The difference with + normal Typer is that expressions are also accepted in addition to + declarations. + + Note that all declarations are hoisted before expressions. *) +let decls_of_interactive + (source : Source.t) + (ectx : elab_context) + : ldecls list * lexp list * elab_context = + + let classify_sexps nodes = + let rec loop sexps decls exprs = + match sexps with + | [] -> (List.rev decls, List.rev exprs) + | sexp :: sexps + -> (match sexp with + | Node (Symbol (_, ("_=_" | "_:_")), [Symbol _; _]) + -> loop sexps (sexp :: decls) exprs + | Node (Symbol (_, ("_=_")), [Node _; _]) + -> loop sexps (sexp :: decls) exprs + | _ + -> loop sexps decls (sexp :: exprs)) + in loop nodes [] [] + in + + let pretokens = prelex source in + let tokens = lex Grammar.default_stt pretokens in + (* FIXME: This is too eager: it prevents one declaration from changing + * the grammar used in subsequent declarations. *) + let sexps = sexp_parse_all_to_list (ectx_to_grm ectx) tokens (Some ";") in + let decls, exprs = classify_sexps sexps in + + let ldecls, ectx = Elab.lexp_p_decls decls [] ectx in + + let lexprs = Elab.lexp_parse_all exprs ectx in + List.iter (fun lexpr -> ignore (check (ectx_to_lctx ectx) lexpr)) lexprs; + + (ldecls, lexprs, ectx)
===================================== src/gambit.ml ===================================== @@ -0,0 +1,269 @@ +(* Copyright (C) 2021 Free Software Foundation, Inc. + * + * Author: Simon Génier simon.genier@umontreal.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/. *) + +open Printf + +open Debruijn +open Elexp + +type ldecls = Lexp.ldecls +type lexp = Lexp.lexp + +module Scm = struct + type t = + | Symbol of string + | List of t list + | String of string + | Integer of Z.t + | Float of float + + let begin' : t = Symbol "begin" + let case : t = Symbol "case" + let define : t = Symbol "define" + let double_right_arrow : t = Symbol "=>" + let else' : t = Symbol "else" + let lambda : t = Symbol "lambda" + let let' : t = Symbol "let" + let letrec : t = Symbol "letrec" + let quote : t = Symbol "quote" + let prim_vector : t = Symbol "##vector" + let prim_vector_ref : t = Symbol "##vector-ref" + + let is_valid_bare_symbol (name : string) : bool = + let length = String.length name in + let rec loop i = + if Int.equal length i + then true + else + match name.[i] with + | '|' | ''' | ' ' | '(' | ')' -> false + | _ -> loop (i + 1) + in loop 0 + + let escape_symbol (name : string) : string = + if is_valid_bare_symbol name + then name + else + let buffer = Buffer.create (String.length name) in + Buffer.add_char buffer '|'; + let encode_char = function + | '|' -> Buffer.add_string buffer {|||} + | c -> Buffer.add_char buffer c + in + String.iter encode_char name; + Buffer.add_char buffer '|'; + Buffer.contents buffer + + let symbol (name : string) : t = + Symbol (escape_symbol name) + + let rec string_of_exp (exp : t) : string = + match exp with + | Symbol (name) -> name + | List (elements) + -> "(" ^ String.concat " " (List.map string_of_exp elements) ^ ")" + | String (value) + -> let length = String.length value in + let buffer = Buffer.create length in + let encode_char = function + | '\x00' .. '\x06' as c + -> (Buffer.add_string buffer "\x"; + Buffer.add_string buffer (Printf.sprintf "%02d" (Char.code c))) + | '\x07' -> Buffer.add_string buffer "\a" + | '\x08' -> Buffer.add_string buffer "\b" + | '\x09' -> Buffer.add_string buffer "\t" + | '\' -> Buffer.add_string buffer "\\" + | '"' -> Buffer.add_string buffer "\"" + | c -> Buffer.add_char buffer c + in + String.iter encode_char value; + Buffer.contents buffer + | Integer (value) -> Z.to_string value + | Float (value) -> string_of_float value + + let print (output : out_channel) (exp : t) : unit = + output_string output (string_of_exp exp); + output_char output '\n' +end + +let gensym : string -> string = + let counter = ref 0 in + fun name -> + let i = !counter in + counter := i + 1; + let name = sprintf "%s%%%d" name i in + Scm.escape_symbol name + +module ScmContext = struct + (* Maps Debruijn indices to Scheme variable names. *) + type t = string Myers.myers + + let nil : t = Myers.nil + + let of_ectx (ectx : elab_context) : t = + let f ((_, name), _, _ : env_elem) : string = Option.get name in + Myers.map f (ectx_to_lctx ectx) + + let intro (sctx : t) (_, name : vname) : t * string = + let name = gensym (Option.value ~default:"g" name) in + Myers.cons name sctx, name + + let intro_binding (sctx : t) (name, elexp : vname * elexp) = + let sctx, name = intro sctx name in + sctx, (name, elexp) + + let lookup (sctx : t) (index : int) : string option = + Myers.nth_opt index sctx +end + +let rec scheme_of_expr (sctx : ScmContext.t) (elexp : elexp) : Scm.t = + match elexp with + | Elexp.Imm (Sexp.String (_, s)) -> Scm.String s + + | Elexp.Imm (Sexp.Integer (_, i)) -> Scm.Integer i + + | Elexp.Imm (Sexp.Float (_, f)) -> Scm.Float f + + | Elexp.Builtin (_, "Sexp.node") -> Scm.Symbol "cons" + + | Elexp.Builtin (_, "Sexp.symbol") -> Scm.Symbol "string->symbol" + + | Elexp.Builtin (_, name) -> failwith ("TODO: Built-in "" ^ name ^ """) + + | Elexp.Var (_, index) + -> (match ScmContext.lookup sctx index with + | None -> Scm.Symbol "TODO" + | Some name -> Scm.Symbol name) + + | Elexp.Let (_, bindings, body) + -> if List.length bindings = 0 + then scheme_of_expr sctx body + else + let sctx, bindings = + Listx.fold_left_map ScmContext.intro_binding sctx bindings + in + let scheme_of_binding (name, elexp) = + Scm.List [Scm.Symbol name; scheme_of_expr sctx elexp] + in + Scm.List [Scm.letrec; + Scm.List (List.map scheme_of_binding bindings); + scheme_of_expr sctx body] + + | Elexp.Lambda (name, body) + -> let sctx, name = ScmContext.intro sctx name in + Scm.List [Scm.lambda; + Scm.List [Scm.Symbol name]; + scheme_of_expr sctx body] + + | Elexp.Call (head, tail) + -> let scm_head = scheme_of_expr sctx head in + let scm_tail = List.map (scheme_of_expr sctx) tail in + Scm.List (scm_head :: scm_tail) + + | Elexp.Cons (arity, (_, name)) + -> let rec make_vars i vars = + match i with + | 0 -> vars + | _ -> make_vars (i - 1) (Scm.Symbol (gensym "") :: vars) + in + let vars = make_vars arity [] in + let vector_expr = + Scm.List (Scm.prim_vector + :: Scm.List [Scm.quote; Scm.symbol name] + :: List.rev vars) + in + let rec make_curried_lambda vars body = + match vars with + | [] -> body + | var :: vars' + -> let body' = Scm.List [Scm.lambda; Scm.List [var]; body] in + make_curried_lambda vars' body' + in + make_curried_lambda vars vector_expr + + | Elexp.Case (_, motive, branches, default_branch) + -> let motive_name = Scm.Symbol (gensym "") in + let scm_default_branch = + match default_branch with + | None -> [] + | Some (name, body) + -> let sctx, name = ScmContext.intro sctx name in + (* (else => (lambda (name) body)) *) + [Scm.List [Scm.else'; + Scm.double_right_arrow; + Scm.List [Scm.lambda; + Scm.List [Scm.Symbol name]; + scheme_of_expr sctx body]]] + in + let add_branch cons_name (_, field_names, branch_body) scm_branches = + let make_binding (sctx, bindings, i) (location, name) = + match name with + | Some "_" -> sctx, bindings, Z.succ i + | _ + -> let sctx, name = ScmContext.intro sctx (location, name) in + let binding = Scm.List [Scm.Symbol name; + Scm.List [Scm.prim_vector_ref; + motive_name; + Scm.Integer i]] + in + sctx, binding :: bindings, Z.succ i + in + let sctx, bindings, _ = List.fold_left make_binding (sctx, [], Z.one) field_names in + let scm_branch = + Scm.List [Scm.List [Scm.symbol cons_name]; + if Int.equal (List.length bindings) 0 + then scheme_of_expr sctx branch_body + else + Scm.List [Scm.let'; + Scm.List (List.rev bindings); + scheme_of_expr sctx branch_body]] + in + scm_branch :: scm_branches + in + let scm_branches = + List.rev_append (SMap.fold add_branch branches []) scm_default_branch + in + let scm_case = + Scm.List (Scm.case + :: Scm.List [Scm.prim_vector_ref; + motive_name; + Scm.Integer Z.zero] + :: scm_branches) + in + Scm.List [Scm.let'; + Scm.List [Scm.List [motive_name; scheme_of_expr sctx motive]]; + scm_case] + + | Elexp.Type _ -> Scm.Symbol "lets-hope-its-ok-if-i-erase-this" + + | _ -> failwith ("[gambit] unsupported elexp: " ^ elexp_string elexp) + +let scheme_of_decl (sctx : ScmContext.t) (name, elexp : string * elexp) : Scm.t = + Scm.List ([Scm.define; Scm.Symbol name; scheme_of_expr sctx elexp]) + +let scheme_of_decls + (lctx : lexp_context) + (sctx : ScmContext.t) + (ldecls : ldecls) + : ScmContext.t * Scm.t = + + let _, eldecls = Opslexp.clean_decls lctx ldecls in + let sctx, eldecls = Listx.fold_left_map ScmContext.intro_binding sctx eldecls in + sctx, Scm.List (Scm.begin' :: List.map (scheme_of_decl sctx) eldecls)
===================================== src/lexer.ml ===================================== @@ -145,7 +145,7 @@ let lex tenv (pts : pretoken list) : sexp list = gettokens pts 0 0 []
let lex_str (str: string) tenv = - let pretoks = prelex_string str in + let pretoks = prelex (Source.of_string str) in lex tenv pretoks
let sexp_parse_str (str: string) tenv grm limit =
===================================== src/lexp.ml ===================================== @@ -118,6 +118,7 @@ type ltype = lexp | SLlub of lexp * lexp
type ldecl = vname * lexp * ltype +type ldecls = ldecl list
type varbind = | Variable
===================================== src/main.ml ===================================== @@ -0,0 +1,272 @@ +(* Copyright (C) 2021 Free Software Foundation, Inc. + * + * Author: Simon Génier simon.genier@umontreal.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/. *) + +open Printf + +open Backend +open Debruijn +open Elab +open Eval +open Fmt +open Lexp + +let error = Log.log_error ~section:"MAIN" + +let arg_batch = ref false +let arg_files = ref [] +let backend_name = ref "interpreter" + +(* ./typer [options] files *) +let arg_defs = + [("--batch", Arg.Set arg_batch, "Don't run the interactive loop"); + + ("--verbosity", + Arg.String Log.set_typer_log_level_str, + "Set the logging level"); + + ("-v", Arg.Unit Log.increment_log_level, "Increment verbosity"); + + ("--backend", + Arg.Symbol (["interpreter"; "gambit"], fun name -> backend_name := name), + "Select the backend"); + ] + +let print_and_clear_log () = + Log.print_and_clear_log (); + flush stdout + +let handle_stopped_compilation msg = + Log.print_and_clear_log (); + print_endline msg; + flush stdout + +let welcome_message = +" Typer 0.0.0 - Interpreter - (c) 2016-2021 + + %quit (%q) : leave REPL + %help (%h) : print help +" + +let help_message = +" %quit (%q) : leave REPL + %who (%w) : print runtime environment + %info (%i) : print elaboration environment + %calltrace (%ct): print eval trace of last call + %typertrace (%tt): print typer trace + %readfile : read a Typer file + %help (%h) : print help +" + +let print_input_line i = + printf " In[%02d] >> " i + +(* Read stdin for input. + + Returns only when the last char is ';'. We can use '%' to prevent parsing. If + return is pressed and the last char is not ';' then indentation will be + added. *) +let rec read_input i = + print_input_line i; + flush stdout; + + let rec loop str i = + flush stdout; + let line = input_line stdin in + let s = String.length str in + let n = String.length line in + if s = 0 && n = 0 then read_input i else + (if n = 0 then ( + print_string " . "; + print_string (String.make (i * 4) ' '); + loop str (i + 1)) + else + let str = if s > 0 then String.concat "\n" [str; line] else line in + if line.[n - 1] = ';' || line.[0] = '%' then + str + else ( + print_string " . "; + print_string (String.make (i * 4) ' '); + loop str (i + 1))) in + + loop "" i + +let process_file + (backend : #backend) + (ectx : elab_context) + (file_name : string) + : elab_context = + + try + let source = Source.of_file_name file_name in + let decls, ectx = Frontend.decls_of_source source ectx in + List.iter (backend#process_decls ectx) decls; + ectx + with + | Sys_error _ + -> (error ("file "" ^ file_name ^ "" does not exist."); + ectx) + +let process_interactive + (interactive : #interactive_backend) + (i : int) + (ectx : elab_context) + (input : string) + : elab_context = + + let source = Source.of_string input in + let decls, exprs, ectx = Frontend.decls_of_interactive source ectx in + + List.iter (interactive#process_decls ectx) decls; + print_and_clear_log (); + + let values = List.map (interactive#eval_expr ectx) exprs in + List.iter (print_eval_result i) values; + print_and_clear_log (); + + ectx + +let rec repl + (i : int) + (interactive : interactive_backend) + (ectx : elab_context) + : unit = + + let input = try read_input i with End_of_file -> "%quit" in + + let ectx = + match input with + (* Check special keywords *) + | "%quit" | "%q" + -> exit 0 + | "%help" | "%h" + -> print_string help_message; + ectx + | "%calltrace" | "%ct" + -> print_eval_trace None; + ectx + | "%typertrace" | "%tt" + -> print_typer_trace None; + ectx + | "%lcollisions" | "%cl" + -> Util.get_stats_hashtbl (WHC.stats hc_table); + ectx + + (* command with arguments *) + | _ when input.[0] = '%' && input.[1] != ' ' + -> (match String.split_on_char ' ' input with + | "%readfile" :: args + -> (try + let ectx = + List.fold_left (process_file interactive) ectx args + in + print_and_clear_log (); + ectx + with + | Log.Stop_Compilation msg + -> handle_stopped_compilation msg; + ectx) + | "%who" :: args | "%w" :: args + -> (match args with + | ["all"] -> interactive#dump_rte_ctx + | _ -> interactive#print_rte_ctx); + ectx + | "%info" :: args | "%i" :: args + -> (match args with + | ["all"] -> dump_lexp_ctx (ectx_to_lctx ectx) + | _ -> print_lexp_ctx (ectx_to_lctx ectx)); + ectx + + | cmd :: _ + -> error (""" ^ cmd ^ "" is not a correct repl command"); + ectx + + | _ + -> ectx) + + (* eval input *) + | _ + -> (try process_interactive interactive i ectx input with + | Log.Stop_Compilation msg + -> handle_stopped_compilation msg; + ectx + | Log.Internal_error msg + -> handle_stopped_compilation ("Internal error: " ^ msg); + ectx + | Log.User_error msg + -> handle_stopped_compilation ("Fatal user error: " ^ msg); + ectx) + + in repl (i + 1) interactive ectx + +let main () = + Arg.parse arg_defs (fun file -> arg_files := file :: !arg_files) ""; + + let is_batch = !arg_batch in + let file_names = List.rev !arg_files in + let backend = + match !backend_name with + | "interpreter" + -> (new ast_interpreter default_rctx :> backend) + | "gambit" + -> (new gambit_compiler default_ectx stdout :> backend) + | backend_name + -> (print_string ("unknown backend: " ^ backend_name); + exit 1) + in + + let process_file = + if is_batch + then + fun (ectx, i) file_name + -> let ectx = process_file backend ectx file_name in + ectx, i + else + (print_string (make_title " TYPER REPL "); + print_string welcome_message; + print_string (make_sep '='); + flush stdout; + fun (ectx, i) file_name + -> printf " In[%02d] >> %%readfile %s\n" i file_name; + let ectx = process_file backend ectx file_name in + ectx, i + 1) + in + + let ectx, i = + try + let ectx, i = List.fold_left process_file (default_ectx, 0) file_names in + print_and_clear_log (); + ectx, i + with + | Log.Stop_Compilation msg + -> handle_stopped_compilation msg; + exit 1 + | Log.Internal_error msg as e + -> handle_stopped_compilation ("Internal error: " ^ msg); + raise e + | Log.User_error msg + -> handle_stopped_compilation ("Fatal user error: " ^ msg); + exit 1 + in + + match is_batch, backend#interactive with + | false, Some interactive -> repl i interactive ectx + | _ -> () + +let _ = main ()
===================================== src/myers.ml ===================================== @@ -75,6 +75,11 @@ let rec nthcdr n l =
let nth n l = car (nthcdr n l)
+let nth_opt (n : int) (l : 'a myers) : 'a option = + match nthcdr n l with + | Mnil -> None + | Mcons (x, _, _, _) -> Some x + (* While `nth` is O(log N), `set_nth` is O(N)! :-( *) let rec set_nth n v l = match (n, l) with | 0, Mcons (_, cdr, s, tail) -> Mcons (v, cdr, s, tail)
===================================== src/option.ml ===================================== @@ -30,3 +30,8 @@ let get (o : 'a option) : 'a = match o with | Some v -> v | None -> invalid_arg "expected Some" + +let value ~(default : 'a) (o : 'a option) : 'a = + match o with + | Some v -> v + | None -> default
===================================== src/prelexer.ml ===================================== @@ -50,15 +50,15 @@ let inc_cp (cp:charpos) (c:char) = (* Count char positions in utf-8: don't count the non-leading bytes. *) if utf8_head_p c then cp+1 else cp
-let rec prelex (file : string) (getline : unit -> string) ln ctx acc (doc : string) +let rec loop (source : Source.t) ln ctx acc (doc : string) : pretoken list = + let file = Source.file_name source in try - (* let fin = open_in file in *) - let line = getline () in + let line = Source.next_line source in let limit = String.length line in - let nextline = prelex file getline (ln + 1) in - let rec prelex' ctx (bpos:bytepos) (cpos:charpos) acc doc = - let nexttok = prelex' ctx in + let nextline = loop source (ln + 1) in + let rec loop' ctx (bpos:bytepos) (cpos:charpos) acc doc = + let nexttok = loop' ctx in if bpos >= limit then nextline ctx acc doc else match line.[bpos] with | c when c <= ' ' -> nexttok (bpos+1) (cpos+1) acc doc @@ -100,18 +100,19 @@ let rec prelex (file : string) (getline : unit -> string) ln ctx acc (doc : stri | char -> prestring (bp+2) (cp+2) (char :: chars)) | char -> prestring (bp+1) (inc_cp cp char) (char :: chars) in prestring (bpos+1) (cpos+1) [] - | '{' -> prelex' ((ln, cpos, bpos, acc) :: ctx) (bpos+1) (cpos+1) [] doc + | '{' -> loop' ((ln, cpos, bpos, acc) :: ctx) (bpos+1) (cpos+1) [] doc | '}' -> (match ctx with - | ((sln, scpos, _sbpos, sacc) :: ctx) -> - prelex' ctx (bpos+1) (cpos+1) - (Preblock ({file=file; line=sln; column=scpos; docstr=doc}, - List.rev acc, - {file=file; line=ln; column=(cpos + 1); docstr=doc}) - :: sacc) "" - | _ -> (prelexer_error {file=file; line=ln; column=cpos; docstr=doc} + | ((sln, scpos, _, sacc) :: ctx) + -> loop' ctx (bpos+1) (cpos+1) + (Preblock ({file=file; line=sln; column=scpos; docstr=doc}, + List.rev acc, + {file=file; line=ln; column=(cpos + 1); docstr=doc}) + :: sacc) "" + | _ + -> (prelexer_error {file=file; line=ln; column=cpos; docstr=doc} "Unmatched closing brace"; - prelex' ctx (bpos+1) (cpos+1) acc doc)) + loop' ctx (bpos+1) (cpos+1) acc doc)) | char (* A pretoken. *) -> let rec pretok bp cp = if bp >= limit then @@ -130,7 +131,7 @@ let rec prelex (file : string) (getline : unit -> string) ln ctx acc (doc : stri pretok (bp + 2) (1 + inc_cp cp char) | char -> pretok (bp+1) (inc_cp cp char) in pretok (bpos+1) (inc_cp cpos char) - in prelex' ctx 0 1 acc doc (* Traditionally, column numbers start at 1 :-( *) + in loop' ctx 0 1 acc doc (* Traditionally, column numbers start at 1 :-( *) with End_of_file -> match ctx with | [] -> List.rev acc @@ -138,26 +139,9 @@ let rec prelex (file : string) (getline : unit -> string) ln ctx acc (doc : stri (prelexer_error {file=file; line=ln; column=cpos; docstr=""} "Unmatched opening brace"; List.rev acc)
- -let prelex_file file = - let fin = open_in file - in prelex file (fun _ -> input_line fin) - (* Traditionally, line numbers start at 1 :-( *) - 1 [] [] "" - -let prelex_string str = - let pos = ref 0 in - let getline () = - let start = !pos in - if start >= String.length str then raise End_of_file else - let i = try String.index_from str start '\n' - with Not_found -> String.length str - 1 in - let npos = i + 1 in - pos := npos; - let line = string_sub str start npos in - (* print_string ("Read line: " ^ line); *) - line - in prelex "<string>" getline 1 [] [] "" +let prelex (source : Source.t) : pretoken list = + (* Traditionally, line numbers start at 1 :-( *) + loop source 1 [] [] ""
let pretoken_name pretok = match pretok with
===================================== src/source.ml ===================================== @@ -0,0 +1,48 @@ +(* Copyright (C) 2021 Free Software Foundation, Inc. + * + * Author: Simon Génier simon.genier@umontreal.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/. *) + +type t = + | File of string * in_channel + | String of string * int ref + +let of_file_name file_name = + File (file_name, open_in file_name) + +let of_string source = + String (source, ref 0) + +let next_line = function + | File (_, in_channel) -> input_line in_channel + | String (source, pos) + -> (let start = !pos in + if start >= String.length source + then raise End_of_file + else + let npos = + match String.index_from_opt source start '\n' with + | Some (new_index) -> new_index + 1 + | None -> String.length source + in + pos := npos; + String.sub source start (npos - start)) + +let file_name = function + | File (file_name, _) -> file_name + | String _ -> "<string>"
View it on GitLab: https://gitlab.com/monnier/typer/-/commit/1577169b7d51928f9aa4a86511504c1d50...
Afficher les réponses par date