mirror of
https://github.com/ProgramSnail/Lama.git
synced 2025-12-05 22:38:44 +00:00
src: Adding new switch and moving code from Driver to Language
Signed-off-by: Kakadu <Kakadu@pm.me>
This commit is contained in:
Kakadu
parent
6a7ba9df5f
commit
c74757cbb7
5 changed files with 268 additions and 61 deletions
2
Makefile
2
Makefile
|
|
@ -31,5 +31,5 @@ clean:
|
|||
make clean -C runtime
|
||||
make clean -C stdlib
|
||||
make clean -C regression
|
||||
|
||||
$(MAKE) clean -C bench
|
||||
|
||||
|
|
|
|||
|
|
@ -1,45 +1,11 @@
|
|||
open Ostap
|
||||
|
||||
let parse cmd =
|
||||
let s = Util.read cmd#get_infile in
|
||||
let kws = [
|
||||
"skip";
|
||||
"if"; "then"; "else"; "elif"; "fi";
|
||||
"while"; "do"; "od";
|
||||
"repeat"; "until";
|
||||
"for";
|
||||
"fun"; "local"; "public"; "external"; "return"; "import";
|
||||
"length";
|
||||
"string";
|
||||
"case"; "of"; "esac"; "when";
|
||||
"boxed"; "unboxed"; "string"; "sexp"; "array";
|
||||
"infix"; "infixl"; "infixr"; "at"; "before"; "after";
|
||||
"true"; "false"; "lazy"; "eta"; "syntax"]
|
||||
in
|
||||
Util.parse
|
||||
(object
|
||||
inherit Matcher.t s
|
||||
inherit Util.Lexers.decimal s
|
||||
inherit Util.Lexers.string s
|
||||
inherit Util.Lexers.char s
|
||||
inherit Util.Lexers.infix s
|
||||
inherit Util.Lexers.lident kws s
|
||||
inherit Util.Lexers.uident kws s
|
||||
inherit Util.Lexers.skip [
|
||||
Matcher.Skip.whitespaces " \t\n\r";
|
||||
Matcher.Skip.lineComment "--";
|
||||
Matcher.Skip.nestedComment "(*" "*)"
|
||||
] s
|
||||
end
|
||||
)
|
||||
(if cmd#is_workaround then ostap (p:!(Language.constparse cmd) -EOF) else ostap (p:!(Language.parse cmd) -EOF))
|
||||
|
||||
exception Commandline_error of string
|
||||
|
||||
class options args =
|
||||
let n = Array.length args in
|
||||
let dump_ast = 1 in
|
||||
let dump_sm = 2 in
|
||||
let dump_ast = 0b1 in
|
||||
let dump_sm = 0b010 in
|
||||
let dump_source = 0b100 in
|
||||
(* Kakadu: binary masks are cool for C code, but for OCaml I don't see any reason to save memory like this *)
|
||||
let help_string =
|
||||
"Lama compiler. (C) JetBrains Reserach, 2017-2020.\n" ^
|
||||
"Usage: lamac <options> <input file>\n\n" ^
|
||||
|
|
@ -51,6 +17,7 @@ class options args =
|
|||
" -i --- interpret on a source-level interpreter\n" ^
|
||||
" -s --- compile into stack machine code and interpret on the stack machine initerpreter\n" ^
|
||||
" -dp --- dump AST (the output will be written into .ast file)\n" ^
|
||||
" -dsrc --- dump pretty-printed source code\n" ^
|
||||
" -ds --- dump stack machine code (the output will be written into .sm file; has no\n" ^
|
||||
" effect if -i option is specfied)\n" ^
|
||||
" -v --- show version\n" ^
|
||||
|
|
@ -84,6 +51,7 @@ class options args =
|
|||
| "-s" -> self#set_mode `SM
|
||||
| "-i" -> self#set_mode `Eval
|
||||
| "-ds" -> self#set_dump dump_sm
|
||||
| "-dsrc" -> self#set_dump dump_source
|
||||
| "-dp" -> self#set_dump dump_ast
|
||||
| "-h" -> self#set_help
|
||||
| "-v" -> self#set_version
|
||||
|
|
@ -160,7 +128,11 @@ class options args =
|
|||
Buffer.add_string buf "</html>";
|
||||
self#dump_file "html" (Buffer.contents buf)
|
||||
)
|
||||
else ()
|
||||
method dump_source (ast: Language.Expr.t) =
|
||||
if (!dump land dump_source) > 0
|
||||
then Pprinter.pp Format.std_formatter ast;
|
||||
|
||||
|
||||
method dump_SM sm =
|
||||
if (!dump land dump_sm) > 0
|
||||
then self#dump_file "sm" (SM.show_prg sm)
|
||||
|
|
@ -182,9 +154,10 @@ let main =
|
|||
try
|
||||
let cmd = new options Sys.argv in
|
||||
cmd#greet;
|
||||
match (try parse cmd with Language.Semantic_error msg -> `Fail msg) with
|
||||
match (try Language.run_parser cmd with Language.Semantic_error msg -> `Fail msg) with
|
||||
| `Ok prog ->
|
||||
cmd#dump_AST (snd prog);
|
||||
cmd#dump_source (snd prog);
|
||||
(match cmd#get_mode with
|
||||
| `Default | `Compile ->
|
||||
ignore @@ X86.build cmd prog
|
||||
|
|
|
|||
|
|
@ -294,7 +294,7 @@ module Pattern =
|
|||
(* any sexp value *) | SexpTag
|
||||
(* any array value *) | ArrayTag
|
||||
(* any closure *) | ClosureTag
|
||||
with show, foldl, html
|
||||
with show, foldl, html, fmt
|
||||
|
||||
(* Pattern parser *)
|
||||
ostap (
|
||||
|
|
@ -349,6 +349,10 @@ module Expr =
|
|||
(* The type for expressions. Note, in regular OCaml there is no "@type..."
|
||||
notation, it came from GT.
|
||||
*)
|
||||
|
||||
@type qualifier = [ `Local | `Public | `Extern | `PublicExtern ]
|
||||
with show, html
|
||||
|
||||
@type t =
|
||||
(* integer constant *) | Const of int
|
||||
(* array *) | Array of t list
|
||||
|
|
@ -377,7 +381,7 @@ module Expr =
|
|||
(* leave a scope *) | Leave
|
||||
(* intrinsic (for evaluation) *) | Intrinsic of (t config, t config) arrow
|
||||
(* control (for control flow) *) | Control of (t config, t * t config) arrow
|
||||
and decl = [`Local | `Public | `Extern | `PublicExtern ] * [`Fun of string list * t | `Variable of t option]
|
||||
and decl = qualifier * [`Fun of string list * t | `Variable of t option]
|
||||
with show, html
|
||||
|
||||
let notRef = function Reff -> false | _ -> true
|
||||
|
|
@ -1250,3 +1254,39 @@ let parse cmd =
|
|||
)
|
||||
in
|
||||
parse cmd
|
||||
|
||||
|
||||
let run_parser cmd =
|
||||
let s = Util.read cmd#get_infile in
|
||||
let kws = [
|
||||
"skip";
|
||||
"if"; "then"; "else"; "elif"; "fi";
|
||||
"while"; "do"; "od";
|
||||
"repeat"; "until";
|
||||
"for";
|
||||
"fun"; "local"; "public"; "external"; "return"; "import";
|
||||
"length";
|
||||
"string";
|
||||
"case"; "of"; "esac"; "when";
|
||||
"boxed"; "unboxed"; "string"; "sexp"; "array";
|
||||
"infix"; "infixl"; "infixr"; "at"; "before"; "after";
|
||||
"true"; "false"; "lazy"; "eta"; "syntax"]
|
||||
in
|
||||
Util.parse
|
||||
(object
|
||||
inherit Matcher.t s
|
||||
inherit Util.Lexers.decimal s
|
||||
inherit Util.Lexers.string s
|
||||
inherit Util.Lexers.char s
|
||||
inherit Util.Lexers.infix s
|
||||
inherit Util.Lexers.lident kws s
|
||||
inherit Util.Lexers.uident kws s
|
||||
inherit Util.Lexers.skip [
|
||||
Matcher.Skip.whitespaces " \t\n\r";
|
||||
Matcher.Skip.lineComment "--";
|
||||
Matcher.Skip.nestedComment "(*" "*)"
|
||||
] s
|
||||
end
|
||||
)
|
||||
(if cmd#is_workaround then ostap (p:!(constparse cmd) -EOF) else ostap (p:!(parse cmd) -EOF))
|
||||
|
||||
|
|
|
|||
|
|
@ -2,12 +2,11 @@ TOPFILE = lamac
|
|||
OCAMLC = ocamlfind c
|
||||
OCAMLOPT = ocamlfind opt
|
||||
OCAMLDEP = ocamlfind dep
|
||||
SOURCES = version.ml stdpath.ml Language.ml SM.ml X86.ml Driver.ml
|
||||
SOURCES = version.ml stdpath.ml Language.ml Pprinter.ml SM.ml X86.ml Driver.ml
|
||||
CAMLP5 = -syntax camlp5o -package ostap.syntax,GT.syntax.all
|
||||
PXFLAGS = $(CAMLP5)
|
||||
BFLAGS = -rectypes -g
|
||||
BFLAGS = -rectypes -g -w -13-58 -package ostap,unix
|
||||
OFLAGS = $(BFLAGS)
|
||||
LIBS = unix.cma
|
||||
|
||||
all: depend metagen $(TOPFILE)
|
||||
|
||||
|
|
@ -19,10 +18,10 @@ depend: $(SOURCES)
|
|||
$(OCAMLDEP) $(PXFLAGS) *.ml > .depend
|
||||
|
||||
$(TOPFILE): $(SOURCES:.ml=.cmx)
|
||||
$(OCAMLOPT) -o $(TOPFILE) $(OFLAGS) $(LIBS:.cma=.cmxa) -linkpkg -package ostap $(SOURCES:.ml=.cmx)
|
||||
$(OCAMLOPT) -o $(TOPFILE) $(OFLAGS) -linkpkg $(SOURCES:.ml=.cmx)
|
||||
|
||||
$(TOPFILE).byte: $(SOURCES:.ml=.cmo)
|
||||
$(OCAMLC) -o $(TOPFILE).byte $(BFLAGS) $(LIBS) -linkpkg -package ostap $(SOURCES:.ml=.cmo)
|
||||
$(OCAMLC) -o $(TOPFILE).byte $(BFLAGS) -linkpkg $(SOURCES:.ml=.cmo)
|
||||
|
||||
clean:
|
||||
rm -Rf *.cmi *.cmo *.cmx *.annot *.o *.opt *.byte *~ .depend
|
||||
|
|
|
|||
195
src/Pprinter.ml
Normal file
195
src/Pprinter.ml
Normal file
|
|
@ -0,0 +1,195 @@
|
|||
open Language
|
||||
|
||||
class pp_pattern fself = object
|
||||
inherit [Format.formatter, Pattern.t, unit] Pattern.t_t
|
||||
|
||||
method c_Wildcard ppf _ = Format.fprintf ppf "_"
|
||||
method c_Const ppf _ = Format.fprintf ppf "%d"
|
||||
method c_Named ppf _ name _ =
|
||||
(* TODO: should I ignore another argument? *)
|
||||
Format.fprintf ppf "%s" name
|
||||
method c_Sexp ppf _ name xs =
|
||||
match name,xs with
|
||||
| "cons", [l; r] ->
|
||||
Format.fprintf ppf "%a@ :@ %a" fself l fself r
|
||||
| _ ->
|
||||
Format.fprintf ppf "@[%s@ (" name;
|
||||
xs |> List.iter (Format.fprintf ppf "%a@ " fself);
|
||||
Format.fprintf ppf ")@] "
|
||||
|
||||
method c_Array ppf _ xs =
|
||||
Format.fprintf ppf "@[{ ";
|
||||
Format.pp_print_list ~pp_sep:(fun ppf () -> Format.fprintf ppf ", ")
|
||||
fself ppf xs;
|
||||
Format.fprintf ppf " }@]"
|
||||
|
||||
method c_ArrayTag ppf _ = Format.fprintf ppf "#array"
|
||||
method c_SexpTag ppf _ = Format.fprintf ppf "#sexp"
|
||||
method c_ClosureTag ppf _ = Format.fprintf ppf "#fun"
|
||||
method c_UnBoxed ppf _ = failwith "not implemented"
|
||||
method c_String ppf _ = failwith "not implemented"
|
||||
method c_StringTag ppf _ = failwith "not implemented"
|
||||
method c_Boxed ppf _ = failwith "not implemented"
|
||||
end
|
||||
|
||||
let pp_pattern fmt p =
|
||||
GT.transform Pattern.t (new pp_pattern) fmt p
|
||||
|
||||
class pp_expr on_decl fself =
|
||||
object
|
||||
inherit [Format.formatter, Expr.t, unit] Expr.t_t
|
||||
method c_Const ppf _ = Format.fprintf ppf "%d"
|
||||
method c_Var ppf _ = Format.fprintf ppf "%s"
|
||||
method c_Ref ppf _ = Format.fprintf ppf "%s"
|
||||
method c_Array ppf _ xs =
|
||||
Format.fprintf ppf "@[{@ ";
|
||||
xs |> List.iteri (fun i ->
|
||||
if i<>0 then Format.fprintf ppf ",@ ";
|
||||
fself ppf);
|
||||
Format.fprintf ppf " }@]"
|
||||
method c_String ppf _ s = Format.fprintf ppf "\"%s\"" s
|
||||
|
||||
method c_Sexp ppf _ name xs =
|
||||
match name,xs with
|
||||
| "cons", [l;r] -> Format.fprintf ppf "@[%a : %a@]" fself l fself r
|
||||
| _ ->
|
||||
Format.fprintf ppf "@[%s@ (" name;
|
||||
xs |> List.iteri (fun i x ->
|
||||
if i<>0 then Format.fprintf ppf ", ";
|
||||
fself ppf x
|
||||
);
|
||||
Format.fprintf ppf ")@]"
|
||||
|
||||
method c_Binop ppf _ op l r =
|
||||
Format.fprintf ppf "@[%a@ %s@ %a@]" fself l op fself r
|
||||
method c_Elem ppf _ l idx =
|
||||
Format.fprintf ppf "%a[%a]" fself l fself idx
|
||||
method c_ElemRef ppf _ l idx =
|
||||
(* TODO: should Elem and ElemRef be the same? *)
|
||||
Format.fprintf ppf "%a[%a]" fself l fself idx
|
||||
method c_Length ppf _ e =
|
||||
Format.fprintf ppf "@[(%a).length@]" fself e
|
||||
method c_StringVal ppf _ _x__519_ =
|
||||
Format.fprintf ppf "StringVal @[(@,%a@,)@]" fself _x__519_
|
||||
method c_Call ppf _ f args =
|
||||
Format.fprintf ppf "@[%a @[(" fself f;
|
||||
args |> List.iteri (fun i arg ->
|
||||
Format.fprintf ppf "%s%a" (if i<>0 then ", " else "") fself arg
|
||||
);
|
||||
Format.fprintf ppf ")@]@]"
|
||||
|
||||
|
||||
method c_Assign ppf _ _x__526_ _x__527_ =
|
||||
Format.fprintf ppf "@[%a@ :=@ %a@]" fself _x__526_ fself _x__527_
|
||||
method c_Seq ppf _ l r =
|
||||
Format.fprintf ppf "@[<v>%a;@ %a@]" fself l fself r
|
||||
method c_Skip ppf _ = Format.fprintf ppf "skip"
|
||||
method c_If ppf _ _x__533_ _x__534_ _x__535_ =
|
||||
Format.fprintf ppf "@[if %a then @[<v 2>{@,%a@]@ @[<v 2>} else {@,%a@]@ } fi@]"
|
||||
fself _x__533_ fself _x__534_ fself _x__535_
|
||||
method c_While ppf _ cond body =
|
||||
Format.fprintf ppf "@[<v 2>";
|
||||
Format.fprintf ppf "while %a do@," fself cond;
|
||||
fself ppf body;
|
||||
Format.fprintf ppf "@]@ ";
|
||||
Format.fprintf ppf "od";
|
||||
(*Format.fprintf inh___536_ "While @[(@,%a,@,@ %a@,)@]" fself
|
||||
cond fself body*)
|
||||
method c_Repeat ppf _ cond body =
|
||||
Format.fprintf ppf "@[<v 2>";
|
||||
Format.fprintf ppf "repeat@,%a" fself body;
|
||||
Format.fprintf ppf "until %a@]" fself cond
|
||||
|
||||
|
||||
method c_Case ppf _ scru cases _ _ =
|
||||
Format.fprintf ppf "@[<v>";
|
||||
Format.fprintf ppf "@[case %a of@ @]@," fself scru;
|
||||
Format.fprintf ppf "@[<v 0>";
|
||||
cases |> List.iteri (fun i (p,e) ->
|
||||
Format.fprintf ppf "@[%s %a@ ->@ %a@]@ " (if i=0 then " " else "|") pp_pattern p fself e
|
||||
);
|
||||
Format.fprintf ppf "@]";
|
||||
Format.fprintf ppf "@[esac@]";
|
||||
Format.fprintf ppf "@]"
|
||||
|
||||
|
||||
method c_Return ppf _ e =
|
||||
match e with
|
||||
| None -> Format.fprintf ppf "return"
|
||||
| Some e -> Format.fprintf ppf "@[return@ %a@]" fself e
|
||||
|
||||
method c_Ignore ppf _ e =
|
||||
Format.fprintf ppf "@[%a@]" fself e
|
||||
method c_Unit ppf _ = Format.fprintf ppf "Unit "
|
||||
method c_Scope ppf _ xs body =
|
||||
Format.fprintf ppf "@[<v>";
|
||||
Format.pp_print_list ~pp_sep:(fun fmt () -> ())
|
||||
(fun ppf (name, d) ->
|
||||
Format.fprintf ppf "@[%a@]@," (fun ppf -> on_decl (name,ppf)) d)
|
||||
ppf xs;
|
||||
fself ppf body;
|
||||
Format.fprintf ppf "@]"
|
||||
|
||||
method c_Lambda ppf _ args body =
|
||||
Format.fprintf ppf "@[fun (%a) { %a }@]"
|
||||
(Format.pp_print_list ~pp_sep:Format.pp_print_space Format.pp_print_text)
|
||||
args
|
||||
fself
|
||||
body
|
||||
|
||||
method c_Leave ppf _ = Format.fprintf ppf "Leave "
|
||||
method c_Intrinsic ppf _ _ =
|
||||
Format.fprintf ppf "Intrinsic"
|
||||
|
||||
method c_Control ppf _ _ =
|
||||
Format.fprintf ppf "Control"
|
||||
|
||||
end
|
||||
|
||||
class pp_decl fself on_expr = object(self)
|
||||
inherit [ (string*Format.formatter), _, unit] Expr.decl_t
|
||||
method qualifier ppf : Expr.qualifier -> _ = function
|
||||
| `Local -> ()
|
||||
| `Extern -> Format.fprintf ppf "extern@ "
|
||||
| `Public -> Format.fprintf ppf "public@ "
|
||||
| `PublicExtern -> Format.fprintf ppf "not implemented %d" __LINE__
|
||||
|
||||
method args ppf =
|
||||
Format.fprintf ppf "%a" @@
|
||||
Format.pp_print_list ~pp_sep:(fun ppf () -> Format.fprintf ppf ",")
|
||||
(Format.pp_print_text)
|
||||
|
||||
method c_DECL (name,ppf) (qual, (item: [`Fun of string list * Expr.t | `Variable of Expr.t GT.option])) =
|
||||
match item with
|
||||
| `Variable(None) -> Format.fprintf ppf "local %s;" name
|
||||
| `Variable(Some e) ->
|
||||
Format.fprintf ppf "local %s = %a;" name on_expr e
|
||||
| `Fun (ss,e) ->
|
||||
Format.fprintf ppf "@[<v>";
|
||||
Format.fprintf ppf "@[%afun %s (%a) @]@," self#qualifier qual name self#args ss;
|
||||
Format.fprintf ppf "@[<v 2>{@,@[%a@]@]@ " on_expr e;
|
||||
Format.fprintf ppf "}";
|
||||
Format.fprintf ppf "@]"
|
||||
|
||||
end
|
||||
|
||||
|
||||
let fix_decl decl0 t0 =
|
||||
let rec traitdecl inh subj =
|
||||
Expr.gcata_decl (decl0 traitdecl traitt) inh subj
|
||||
and traitt inh subj =
|
||||
Expr.gcata_t (t0 traitdecl traitt) inh subj
|
||||
in
|
||||
(traitdecl, traitt)
|
||||
|
||||
let pp fmt s =
|
||||
snd (fix_decl (new pp_decl) (new pp_expr)) fmt s
|
||||
|
||||
let pp ppf ast =
|
||||
let margin =
|
||||
try int_of_string @@ Sys.getenv "LAMA_MARGIN"
|
||||
with Failure _ | Not_found -> 35
|
||||
in
|
||||
Format.set_margin margin;
|
||||
Format.set_max_indent 15;
|
||||
Format.printf "%a\n%!" pp ast
|
||||
Loading…
Add table
Add a link
Reference in a new issue