diff --git a/src/Driver.ml b/src/Driver.ml index 04818b39e..71d0e2df7 100644 --- a/src/Driver.ml +++ b/src/Driver.ml @@ -8,7 +8,14 @@ let parse infile = inherit Util.Lexers.decimal s inherit Util.Lexers.string s inherit Util.Lexers.char s - inherit Util.Lexers.ident ["skip"; "if"; "then"; "else"; "elif"; "fi"; "while"; "do"; "od"; "repeat"; "until"; "for"; "fun"; "local"; "return"; "length"] s + inherit Util.Lexers.ident ["skip"; + "if"; "then"; "else"; "elif"; "fi"; + "while"; "do"; "od"; + "repeat"; "until"; + "for"; + "fun"; "local"; "return"; + "length"; + "case"; "of"; "esac"; "when"] s inherit Util.Lexers.skip [ Matcher.Skip.whitespaces " \t\n"; Matcher.Skip.lineComment "--"; diff --git a/src/Language.ml b/src/Language.ml index 82b9be6e3..c53a3dfa5 100644 --- a/src/Language.ml +++ b/src/Language.ml @@ -25,6 +25,7 @@ module Value = | Array a -> a | _ -> failwith "array value expected" + let sexp s vs = Sexp (s, vs) let of_int n = Int n let of_string s = String s let of_array a = Array a @@ -226,16 +227,48 @@ module Expr = module Stmt = struct + (* Patterns in statements *) + module Pattern = + struct + + (* The type for patterns *) + @type t = + (* wildcard "-" *) | Wildcard + (* S-expression *) | Sexp of string * t list + (* identifier *) | Ident of string + (* constant *) | Const of int + (* string *) | String of string + (* array *) | Array of t list + (* arbitrary array *) | IsArray + (* arbitrary string *) | IsString + with show + + (* Pattern parser *) + ostap ( + parse: + %"_" {Wildcard} + | "`" t:IDENT ps:(-"(" !(Util.list)[parse] -")")? {Sexp (t, match ps with None -> [] | Some ps -> ps)} + | x:IDENT {Ident x} + | n:DECIMAL {Const n} + | s:STRING {String s} + | a:(-"[" !(Util.list)[parse] -"]") {Array a} + | "#" "[" "]" {IsArray} + | "#" {IsString} + ) + + end + (* The type for statements *) - type t = + @type t = (* assignment *) | Assign of string * Expr.t list * Expr.t (* composition *) | Seq of t * t (* empty statement *) | Skip (* conditional *) | If of Expr.t * t * t (* loop with a pre-condition *) | While of Expr.t * t (* loop with a post-condition *) | Repeat of t * Expr.t + (* pattern-matching *) | Case of Expr.t * (Pattern.t * Expr.t option * t) list (* return statement *) | Return of Expr.t option - (* call a procedure *) | Call of string * Expr.t list + (* call a procedure *) | Call of string * Expr.t list with show (* Statement evaluator @@ -299,7 +332,8 @@ module Stmt = Seq (i, While (c, Seq (b, s))) } | %"repeat" s:parse %"until" e:!(Expr.parse) {Repeat (s, e)} - | %"return" e:!(Expr.parse)? {Return e} + | %"return" e:!(Expr.parse)? {Return e} + | %"case" e:!(Expr.parse) %"of" bs:!(Util.listBy)[ostap ("|")][ostap (!(Pattern.parse) (-"when" !(Expr.parse))? parse)] %"esac" {Case (e, bs)} | x:IDENT s:(is:(-"[" !(Expr.parse) -"]")* ":=" e :!(Expr.parse) {Assign (x, is, e)} | "(" args:!(Util.list0)[Expr.parse] ")" {Call (x, args)} diff --git a/src/SM.ml b/src/SM.ml index 699403191..ed5dd3ae7 100644 --- a/src/SM.ml +++ b/src/SM.ml @@ -5,7 +5,8 @@ open Language @type insn = (* binary operator *) | BINOP of string (* put a constant on the stack *) | CONST of int -(* put a string on the stack *) | STRING of string +(* put a string on the stack *) | STRING of string +(* create an S-expression *) | SEXP of string * int (* load a variable to the stack *) | LD of string (* store a variable from the stack *) | ST of string (* store in an array *) | STA of string * int @@ -48,6 +49,8 @@ let rec eval env ((cstack, stack, ((st, i, o) as c)) as conf) = function | BINOP op -> let y::x::stack' = stack in eval env (cstack, (Value.of_int @@ Expr.to_func op (Value.to_int x) (Value.to_int y)) :: stack', c) prg' | CONST i -> eval env (cstack, (Value.of_int i)::stack, c) prg' | STRING s -> eval env (cstack, (Value.of_string s)::stack, c) prg' + | SEXP (s, n) -> let vs, stack' = split n stack in + eval env (cstack, (Value.sexp s @@ List.rev vs)::stack', c) prg' | LD x -> eval env (cstack, State.eval st x :: stack, c) prg' | ST x -> let z::stack' = stack in eval env (cstack, stack', (State.update x z st, i, o)) prg' | STA (x, n) -> let v::is, stack' = split (n+1) stack in @@ -120,6 +123,7 @@ let compile (defs, p) = | Expr.Binop (op, x, y) -> expr x @ expr y @ [BINOP op] | Expr.Call (f, args) -> call f args false | Expr.Array xs -> List.flatten (List.map expr xs) @ [CALL (".array", List.length xs, false)] + | Expr.Sexp (t, xs) -> List.flatten (List.map expr xs) @ [CALL (".array", List.length xs, false)] | Expr.Elem (a, i) -> expr a @ expr i @ [CALL (".elem", 2, false)] | Expr.Length e -> expr e @ [CALL (".length", 1, false)] in