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

Extended pattern-matching

Browse source
This commit is contained in:
Dmitry Boulytchev 2018-11-06 00:21:38 +03:00 • committed by danyabeerzun
parent 99fdd176f4
commit 91f4bd6096
10 changed files with 253 additions and 45 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
View file

@ -5,3 +5,9 @@
2
3
5
5
1
2
3
4
5

17
regression/orig/test047.log Normal file
View file

@ -0,0 +1,17 @@
> 1
1
1
1
1
2
3
100
3
2
1
6
5
4
3
2
1

10
regression/test046.expr
View file

@ -27,4 +27,12 @@ case `a (1, 2, 3, 4, 5) of
| `a (_, _, _) -> write (3)
| `a (_, _, _, _) -> write (4)
| `a (_, _, _, _, _) -> write (5)
esac
esac;
write (`a (1, 2, 3, 4, 5).length);
write (`a (1, 2, 3, 4, 5)[0]);
write (`a (1, 2, 3, 4, 5)[1]);
write (`a (1, 2, 3, 4, 5)[2]);
write (`a (1, 2, 3, 4, 5)[3]);
write (`a (1, 2, 3, 4, 5)[4])

72
regression/test047.expr Normal file
View file

@ -0,0 +1,72 @@
fun collect_ints_acc (v, tail) local i {
case v of
a@#unboxed -> return `cons (a, tail)
| #string -> return tail
| _ ->
for i := 0, i < v.length, i := i + 1 do
tail := collect_ints_acc (v[i], tail)
od;
return tail
esac
}
fun collect_ints (v) {
return collect_ints_acc (v, `nil)
}
fun print_list (l) {
case l of
`nil -> skip
| `cons (n, t) -> write (n); print_list (t)
esac
}
n := read ();
case 1 of
5 -> write (5)
| 4 -> write (4)
| 3 -> write (3)
| 2 -> write (2)
| 1 -> write (1)
| 0 -> write (0)
esac;
case 1 of
a@5 -> write (a)
| a@4 -> write (a)
| a@3 -> write (a)
| a@2 -> write (a)
| a@1 -> write (a)
| a@0 -> write (a)
esac;
case `a (1, 2, 3) of
`a (1, 3, 5) -> write (0)
| `a (3, 4, 5) -> write (0)
| `a (1, 2, 3) -> write (1)
| `a (6, 7, 8) -> write (0)
esac;
case "abc" of
"def" -> write (0)
| "ab" -> write (0)
| "abc" -> write (1)
| "" -> write (0)
esac;
case [1, 2, 3] of
[] -> write (0)
| [a, b] -> write (0)
| [a, b, c] -> write (a); write (b); write (c)
| [_, _, _] -> write (0)
esac;
case [1, 2, 3] of
[] -> write (0)
| [a, b] -> write (0)
| [_, _, _] -> write (100)
| [a, b, c] -> write (a); write (b); write (c)
esac;
print_list (collect_ints ([1, 2, 3, [4, 5, 6, `cons (1, 2, 3)]]))

1
regression/test047.input Normal file
View file

@ -0,0 +1 @@
0

45
runtime/runtime.c
View file

@ -223,6 +223,51 @@ extern int Btag (void *d, int t, int n) {
return BOX(TAG(r->tag) == SEXP_TAG && TO_SEXP(d)->tag == t && LEN(r->tag) == n);
}
extern int Barray_patt (void *d, int n) {
if (UNBOXED(d)) return BOX(0);
else {
data *r = TO_DATA(d);
return BOX(TAG(r->tag) == ARRAY_TAG && LEN(r->tag) == n);
}
}
extern int Bstring_patt (void *x, void *y) {
if (UNBOXED(x)) return BOX(0);
else {
data *rx = TO_DATA(x), *ry = TO_DATA(y);
if (TAG(rx->tag) != STRING_TAG) return BOX(0);
return BOX(strcmp (rx->contents, ry->contents) == 0 ? 1 : 0);
}
}
extern int Bboxed_patt (void *x) {
return BOX(UNBOXED(x) ? 0 : 1);
}
extern int Bunboxed_patt (void *x) {
return BOX(UNBOXED(x) ? 1 : 0);
}
extern int Barray_tag_patt (void *x) {
if (UNBOXED(x)) return BOX(0);
return BOX(TAG(TO_DATA(x)->tag) == ARRAY_TAG);
}
extern int Bstring_tag_patt (void *x) {
if (UNBOXED(x)) return BOX(0);
return BOX(TAG(TO_DATA(x)->tag) == STRING_TAG);
}
extern int Bsexp_tag_patt (void *x) {
if (UNBOXED(x)) return BOX(0);
return BOX(TAG(TO_DATA(x)->tag) == SEXP_TAG);
}
extern void Bsta (int n, int v, void *s, ...) {
va_list args;
int i, k;

17
src/Language.ml
View file

@ -133,8 +133,6 @@ module Builtin =
| ".length" -> (st, i, o, Some (Value.of_int (match List.hd args with Value.Sexp (_, a) | Value.Array a -> List.length a | Value.String s -> String.length s)))
| ".array" -> (st, i, o, Some (Value.of_array args))
| ".stringval" -> let [a] = args in (st, i, o, Some (Value.of_string @@ Value.string_val a))
| "isArray" -> let [a] = args in (st, i, o, Some (Value.of_int @@ match a with Value.Array _ -> 1 | _ -> 0))
| "isString" -> let [a] = args in (st, i, o, Some (Value.of_int @@ match a with Value.String _ -> 1 | _ -> 0))
end
@ -312,7 +310,8 @@ module Stmt =
| "[" 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}
| s:STRING {String (String.sub s 1 (String.length s - 2))}
| c:CHAR {Const (Char.code c)}
| "#" %"boxed" {Boxed}
| "#" %"unboxed" {UnBoxed}
| "#" %"string" {StringTag}
@ -389,7 +388,17 @@ module Stmt =
match patt, v with
| 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
| Pattern.Sexp (t, ps), Value.Sexp (t', vs) when t = t' && List.length ps = List.length vs -> match_list ps vs st
| Pattern.Array ps , Value.Array vs when List.length ps = List.length vs -> match_list ps vs st
| Pattern.Const n , Value.Int n' when n = n' -> st
| Pattern.String s , Value.String s' when s = s' -> st
| Pattern.Boxed , Value.String _
| Pattern.Boxed , Value.Array _
| Pattern.UnBoxed , Value.Int _
| Pattern.Boxed , Value.Sexp (_, _)
| Pattern.StringTag , Value.String _
| Pattern.ArrayTag , Value.Array _
| Pattern.SexpTag , Value.Sexp (_, _) -> st
| _ -> None
and match_list ps vs s =
match ps, vs with

63
src/SM.ml
View file

@ -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'
)
@ -137,10 +154,26 @@ 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 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 ->
@ -150,7 +183,7 @@ let compile (defs, p) =
(0, env, [])
ps
in
env, true, tag @ List.flatten (List.rev code) @ [DROP]
List.flatten (List.rev code), env
and bindings p =
let bindings =
fix0 (fun fself ->
@ -159,14 +192,14 @@ let compile (defs, p) =
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_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

17
src/X86.ml
View file

@ -328,6 +328,23 @@ let compile env code =
let env, code = call env ".tag" 3 false in
env, [Mov (L env#hash t, s1); Mov (L n, s2)] @ code
| ARRAY n ->
let s, env = env#allocate in
let env, code = call env ".array_patt" 2 false in
env, [Mov (L n, s)] @ code
| PATT StrCmp -> call env ".string_patt" 2 false
| PATT patt ->
call env
(match patt with
| Boxed -> ".boxed_patt"
| UnBoxed -> ".unboxed_patt"
| Array -> ".array_tag_patt"
| String -> ".string_tag_patt"
| Sexp -> ".sexp_tag_patt"
) 1 false
| ENTER xs ->
let env, code =
List.fold_left