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

External/public, better options

Browse source
This commit is contained in:
Dmitry Boulytchev 2019-11-24 02:30:32 +03:00
parent 5a883d8fa9
commit 1a849e7a56
12 changed files with 294 additions and 93 deletions
Download patch file Download diff file Expand all files Collapse all files

13
doc/spec/01.general_characteristic.tex Normal file
View file

@ -0,0 +1,13 @@
\section{General Characteristic of the Language}
\begin{itemize}
\item procedural with first-class functions~--- functions can be passed as arguments, placed in data structures,
returned and constructed at runtime via closures mechanism;
\item with lexical static scoping;
\item strict~--- all arguments of function application are evaluated before function's body;
\item imperative~--- variables can be re-assigned, function calls can have side effects;
\item untyped~--- no static type checking is performed;
\item supports S-expressions and pattern-matching;
\item supports user-defined infix operators, including those defined in local scopes;
\item with automatic memory management (garbage collection).
\end{itemize}

50
doc/spec/02.notation.tex Normal file
View file

@ -0,0 +1,50 @@
\section{Notation}
Pairs and tuples:
\[
\inbr{\bullet,\,\bullet,\,\dots}
\]
Lists of elements of kind $X$:
\[
X^*
\]
Deconstructing lists into sublists:
\[
h\circ t
\]
This applies also to lists of length 1. Empty list is denoted
\[
\epsilon
\]
For a mapping $f : X\to Y$ we use the following definition:
\[
f [x\gets y] = \lambda\,z\,.\,
\left\{
\begin{array}{rcl}
y &,& x = z \\
f\;x &,& x\neq z
\end{array}
\right.
\]
Empty mapping (undefined everywhere) is denoted $\Lambda$, the domain of a mapping $f$~--- $\dom{f}$, and we abbreviate
\[
\Lambda[x_1\gets y_1][x_2\gets y_2]\dots[x_k\gets y_k]
\]
as
\[
[x_1\gets y_1,\,x_2\gets y_2,\,\dots,\,x_k\gets y_k]
\]

20
doc/spec/03.values.tex Normal file
View file

@ -0,0 +1,20 @@
\section{Names, Values and States}
\begin{table}[t]
\begin{tabular}{cccl}
denotation & instances & definition & comments \\
\hline
$\mathscr X$ & $x,\,y,\,z,\,\dots$ & & variables \\
$\mathscr T$ & $\llang{C},\,\llang{D},\,\dots$ & & tags (constructors) \\
$\Sigma$ & $\sigma$ & $\mathscr X\to\mathscr V$ & bindings (a partial map from variables to values) \\
$\Sigma_{\mathscr X}$ & $\inbr{\sigma,\,S}$ & $2^{\mathscr X}\times\Sigma$ & local scope (a set of variable and bindings) \\
$St$ & $\inbr{\sigma_g,\,ss}$ & $\Sigma\times\Sigma^*_{\mathscr X}$ & state (global bindings and a stack of local scopes) \\
$\mathscr L$ & $l$ & & locations \\
$M$ & $\mu$ & $\mathscr L\to\mathscr C$ & abstract memory (a partial map from locations to composite values) \\
$\mathscr V$ & $v$ & $\mathbb Z\uplus \mathscr L$ & values (integer values or locations) \\
$\mathscr C$ & & $Arr\uplus Sexp \uplus Clo$ & composite values (arrays, S-expressions or closures) \\
$Arr$ & & $\mathbb N\times (\mathbb N\to\mathscr V)$ & arrays (length and element function) \\
$Sexp$ & & $\mathscr T \times Arr$ & S-expressions (tag and array of subvalues) \\
$Clo$ & & $\mathscr X \times \Sigma^*_{\mathscr X}$ & closures (function name and a stack of local scopes)
\end{tabular}
\end{table}

31
doc/spec/spec.tex
View file

@ -25,6 +25,7 @@
\usepackage{multirow,bigdelim}
\usepackage{subcaption}
\usepackage{placeins}
\usepackage{xspace}
\makeatletter
@ -71,15 +72,12 @@
\renewcommand{\emptyset}{\varnothing}
\newcommand{\dom}[1]{\mathtt{dom}\;{#1}}
\newcommand{\primi}[2]{\mathbf{#1}\;{#2}}
\newcommand{\sial}{S\textit{\lower -.5ex\hbox{I}\kern -.1667em\lower .5ex\hbox {A}}\kern -.125emL\@\xspace}
\definecolor{light-gray}{gray}{0.90}
\newcommand{\graybox}[1]{\colorbox{light-gray}{#1}}
\lstdefinelanguage{ocaml}{
keywords={let, begin, end, in, match, type, and, fun,
function, try, mod, with, class, object, method, of, rec, repeat, until,
while, not, do, done, as, val, inherit, module, sig, @type, struct,
if, then, else, open, virtual, new, fresh, skip, od, fi, elif, for, local, return, read, write, fi, case, esac, od},
\lstdefinelanguage{sial}{
keywords={fun, case, esac, do, od, if, then, else, elif, fi, skip, repeat, until, for, local},
sensitive=true,
%basicstyle=\small,
commentstyle=\scriptsize\rmfamily,
@ -88,7 +86,7 @@ identifierstyle=\ttfamily,
basewidth={0.5em,0.5em},
columns=fixed,
fontadjust=true,
literate={->}{{$\to$}}3 {===}{{$\equiv$}}1 {=/=}{{$\not\equiv$}}1 {|>}{{$\triangleright$}}3 {\&\&\&}{{$\wedge$}}2 {|||}{{$\vee$}}2 {^}{{$\uparrow$}}1,
literate={->}{{$\to$}}3,
morecomment=[s]{(*}{*)}
}
@ -101,16 +99,12 @@ commentstyle=\scriptsize\rmfamily,
basewidth={0.5em,0.5em},
fontadjust=true,
escapechar=!,
language=ocaml
language=sial
}
\sloppy
\newcommand{\ocaml}{\texttt{OCaml}\xspace}
\theoremstyle{definition}
\title{Introduction to Programming Languages, Compilers and Tools}
\title{\sial Language Definition}
\author{Dmitry Boulytchev}
@ -118,13 +112,8 @@ language=ocaml
\maketitle
\input{01}
\input{02}
\input{03}
\input{04}
\input{05}
\input{06}
\input{07}
\input{08}
\input{01.general_characteristic}
\input{02.notation}
\input{03.values}
\end{document}

2
regression/x86only/test001.expr
View file

@ -1,3 +1,5 @@
external fun printf ();
fun insert (tree, value) {
case tree of
Empty -> return Node (value, Empty, Empty)

2
regression/x86only/test002.expr
View file

@ -1,3 +1,5 @@
external fun printf ();
fun collect_ints_acc (v, tail) {
local i;

2
regression/x86only/test003.expr
View file

@ -1,3 +1,5 @@
external fun printf ();
local lists = [
{},
{1, 2, 3, 4},

2
regression/x86only/test004.expr
View file

@ -1,3 +1,5 @@
external fun printf ();
fun hd (l) {
case l of
h : _ -> return h

105
src/Driver.ml
View file

@ -8,7 +8,7 @@ let parse infile =
"while"; "do"; "od";
"repeat"; "until";
"for";
"fun"; "local"; "return";
"fun"; "local"; "public"; "external"; "return";
"length";
"string";
"case"; "of"; "esac"; "when";
@ -32,36 +32,91 @@ let parse infile =
)
(ostap (!(Language.parse Language.Infix.default) -EOF))
exception Commandline_error of string
class options args =
let n = Array.length args in
let rec fix f = f (fix f) in
object (self)
val i = ref 1
val infile = ref (None : string option)
val paths = ref ([] : string list)
val mode = ref (`Default : [`Default | `Eval | `SM | `Compile ])
val help = ref false
initializer
let rec loop () =
match self#peek with
| Some opt ->
(match opt with
| "-c" -> self#set_mode `Compile
| "-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
| "-i" -> self#set_mode `Eval
| "-h" -> self#set_help
| _ ->
if opt.[0] = '-'
then raise (Commandline_error (Printf.sprintf "invalid command line specifier ('%s')" opt))
else self#set_infile opt
);
loop ()
| None -> ()
in loop ()
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'))
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)))
else None
method private set_help = help := true
method get_mode = !mode
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
end
let main =
(* try*)
let interpret = Sys.argv.(1) = "-i" in
let cmd = new options Sys.argv in
(*let interpret = Sys.argv.(1) = "-i" in
let stack = Sys.argv.(1) = "-s" in
let to_compile = not (interpret || stack) in
let infile = Sys.argv.(if not to_compile then 2 else 1) in
match (try parse infile with Language.Semantic_error msg -> `Fail msg) with
*)
match (try parse cmd#get_infile with Language.Semantic_error msg -> `Fail msg) with
| `Ok prog ->
if to_compile
then (
let basename = Filename.chop_suffix infile ".expr" in
ignore @@ X86.build prog basename
)
else (
(* Printf.printf "Program:\n%s\n" (GT.show(Language.Expr.t) prog);*)
(*Format.printf "Program\n%s\n%!" (HTML.toHTML ((GT.html(Language.Expr.t)) prog));*)
let rec read acc =
try
let r = read_int () in
Printf.printf "> ";
read (acc @ [r])
with End_of_file -> acc
in
let input = read [] in
let output =
if interpret
then Language.eval prog input
else SM.run (SM.compile prog) input
in
List.iter (fun i -> Printf.printf "%d\n" i) output
(match cmd#get_mode with
| `Default | `Compile ->
ignore @@ X86.build cmd prog
| _ ->
(* Printf.printf "Program:\n%s\n" (GT.show(Language.Expr.t) prog);*)
(*Format.printf "Program\n%s\n%!" (HTML.toHTML ((GT.html(Language.Expr.t)) prog));*)
let rec read acc =
try
let r = read_int () in
Printf.printf "> ";
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
else SM.run (SM.compile prog) input
in
List.iter (fun i -> Printf.printf "%d\n" i) output
)
| `Fail er -> Printf.eprintf "Error: %s\n" er
(* with Invalid_argument _ ->

61
src/Language.ml
View file

@ -328,7 +328,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 = [`Fun of string list * t | `Variable of t option]
and decl = [`Local | `Public | `Extern] * [`Fun of string list * t | `Variable of t option]
with show,html
(* Reff : parsed expression should return value Reff (look for ":=");
@ -416,11 +416,16 @@ module Expr =
let vars, body, bnds =
List.fold_left
(fun (vs, bd, bnd) -> function
| (name, `Variable value) -> (name, true) :: vs, (match value with None -> bd | Some v -> Seq (Ignore (Assign (Ref name, v)), bd)), bnd
| (name, `Fun (args, b)) -> (name, false) :: vs, bd, (name, Value.FunRef (name, args, b, 1 + State.level st)) :: bnd
| (name, (_, `Variable value)) -> (name, true) :: vs, (match value with None -> bd | Some v -> Seq (Ignore (Assign (Ref name, v)), bd)), bnd
| (name, (_, `Fun (args, b))) -> (name, false) :: vs, bd, (name, Value.FunRef (name, args, b, 1 + State.level st)) :: bnd
)
([], body, [])
(List.rev defs)
(List.rev @@
List.map (function
| (name, (`Extern, _)) -> raise (Semantic_error (Printf.sprintf "external names ('%s') not supported in evaluation" name))
| x -> x
)
defs)
in
eval (State.push st (State.from_list bnds) vars, i, o, vs) k (Seq (body, Leave))
| Unit ->
@ -447,7 +452,7 @@ module Expr =
in
eval (st, i, o, v :: vs) Skip k
| Ref x ->
eval (st, i, o, (Value.Var (Value.Global x)) :: vs) Skip k
eval (st, i, o, (Value.Var (Value.Global x)) :: vs) Skip k (* only Value.Global is supported in interpretation *)
| Array xs ->
eval conf k (schedule_list (xs @ [Intrinsic (fun (st, i, o, vs) -> let es, vs' = take (List.length xs) vs in Builtin.eval (st, i, o, vs') (List.rev es) ".array")]))
| Sexp (t, xs) ->
@ -700,9 +705,8 @@ module Expr =
| %"for" i:parse[def][infix][Void] "," c:parse[def][infix][Val] "," s:parse[def][infix][Void] %"do" b:scope[def][infix][Void][parse def] => {isVoid atr} => %"od"
{Seq (i, While (c, Seq (b, s)))}
| %"repeat" s:scope[def][infix][Void][parse def] %"until" e:basic[def][infix][Val]
=> {isVoid atr} => {Repeat (s, e)}
| %"return" e:basic[def][infix][Val]? => {isVoid atr} => {Return e}
| %"repeat" s:scope[def][infix][Void][parse def] %"until" e:basic[def][infix][Val] => {isVoid atr} => {Repeat (s, e)}
| %"return" e:basic[def][infix][Val]? => {isVoid atr} => {Return e}
| %"case" e:parse[def][infix][Val] %"of" bs:!(Util.listBy1)[ostap ("|")][ostap (!(Pattern.parse) -"->" parse[def][infix][atr])] %"esac"
{Case (e, bs)}
@ -793,28 +797,42 @@ module Definition =
(* The type for a definition: aither a function/infix, or a local variable *)
type t = string * [`Fun of string list * Expr.t | `Variable of Expr.t option]
let unopt_mod = function None -> `Local | Some m -> m
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};
head[infix]:
%"fun" name:LIDENT {name, infix}
| ass:(%"infix" {`Nona} | %"infixl" {`Lefta} | %"infixr" {`Righta})
m:(%"external" {`Extern} | %"public" {`Public})? %"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] {
let name = Expr.infix_name op in
match md (Expr.sem name) infix with
| `Ok infix' -> name, infix'
| `Ok infix' -> unopt_mod m, op, name, infix'
| `Fail msg -> raise (Semantic_error msg)
};
local_var[infix][expr][def]: name:LIDENT value:(-"=" expr[def][infix][Expr.Val])? {name, `Variable value};
local_var[m][infix][expr][def]: name:LIDENT value:(-"=" expr[def][infix][Expr.Val])? {
match m, value with
| `Extern, Some _ -> raise (Semantic_error (Printf.sprintf "initial value for an external variable '%s' can not be specified" name))
| _ -> name, (m,`Variable value)
};
parse[infix][expr][def]:
%"local" locs:!(Util.list (local_var infix expr def)) ";" {locs, infix}
| <(name, infix')> : head[infix] "(" args:!(Util.list0 arg) ")"
body:expr[def][infix'][Expr.Void] {
[(name, `Fun (args, body))], infix'
}
m:(%"local" {`Local} | %"public" {`Public} | %"external" {`Extern})
locs:!(Util.list (local_var m infix expr def)) ";" {locs, infix}
| - <(m, orig_name, name, infix')> : head[infix] -"(" -args:!(Util.list0 arg) -")"
(body:expr[def][infix'][Expr.Void] {
match m with
| `Extern -> raise (Semantic_error (Printf.sprintf "body for an external function '%s' can not be specified" orig_name))
| _ -> [(name, (m, `Fun (args, body)))], infix'
} |
";" {
match m with
| `Extern -> [(name, (m, `Fun (args, Expr.Skip)))], infix'
| _ -> raise (Semantic_error (Printf.sprintf "missing body for the function/infix '%s'" orig_name))
})
)
end
@ -836,8 +854,13 @@ let eval expr i =
(* Top-level parser *)
ostap (
parse[infix]: !(Expr.scope definitions infix Expr.Void (Expr.parse definitions));
parse[infix]:
<(d, infix')> : definitions[infix] expr:!(Expr.parse definitions infix' Expr.Void)? {
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'] {def @ defs, infix''}
<(def, infix')> : !(Definition.parse infix Expr.basic definitions) <(defs, infix'')> : definitions[infix'] {
def @ defs, infix''
}
| empty {[], infix}
)

51
src/SM.ml
View file

@ -30,6 +30,8 @@ open Language
(* checks the tag and arity of S-expression *) | TAG of string * int
(* checks the tag and size of array *) | ARRAY of int
(* checks various patterns *) | PATT of patt
(* external definition *) | EXTERN of string
(* public definition *) | PUBLIC of string
with show
(* The type for the stack machine program *)
@ -94,6 +96,7 @@ let rec eval env (((cstack, stack, glob, loc, i, o) as conf) : config) = functio
Printf.eprintf "end\n";
*)
(match insn with
| PUBLIC _ | EXTERN _ -> eval env conf prg'
| BINOP op -> let y::x::stack' = stack in eval env (cstack, (Value.of_int @@ Expr.to_func op (Value.to_int x) (Value.to_int y)) :: stack', glob, loc, i, o) prg'
| CONST n -> eval env (cstack, (Value.of_int n)::stack, glob, loc, i, o) prg'
| STRING s -> eval env (cstack, (Value.of_string @@ Bytes.of_string s)::stack, glob, loc, i, o) prg'
@ -337,12 +340,19 @@ object (self : 'self)
val lam_index = 0
val scope = init_scope State.I
val fundefs = Top []
val decls = []
method global_scope = scope_index = 0
method get_label = (label @@ string_of_int label_index), {< label_index = label_index + 1 >}
method nargs = scope.arg_index
method nlocals = scope.nlocals
method get_decls =
List.map (function (name, `Extern) -> EXTERN name | (name, `Public) -> PUBLIC name | _ -> invalid_arg "must not happen") @@
List.filter (function (_, `Local) -> false | _ -> true) decls
method push_scope = {<
scope_index = scope_index + 1;
scope = {
@ -415,7 +425,14 @@ object (self : 'self)
}
>}
method add_name (name : string) (mut : bool) = {<
method check_scope m name =
match m with
| `Local -> ()
| _ ->
raise (Semantic_error (Printf.sprintf "external/public definitions ('%s') not allowed in local scopes" name))
method add_name (name : string) (m : [`Local | `Extern | `Public]) (mut : bool) = {<
decls = (name, m) :: decls;
scope = {
scope with
st = (match scope.st with
@ -424,6 +441,7 @@ object (self : 'self)
| State.G (names, s) ->
State.G (check_name_and_add names name mut, State.bind name (Value.Global name) s)
| State.L (names, s, p) ->
self#check_scope m name;
State.L (check_name_and_add names name mut, State.bind name (Value.Local scope.local_index) s, p)
);
local_index = (match scope.st with State.L _ -> scope.local_index + 1 | _ -> scope.local_index);
@ -434,7 +452,7 @@ object (self : 'self)
method fun_internal_name (name : string) =
(match scope.st with State.G _ -> label | _ -> scope_label scope_index) name
method add_fun_name (name : string) =
method add_fun_name (name : string) (m : [`Local | `Extern | `Public]) =
let name' = self#fun_internal_name name in
let st' =
match scope.st with
@ -443,9 +461,11 @@ object (self : 'self)
| State.G (names, s) ->
State.G (check_name_and_add names name false, State.bind name (Value.Fun name') s)
| State.L (names, s, p) ->
self#check_scope m name;
State.L (check_name_and_add names name false, State.bind name (Value.Fun name') s, p)
in
{<
decls = (name, m) :: decls;
scope = {scope with st = st'}
>}
@ -453,11 +473,14 @@ object (self : 'self)
let name' = self#fun_internal_name (Printf.sprintf "lambda_%d" lam_index) in
{< fundefs = add_fun fundefs (to_fundef name' args body scope.st); lam_index = lam_index + 1 >}, name'
method add_fun (name : string) (args : string list) (body : Expr.t) =
method add_fun (name : string) (args : string list) (m : [`Local | `Extern | `Public]) (body : Expr.t) =
let name' = self#fun_internal_name name in
{<
fundefs = add_fun fundefs (to_fundef name' args body scope.st)
>}
match m with
| `Extern -> self
| _ ->
{<
fundefs = add_fun fundefs (to_fundef name' args body scope.st)
>}
method lookup name =
match State.eval scope.st name with
@ -543,7 +566,7 @@ let compile p =
let env, code =
List.fold_left
(fun (env, acc) (name, path) ->
let env = env#add_name name true in
let env = env#add_name name `Local true in
let env, dsg = env#lookup name in
env,
([DUP] @
@ -574,14 +597,14 @@ let compile p =
List.fold_left
(fun (env, e, funs) ->
function
| name, `Fun (args, b) -> env#add_fun_name name, e, (name, args, b) :: funs
| name, `Variable None -> env#add_name name true, e, funs
| name, `Variable (Some v) -> env#add_name name true, Expr.Seq (Expr.Ignore (Expr.Assign (Expr.Ref name, v)), e), funs
| name, (m, `Fun (args, b)) -> env#add_fun_name name m, e, (name, args, m, b) :: funs
| name, (m, `Variable None) -> env#add_name name m true, e, funs
| name, (m, `Variable (Some v)) -> env#add_name name m true, Expr.Seq (Expr.Ignore (Expr.Assign (Expr.Ref name, v)), e), funs
)
(env, e, [])
(List.rev ds)
in
let env = List.fold_left (fun env (name, args, b) -> env#add_fun name args b) env funs in
let env = List.fold_left (fun env (name, args, m, b) -> env#add_fun name args m b) env funs in
let env, flag, code = compile_expr l env e in
env#pop_scope, flag, code
@ -709,6 +732,8 @@ let compile p =
let env = new env in
let lend, env = env#get_label in
let env, flag, code = compile_expr lend env p in
let env, prg = compile_fundefs [[LABEL "main"; BEGIN ("main", 0, env#nlocals, [])] @(if flag then code @ [LABEL lend] else code) @ [END]] env in
let prg = List.flatten prg in
let code = if flag then code @ [LABEL lend] else code in
let has_main = List.length code > 0 in
let env, prg = compile_fundefs [if has_main then [LABEL "main"; BEGIN ("main", 0, env#nlocals, [])] @ code @ [END] else []] env in
let prg = (if has_main then [PUBLIC "main"] else []) @ env#get_decls @ List.flatten prg in
prg

40
src/X86.ml
View file

@ -217,6 +217,9 @@ let compile env code =
let stack = env#show_stack in
let env', code' =
match instr with
| PUBLIC name -> env#register_public name, []
| EXTERN name -> env#register_extern name, []
| CLOSURE name ->
let pushr, popr =
List.split @@ List.map (fun r -> (Push r, Pop r)) (env#live_registers 0)
@ -492,6 +495,13 @@ class env prg =
val barrier = false (* barrier condition *)
val max_locals_size = 0
val has_closure = false
val publics = S.empty
val externs = S.empty
method publics = S.elements publics
method register_public name = {< publics = S.add name publics >}
method register_extern name = {< externs = S.add name externs >}
method max_locals_size = max_locals_size
@ -548,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))
@ -593,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 *)
@ -605,7 +615,7 @@ class env prg =
y, {< scount = scount + 1; stringm = m>}
(* gets all global variables *)
method globals = S.elements globals
method globals = S.elements (S.diff globals externs)
(* gets all string definitions *)
method strings = M.bindings stringm
@ -643,24 +653,32 @@ let genasm prog =
let sm = SM.compile prog in
let env, code = compile (new env sm) sm in
let gc_start, gc_end = "__gc_data_start", "__gc_data_end" in
let globals =
List.map (fun s -> Meta (Printf.sprintf "\t.globl\t%s" s)) ([gc_start; gc_end] @ env#publics)
in
let data = [Meta "\t.data";
Meta (Printf.sprintf "filler:\t.fill\t%d, 4, 1" env#max_locals_size);
Meta (Printf.sprintf "\t.globl\t%s" gc_start); Meta (Printf.sprintf "\t.globl\t%s" gc_end)] @
[Meta (Printf.sprintf "%s:" gc_start)] @
(List.map (fun s -> Meta (Printf.sprintf "%s:\t.int\t1" s )) env#globals) @
[Meta (Printf.sprintf "%s:" gc_end)] @
(List.map (fun (s, v) -> Meta (Printf.sprintf "%s:\t.string\t\"%s\"" v s)) env#strings)
Meta (Printf.sprintf "%s:" gc_start)] @
(List.map (fun s -> Meta (Printf.sprintf "%s:\t.int\t1" s)) env#globals) @
[Meta (Printf.sprintf "%s:" gc_end)] @
(List.map (fun (s, v) -> Meta (Printf.sprintf "%s:\t.string\t\"%s\"" v s)) env#strings)
in
let asm = Buffer.create 1024 in
List.iter
(fun i -> Buffer.add_string asm (Printf.sprintf "%s\n" @@ show i))
(data @ [Meta "\t.text"; Meta "\t.globl\tmain"] @ code);
(globals @ data @ [Meta "\t.text"] @ code);
Buffer.contents asm
(* Builds a program: generates the assembler file and compiles it with the gcc toolchain *)
let build prog name =
let build cmd prog =
let name = Filename.chop_suffix cmd#get_infile ".expr" in
let outf = open_out (Printf.sprintf "%s.s" name) in
Printf.fprintf outf "%s" (genasm prog);
close_out outf;
let inc = try Sys.getenv "RC_RUNTIME" with _ -> "../runtime" in
Sys.command (Printf.sprintf "gcc -g -m32 -o %s %s.s %s/runtime.a" name name inc)
match cmd#get_mode with
| `Default ->
Sys.command (Printf.sprintf "gcc -g -m32 -o %s %s.s %s/runtime.a" name name inc)
| `Compile ->
Sys.command (Printf.sprintf "gcc -g -m32 -c %s.s" name)
| _ -> invalid_arg "must not happen"