mirror of
https://github.com/ProgramSnail/Lama.git
synced 2025-12-06 06:48:48 +00:00
Starting to develop FCF in SM
This commit is contained in:
Dmitry Boulytchev
parent
ee1d5c08ec
commit
c3e6d4c76d
4 changed files with 62 additions and 55 deletions
|
|
@ -56,7 +56,7 @@ let main =
|
|||
let output =
|
||||
if interpret
|
||||
then Language.eval prog input
|
||||
else [] (* SM.run (SM.compile prog) input *) (* TODO! *)
|
||||
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
|
||||
|
|
|
|||
|
|
@ -134,12 +134,6 @@ module State =
|
|||
(* empty state *)
|
||||
let empty = I
|
||||
|
||||
(* initialize empty state *)
|
||||
let init st vars list =
|
||||
match st with
|
||||
| I -> G (vars @ Builtin.names, List.fold_left (fun s (name, value) -> bind name value s) (from_list list) (Builtin.bindings ()))
|
||||
| _ -> invalid_arg "state already initialzied"
|
||||
|
||||
(* Scope operation: checks if a name is in a scope *)
|
||||
let in_scope x s = List.exists (fun (y, _) -> y = x) s
|
||||
|
||||
|
|
@ -195,10 +189,13 @@ module State =
|
|||
| L (_, _, e) -> enter e xs
|
||||
|
||||
(* Push a new local scope *)
|
||||
let push st s xs = L (xs, s, st)
|
||||
let push st s xs =
|
||||
match st with
|
||||
| I -> G (xs @ Builtin.names, List.fold_left (fun s (name, value) -> bind name value s) s (Builtin.bindings ()))
|
||||
| _ -> L (xs, s, st)
|
||||
|
||||
(* Drop a local scope *)
|
||||
let drop (L (_, _, e)) = e
|
||||
let drop = function L (_, _, e) -> e | G _ -> I
|
||||
|
||||
(* Observe a variable in a state and print it to stderr *)
|
||||
let observe st x =
|
||||
|
|
@ -296,7 +293,7 @@ module Expr =
|
|||
(* return statement *) | Return of t option
|
||||
(* ignore a value *) | Ignore of t
|
||||
(* unit value *) | Unit
|
||||
(* entering the scope *) | Scope of [`Global | `Local] * (string * [`Fun of string list * t | `Variable of t option]) list * t
|
||||
(* entering the scope *) | Scope of (string * [`Fun of string list * t | `Variable of t option]) list * t
|
||||
(* lambda expression *) | Lambda of string list * t
|
||||
(* leave a scope *) | Leave
|
||||
(* intrinsic (for evaluation) *) | Intrinsic of (t config -> t config)
|
||||
|
|
@ -383,7 +380,7 @@ module Expr =
|
|||
match expr with
|
||||
| Lambda (args, body) ->
|
||||
eval (st, i, o, Value.Closure (args, body, st) ::vs) Skip k
|
||||
| Scope (kind, defs, body) ->
|
||||
| Scope (defs, body) ->
|
||||
let vars, body, bnds =
|
||||
List.fold_left
|
||||
(fun (vs, bd, bnd) -> function
|
||||
|
|
@ -393,13 +390,7 @@ module Expr =
|
|||
([], body, [])
|
||||
(List.rev defs)
|
||||
in
|
||||
eval
|
||||
((match kind with
|
||||
| `Local -> State.push st (State.from_list bnds) vars
|
||||
| `Global -> State.init st vars bnds
|
||||
), i, o, vs)
|
||||
k
|
||||
(match kind with `Global -> body | `Local -> Seq (body, Leave))
|
||||
eval (State.push st (State.from_list bnds) vars, i, o, vs) k (Seq (body, Leave))
|
||||
| Unit ->
|
||||
eval (st, i, o, Value.Empty :: vs) Skip k
|
||||
| Ignore s ->
|
||||
|
|
@ -595,7 +586,7 @@ module Expr =
|
|||
ostap (
|
||||
parse[def][infix][atr]: h:basic[def][infix][Void] -";" t:parse[def][infix][atr] {Seq (h, t)}
|
||||
| basic[def][infix][atr];
|
||||
scope[kind][def][infix][atr][e]: <(d, infix')> : def[infix] expr:e[infix'][atr] {Scope (kind, d, expr)};
|
||||
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);
|
||||
|
||||
|
|
@ -642,7 +633,7 @@ module Expr =
|
|||
| %"infix" s:STRING => {notRef atr} => {ignore atr (Var (infix_name @@ unquote s))}
|
||||
| %"fun" "(" args:!(Util.list0)[ostap (STRING)] ")" body:parse[def][infix][Void] => {notRef atr} => {ignore atr (Lambda (args, body))}
|
||||
| "[" es:!(Util.list0)[parse def infix Val] "]" => {notRef atr} => {ignore atr (Array es)}
|
||||
| -"{" scope[`Local][def][infix][atr][parse def] -"}"
|
||||
| -"{" scope[def][infix][atr][parse def] -"}"
|
||||
| "{" es:!(Util.list0)[parse def infix Val] "}" => {notRef atr} => {ignore atr (match es with
|
||||
| [] -> Const 0
|
||||
| _ -> List.fold_right (fun x acc -> Sexp ("cons", [x; acc])) es (Const 0))
|
||||
|
|
@ -655,22 +646,22 @@ module Expr =
|
|||
|
||||
| {isVoid atr} => %"skip" {Skip}
|
||||
|
||||
| %"if" e:parse[def][infix][Val] %"then" the:scope[`Local][def][infix][atr][parse def]
|
||||
elif:(%"elif" parse[def][infix][Val] %"then" scope[`Local][def][infix][atr][parse def])*
|
||||
%"else" els:scope[`Local][def][infix][atr][parse def] %"fi"
|
||||
| %"if" e:parse[def][infix][Val] %"then" the:scope[def][infix][atr][parse def]
|
||||
elif:(%"elif" parse[def][infix][Val] %"then" scope[def][infix][atr][parse def])*
|
||||
%"else" els:scope[def][infix][atr][parse def] %"fi"
|
||||
{If (e, the, List.fold_right (fun (e, t) elif -> If (e, t, elif)) elif els)}
|
||||
| %"if" e:parse[def][infix][Val] %"then" the:scope[`Local][def][infix][Void][parse def]
|
||||
elif:(%"elif" parse[def][infix][Val] %"then" scope[`Local][def][infix][atr][parse def])*
|
||||
| %"if" e:parse[def][infix][Val] %"then" the:scope[def][infix][Void][parse def]
|
||||
elif:(%"elif" parse[def][infix][Val] %"then" scope[def][infix][atr][parse def])*
|
||||
=> {isVoid atr} => %"fi"
|
||||
{If (e, the, List.fold_right (fun (e, t) elif -> If (e, t, elif)) elif Skip)}
|
||||
|
||||
| %"while" e:parse[def][infix][Val] %"do" s:scope[`Local][def][infix][Void][parse def]
|
||||
| %"while" e:parse[def][infix][Val] %"do" s:scope[def][infix][Void][parse def]
|
||||
=> {isVoid atr} => %"od" {While (e, s)}
|
||||
|
||||
| %"for" i:parse[def][infix][Void] "," c:parse[def][infix][Val] "," s:parse[def][infix][Void] %"do" b:scope[`Local][def][infix][Void][parse def] => {isVoid atr} => %"od"
|
||||
| %"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[`Local][def][infix][Void][parse def] %"until" e:basic[def][infix][Val]
|
||||
| %"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}
|
||||
|
||||
|
|
@ -806,7 +797,7 @@ let eval expr i =
|
|||
|
||||
(* Top-level parser *)
|
||||
ostap (
|
||||
parse[infix]: !(Expr.scope `Global (definitions global) infix Expr.Void (Expr.parse (definitions local)));
|
||||
parse[infix]: !(Expr.scope (definitions global) infix Expr.Void (Expr.parse (definitions local)));
|
||||
local: %"local" {`Local};
|
||||
global: %"global" {`Global};
|
||||
definitions[kind][infix]:
|
||||
|
|
|
|||
64
src/SM.ml
64
src/SM.ml
|
|
@ -155,8 +155,26 @@ let run p i =
|
|||
Takes a program in the source language and returns an equivalent program for the
|
||||
stack machine
|
||||
*)
|
||||
let compile (defs, p) =
|
||||
let label s = "L" ^ s in
|
||||
|
||||
let label s = "L" ^ s
|
||||
|
||||
class env =
|
||||
object (self : 'self)
|
||||
val label_index = 0
|
||||
val scope_index = 0
|
||||
val globals = ([] : string list)
|
||||
|
||||
method get_label = (label @@ string_of_int label_index), {< label_index = label_index + 1 >}
|
||||
|
||||
method push_scope (k : [`Global | `Local]) = self
|
||||
|
||||
method pop_scope (k : [`Global | `Local]) = self
|
||||
|
||||
method add_var (k : [`Global | `Local]) (name : string) = match k with `Global -> self | `Local -> self
|
||||
method add_fun (k : [`Global | `Local]) (name : string) = match k with `Global -> self | `Local -> self
|
||||
end
|
||||
|
||||
let compile p =
|
||||
let rec pattern env lfalse = function
|
||||
| Pattern.Wildcard -> env, false, [DROP]
|
||||
| Pattern.Named (_, p) -> pattern env lfalse p
|
||||
|
|
@ -231,6 +249,23 @@ let compile (defs, p) =
|
|||
let env, flag2, s2 = compile_list l env es in
|
||||
add_code (env, flag1, s1) les flag2 s2
|
||||
and compile_expr l env = function
|
||||
| Expr.Scope (ds, e) ->
|
||||
let k = `Global in
|
||||
let env = env#push_scope k in
|
||||
let env, e =
|
||||
List.fold_left
|
||||
(fun (env, e) ->
|
||||
function
|
||||
| name, `Fun _ -> env#add_fun k name, e
|
||||
| name, `Variable None -> env#add_var k name, e
|
||||
| name, `Variable (Some v) -> env#add_var k name, Expr.Seq (Expr.Assign (Expr.Ref name, v), e)
|
||||
)
|
||||
(env, e)
|
||||
ds
|
||||
in
|
||||
let env, flag, code = compile_expr l env e in
|
||||
env#pop_scope k, flag, code
|
||||
|
||||
| Expr.Unit -> env, false, [CONST 0]
|
||||
|
||||
| Expr.Ignore s -> let ls, env = env#get_label in
|
||||
|
|
@ -265,9 +300,6 @@ let compile (defs, p) =
|
|||
|
||||
| Expr.Assign (x, e) -> let lassn, env = env#get_label in
|
||||
add_code (compile_list lassn env [x; e]) lassn false [match x with Expr.ElemRef _ -> STA | _ -> STI]
|
||||
(* (match x with
|
||||
* | Expr.Ref x -> add_code (compile_expr lassn env e) lassn false [ST x]
|
||||
* | _ -> add_code (compile_list lassn env [x; e]) lassn false [match x with Expr.ElemRef _ -> STA | _ -> STI]) *)
|
||||
|
||||
| Expr.Skip -> env, false, []
|
||||
|
||||
|
|
@ -334,12 +366,7 @@ let compile (defs, p) =
|
|||
in
|
||||
env, true, se @ (if fe then [LABEL lexp] else []) @ [DUP] @ (List.flatten @@ List.rev code) @ [JMP l]
|
||||
in
|
||||
let compile_def env (name, def) =
|
||||
let args, stmt =
|
||||
match def with
|
||||
| `Fun (args, stmt) -> args, stmt
|
||||
| _ -> invalid_arg "local definition"
|
||||
in
|
||||
let compile_fundef env (name, args, stmt) =
|
||||
let lend, env = env#get_label in
|
||||
let env, flag, code = compile_expr lend env stmt in
|
||||
env,
|
||||
|
|
@ -348,18 +375,7 @@ let compile (defs, p) =
|
|||
(if flag then [LABEL lend] else []) @
|
||||
[END]
|
||||
in
|
||||
let env =
|
||||
object
|
||||
val ls = 0
|
||||
method get_label = (label @@ string_of_int ls), {< ls = ls + 1 >}
|
||||
end
|
||||
in
|
||||
let env, def_code =
|
||||
List.fold_left
|
||||
(fun (env, code) (name, others) -> let env, code' = compile_def env (label name, others) in env, code'::code)
|
||||
(env, [])
|
||||
defs
|
||||
in
|
||||
let env = new env in
|
||||
let lend, env = env#get_label in
|
||||
let _, flag, code = compile_expr lend env p in
|
||||
(if flag then code @ [LABEL lend] else code) @ [END] @ (List.concat def_code)
|
||||
(if flag then code @ [LABEL lend] else code) @ [END]
|
||||
|
|
|
|||
|
|
@ -558,7 +558,7 @@ let genasm (ds, stmt) =
|
|||
let env, code =
|
||||
compile
|
||||
(new env)
|
||||
((LABEL "main") :: (BEGIN ("main", [], [])) :: SM.compile (ds, stmt))
|
||||
((LABEL "main") :: (BEGIN ("main", [], [])) :: [] (* TODO! SM.compile (ds, stmt) *))
|
||||
in
|
||||
let gc_start, gc_end = "__gc_data_start", "__gc_data_end" in
|
||||
let data = [Meta "\t.data";
|
||||
|
|
|
|||
Loading…
Add table
Add a link
Reference in a new issue