mirror of
https://github.com/ProgramSnail/Lama.git
synced 2025-12-06 06:48:48 +00:00
Reach pattern-matching.
This commit is contained in:
Dmitry Boulytchev
parent
40afee26cc
commit
de17bdc3c4
6 changed files with 132 additions and 16 deletions
|
|
@ -7,9 +7,9 @@ RC=../src/rc.opt
|
|||
check: $(TESTS)
|
||||
|
||||
$(TESTS): %: %.expr
|
||||
@$(RC) $< && cat $@.input | ./$@ > $@.log && diff $@.log orig/$@.log
|
||||
#@$(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)
|
||||
|
|
|
|||
12
regression/orig/test038.log
Normal file
12
regression/orig/test038.log
Normal file
|
|
@ -0,0 +1,12 @@
|
|||
> 1
|
||||
2
|
||||
3
|
||||
4
|
||||
1
|
||||
2
|
||||
3
|
||||
4
|
||||
3
|
||||
4
|
||||
1
|
||||
2
|
||||
24
regression/test038.expr
Normal file
24
regression/test038.expr
Normal file
|
|
@ -0,0 +1,24 @@
|
|||
fun append (x, y) {
|
||||
case x of
|
||||
`nil -> return y
|
||||
| `cons (h, t) -> return `cons (h, append (t, y))
|
||||
esac
|
||||
}
|
||||
|
||||
fun printList (x) {
|
||||
case x of
|
||||
`nil -> skip
|
||||
| `cons (h, t) -> write (h); printList (t)
|
||||
esac
|
||||
}
|
||||
|
||||
n := read ();
|
||||
|
||||
x := `cons (1, `cons (2, `nil));
|
||||
y := `cons (3, `cons (4, `nil));
|
||||
|
||||
printList (x);
|
||||
printList (y);
|
||||
printList (append (x, y));
|
||||
printList (append (y, x))
|
||||
|
||||
1
regression/test038.input
Normal file
1
regression/test038.input
Normal file
|
|
@ -0,0 +1 @@
|
|||
0
|
||||
|
|
@ -73,16 +73,29 @@ module State =
|
|||
| L (scope, s, enclosing) -> if List.mem x scope then s x else eval enclosing x
|
||||
|
||||
(* Creates a new scope, based on a given state *)
|
||||
let enter st xs =
|
||||
let rec enter st xs =
|
||||
match st with
|
||||
| G _ -> L (xs, undefined, st)
|
||||
| L (_, _, e) -> L (xs, undefined, e)
|
||||
| L (_, _, e) -> enter e xs
|
||||
|
||||
(* Drops a scope *)
|
||||
let leave (L (_, _, e)) st' =
|
||||
match st' with
|
||||
| L (scope, s, _) -> L (scope, s, e)
|
||||
| G _ -> e
|
||||
let leave st st' =
|
||||
let rec get = function
|
||||
| G _ as st -> st
|
||||
| L (_, _, e) -> get e
|
||||
in
|
||||
let g = get st in
|
||||
let rec recurse = function
|
||||
| L (scope, s, e) -> L (scope, s, recurse e)
|
||||
| G _ -> g
|
||||
in
|
||||
recurse st'
|
||||
|
||||
(* Push a new local scope *)
|
||||
let push st s xs = L (xs, s, st)
|
||||
|
||||
(* Drop a local scope *)
|
||||
let drop (L (_, _, e)) = e
|
||||
|
||||
end
|
||||
|
||||
|
|
@ -258,7 +271,7 @@ module Stmt =
|
|||
(* array *) | Array of t list
|
||||
(* arbitrary array *) | IsArray
|
||||
(* arbitrary string *) | IsString
|
||||
with show
|
||||
with show, foldl
|
||||
|
||||
(* Pattern parser *)
|
||||
ostap (
|
||||
|
|
@ -273,6 +286,10 @@ module Stmt =
|
|||
| "#" {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
|
||||
|
||||
end
|
||||
|
||||
(* The type for statements *)
|
||||
|
|
@ -285,7 +302,8 @@ module Stmt =
|
|||
(* loop with a post-condition *) | Repeat of t * Expr.t
|
||||
(* pattern-matching *) | Case of Expr.t * (Pattern.t * Expr.t option * t) list
|
||||
(* return statement *) | Return of Expr.t option
|
||||
(* call a procedure *) | Call of string * Expr.t list with show
|
||||
(* call a procedure *) | Call of string * Expr.t list
|
||||
(* leave a scope *) | Leave with show
|
||||
|
||||
(* Statement evaluator
|
||||
|
||||
|
|
@ -309,7 +327,8 @@ module Stmt =
|
|||
let rec eval env ((st, i, o, r) as conf) k stmt =
|
||||
let seq x = function Skip -> x | y -> Seq (x, y) in
|
||||
match stmt with
|
||||
| Assign (x, is, e) ->
|
||||
| Leave -> eval env (State.drop st, i, o, r) Skip k
|
||||
| Assign (x, is, e) ->
|
||||
let (st, i, o, is) = Expr.eval_list env conf is in
|
||||
let (st, i, o, Some v) = Expr.eval env (st, i, o, None) e in
|
||||
eval env (update st x v is, i, o, None) Skip k
|
||||
|
|
@ -324,6 +343,46 @@ module Stmt =
|
|||
| Repeat (s, e) -> eval env conf (seq (While (Expr.Binop ("==", e, Expr.Const 0), s)) k) s
|
||||
| Return e -> (match e with None -> (st, i, o, None) | Some e -> Expr.eval env conf e)
|
||||
| Call (f, args) -> eval env (Expr.eval env conf (Expr.Call (f, args))) k Skip
|
||||
| Case (e, bs) ->
|
||||
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 ->
|
||||
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)
|
||||
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 =
|
||||
match ps, vs with
|
||||
| [], [] -> s
|
||||
| p::ps, v::vs -> match_list ps vs (match_patt p v s)
|
||||
| _ -> None
|
||||
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
|
||||
in
|
||||
branch conf' bs
|
||||
|
||||
(* Statement parser *)
|
||||
ostap (
|
||||
|
|
@ -350,7 +409,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) (-"when" !(Expr.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)}
|
||||
|
|
|
|||
22
src/SM.ml
22
src/SM.ml
|
|
@ -16,7 +16,8 @@ open Language
|
|||
(* begins procedure definition *) | BEGIN of string * string list * string list
|
||||
(* end procedure definition *) | END
|
||||
(* calls a function/procedure *) | CALL of string * int * bool
|
||||
(* returns from a function *) | RET of bool with show
|
||||
(* returns from a function *) | RET of bool
|
||||
| DROP | DUP | OVER with show
|
||||
|
||||
(* The type for the stack machine program *)
|
||||
type prg = insn list
|
||||
|
|
@ -116,6 +117,25 @@ 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 expr = function
|
||||
| Expr.Var x -> [LD x]
|
||||
| Expr.Const n -> [CONST n]
|
||||
|
|
|
|||
Loading…
Add table
Add a link
Reference in a new issue