Commits

yoshihiro503  committed 31c91a8

version 0.2

  • Participants
  • Parent commits cd20c0b

Comments (0)

Files changed (10)

 	$ ./minruby sample/test.rb
 
 
+SYNTAX
+======
+	<program> ::= <expr>
+	
+	<expr> ::= <expr1>*
+	<expr1> ::= <rterm> ( [ "&&" | "||" ] <rterm> )*
+
+	<rterm> ::= <aterm> ( [ "==" | "<=" | .. | ">" ] <aterm> )*
+
+	<aterm> ::= <mterm> ( [ "+" | "-" ] <mterm> )*
+
+	<mterm> ::= <factor> ( ["*" | "/" ] <factor> )*
+
+	<factor> ::= <factor1> "." <ident> "(" <expr> "," .. "," <expr> ")"
+		   | <factor1>
+
+	<factor1> ::= <ident> "=" <expr>
+		    | <ident> "(" <expr> "," .. "," <expr> ")"
+		    | <field>
+		    | "(" <expr> ")"
+		    | "if" <expr> "then" <expr> "else" <expr> "end"
+		    | <literal>
+		 
+	<field> ::= "def" <ident> "(" <ident> "," .. "," <ident> ")" <expr> "end"
+		  | "class" <ident>  <field> .. <field>  "end"
+
+	<literal> ::= <string> | <int> | <bool> | <ident>
+		  
+
 
 IMPLEMENTED SYNTAX
 ==================
 #!/bin/sh
+#ocamlc util.ml lexer.ml parserUtil.ml expression.ml parser.ml rbString.ml rbInt.ml rbBool.ml eval.ml main.ml -o minruby
 ocamlc util.ml lexer.ml parserUtil.ml expression.ml parser.ml rbString.ml rbInt.ml rbBool.ml eval.ml main.ml -o minruby
 rm *.cm[oi]
 open Util
+open List
 open Expression
 
 (* for debug ============*)
 (* ======================*)
 
 
-let eval_literal ctx = function
+let make_inst ctx = function
   | LInt i -> (RbInt.of_int i)
   | LBool b -> (RbBool.of_bool b)
   | LString s -> (RbString.of_string s)
       try get_var ctx v with
       | e -> failwith @@ "Eval.eval_literal: unbound value: " ^ v
 
-let make_class cname cls_ctx =
-  let new_instance = 
-    { class_name = cname; ctx = cls_ctx }
+
+let rec eval ctx exp : inst * context =
+  match exp with
+  | Literal l -> make_inst ctx l, ctx
+  | Ignore (e1, e2) ->
+      let _, ctx' = eval ctx e1 in
+      eval ctx' e2
+  | Call (Local, fname, args) ->
+      let f =
+	try get_fun ctx fname with
+	| UnboundValue -> failwith @@ "Eval.eval: Call: " ^ fname ^ " is unbound function in Local"
+      in
+      let args = List.map (fst $ eval ctx) args in
+      call ctx f args fname, ctx
+  | Call (Obj e, fname, args) ->
+      let o, ctx' = eval ctx e in
+      let f = get_fun o.ctx fname in
+      let args = List.map (fst $ eval ctx) args in
+      call ctx' f args fname, ctx'
+  | If (cond, e1, e2) ->
+      let b, ctx' = eval ctx cond in
+      eval ctx' begin if RbBool.to_bool b then e1 else e2 end
+  | BinOp (op, e1, e2) ->
+      let (v1,_), (v2,_) = eval ctx e1, eval ctx e2 in
+      eval_binop op v1 v2, ctx
+  | Field fs ->
+      null_obj, add_field ctx fs
+  | Assign (vname, e) ->
+      let v, ctx' = eval ctx e in
+      null_obj, set_var ctx' vname v
+  | External ocaml_program ->
+      ocaml_program ctx;
+      null_obj, ctx
+and call ctx (argnames, body) args fname =
+  let ctx' =
+    try List.fold_left2 set_var ctx argnames args with
+    | Invalid_argument s -> failwith @@ Printf.sprintf "function %s required %d arguments, but is taked %d: %s\n" fname (length argnames) (length args) s;
   in
-  { class_name="Class"; ctx=[
-    ("new", Fun ([], [], [`External(const new_instance)]));
-    ("to_s", Fun ([], [], [`External(const @@ RbString.of_string cname)]));
-  ] }
+  fst @@ eval ctx' body
 
+and add_field ctx : field -> context = function
+  | FunDef (fname, argnames, body) ->
+      set_fun ctx fname (argnames, body)
+  | ClassDef (cname, fields) ->
+      set_class ctx cname fields
 
-let rec eval ctx : state list -> inst = fun sts ->
-  fst @@ eval_local (null_obj, ctx) sts
-and eval_local (prev, ctx) = function
-  (*| `TExpr (call return (x)) :: _ -> Return (x)*) (* TODO return *)
-  | sts -> List.fold_left iter (prev,ctx) sts
-and iter (re, ctx) = function
-  | `TExpr e ->
-      eval_exp ctx e
-  | `TAssign (vname, e) ->
-      let re, ctx' = eval_exp ctx e in
-      (re, (vname, Var re) :: ctx')
-  | `TDef (fname, argnames, fbody) ->
-      (re, (fname, Fun(argnames, ctx, fbody)) :: ctx)
-  | `TClass (cname, states) ->
-      let _, obj_ctx = eval_local (null_obj, ctx) states in
-      (re, set_var ctx cname (make_class cname obj_ctx))
-(*      (re, (cname, `Cls(snd @@ eval_local (null_obj,ctx) states)) :: ctx)*)
-  | `External ocaml_operation ->
-      let ins = ocaml_operation ctx in
-      (ins, ctx)
+and eval_binop op v1 v2 =
+  let numbinop f = RbInt.of_int @@ f (RbInt.to_int v1) (RbInt.to_int v2) in
+  let relbinop f = match v1.class_name, v2.class_name with
+  | "Int", "Int" ->
+      RbBool.of_bool @@ f (RbInt.to_int v1) (RbInt.to_int v2)
+  | c1, c2 -> failwith @@ "Eval.eval_binop: relbinop: " ^ c1 ^ ", " ^ c2
+  in
+  let logbinop f = RbBool.of_bool @@ f (RbBool.to_bool v1) (RbBool.to_bool v2) in
+  match op with
+  | Mult -> numbinop ( * )
+  | Div ->  numbinop ( / )
+  | Plus -> numbinop ( + )
+  | Minus ->numbinop ( - )
+  | Eq -> relbinop ( = )
+  | Le -> relbinop (<= )
+  | Lt -> relbinop ( < )
+  | Ge -> relbinop (>= )
+  | Gt -> relbinop ( > )
+  | And -> logbinop ( && )
+  | Or  -> logbinop ( || )
 
-and eval_exp ctx : expr -> inst * context = function
-  | `ETerm (op, reltm, exp) ->
-      let re1, ctx' = eval_rel ctx reltm in
-      let re2, ctx'' = eval_exp ctx' exp in
-      RbBool.bin_op op re1 re2, ctx''
-  | `ERtm reltm -> eval_rel ctx reltm
-  | `ECall (`TopLevel, fname, args) ->
-      call ctx (toplevel ctx) fname args
-  | `ECall (`Obj e, fname, args) ->
-      let re, ctx' = eval_exp ctx e in
-      call ctx' re fname args
-  | `EIf (cond, e1, e2) ->
-      let re, ctx' = eval_exp ctx cond in
-      eval_exp ctx' (if RbBool.to_bool re then e1 else e2)
-and eval_rel ctx = function
-  | `RAtm addtm -> eval_add ctx addtm
-  | `Rtm (op, add_tm, rel_tm) ->
-      let re1, ctx' = eval_add ctx add_tm in
-      let re2, ctx'' = eval_rel ctx' rel_tm in
-      RbBool.bin_op op re1 re2, ctx''
-and eval_add ctx = function
-  | `AMtm multm -> eval_mul ctx multm
-  | `Atm (op, mul_tm, add_tm) ->
-      let re1, ctx' = eval_mul ctx mul_tm in
-      let re2, ctx'' = eval_add ctx' add_tm in
-      RbInt.bin_op op re1 re2, ctx''
-and eval_mul ctx = function
-  | `MFac fac -> eval_fac ctx fac
-  | `Mtm (op, fac, mul_tm) ->
-      let re1, ctx' = eval_fac ctx fac in
-      let re2, ctx'' = eval_mul ctx' mul_tm in
-      RbInt.bin_op op re1 re2, ctx''
-and eval_fac ctx = function
-  | `FLit lit -> (eval_literal ctx lit, ctx)
-  | `FExp exp -> eval_exp ctx exp
 
-and call ctx instance fname args : inst * context =
-  let argnames, fctx, body =
-    try get_fun instance.ctx fname with
-    | e -> failwith @@ "Eval.call: unbound function: " ^ fname ^ " in class " ^ instance.class_name
-  in
-  let ctx' =
-    try List.fold_left (fun ctx (name,arg) ->
-      let value, ctx' = eval_exp ctx arg in
-      set_var ctx' name value)
-	ctx (List.combine argnames args)
-    with
-    | UnboundValue -> failwith @@ "call: in class " ^ instance.class_name
-    | Invalid_argument msg -> failwith @@ Printf.sprintf "call: function '%s' required %d args, but take %d: %s" fname (List.length argnames) (List.length args) msg
-  in
-  let result, _ = eval_local (null_obj, ctx') body in
-  result, ctx (* 関数呼び出しでは環境ctxに影響を与えない *)
+  
 
+let init_ctx : context = [
+  ("puts", Fun (["x"], External (fun ctx ->
+    let x = get_var ctx "x" in
+    print_endline @@ RbString.to_string @@ call x.ctx (get_fun x.ctx "to_s") [] "puts";
+    null_obj)
+	       ))]
+  
 
 
-
-
+    
+    
+(*
 let init_ctx : context = [
   ("puts", Fun (["x"], [], [`External(fun ctx ->
     let s =
     in
     print_endline s; null_obj)]))
 ]
+*)

File expression.ml

 open Util
 
+
 type literal = LString of string | LInt of int | LBool of bool | LVar of string
 
+type expr =
+  | Call of obj * string * expr list
+  | Field of field
+  | Assign of string * expr
+  | If of expr * expr * expr
+  | Literal of literal
+  | BinOp of op * expr * expr
+  | Ignore of expr * expr
+  | External of (context -> inst)
+and field =
+  | FunDef of string * string list * expr
+  | ClassDef of string * field list
+and obj = Obj of expr | Local
+and op = Mult | Div | Plus | Minus | Eq | Le | Lt | Ge | Gt | And | Or
+
+(* CONTEXT *)
+and context = (string * f) list
+and f = Var of inst | Fun of string list * expr
+and inst = { class_name:string; ctx:context }
+
+exception UnboundValue
+
+let sliteral = function
+  | LString s -> s
+  | LInt i -> string_of_int i
+  | LBool b -> string_of_bool b
+  | LVar v -> v
+
+let rec sexpr = function
+  | Call (Local, fname, _) -> "Call Local#" ^ fname
+  | Call (Obj o, fname, _) -> "Call ?#" ^ fname
+  | Field (FunDef (fname, argnames, e)) -> "FunDef:" ^ fname ^ "(" ^ sexpr e ^ ")"
+  | Field (ClassDef (cname, fs)) -> "ClassDef"
+  | Assign (vname, _) -> "Assign:" ^ vname
+  | If (_, e1, e2) -> "If(" ^ sexpr e1 ^ ", " ^ sexpr e2 ^ ")"
+  | Literal lit -> sliteral lit
+  | BinOp (op, e1, e2) -> "BinOp"
+  | Ignore (e1, e2) -> "Ig(" ^ sexpr e1 ^ ");\n" ^ sexpr e2
+  | External func -> "External"
+
+let rec get_var ctx vname =
+  match ctx with
+  | [] -> p "E.get_var: unboundvar: %s\n" vname;
+	raise UnboundValue
+  | (name, Var v) :: tl when name=vname -> v
+  | _ :: tl -> get_var tl vname
+let set_var ctx vname value = (vname, Var value) :: ctx
+let rec get_fun ctx fname =
+  match ctx with
+  | [] -> p "E.get_fun: unboundfun: %s\n" fname;
+      raise UnboundValue
+  | (name, Fun (args, body)) :: tl when name=fname -> (args, body)
+  | _ :: tl -> get_fun tl fname
+let set_fun ctx fname (argnames, body) = (fname, Fun (argnames, body)) :: ctx
+let set_class ctx cname fields = ctx (* TODO *)
+
+let null_obj = { class_name="Null"; ctx = []}
+
+(*
 type expr = [
     `ETerm of [ `And | `Or ] * rel_tm * expr
   | `ERtm of rel_tm
   | `Mtm of [ `Mult | `Div ] * fac * mul_tm
   | `MFac of fac ]
 and fac = [ `FLit of literal | `FExp of expr ]
+*)
 
+(*
 type context = (string * fld) list
 and state = [ 
   | `TExpr of expr
 and inst = { class_name: string; ctx: context }
 and fld = Var of inst | Fun of string list * context * state list
 
-exception UnboundValue
 
 let toplevel_name = "__T"
 
 let null_obj = { class_name="Null"; ctx = []}
 let todo_obj = { class_name="TODO"; ctx = []}
 
-
+*)
     | Stream.Error msg -> p "stream error: %s\n" msg; List.rev store
   in
   let ast = Parser.parse (read_iter []) in
+  print_endline @@ Expression.sexpr ast;
+  p "=== eval ===\n";
   Eval.eval Eval.init_ctx ast
+
 (* for debug ===========*)
  let mode = 0
  let pts ts = match mode with
- | 1 -> p " - %s\n" (slist ", " stoken ts)
+ | 1 -> p " - %s\n" (slist ", " stoken ts); flush stderr
  | 2 ->
     let s = match ts with
-    | t1::t2::t3::t4::tail -> slist ";\t" stoken [t1;t2;t3] ^ "\t" ^ slist "" (const ".") (t4::tail)
+    | t1::t2::t3::t4::tail ->  slist "" (const ".") (t4::tail) ^ slist ";\t" stoken [t3;t2;t1]
     | _ -> (slist "; " stoken ts)
     in p " - %s\n" s
  | _ -> ()
 
 let kwd k = function
   | t1 :: ts when t1=Kwd k -> pts ts; Inl (t1, ts)
-  | _ -> Inr ("kwd:" ^ k)
+  | _ ->
+ Inr ("kwd:" ^ k)
 
-
+(*
 let add_op = function
   | Kwd "+" :: ts -> Inl (`Plus, ts)
   | Kwd "-" :: ts -> Inl (`Minus, ts)
   | Kwd "&&" :: ts -> Inl (`And, ts)
   | Kwd "||" :: ts -> Inl (`Or, ts)
   | _ -> Inr "log_op"
+*)
 
 
 
-
-let sep_many delim p =
+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 "=" >> expr >>= fun e -> return (Assign (vname, e)))
+  <|>
+  (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, []) ->
+      p "=== Parser.parse: success! ===\n";
+      states
+  | Inl (states, ts) ->
+      p "Parser.parse: unread tokens:\n";
+      p " %s\n" (slist ", " stoken ts);
+      states
+  | Inr msg ->
+      failwith @@ "parse err: " ^ msg
+
+
+(*
 let rec expr : expr parser = fun code ->
   begin
     (ident >>= fun fname -> arguments() >>= fun args -> return (`ECall (`TopLevel, fname, args)))
     (expr >>= fun e -> return (`TExpr e))
   end code
 
-let parse code =
-  match (many (state :> state parser)) 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
 
-
+*)
 open Expression
 
 let of_bool b = { class_name="Bool"; ctx=[
-		 ("to_s", Fun ([], [], [`External(const @@ RbString.of_string @@ string_of_bool b)]));
-		 ("__body", Fun ([], [], [ `TExpr (expr_of_lit (LBool b)) ]));
+		 ("to_s", Fun ([], Literal (LString (string_of_bool b))));
+		 ("__body", Fun ([], Literal (LBool b)));
 ] }
 
 
 let to_bool obj =
   match get_fun obj.ctx "__body" with
-  | (_, _, [ `TExpr (`ERtm (`RAtm (`AMtm (`MFac (`FLit (LBool x))))))]) -> x
-  | _ -> failwith @@ "RbString.to_string: " ^ obj.class_name
-
-
-let bin_op op re1 re2 =
-  let b = match op with
-  | `Eq -> RbInt.to_int re1 =  RbInt.to_int re2
-  | `Ge -> RbInt.to_int re1 <= RbInt.to_int re2
-  | `Gt -> RbInt.to_int re1 <  RbInt.to_int re2
-  | `Le -> RbInt.to_int re1 >= RbInt.to_int re2
-  | `Lt -> RbInt.to_int re1 >  RbInt.to_int re2
-  | `And-> to_bool re1 && to_bool re2
-  | `Or -> to_bool re1 || to_bool re2
-  in
-  of_bool b
-    
-
+  | (_, Literal (LBool x)) -> x
+  | _ -> failwith @@ "RbBool.to_bool: " ^ obj.class_name
 open Expression
 
 let of_int i = { class_name="Int"; ctx=[
-		 ("to_s", Fun ([], [], [`External(const @@ RbString.of_string @@ string_of_int i)]));
-		 ("__body", Fun ([], [], [ `TExpr (expr_of_lit (LInt i)) ]));
-] }
+		 ("to_s", Fun ([], Literal (LString (string_of_int i))));
+		 ("__body", Fun ([], Literal (LInt i)) );
+(*		 ("*", Fun (["x"], [], External (fun ctx ->
+		   let x = get_var ctx "x" in
+		   eval ctx @@ Literal (LInt (i+x))
+) ));*)
+	       ] }
 
 let to_int obj =
   match get_fun obj.ctx "__body" with
-  | (_, _, [ `TExpr (`ERtm (`RAtm (`AMtm (`MFac (`FLit (LInt x))))))]) -> x
-  | _ -> failwith @@ "RbString.to_string: " ^ obj.class_name
-
-let bin_op op re1 re2 =
-  let f = match op with
-  | `Plus -> ( + )
-  | `Minus -> ( - )
-  | `Mult -> ( * )
-  | `Div -> ( / )
-  in
-  of_int @@ f (to_int re2) (to_int re1)
-    
-
+  | (_, Literal (LInt x)) -> x
+  | _ -> failwith @@ "RbInt.to_int: " ^ obj.class_name
 open Expression
 
 let of_string s = { class_name="String"; ctx=[
-		    ("to_s", Fun ([], [], [ `TExpr (expr_of_lit (LString s)) ]))
-
-] }
+		    ("to_s", Fun ([], Literal (LString s)))
+		  ] }
 
 let to_string s_obj =
   match get_fun s_obj.ctx "to_s" with
-  | (_, _, [ `TExpr (`ERtm (`RAtm (`AMtm (`MFac (`FLit (LString s))))))]) ->
+  | (_, Literal (LString s)) ->
       s
   | _ -> failwith @@ "RbString.to_string: " ^ s_obj.class_name
 

File samples/test.rb

 
 puts ("hello, world")
 
+(*
 class C
   class CC
     def hoge() "hoge" end
 puts (D)
 d = D.new()
 
-
+*)
 def fib (n)
   if n <= 2 then
     1
   else
-    (fib (n - 1)) + (fib (n - 2))
+    fib (n - 1) + fib (n - 2)
   end
 end