mirror of
https://github.com/ProgramSnail/Lama.git
synced 2025-12-26 16:48:46 +00:00
Infix import
This commit is contained in:
Dmitry Boulytchev
parent
cf5d0f1bc7
commit
1d9aeefd16
4 changed files with 117 additions and 40 deletions
|
|
@ -1,7 +1,7 @@
|
|||
open Ostap
|
||||
|
||||
let parse infile =
|
||||
let s = Util.read infile in
|
||||
let parse cmd =
|
||||
let s = Util.read cmd#get_infile in
|
||||
let kws = [
|
||||
"skip";
|
||||
"if"; "then"; "else"; "elif"; "fi";
|
||||
|
|
@ -30,7 +30,7 @@ let parse infile =
|
|||
] s
|
||||
end
|
||||
)
|
||||
(ostap (p:!(Language.parse Language.Infix.default) -EOF))
|
||||
(ostap (p:!(Language.parse cmd) -EOF))
|
||||
|
||||
exception Commandline_error of string
|
||||
|
||||
|
|
@ -89,7 +89,7 @@ class options args =
|
|||
let main =
|
||||
(* try*)
|
||||
let cmd = new options Sys.argv in
|
||||
match (try parse cmd#get_infile with Language.Semantic_error msg -> `Fail msg) with
|
||||
match (try parse cmd with Language.Semantic_error msg -> `Fail msg) with
|
||||
| `Ok prog ->
|
||||
(match cmd#get_mode with
|
||||
| `Default | `Compile ->
|
||||
|
|
|
|||
126
src/Language.ml
126
src/Language.ml
|
|
@ -392,7 +392,7 @@ module Expr =
|
|||
|
||||
let infix_name infix =
|
||||
let b = Buffer.create 64 in
|
||||
Buffer.add_string b "__Infix_";
|
||||
Buffer.add_string b "i__Infix_";
|
||||
Seq.iter (fun c -> Buffer.add_string b (string_of_int @@ Char.code c)) @@ String.to_seq infix;
|
||||
Buffer.contents b
|
||||
|
||||
|
|
@ -632,7 +632,7 @@ module Expr =
|
|||
| basic[def][infix][atr];
|
||||
scope[def][infix][atr][e]: <(d, infix')> : def[infix] expr:e[infix'][atr] {Scope (d, expr)};
|
||||
|
||||
basic[def][infix][atr]: !(expr (fun x -> x) (Array.map (fun (a, (atr, l)) -> a, (atr, List.map (fun (s, f) -> ostap (- $(s)), f) l)) infix) (primary def infix) atr);
|
||||
basic[def][infix][atr]: !(expr (fun x -> x) (Array.map (fun (a, (atr, l)) -> a, (atr, List.map (fun (s, _, f) -> ostap (- $(s)), f) l)) infix) (primary def infix) atr);
|
||||
|
||||
primary[def][infix][atr]:
|
||||
b:base[def][infix][Val] is:( "[" i:parse[def][infix][Val] "]" {`Elem i}
|
||||
|
|
@ -721,14 +721,48 @@ module Expr =
|
|||
(* Infix helpers *)
|
||||
module Infix =
|
||||
struct
|
||||
|
||||
@type kind = Predefined | Public | Local with show
|
||||
@type ass = [`Lefta | `Righta | `Nona] with show
|
||||
@type loc = [`Before of string | `After of string | `At of string] with show
|
||||
@type export = (ass * string * loc) list with show
|
||||
|
||||
type t = ([`Lefta | `Righta | `Nona] * ((Expr.atr -> (Expr.atr * Expr.atr)) * ((string * kind * (Expr.t -> Expr.atr -> Expr.t -> Expr.t)) list))) array
|
||||
|
||||
type t = ([`Lefta | `Righta | `Nona] * ((Expr.atr -> (Expr.atr * Expr.atr)) * ((string * (Expr.t -> Expr.atr -> Expr.t -> Expr.t)) list))) array
|
||||
|
||||
let extract_exports infix =
|
||||
let ass_string = function `Lefta -> "L" | `Righta -> "R" | _ -> "I" in
|
||||
let exported =
|
||||
Array.map
|
||||
(fun (ass, (_, ops)) ->
|
||||
(ass, List.map (fun (s, kind, _) -> s, kind) @@ List.filter (function (_, Public, _) | (_, Predefined, _) -> true | _ -> false) ops)
|
||||
)
|
||||
infix
|
||||
in
|
||||
let _, exports =
|
||||
Array.fold_left
|
||||
(fun (loc, acc) (ass, list) ->
|
||||
let rec inner (loc, acc) = function
|
||||
| [] -> (loc, acc)
|
||||
| (s, kind) :: tl ->
|
||||
let loc' = match tl with [] -> `After s | _ -> `At s in
|
||||
(fun again ->
|
||||
match kind with
|
||||
| Public -> again (loc', (ass, s, loc) :: acc)
|
||||
| _ -> again (loc', acc)
|
||||
)
|
||||
(match tl with [] -> fun acc -> acc | _ -> fun acc -> inner acc tl)
|
||||
in
|
||||
inner (loc, acc) list
|
||||
)
|
||||
(`Before ":=", [])
|
||||
exported
|
||||
in List.rev exports
|
||||
|
||||
let default : t =
|
||||
Array.map (fun (a, s) ->
|
||||
a,
|
||||
((fun _ -> (if (List.hd s) = ":=" then Expr.Reff else Expr.Val), Expr.Val),
|
||||
List.map (fun s -> s, Expr.sem_init s) s)
|
||||
List.map (fun s -> s, Predefined, Expr.sem_init s) s)
|
||||
)
|
||||
[|
|
||||
`Righta, [":="];
|
||||
|
|
@ -744,45 +778,47 @@ module Infix =
|
|||
|
||||
let find_op infix op cb ce =
|
||||
try
|
||||
Array.iteri (fun i (_, (_, l)) -> if List.exists (fun (s, _) -> s = op) l then raise (Break (cb i))) infix;
|
||||
Array.iteri (fun i (_, (_, l)) -> if List.exists (fun (s, _, _) -> s = op) l then raise (Break (cb i))) infix;
|
||||
ce ()
|
||||
with Break x -> x
|
||||
|
||||
let no_op op coord = `Fail (Printf.sprintf "infix ``%s'' not found in the scope at %s" op (Msg.Coord.toString coord))
|
||||
|
||||
let at coord op newp (sem, _) infix =
|
||||
let kind_of = function true -> Public | _ -> Local
|
||||
|
||||
let at coord op newp public (sem, _) (infix : t) =
|
||||
find_op infix op
|
||||
(fun i ->
|
||||
`Ok (Array.init (Array.length infix)
|
||||
(fun j ->
|
||||
if j = i
|
||||
then let (a, (atr, l)) = infix.(i) in (a, (atr, ((newp, sem) :: l)))
|
||||
then let (a, (atr, l)) = infix.(i) in (a, (atr, ((newp, kind_of public, sem) :: l)))
|
||||
else infix.(j)
|
||||
))
|
||||
)
|
||||
(fun _ -> no_op op coord)
|
||||
|
||||
let before coord op newp ass (sem, atr) infix =
|
||||
let before coord op newp ass public (sem, atr) (infix : t) =
|
||||
find_op infix op
|
||||
(fun i ->
|
||||
`Ok (Array.init (1 + Array.length infix)
|
||||
(fun j ->
|
||||
if j < i
|
||||
then infix.(j)
|
||||
else if j = i then (ass, (atr, [newp, sem]))
|
||||
else if j = i then (ass, (atr, [newp, kind_of public, sem]))
|
||||
else infix.(j-1)
|
||||
))
|
||||
)
|
||||
(fun _ -> no_op op coord)
|
||||
|
||||
let after coord op newp ass (sem, atr) infix =
|
||||
let after coord op newp ass public (sem, atr) (infix : t) =
|
||||
find_op infix op
|
||||
(fun i ->
|
||||
`Ok (Array.init (1 + Array.length infix)
|
||||
(fun j ->
|
||||
if j <= i
|
||||
then infix.(j)
|
||||
else if j = i+1 then (ass, (atr, [newp, sem]))
|
||||
else if j = i+1 then (ass, (atr, [newp, kind_of public, sem]))
|
||||
else infix.(j-1)
|
||||
))
|
||||
)
|
||||
|
|
@ -801,14 +837,14 @@ module Definition =
|
|||
|
||||
ostap (
|
||||
arg : LIDENT;
|
||||
position[ass][coord][newp]:
|
||||
%"at" s:STRING {Infix.at coord (unquote s) newp}
|
||||
| f:(%"before" {Infix.before} | %"after" {Infix.after}) s:STRING {f coord (unquote s) newp ass};
|
||||
position[pub][ass][coord][newp]:
|
||||
%"at" s:STRING {Infix.at coord (unquote s) newp pub}
|
||||
| f:(%"before" {Infix.before} | %"after" {Infix.after}) s:STRING {f coord (unquote s) newp ass pub};
|
||||
head[infix]:
|
||||
m:(%"external" {`Extern} | %"public" e:(%"external")? {match e with None -> `Public | _ -> `PublicExtern})? %"fun" name:LIDENT {unopt_mod m, name, name, infix}
|
||||
| m:(%"public" {`Public})? ass:(%"infix" {`Nona} | %"infixl" {`Lefta} | %"infixr" {`Righta})
|
||||
l:$ op:(s:STRING {unquote s})
|
||||
md:position[ass][l#coord][op] {
|
||||
md:position[match m with Some _ -> true | _ -> false][ass][l#coord][op] {
|
||||
let name = Expr.infix_name op in
|
||||
match md (Expr.sem name) infix with
|
||||
| `Ok infix' -> unopt_mod m, op, name, infix'
|
||||
|
|
@ -836,12 +872,12 @@ module Definition =
|
|||
)
|
||||
|
||||
end
|
||||
|
||||
|
||||
module Interface =
|
||||
struct
|
||||
|
||||
(* Generates an interface file. *)
|
||||
let gen (imps, p) =
|
||||
let gen ((imps, ifxs), p) =
|
||||
let buf = Buffer.create 256 in
|
||||
let append str = Buffer.add_string buf str in
|
||||
List.iter (fun i -> append "I,"; append i; append ";\n") imps;
|
||||
|
|
@ -857,7 +893,16 @@ module Interface =
|
|||
| _ -> ()
|
||||
)
|
||||
decls;
|
||||
| _ -> ());
|
||||
| _ -> ());
|
||||
List.iter
|
||||
(function (ass, op, loc) ->
|
||||
let append_op op = append "\""; append op; append "\"" in
|
||||
append (match ass with `Lefta -> "L," | `Righta -> "R," | _ -> "N,");
|
||||
append_op op;
|
||||
append ",";
|
||||
(match loc with `At op -> append "T,"; append_op op | `After op -> append "A,"; append_op op | `Before op -> append "B,"; append_op op);
|
||||
append ";\n"
|
||||
) ifxs;
|
||||
Buffer.contents buf
|
||||
|
||||
(* Read an interface file *)
|
||||
|
|
@ -866,7 +911,11 @@ module Interface =
|
|||
funspec: "F" "," i:IDENT ";" {`Fun i};
|
||||
varspec: "V" "," i:IDENT ";" {`Variable i};
|
||||
import : "I" "," i:IDENT ";" {`Import i};
|
||||
interface: (funspec | varspec | import)*
|
||||
infix : a:ass "," op:STRING "," l:loc ";" {`Infix (a, op, l)};
|
||||
ass : "L" {`Lefta} | "R" {`Righta} | "N" {`Nona};
|
||||
loc : m:mode "," op:STRING {m op};
|
||||
mode : "T" {fun x -> `At x} | "A" {fun x -> `After x} | "B" {fun x -> `Before x};
|
||||
interface: (funspec | varspec | import | infix)*
|
||||
)
|
||||
in
|
||||
try
|
||||
|
|
@ -874,6 +923,7 @@ module Interface =
|
|||
(match Util.parse (object
|
||||
inherit Matcher.t s
|
||||
inherit Util.Lexers.ident [] s
|
||||
inherit Util.Lexers.string s
|
||||
inherit Util.Lexers.skip [Matcher.Skip.whitespaces " \t\n"] s
|
||||
end)
|
||||
(ostap (interface -EOF))
|
||||
|
|
@ -897,7 +947,7 @@ module Interface =
|
|||
| None -> invalid_arg (Printf.sprintf "could not find an interface file for import '%s'" import)
|
||||
|
||||
end
|
||||
|
||||
|
||||
(* The top-level definitions *)
|
||||
|
||||
(* Top-level evaluator
|
||||
|
|
@ -912,10 +962,36 @@ let eval (_, expr) i =
|
|||
|
||||
(* Top-level parser *)
|
||||
ostap (
|
||||
imports: is:(%"import" !(Util.list (ostap (LIDENT))) -";")* {List.flatten is};
|
||||
parse[infix]:
|
||||
is:imports <(d, infix')> : definitions[infix] expr:!(Expr.parse definitions infix' Expr.Void)? {
|
||||
is, Expr.Scope (d, match expr with None -> Expr.Skip | Some e -> e)
|
||||
imports[cmd]: l:$ is:(%"import" !(Util.list (ostap (LIDENT))) -";")* {
|
||||
let is = List.flatten is in
|
||||
let infix =
|
||||
List.fold_left
|
||||
(fun infix import ->
|
||||
List.fold_left
|
||||
(fun infix item ->
|
||||
let insert name infix md =
|
||||
let name = Expr.infix_name name in
|
||||
match md (Expr.sem name) infix with
|
||||
| `Ok infix' -> infix'
|
||||
| `Fail msg -> raise (Semantic_error msg)
|
||||
in
|
||||
match item with
|
||||
| `Infix (_ , op, `At op') -> insert (unquote op) infix (Infix.at l#coord (unquote op') (unquote op) false)
|
||||
| `Infix (ass, op, `Before op') -> insert (unquote op) infix (Infix.before l#coord (unquote op') (unquote op) ass false)
|
||||
| `Infix (ass, op, `After op') -> insert (unquote op) infix (Infix.after l#coord (unquote op') (unquote op) ass false)
|
||||
| _ -> infix
|
||||
)
|
||||
infix
|
||||
(snd (Interface.find import cmd#get_include_paths))
|
||||
)
|
||||
Infix.default
|
||||
is
|
||||
in
|
||||
is, infix
|
||||
};
|
||||
parse[cmd]:
|
||||
<(is, infix)> : imports[cmd] <(d, infix')> : definitions[infix] expr:!(Expr.parse definitions infix' Expr.Void)? {
|
||||
(is, Infix.extract_exports infix'), Expr.Scope (d, match expr with None -> Expr.Skip | Some e -> e)
|
||||
};
|
||||
definitions[infix]:
|
||||
<(def, infix')> : !(Definition.parse infix Expr.basic definitions) <(defs, infix'')> : definitions[infix'] {
|
||||
|
|
|
|||
17
src/SM.ml
17
src/SM.ml
|
|
@ -369,15 +369,16 @@ object (self : 'self)
|
|||
method nlocals = scope.nlocals
|
||||
|
||||
method get_decls =
|
||||
let opt_label = function true -> label | _ -> fun x -> "global_" ^ x in
|
||||
List.flatten @@
|
||||
List.map
|
||||
(function
|
||||
| (name, `Extern) -> [EXTERN name]
|
||||
| (name, `Public) -> [PUBLIC name]
|
||||
| (name, `PublicExtern) -> [PUBLIC name; EXTERN name]
|
||||
| _ -> invalid_arg "must not happen"
|
||||
| (name, `Extern, f) -> [EXTERN (opt_label f name)]
|
||||
| (name, `Public, f) -> [PUBLIC (opt_label f name)]
|
||||
| (name, `PublicExtern, f) -> [PUBLIC (opt_label f name); EXTERN (opt_label f name)]
|
||||
| _ -> invalid_arg "must not happen"
|
||||
) @@
|
||||
List.filter (function (_, `Local) -> false | _ -> true) decls
|
||||
List.filter (function (_, `Local, _) -> false | _ -> true) decls
|
||||
|
||||
method push_scope =
|
||||
match scope.st with
|
||||
|
|
@ -455,7 +456,7 @@ object (self : 'self)
|
|||
raise (Semantic_error (Printf.sprintf "external/public definitions ('%s') not allowed in local scopes" name))
|
||||
|
||||
method add_name (name : string) (m : [`Local | `Extern | `Public | `PublicExtern]) (mut : bool) = {<
|
||||
decls = (name, m) :: decls;
|
||||
decls = (name, m, false) :: decls;
|
||||
scope = {
|
||||
scope with
|
||||
st = (match scope.st with
|
||||
|
|
@ -488,7 +489,7 @@ object (self : 'self)
|
|||
State.L (check_name_and_add names name false, State.bind name (Value.Fun name') s, p)
|
||||
in
|
||||
{<
|
||||
decls = (name, m) :: decls;
|
||||
decls = (name, m, true) :: decls;
|
||||
scope = {scope with st = st'}
|
||||
>}
|
||||
|
||||
|
|
@ -530,7 +531,7 @@ object (self : 'self)
|
|||
|
||||
end
|
||||
|
||||
let compile cmd (imports, p) =
|
||||
let compile cmd ((imports, infixes), p) =
|
||||
let rec pattern env lfalse = function
|
||||
| Pattern.Wildcard -> env, false, [DROP]
|
||||
| Pattern.Named (_, p) -> pattern env lfalse p
|
||||
|
|
|
|||
|
|
@ -558,7 +558,7 @@ class env prg =
|
|||
(* gets a name for a global variable *)
|
||||
method loc x =
|
||||
match x with
|
||||
| Value.Global name -> M ((*"global_" ^*) name)
|
||||
| Value.Global name -> M ("global_" ^ name)
|
||||
| Value.Fun name -> M ("$" ^ name)
|
||||
| Value.Local i -> S i
|
||||
| Value.Arg i -> S (- (i + if has_closure then 2 else 1))
|
||||
|
|
@ -603,7 +603,7 @@ class env prg =
|
|||
(* registers a variable in the environment *)
|
||||
method variable x =
|
||||
match x with
|
||||
| Value.Global name -> {< globals = S.add ((*"global_" ^*) name) globals >}
|
||||
| Value.Global name -> {< globals = S.add ("global_" ^ name) globals >}
|
||||
| _ -> self
|
||||
|
||||
(* registers a string constant *)
|
||||
|
|
@ -699,7 +699,7 @@ let build cmd prog =
|
|||
let inc = try Sys.getenv "RC_RUNTIME" with _ -> "../runtime" in
|
||||
match cmd#get_mode with
|
||||
| `Default ->
|
||||
let objs = find_objects (fst prog) cmd#get_include_paths in
|
||||
let objs = find_objects (fst @@ fst prog) cmd#get_include_paths in
|
||||
let buf = Buffer.create 255 in
|
||||
List.iter (fun o -> Buffer.add_string buf o; Buffer.add_string buf " ") objs;
|
||||
Sys.command (Printf.sprintf "gcc -g -m32 -o %s %s.s %s %s/runtime.a" name name (Buffer.contents buf) inc)
|
||||
|
|
|
|||
Loading…
Add table
Add a link
Reference in a new issue