st/lama_byterun
1
0
Fork 0
mirror of https://github.com/ProgramSnail/Lama.git synced 2025-12-05 22:38:44 +00:00
Code Issues Projects Releases Packages Wiki Activity Actions

move to dune; fix warnings

Browse source
This commit is contained in:
Danya Berezun 2023-09-04 21:43:28 +02:00
parent 41fb7b15f9
commit 9170b9c860
8 changed files with 2655 additions and 1830 deletions
Download patch file Download diff file Expand all files Collapse all files

3
dune-project Normal file
View file

@ -0,0 +1,3 @@
(lang dune 3.3)
(cram enable)

1
src/.ocamlformat Normal file
View file

@ -0,0 +1 @@
profile=default

281
src/Driver.ml
View file

@ -2,184 +2,223 @@ exception Commandline_error of string
class options args = class options args =
let n = Array.length args in let n = Array.length args in
let dump_ast = 0b1 in let dump_ast = 0b1 in
let dump_sm = 0b010 in let dump_sm = 0b010 in
let dump_source = 0b100 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 *) (* 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 = let help_string =
"Lama compiler. (C) JetBrains Reserach, 2017-2020.\n" ^ "Lama compiler. (C) JetBrains Reserach, 2017-2020.\n"
"Usage: lamac <options> <input file>\n\n" ^ ^ "Usage: lamac <options> <input file>\n\n"
"When no options specified, builds the source file into executable.\n" ^ ^ "When no options specified, builds the source file into executable.\n"
"Options:\n" ^ ^ "Options:\n" ^ " -c --- compile into object file\n"
" -c --- compile into object file\n" ^ ^ " -o <file> --- write executable into file <file>\n"
" -o <file> --- write executable into file <file>\n" ^ ^ " -I <path> --- add <path> into unit search path list\n"
" -I <path> --- add <path> into unit search path list\n" ^ ^ " -i --- interpret on a source-level interpreter\n"
" -i --- interpret on a source-level interpreter\n" ^ ^ " -s --- compile into stack machine code and interpret on the \
" -s --- compile into stack machine code and interpret on the stack machine initerpreter\n" ^ stack machine initerpreter\n"
" -dp --- dump AST (the output will be written into .ast file)\n" ^ ^ " -dp --- dump AST (the output will be written into .ast file)\n"
" -dsrc --- dump pretty-printed source code\n" ^ ^ " -dsrc --- dump pretty-printed source code\n"
" -ds --- dump stack machine code (the output will be written into .sm file; has no\n" ^ ^ " -ds --- dump stack machine code (the output will be written \
" effect if -i option is specfied)\n" ^ into .sm file; has no\n"
" -b --- compile to a stack machine bytecode\n" ^ ^ " effect if -i option is specfied)\n"
" -v --- show version\n" ^ ^ " -b --- compile to a stack machine bytecode\n"
" -h --- show this help\n" ^ " -v --- show version\n" ^ " -h --- show this help\n"
in in
object (self) object (self)
val version = ref false val version = ref false
val help = ref false val help = ref false
val i = ref 1 val i = ref 1
val infile = ref (None : string option) val infile = ref (None : string option)
val outfile = ref (None : string option) val outfile = ref (None : string option)
val paths = ref [X86.get_std_path ()] val paths = ref [ X86.get_std_path () ]
val mode = ref (`Default : [`Default | `Eval | `SM | `Compile | `BC]) val mode = ref (`Default : [ `Default | `Eval | `SM | `Compile | `BC ])
val curdir = Unix.getcwd () val curdir = Unix.getcwd ()
val debug = ref false val debug = ref false
(* Workaround until Ostap starts to memoize properly *) (* Workaround until Ostap starts to memoize properly *)
val const = ref false val const = ref false
(* end of the workaround *) (* end of the workaround *)
val dump = ref 0 val dump = ref 0
initializer initializer
let rec loop () = let rec loop () =
match self#peek with match self#peek with
| Some opt -> | Some opt ->
(match opt with (match opt with
(* Workaround until Ostap starts to memoize properly *) (* Workaround until Ostap starts to memoize properly *)
| "-w" -> self#set_workaround | "-w" -> self#set_workaround
(* end of the workaround *) (* end of the workaround *)
| "-c" -> self#set_mode `Compile | "-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) | "-o" -> (
| "-I" -> (match self#peek with None -> raise (Commandline_error "Path expected after '-I' specifier") | Some path -> self#add_include_path path) match self#peek with
| "-s" -> self#set_mode `SM | None ->
| "-b" -> self#set_mode `BC raise
| "-i" -> self#set_mode `Eval (Commandline_error "File name expected after '-o' specifier")
| "-ds" -> self#set_dump dump_sm | Some fname -> self#set_outfile fname)
| "-dsrc" -> self#set_dump dump_source | "-I" -> (
| "-dp" -> self#set_dump dump_ast match self#peek with
| "-h" -> self#set_help | None ->
| "-v" -> self#set_version raise (Commandline_error "Path expected after '-I' specifier")
| "-g" -> self#set_debug | Some path -> self#add_include_path path)
| _ -> | "-s" -> self#set_mode `SM
if opt.[0] = '-' | "-b" -> self#set_mode `BC
then raise (Commandline_error (Printf.sprintf "Invalid command line specifier ('%s')" opt)) | "-i" -> self#set_mode `Eval
else self#set_infile opt | "-ds" -> self#set_dump dump_sm
); | "-dsrc" -> self#set_dump dump_source
loop () | "-dp" -> self#set_dump dump_ast
| None -> () | "-h" -> self#set_help
in loop () | "-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);
loop ()
| None -> ()
in
loop ()
(* Workaround until Ostap starts to memoize properly *) (* Workaround until Ostap starts to memoize properly *)
method is_workaround = !const method is_workaround = !const
method private set_workaround = method private set_workaround = const := true
const := true
(* end of the workaround *) (* end of the workaround *)
method private set_help = help := true method private set_help = help := true
method private set_version = version := true method private set_version = version := true
method private set_dump mask = method private set_dump mask = dump := !dump lor mask
dump := !dump lor mask
method private set_infile name = method private set_infile name =
match !infile with match !infile with
| None -> infile := Some name | 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 = method private set_outfile name =
match !outfile with match !outfile with
| None -> outfile := Some name | None -> outfile := Some name
| Some name' -> raise (Commandline_error (Printf.sprintf "Output file ('%s') already specified" name')) | Some name' ->
method private add_include_path path = raise
paths := path :: !paths (Commandline_error
(Printf.sprintf "Output file ('%s') already specified" name'))
method private add_include_path path = paths := path :: !paths
method private set_mode s = method private set_mode s =
match !mode with match !mode with
| `Default -> mode := s | `Default -> mode := s
| _ -> raise (Commandline_error "Extra compilation mode specifier") | _ -> raise (Commandline_error "Extra compilation mode specifier")
method private peek = method private peek =
let j = !i in let j = !i in
if j < n if j < n then (
then (incr i; Some (args.(j))) incr i;
Some args.(j))
else None else None
method get_mode = !mode method get_mode = !mode
method get_output_option = method get_output_option =
match !outfile with match !outfile with
| None -> Printf.sprintf "-o %s" self#basename | None -> Printf.sprintf "-o %s" self#basename
| Some name -> Printf.sprintf "-o %s" name | Some name -> Printf.sprintf "-o %s" name
method get_absolute_infile = method get_absolute_infile =
let f = self#get_infile in let f = self#get_infile in
if Filename.is_relative f then Filename.concat curdir f else f if Filename.is_relative f then Filename.concat curdir f else f
method get_infile = method get_infile =
match !infile with match !infile with
| None -> raise (Commandline_error "Input file not specified") | None -> raise (Commandline_error "Input file not specified")
| Some name -> name | Some name -> name
method get_help = !help method get_help = !help
method get_include_paths = !paths 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 = method topname =
match !mode with match !mode with `Compile -> "init" ^ self#basename | _ -> "main"
| `Compile -> "init" ^ self#basename
| _ -> "main"
method dump_file ext contents = method dump_file ext contents =
let name = self#basename in let name = self#basename in
let outf = open_out (Printf.sprintf "%s.%s" name ext) in let outf = open_out (Printf.sprintf "%s.%s" name ext) in
Printf.fprintf outf "%s" contents; Printf.fprintf outf "%s" contents;
close_out outf close_out outf
method dump_AST ast = method dump_AST ast =
if (!dump land dump_ast) > 0 if !dump land dump_ast > 0 then (
then (
let buf = Buffer.create 1024 in let buf = Buffer.create 1024 in
Buffer.add_string buf "<html>"; 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>"; 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 "</li></body>";
Buffer.add_string buf "</html>"; Buffer.add_string buf "</html>";
self#dump_file "html" (Buffer.contents buf) self#dump_file "html" (Buffer.contents buf))
)
method dump_source (ast: Language.Expr.t) = method dump_source (ast : Language.Expr.t) =
if (!dump land dump_source) > 0 if !dump land dump_source > 0 then Pprinter.pp Format.std_formatter ast
then Pprinter.pp Format.std_formatter ast;
method dump_SM sm = method dump_SM sm =
if (!dump land dump_sm) > 0 if !dump land dump_sm > 0 then self#dump_file "sm" (SM.show_prg sm)
then self#dump_file "sm" (SM.show_prg sm)
else () else ()
method greet = method greet =
(match !outfile with (match !outfile with
| None -> () | 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 !version then Printf.printf "%s\n" Version.version;
if !help then Printf.printf "%s" help_string if !help then Printf.printf "%s" help_string
method get_debug =
if !debug then "" else "-g" method get_debug = if !debug then "" else "-g"
method set_debug = method set_debug = debug := true
debug := true
end end
let main = let[@ocaml.warning "-32"] main =
try try
let cmd = new options Sys.argv in let cmd = new options Sys.argv in
cmd#greet; cmd#greet;
match (try Language.run_parser cmd with Language.Semantic_error msg -> `Fail msg) with match
| `Ok prog -> try Language.run_parser cmd
cmd#dump_AST (snd prog); with Language.Semantic_error msg -> `Fail msg
cmd#dump_source (snd prog); with
(match cmd#get_mode with | `Ok prog -> (
| `Default | `Compile -> cmd#dump_AST (snd prog);
ignore @@ X86.build cmd prog cmd#dump_source (snd prog);
| `BC -> match cmd#get_mode with
SM.ByteCode.compile cmd (SM.compile cmd prog) | `Default | `Compile -> ignore @@ X86.build cmd prog
| `BC -> SM.ByteCode.compile cmd (SM.compile cmd prog)
| _ -> | _ ->
let rec read acc = let rec read acc =
try try
let r = read_int () in let r = read_int () in
Printf.printf "> "; Printf.printf "> ";
read (acc @ [r]) read (acc @ [ r ])
with End_of_file -> acc with End_of_file -> acc
in in
let input = read [] in let input = read [] in
let output = let output =
if cmd#get_mode = `Eval if cmd#get_mode = `Eval then Language.eval prog input
then Language.eval prog input else SM.run (SM.compile cmd prog) input
else SM.run (SM.compile cmd prog) input in
in List.iter (fun i -> Printf.printf "%d\n" i) output)
List.iter (fun i -> Printf.printf "%d\n" i) output | `Fail er ->
) Printf.eprintf "Error: %s\n" er;
| `Fail er -> Printf.eprintf "Error: %s\n" er; exit 255 exit 255
with with
| Language.Semantic_error msg -> Printf.printf "Error: %s\n" msg; exit 255 | Language.Semantic_error msg ->
| Commandline_error msg -> Printf.printf "%s\n" msg; exit 255 Printf.printf "Error: %s\n" msg;
exit 255
| Commandline_error msg ->
Printf.printf "%s\n" msg;
exit 255

177
src/Language.ml
View file

@ -3,6 +3,8 @@
*) *)
module OrigList = List module OrigList = List
[@@@ocaml.warning "-7-8-13-15-20-26-27-32"]
open GT open GT
(* Opening a library for combinator-based syntax analysis *) (* Opening a library for combinator-based syntax analysis *)
@ -55,7 +57,7 @@ module Loc =
let report_error ?(loc=None) str = let report_error ?(loc=None) str =
raise (Semantic_error (str ^ match loc with None -> "" | Some (l, c) -> Printf.sprintf " at (%d, %d)" l c));; raise (Semantic_error (str ^ match loc with None -> "" | Some (l, c) -> Printf.sprintf " at (%d, %d)" l c));;
@type k = Unmut | Mut | FVal with show, html, foldl @type k = Unmut | Mut | FVal with show, html, foldl
(* Values *) (* Values *)
@ -85,7 +87,7 @@ module Value =
with show, html, foldl with show, html, foldl
let is_int = function Int _ -> true | _ -> false let is_int = function Int _ -> true | _ -> false
let to_int = function let to_int = function
| Int n -> n | Int n -> n
| x -> failwith (Printf.sprintf "int value expected (%s)\n" (show(t) (fun _ -> "<not supported>") (fun _ -> "<not supported>") x)) | x -> failwith (Printf.sprintf "int value expected (%s)\n" (show(t) (fun _ -> "<not supported>") (fun _ -> "<not supported>") x))
@ -114,6 +116,7 @@ module Value =
match x with match x with
| Sexp (_, a) | Array a -> ignore (update_array a i v) | Sexp (_, a) | Array a -> ignore (update_array a i v)
| String a -> ignore (update_string a i (Char.chr @@ to_int 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 string_val v =
let buf = Buffer.create 128 in let buf = Buffer.create 128 in
@ -121,8 +124,7 @@ module Value =
let rec inner = function let rec inner = function
| Int n -> append (string_of_int n) | Int n -> append (string_of_int n)
| String s -> append "\""; append @@ Bytes.to_string s; append "\"" | String s -> append "\""; append @@ Bytes.to_string s; append "\""
| Array a -> let n = Array.length a in | Array a -> append "["; Array.iteri (fun i a -> (if i > 0 then append ", "); inner a) a; append "]"
append "["; Array.iteri (fun i a -> (if i > 0 then append ", "); inner a) a; append "]"
| Sexp (t, a) -> let n = Array.length a in | Sexp (t, a) -> let n = Array.length a in
if t = "cons" if t = "cons"
then ( then (
@ -131,6 +133,7 @@ module Value =
| [||] -> () | [||] -> ()
| [|x; Int 0|] -> inner x | [|x; Int 0|] -> inner x
| [|x; Sexp ("cons", a)|] -> inner x; append ", "; inner_list a | [|x; Sexp ("cons", a)|] -> inner x; append ", "; inner_list a
| _ -> failwith (Printf.sprintf "Unexpected pattern: %s: %d" __FILE__ __LINE__)
in inner_list a; in inner_list a;
append "}" 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; (if n > 0 then (append " ("; Array.iteri (fun i a -> (if i > 0 then append ", "); inner a) a;
append ")")) append ")"))
) )
| _ -> failwith (Printf.sprintf "Unexpected pattern: %s: %d" __FILE__ __LINE__)
in in
inner v; inner v;
Bytes.of_string @@ Buffer.contents buf Bytes.of_string @@ Buffer.contents buf
@ -156,24 +160,27 @@ module Builtin =
let eval (st, i, o, vs) args = function 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") | "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) | "write" -> (st, i, o @ [Value.to_int @@ List.hd args], Value.Empty :: vs)
| ".elem" -> let [b; j] = args in | ".elem" -> (match args with
(st, i, o, let i = Value.to_int j in | [b; j] -> (st, i, o, let i = Value.to_int j in
(match b with (match b with
| Value.String s -> Value.of_int @@ Char.code (Bytes.get s i) | Value.String s -> Value.of_int @@ Char.code (Bytes.get s i)
| Value.Array a -> a.(i) | Value.Array a -> a.(i)
| Value.Sexp (_, a) -> a.(i) | Value.Sexp (_, a) -> a.(i)
) :: vs | _ -> failwith (Printf.sprintf "Unexpected pattern: %s: %d" __FILE__ __LINE__)
) :: 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))::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 | _ -> failwith (Printf.sprintf "Unexpected pattern: %s: %d" __FILE__ __LINE__)))::vs)
| ".array" -> (st, i, o, (Value.of_array @@ Array.of_list args)::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 end
(* States *) (* States *)
module State = module State =
struct struct
(* State: global state, local state, scope variables *) (* State: global state, local state, scope variables *)
@type 'a t = @type 'a t =
| I | I
@ -273,7 +280,7 @@ module State =
| _ -> L (xs, s, st) | _ -> L (xs, s, st)
(* Drop a local scope *) (* 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 *) (* Observe a variable in a state and print it to stderr *)
let observe st x = let observe st x =
@ -440,19 +447,18 @@ module Expr =
let seq x = function Skip -> x | y -> Seq (x, y) let seq x = function Skip -> x | y -> Seq (x, y)
let schedule_list h::tl = let schedule_list = function h::tl -> List.fold_left seq h tl | _ -> failwith (Printf.sprintf "Unexpected pattern: %s: %d" __FILE__ __LINE__)
List.fold_left seq h tl
let rec take = function let rec take = function
| 0 -> fun rest -> [], rest | 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 rec eval ((st, i, o, vs) as conf) k expr =
let print_values vs = (* let print_values vs =
Printf.eprintf "Values:\n%!"; Printf.eprintf "Values:\n%!";
List.iter (fun v -> Printf.eprintf "%s\n%!" @@ show(Value.t) (fun _ -> "<expr>") (fun _ -> "<state>") v) vs; List.iter (fun v -> Printf.eprintf "%s\n%!" @@ show(Value.t) (fun _ -> "<expr>") (fun _ -> "<state>") v) vs;
Printf.eprintf "End Values\n%!" Printf.eprintf "End Values\n%!"
in in *)
match expr with match expr with
| Lambda (args, body) -> | Lambda (args, body) ->
eval (st, i, o, Value.Closure (args, body, [|st|]) :: vs) Skip k eval (st, i, o, Value.Closure (args, body, [|st|]) :: vs) Skip k
@ -500,73 +506,78 @@ module Expr =
| Sexp (t, xs) -> | 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'))])) 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) -> | 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) -> | 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) -> | 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) -> | Call (f, args) ->
eval conf k (schedule_list (f :: args @ [Intrinsic (fun (st, i, o, vs) -> eval conf k (schedule_list (f :: args @ [Intrinsic (fun (st, i, o, vs) ->
let es, vs' = take (List.length args + 1) vs in let es, vs' = take (List.length args + 1) vs in
let f :: es = List.rev es in match List.rev es with
(match f with | f :: es ->
| Value.Builtin name -> (match f with
Builtin.eval (st, i, o, vs') es name | Value.Builtin name ->
| Value.Closure (args, body, closure) -> Builtin.eval (st, i, o, vs') es name
let st' = State.push (State.leave st closure.(0)) (State.from_list @@ List.combine args es) (List.map (fun x -> x, Mut) args) in | Value.Closure (args, body, closure) ->
let st'', i', o', vs'' = eval (st', i, o, []) Skip body in let st' = State.push (State.leave st closure.(0)) (State.from_list @@ List.combine args es) (List.map (fun x -> x, Mut) args) in
closure.(0) <- st''; let st'', i', o', vs'' = eval (st', i, o, []) Skip body in
(State.leave st'' st, i', o', match vs'' with [v] -> v::vs' | _ -> Value.Empty :: vs') closure.(0) <- st'';
| _ -> report_error (Printf.sprintf "callee did not evaluate to a function: \"%s\"" (show(Value.t) (fun _ -> "<expr>") (fun _ -> "<state>") f)) (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 | Leave -> eval (State.drop st, i, o, vs) Skip k
| Assign (x, e) -> | 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) -> | Seq (s1, s2) ->
eval conf (seq s2 k) s1 eval conf (seq s2 k) s1
| Skip -> | Skip ->
(match k with Skip -> conf | _ -> eval conf Skip k) (match k with Skip -> conf | _ -> eval conf Skip k)
| If (e, s1, s2) -> | 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) -> | 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) -> | DoWhile (s, e) ->
eval conf (seq (While (e, s)) k) s eval conf (seq (While (e, s)) k) s
| Case (e, bs, _, _)-> | Case (e, bs, _, _)->
let rec branch ((st, i, o, v::vs) as conf) = function let rec branch =
| [] -> failwith (Printf.sprintf "Pattern matching failed: no branch is selected while matching %s\n" (show(Value.t) (fun _ -> "<expr>") (fun _ -> "<state>") v)) function (_,_,_,[]) -> failwith (Printf.sprintf "Unexpected pattern: %s: %d" __FILE__ __LINE__)
| (patt, body)::tl -> | ((st, i, o, v::vs) as conf) -> function
let rec match_patt patt v st = | [] -> failwith (Printf.sprintf "Pattern matching failed: no branch is selected while matching %s\n" (show(Value.t) (fun _ -> "<expr>") (fun _ -> "<state>") v))
let update x v = function | (patt, body)::tl ->
| None -> None let rec match_patt patt v st =
| Some s -> Some (State.bind x v s) let update x v = function
in | None -> None
match patt, v with | Some s -> Some (State.bind x v s)
| Pattern.Named (x, p), v -> update x v (match_patt p v st ) in
| Pattern.Wildcard , _ -> st match patt, v with
| Pattern.Sexp (t, ps), Value.Sexp (t', vs) when t = t' && List.length ps = Array.length vs -> match_list ps (Array.to_list vs) st | Pattern.Named (x, p), v -> update x v (match_patt p v st )
| Pattern.Array ps , Value.Array vs when List.length ps = Array.length vs -> match_list ps (Array.to_list vs) st | Pattern.Wildcard , _ -> st
| Pattern.Const n , Value.Int n' when n = n' -> st | Pattern.Sexp (t, ps), Value.Sexp (t', vs) when t = t' && List.length ps = Array.length vs -> match_list ps (Array.to_list vs) st
| Pattern.String s , Value.String s' when s = Bytes.to_string s' -> st | Pattern.Array ps , Value.Array vs when List.length ps = Array.length vs -> match_list ps (Array.to_list vs) st
| Pattern.Boxed , Value.String _ | Pattern.Const n , Value.Int n' when n = n' -> st
| Pattern.Boxed , Value.Array _ | Pattern.String s , Value.String s' when s = Bytes.to_string s' -> st
| Pattern.UnBoxed , Value.Int _ | Pattern.Boxed , Value.String _
| Pattern.Boxed , Value.Sexp (_, _) | Pattern.Boxed , Value.Array _
| Pattern.StringTag , Value.String _ | Pattern.UnBoxed , Value.Int _
| Pattern.ArrayTag , Value.Array _ | Pattern.Boxed , Value.Sexp (_, _)
| Pattern.ClosureTag , Value.Closure _ | Pattern.StringTag , Value.String _
| Pattern.SexpTag , Value.Sexp (_, _) -> st | Pattern.ArrayTag , Value.Array _
| _ -> None | Pattern.ClosureTag , Value.Closure _
and match_list ps vs s = | Pattern.SexpTag , Value.Sexp (_, _) -> st
match ps, vs with | _ -> None
| [], [] -> s and match_list ps vs s =
| p::ps, v::vs -> match_list ps vs (match_patt p v s) match ps, vs with
| _ -> None | [], [] -> s
in | p::ps, v::vs -> match_list ps vs (match_patt p v s)
match match_patt patt v (Some State.undefined) with | _ -> None
| None -> branch conf tl in
| Some st' -> eval (State.push st st' (List.map (fun x -> x, Unmut) @@ Pattern.vars patt), i, o, vs) k (Seq (body, Leave)) match match_patt patt v (Some State.undefined) with
| None -> branch conf tl
| Some st' -> eval (State.push st st' (List.map (fun x -> x, Unmut) @@ Pattern.vars patt), i, o, vs) k (Seq (body, Leave))
in in
eval conf Skip (schedule_list [e; Intrinsic (fun conf -> branch conf bs)]) eval conf Skip (schedule_list [e; Intrinsic (fun conf -> branch conf bs)])
@ -635,14 +646,14 @@ module Expr =
let not_a_reference s = new Reason.t (Msg.make "not a reference" [||] (Msg.Locator.Point s#coord)) let not_a_reference s = new Reason.t (Msg.make "not a reference" [||] (Msg.Locator.Point s#coord))
(* UGLY! *) (* 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 makeParsers env =
let makeParser, makeBasicParser, makeScopeParser = let [@ocaml.warning "-26"] makeParser, makeBasicParser, makeScopeParser =
let def s = let Some def = Obj.magic !defCell in def s in let [@ocaml.warning "-20"] def s = let [@ocaml.warning "-8"] Some def = Obj.magic !defCell in def s in
let ostap ( let ostap (
parse[infix][atr]: h:basic[infix][Void] -";" t:parse[infix][atr] {Seq (h, t)} | basic[infix][atr]; 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)}; 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 show(showable) @@ Array.map (fun (ass, (_, l)) -> List.map (fun (str, kind, _) -> ass, str, kind) l) infix
let extract_exports 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 = let exported =
Array.map Array.map
(fun (ass, (_, ops)) -> (fun (ass, (_, ops)) ->
@ -1013,7 +1024,7 @@ module Definition =
(* end of the workaround *) (* end of the workaround *)
) )
let makeParser env exprBasic exprScope = let [@ocaml.warning "-26"] makeParser env exprBasic exprScope =
let ostap ( let ostap (
arg : l:$ x:LIDENT {Loc.attach x l#coord; x}; arg : l:$ x:LIDENT {Loc.attach x l#coord; x};
position[pub][ass][coord][newp]: position[pub][ass][coord][newp]:
@ -1107,7 +1118,7 @@ module Interface =
Buffer.contents buf Buffer.contents buf
(* Read an interface file *) (* Read an interface file *)
let read fname = let [@ocaml.warning "-26"] read fname =
let ostap ( let ostap (
funspec: "F" "," i:IDENT ";" {`Fun i}; funspec: "F" "," i:IDENT ";" {`Fun i};
varspec: "V" "," i:IDENT ";" {`Variable i}; varspec: "V" "," i:IDENT ";" {`Variable i};
@ -1201,8 +1212,8 @@ ostap (
let parse cmd = let parse cmd =
let env = let env =
object object
val imports = Pervasives.ref ([] : string list) val imports = Stdlib.ref ([] : string list)
val tmp_index = Pervasives.ref 0 val tmp_index = Stdlib.ref 0
method add_import imp = imports := imp :: !imports method add_import imp = imports := imp :: !imports
method get_tmp = let index = !tmp_index in incr tmp_index; Printf.sprintf "__tmp%d" index method get_tmp = let index = !tmp_index in incr tmp_index; Printf.sprintf "__tmp%d" index
@ -1223,7 +1234,7 @@ let parse cmd =
definitions definitions
in in
let definitions = Pervasives.ref None in let definitions = Stdlib.ref None in
let (makeParser, makeBasicParser, makeScopeParser) = Expr.makeParsers env in let (makeParser, makeBasicParser, makeScopeParser) = Expr.makeParsers env in
@ -1233,7 +1244,7 @@ let parse cmd =
definitions := Some (makeDefinitions env exprBasic exprScope); definitions := Some (makeDefinitions env exprBasic exprScope);
let Some definitions = !definitions in let [@ocaml.warning "-8-20"] Some definitions = !definitions in
let ostap ( let ostap (
parse[cmd]: parse[cmd]:
@ -1255,7 +1266,7 @@ let run_parser cmd =
"while"; "do"; "od"; "while"; "do"; "od";
"for"; "for";
"fun"; "var"; "public"; "external"; "import"; "fun"; "var"; "public"; "external"; "import";
"case"; "of"; "esac"; "case"; "of"; "esac";
"box"; "val"; "str"; "sexp"; "array"; "box"; "val"; "str"; "sexp"; "array";
"infix"; "infixl"; "infixr"; "at"; "before"; "after"; "infix"; "infixl"; "infixr"; "at"; "before"; "after";
"true"; "false"; "lazy"; "eta"; "syntax"] "true"; "false"; "lazy"; "eta"; "syntax"]

7
src/Makefile
View file

@ -8,7 +8,9 @@ PXFLAGS = $(CAMLP5)
BFLAGS = -rectypes -g -w -13-58 -package GT,ostap,unix BFLAGS = -rectypes -g -w -13-58 -package GT,ostap,unix
OFLAGS = $(BFLAGS) OFLAGS = $(BFLAGS)
all: depend metagen $(TOPFILE) all: # depend metagen # $(TOPFILE)
dune build ./Driver.exe
ln -sf ../_build/default/src/Driver.exe lamac
metagen: 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 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: clean:
$(RM) $(TOPFILE) *.cm[ioxa] *.annot *.o *.opt *.byte *~ .depend $(RM) $(TOPFILE) *.cm[ioxa] *.annot *.o *.opt *.byte *~ .depend
dune clean
-include .depend -include .depend
# generic rules # generic rules
@ -44,4 +47,4 @@ clean:
$(OCAMLOPT) -c $(OFLAGS) $(STATIC) $(PXFLAGS) $< $(OCAMLOPT) -c $(OFLAGS) $(STATIC) $(PXFLAGS) $<
%.cmx: %.ml %.cmx: %.ml
$(OCAMLOPT) -c $(OFLAGS) $(STATIC) $(PXFLAGS) $< $(OCAMLOPT) -c $(OFLAGS) $(STATIC) $(PXFLAGS) $<

2482
src/SM.ml
View file

File diff suppressed because it is too large Load diff

1423
src/X86.ml
View file

File diff suppressed because it is too large Load diff

111
src/dune Normal file
View 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))