mirror of
https://github.com/ProgramSnail/Lama.git
synced 2025-12-24 15:48:47 +00:00
Extended pattern-matching
This commit is contained in:
Dmitry Boulytchev
danyabeerzun
parent
99fdd176f4
commit
91f4bd6096
10 changed files with 253 additions and 45 deletions
91
src/SM.ml
91
src/SM.ml
|
|
@ -1,6 +1,9 @@
|
|||
open GT
|
||||
open Language
|
||||
|
||||
|
||||
(* The type for patters *)
|
||||
@type patt = StrCmp | String | Array | Sexp | Boxed | UnBoxed with show
|
||||
|
||||
(* The type for the stack machine instructions *)
|
||||
@type insn =
|
||||
(* binary operator *) | BINOP of string
|
||||
|
|
@ -21,6 +24,8 @@ open Language
|
|||
(* duplicates the top element *) | DUP
|
||||
(* swaps two top elements *) | SWAP
|
||||
(* 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
|
||||
(* enters a scope *) | ENTER of string list
|
||||
(* leaves a scope *) | LEAVE
|
||||
with show
|
||||
|
|
@ -28,7 +33,7 @@ with show
|
|||
(* The type for the stack machine program *)
|
||||
type prg = insn list
|
||||
|
||||
let print_prg p = List.iter (fun i -> Printf.printf "%s\n" (show(insn) i)) p
|
||||
let print_prg p = List.iter (fun i -> Printf.printf "%s\n\!" (show(insn) i)) p
|
||||
|
||||
(* The type for the stack machine configuration: control stack, stack and configuration from statement
|
||||
interpreter
|
||||
|
|
@ -81,10 +86,22 @@ let rec eval env ((cstack, stack, ((st, i, o) as c)) as conf) = function
|
|||
eval env (cstack, y::x::stack', c) prg'
|
||||
| TAG (t, n) -> let x::stack' = stack in
|
||||
eval env (cstack, (Value.of_int @@ match x with Value.Sexp (t', a) when t' = t && List.length a = n -> 1 | _ -> 0) :: stack', c) prg'
|
||||
|
||||
| ARRAY n -> let x::stack' = stack in
|
||||
eval env (cstack, (Value.of_int @@ match x with Value.Array a when List.length a = n -> 1 | _ -> 0) :: stack', c) prg'
|
||||
| PATT StrCmp -> let x::y::stack' = stack in
|
||||
eval env (cstack, (Value.of_int @@ match x, y with (Value.String xs, Value.String ys) when xs = ys -> 1 | _ -> 0) :: stack', c) prg'
|
||||
| PATT Array -> let x::stack' = stack in
|
||||
eval env (cstack, (Value.of_int @@ match x with Value.Array _ -> 1 | _ -> 0) :: stack', c) prg'
|
||||
| PATT String -> let x::stack' = stack in
|
||||
eval env (cstack, (Value.of_int @@ match x with Value.String _ -> 1 | _ -> 0) :: stack', c) prg'
|
||||
| PATT Sexp -> let x::stack' = stack in
|
||||
eval env (cstack, (Value.of_int @@ match x with Value.Sexp _ -> 1 | _ -> 0) :: stack', c) prg'
|
||||
| PATT Boxed -> let x::stack' = stack in
|
||||
eval env (cstack, (Value.of_int @@ match x with Value.Int _ -> 0 | _ -> 1) :: stack', c) prg'
|
||||
| PATT UnBoxed -> let x::stack' = stack in
|
||||
eval env (cstack, (Value.of_int @@ match x with Value.Int _ -> 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'
|
||||
)
|
||||
|
||||
|
|
@ -95,7 +112,7 @@ let rec eval env ((cstack, stack, ((st, i, o) as c)) as conf) = function
|
|||
Takes a program, an input stream, and returns an output stream this program calculates
|
||||
*)
|
||||
let run p i =
|
||||
(*print_prg p;*)
|
||||
(* print_prg p; *)
|
||||
let module M = Map.Make (String) in
|
||||
let rec make_map m = function
|
||||
| [] -> m
|
||||
|
|
@ -137,36 +154,52 @@ let compile (defs, p) =
|
|||
and pattern env lfalse = function
|
||||
| Stmt.Pattern.Wildcard -> env, false, [DROP]
|
||||
| Stmt.Pattern.Named (_, p) -> pattern env lfalse p
|
||||
| Stmt.Pattern.Sexp (t, ps) ->
|
||||
let ltag , env = env#get_label in
|
||||
| Stmt.Pattern.Const c -> env, true, [CONST c; BINOP "=="; CJMP ("z", lfalse)]
|
||||
| Stmt.Pattern.String s -> env, true, [STRING s; PATT StrCmp; CJMP ("z", lfalse)]
|
||||
| Stmt.Pattern.ArrayTag -> env, true, [PATT Array; CJMP ("z", lfalse)]
|
||||
| Stmt.Pattern.StringTag -> env, true, [PATT String; CJMP ("z", lfalse)]
|
||||
| Stmt.Pattern.SexpTag -> env, true, [PATT Sexp; CJMP ("z", lfalse)]
|
||||
| Stmt.Pattern.UnBoxed -> env, true, [PATT UnBoxed; CJMP ("z", lfalse)]
|
||||
| Stmt.Pattern.Boxed -> env, true, [PATT Boxed; CJMP ("z", lfalse)]
|
||||
| Stmt.Pattern.Array ps ->
|
||||
let lhead, env = env#get_label in
|
||||
let ldrop, env = env#get_label in
|
||||
let tag = [DUP; TAG (t, List.length ps); CJMP ("nz", ltag); LABEL ldrop; DROP; JMP lfalse; LABEL ltag] in
|
||||
let _, env, code =
|
||||
List.fold_left
|
||||
(fun (i, env, code) p ->
|
||||
let env, _, pcode = pattern env ldrop p in
|
||||
i+1, env, ([DUP; CONST i; CALL (".elem", 2, false)] @ pcode) :: code
|
||||
)
|
||||
(0, env, [])
|
||||
ps
|
||||
in
|
||||
env, true, tag @ List.flatten (List.rev code) @ [DROP]
|
||||
let tag = [DUP; ARRAY (List.length ps); CJMP ("nz", lhead); LABEL ldrop; DROP; JMP lfalse; LABEL lhead] in
|
||||
let code, env = pattern_list lhead ldrop env ps in
|
||||
env, true, tag @ code @ [DROP]
|
||||
| Stmt.Pattern.Sexp (t, ps) ->
|
||||
let lhead, env = env#get_label in
|
||||
let ldrop, env = env#get_label in
|
||||
let tag = [DUP; TAG (t, List.length ps); CJMP ("nz", lhead); LABEL ldrop; DROP; JMP lfalse; LABEL lhead] in
|
||||
let code, env = pattern_list lhead ldrop env ps in
|
||||
env, true, tag @ code @ [DROP]
|
||||
and pattern_list lhead ldrop env ps =
|
||||
let _, env, code =
|
||||
List.fold_left
|
||||
(fun (i, env, code) p ->
|
||||
let env, _, pcode = pattern env ldrop p in
|
||||
i+1, env, ([DUP; CONST i; CALL (".elem", 2, false)] @ pcode) :: code
|
||||
)
|
||||
(0, env, [])
|
||||
ps
|
||||
in
|
||||
List.flatten (List.rev code), env
|
||||
and bindings p =
|
||||
let bindings =
|
||||
fix0 (fun fself ->
|
||||
transform(Stmt.Pattern.t)
|
||||
(object inherit [int list, (string * int list) list, _] @Stmt.Pattern.t
|
||||
method c_Wildcard path = []
|
||||
method c_Named path s p = [s, path] @ fself path p
|
||||
method c_Sexp path x ps = List.concat @@ List.mapi (fun i p -> fself (path @ [i]) p) ps
|
||||
method c_UnBoxed = invalid_arg ""
|
||||
method c_StringTag = invalid_arg ""
|
||||
method c_String = invalid_arg ""
|
||||
method c_SexpTag = invalid_arg ""
|
||||
method c_Const = invalid_arg ""
|
||||
method c_Boxed = invalid_arg ""
|
||||
method c_ArrayTag = invalid_arg ""
|
||||
method c_Array = invalid_arg ""
|
||||
method c_Wildcard path = []
|
||||
method c_Named path s p = [s, path] @ fself path p
|
||||
method c_Sexp path x ps = List.concat @@ List.mapi (fun i p -> fself (path @ [i]) p) ps
|
||||
method c_UnBoxed _ = []
|
||||
method c_StringTag _ = []
|
||||
method c_String _ _ = []
|
||||
method c_SexpTag _ = []
|
||||
method c_Const _ _ = []
|
||||
method c_Boxed _ = []
|
||||
method c_ArrayTag _ = []
|
||||
method c_Array path ps = List.concat @@ List.mapi (fun i p -> fself (path @ [i]) p) ps
|
||||
end))
|
||||
[]
|
||||
p
|
||||
|
|
|
|||
Loading…
Add table
Add a link
Reference in a new issue