Commits

Anonymous committed a2bea48

import

  • Participants

Comments (0)

Files changed (10)

+(**********************************************)
+(*                min_ruby                    *)
+(**********************************************)
+
+
+BUILD
+=====
+
+	$ ./build.sh
+
+
+USAGE
+=====
+
+	$ ./minruby sample/test.rb
+#!/bin/sh
+ocamlc util.ml lexer.ml parserUtil.ml parser.ml stdlib.ml eval.ml main.ml -o minruby
+rm *.cm[oi]
+open Util
+open Parser
+open Stdlib
+
+let eval_literal ctx = function
+  | LInt i -> int_obj i
+  | LBool b -> bool_obj b
+  | LVar v ->
+      try List.assoc v ctx with
+      | Not_found -> failwith @@ "Eval.eval_literal: unbound value: " ^ v
+
+
+let rec eval ctx statements : context * obj =
+  List.fold_left eval1 (ctx,null_obj) statements
+
+and eval1 (ctx,_) : state -> context * obj = function
+  | `TExpr exp ->
+      let r = eval_exp ctx exp in
+      ctx, r
+  | `TAssign (vname, e) ->
+      ctx, todo_obj (* TODO *)
+  | `TDef (fname, argnames, fbody) ->
+      add_function ctx (fname, argnames, (fbody :> state list)), null_obj
+  | `TClass (class_name, states) ->
+      ctx, null_obj (* TODO *)
+(*      List.fold_left eval1 ctx states, null_obj*)
+  | `External ocaml_operation ->
+      ocaml_operation ctx;
+      ctx, null_obj
+
+and eval_exp ctx : expr -> obj = function
+  | `ETerm (op, reltm, exp) -> todo_obj
+  | `ERtm reltm -> eval_rel ctx reltm
+  | `ECall (`TopLevel, fname, args) ->
+      call ctx (List.assoc top_level_class_name ctx) fname args
+  | `ECall (`Obj e, fname, args) ->
+      todo_obj (* TODO *)
+  | _ -> todo_obj
+and eval_rel ctx = function
+  | `RAtm addtm -> eval_add ctx addtm
+  | _ -> todo_obj (* TODO *)
+and eval_add ctx = function
+  | `AMtm multm -> eval_mul ctx multm
+  | _ -> todo_obj (* TODO *)
+and eval_mul ctx = function
+  | `MFac fac -> eval_fac ctx fac
+  | _ -> todo_obj (* TODO *)
+and eval_fac ctx = function
+  | `FLit lit -> eval_literal ctx lit
+  | `FExp exp -> eval_exp ctx exp
+
+and call ctx obj fname args : obj =
+  let argnames, body =
+    try List.assoc fname obj.fields with
+    | Not_found -> failwith @@ "Eval.call: unbound function: " ^ fname
+  in
+  let args' = List.map (eval_exp ctx) args in (* call by need *)
+  let ctx' = List.fold_left (fun ctx (name,arg) -> (name,arg)::ctx) ctx (List.combine argnames args') in
+  let _, result = eval ctx' body in
+  result
+open Genlex
+
+let lexer =
+  Genlex.make_lexer ["def"; "end"; "lambda"; "if"; "else"; "class"; "return";
+		     "("; ")"; "."; ","; "+"; "-"; "*"; "/"; "<="; ">="; "<"; ">"; "="; "&&"; "||"; "\n"]
+
+let stoken = function
+  | Kwd s -> "kwd(" ^ s ^ ")"
+  | Ident s -> "ident(" ^ s ^ ")"
+  | Int i -> "int(" ^ string_of_int i ^ ")"
+  | Float f -> "float(" ^ string_of_float f ^ ")"
+  | String s ->  "string(" ^ s ^ ")"
+  | Char c ->  "char(" ^ String.make 1 c ^ ")"
+
+open Util
+open Lexer
+open ParserUtil
+open Parser
+
+let main =
+  let ch = open_in Sys.argv.(1) in
+  let tstream = Lexer.lexer (Stream.of_channel ch) in
+  let rec local store =
+    try local (Stream.next tstream :: store) with
+    | Stream.Failure -> List.rev store
+    | Stream.Error msg -> p "stream error: %s\n" msg; List.rev store
+  in
+  match Parser.parse (local []) with
+  | Inl (e, ts) ->
+      if List.length ts = 0 then begin
+	p "=== main: parse success! ===\n";
+	ignore (Eval.eval Stdlib.init_ctx (e :> Stdlib.state list))
+      end else 
+	List.iter (p "token: %s\n" $ stoken) ts
+  | Inr msg ->
+      p "main: parse err: %s\n" msg
+open Util
+open Lexer
+open Genlex
+open ParserUtil
+
+type 'a parser = ('a, token list) ParserUtil.parser
+
+let token t = function
+  | t1 :: ts when t=t1 -> Inl (t1, ts)
+  | _ -> Inr ("token:" ^ stoken t)
+
+let ident = function
+  | Ident s :: ts -> Inl (s, ts)
+  | _ -> Inr ("ident")
+
+type literal = LInt of int | LBool of bool | LVar of string
+let literal = function
+  | Int i :: ts -> Inl (LInt i, ts)
+  | Kwd "true" :: ts -> Inl (LBool true, ts)
+  | Kwd "false" :: ts -> Inl (LBool false, ts)
+  | Ident v :: ts -> Inl (LVar v, ts)
+  | _ -> Inr "literal"
+
+let kwd k = function
+  | t1 :: ts when t1=Kwd k -> Inl (t1, ts)
+  | _ -> Inr ("kwd:" ^ k)
+
+
+let add_op = function
+  | Kwd "+" :: ts -> Inl (`Plus, ts)
+  | Kwd "-" :: ts -> Inl (`Minus, ts)
+  | _ -> Inr "add_op"
+let unary_op = add_op
+
+let mul_op = function
+  | Kwd "*" :: ts -> Inl (`Mult, ts)
+  | Kwd "/" :: ts -> Inl (`Div, ts)
+  | _ -> Inr "mul_op"
+
+let rel_op = function
+  | Kwd "="  :: ts -> Inl (`Eq, ts)
+  | Kwd "<=" :: ts -> Inl (`Le, ts)
+  | Kwd ">=" :: ts -> Inl (`Ge, ts)
+  | Kwd "<"  :: ts -> Inl (`Lt, ts)
+  | Kwd ">"  :: ts -> Inl (`Gt, ts)
+  | _ -> Inr "rel_op"
+
+let log_op = function
+  | Kwd "&&" :: ts -> Inl (`And, ts)
+  | Kwd "||" :: ts -> Inl (`Or, ts)
+  | _ -> Inr "log_op"
+
+
+
+type expr = [
+    `ETerm of [ `And | `Or ] * rel_tm * expr
+  | `ERtm of rel_tm
+  | `ECall of [ `TopLevel | `Obj of expr] * string * expr list
+  | `EIf of expr * expr * expr
+]
+and rel_tm = [
+    `Rtm of [ `Eq | `Ge | `Gt | `Le | `Lt ] * add_tm * rel_tm
+  | `RAtm of add_tm ]
+and add_tm = [
+    `Atm of [ `Plus | `Minus ] * mul_tm * add_tm
+  | `AMtm of mul_tm ]
+and mul_tm = [
+  | `Mtm of [ `Mult | `Div ] * fac * mul_tm
+  | `MFac of fac ]
+and fac = [ `FLit of literal | `FExp of expr ]
+
+
+let sep_many delim p =
+  p >>= fun x1 -> many (kwd delim >> p) >>= fun xs -> return (x1::xs)
+
+let rec expr : expr parser = fun code ->
+  begin
+    (ident >>= fun fname -> arguments() >>= fun args -> return (`ECall (`TopLevel, fname, args)))
+    <|>
+    (expr_body >>= fun e ->
+      (kwd "." >> ident >>= fun fname -> arguments() >>= fun args -> return (`ECall (`Obj e, fname, args)))
+      <|>
+      (return e))
+  end code
+and expr_body = fun code ->
+  begin
+    (* term *)
+    (rel_term >>= fun t1 -> many (log_op >>= fun op -> rel_term >>= fun t -> return (op, t)) >>=
+      (return $ List.fold_left (fun exp (op, rtm) -> `ETerm (op, rtm, exp)) (`ERtm t1)))
+    <|>
+    (* if *)
+    (kwd "if" >> expr >>= fun cond -> kwd "then" >> expr >>= fun texp ->
+      kwd "else" >> expr >>= fun eexp -> kwd "end" >> return (`EIf (cond, texp, eexp)))
+  end code
+and rel_term code =
+  begin
+    (add_term >>= fun t1 -> many (rel_op >>= fun op -> add_term >>= fun t -> return (op, t)) >>=
+      (return $ List.fold_left (fun rtm (op, atm) -> `Rtm (op, atm, rtm)) (`RAtm t1)))
+  end code
+and add_term code =
+  begin
+    (mul_term >>= fun t1 -> many (add_op >>= fun aop -> mul_term >>= fun t -> return (aop,t)) >>=
+      (return $ List.fold_left (fun atm (aop,tm) -> `Atm (aop, tm, atm)) (`AMtm t1)))
+  end code
+and mul_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 mtm (mop,fac) -> `Mtm (mop, fac, mtm)) (`MFac (f1)))
+  end code
+and factor () = fun code ->
+begin
+  (literal >>= fun l -> return (`FLit l))
+    <|> (kwd "(" >> expr >>= fun e -> kwd ")" >> return (`FExp e))
+end code
+
+and arguments () = fun code ->
+begin
+  kwd "(" >> sep_many "," expr >>= fun args -> kwd ")" >> return args
+end code
+
+
+type st = [
+    `TExpr of expr | `TAssign of string * expr | `TDef of string * string list * st list
+  | `TClass of string * st list ]
+(**
+   ʸ(statement) �Υѡ�����
+**)
+let rec state : st parser = fun code ->
+  begin
+    (* ����ʸ *)
+    (ident >>= fun vname -> kwd "=" >> expr >>= fun e -> return (`TAssign (vname, e)))
+    <|>
+    (* �᥽�å���� *)
+    (kwd "def" >> ident >>= fun fname -> kwd "(" >> sep_many "," ident >>= fun argnames ->
+      kwd ")" >> many state >>= fun fbody -> kwd "end" >> return (`TDef (fname, argnames, fbody)))
+    <|>
+    (* ���饹��� *)
+    (kwd "class" >> ident >>= fun class_name -> many state >>= fun states -> kwd "end" >> return (`TClass (class_name, states)))
+    <|>
+    (expr >>= fun e -> return (`TExpr e))
+  end code
+
+let parse = many state

File parserUtil.ml

+open Util
+
+type ('l, 'r) either = Inl of 'l | Inr of 'r
+type error_msg = string
+type ('a, 'ts) parser = 'ts -> ('a * 'ts, error_msg) either
+
+let (<|>) : ('a, 'ts) parser -> ('a, 'ts) parser -> ('a, 'ts) parser =
+    fun p1 p2 ->
+      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 (>>=) : ('a, 'ts) parser -> ('a -> ('b, 'ts) parser) -> ('b, 'ts) parser = 
+    fun p f ->
+      fun code ->
+	match p code with
+	| Inl (x, ts) -> f x ts
+	| Inr msg -> Inr msg
+
+let (>>) : ('a, 'ts) parser -> ('b, 'ts) parser -> ('b, 'ts) parser =
+    fun p1 p2 ->
+      p1 >>= fun _ -> p2
+
+let return : 'a -> ('a, 'ts) parser =
+    fun 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 msg ->
+	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)
+

File samples/test.rb

+puts (5)
+(*
+putStr (hoge)
+class C
+  def ff (hoge, foo)
+    3
+  end
+end
+def f (x)
+  1 + 2
+end
+
+*)
+open Util
+open Parser
+
+let top_level_class_name = "__TopLevelClass"
+
+type context = (string * obj) list
+and state = [ Parser.st | `External of (context -> unit) ]
+and obj = { name: string; fields: (string * (string list * state list)) list }
+
+let null_obj = { name="Null"; fields = [] }
+let string_obj s = { name="String"; fields = [ ]}
+let int_obj i = { name="Int"; fields = []}
+let bool_obj b = { name="Bool"; fields = []}
+let todo_obj = { name="TODO"; fields = []}
+
+let show obj = obj.name
+
+
+       
+let get_value ctx vname =
+  try List.assoc vname ctx with
+  | Not_found -> failwith @@ "get_value: notfound: " ^ vname
+
+let set_ctx ctx vname obj =
+  (vname, obj) :: (List.remove_assoc vname ctx)
+
+let init_ctx =
+    [ (top_level_class_name,
+       { name="";
+	 fields=[
+	 ("puts", (["x"], [
+		   `External (fun ctx -> p "%s\n" (show @@ get_value ctx "x"))
+		 ])) ] }) ]
+
+
+let add_field cls (fname, argnames, fbody) =
+  { cls with fields = (fname, (argnames, fbody)) ::cls.fields }
+
+let add_class_method ctx class_name f =
+  let cls = List.assoc class_name ctx in
+  set_ctx ctx class_name (add_field cls f)
+
+let add_function ctx f =
+  add_class_method ctx top_level_class_name f
+
+let (@@) f x = f x
+let ($) g f = fun x -> g (f x)
+let p = Printf.printf
+let pr = print_endline
+
+let slist delim show l =
+  String.concat delim @@ List.map show l