Commits

yoshihiro503  committed 4944657

import

  • Participants

Comments (0)

Files changed (5)

+ocamlc -o prim util.ml syntax.ml lex.ml parser.ml
+open Syntax
+
+let token filename =
+  let ch = open_in filename in
+  let word c =
+    let rec word_iter store =
+      try
+        begin match input_char ch with
+        | 'a'..'z' | 'A'..'Z' as c ->
+           word_iter (c :: store)
+        | other -> [other], String.concat "" (List.map (String.make 1) (List.rev store)) end
+      with | End_of_file -> [], String.concat "" (List.map (String.make 1) (List.rev store))
+    in
+    word_iter [c]
+  in
+  let rec loop l =
+    try
+      let c, tl = match l with
+        | [] -> input_char ch, []
+        | c :: tl -> c, tl
+      in
+      begin match c with
+      | ' ' -> loop tl
+      | '\t' -> loop tl
+      | '\n' -> loop tl
+      | ';' -> Semicolon :: loop tl
+      | '.' -> Dot :: loop tl
+(*      | '(' -> P_Open
+      | ')' -> P_Close*)
+      | 'a'..'z' | 'A'..'Z' as c1 ->
+         begin match word c1 with
+         | l, "MODULE" -> Reserved(Module) :: (loop l)
+         | l, "BEGIN" -> Reserved(Begin) :: (loop l)
+         | l, "END" -> Reserved(End) :: (loop l)
+         | l, w -> Literal(Ident(w)) :: (loop l)
+         end
+      | _ -> failwith ("lex error:" ^ String.make 1 c)
+      end
+    with
+     | End_of_file -> []
+  in
+  loop []
+open Util
+open Syntax
+open Lex
+type ('l, 'r) either = Inl of 'l | Inr of 'r
+type 'a parser = token list -> ('a * token list, string) either
+
+(*-------------------------------*)
+let (<|>) (p1:'a parser) (p2:'a parser) = fun code ->
+  match p1 code, p2 code with
+  | Inl (x1, ts), _ -> Inl (x1, ts)
+  | _, Inl (x2, ts) -> Inl (x2, ts)
+  | Inr (msg1), Inr (msg2) -> Inr (msg1 ^ msg2)
+
+let (>>=) (p:'a parser) (f:'a -> 'b parser) = fun code ->
+  match p code with
+  | Inl (x, ts) -> f x ts
+  | Inr msg -> Inr msg
+
+let (>>) p1 p2 = p1 >>= fun _ -> p2
+
+let return x = fun code -> Inl (x, code)
+
+let many p =
+  let rec local store code =
+    match p code with
+    | Inl (x, ts) -> local (x::store) ts
+    | Inr _ -> List.rev store, code
+  in
+  fun code -> Inl (local [] code)
+
+let opt p = fun code ->
+  match p code with
+  | Inl (x, ts) -> Inl (Some x, ts)
+  | Inr _ ->  Inl (None, code)
+(*-------------------------------*)
+
+
+let token t = function
+  | t1 :: ts when t=t1 -> Inl (t1, ts)
+  | _ -> Inr ("parse token: " ^ stoken t)
+
+let ident = function
+  | Literal(Ident s) :: ts -> Inl (s, ts)
+  | _ -> Inr "ident"
+
+let literal = function
+  | Literal l :: ts -> Inl (l, ts)
+  | _ -> Inr "literal"
+let add_op = function
+  | Plus :: ts -> Inl (Plus, ts)
+  | Minus :: ts -> Inl (Minus, ts)
+  | _ -> Inr "unary op"
+let mul_op = function
+  | Mult :: ts -> Inl (Mult, ts)
+  | Div :: ts -> Inl (Div, ts)
+  | _ -> Inr "mul op"
+let unary_op = add_op
+(**
+<program> ::= MODULE <ident> ; <vdecl opt> BEGIN <statement list> END .
+
+<vdecl> ::= VAR <decl seplist(',')>
+<decl> ::= <ident list> : <type> ;
+<type> ::= INT | STRING
+
+<statement> ::= <ident> := <expr>
+              | IF <relation> THEN <statement list> <else opt> END
+              | WHILE <relation> DO <statement list> END
+              | <ident> ( <literal> )
+<else> ::= ELSE <statement list>
+<relation> ::= <expr> <relop> <expr>
+<expr> ::= <term> <(<addop> <term>) list>
+<term> ::= <uop opt> <factor> <(<mulop> <factor>) list>
+<factor> ::= <literal>
+           | ( <expr> )
+<literal> ::= <ident>
+            | <number>
+            | <string>
+
+<relop> ::= <> | < | <= | = | > | >=
+<uop>   ::= + | -
+<addop> ::= + | -
+<mulop> ::= * | /
+*)
+
+let rec expr code = begin term >>= fun t1 -> many (add_op >>= fun aop -> term >>= fun t -> return (aop,t)) >>=
+  (return $ List.fold_left (fun ex (aop,tm) -> `Ex (aop,ex,`TM(tm))) (`TM t1))
+  end code
+and term code = begin
+  opt unary_op >>= fun uop_opt -> factor >>= fun f1 ->
+  many (mul_op >>= fun mop -> factor >>= fun f -> return(mop, f))
+  >>= (return $ List.fold_left (fun tm (mop,fac) -> `TM (mop,tm,`F(fac))) (`F f1))
+  end code
+and factor code = begin
+  literal >>= fun l -> return (`Lit l)
+  <|> (token P_Open >> expr >>= fun e -> token P_Close >> return (`F_Ex e)) end code
+
+let statement = ident >>= fun s -> token Assign >> expr >>= fun e -> return (Ass (s, e))
+ <|> (ident >>= fun s -> token P_Open >> literal >>= fun l -> token P_Close >> return (Call (s, l)))
+
+let parse_module = token (Reserved Module) >> ident >>= fun s -> token Semicolon >>
+  token (Reserved Begin) >> many statement >>= fun ss -> token (Reserved End) >>
+  token Dot >> return (Pg (s, [], ss))
+
+let parse_file filename =
+  let ts = Lex.token filename in
+  match parse_module ts with
+  | Inl (m, []) -> print_endline "parse success"
+  | Inl (m, l) -> print_endline "rest: "
+  | Inr msg -> print_endline ("parse err" ^ msg)
+(*  let p = parse_module ts in
+  List.iter (fun t -> print_endline (Syntax.stoken t)) ts
+*)
+
+let test =
+  parse_file "test.prim"
+(** Prim Language  syntax.ml
+ for my compile at CSNagoya
+ Y. Imai wrote 2008 12 14
+*)
+
+type ident = string
+
+type literal =
+| Ident of ident
+| Number of string
+| String of string
+
+type ty = INT | STRING
+
+type decl = ident list * ty
+
+type 'expr relation = Eq of 'expr * 'expr
+type 'expr statement =
+ | Ass of ident * 'expr
+ | If of 'expr relation * 'expr statement list * 'expr statement list
+(*   | WHILE*) 
+ | Call of ident * literal
+
+type 'expr program =
+ | Pg of ident * decl list * 'expr statement list
+
+type reserved =
+ | Module  | Begin  | End | Var | If | Then | Else | While | Do
+
+type token =
+  | Literal of literal
+  | Type of ty
+  | Reserved of reserved
+  | Semicolon
+  | Dot
+  | P_Open
+  | P_Close
+  | Assign
+  | Plus
+  | Minus
+  | Mult
+  | Div
+
+ 
+
+let sliteral = function
+  | Ident (s) -> s
+  | Number (s) -> s
+  | String (s) -> "\"" ^ s ^ "\""
+
+let sreserved = function 
+  | Module -> "Module"
+  | Begin -> "Begin"
+  | End -> "End"
+  | _ -> "_"
+
+let stoken = function 
+  | Literal (l) -> "literal:" ^ sliteral l
+  | Type (t) -> "type"
+  | Reserved (r) -> "reserved:" ^ sreserved r
+  | Semicolon -> "semicolon"
+  | Dot -> "dot"
+  | P_Open -> "popen"
+  | P_Close -> "pclose"
+  | _ -> "_"
+let ( @@ ) f x = f x
+let ( $ ) g f x = g (f x)