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

'as' pattern

Browse source
This commit is contained in:
Dmitry Boulytchev 2018-11-05 18:21:41 +03:00
parent be89ee983a
commit 8a4874797b
8 changed files with 89 additions and 31 deletions
Download patch file Download diff file Expand all files Collapse all files

6
regression/Makefile
View file

@ -7,9 +7,9 @@ RC=../src/rc.opt
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
$(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
clean:
rm -f test*.log *.s *~ $(TESTS)

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

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

21
regression/test046.expr Normal file
View file

@ -0,0 +1,21 @@
n := read ();
case 3 of
a -> write (a)
| _ -> write (0)
esac;
case 3 of
a -> write (a)
esac;
case 3 of
a@_ -> write (a)
esac;
case `a (1, 2, 3) of
`b -> write (1)
| a@`a (_, _, _) -> case a of
`a (x, y, z) -> write (x); write (y); write (z)
esac
esac

1
regression/test046.input Normal file
View file

@ -0,0 +1 @@
0

3
src/Driver.ml
View file

@ -16,7 +16,8 @@ let parse infile =
"fun"; "local"; "return";
"length";
"string";
"case"; "of"; "esac"; "when"] s
"case"; "of"; "esac"; "when";
"boxed"; "unboxed"; "string"; "sexp"; "array"] s
inherit Util.Lexers.skip [
Matcher.Skip.whitespaces " \t\n";
Matcher.Skip.lineComment "--";

24
src/Language.ml
View file

@ -293,7 +293,15 @@ module Stmt =
@type t =
(* wildcard "-" *) | Wildcard
(* S-expression *) | Sexp of string * t list
(* identifier *) | Ident of string
(* array *) | Array of t list
(* identifier *) | Named of string * t
(* ground integer *) | Const of int
(* ground string *) | String of string
(* boxed value *) | Boxed
(* unboxed value *) | UnBoxed
(* any string value *) | StringTag
(* any sexp value *) | SexpTag
(* any array value *) | ArrayTag
with show, foldl
(* Pattern parser *)
@ -301,11 +309,19 @@ module Stmt =
parse:
%"_" {Wildcard}
| "`" t:IDENT ps:(-"(" !(Util.list)[parse] -")")? {Sexp (t, match ps with None -> [] | Some ps -> ps)}
| x:IDENT {Ident x}
| "[" ps:(!(Util.list0)[parse]) "]" {Array ps}
| x:IDENT y:(-"@" parse)? {match y with None -> Named (x, Wildcard) | Some y -> Named (x, y)}
| c:DECIMAL {Const c}
| s:STRING {String s}
| "#" %"boxed" {Boxed}
| "#" %"unboxed" {UnBoxed}
| "#" %"string" {StringTag}
| "#" %"sexp" {SexpTag}
| "#" %"array" {ArrayTag}
)
let vars p = fix0 (fun f ->
transform(t) (object inherit [string list, _] @t[foldl] f method c_Ident s name = name::s end)) [] p
transform(t) (object inherit [string list, _] @t[foldl] f method c_Named s name p = name :: f s p end)) [] p
end
@ -371,7 +387,7 @@ module Stmt =
| Some s -> Some (State.bind x v s)
in
match patt, v with
| Pattern.Ident x , v -> update x v st
| Pattern.Named (x, p), v -> update x v (match_patt p v st )
| Pattern.Wildcard , _ -> st
| Pattern.Sexp (t, ps), Value.Sexp (t', vs) when t = t' -> match_list ps vs st
| _ -> None

38
src/SM.ml
View file

@ -136,7 +136,7 @@ let compile (defs, p) =
args_code @ [CALL (label f, List.length args, p)]
and pattern env lfalse = function
| Stmt.Pattern.Wildcard -> env, false, [DROP]
| Stmt.Pattern.Ident n -> env, false, [DROP]
| Stmt.Pattern.Named (_, p) -> pattern env lfalse p
| Stmt.Pattern.Sexp (t, ps) ->
let ltag , env = env#get_label in
let ldrop, env = env#get_label in
@ -157,8 +157,16 @@ let compile (defs, p) =
transform(Stmt.Pattern.t)
(object inherit [int list, (string * int list) list, _] @Stmt.Pattern.t
method c_Wildcard path = []
method c_Ident path s = [s, 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 ""
end))
[]
p
@ -218,28 +226,32 @@ let compile (defs, p) =
| Stmt.Case (e, [p, s]) ->
let ldrop, env = env#get_label in
let env, _, pcode = pattern env ldrop p in
let env, _, scode = compile_stmt ldrop env (Stmt.Seq (s, Stmt.Leave)) in
env, true, expr e @ [DUP] @ pcode @ bindings p @ scode @ [JMP l; LABEL ldrop; DROP]
let env, ldrop' , pcode = pattern env ldrop p in
let env, ldrop'', scode = compile_stmt ldrop env (Stmt.Seq (s, Stmt.Leave)) in
if ldrop' || ldrop''
then env, true , expr e @ [DUP] @ pcode @ bindings p @ scode @ [JMP l; LABEL ldrop; DROP]
else env, false, expr e @ [DUP] @ pcode @ bindings p @ scode
| Stmt.Case (e, brs) ->
let n = List.length brs - 1 in
(*let ldrop, env = env#get_label in*)
let env, _, _, code =
let env, _, _, code, _ =
List.fold_left
(fun (env, lab, i, code) (p, s) ->
(fun ((env, lab, i, code, continue) as acc) (p, s) ->
if continue
then
let (lfalse, env), jmp =
if i = n
then (l, env), []
else env#get_label, [JMP l]
in
let env, _, pcode = pattern env lfalse p in
let env, _, scode = compile_stmt l(*ldrop*) env (Stmt.Seq (s, Stmt.Leave)) in
(env, Some lfalse, i+1, ((match lab with None -> [] | Some l -> [LABEL l; DUP]) @ pcode @ bindings p @ scode @ jmp) :: code)
let env, lfalse', pcode = pattern env lfalse p in
let env, l' , scode = compile_stmt l env (Stmt.Seq (s, Stmt.Leave)) in
(env, Some lfalse, i+1, ((match lab with None -> [] | Some l -> [LABEL l; DUP]) @ pcode @ bindings p @ scode @ jmp) :: code, lfalse')
else acc
)
(env, None, 0, []) brs
(env, None, 0, [], true) brs
in
env, true, expr e @ [DUP] @ (List.flatten @@ List.rev code) @ [JMP l] (*; LABEL ldrop; DROP]*)
env, true, expr e @ [DUP] @ (List.flatten @@ List.rev code) @ [JMP l]
in
let compile_def env (name, (args, locals, stmt)) =
let lend, env = env#get_label in

3
src/X86.ml
View file

@ -310,7 +310,8 @@ let compile env code =
let env, code = call env ".sexp" (n+1) false in
env, [Mov (L env#hash t, s)] @ code
| DROP -> snd env#pop, []
| DROP ->
snd env#pop, []
| DUP ->
let x = env#peek in