1. Yoshihiro Imai
  2. OCamlRuby

Commits

yoshihiro503  committed 411ff29

line position

  • Participants
  • Parent commits 3fc4124
  • Branches default

Comments (0)

Files changed (10)

File ast.ml

View file
 open Genlex
 
 (* TOKEN *)
-type token = Genlex.token
-
+type pos = { line: int; idx: int }
+type token = pos * Genlex.token
+let pos_compare p1 p2 =
+  match compare p1.line p2.line, compare p1.idx p2.idx with
+  | 0, c -> c
+  | 1, _ -> 1
+  | _, _ -> -1
+let null_pos = { line=(-1); idx=(-1) }
 
 (* EXPRESSION*)
 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
-    (* 数値やブール等の定数値 *)
-  | Literal of literal
-    (* 変数 *)
-  | Variable of string
-    (* 関数定義 *)
-  | FunDef of string * string list * expr
-    (* クラス定義 *)
-  | ClassDef of string * expr
-    (* 評価済みのオブジェクト(内部で使用) *)
-  | Const of inst
-    (* OCamlの関数(内部で使用) *)
-  | External of (inst -> expr)
+  | Ignore of expr * expr    (* 式 e1を実行して, e2 *)
+  | Call of obj * string * expr list    (* 関数呼び出し、またはメソッド呼び出し *)
+  | Assign of string * expr    (* 変数へ代入 *)
+  | If of expr * expr * expr    (* if 式 *)
+  | Literal of literal    (* 数値やブール等の定数値 *)
+  | Variable of string    (* 変数 *)
+  | FunDef of string * string list * expr    (* 関数定義 *)
+  | ClassDef of pos * string * expr    (* クラス定義 *)
+  | Const of inst    (* 評価済みのオブジェクト(内部で使用) *)
+  | External of (inst -> expr)    (* OCamlの関数(内部で使用) *)
 and obj = Obj of expr | Self
 
 (* CONTEXT *)
 
 
 (* for debug ============*)
-let s_token = function
+let s_token0 = 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 ^ ")"
+let s_token (pos, t) = Printf.sprintf "{%d:%s}" pos.line (s_token0 t)
 let s_literal = function
   | LString s -> s
   | LInt i -> string_of_int i
   | 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"
+  | ClassDef (p, 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
   slist "," (fun (n,_) -> n) (list_of_hash vhash)
 (* ======================*)
 
-  
 
 let create_ctx () = Hashtbl.create 50, Hashtbl.create 50
 let rec get_var (var_hash, _) vname =

File build.sh

View file
 #!/bin/sh
-ocamlopt util.ml llist.ml ast.ml lexer.ml parserUtil.ml parser.ml rbString.ml rbInt.ml rbBool.ml eval.ml main.ml -o ocamlruby
+ocamlopt util.ml llist.ml ast.ml lexer.ml parserMonado.ml parser.ml rbString.ml rbInt.ml rbBool.ml eval.ml main.ml -o ocamlruby
 

File eval.ml

View file
   | LBool b -> (RbBool.of_bool b)
   | LString s -> (RbString.of_string s)
 
+
 let rec eval self exp : inst * context =
   match exp with
   | Const obj -> obj, self.ctx
   | FunDef (fname, argnames, body) ->
       set_fun self.ctx fname (argnames, body);
       lambda self (argnames, body), self.ctx
-  | ClassDef (cname, body) ->
+  | ClassDef (pos, cname, body) ->
       let cls = make_class self.ctx cname body in
       set_var self.ctx cname cls;
       cls, self.ctx
   let ctx = copy_ctx local_ctx in
   set_fun ctx "to_s" ([], Literal (LString cname));
   let cls = { class_name="Class"; ctx=ctx } in
-  let init0 = { class_name=cname; ctx=snd @@ eval cls body } in
+  let init0 = { class_name=cname; ctx=create_ctx() } in
+  let _ = eval init0 body in
   let init = match get_initializer init0.ctx body with
   | Some (init_argnames, init_body) ->
       init_argnames, External (fun self ->

File lexer.ml

View file
-let lexer = Genlex.make_lexer ["def"; "end"; "lambda"; "if"; "then"; "else"; "class"; "return"; "("; ")"; "."; ","; "+"; "-"; "*"; "/"; "=="; "<="; ">="; "<"; ">"; "="; "&&"; "||"; "@"; "&"; "do"; "{"; "}"; "|"; "lambda"]
+let lexer = Genlex.make_lexer ["`"; "def"; "end"; "lambda"; "if"; "then"; "else"; "class"; "return"; "("; ")"; "."; ","; "+"; "-"; "*"; "/"; "=="; "<="; ">="; "<"; ">"; "="; "&&"; "||"; "@"; "&"; "do"; "{"; "}"; "|"; "lambda"; ":"]
 			       
 			       
 

File llist.ml

View file
 let slist delim show l =
   String.concat delim @@ List.map show l
 
-let sllist delim show l =
-  let fin = take 20 l in
-  if List.length fin <= 20 then
+let sllist ?(items:int=20) delim show l =
+  let fin = take items l in
+  if List.length fin <= items then
     slist delim show fin
   else
     slist delim show fin ^ "..."

File main.ml

View file
     try open_in Sys.argv.(1) with
     | Invalid_argument s -> prerr_endline "no input file"; exit 0
   in
-  Eval.eval Eval.toplevel @@ Parser.parse @@ Llist.of_stream @@ Lexer.lexer @@ Stream.of_channel ch
+  try
+    Eval.eval Eval.toplevel @@ Parser.parse
+     @@ Llist.of_stream @@ Lexer.lexer
+     @@ stream_map (function '\n' -> '`' | c -> c) @@ Stream.of_channel ch
+  with
+  | Parser.ParseError (pos, msg) -> p "Parse error: line %d: %s\n" pos.Ast.line msg ; exit 0
+  

File parser.ml

View file
 open Util
 open Llist
 open Ast
-open ParserUtil
+open ParserMonado
 
-type 'a parser = ('a, token llist) ParserUtil.parser
+module P = ParserMonado.Make (struct
+  type ts = token llist
+  type error = pos * string
+  let eplus (p1, s1) (p2, s2) =
+    match pos_compare p1 p2 with
+    | 0 -> (p1, s1 ^"\n"^ s2)
+    | 1 -> (p1, s1)
+    | _ -> (p2, s2)
+end)
+
+open P
+type 'a parser = 'a m
+exception ParseError of error
 
 (* for debug ===========*)
  let mode = 0
  | _ -> ()
 (* =================== *)
 
-let token t = function
-  | Cons (t1, ts) when t=t1 -> pts ts; Inl (t1, !$ts)
-  | _ -> Inr ("token:" ^ s_token t)
+let unit_parser f : 'a parser = function
+  | Cons (t1, ts) ->
+      begin match f t1 with
+      | `Val v -> pts ts; Inl (v, !$ts)
+      | `Err s -> Inr s
+      end
+  | Nil -> Inr (Ast.null_pos, "unit_parser")
 
-let kwd k = function
-  | Cons (t1, ts) when t1=Genlex.Kwd k -> pts ts; Inl (t1, !$ts)
-  | _ -> Inr ("P.kwd:'" ^ k ^ "'")
+let kwd k = unit_parser (function | (pos, Genlex.Kwd ki) when k = ki -> `Val (pos,k) | (pos,t) -> `Err (pos,"token'"^s_token0 t^"' is not kwd'"^ k ^"'"))
+let ident0 = unit_parser (function | (pos, Genlex.Ident s) -> `Val s | (pos,t) -> `Err (pos, "token'"^s_token0 t^"' is not identifier."))
+let ident = (kwd "@" >> ident0) <|> (kwd "&" >> ident0)  <|> ident0
 
-let ident0 = function
-  | Cons (Genlex.Ident s, ts) -> pts ts; Inl (s, !$ts)
-  | _ -> Inr ("ident0")
-let ident = (kwd "@" >> ident0) <|> (kwd "&" >> ident0)  <|> ident0
-  
+let literal = unit_parser (function
+  | pos, Genlex.String s -> `Val (LString s)
+  | pos, Genlex.Int i -> `Val (LInt i)
+  | pos, Genlex.Kwd "true" -> `Val (LBool true)
+  | pos, Genlex.Kwd "false" -> `Val (LBool false)
+  | pos, _ -> `Err (pos, "literal"))
 
-let literal = function
-  | Cons (Genlex.String s, ts) -> pts ts; Inl (LString s, !$ts)
-  | Cons (Genlex.Int i, ts) -> pts ts; Inl (LInt i, !$ts)
-  | Cons (Genlex.Kwd "true", ts) -> Inl (LBool true, !$ts)
-  | Cons (Genlex.Kwd "false", ts) -> Inl (LBool false, !$ts)
-  | _ -> Inr "literal"
 
-
-let sep_many delim : 'a parser -> 'a list parser = fun p ->
+let sep_many delim (p: 'a parser) : 'a list parser =
   (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 make_block(argnames, body) =
-  Call (Obj (ClassDef ("__BLOCK", FunDef ("call", argnames, body))), "new", [])
+let make_block(pos, argnames, body) =
+  Call (Obj (ClassDef (pos, "__BLOCK", FunDef ("call", argnames, body))), "new", [])
 
 
 let rec expr code =
   (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" >>= fun (pos,_) -> ident >>= fun cname -> expr >>= fun flds -> kwd "end" >> return (ClassDef (pos, cname, flds)))
   <|>
-  (kwd "class" >> expr >>= fun flds -> kwd "end" >> return (ClassDef ("__UNNAMEDCLASS", flds)))
+  (kwd "class" >>= fun (pos,_) -> expr >>= fun flds -> kwd "end" >> return (ClassDef (pos, "__UNNAMEDCLASS", flds)))
   <|>
   (block())
   <|>
   (return fac)
 
 and block () =
-  (kwd "{"  >> kwd "|" >> sep_many "," ident >>= fun argnames -> kwd "|" >> expr >>= fun body -> kwd "}" >> return @@ make_block(argnames, body))
+  (kwd "{"  >>= fun (pos,_) -> kwd "|" >> sep_many "," ident >>= fun argnames -> kwd "|" >> expr >>= fun body -> kwd "}" >> return @@ make_block(pos, argnames, body))
   <|>
-  (kwd "do" >> kwd "|" >> sep_many "," ident >>= fun argnames -> kwd "|" >> expr >>= fun body -> kwd "end" >> return @@ make_block(argnames, body))
+  (kwd "do" >>= fun (pos,_) -> kwd "|" >> sep_many "," ident >>= fun argnames -> kwd "|" >> expr >>= fun body -> kwd "end" >> return @@ make_block(pos, argnames, body))
 
 
 
 
+let rec set_position l i = function
+  | Cons (Genlex.Kwd "`", tl) -> set_position (l+1) 1 !$tl
+  | Cons (t, tl) -> Cons (({ line=l; idx=i }, t), lazy (set_position l (i+1) !$tl))
+  | Nil -> Nil
 
 let parse code =
-  match expr code with
+  match expr @@ set_position 1 1 code with
   | Inl (states, Nil) ->
       states
-  | Inl (states, ts) ->
-      p "Parser.parse: unread tokens:\n";
-      p " %s\n" (sllist ", " s_token ts);
-      states
-  | Inr msg ->
-      failwith @@ "parse err: " ^ msg
+  | Inl (states, Cons((pos,t),ts)) ->
+      raise (ParseError (pos, "unread token: '"^s_token0 t^"'."))
+  | Inr e ->
+      raise (ParseError e)

File parserUtil.ml

View file
 open Util
 
-type error_msg = string
-type ('a, 'ts) parser = 'ts -> ('a * 'ts, error_msg) either
+type error = Ast.pos * string
+type ('a, 'ts) parser = 'ts -> ('a * 'ts, error) 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
+module ParserMonado (T : sig type ts type error val eplus : error -> error -> error end) = struct
+  type 'a m = T.ts -> ('a * T.ts, T.error) either
 
-let (>>) : ('a, 'ts) parser -> ('b, 'ts) parser -> ('b, 'ts) parser =
-    fun p1 p2 ->
-      p1 >>= fun _ -> p2
+(* return : 'a -> ('a, 'ts) parser =*)
+  let return x = fun code -> Inl (x, code)
+      
+(* (>>=) : ('a, 'ts) parser -> ('a -> ('b, 'ts) parser) -> ('b, 'ts) parser *)
+  let (>>=) p f = fun code ->
+    match p code with
+    | Inl (x, ts) -> f x ts
+    | Inr err -> Inr err
+	  
+(* (>>) : ('a, 'ts) parser -> ('b, 'ts) parser -> ('b, 'ts) parser =*)
+  let (>>) p1 p2 = p1 >>= fun _ -> p2
+      
+(* (<|>) : ('a, 'ts) parser -> ('a, 'ts) parser -> ('a, 'ts) parser *)
+  let (<|>) p1 p2 = fun code ->
+    match p1 code, p2 code with
+    | Inl (x1, ts), _ -> Inl (x1, ts)
+    | _, Inl (x2, ts) -> Inl (x2, ts)
+    | Inr (err1), Inr (err2) -> Inr (T.eplus err1 err2)
+	  
+  let rec many p =
+    (p >>= fun x -> many p >>= fun xs -> return (x::xs))
+      <|> (return [])
+	
+  let opt p =
+    (p >>= fun x -> return (Some x)) <|> (return None)
+end
 
-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

View file
-(* comment *)
-(* (* nested comment *)
-*)
 
-def fff () ggg() + ggg() end
+
+def fff () ggg() + ggg() end {
 def ggg() 99 end
 puts (fff()) 
 
 
 
-id = lambda {|x| x }
-puts (id.call(3))
+id = lambda do|x| x end
+puts (id.call("IDENTITY"))
 
 
 puts(3+8)

File util.ml

View file
 type ('l, 'r) either = Inl of 'l | Inr of 'r
 
 let list_of_hash t = Hashtbl.fold (fun k v store -> (k,v) :: store) t []
+
+(* じじぃの日記、ツッコミ可より http://jijixi.azito.com/cgi-bin/diary/index.rb?date=20060617#p08 *)
+let stream_map f stream =                                                    
+    Stream.from (fun i ->
+      try Some (f (Stream.next stream))
+      with Stream.Failure -> None);;