st/lama_byterun
1
0
Fork 0
mirror of https://github.com/ProgramSnail/Lama.git synced 2025-12-06 14:58:50 +00:00
Code Issues Projects Releases Packages Wiki Activity Actions

Closure-pattern, infix references (interpretataion only)

Browse source
This commit is contained in:
Dmitry Boulytchev 2019-09-25 00:25:40 +03:00
parent c92555f7a8
commit efea4901ef
8 changed files with 57 additions and 18 deletions
Download patch file Download diff file Expand all files Collapse all files

4
regression/orig/test062.log Normal file
View file

@ -0,0 +1,4 @@
> 5
7
12
-2

1
regression/orig/test064.log Normal file
View file

@ -0,0 +1 @@
> 5

20
regression/test062.expr Normal file
View file

@ -0,0 +1,20 @@
fun a (x, y) {
local a = x + y, b = x - y;
{
local f = fun () {
write (x);
write (y);
write (a);
write (b)
};
a := 100;
b := 200;
x := 800;
y := 1000;
return f
}
}
a (5, 7) ()

1
regression/test062.input Normal file
View file

@ -0,0 +1 @@
5

3
regression/test064.expr Normal file
View file

@ -0,0 +1,3 @@
infixr "++" at "+" (a, b) {return a+b}
write (infix "++" (2, 3))

1
regression/test064.input Normal file
View file

@ -0,0 +1 @@
5

22
src/Language.ml
View file

@ -223,6 +223,7 @@ module Pattern =
(* any string value *) | StringTag
(* any sexp value *) | SexpTag
(* any array value *) | ArrayTag
(* any closure *) | ClosureTag
with show, foldl
(* Pattern parser *)
@ -253,6 +254,7 @@ module Pattern =
| "#" %"string" {StringTag}
| "#" %"sexp" {SexpTag}
| "#" %"array" {ArrayTag}
| "#" %"fun" {ClosureTag}
| -"(" parse -")"
)
@ -295,6 +297,7 @@ module Expr =
(* ignore a value *) | Ignore of t
(* unit value *) | Unit
(* entering the scope *) | Scope of [`Global | `Local] * (string * [`Fun of string list * t | `Variable of t option]) list * t
(* lambda expression *) | Lambda of string list * t
(* leave a scope *) | Leave
(* intrinsic (for evaluation) *) | Intrinsic of (t config -> t config)
(* control (for control flow) *) | Control of (t config -> t * t config)
@ -358,6 +361,12 @@ module Expr =
let seq x = function Skip -> x | y -> Seq (x, y)
let infix_name infix =
let b = Buffer.create 64 in
Buffer.add_string b "__Infix_";
Seq.iter (fun c -> Buffer.add_string b (string_of_int @@ Char.code c)) @@ String.to_seq infix;
Buffer.contents b
let schedule_list h::tl =
List.fold_left seq h tl
@ -372,6 +381,8 @@ module Expr =
Printf.eprintf "End Values\n%!"
in
match expr with
| Lambda (args, body) ->
eval env (st, i, o, Value.Closure (args, body, st) ::vs) Skip k
| Scope (kind, defs, body) ->
let vars, body, bnds =
List.fold_left
@ -470,6 +481,7 @@ module Expr =
| Pattern.Boxed , Value.Sexp (_, _)
| Pattern.StringTag , Value.String _
| Pattern.ArrayTag , Value.Array _
| Pattern.ClosureTag , Value.Closure _
| Pattern.SexpTag , Value.Sexp (_, _) -> st
| _ -> None
and match_list ps vs s =
@ -627,6 +639,8 @@ module Expr =
n:DECIMAL => {notRef atr} => {ignore atr (Const n)}
| s:STRING => {notRef atr} => {ignore atr (String (unquote s))}
| c:CHAR => {notRef atr} => {ignore atr (Const (Char.code c))}
| %"infix" s:STRING => {notRef atr} => {ignore atr (Var (infix_name @@ unquote s))}
| %"fun" "(" args:!(Util.list0)[ostap (STRING)] ")" body:parse[def][infix][Void] => {notRef atr} => {ignore atr (Lambda (args, body))}
| "[" es:!(Util.list0)[parse def infix Val] "]" => {notRef atr} => {ignore atr (Array es)}
| -"{" scope[`Local][def][infix][atr][parse def] -"}"
| "{" es:!(Util.list0)[parse def infix Val] "}" => {notRef atr} => {ignore atr (match es with
@ -676,12 +690,6 @@ module Infix =
type t = ([`Lefta | `Righta | `Nona] * ((Expr.atr -> (Expr.atr * Expr.atr)) * ((string * (Expr.t -> Expr.atr -> Expr.t -> Expr.t)) list))) array
let name infix =
let b = Buffer.create 64 in
Buffer.add_string b "__Infix_";
Seq.iter (fun c -> Buffer.add_string b (string_of_int @@ Char.code c)) @@ String.to_seq infix;
Buffer.contents b
let default : t =
Array.map (fun (a, s) ->
a,
@ -765,7 +773,7 @@ module Definition =
| ass:(%"infix" {`Nona} | %"infixl" {`Lefta} | %"infixr" {`Righta})
l:$ op:(s:STRING {unquote s})
md:position[ass][l#coord][op] {
let name = Infix.name op in
let name = Expr.infix_name op in
match md (Expr.sem name) infix with
| `Ok infix' -> name, infix'
| `Fail msg -> raise (Semantic_error msg)

23
src/SM.ml
View file

@ -195,17 +195,18 @@ let compile (defs, p) =
transform(Pattern.t)
(fun fself ->
object inherit [int list, _, (string * int list) list] @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 _ _ = []
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
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_ClosureTag _ _ = []
method c_Array path _ ps = List.concat @@ List.mapi (fun i p -> fself (path @ [i]) p) ps
end)
[]
p