Commits

Anonymous committed 988a9bb

version 0.5

  • Participants
  • Parent commits 1d9e9d0

Comments (0)

Files changed (12)

 
 	<factor1> ::= <ident> "=" <lterm>
 		    | <ident> "(" <expr> "," .. "," <expr> ")"
+	    	    | <ident> <block>
+		    | <ident>
 		    | "def" <ident> "(" <ident> "," .. "," <ident> ")" <expr> "end"
-		    | "class" <ident>  <field> .. <field>  "end"
+		    | "def" <ident>  <expr> "end"
+		    | "class" <ident>  <expr>  "end"
+		    	    | "class"  <expr>  "end"
+		    | <block>
+		    | "lambda" <block>
 		    | "(" <expr> ")"
 		    | "if" <expr> "then" <expr> "else" <expr> "end"
 		    | <literal>
 		 
 	<factor_next> ::= "." <ident> "(" <expr> "," .. "," <expr> ")"  <factor_next>
-		        | ε
+		        | "." <ident>  <block> <factor_next>	
+			| "." <ident>  <factor_next>
+		        | <e>
 
-	<literal> ::= <string> | <int> | <bool> | <ident>
+	<block> ::= "{"  "|" <ident> "," .. "," <ident> "|" <expr> "}"
+		  | "do" "|" <ident> "," .. "," <ident> "|" <expr> "end"
+
+	<literal> ::= <string> | <int> | <bool>
 
 
 
 	- 大小比較
 	- bool演算
 	- 引数が無いメソッドの括弧省略
+	- ブロック構文、ラムダ式
+	- 無名クラス、無名関数
 
 
 まだないもの
 type literal = LString of string | LInt of int | LBool of bool
 
 type expr =
+    (* 式 e1を実行して, e2 *)
+  | Ignore of expr * expr
+    (* 関数呼び出し、またはメソッド呼び出し *)
   | Call of obj * string * expr list
+    (* 変数へ代入 *)
   | Assign of string * expr
+    (* if 式 *)
   | If of expr * expr * expr
-  | BinOp of op * expr * expr
-  | Ignore of expr * expr
+    (* 数値やブール等の定数値 *)
+  | Literal of literal
+    (* 変数 *)
+  | Variable of string
+    (* 関数定義 *)
+  | FunDef of string * string list * expr
+    (* クラス定義 *)
+  | ClassDef of string * expr
+    (* 評価済みのオブジェクト(内部で使用) *)
+  | Const of inst
+    (* OCamlの関数(内部で使用) *)
   | External of (inst -> expr)
-  | Literal of literal
-  | Variable of string
-  | Const of inst
-  | FunDef of string * string list * expr
-  | ClassDef of string * expr
-and obj = Obj of expr | Local
-and op = Mult | Div | Plus | Minus | Eq | Le | Lt | Ge | Gt | And | Or
+and obj = Obj of expr | Self
 
 (* CONTEXT *)
 and context = (string, inst) Hashtbl.t * (string, (string list * expr)) Hashtbl.t
   | LInt i -> string_of_int i
   | LBool b -> string_of_bool b
 let rec s_expr = function
-  | Call (Local, fname, _) -> "Call Local#" ^ fname
+  | Call (Self, fname, _) -> "Call Self#" ^ fname
   | Call (Obj o, fname, _) -> "Call ?#" ^ fname
   | FunDef (fname, argnames, e) -> "FunDef:" ^ fname ^ "(" ^ s_expr e ^ ")"
   | ClassDef (cname, fs) -> "ClassDef"
   | Assign (vname, expr) -> "Assign:(" ^ vname ^ ":=" ^ s_expr expr ^ ")"
   | If (_, e1, e2) -> "If(" ^ s_expr e1 ^ ", " ^ s_expr e2 ^ ")"
   | Literal lit -> s_literal lit
-  | BinOp (op, e1, e2) -> "BinOp"
   | Ignore (e1, e2) -> "Ig(" ^ s_expr e1 ^ ");\t" ^ s_expr e2
   | External func -> "External"
   | Const obj -> "Const(" ^ s_obj obj ^ ")"
   match exp with
   | Const obj -> obj, self.ctx
   | Literal l -> make_inst l, self.ctx
-  | Variable v -> begin try get_var self.ctx v, self.ctx with
-    | e -> failwith @@ "Eval.eval: unbound value: " ^ v ^ ": " ^ Printexc.to_string e end
+  | Variable v ->
+      begin try get_var self.ctx v, self.ctx with
+      | UnboundValue -> (* 変数じゃなかったら引数ゼロの関数かもしれない *)
+	  begin try call self (get_fun self.ctx v) [] v, self.ctx with
+	  | UnboundValue -> failwith @@ "Eval.eval: unbound value: " ^ v
+	  end
+      end
   | Ignore (e1, e2) ->
       let _, _ = eval self e1 in
       eval self e2
-  | Call (Local, fname, args) ->
+  | Call (Self, fname, args) ->
       let f =
 	try get_fun self.ctx fname with
 	| UnboundValue -> failwith @@ "Eval.eval: Call: " ^ fname ^ " is unbound function in "
   | If (cond, e1, e2) ->
       let b, ctx' = eval self cond in
       eval self begin if RbBool.to_bool b then e1 else e2 end
-  | BinOp (op, e1, e2) ->
-      let (v1,_), (v2,_) = eval self e1, eval self e2 in
-      eval_binop op v1 v2, self.ctx
   | FunDef (fname, argnames, body) ->
       set_fun self.ctx fname (argnames, body);
-      null_obj "fundef", self.ctx
+      lambda self (argnames, body), self.ctx
   | ClassDef (cname, body) ->
       let cls = make_class self.ctx cname body in
       set_var self.ctx cname cls;
   in
   let result = fst @@ eval self body in
   List.iter (remove_var self.ctx) argnames;
-result
+  result
 
-
-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 lambda self (argnames, body) =
+  let ctx = copy_ctx self.ctx in
+  set_fun ctx "call" (argnames, (External (fun self -> body)));
+  { class_name="__LAMBDA"; ctx=ctx }
 
 
 let toplevel : inst =
-let lexer = Genlex.make_lexer ["def"; "end"; "lambda"; "if"; "then"; "else"; "class"; "return"; "("; ")"; "."; ","; "+"; "-"; "*"; "/"; "=="; "<="; ">="; "<"; ">"; "="; "&&"; "||"; "@"; "&"]
+let lexer = Genlex.make_lexer ["def"; "end"; "lambda"; "if"; "then"; "else"; "class"; "return"; "("; ")"; "."; ","; "+"; "-"; "*"; "/"; "=="; "<="; ">="; "<"; ">"; "="; "&&"; "||"; "@"; "&"; "do"; "{"; "}"; "|"; "lambda"]
 			       
 			       
 
   String.concat delim @@ List.map show l
 
 let sllist delim show l =
-  (slist delim show @@ take 20 l) ^ "..."
+  let fin = take 20 l in
+  if List.length fin <= 20 then
+    slist delim show fin
+  else
+    slist delim show fin ^ "..."
+
+
     try open_in Sys.argv.(1) with
     | Invalid_argument s -> prerr_endline "no input file"; exit 0
   in
-  Eval.eval Eval.init_ctx @@ Parser.parse @@ Llist.of_stream @@ Lexer.lexer @@ Stream.of_channel ch
+
+  let tstream = Lexer.lexer (Stream.of_channel ch) in
+  let ts = Llist.of_stream tstream in
+(*  print_endline @@ Llist.sllist "; " Ast.s_token ts;*)
+  let ast = Parser.parse ts in
+(*  print_endline @@ (Ast.s_expr ast);*)
+  Eval.eval Eval.toplevel ast
+
+(*  Eval.eval Eval.init_ctx @@ Parser.parse @@ Llist.of_stream @@ Lexer.lexer @@ Stream.of_channel ch*)
 
 let kwd k = function
   | Cons (t1, ts) when t1=Genlex.Kwd k -> pts ts; Inl (t1, !$ts)
-  | _ -> Inr ("kwd:" ^ k)
+  | _ -> Inr ("P.kwd:'" ^ k ^ "'")
 
 let ident0 = function
   | Cons (Genlex.Ident s, ts) -> pts ts; Inl (s, !$ts)
-  | _ -> Inr ("ident")
+  | _ -> Inr ("ident0")
 let ident = (kwd "@" >> ident0) <|> (kwd "&" >> ident0)  <|> ident0
   
 
 let arguments_as : 'a parser -> 'a list parser = fun p ->
   (kwd "(" >> sep_many "," p >>= fun args -> kwd ")" >> return args)
 
+let make_block(argnames, body) =
+  Call (Obj (ClassDef ("__BLOCK", FunDef ("call", argnames, body))), "new", [])
 
-	
+
 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))
+  rterm() >>= fun t1 -> (kwd "&&" >> lterm() >>= fun tm -> return @@ Call (Obj t1, "&&", [tm]))
+                    <|> (kwd "||" >> lterm() >>= fun tm -> return @@ Call (Obj 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))
+  aterm() >>= fun t1 -> (kwd "==" >> rterm() >>= fun tm -> return @@ Call (Obj t1, "==", [tm]))
+                    <|> (kwd "!=" >> rterm() >>= fun tm -> return @@ Call (Obj t1, "!=", [tm]))
+                    <|> (kwd "<=" >> rterm() >>= fun tm -> return @@ Call (Obj t1, "<=", [tm]))
+                    <|> (kwd "<"  >> rterm() >>= fun tm -> return @@ Call (Obj t1, "<",  [tm]))
+                    <|> (kwd ">=" >> rterm() >>= fun tm -> return @@ Call (Obj t1, ">=", [tm]))
+                    <|> (kwd ">"  >> rterm() >>= fun tm -> return @@ Call (Obj 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))
+  mterm() >>= fun t1 -> (kwd "+" >> aterm() >>= fun tm -> return @@ Call (Obj t1, "+", [tm]))
+                    <|> (kwd "-" >> aterm() >>= fun tm -> return @@ Call (Obj 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))
+  factor() >>= fun f1 -> (kwd "*" >> mterm() >>= fun tm -> return @@ Call (Obj f1, "*", [tm]))
+                     <|> (kwd "/" >> mterm() >>= fun tm -> return @@ Call (Obj f1, "/", [tm]))
 		     <|> (return f1)
 
 and factor () =
 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)))
+  (ident >>= fun fname -> arguments_as (expr) >>= fun args -> return (Call (Self, fname, args)))
+  <|>
+  (ident >>= fun fname -> block() >>= fun b -> return @@ Call (Self, fname, [b]))
   <|>
   (kwd "def" >> ident >>= fun fname -> arguments_as ident >>= fun argnames -> expr >>= fun body -> kwd "end" >>
     return (FunDef (fname, argnames, body)))
   <|>
+  (kwd "def" >> ident >>= fun fname -> expr >>= fun body -> kwd "end" >>
+    return (FunDef (fname, [], body)))
+  <|>
   (kwd "class" >> ident >>= fun cname -> expr >>= fun flds -> kwd "end" >> return (ClassDef (cname, flds)))
   <|>
+  (kwd "class" >> expr >>= fun flds -> kwd "end" >> return (ClassDef ("__UNNAMEDCLASS", flds)))
+  <|>
+  (block())
+  <|>
+  (kwd "lambda" >> block())
+  <|>
   (kwd "if" >> expr >>= fun cond -> kwd "then" >> expr >>= fun e1 -> kwd "else" >> expr >>= fun e2 -> kwd"end" >>
     return (If (cond, e1, e2)))
   <|>
   <|>
   (ident >>= fun x -> return @@ Variable x)
 and factor_next fac =
-  (kwd "." >> ident >>= fun fname -> arguments_as (expr) >>= fun args -> factor_next (Call (Obj fac, fname, args)))
+  (kwd "." >> ident >>= fun fname -> arguments_as expr >>= fun args -> factor_next @@ Call (Obj fac, fname, args))
+  <|>
+  (kwd "." >> ident >>= fun fname -> block() >>= fun b -> factor_next @@ Call (Obj fac, fname, [b]))
+  <|>
+  (kwd "." >> ident >>= fun fname -> factor_next @@ Call (Obj fac, fname, []))
   <|>
   (return fac)
 
+and block () =
+  (kwd "{"  >> kwd "|" >> sep_many "," ident >>= fun argnames -> kwd "|" >> expr >>= fun body -> kwd "}" >> return @@ make_block(argnames, body))
+  <|>
+  (kwd "do" >> kwd "|" >> sep_many "," ident >>= fun argnames -> kwd "|" >> expr >>= fun body -> kwd "end" >> return @@ make_block(argnames, body))
+
 
 
 
 open Util
 open Ast
 
-let of_bool b =
-  let ctx = create_ctx () in
-  set_fun ctx "to_s" ([], Literal (LString (string_of_bool b)));
-  set_fun ctx "__body" ([], Literal (LBool b));
-  { class_name="Bool"; ctx=ctx }
-
 let to_bool obj =
   match get_fun obj.ctx "__body" with
   | (_, Literal (LBool x)) -> x
   | _ -> failwith @@ "RbBool.to_bool: " ^ obj.class_name
+
+let of_bool b =
+  let fmake args f = (args, External (fun self ->
+    let xs = List.map (to_bool $ get_var self.ctx) args in
+    f b xs))
+  in
+  let ctx = create_ctx () in
+  set_fun ctx "to_s" ([], Literal (LString (string_of_bool b)));
+  set_fun ctx "__body" ([], Literal (LBool b));
+  set_fun ctx "==" @@ fmake ["__x"] (fun x xs -> Literal (LBool (x = List.hd xs)));
+  set_fun ctx "!=" @@ fmake ["__x"] (fun x xs -> Literal (LBool (x != List.hd xs)));
+  set_fun ctx "&&" @@ fmake ["__x"] (fun x xs -> Literal (LBool (x && List.hd xs)));
+  set_fun ctx "||" @@ fmake ["__x"] (fun x xs -> Literal (LBool (x || List.hd xs)));
+
+  { class_name="Bool"; ctx=ctx }
 open Util
 open Ast
 
-let of_int i =
-  let ctx = create_ctx () in
-  set_var ctx (string_of_int i) (null_obj "int");
-  set_fun ctx "to_s" ([], Literal (LString (string_of_int i)));
-  set_fun ctx "__body" ([], Literal (LInt i));
-  { class_name="Int"; ctx=ctx }
-
 let to_int obj =
   match get_fun obj.ctx "__body" with
   | (_, Literal (LInt x)) -> x
   | _ -> failwith @@ "RbInt.to_int: " ^ obj.class_name
+
+let of_int i =
+  let ctx = create_ctx () in
+  let fmake args f = (args, External (fun self ->
+    let xs = List.map (to_int $ get_var self.ctx) args in
+    f i xs))
+  in
+  set_var ctx (string_of_int i) (null_obj "int");
+  set_fun ctx "to_s" ([], Literal (LString (string_of_int i)));
+  set_fun ctx "__body" ([], Literal (LInt i));
+  set_fun ctx "+" @@ fmake ["__x"] (fun i ys -> Literal (LInt (i + List.hd ys)));
+  set_fun ctx "-" @@ fmake ["__x"] (fun i ys -> Literal (LInt (i - List.hd ys)));
+  set_fun ctx "*" @@ fmake ["__x"] (fun i ys -> Literal (LInt (i * List.hd ys)));
+  set_fun ctx "/" @@ fmake ["__x"] (fun i ys -> Literal (LInt (i / List.hd ys)));
+  set_fun ctx "==" @@ fmake ["__x"] (fun x xs -> Literal (LBool (x = List.hd xs)));
+  set_fun ctx "!=" @@ fmake ["__x"] (fun x xs -> Literal (LBool (x != List.hd xs)));
+  set_fun ctx "<=" @@ fmake ["__x"] (fun x xs -> Literal (LBool (x <= List.hd xs)));
+  set_fun ctx "<"  @@ fmake ["__x"] (fun x xs -> Literal (LBool (x <  List.hd xs)));
+  set_fun ctx ">=" @@ fmake ["__x"] (fun x xs -> Literal (LBool (x >= List.hd xs)));
+  set_fun ctx ">"  @@ fmake ["__x"] (fun x xs -> Literal (LBool (x >  List.hd xs)));
+  { class_name="Int"; ctx=ctx }
 open Util
 open Ast
 
-let of_string s =
-  let ctx = create_ctx () in
-  set_fun ctx "to_s" ([], Literal (LString s));
-  { class_name="String"; ctx=ctx }
-
 let to_string s_obj =
   match get_fun s_obj.ctx "to_s" with
   | (_, Literal (LString s)) ->
       s
   | _ -> failwith @@ "RbString.to_string: " ^ s_obj.class_name
 
+let of_string s =
+  let ctx = create_ctx () in
+  let fmake args f = (args, External (fun self ->
+    let xs = List.map (to_string $ get_var self.ctx) args in
+    f s xs))
+  in
+  set_fun ctx "to_s" ([], Literal (LString s));
+  set_fun ctx "+" @@ fmake ["__x"] (fun x xs -> Literal (LString (x ^ List.hd xs)));
+  set_fun ctx "==" @@ fmake ["__x"] (fun x xs -> Literal (LBool (x = List.hd xs)));
+  set_fun ctx "!=" @@ fmake ["__x"] (fun x xs -> Literal (LBool (x != List.hd xs)));
+  { class_name="String"; ctx=ctx }
 
 
+
+

File samples/test.rb

 *)
 
 
+
+(*
+f = lambda { | x | x }
+puts (f.call(3))
+*)
+
+puts(3+8)
+
+puts("foo" + "bar")
+
+def ff (x)
+  puts(x+3)
+end.call(5)
+
+(*
 class CCC
-  @hoge = 7
   def initialize()
-    puts("inininin")
     @hoge = 3
   end
-  def getx ()
+  def getx
     @hoge
   end
   def setx(n)
     @hoge = n
   end
-  def to_s ()
+  def to_s
     @hoge
   end
 end
 x = 10
 
 c = CCC.new()
-puts(c.getx())
+puts(c.getx)
 puts(c.to_s())
 puts(c)
 
-
+*)
 
 (*
 puts (10 == x)