stdlib/genlex.ml

   1 (***********************************************************************)
   2 (*                                                                     *)
   3 (*                           Objective Caml                            *)
   4 (*                                                                     *)
   5 (*              Xavier Leroy, projet Cristal, INRIA Rocquencourt       *)
   6 (*                                                                     *)
   7 (*  Copyright 1996 Institut National de Recherche en Informatique et   *)
   8 (*  en Automatique.  All rights reserved.  This file is distributed    *)
   9 (*  under the terms of the GNU Library General Public License, with    *)
  10 (*  the special exception on linking described in file ../LICENSE.     *)
  11 (*                                                                     *)
  12 (***********************************************************************)
  13
  14 (* $Id$ *)
  15
  16 type token =
  17     Kwd of string
  18   | Ident of string
  19   | Int of int
  20   | Float of float
  21   | String of string
  22   | Char of char
  23
  24
  25 (* The string buffering machinery *)
  26
  27 let initial_buffer = String.create 32
  28
  29 let buffer = ref initial_buffer
  30 let bufpos = ref 0
  31
  32 let reset_buffer () = buffer := initial_buffer; bufpos := 0
  33
  34 let store c =
  35   if !bufpos >= String.length !buffer then
  36     begin
  37       let newbuffer = String.create (2 * !bufpos) in
  38       String.blit !buffer 0 newbuffer 0 !bufpos; buffer := newbuffer
  39     end;
  40   String.set !buffer !bufpos c;
  41   incr bufpos
  42
  43 let get_string () =
  44   let s = String.sub !buffer 0 !bufpos in buffer := initial_buffer; s
  45
  46 (* The lexer *)
  47
  48 let make_lexer keywords =
  49   let kwd_table = Hashtbl.create 17 in
  50   List.iter (fun s -> Hashtbl.add kwd_table s (Kwd s)) keywords;
  51   let ident_or_keyword id =
  52     try Hashtbl.find kwd_table id with
  53       Not_found -> Ident id
  54   and keyword_or_error c =
  55     let s = String.make 1 c in
  56     try Hashtbl.find kwd_table s with
  57       Not_found -> raise (Stream.Error ("Illegal character " ^ s))
  58   in
  59   let rec next_token (strm__ : _ Stream.t) =
  60     match Stream.peek strm__ with
  61       Some (' ' | '\010' | '\013' | '\009' | '\026' | '\012') ->
  62         Stream.junk strm__; next_token strm__
  63     | Some ('A'..'Z' | 'a'..'z' | '_' | '\192'..'\255' as c) ->
  64         Stream.junk strm__;
  65         let s = strm__ in reset_buffer (); store c; ident s
  66     | Some
  67         ('!' | '%' | '&' | '$' | '#' | '+' | '/' | ':' | '<' | '=' | '>' |
  68          '?' | '@' | '\\' | '~' | '^' | '|' | '*' as c) ->
  69         Stream.junk strm__;
  70         let s = strm__ in reset_buffer (); store c; ident2 s
  71     | Some ('0'..'9' as c) ->
  72         Stream.junk strm__;
  73         let s = strm__ in reset_buffer (); store c; number s
  74     | Some '\'' ->
  75         Stream.junk strm__;
  76         let c =
  77           try char strm__ with
  78             Stream.Failure -> raise (Stream.Error "")
  79         in
  80         begin match Stream.peek strm__ with
  81           Some '\'' -> Stream.junk strm__; Some (Char c)
  82         | _ -> raise (Stream.Error "")
  83         end
  84     | Some '"' ->
  85         Stream.junk strm__;
  86         let s = strm__ in reset_buffer (); Some (String (string s))
  87     | Some '-' -> Stream.junk strm__; neg_number strm__
  88     | Some '(' -> Stream.junk strm__; maybe_comment strm__
  89     | Some c -> Stream.junk strm__; Some (keyword_or_error c)
  90     | _ -> None
  91   and ident (strm__ : _ Stream.t) =
  92     match Stream.peek strm__ with
  93       Some
  94         ('A'..'Z' | 'a'..'z' | '\192'..'\255' | '0'..'9' | '_' | '\'' as c) ->
  95         Stream.junk strm__; let s = strm__ in store c; ident s
  96     | _ -> Some (ident_or_keyword (get_string ()))
  97   and ident2 (strm__ : _ Stream.t) =
  98     match Stream.peek strm__ with
  99       Some
 100         ('!' | '%' | '&' | '$' | '#' | '+' | '-' | '/' | ':' | '<' | '=' |
 101          '>' | '?' | '@' | '\\' | '~' | '^' | '|' | '*' as c) ->
 102         Stream.junk strm__; let s = strm__ in store c; ident2 s
 103     | _ -> Some (ident_or_keyword (get_string ()))
 104   and neg_number (strm__ : _ Stream.t) =
 105     match Stream.peek strm__ with
 106       Some ('0'..'9' as c) ->
 107         Stream.junk strm__;
 108         let s = strm__ in reset_buffer (); store '-'; store c; number s
 109     | _ -> let s = strm__ in reset_buffer (); store '-'; ident2 s
 110   and number (strm__ : _ Stream.t) =
 111     match Stream.peek strm__ with
 112       Some ('0'..'9' as c) ->
 113         Stream.junk strm__; let s = strm__ in store c; number s
 114     | Some '.' ->
 115         Stream.junk strm__; let s = strm__ in store '.'; decimal_part s
 116     | Some ('e' | 'E') ->
 117         Stream.junk strm__; let s = strm__ in store 'E'; exponent_part s
 118     | _ -> Some (Int (int_of_string (get_string ())))
 119   and decimal_part (strm__ : _ Stream.t) =
 120     match Stream.peek strm__ with
 121       Some ('0'..'9' as c) ->
 122         Stream.junk strm__; let s = strm__ in store c; decimal_part s
 123     | Some ('e' | 'E') ->
 124         Stream.junk strm__; let s = strm__ in store 'E'; exponent_part s
 125     | _ -> Some (Float (float_of_string (get_string ())))
 126   and exponent_part (strm__ : _ Stream.t) =
 127     match Stream.peek strm__ with
 128       Some ('+' | '-' as c) ->
 129         Stream.junk strm__; let s = strm__ in store c; end_exponent_part s
 130     | _ -> end_exponent_part strm__
 131   and end_exponent_part (strm__ : _ Stream.t) =
 132     match Stream.peek strm__ with
 133       Some ('0'..'9' as c) ->
 134         Stream.junk strm__; let s = strm__ in store c; end_exponent_part s
 135     | _ -> Some (Float (float_of_string (get_string ())))
 136   and string (strm__ : _ Stream.t) =
 137     match Stream.peek strm__ with
 138       Some '"' -> Stream.junk strm__; get_string ()
 139     | Some '\\' ->
 140         Stream.junk strm__;
 141         let c =
 142           try escape strm__ with
 143             Stream.Failure -> raise (Stream.Error "")
 144         in
 145         let s = strm__ in store c; string s
 146     | Some c -> Stream.junk strm__; let s = strm__ in store c; string s
 147     | _ -> raise Stream.Failure
 148   and char (strm__ : _ Stream.t) =
 149     match Stream.peek strm__ with
 150       Some '\\' ->
 151         Stream.junk strm__;
 152         begin try escape strm__ with
 153           Stream.Failure -> raise (Stream.Error "")
 154         end
 155     | Some c -> Stream.junk strm__; c
 156     | _ -> raise Stream.Failure
 157   and escape (strm__ : _ Stream.t) =
 158     match Stream.peek strm__ with
 159       Some 'n' -> Stream.junk strm__; '\n'
 160     | Some 'r' -> Stream.junk strm__; '\r'
 161     | Some 't' -> Stream.junk strm__; '\t'
 162     | Some ('0'..'9' as c1) ->
 163         Stream.junk strm__;
 164         begin match Stream.peek strm__ with
 165           Some ('0'..'9' as c2) ->
 166             Stream.junk strm__;
 167             begin match Stream.peek strm__ with
 168               Some ('0'..'9' as c3) ->
 169                 Stream.junk strm__;
 170                 Char.chr
 171                   ((Char.code c1 - 48) * 100 + (Char.code c2 - 48) * 10 +
 172                      (Char.code c3 - 48))
 173             | _ -> raise (Stream.Error "")
 174             end
 175         | _ -> raise (Stream.Error "")
 176         end
 177     | Some c -> Stream.junk strm__; c
 178     | _ -> raise Stream.Failure
 179   and maybe_comment (strm__ : _ Stream.t) =
 180     match Stream.peek strm__ with
 181       Some '*' ->
 182         Stream.junk strm__; let s = strm__ in comment s; next_token s
 183     | _ -> Some (keyword_or_error '(')
 184   and comment (strm__ : _ Stream.t) =
 185     match Stream.peek strm__ with
 186       Some '(' -> Stream.junk strm__; maybe_nested_comment strm__
 187     | Some '*' -> Stream.junk strm__; maybe_end_comment strm__
 188     | Some c -> Stream.junk strm__; comment strm__
 189     | _ -> raise Stream.Failure
 190   and maybe_nested_comment (strm__ : _ Stream.t) =
 191     match Stream.peek strm__ with
 192       Some '*' -> Stream.junk strm__; let s = strm__ in comment s; comment s
 193     | Some c -> Stream.junk strm__; comment strm__
 194     | _ -> raise Stream.Failure
 195   and maybe_end_comment (strm__ : _ Stream.t) =
 196     match Stream.peek strm__ with
 197       Some ')' -> Stream.junk strm__; ()
 198     | Some '*' -> Stream.junk strm__; maybe_end_comment strm__
 199     | Some c -> Stream.junk strm__; comment strm__
 200     | _ -> raise Stream.Failure
 201   in
 202   fun input -> Stream.from (fun count -> next_token input)