diff --git a/regression/orig/test062.log b/regression/orig/test062.log new file mode 100644 index 000000000..3c41e142a --- /dev/null +++ b/regression/orig/test062.log @@ -0,0 +1,4 @@ +> 5 +7 +12 +-2 diff --git a/regression/orig/test064.log b/regression/orig/test064.log new file mode 100644 index 000000000..3af13cd74 --- /dev/null +++ b/regression/orig/test064.log @@ -0,0 +1 @@ +> 5 diff --git a/regression/test062.expr b/regression/test062.expr new file mode 100644 index 000000000..46c7b68c9 --- /dev/null +++ b/regression/test062.expr @@ -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) () \ No newline at end of file diff --git a/regression/test062.input b/regression/test062.input new file mode 100644 index 000000000..7ed6ff82d --- /dev/null +++ b/regression/test062.input @@ -0,0 +1 @@ +5 diff --git a/regression/test064.expr b/regression/test064.expr new file mode 100644 index 000000000..78c2344d1 --- /dev/null +++ b/regression/test064.expr @@ -0,0 +1,3 @@ +infixr "++" at "+" (a, b) {return a+b} + +write (infix "++" (2, 3)) \ No newline at end of file diff --git a/regression/test064.input b/regression/test064.input new file mode 100644 index 000000000..7ed6ff82d --- /dev/null +++ b/regression/test064.input @@ -0,0 +1 @@ +5 diff --git a/src/Language.ml b/src/Language.ml index 08bd8350f..2a7ddd2fc 100644 --- a/src/Language.ml +++ b/src/Language.ml @@ -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) diff --git a/src/SM.ml b/src/SM.ml index 0ab1aea54..322244b8b 100644 --- a/src/SM.ml +++ b/src/SM.ml @@ -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