S-expressions and pattern matching

regression/Makefile

@@ -9,7 +9,7 @@ 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
+	cat $@.input | $(RC) -s $< > $@.log && diff $@.log orig/$@.log
 
 clean:
 	rm -f test*.log *.s *~ $(TESTS)

regression/orig/test039.log

@@ -0,0 +1,6 @@
+> 1
+1
+1
+1
+0
+0

regression/test038.expr

@@ -21,4 +21,3 @@ printList (x);
 printList (y);
 printList (append (x, y));
 printList (append (y, x))
-

regression/test039.expr

@@ -0,0 +1,31 @@
+fun insert (t, x) {
+  case t of
+    `leaf           -> return `node (x, `leaf, `leaf)
+  | `node (y, l, r) -> if x > y
+                          then return `node (y, insert (l, x), r)
+			  else return `node (y, l, insert (r, x))
+		       fi
+  esac
+}
+
+fun find (t, x) {
+  case t of
+    `leaf           -> return 0
+  | `node (y, l, r) -> if x == y then return 1
+		       elif x > y then return find (l, x)
+		                  else return find (r, x)
+		       fi
+  esac
+}
+
+n := read ();
+
+t := insert (insert (insert (insert (`leaf, 5), 4), 6), 3);
+
+write (find (t, 5));
+write (find (t, 4));
+write (find (t, 6));
+write (find (t, 3));
+write (find (t, 2));
+write (find (t, 1))
+

regression/test039.input

@@ -0,0 +1 @@
+0

src/Language.ml

@@ -51,6 +51,9 @@ module State =
     (* Undefined state *)
     let undefined x = failwith (Printf.sprintf "Undefined variable: %s" x)
 
+    (* Bind a variable to a value in a state *)
+    let bind x v s = fun y -> if x = y then v else s y 
+
     (* Empty state *)
     let empty = G undefined
 
@@ -58,11 +61,10 @@ module State =
        to value v and returns the new state w.r.t. a scope
     *)
     let update x v s =
-      let u x v s = fun y -> if x = y then v else s y in
       let rec inner = function
-      | G s -> G (u x v s)
+      | G s -> G (bind x v s)
       | L (scope, s, enclosing) ->
-         if List.mem x scope then L (scope, u x v s, enclosing) else L (scope, s, inner enclosing)
+         if List.mem x scope then L (scope, bind x v s, enclosing) else L (scope, s, inner enclosing)
       in
       inner s
 
@@ -111,6 +113,7 @@ module Builtin =
                                Some (match b with
                                      | Value.String   s  -> Value.of_int @@ Char.code s.[i]
                                      | Value.Array    a  -> List.nth a i
+                                     | Value.Sexp (_, a) -> List.nth a i
                                )
                     )         
     | ".length"  -> (st, i, o, Some (Value.of_int (match List.hd args with Value.Array a -> List.length a | Value.String s -> String.length s)))
@@ -266,11 +269,6 @@ module Stmt =
         (* 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, foldl
 
         (* Pattern parser *)                                 
@@ -279,16 +277,10 @@ module Stmt =
             %"_" {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}
         )
         
         let vars p =
-          let module S = Set.Make (String) in
+          transform(t) (object inherit [string list] @t[foldl] method c_Ident s _ name = name::s end) [] p
-          S.elements @@ transform(t) (object inherit [S.t] @t[foldl] method c_Ident s _ name = S.add name s end) S.empty p
         
       end
         
@@ -300,7 +292,7 @@ module Stmt =
     (* 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
+    (* pattern-matching                 *) | Case   of Expr.t * (Pattern.t * t) list
     (* return statement                 *) | Return of Expr.t option
     (* call a procedure                 *) | Call   of string * Expr.t list 
     (* leave a scope                    *) | Leave  with show
@@ -347,20 +339,15 @@ module Stmt =
           let (_, _, _, Some v) as conf' = Expr.eval env conf e in
           let rec branch ((st, i, o, _) as conf) = function
           | [] -> failwith (Printf.sprintf "Pattern matching failed: no branch is selected while matching %s\n" (show(Value.t) v))
-         | (patt, con, body)::tl ->
+          | (patt, body)::tl ->
              let rec match_patt patt v st =
                let update x v = function
                | None   -> None
-              | Some s -> Some (fun y -> if y = x then v else s y)
+               | Some s -> Some (State.bind x v s)
                in
                match patt, v with
                | Pattern.Ident  x    , v                               -> update x v st
                | Pattern.Wildcard    , _                               -> st
-              | Pattern.Const n     , Value.Int    n'     when n = n' -> st
-              | Pattern.String s    , Value.String s'     when s = s' -> st
-              | Pattern.Array  p    , Value.Array  p'                 -> match_list p p' st
-              | Pattern.IsArray     , Value.Array  _                  -> st
-              | Pattern.IsString    , Value.String _                  -> st
                | Pattern.Sexp (t, ps), Value.Sexp (t', vs) when t = t' -> match_list ps vs st
                | _                                                     -> None
              and match_list ps vs s =
@@ -371,16 +358,7 @@ module Stmt =
              in
              match match_patt patt v (Some State.undefined) with
              | None     -> branch conf tl
-            | Some st' ->
+             | Some st' -> eval env (State.push st st' (Pattern.vars patt), i, o, None) k (Seq (body, Leave))
-               let st'' = State.push st st' (Pattern.vars patt) in
-               let (st''', i', o', Some c) =
-                 match con with
-                 | None   -> (st'', i, o, Some (Value.of_int 1))
-                 | Some c -> Expr.eval env (st'', i, o, None) c 
-               in
-               if Value.to_int c <> 0
-               then eval env (st''', i', o', None) k (Seq (body, Leave))
-               else branch (st''', i', o', None) tl
          in
          branch conf' bs
            
@@ -409,7 +387,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)}
+      | %"case" e:!(Expr.parse) %"of" bs:!(Util.listBy)[ostap ("|")][ostap (!(Pattern.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/Makefile

@@ -1,12 +1,11 @@
 TOPFILE = rc
-OCAMLC = ocamlc
+OCAMLC = ocamlfind c
-OCAMLOPT = ocamlopt
+OCAMLOPT = ocamlfind opt
-OCAMLDEP = ocamldep
+OCAMLDEP = ocamlfind dep
 SOURCES = Language.ml SM.ml X86.ml Driver.ml
-LIBS = GT.cma unix.cma re.cma emacs/re_emacs.cma str/re_str.cma 
+CAMLP5 = -syntax camlp5o -package ostap.syntax,GT.syntax.all
-CAMLP5 = -pp "camlp5o -I `ocamlfind -query GT.syntax` -I `ocamlfind -query ostap.syntax` pa_ostap.cmo pa_gt.cmo -L `ocamlfind -query GT.syntax`"
 PXFLAGS = $(CAMLP5)
-BFLAGS = -rectypes -I `ocamlfind -query GT` -I `ocamlfind -query re`  -I `ocamlfind -query ostap` 
+BFLAGS = -rectypes
 OFLAGS = $(BFLAGS)
 
 all: .depend $(TOPFILE).opt
@@ -15,10 +14,10 @@ all: .depend $(TOPFILE).opt
 	$(OCAMLDEP) $(PXFLAGS) *.ml > .depend
 
 $(TOPFILE).opt: $(SOURCES:.ml=.cmx)
-	$(OCAMLOPT) -o $(TOPFILE).opt $(OFLAGS) $(LIBS:.cma=.cmxa) ostap.cmx $(SOURCES:.ml=.cmx)
+	$(OCAMLOPT) -o $(TOPFILE).opt $(OFLAGS) $(LIBS:.cma=.cmxa) -linkpkg -package ostap $(SOURCES:.ml=.cmx)
 
 $(TOPFILE).byte: $(SOURCES:.ml=.cmo)
-	$(OCAMLC) -o $(TOPFILE).byte $(BFLAGS) $(LIBS) ostap.cma $(SOURCES:.ml=.cmo) 
+	$(OCAMLC) -o $(TOPFILE).byte $(BFLAGS) $(LIBS) -linkpkg -package ostap $(SOURCES:.ml=.cmo) 
 
 clean:
 	rm -Rf *.cmi *.cmo *.cmx *.annot *.o *.opt *.byte *~ .depend

src/SM.ml

@@ -17,7 +17,13 @@ open Language
 (* end procedure definition        *) | END
 (* calls a function/procedure      *) | CALL    of string * int * bool
 (* returns from a function         *) | RET     of bool
-                                      | DROP | DUP | OVER with show
+(* drops the top element off       *) | DROP
+(* duplicates the top element      *) | DUP
+(* swaps two top elements          *) | SWAP
+(* checks the tag of S-expression  *) | TAG     of string
+(* enters a scope                  *) | ENTER   of string list
+(* leaves a scope                  *) | LEAVE
+with show
                                                    
 (* The type for the stack machine program *)
 type prg = insn list
@@ -69,6 +75,17 @@ let rec eval env ((cstack, stack, ((st, i, o) as c)) as conf) = function
                                   | (prg', st')::cstack' -> eval env (cstack', stack, (State.leave st st', i, o)) prg'
                                   | []                   -> conf
                                  )
+    | DROP                    -> eval env (cstack, List.tl stack, c) prg'
+    | DUP                     -> eval env (cstack, List.hd stack :: stack, c) prg'
+    | SWAP                    -> let x::y::stack' = stack in
+                                 eval env (cstack, y::x::stack', c) prg'
+    | TAG t                   -> let x::stack' = stack in
+                                 eval env (cstack, (Value.of_int @@ match x with Value.Sexp (t', _) when t' = t -> 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'
    ) 
 
 (* Top-level evaluation
@@ -78,7 +95,7 @@ let rec eval env ((cstack, stack, ((st, i, o) as c)) as conf) = function
    Takes a program, an input stream, and returns an output stream this program calculates
 *)
 let run p i =
-  (*print_prg p; *)
+  (*print_prg p;*)
   let module M = Map.Make (String) in
   let rec make_map m = function
   | []              -> m
@@ -117,25 +134,29 @@ let compile (defs, p) =
   let rec call f args p =
     let args_code = List.concat @@ List.map expr args in
     args_code @ [CALL (label f, List.length args, p)]
-  and pattern = function
+  and pattern lfalse = function
-  | Stmt.Pattern.Wildcard         -> [DROP; CONST 1]
+  | Stmt.Pattern.Wildcard         -> false, [DROP]
-  | Stmt.Pattern.Const     n      -> [CONST n; BINOP "=="]
+  | Stmt.Pattern.Ident     n      -> false, [DROP]
-  | Stmt.Pattern.String    s      -> [STRING s; CALL ("strcmp", 2, false)]
+  | Stmt.Pattern.Sexp     (t, ps) ->
-  | Stmt.Pattern.Ident     n      -> [DROP; CONST 1]
+     true,
-  | Stmt.Pattern.Array     ps     -> [DUP;
+     [DUP; TAG t; CJMP ("z", lfalse)] @ 
-                                      CALL ("isArray", 1, false);
+     (List.concat @@
-                                      OVER;
+        List.mapi
-                                      CALL (".length", 1, false);
+          (fun i p ->             
-                                      CONST (List.length ps);
+             [DUP; CONST i; CALL (".elem", 2, false)] @
-                                      BINOP "==";
+             snd @@ pattern lfalse p
-                                      BINOP "&&";
+          )
-                                     ]
+          ps
-  | Stmt.Pattern.IsArray          -> [CALL ("isArray", 1, false)]
+     )
-  | Stmt.Pattern.IsString         -> [CALL ("isString", 1, false)]
+  and bindings p =
-  | Stmt.Pattern.Sexp     (t, ps) -> []
+    let rec inner = function
-  and patterns = function
+    | Stmt.Pattern.Ident n      -> [SWAP]
-  | []         -> []
+    | Stmt.Pattern.Wildcard     -> [DROP]
-  | (e, p)::ps -> expr e @ pattern p @ [BINOP "&&"] @ patterns ps 
+    | Stmt.Pattern.Sexp (_, ps) ->
+       (List.flatten @@ List.mapi (fun i p -> [DUP; CONST i; CALL (".elem", 2, false)] @ inner p) ps) @
+       [DROP]
+    in
+    inner p @ [ENTER (Stmt.Pattern.vars p)]
   and expr = function
   | Expr.Var    x         -> [LD x]
   | Expr.Const  n         -> [CONST n]
@@ -143,7 +164,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.Sexp (t, xs)     -> List.flatten (List.map expr xs) @ [SEXP (t, List.length xs)]
   | Expr.Elem (a, i)      -> expr a @ expr i @ [CALL (".elem", 2, false)]
   | Expr.Length e         -> expr e @ [CALL (".length", 1, false)]
   in
@@ -175,6 +196,31 @@ let compile (defs, p) =
   | Stmt.Call   (f, args)   -> env, false, call f args true
                                                          
   | Stmt.Return e           -> env, false, (match e with Some e -> expr e | None -> []) @ [RET (e <> None)]
+
+  | Stmt.Leave              -> env, false, [LEAVE]
+                                             
+  | Stmt.Case (e, [p, s])   ->
+     let      pflag, pcode = pattern l p in
+     let env, sflag, scode = compile_stmt l env (Stmt.Seq (s, Stmt.Leave))  in
+     env, pflag || sflag, expr e @ pcode @ bindings p @ scode 
+                                    
+  | Stmt.Case (e, brs)      ->
+     let n = List.length brs - 1 in
+     let env, _, _, code =
+       List.fold_left
+         (fun (env, lab, i, code) (p, s) ->
+            let (lfalse, env), jmp =
+              if i = n
+              then (l, env), []
+              else env#get_label, [JMP l]
+            in
+            let      _, pcode = pattern lfalse p     in
+            let env, _, scode = compile_stmt l env (Stmt.Seq (s, Stmt.Leave)) in
+            (env, Some lfalse, i+1, ((match lab with None -> [] | Some l -> [LABEL l]) @ pcode @ bindings p @ scode @ jmp) :: code)          
+         )
+         (env, None, 0, []) brs
+     in
+     env, true, expr e @ List.flatten @@ List.rev code
   in
   let compile_def env (name, (args, locals, stmt)) =
     let lend, env       = env#get_label in