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

S-expressions and pattern matching

Browse source
This commit is contained in:
Dmitry Boulytchev 2018-05-04 02:59:23 +03:00 • committed by danyaberezun
parent 958bf482a8
commit 800d976b8e
8 changed files with 148 additions and 88 deletions
Download patch file Download diff file Expand all files Collapse all files

2
regression/Makefile
View file

@ -9,7 +9,7 @@ check: $(TESTS)
$(TESTS): %: %.expr
#@$(RC) $< && cat $@.input | ./$@ > $@.log && diff $@.log orig/$@.log
cat $@.input | $(RC) -i $< > $@.log && diff $@.log orig/$@.log
#cat $@.input | $(RC) -s $< > $@.log && diff $@.log orig/$@.log
cat $@.input | $(RC) -s $< > $@.log && diff $@.log orig/$@.log
clean:
rm -f test*.log *.s *~ $(TESTS)

6
regression/orig/test039.log Normal file
View file

@ -0,0 +1,6 @@
> 1
1
1
1
0
0

1
regression/test038.expr
View file

@ -21,4 +21,3 @@ printList (x);
printList (y);
printList (append (x, y));
printList (append (y, x))

31
regression/test039.expr Normal file
View file

@ -0,0 +1,31 @@
fun insert (t, x) {
case t of
`leaf -> return `node (x, `leaf, `leaf)
| `node (y, l, r) -> if x > y
then return `node (y, insert (l, x), r)
else return `node (y, l, insert (r, x))
fi
esac
}
fun find (t, x) {
case t of
`leaf -> return 0
| `node (y, l, r) -> if x == y then return 1
elif x > y then return find (l, x)
else return find (r, x)
fi
esac
}
n := read ();
t := insert (insert (insert (insert (`leaf, 5), 4), 6), 3);
write (find (t, 5));
write (find (t, 4));
write (find (t, 6));
write (find (t, 3));
write (find (t, 2));
write (find (t, 1))

1
regression/test039.input Normal file
View file

@ -0,0 +1 @@
0

46
src/Language.ml
View file

@ -51,6 +51,9 @@ module State =
(* Undefined state *)
let undefined x = failwith (Printf.sprintf "Undefined variable: %s" x)
(* Bind a variable to a value in a state *)
let bind x v s = fun y -> if x = y then v else s y
(* Empty state *)
let empty = G undefined
@ -58,11 +61,10 @@ module State =
to value v and returns the new state w.r.t. a scope
*)
let update x v s =
let u x v s = fun y -> if x = y then v else s y in
let rec inner = function
| G s -> G (u x v s)
| G s -> G (bind x v s)
| L (scope, s, enclosing) ->
if List.mem x scope then L (scope, u x v s, enclosing) else L (scope, s, inner enclosing)
if List.mem x scope then L (scope, bind x v s, enclosing) else L (scope, s, inner enclosing)
in
inner s
@ -111,6 +113,7 @@ module Builtin =
Some (match b with
| Value.String s -> Value.of_int @@ Char.code s.[i]
| Value.Array a -> List.nth a i
| Value.Sexp (_, a) -> List.nth a i
)
)
| ".length" -> (st, i, o, Some (Value.of_int (match List.hd args with Value.Array a -> List.length a | Value.String s -> String.length s)))
@ -266,11 +269,6 @@ module Stmt =
(* wildcard "-" *) | Wildcard
(* S-expression *) | Sexp of string * t list
(* identifier *) | Ident of string
(* constant *) | Const of int
(* string *) | String of string
(* array *) | Array of t list
(* arbitrary array *) | IsArray
(* arbitrary string *) | IsString
with show, foldl
(* Pattern parser *)
@ -279,16 +277,10 @@ module Stmt =
%"_" {Wildcard}
| "`" t:IDENT ps:(-"(" !(Util.list)[parse] -")")? {Sexp (t, match ps with None -> [] | Some ps -> ps)}
| x:IDENT {Ident x}
| n:DECIMAL {Const n}
| s:STRING {String s}
| a:(-"[" !(Util.list)[parse] -"]") {Array a}
| "#" "[" "]" {IsArray}
| "#" {IsString}
)
let vars p =
let module S = Set.Make (String) in
S.elements @@ transform(t) (object inherit [S.t] @t[foldl] method c_Ident s _ name = S.add name s end) S.empty p
transform(t) (object inherit [string list] @t[foldl] method c_Ident s _ name = name::s end) [] p
end
@ -300,7 +292,7 @@ module Stmt =
(* conditional *) | If of Expr.t * t * t
(* loop with a pre-condition *) | While of Expr.t * t
(* loop with a post-condition *) | Repeat of t * Expr.t
(* pattern-matching *) | Case of Expr.t * (Pattern.t * Expr.t option * t) list
(* pattern-matching *) | Case of Expr.t * (Pattern.t * t) list
(* return statement *) | Return of Expr.t option
(* call a procedure *) | Call of string * Expr.t list
(* leave a scope *) | Leave with show
@ -347,20 +339,15 @@ module Stmt =
let (_, _, _, Some v) as conf' = Expr.eval env conf e in
let rec branch ((st, i, o, _) as conf) = function
| [] -> failwith (Printf.sprintf "Pattern matching failed: no branch is selected while matching %s\n" (show(Value.t) v))
| (patt, con, body)::tl ->
| (patt, body)::tl ->
let rec match_patt patt v st =
let update x v = function
| None -> None
| Some s -> Some (fun y -> if y = x then v else s y)
| Some s -> Some (State.bind x v s)
in
match patt, v with
| Pattern.Ident x , v -> update x v st
| Pattern.Wildcard , _ -> st
| Pattern.Const n , Value.Int n' when n = n' -> st
| Pattern.String s , Value.String s' when s = s' -> st
| Pattern.Array p , Value.Array p' -> match_list p p' st
| Pattern.IsArray , Value.Array _ -> st
| Pattern.IsString , Value.String _ -> st
| Pattern.Sexp (t, ps), Value.Sexp (t', vs) when t = t' -> match_list ps vs st
| _ -> None
and match_list ps vs s =
@ -371,16 +358,7 @@ module Stmt =
in
match match_patt patt v (Some State.undefined) with
| None -> branch conf tl
| Some st' ->
let st'' = State.push st st' (Pattern.vars patt) in
let (st''', i', o', Some c) =
match con with
| None -> (st'', i, o, Some (Value.of_int 1))
| Some c -> Expr.eval env (st'', i, o, None) c
in
if Value.to_int c <> 0
then eval env (st''', i', o', None) k (Seq (body, Leave))
else branch (st''', i', o', None) tl
| Some st' -> eval env (State.push st st' (Pattern.vars patt), i, o, None) k (Seq (body, Leave))
in
branch conf' bs
@ -409,7 +387,7 @@ module Stmt =
}
| %"repeat" s:parse %"until" e:!(Expr.parse) {Repeat (s, e)}
| %"return" e:!(Expr.parse)? {Return e}
| %"case" e:!(Expr.parse) %"of" bs:!(Util.listBy)[ostap ("|")][ostap (!(Pattern.parse) (-"when" !(Expr.parse))? -"->" parse)] %"esac" {Case (e, bs)}
| %"case" e:!(Expr.parse) %"of" bs:!(Util.listBy)[ostap ("|")][ostap (!(Pattern.parse) -"->" parse)] %"esac" {Case (e, bs)}
| x:IDENT
s:(is:(-"[" !(Expr.parse) -"]")* ":=" e :!(Expr.parse) {Assign (x, is, e)} |
"(" args:!(Util.list0)[Expr.parse] ")" {Call (x, args)}

15
src/Makefile
View file

@ -1,12 +1,11 @@
TOPFILE = rc
OCAMLC = ocamlc
OCAMLOPT = ocamlopt
OCAMLDEP = ocamldep
OCAMLC = ocamlfind c
OCAMLOPT = ocamlfind opt
OCAMLDEP = ocamlfind dep
SOURCES = Language.ml SM.ml X86.ml Driver.ml
LIBS = GT.cma unix.cma re.cma emacs/re_emacs.cma str/re_str.cma
CAMLP5 = -pp "camlp5o -I `ocamlfind -query GT.syntax` -I `ocamlfind -query ostap.syntax` pa_ostap.cmo pa_gt.cmo -L `ocamlfind -query GT.syntax`"
CAMLP5 = -syntax camlp5o -package ostap.syntax,GT.syntax.all
PXFLAGS = $(CAMLP5)
BFLAGS = -rectypes -I `ocamlfind -query GT` -I `ocamlfind -query re` -I `ocamlfind -query ostap`
BFLAGS = -rectypes
OFLAGS = $(BFLAGS)
all: .depend $(TOPFILE).opt
@ -15,10 +14,10 @@ all: .depend $(TOPFILE).opt
$(OCAMLDEP) $(PXFLAGS) *.ml > .depend
$(TOPFILE).opt: $(SOURCES:.ml=.cmx)
$(OCAMLOPT) -o $(TOPFILE).opt $(OFLAGS) $(LIBS:.cma=.cmxa) ostap.cmx $(SOURCES:.ml=.cmx)
$(OCAMLOPT) -o $(TOPFILE).opt $(OFLAGS) $(LIBS:.cma=.cmxa) -linkpkg -package ostap $(SOURCES:.ml=.cmx)
$(TOPFILE).byte: $(SOURCES:.ml=.cmo)
$(OCAMLC) -o $(TOPFILE).byte $(BFLAGS) $(LIBS) ostap.cma $(SOURCES:.ml=.cmo)
$(OCAMLC) -o $(TOPFILE).byte $(BFLAGS) $(LIBS) -linkpkg -package ostap $(SOURCES:.ml=.cmo)
clean:
rm -Rf *.cmi *.cmo *.cmx *.annot *.o *.opt *.byte *~ .depend

88
src/SM.ml
View file

@ -17,7 +17,13 @@ open Language
(* end procedure definition *) | END
(* calls a function/procedure *) | CALL of string * int * bool
(* returns from a function *) | RET of bool
| DROP | DUP | OVER with show
(* drops the top element off *) | DROP
(* duplicates the top element *) | DUP
(* swaps two top elements *) | SWAP
(* checks the tag of S-expression *) | TAG of string
(* enters a scope *) | ENTER of string list
(* leaves a scope *) | LEAVE
with show
(* The type for the stack machine program *)
type prg = insn list
@ -69,6 +75,17 @@ let rec eval env ((cstack, stack, ((st, i, o) as c)) as conf) = function
| (prg', st')::cstack' -> eval env (cstack', stack, (State.leave st st', i, o)) prg'
| [] -> conf
)
| DROP -> eval env (cstack, List.tl stack, c) prg'
| DUP -> eval env (cstack, List.hd stack :: stack, c) prg'
| SWAP -> let x::y::stack' = stack in
eval env (cstack, y::x::stack', c) prg'
| TAG t -> let x::stack' = stack in
eval env (cstack, (Value.of_int @@ match x with Value.Sexp (t', _) when t' = t -> 1 | _ -> 0) :: stack', c) prg'
| ENTER xs -> let vs, stack' = split (List.length xs) stack in
eval env (cstack, stack', (State.push st (List.fold_left (fun s (x, v) -> State.bind x v s) State.undefined (List.combine xs vs)) xs, i, o)) prg'
| LEAVE -> eval env (cstack, stack, (State.drop st, i, o)) prg'
)
(* Top-level evaluation
@ -117,25 +134,29 @@ let compile (defs, p) =
let rec call f args p =
let args_code = List.concat @@ List.map expr args in
args_code @ [CALL (label f, List.length args, p)]
and pattern = function
| Stmt.Pattern.Wildcard -> [DROP; CONST 1]
| Stmt.Pattern.Const n -> [CONST n; BINOP "=="]
| Stmt.Pattern.String s -> [STRING s; CALL ("strcmp", 2, false)]
| Stmt.Pattern.Ident n -> [DROP; CONST 1]
| Stmt.Pattern.Array ps -> [DUP;
CALL ("isArray", 1, false);
OVER;
CALL (".length", 1, false);
CONST (List.length ps);
BINOP "==";
BINOP "&&";
]
| Stmt.Pattern.IsArray -> [CALL ("isArray", 1, false)]
| Stmt.Pattern.IsString -> [CALL ("isString", 1, false)]
| Stmt.Pattern.Sexp (t, ps) -> []
and patterns = function
| [] -> []
| (e, p)::ps -> expr e @ pattern p @ [BINOP "&&"] @ patterns ps
and pattern lfalse = function
| Stmt.Pattern.Wildcard -> false, [DROP]
| Stmt.Pattern.Ident n -> false, [DROP]
| Stmt.Pattern.Sexp (t, ps) ->
true,
[DUP; TAG t; CJMP ("z", lfalse)] @
(List.concat @@
List.mapi
(fun i p ->
[DUP; CONST i; CALL (".elem", 2, false)] @
snd @@ pattern lfalse p
)
ps
)
and bindings p =
let rec inner = function
| Stmt.Pattern.Ident n -> [SWAP]
| Stmt.Pattern.Wildcard -> [DROP]
| Stmt.Pattern.Sexp (_, ps) ->
(List.flatten @@ List.mapi (fun i p -> [DUP; CONST i; CALL (".elem", 2, false)] @ inner p) ps) @
[DROP]
in
inner p @ [ENTER (Stmt.Pattern.vars p)]
and expr = function
| Expr.Var x -> [LD x]
| Expr.Const n -> [CONST n]
@ -143,7 +164,7 @@ let compile (defs, p) =
| Expr.Binop (op, x, y) -> expr x @ expr y @ [BINOP op]
| Expr.Call (f, args) -> call f args false
| Expr.Array xs -> List.flatten (List.map expr xs) @ [CALL (".array", List.length xs, false)]
| Expr.Sexp (t, xs) -> List.flatten (List.map expr xs) @ [CALL (".array", List.length xs, false)]
| Expr.Sexp (t, xs) -> List.flatten (List.map expr xs) @ [SEXP (t, List.length xs)]
| Expr.Elem (a, i) -> expr a @ expr i @ [CALL (".elem", 2, false)]
| Expr.Length e -> expr e @ [CALL (".length", 1, false)]
in
@ -175,6 +196,31 @@ let compile (defs, p) =
| Stmt.Call (f, args) -> env, false, call f args true
| Stmt.Return e -> env, false, (match e with Some e -> expr e | None -> []) @ [RET (e <> None)]
| Stmt.Leave -> env, false, [LEAVE]
| Stmt.Case (e, [p, s]) ->
let pflag, pcode = pattern l p in
let env, sflag, scode = compile_stmt l env (Stmt.Seq (s, Stmt.Leave)) in
env, pflag || sflag, expr e @ pcode @ bindings p @ scode
| Stmt.Case (e, brs) ->
let n = List.length brs - 1 in
let env, _, _, code =
List.fold_left
(fun (env, lab, i, code) (p, s) ->
let (lfalse, env), jmp =
if i = n
then (l, env), []
else env#get_label, [JMP l]
in
let _, pcode = pattern lfalse p in
let env, _, scode = compile_stmt l env (Stmt.Seq (s, Stmt.Leave)) in
(env, Some lfalse, i+1, ((match lab with None -> [] | Some l -> [LABEL l]) @ pcode @ bindings p @ scode @ jmp) :: code)
)
(env, None, 0, []) brs
in
env, true, expr e @ List.flatten @@ List.rev code
in
let compile_def env (name, (args, locals, stmt)) =
let lend, env = env#get_label in