mirror of
https://github.com/ProgramSnail/Lama.git
synced 2025-12-05 22:38:44 +00:00
move to dune; fix warnings
This commit is contained in:
Danya Berezun
parent
41fb7b15f9
commit
9170b9c860
8 changed files with 2655 additions and 1830 deletions
3
dune-project
Normal file
3
dune-project
Normal file
|
|
@ -0,0 +1,3 @@
|
|||
(lang dune 3.3)
|
||||
|
||||
(cram enable)
|
||||
1
src/.ocamlformat
Normal file
1
src/.ocamlformat
Normal file
|
|
@ -0,0 +1 @@
|
|||
profile=default
|
||||
183
src/Driver.ml
183
src/Driver.ml
|
|
@ -7,22 +7,22 @@ class options args =
|
|||
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" ^
|
||||
"When no options specified, builds the source file into executable.\n" ^
|
||||
"Options:\n" ^
|
||||
" -c --- compile into object file\n" ^
|
||||
" -o <file> --- write executable into file <file>\n" ^
|
||||
" -I <path> --- add <path> into unit search path list\n" ^
|
||||
" -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" ^
|
||||
" -b --- compile to a stack machine bytecode\n" ^
|
||||
" -v --- show version\n" ^
|
||||
" -h --- show this help\n"
|
||||
"Lama compiler. (C) JetBrains Reserach, 2017-2020.\n"
|
||||
^ "Usage: lamac <options> <input file>\n\n"
|
||||
^ "When no options specified, builds the source file into executable.\n"
|
||||
^ "Options:\n" ^ " -c --- compile into object file\n"
|
||||
^ " -o <file> --- write executable into file <file>\n"
|
||||
^ " -I <path> --- add <path> into unit search path list\n"
|
||||
^ " -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"
|
||||
^ " -b --- compile to a stack machine bytecode\n"
|
||||
^ " -v --- show version\n" ^ " -h --- show this help\n"
|
||||
in
|
||||
object (self)
|
||||
val version = ref false
|
||||
|
|
@ -30,14 +30,17 @@ class options args =
|
|||
val i = ref 1
|
||||
val infile = ref (None : string option)
|
||||
val outfile = ref (None : string option)
|
||||
val paths = ref [X86.get_std_path ()]
|
||||
val mode = ref (`Default : [`Default | `Eval | `SM | `Compile | `BC])
|
||||
val paths = ref [ X86.get_std_path () ]
|
||||
val mode = ref (`Default : [ `Default | `Eval | `SM | `Compile | `BC ])
|
||||
val curdir = Unix.getcwd ()
|
||||
val debug = ref false
|
||||
|
||||
(* Workaround until Ostap starts to memoize properly *)
|
||||
val const = ref false
|
||||
|
||||
(* end of the workaround *)
|
||||
val dump = ref 0
|
||||
|
||||
initializer
|
||||
let rec loop () =
|
||||
match self#peek with
|
||||
|
|
@ -47,8 +50,17 @@ class options args =
|
|||
| "-w" -> self#set_workaround
|
||||
(* end of the workaround *)
|
||||
| "-c" -> self#set_mode `Compile
|
||||
| "-o" -> (match self#peek with None -> raise (Commandline_error "File name expected after '-o' specifier") | Some fname -> self#set_outfile fname)
|
||||
| "-I" -> (match self#peek with None -> raise (Commandline_error "Path expected after '-I' specifier") | Some path -> self#add_include_path path)
|
||||
| "-o" -> (
|
||||
match self#peek with
|
||||
| None ->
|
||||
raise
|
||||
(Commandline_error "File name expected after '-o' specifier")
|
||||
| Some fname -> self#set_outfile fname)
|
||||
| "-I" -> (
|
||||
match self#peek with
|
||||
| None ->
|
||||
raise (Commandline_error "Path expected after '-I' specifier")
|
||||
| Some path -> self#add_include_path path)
|
||||
| "-s" -> self#set_mode `SM
|
||||
| "-b" -> self#set_mode `BC
|
||||
| "-i" -> self#set_mode `Eval
|
||||
|
|
@ -59,127 +71,154 @@ class options args =
|
|||
| "-v" -> self#set_version
|
||||
| "-g" -> self#set_debug
|
||||
| _ ->
|
||||
if opt.[0] = '-'
|
||||
then raise (Commandline_error (Printf.sprintf "Invalid command line specifier ('%s')" opt))
|
||||
else self#set_infile opt
|
||||
);
|
||||
if opt.[0] = '-' then
|
||||
raise
|
||||
(Commandline_error
|
||||
(Printf.sprintf "Invalid command line specifier ('%s')" opt))
|
||||
else self#set_infile opt);
|
||||
loop ()
|
||||
| None -> ()
|
||||
in loop ()
|
||||
in
|
||||
loop ()
|
||||
|
||||
(* Workaround until Ostap starts to memoize properly *)
|
||||
method is_workaround = !const
|
||||
method private set_workaround =
|
||||
const := true
|
||||
method private set_workaround = const := true
|
||||
|
||||
(* end of the workaround *)
|
||||
method private set_help = help := true
|
||||
method private set_version = version := true
|
||||
method private set_dump mask =
|
||||
dump := !dump lor mask
|
||||
method private set_dump mask = dump := !dump lor mask
|
||||
|
||||
method private set_infile name =
|
||||
match !infile with
|
||||
| None -> infile := Some name
|
||||
| Some name' -> raise (Commandline_error (Printf.sprintf "Input file ('%s') already specified" name'))
|
||||
| Some name' ->
|
||||
raise
|
||||
(Commandline_error
|
||||
(Printf.sprintf "Input file ('%s') already specified" name'))
|
||||
|
||||
method private set_outfile name =
|
||||
match !outfile with
|
||||
| None -> outfile := Some name
|
||||
| Some name' -> raise (Commandline_error (Printf.sprintf "Output file ('%s') already specified" name'))
|
||||
method private add_include_path path =
|
||||
paths := path :: !paths
|
||||
| Some name' ->
|
||||
raise
|
||||
(Commandline_error
|
||||
(Printf.sprintf "Output file ('%s') already specified" name'))
|
||||
|
||||
method private add_include_path path = paths := path :: !paths
|
||||
|
||||
method private set_mode s =
|
||||
match !mode with
|
||||
| `Default -> mode := s
|
||||
| _ -> raise (Commandline_error "Extra compilation mode specifier")
|
||||
|
||||
method private peek =
|
||||
let j = !i in
|
||||
if j < n
|
||||
then (incr i; Some (args.(j)))
|
||||
if j < n then (
|
||||
incr i;
|
||||
Some args.(j))
|
||||
else None
|
||||
|
||||
method get_mode = !mode
|
||||
|
||||
method get_output_option =
|
||||
match !outfile with
|
||||
| None -> Printf.sprintf "-o %s" self#basename
|
||||
| Some name -> Printf.sprintf "-o %s" name
|
||||
|
||||
method get_absolute_infile =
|
||||
let f = self#get_infile in
|
||||
if Filename.is_relative f then Filename.concat curdir f else f
|
||||
|
||||
method get_infile =
|
||||
match !infile with
|
||||
| None -> raise (Commandline_error "Input file not specified")
|
||||
| Some name -> name
|
||||
|
||||
method get_help = !help
|
||||
method get_include_paths = !paths
|
||||
method basename = Filename.chop_suffix (Filename.basename self#get_infile) ".lama"
|
||||
|
||||
method basename =
|
||||
Filename.chop_suffix (Filename.basename self#get_infile) ".lama"
|
||||
|
||||
method topname =
|
||||
match !mode with
|
||||
| `Compile -> "init" ^ self#basename
|
||||
| _ -> "main"
|
||||
match !mode with `Compile -> "init" ^ self#basename | _ -> "main"
|
||||
|
||||
method dump_file ext contents =
|
||||
let name = self#basename in
|
||||
let outf = open_out (Printf.sprintf "%s.%s" name ext) in
|
||||
Printf.fprintf outf "%s" contents;
|
||||
close_out outf
|
||||
|
||||
method dump_AST ast =
|
||||
if (!dump land dump_ast) > 0
|
||||
then (
|
||||
if !dump land dump_ast > 0 then (
|
||||
let buf = Buffer.create 1024 in
|
||||
Buffer.add_string buf "<html>";
|
||||
Buffer.add_string buf (Printf.sprintf "<title> %s </title>" self#get_infile);
|
||||
Buffer.add_string buf
|
||||
(Printf.sprintf "<title> %s </title>" self#get_infile);
|
||||
Buffer.add_string buf "<body><li>";
|
||||
GT.html(Language.Expr.t) ast buf;
|
||||
GT.html Language.Expr.t ast buf;
|
||||
Buffer.add_string buf "</li></body>";
|
||||
Buffer.add_string buf "</html>";
|
||||
self#dump_file "html" (Buffer.contents buf)
|
||||
)
|
||||
method dump_source (ast: Language.Expr.t) =
|
||||
if (!dump land dump_source) > 0
|
||||
then Pprinter.pp Format.std_formatter ast;
|
||||
self#dump_file "html" (Buffer.contents buf))
|
||||
|
||||
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)
|
||||
if !dump land dump_sm > 0 then self#dump_file "sm" (SM.show_prg sm)
|
||||
else ()
|
||||
|
||||
method greet =
|
||||
(match !outfile with
|
||||
| None -> ()
|
||||
| Some _ -> (match !mode with `Default -> () | _ -> Printf.printf "Output file option ignored in this mode.\n")
|
||||
);
|
||||
| Some _ -> (
|
||||
match !mode with
|
||||
| `Default -> ()
|
||||
| _ -> Printf.printf "Output file option ignored in this mode.\n"));
|
||||
if !version then Printf.printf "%s\n" Version.version;
|
||||
if !help then Printf.printf "%s" help_string
|
||||
method get_debug =
|
||||
if !debug then "" else "-g"
|
||||
method set_debug =
|
||||
debug := true
|
||||
|
||||
method get_debug = if !debug then "" else "-g"
|
||||
method set_debug = debug := true
|
||||
end
|
||||
|
||||
let main =
|
||||
let[@ocaml.warning "-32"] main =
|
||||
try
|
||||
let cmd = new options Sys.argv in
|
||||
cmd#greet;
|
||||
match (try Language.run_parser cmd with Language.Semantic_error msg -> `Fail msg) with
|
||||
| `Ok prog ->
|
||||
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
|
||||
| `BC ->
|
||||
SM.ByteCode.compile cmd (SM.compile cmd prog)
|
||||
match cmd#get_mode with
|
||||
| `Default | `Compile -> ignore @@ X86.build cmd prog
|
||||
| `BC -> SM.ByteCode.compile cmd (SM.compile cmd prog)
|
||||
| _ ->
|
||||
let rec read acc =
|
||||
try
|
||||
let r = read_int () in
|
||||
Printf.printf "> ";
|
||||
read (acc @ [r])
|
||||
read (acc @ [ r ])
|
||||
with End_of_file -> acc
|
||||
in
|
||||
let input = read [] in
|
||||
let output =
|
||||
if cmd#get_mode = `Eval
|
||||
then Language.eval prog input
|
||||
if cmd#get_mode = `Eval then Language.eval prog input
|
||||
else SM.run (SM.compile cmd prog) input
|
||||
in
|
||||
List.iter (fun i -> Printf.printf "%d\n" i) output
|
||||
)
|
||||
| `Fail er -> Printf.eprintf "Error: %s\n" er; exit 255
|
||||
List.iter (fun i -> Printf.printf "%d\n" i) output)
|
||||
| `Fail er ->
|
||||
Printf.eprintf "Error: %s\n" er;
|
||||
exit 255
|
||||
with
|
||||
| Language.Semantic_error msg -> Printf.printf "Error: %s\n" msg; exit 255
|
||||
| Commandline_error msg -> Printf.printf "%s\n" msg; exit 255
|
||||
| Language.Semantic_error msg ->
|
||||
Printf.printf "Error: %s\n" msg;
|
||||
exit 255
|
||||
| Commandline_error msg ->
|
||||
Printf.printf "%s\n" msg;
|
||||
exit 255
|
||||
|
|
|
|||
|
|
@ -3,6 +3,8 @@
|
|||
*)
|
||||
module OrigList = List
|
||||
|
||||
[@@@ocaml.warning "-7-8-13-15-20-26-27-32"]
|
||||
|
||||
open GT
|
||||
|
||||
(* Opening a library for combinator-based syntax analysis *)
|
||||
|
|
@ -114,6 +116,7 @@ module Value =
|
|||
match x with
|
||||
| Sexp (_, a) | Array a -> ignore (update_array a i v)
|
||||
| String a -> ignore (update_string a i (Char.chr @@ to_int v))
|
||||
| _ -> failwith (Printf.sprintf "Unexpected pattern: %s: %d" __FILE__ __LINE__)
|
||||
|
||||
let string_val v =
|
||||
let buf = Buffer.create 128 in
|
||||
|
|
@ -121,8 +124,7 @@ module Value =
|
|||
let rec inner = function
|
||||
| Int n -> append (string_of_int n)
|
||||
| String s -> append "\""; append @@ Bytes.to_string s; append "\""
|
||||
| Array a -> let n = Array.length a in
|
||||
append "["; Array.iteri (fun i a -> (if i > 0 then append ", "); inner a) a; append "]"
|
||||
| Array a -> append "["; Array.iteri (fun i a -> (if i > 0 then append ", "); inner a) a; append "]"
|
||||
| Sexp (t, a) -> let n = Array.length a in
|
||||
if t = "cons"
|
||||
then (
|
||||
|
|
@ -131,6 +133,7 @@ module Value =
|
|||
| [||] -> ()
|
||||
| [|x; Int 0|] -> inner x
|
||||
| [|x; Sexp ("cons", a)|] -> inner x; append ", "; inner_list a
|
||||
| _ -> failwith (Printf.sprintf "Unexpected pattern: %s: %d" __FILE__ __LINE__)
|
||||
in inner_list a;
|
||||
append "}"
|
||||
)
|
||||
|
|
@ -139,6 +142,7 @@ module Value =
|
|||
(if n > 0 then (append " ("; Array.iteri (fun i a -> (if i > 0 then append ", "); inner a) a;
|
||||
append ")"))
|
||||
)
|
||||
| _ -> failwith (Printf.sprintf "Unexpected pattern: %s: %d" __FILE__ __LINE__)
|
||||
in
|
||||
inner v;
|
||||
Bytes.of_string @@ Buffer.contents buf
|
||||
|
|
@ -156,18 +160,21 @@ module Builtin =
|
|||
let eval (st, i, o, vs) args = function
|
||||
| "read" -> (match i with z::i' -> (st, i', o, (Value.of_int z)::vs) | _ -> failwith "Unexpected end of input")
|
||||
| "write" -> (st, i, o @ [Value.to_int @@ List.hd args], Value.Empty :: vs)
|
||||
| ".elem" -> let [b; j] = args in
|
||||
(st, i, o, let i = Value.to_int j in
|
||||
| ".elem" -> (match args with
|
||||
| [b; j] -> (st, i, o, let i = Value.to_int j in
|
||||
(match b with
|
||||
| Value.String s -> Value.of_int @@ Char.code (Bytes.get s i)
|
||||
| Value.Array a -> a.(i)
|
||||
| Value.Sexp (_, a) -> a.(i)
|
||||
| _ -> failwith (Printf.sprintf "Unexpected pattern: %s: %d" __FILE__ __LINE__)
|
||||
) :: vs
|
||||
)
|
||||
| "length" -> (st, i, o, (Value.of_int (match List.hd args with Value.Sexp (_, a) | Value.Array a -> Array.length a | Value.String s -> Bytes.length s))::vs)
|
||||
| _ -> failwith (Printf.sprintf "Unexpected pattern: %s: %d" __FILE__ __LINE__)
|
||||
)
|
||||
| "length" -> (st, i, o, (Value.of_int (match List.hd args with Value.Sexp (_, a) | Value.Array a -> Array.length a | Value.String s -> Bytes.length s | _ -> failwith (Printf.sprintf "Unexpected pattern: %s: %d" __FILE__ __LINE__)))::vs)
|
||||
| ".array" -> (st, i, o, (Value.of_array @@ Array.of_list args)::vs)
|
||||
| "string" -> let [a] = args in (st, i, o, (Value.of_string @@ Value.string_val a)::vs)
|
||||
|
||||
| "string" -> (match args with | [a] -> (st, i, o, (Value.of_string @@ Value.string_val a)::vs) | _ -> failwith (Printf.sprintf "Unexpected pattern: %s: %d" __FILE__ __LINE__))
|
||||
| _ -> failwith (Printf.sprintf "Unexpected pattern: %s: %d" __FILE__ __LINE__)
|
||||
end
|
||||
|
||||
(* States *)
|
||||
|
|
@ -273,7 +280,7 @@ module State =
|
|||
| _ -> L (xs, s, st)
|
||||
|
||||
(* Drop a local scope *)
|
||||
let drop = function L (_, _, e) -> e | G _ -> I
|
||||
let drop = function L (_, _, e) -> e | G _ -> I | _ -> failwith (Printf.sprintf "Unexpected pattern: %s: %d" __FILE__ __LINE__)
|
||||
|
||||
(* Observe a variable in a state and print it to stderr *)
|
||||
let observe st x =
|
||||
|
|
@ -440,19 +447,18 @@ module Expr =
|
|||
|
||||
let seq x = function Skip -> x | y -> Seq (x, y)
|
||||
|
||||
let schedule_list h::tl =
|
||||
List.fold_left seq h tl
|
||||
let schedule_list = function h::tl -> List.fold_left seq h tl | _ -> failwith (Printf.sprintf "Unexpected pattern: %s: %d" __FILE__ __LINE__)
|
||||
|
||||
let rec take = function
|
||||
| 0 -> fun rest -> [], rest
|
||||
| n -> fun h::tl -> let tl', rest = take (n-1) tl in h :: tl', rest
|
||||
| n -> function h::tl -> let tl', rest = take (n-1) tl in h :: tl', rest | _ -> failwith (Printf.sprintf "Unexpected pattern: %s: %d" __FILE__ __LINE__)
|
||||
|
||||
let rec eval ((st, i, o, vs) as conf) k expr =
|
||||
let print_values vs =
|
||||
(* let print_values vs =
|
||||
Printf.eprintf "Values:\n%!";
|
||||
List.iter (fun v -> Printf.eprintf "%s\n%!" @@ show(Value.t) (fun _ -> "<expr>") (fun _ -> "<state>") v) vs;
|
||||
Printf.eprintf "End Values\n%!"
|
||||
in
|
||||
in *)
|
||||
match expr with
|
||||
| Lambda (args, body) ->
|
||||
eval (st, i, o, Value.Closure (args, body, [|st|]) :: vs) Skip k
|
||||
|
|
@ -500,15 +506,16 @@ module Expr =
|
|||
| Sexp (t, xs) ->
|
||||
eval conf k (schedule_list (xs @ [Intrinsic (fun (st, i, o, vs) -> let es, vs' = take (List.length xs) vs in (st, i, o, Value.Sexp (t, Array.of_list (List.rev es)) :: vs'))]))
|
||||
| Binop (op, x, y) ->
|
||||
eval conf k (schedule_list [x; y; Intrinsic (fun (st, i, o, y::x::vs) -> (st, i, o, (Value.of_int @@ to_func op (Value.to_int x) (Value.to_int y)) :: vs))])
|
||||
eval conf k (schedule_list [x; y; Intrinsic (function (st, i, o, y::x::vs) -> (st, i, o, (Value.of_int @@ to_func op (Value.to_int x) (Value.to_int y)) :: vs) | _ -> failwith (Printf.sprintf "Unexpected pattern: %s: %d" __FILE__ __LINE__))])
|
||||
| Elem (b, i) ->
|
||||
eval conf k (schedule_list [b; i; Intrinsic (fun (st, i, o, j::b::vs) -> Builtin.eval (st, i, o, vs) [b; j] ".elem")])
|
||||
eval conf k (schedule_list [b; i; Intrinsic (function (st, i, o, j::b::vs) -> Builtin.eval (st, i, o, vs) [b; j] ".elem" | _ -> failwith (Printf.sprintf "Unexpected pattern: %s: %d" __FILE__ __LINE__))])
|
||||
| ElemRef (b, i) ->
|
||||
eval conf k (schedule_list [b; i; Intrinsic (fun (st, i, o, j::b::vs) -> (st, i, o, (Value.Elem (b, Value.to_int j))::vs))])
|
||||
eval conf k (schedule_list [b; i; Intrinsic (function (st, i, o, j::b::vs) -> (st, i, o, (Value.Elem (b, Value.to_int j))::vs) | _ -> failwith (Printf.sprintf "Unexpected pattern: %s: %d" __FILE__ __LINE__))])
|
||||
| Call (f, args) ->
|
||||
eval conf k (schedule_list (f :: args @ [Intrinsic (fun (st, i, o, vs) ->
|
||||
let es, vs' = take (List.length args + 1) vs in
|
||||
let f :: es = List.rev es in
|
||||
match List.rev es with
|
||||
| f :: es ->
|
||||
(match f with
|
||||
| Value.Builtin name ->
|
||||
Builtin.eval (st, i, o, vs') es name
|
||||
|
|
@ -518,23 +525,27 @@ module Expr =
|
|||
closure.(0) <- st'';
|
||||
(State.leave st'' st, i', o', match vs'' with [v] -> v::vs' | _ -> Value.Empty :: vs')
|
||||
| _ -> report_error (Printf.sprintf "callee did not evaluate to a function: \"%s\"" (show(Value.t) (fun _ -> "<expr>") (fun _ -> "<state>") f))
|
||||
))]))
|
||||
)
|
||||
| _ -> failwith (Printf.sprintf "Unexpected pattern: %s: %d" __FILE__ __LINE__)
|
||||
)]))
|
||||
|
||||
| Leave -> eval (State.drop st, i, o, vs) Skip k
|
||||
| Assign (x, e) ->
|
||||
eval conf k (schedule_list [x; e; Intrinsic (fun (st, i, o, v::x::vs) -> (update st x v, i, o, v::vs))])
|
||||
eval conf k (schedule_list [x; e; Intrinsic (function (st, i, o, v::x::vs) -> (update st x v, i, o, v::vs) | _ -> failwith (Printf.sprintf "Unexpected pattern: %s: %d" __FILE__ __LINE__))])
|
||||
| Seq (s1, s2) ->
|
||||
eval conf (seq s2 k) s1
|
||||
| Skip ->
|
||||
(match k with Skip -> conf | _ -> eval conf Skip k)
|
||||
| If (e, s1, s2) ->
|
||||
eval conf k (schedule_list [e; Control (fun (st, i, o, e::vs) -> (if Value.to_int e <> 0 then s1 else s2), (st, i, o, vs))])
|
||||
eval conf k (schedule_list [e; Control (function (st, i, o, e::vs) -> (if Value.to_int e <> 0 then s1 else s2), (st, i, o, vs) | _ -> failwith (Printf.sprintf "Unexpected pattern: %s: %d" __FILE__ __LINE__))])
|
||||
| While (e, s) ->
|
||||
eval conf k (schedule_list [e; Control (fun (st, i, o, e::vs) -> (if Value.to_int e <> 0 then seq s expr else Skip), (st, i, o, vs))])
|
||||
eval conf k (schedule_list [e; Control (function (st, i, o, e::vs) -> (if Value.to_int e <> 0 then seq s expr else Skip), (st, i, o, vs) | _ -> failwith (Printf.sprintf "Unexpected pattern: %s: %d" __FILE__ __LINE__))])
|
||||
| DoWhile (s, e) ->
|
||||
eval conf (seq (While (e, s)) k) s
|
||||
| Case (e, bs, _, _)->
|
||||
let rec branch ((st, i, o, v::vs) as conf) = function
|
||||
let rec branch =
|
||||
function (_,_,_,[]) -> failwith (Printf.sprintf "Unexpected pattern: %s: %d" __FILE__ __LINE__)
|
||||
| ((st, i, o, v::vs) as conf) -> function
|
||||
| [] -> failwith (Printf.sprintf "Pattern matching failed: no branch is selected while matching %s\n" (show(Value.t) (fun _ -> "<expr>") (fun _ -> "<state>") v))
|
||||
| (patt, body)::tl ->
|
||||
let rec match_patt patt v st =
|
||||
|
|
@ -635,14 +646,14 @@ module Expr =
|
|||
let not_a_reference s = new Reason.t (Msg.make "not a reference" [||] (Msg.Locator.Point s#coord))
|
||||
|
||||
(* UGLY! *)
|
||||
let predefined_op : (Obj.t -> Obj.t -> Obj.t) ref = Pervasives.ref (fun _ _ -> invalid_arg "must not happen")
|
||||
let predefined_op : (Obj.t -> Obj.t -> Obj.t) ref = Stdlib.ref (fun _ _ -> invalid_arg "must not happen")
|
||||
|
||||
let defCell = Pervasives.ref 0
|
||||
let defCell = Stdlib.ref 0
|
||||
|
||||
(* ======= *)
|
||||
let makeParsers env =
|
||||
let makeParser, makeBasicParser, makeScopeParser =
|
||||
let def s = let Some def = Obj.magic !defCell in def s in
|
||||
let [@ocaml.warning "-26"] makeParser, makeBasicParser, makeScopeParser =
|
||||
let [@ocaml.warning "-20"] def s = let [@ocaml.warning "-8"] Some def = Obj.magic !defCell in def s in
|
||||
let ostap (
|
||||
parse[infix][atr]: h:basic[infix][Void] -";" t:parse[infix][atr] {Seq (h, t)} | basic[infix][atr];
|
||||
scope[infix][atr]: <(d, infix')> : def[infix] expr:parse[infix'][atr] {Scope (d, expr)} | {isVoid atr} => <(d, infix')> : def[infix] => {d <> []} => {Scope (d, materialize atr Skip)};
|
||||
|
|
@ -872,7 +883,7 @@ module Infix =
|
|||
show(showable) @@ Array.map (fun (ass, (_, l)) -> List.map (fun (str, kind, _) -> ass, str, kind) l) infix
|
||||
|
||||
let extract_exports infix =
|
||||
let ass_string = function `Lefta -> "L" | `Righta -> "R" | _ -> "I" in
|
||||
(* let ass_string = function `Lefta -> "L" | `Righta -> "R" | _ -> "I" in *)
|
||||
let exported =
|
||||
Array.map
|
||||
(fun (ass, (_, ops)) ->
|
||||
|
|
@ -1013,7 +1024,7 @@ module Definition =
|
|||
(* end of the workaround *)
|
||||
)
|
||||
|
||||
let makeParser env exprBasic exprScope =
|
||||
let [@ocaml.warning "-26"] makeParser env exprBasic exprScope =
|
||||
let ostap (
|
||||
arg : l:$ x:LIDENT {Loc.attach x l#coord; x};
|
||||
position[pub][ass][coord][newp]:
|
||||
|
|
@ -1107,7 +1118,7 @@ module Interface =
|
|||
Buffer.contents buf
|
||||
|
||||
(* Read an interface file *)
|
||||
let read fname =
|
||||
let [@ocaml.warning "-26"] read fname =
|
||||
let ostap (
|
||||
funspec: "F" "," i:IDENT ";" {`Fun i};
|
||||
varspec: "V" "," i:IDENT ";" {`Variable i};
|
||||
|
|
@ -1201,8 +1212,8 @@ ostap (
|
|||
let parse cmd =
|
||||
let env =
|
||||
object
|
||||
val imports = Pervasives.ref ([] : string list)
|
||||
val tmp_index = Pervasives.ref 0
|
||||
val imports = Stdlib.ref ([] : string list)
|
||||
val tmp_index = Stdlib.ref 0
|
||||
|
||||
method add_import imp = imports := imp :: !imports
|
||||
method get_tmp = let index = !tmp_index in incr tmp_index; Printf.sprintf "__tmp%d" index
|
||||
|
|
@ -1223,7 +1234,7 @@ let parse cmd =
|
|||
definitions
|
||||
in
|
||||
|
||||
let definitions = Pervasives.ref None in
|
||||
let definitions = Stdlib.ref None in
|
||||
|
||||
let (makeParser, makeBasicParser, makeScopeParser) = Expr.makeParsers env in
|
||||
|
||||
|
|
@ -1233,7 +1244,7 @@ let parse cmd =
|
|||
|
||||
definitions := Some (makeDefinitions env exprBasic exprScope);
|
||||
|
||||
let Some definitions = !definitions in
|
||||
let [@ocaml.warning "-8-20"] Some definitions = !definitions in
|
||||
|
||||
let ostap (
|
||||
parse[cmd]:
|
||||
|
|
|
|||
|
|
@ -8,7 +8,9 @@ PXFLAGS = $(CAMLP5)
|
|||
BFLAGS = -rectypes -g -w -13-58 -package GT,ostap,unix
|
||||
OFLAGS = $(BFLAGS)
|
||||
|
||||
all: depend metagen $(TOPFILE)
|
||||
all: # depend metagen # $(TOPFILE)
|
||||
dune build ./Driver.exe
|
||||
ln -sf ../_build/default/src/Driver.exe lamac
|
||||
|
||||
metagen:
|
||||
echo "let version = \"Version `git rev-parse --abbrev-ref HEAD`, `git rev-parse --short HEAD`, `git rev-parse --verify HEAD |git show --no-patch --no-notes --pretty='%cd'`\"" > version.ml
|
||||
|
|
@ -25,6 +27,7 @@ $(TOPFILE).byte: $(SOURCES:.ml=.cmo)
|
|||
|
||||
clean:
|
||||
$(RM) $(TOPFILE) *.cm[ioxa] *.annot *.o *.opt *.byte *~ .depend
|
||||
dune clean
|
||||
|
||||
-include .depend
|
||||
# generic rules
|
||||
|
|
|
|||
863
src/X86.ml
863
src/X86.ml
File diff suppressed because it is too large
Load diff
111
src/dune
Normal file
111
src/dune
Normal file
|
|
@ -0,0 +1,111 @@
|
|||
(env
|
||||
(dev
|
||||
(flags
|
||||
(:standard -warn-error -3-7-8-13-15-20-26-27-32-33-39))))
|
||||
|
||||
(rule
|
||||
(targets version.ml)
|
||||
(action
|
||||
(progn
|
||||
(with-stdout-to
|
||||
version2.ml
|
||||
(progn
|
||||
(run echo let version = "\"")
|
||||
(run echo Version)
|
||||
(run git rev-parse --abbrev-ref HEAD)
|
||||
(run echo , " ")
|
||||
(run git rev-parse --short HEAD)
|
||||
(run echo , " ")
|
||||
(pipe-stdout
|
||||
(run git rev-parse --verify HEAD)
|
||||
(run git show --no-patch --no-notes --pretty='%cd'))
|
||||
(run echo "\"")))
|
||||
(with-stdout-to
|
||||
version.ml
|
||||
(pipe-stdout
|
||||
(run cat version2.ml)
|
||||
(run tr -d '\n'))))))
|
||||
|
||||
(rule
|
||||
(targets stdpath.ml)
|
||||
(action
|
||||
(progn
|
||||
(with-stdout-to
|
||||
stdpath2.ml
|
||||
(progn
|
||||
(run echo let path = "\"")
|
||||
(run opam var share)
|
||||
(run echo /Lama)
|
||||
(run echo "\"")))
|
||||
(with-stdout-to
|
||||
stdpath.ml
|
||||
(pipe-stdout
|
||||
(run cat stdpath2.ml)
|
||||
(run tr -d '\n'))))))
|
||||
|
||||
(library
|
||||
(name liba)
|
||||
(modules Language Pprinter stdpath version X86 SM)
|
||||
(libraries GT ostap)
|
||||
(flags
|
||||
(:standard
|
||||
-rectypes
|
||||
;-dsource
|
||||
))
|
||||
; (ocamlopt_flags
|
||||
; (:standard -dsource))
|
||||
(wrapped false)
|
||||
(preprocess
|
||||
(per_module
|
||||
((pps GT.ppx_all)
|
||||
SM
|
||||
X86)
|
||||
((action
|
||||
(run %{project_root}/src/pp5+gt+plugins+ostap+dump.byte %{input-file}))
|
||||
Language
|
||||
Pprinter
|
||||
stdpath
|
||||
version)))
|
||||
(preprocessor_deps
|
||||
(file %{project_root}/src/pp5+gt+plugins+ostap+dump.byte)
|
||||
;(file %{project_root}/src/pp5+gt+plugins+ostap+dump.exe)
|
||||
)
|
||||
;(inline_tests)
|
||||
)
|
||||
|
||||
(executable
|
||||
(name Driver)
|
||||
(flags
|
||||
(:standard
|
||||
-rectypes
|
||||
;-dsource
|
||||
))
|
||||
(modules Driver)
|
||||
(libraries liba unix))
|
||||
|
||||
; (rule
|
||||
; (targets pp5+gt+plugins+ostap+dump.exe)
|
||||
; (deps
|
||||
; (package GT))
|
||||
; (action
|
||||
; (run
|
||||
; mkcamlp5.opt
|
||||
; -package
|
||||
; camlp5,camlp5.pa_o,camlp5.pr_dump,camlp5.extend,camlp5.quotations,ostap.syntax,GT.syntax.all,GT.syntax
|
||||
; -o
|
||||
; %{targets})))
|
||||
|
||||
(rule
|
||||
(targets pp5+gt+plugins+ostap+dump.byte)
|
||||
(deps
|
||||
(package GT))
|
||||
(action
|
||||
(run
|
||||
mkcamlp5
|
||||
-package
|
||||
camlp5,camlp5.pa_o,camlp5.pr_o,ostap.syntax,GT.syntax.all,GT.syntax
|
||||
-o
|
||||
%{targets})))
|
||||
|
||||
(cram
|
||||
(deps ./Driver.exe))
|
||||
Loading…
Add table
Add a link
Reference in a new issue