Commits

HongboZhang committed b87bf19

lexer support <</ >> />> syntax, only need to take care is $>> will be broken

  • Participants
  • Parent commits bdb1bd5

Comments (0)

Files changed (1)

File camlp4/Camlp4/Struct/Lexer.mll

 
   open Lexing
   open Sig
-
+  let debug = ref false
+  let opt_char_len  = function Some _ -> 1 | None -> 0
+  let print_opt_char fmt = function Some c ->
+    Format.fprintf fmt "Some %c" c | None -> Format.fprintf fmt "None"
+  module Stack=struct
+    include Stack
+    let push v stk= begin 
+      if!debug then Format.eprintf "Push %a@." print_opt_char v else ();
+      push v stk
+    end 
+    let pop stk = begin
+      if !debug then Format.eprintf "Pop %a@." print_opt_char (top stk);
+      pop stk
+    end 
+  end 
+  let opt_char : char option Stack.t = Stack.create ()      
+  let show_stack () = begin
+    Stack.iter (Format.eprintf "%a@." print_opt_char ) opt_char 
+  end 
   (* Error report *)
   module Error = struct
 
     exception E of t
 
     open Format
-    let opt_char : char option Stack.t = Stack.empty
     let print ppf =
       function
       | Illegal_character c ->
   let shift n c = { (c) with loc = Loc.move `both n c.loc }
   let store_parse f c = store c ; f c c.lexbuf
   let parse f c = f c c.lexbuf
-  let mk_quotation quotation c name loc shift =
+
+  let mk_quotation quotation c name loc shift back =
     let s = parse_nested quotation (update_loc c) in
-    let contents = String.sub s 0 (String.length s - 2) in
+    let contents = String.sub s 0 (String.length s - back) in
     QUOTATION { q_name     = name     ;
                 q_loc      = loc      ;
                 q_shift    = shift    ;
     | "*)"
         { warn Comment_not_end (Loc.of_lexbuf lexbuf)                           ;
           move_start_p (-1) c; SYMBOL "*"                                       }
-    | "<<" (quotchar* as beginning)
+    | "<<" (symbolchar as p)? (quotchar* as beginning)
       { if quotations c
         then (move_start_p (-String.length beginning);
-              mk_quotation quotation c "" "" 2)
-        else parse (symbolchar_star ("<<" ^ beginning)) c                       }
+              Stack.push p opt_char;
+              let len = 2 + opt_char_len p in 
+              mk_quotation quotation c "" "" len len;
+             )
+        else parse
+          (symbolchar_star ("<<" ^ (match p with Some x -> String.make 1 x | None -> "")
+                            ^ beginning)) c   }
     | "<<>>"
       { if quotations c
         then QUOTATION { q_name = ""; q_loc = ""; q_shift = 2; q_contents = "" }
       "(*"
         { store c; with_curr_loc comment c; parse comment c                     }
     | "*)"                                                            { store c }
-    | '<' (':' ident)? ('@' locname)? '<'
+    | '<' (':' ident)? ('@' locname)? '<' (symbolchar as p)?
         { store c;
-          if quotations c then with_curr_loc quotation c; parse comment c       }
+          if quotations c then
+            Stack.push p opt_char; (* It's weird that we handle quotation in comment *)
+            with_curr_loc quotation c; parse comment c       }
     | ident                                             { store_parse comment c }
     | "\""
         { store c;
                                                         SYMBOL(beginning ^ tok) }
 
   and maybe_quotation_at c = parse
-    | (ident as loc) '<'
-      { mk_quotation quotation c "" loc (1 + String.length loc)                 }
+    | (ident as loc) '<' (symbolchar as p)?
+        (* bug fix 2 is for <@ *)
+      { Stack.push p opt_char;
+        mk_quotation quotation c "" loc
+          (2 + 1 + String.length loc + (opt_char_len p)) (2 + opt_char_len p)
+      } (* into the quotaion context *)
     | symbolchar* as tok                                   { SYMBOL("<@" ^ tok) }
 
   and maybe_quotation_colon c = parse
-    | (ident as name) '<'
-      { mk_quotation quotation c name "" (1 + String.length name)               }
-    | (ident as name) '@' (locname as loc) '<'
-      { mk_quotation quotation c name loc
-                     (2 + String.length loc + String.length name)               }
+    | (ident as name) '<' (symbolchar as p)?
+        (* bug fix 2 is for <: *)
+      { Stack.push p opt_char;
+        mk_quotation quotation c name ""
+          (2 + 1 + String.length name + opt_char_len p) (2 + opt_char_len p)
+      } (* into the quotation context *)
+        (* bug fix 2 is for <: *)
+    | (ident as name) '@' (locname as loc) '<' (symbolchar as p)?
+      { Stack.push p opt_char;
+        mk_quotation quotation c name loc
+          (2 + 2 + String.length loc + String.length name + opt_char_len p)
+      (2 + opt_char_len p)}
     | symbolchar* as tok                                   { SYMBOL("<:" ^ tok) }
 
   and quotation c = parse
-    | '<' (':' ident)? ('@' locname)? '<'  (symbol_char as chr)
-                                             {                          store c ;
-                                                      with_curr_loc quotation c ;
-                                                  Stack.push (Some chr) opt_char;
+    | '<' (':' ident)? ('@' locname)? '<'  (symbolchar as p)?
+                                             {                          store c ; (* nested case*)
+                                                          Stack.push  p opt_char;                                                                        
+                                                      with_curr_loc quotation c ; (* *)
                                                               parse quotation c }
-      
-    | '<' (':' ident)? ('@' locname)? '<'    {                          store c ;
-                                                      with_curr_loc quotation c ;
-                                            Stack.push None opt_char;                   
-                                                              parse quotation c }
-    | ">>" (symbol_char as chr)
-                                             { if Some chr = !opt_char then
-                                               store c
-                                              else
+
+    | (symbolchar as p)? ">>"              {
+      if not (Stack.is_empty opt_char) then 
+        let top = Stack.top opt_char in 
+        if p <> top then
+          store_parse quotation c (* move on *)
+        else  begin
+          Stack.pop opt_char;
+          store c ;
+        end
+      else store_parse quotation c;
                                              }
-    | ">>"                                  { if !opt_char = None then
-                                                 store c
-                                              else
-                                                 store_parse quotation c
-                                            }
 
-    | eof                                  { err Unterminated_quotation (loc c) }
+    | eof                                  { show_stack (); err Unterminated_quotation (loc c) }
     | newline                                     { update_loc c None 1 false 0 ;
                                                         store_parse quotation c }
     | _                                               { store_parse quotation c }
     | eof                                   { err Unterminated_antiquot (loc c) }
     | newline
       { update_loc c None 1 false 0; store_parse (antiquot name) c              }
-    | '<' (':' ident)? ('@' locname)? '<'
-      { store c; with_curr_loc quotation c; parse (antiquot name) c             }
+    | '<' (':' ident)? ('@' locname)? '<' (symbolchar as p)?
+      { let () = Stack.push p opt_char
+        let () = store c in
+        let () = with_curr_loc quotation c in
+        parse (antiquot name) c }
     | _                                         { store_parse (antiquot name) c }
 
   {