Pattern-matching parsing

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 "--";

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
 
@@ -300,6 +333,7 @@ module Stmt =
         }
       | %"repeat" s:parse %"until" e:!(Expr.parse)  {Repeat (s, 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)}

src/SM.ml

@@ -6,6 +6,7 @@ open Language
 (* binary operator                 *) | BINOP   of string
 (* put a constant on the stack     *) | CONST   of int
 (* 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