Commits

Anonymous committed bdc92b0

version 0.3

Comments (0)

Files changed (8)

 ======
 	<program> ::= <expr>
 	
-	<expr> ::= <expr1>*
-	<expr1> ::= <rterm> ( [ "&&" | "||" ] <rterm> )*
+	<expr> ::= <lterm>*
+	<lterm> ::= <rterm> ( [ "&&" | "||" ] <rterm> )*
 
 	<rterm> ::= <aterm> ( [ "==" | "<=" | .. | ">" ] <aterm> )*
 
 	<factor> ::= <factor1> "." <ident> "(" <expr> "," .. "," <expr> ")"
 		   | <factor1>
 
-	<factor1> ::= <ident> "=" <expr>
+	<factor1> ::= <ident> "=" <lterm>
 		    | <ident> "(" <expr> "," .. "," <expr> ")"
 		    | <field>
 		    | "(" <expr> ")"
 #!/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]
 
 (* for debug ============*)
 let sobj o =
-  try
-    Printf.sprintf "%s(%d)" o.class_name (RbInt.to_int o)
-  with
-  | _ -> Printf.sprintf "%s()" o.class_name
+  try Printf.sprintf "%s(%d)" o.class_name (RbInt.to_int o) with
+  | e -> p "Eval.sobj: %s\n" (Printexc.to_string e);
+      Printf.sprintf "%s()" o.class_name
 let sctx : context -> string = slist ", " (function
   | name, Var obj -> name ^ ":" ^ sobj obj
   | name, Fun _ -> name ^ ":<fun>")
       try get_var ctx v with
       | e -> failwith @@ "Eval.eval_literal: unbound value: " ^ v
 
+let rec add_field ctx = function
+  | FunDef (fname, argnames, body) ->
+      null_obj, set_fun ctx fname (argnames, body)
+  | ClassDef (cname, fields) ->
+      let cls = make_class cname fields in
+      cls, set_var ctx cname cls
+
+and make_class cname fields : inst =
+  { class_name="Class"; ctx=[
+    ("to_s", Fun ([], Literal (LString cname)));
+    ("new", Fun ([], External (fun ctx ->
+      { class_name=cname; ctx=List.fold_left (fun ctx f -> snd @@ add_field ctx f) ctx fields })));
+  ]}
+
 
 let rec eval ctx exp : inst * context =
   match exp with
       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 f =
+	try get_fun o.ctx fname with
+	| UnboundValue -> failwith @@ "Eval.eval: Call: "^ o.class_name ^"#" ^ fname ^ " is unbound function"
+      in
       let args = List.map (fst $ eval ctx) args in
       call ctx' f args fname, ctx'
   | If (cond, 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
+      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
+      ocaml_program ctx, ctx
 and call ctx (argnames, body) args fname =
   let ctx' =
     try List.fold_left2 set_var ctx argnames args with
   in
   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
 
 and eval_binop op v1 v2 =
   let numbinop f = RbInt.of_int @@ f (RbInt.to_int v1) (RbInt.to_int v2) in
   | Or  -> logbinop ( || )
 
 
-  
 
 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 =
-      let x = get_var ctx "x" in
-      try
-	let argnames, fctx, states = get_fun x.ctx "to_s" in
-	RbString.to_string @@ eval fctx states
-      with
-      | UnboundValue -> p "puts: to_s not defined in class %s.\n" x.class_name; x.class_name ^ "(?)"
-    in
-    print_endline s; null_obj)]))
-]
-*)
+    null_obj)))]
 
 exception UnboundValue
 
+(* for debug ============*)
 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
   | 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
 	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 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;
   | (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
-  | `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 ]
-*)
-
-(*
-type context = (string * fld) list
-and state = [ 
-  | `TExpr of expr
-  | `TAssign of string * expr 
-  | `TDef of string * string list * state list
-  | `TClass of string * state list
-  | `External of (context -> inst)]
-and inst = { class_name: string; ctx: context }
-and fld = Var of inst | Fun of string list * context * state list
-
-
-let toplevel_name = "__T"
-
-
-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, ctx, ss)) :: tl when name=fname -> (args, ctx, ss)
-  | _ :: tl -> get_fun tl fname
-
-let expr_of_lit l : expr = `ERtm (`RAtm (`AMtm (`MFac (`FLit l))))
-let expr_of_fac f : expr = `ERtm (`RAtm (`AMtm (`MFac f)))
-let expr_of_mul m : expr = `ERtm (`RAtm (`AMtm m))
-let expr_of_pls a : expr = `ERtm (`RAtm a)
-
-
-let toplevel ctx = { class_name=toplevel_name; ctx=ctx }
-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";
+(*  print_endline @@ Expression.sexpr ast;*)
   Eval.eval Eval.init_ctx ast
 
 
 let kwd k = function
   | t1 :: ts when t1=Kwd k -> pts ts; 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"
-*)
-
+  | _ -> Inr ("kwd:" ^ k)
+      
 
 
 let sep_many delim : 'a parser -> 'a list parser = fun p ->
     <|>
     (return fac)
 and factor1 () =
-  (ident >>= fun vname -> kwd "=" >> expr >>= fun e -> return (Assign (vname, e)))
+  (ident >>= fun vname -> kwd "=" >> lterm() >>= fun tm -> return (Assign (vname, tm)))
   <|>
   (ident >>= fun fname -> arguments_as (expr) >>= fun args -> return (Call (Local, fname, args)))
   <|>
 let parse code =
   match expr code with
   | Inl (states, []) ->
-      p "=== Parser.parse: success! ===\n";
       states
   | Inl (states, ts) ->
       p "Parser.parse: unread tokens:\n";
       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_body >>= fun e ->
-      (kwd "." >> ident >>= fun fname -> arguments() >>= fun args -> return (`ECall (`Obj e, fname, args)))
-      <|>
-      (return e))
-  end code
-and expr_body 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 () =
-  (literal >>= fun l -> return (`FLit l))
-    <|> (kwd "(" >> expr >>= fun e -> kwd ")" >> return (`FExp e))
-
-and arguments () =
-  (kwd "(" >> sep_many "," expr >>= fun args -> kwd ")" >> return args)
-
-(**
-   文(statement) のパーサー
-**)
-let rec state = 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 of_int i = { class_name="Int"; ctx=[
 		 ("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 =
 
 puts ("hello, world")
 
-(*
 class C
-  class CC
-    def hoge() "hoge" end
-  end
   def f (x, y)
     if (4 * x == 4 || 3 * (y+2) >= 6+1) then
       true
   end
 end
 
-class D
-  def foo (x)
-    x + 5
+def hoge()
+  def huga(x)
+    class X
+      def s ()
+        "bunbun "
+      end
+    end
+    (X.new()).s() + x
   end
+  puts (huga(x))
 end
 
-puts (D)
-d = D.new()
 
-*)
+d =
+  class D
+    def foo (x)
+      x + 5
+    end
+  end.new()
+
+puts (d.foo(3))
+
+
 def fib (n)
   if n <= 2 then
     1