1. Yoshihiro Imai
  2. OCamlRuby

Source

OCamlRuby / parser.ml

open Util
open Lexer
open Genlex
open ParserUtil
open Expression

type 'a parser = ('a, token list) ParserUtil.parser

(* for debug ===========*)
 let mode = 0
 let pts ts = match mode with
 | 1 -> p " - %s\n" (slist ", " stoken ts); flush stderr
 | 2 ->
    let s = match ts with
    | t1::t2::t3::t4::tail ->  slist "" (const ".") (t4::tail) ^ slist ";\t" stoken [t3;t2;t1]
    | _ -> (slist "; " stoken ts)
    in p " - %s\n" s
 | _ -> ()
(* =================== *)

let token t = function
  | t1 :: ts when t=t1 -> pts ts; Inl (t1, ts)
  | _ -> Inr ("token:" ^ stoken t)

let ident = function
  | Ident s :: ts -> pts ts; Inl (s, ts)
  | _ -> Inr ("ident")

let literal = function
  | String s :: ts -> pts ts; Inl (LString s, ts)
  | Int i :: ts -> pts ts; Inl (LInt i, ts)
  | Kwd "true" :: ts -> Inl (LBool true, ts)
  | Kwd "false" :: ts -> Inl (LBool false, ts)
  | Ident v :: ts -> pts ts; Inl (LVar v, ts)
  | _ -> Inr "literal"

let kwd k = function
  | t1 :: ts when t1=Kwd k -> pts ts; Inl (t1, ts)
  | _ -> Inr ("kwd:" ^ k)
      


let sep_many delim : 'a parser -> 'a list parser = fun p ->
  (p >>= fun x1 -> many (kwd delim >> p) >>= fun xs -> return (x1::xs))
  <|>
  (return [])

let arguments_as : 'a parser -> 'a list parser = fun p ->
  (kwd "(" >> sep_many "," p >>= fun args -> kwd ")" >> return args)


	
let rec expr code =
  begin
  lterm() >>= fun tm -> (expr >>= fun e -> return @@ Ignore (tm, e))
                    <|> (return tm)
  end code
and lterm () =
  rterm() >>= fun t1 -> (kwd "&&" >> lterm() >>= fun tm -> return @@ BinOp (And, t1, tm))
                    <|> (kwd "||" >> lterm() >>= fun tm -> return @@ BinOp (Or,  t1, tm))
		    <|> (return t1)
and rterm () =
  aterm() >>= fun t1 -> (kwd "==" >> rterm() >>= fun tm -> return @@ BinOp (Eq,  t1, tm))
                    <|> (kwd "<=" >> rterm() >>= fun tm -> return @@ BinOp (Le, t1, tm))
                    <|> (kwd "<"  >> rterm() >>= fun tm -> return @@ BinOp (Lt, t1, tm))
                    <|> (kwd ">=" >> rterm() >>= fun tm -> return @@ BinOp (Ge, t1, tm))
                    <|> (kwd ">"  >> rterm() >>= fun tm -> return @@ BinOp (Gt, t1, tm))
		    <|> (return t1)
and aterm () =
  mterm() >>= fun t1 -> (kwd "+" >> aterm() >>= fun tm -> return @@ BinOp (Plus,  t1, tm))
                    <|> (kwd "-" >> aterm() >>= fun tm -> return @@ BinOp (Minus, t1, tm))
		    <|> (return t1)
and mterm () =
  factor() >>= fun f1 -> (kwd "*" >> mterm() >>= fun tm -> return @@ BinOp (Mult, f1, tm))
                     <|> (kwd "/" >> mterm() >>= fun tm -> return @@ BinOp (Div,  f1, tm))
		     <|> (return f1)
and factor () =
  factor1() >>= fun fac ->
    (kwd "." >> ident >>= fun fname -> arguments_as (expr) >>= fun args -> return (Call (Obj fac, fname, args)))
    <|>
    (return fac)
and factor1 () =
  (ident >>= fun vname -> kwd "=" >> lterm() >>= fun tm -> return (Assign (vname, tm)))
  <|>
  (ident >>= fun fname -> arguments_as (expr) >>= fun args -> return (Call (Local, fname, args)))
  <|>
  (field >>= fun f -> return @@ Field f)
  <|>
  (kwd "if" >> expr >>= fun cond -> kwd "then" >> expr >>= fun e1 -> kwd "else" >> expr >>= fun e2 -> kwd"end" >>
    return (If (cond, e1, e2)))
  <|>
  (kwd "(" >> expr >>= fun e -> kwd ")" >> return e)
  <|>
  (literal >>= fun l -> return @@ Literal l)
  
and field code =
  begin
  (kwd "def" >> ident >>= fun fname -> arguments_as ident >>= fun argnames -> expr >>= fun body -> kwd "end" >>
    return (FunDef (fname, argnames, body)))
  <|>
  (kwd "class" >> ident >>= fun cname -> many @@ field >>= fun flds -> kwd "end" >> return (ClassDef (cname, flds)))
  end code




let parse code =
  match expr code with
  | Inl (states, []) ->
      states
  | Inl (states, ts) ->
      p "Parser.parse: unread tokens:\n";
      p " %s\n" (slist ", " stoken ts);
      states
  | Inr msg ->
      failwith @@ "parse err: " ^ msg