lv6lexer.mll

{

(*
la gestion des no de ligne est faite dans Lxm 
pour viter les dpendances boucles entre Lexer et Parser
*)
open Lv6parser

(* rcupration d'erreur avec correction line/col *)
exception Lexical_error of string * Lxm.t

let handle_lexical_error fn lexbuf = (
        let lxm = Lxm.make (lexbuf ) in
        try
                fn lexbuf
        with Lexical_error(msg, _) ->
                raise(Lexical_error(msg, lxm))
)
let unget_lexbuf lb =
  lb.Lexing.lex_curr_pos <- lb.Lexing.lex_curr_pos - 1

(* table des mots-cl *)
let keywords = Hashtbl.create 50 ;;
Hashtbl.add keywords "extern"     (function x -> TK_EXTERN x) ;;
Hashtbl.add keywords "unsafe"     (function x -> TK_UNSAFE x) ;;

Hashtbl.add keywords "and"        (function x -> TK_AND x) ;;
Hashtbl.add keywords "assert"     (function x -> TK_ASSERT x) ;;
Hashtbl.add keywords "bool"       (function x -> TK_BOOL x) ;;
Hashtbl.add keywords "const"      (function x -> TK_CONST x) ;;
Hashtbl.add keywords "current"    (function x -> TK_CURRENT x) ;;
Hashtbl.add keywords "div"        (function x -> TK_DIV x) ;;
Hashtbl.add keywords "else"       (function x -> TK_ELSE x) ;;
Hashtbl.add keywords "enum"       (function x -> TK_ENUM x) ;;
Hashtbl.add keywords "function"   (function x -> TK_FUNCTION x) ;;
Hashtbl.add keywords "false"      (function x -> TK_FALSE x) ;;
Hashtbl.add keywords "if"         (function x -> TK_IF x) ;;
Hashtbl.add keywords "int"        (function x -> TK_INT x) ;;
Hashtbl.add keywords "let"        (function x -> TK_LET x) ;;
Hashtbl.add keywords "mod"        (function x -> TK_MOD x) ;;
Hashtbl.add keywords "node"       (function x -> TK_NODE x) ;;
Hashtbl.add keywords "not"        (function x -> TK_NOT x) ;;
Hashtbl.add keywords "operator"   (function x -> TK_OPERATOR x) ;;
Hashtbl.add keywords "or"         (function x -> TK_OR x) ;;
Hashtbl.add keywords "nor"        (function x -> TK_NOR x) ;;
Hashtbl.add keywords "fby"        (function x -> TK_FBY x) ;;
Hashtbl.add keywords "pre"        (function x -> TK_PRE x) ;;
Hashtbl.add keywords "real"       (function x -> TK_REAL x) ;;
Hashtbl.add keywords "returns"    (function x -> TK_RETURNS x) ;;
Hashtbl.add keywords "step"       (function x -> TK_STEP x) ;;
Hashtbl.add keywords "struct"     (function x -> TK_STRUCT x) ;;
Hashtbl.add keywords "tel"        (function x -> TK_TEL x) ;;
Hashtbl.add keywords "type"       (function x -> TK_TYPE x) ;;
Hashtbl.add keywords "then"       (function x -> TK_THEN x) ;;
Hashtbl.add keywords "true"       (function x -> TK_TRUE x) ;;
Hashtbl.add keywords "var"        (function x -> TK_VAR x) ;;
Hashtbl.add keywords "when"       (function x -> TK_WHEN x) ;;
Hashtbl.add keywords "with"       (function x -> TK_WITH x) ;;
Hashtbl.add keywords "xor"        (function x -> TK_XOR x) ;;
Hashtbl.add keywords "model"      (function x -> TK_MODEL x) ;;
Hashtbl.add keywords "package"    (function x -> TK_PACKAGE x) ;;
Hashtbl.add keywords "needs"      (function x -> TK_NEEDS x) ;;
Hashtbl.add keywords "provides"   (function x -> TK_PROVIDES x) ;;
Hashtbl.add keywords "uses"       (function x -> TK_USES x) ;;
Hashtbl.add keywords "is"         (function x -> TK_IS x) ;;
Hashtbl.add keywords "body"       (function x -> TK_BODY x) ;;
Hashtbl.add keywords "end"        (function x -> TK_END x) ;;
Hashtbl.add keywords "include"    (function x -> TK_INCLUDE x) ;;
Hashtbl.add keywords "merge"      (function x -> TK_MERGE x) ;;

let is_a_keyword ( s: string ) = (
        try
                let res = Hashtbl.find keywords s in (Some res)
        with Not_found -> ( None )
)

let token_code tk = (
        match tk with
                  TK_EOF           -> ("TK_EOF" , Lxm.dummy "eof")
                | TK_ERROR     lxm -> ("TK_ERROR" , lxm)
                | TK_EXTERN    lxm -> ("TK_EXTERN" , lxm)
                | TK_UNSAFE    lxm -> ("TK_UNSAFE" , lxm)
                | TK_AND       lxm -> ("TK_AND" , lxm)
                | TK_ARROW     lxm -> ("TK_ARROW" , lxm)
                | TK_ASSERT    lxm -> ("TK_ASSERT" , lxm)
                | TK_BAR       lxm -> ("TK_BAR" , lxm)
                | TK_BOOL      lxm -> ("TK_BOOL" , lxm)
                | TK_CDOTS     lxm -> ("TK_CDOTS" , lxm)
                | TK_CLOSE_BRACKET lxm -> ("TK_CLOSE_BRACKET" , lxm)
                | TK_CLOSE_BRACE   lxm -> ("TK_CLOSE_BRACE" , lxm)
                | TK_CLOSE_PAR     lxm -> ("TK_CLOSE_PAR" , lxm)
                | TK_CLOSE_STATIC_PAR  lxm -> ("TK_CLOSE_STATIC_PAR" , lxm)
                | TK_COLON     lxm -> ("TK_COLON" , lxm)
                | TK_COMA      lxm -> ("TK_COMA" , lxm)
                | TK_CONST     lxm -> ("TK_CONST" , lxm)
                | TK_CURRENT   lxm -> ("TK_CURRENT" , lxm)
                | TK_DIV       lxm -> ("TK_DIV" , lxm)
                | TK_DIESE     lxm -> ("TK_DIESE" , lxm)
                | TK_DOT       lxm -> ("TK_DOT" , lxm)
                | TK_ELSE      lxm -> ("TK_ELSE" , lxm)
                | TK_EQ        lxm -> ("TK_EQ" , lxm)
                | TK_ENUM      lxm -> ("TK_ENUM" , lxm)
                | TK_FALSE     lxm -> ("TK_FALSE" , lxm)
                | TK_FUNCTION  lxm -> ("TK_FUNCTION" , lxm)
                | TK_GT        lxm -> ("TK_GT" , lxm)
                | TK_GTE       lxm -> ("TK_GTE" , lxm)
                | TK_HAT       lxm -> ("TK_HAT" , lxm)
                | TK_ICONST    lxm -> ("TK_ICONT" , lxm)
                | TK_IDENT     lxm -> ("TK_IDENT" , lxm)
                | TK_LONGIDENT lxm -> ("TK_LONGIDENT" , lxm)
                | TK_STRING  lxm -> ("TK_STRING" , lxm)
                | TK_IF        lxm -> ("TK_IF" , lxm)
                | TK_IMPL      lxm -> ("TK_IMPL" , lxm)
                | TK_INT       lxm -> ("TK_INT" , lxm)
                | TK_LET       lxm -> ("TK_LET" , lxm)
                | TK_LT        lxm -> ("TK_LT" , lxm)
                | TK_LTE       lxm -> ("TK_LTE" , lxm)
                | TK_MINUS     lxm -> ("TK_MINUS" , lxm)
                | TK_MOD       lxm -> ("TK_MOD" , lxm)
                | TK_NEQ       lxm -> ("TK_NEQ" , lxm)
                | TK_NODE      lxm -> ("TK_NODE" , lxm)
                | TK_NOR       lxm -> ("TK_NOR" , lxm)
                | TK_NOT       lxm -> ("TK_NOT" , lxm)
                | TK_OPEN_BRACKET lxm -> ("TK_OPEN_BRACKET" , lxm)
                | TK_OPEN_BRACE   lxm -> ("TK_OPEN_BRACE" , lxm)
                | TK_OPEN_PAR     lxm -> ("TK_OPEN_PAR" , lxm)
                | TK_OPEN_STATIC_PAR  lxm -> ("TK_OPEN_STATIC_PAR" , lxm)
                | TK_OPERATOR        lxm -> ("TK_OPERATOR" , lxm)
                | TK_OR        lxm -> ("TK_OR" , lxm)
                | TK_PCENT     lxm -> ("TK_PCENT" , lxm)
                | TK_PLUS      lxm -> ("TK_PLUS" , lxm)
                | TK_POWER     lxm -> ("TK_POWER" , lxm)
                | TK_FBY       lxm -> ("TK_FBY" , lxm)
                | TK_PRE       lxm -> ("TK_PRE" , lxm)
                | TK_RCONST    lxm -> ("TK_RCONST" , lxm)
                | TK_REAL      lxm -> ("TK_REAL" , lxm)
                | TK_RETURNS   lxm -> ("TK_RETURNS" , lxm)
                | TK_SEMICOL   lxm -> ("TK_SEMICOL" , lxm)
                | TK_STAR      lxm -> ("TK_STAR" , lxm)
                | TK_SLASH     lxm -> ("TK_SLASH" , lxm)
                | TK_STEP      lxm -> ("TK_STEP" , lxm)
                | TK_STRUCT    lxm -> ("TK_STRUCT" , lxm)
                | TK_TEL       lxm -> ("TK_TEL" , lxm)
                | TK_THEN      lxm -> ("TK_THEN" , lxm)
                | TK_TRUE      lxm -> ("TK_TRUE" , lxm)
                | TK_TYPE      lxm -> ("TK_TYPE" , lxm)
                | TK_VAR       lxm -> ("TK_VAR" , lxm)
                | TK_WHEN      lxm -> ("TK_WHEN" , lxm)
                | TK_MERGE      lxm -> ("TK_MERGE" , lxm)
                | TK_WITH      lxm -> ("TK_WITH" , lxm)
                | TK_XOR       lxm -> ("TK_XOR" , lxm)
                | TK_MODEL     lxm -> ("TK_MODEL" , lxm)
                | TK_PACKAGE   lxm -> ("TK_PACKAGE" , lxm)
                | TK_NEEDS     lxm -> ("TK_NEEDS" , lxm)
                | TK_PROVIDES  lxm -> ("TK_PROVIDES" , lxm)
                | TK_USES      lxm -> ("TK_USES" , lxm)
                | TK_IS        lxm -> ("TK_IS" , lxm)
                | TK_BODY      lxm -> ("TK_BODY" , lxm)
                | TK_END       lxm -> ("TK_END" , lxm)
                | TK_INCLUDE   lxm -> ("TK_INCLUDE" , lxm)
)

}

(* Pour simplifier les rgles des constantes numriques *)

let chiffre = ['0'-'9']
let chiffres = ['0'-'9'] +
let exposant = ( 'e' | 'E' ) ( '+' | '-' )? chiffres

rule lexer = parse
     eof
                { TK_EOF }
(* saute les blancs *)
(* saute les blancs *)
  | [' ' '\013' '\009' '\012'] +
                { lexer lexbuf }
(* retour  la ligne *)
        | '\n'
                {
                        Lxm.new_line ( lexbuf );
                        lexer lexbuf    
                }
(* commentaire parenths *)
        | "(*"
                {
                        handle_lexical_error comment_par lexbuf;
                        lexer lexbuf
                }
(* commentaire parenths bis *)
        | "/*"
                {
                        handle_lexical_error comment_par_bis lexbuf;
                        lexer lexbuf
                }
(* commentaire en ligne *)
        | "--"
                {
                        handle_lexical_error comment_line lexbuf;
                        lexer lexbuf
                }

(* mots-cl dbutant par un sparateur (prioritaires) *)
        | "->" { TK_ARROW ( Lxm.make lexbuf ) }
        | "=>" { TK_IMPL ( Lxm.make lexbuf ) }
        | "<=" { TK_LTE ( Lxm.make lexbuf ) }
        | "<>" { TK_NEQ ( Lxm.make lexbuf ) }
        | ">=" { TK_GTE ( Lxm.make lexbuf ) }
        | ".." { TK_CDOTS ( Lxm.make lexbuf ) }
        | "**" { TK_POWER ( Lxm.make lexbuf ) }
        (* parentheses des params statiques ... bof *)
        | "<<" { TK_OPEN_STATIC_PAR  ( Lxm.make lexbuf ) }
        | ">>" { TK_CLOSE_STATIC_PAR ( Lxm.make lexbuf ) }
(* sparateurs simples *)
        | "+"  { TK_PLUS ( Lxm.make lexbuf ) }
        | "^"  { TK_HAT ( Lxm.make lexbuf ) }
        | "#"  { TK_DIESE ( Lxm.make lexbuf ) }
        | "-"  { TK_MINUS ( Lxm.make lexbuf ) }
        | "/"  { TK_SLASH ( Lxm.make lexbuf ) }
        | "%"  { TK_PCENT ( Lxm.make lexbuf ) }
        | "*"  { TK_STAR ( Lxm.make lexbuf ) }
        | "|"  { TK_BAR ( Lxm.make lexbuf ) }
        | "="  { TK_EQ ( Lxm.make lexbuf ) }

        | "."  { TK_DOT ( Lxm.make lexbuf ) }
(*      | "\"" { TK_QUOTE ( Lxm.make lexbuf ) } *)
        | ","  { TK_COMA ( Lxm.make lexbuf ) }
        | ";"  { TK_SEMICOL ( Lxm.make lexbuf ) }
        | ":"  { TK_COLON ( Lxm.make lexbuf ) }
        | "("  { TK_OPEN_PAR ( Lxm.make lexbuf ) }
        | ")"  { TK_CLOSE_PAR ( Lxm.make lexbuf ) }
        | "{"  { TK_OPEN_BRACE ( Lxm.make lexbuf ) }
        | "}"  { TK_CLOSE_BRACE ( Lxm.make lexbuf ) }
        | "["  { TK_OPEN_BRACKET ( Lxm.make lexbuf ) }
        | "]"  { TK_CLOSE_BRACKET ( Lxm.make lexbuf ) }
        | "<"  { TK_LT ( Lxm.make lexbuf ) }
        | ">"  { TK_GT ( Lxm.make lexbuf ) }
(* identificateur point *)
        | ['_' 'A'-'Z' 'a'-'z'] ['A'-'Z' 'a'-'z' '\'' '_' '0'-'9'] *
                ':' ':'
          ['_' 'A'-'Z' 'a'-'z'] ['A'-'Z' 'a'-'z' '\'' '_' '0'-'9'] *
                {
                        let lxm = Lxm.make lexbuf in
                        TK_LONGIDENT (lxm)
                }

(* une chaine quelconque *)
         | "\""  [^ '\"']* "\""
            { 
                        let lxm = Lxm.make_string lexbuf in
                          TK_STRING (lxm)
            }
(* constantes entires *)
        |  chiffres  { TK_ICONST (Lxm.make lexbuf ) }


(* constantes relles *)
        |  chiffres (exposant) { TK_RCONST (Lxm.make lexbuf ) }

        |  chiffres '.' chiffres (exposant)? 
            { TK_RCONST (Lxm.make lexbuf ) }

        |  chiffres '.'  (exposant)
            { TK_RCONST (Lxm.make lexbuf ) }

        |  '.' chiffres (exposant)? { TK_RCONST (Lxm.make lexbuf ) }

(* Pour dsambiguer le .. (slice)  *)
        |  chiffres  '.'[^'.'] {
             unget_lexbuf lexbuf;
             TK_RCONST (Lxm.make lexbuf)
           }

(* mot-cl ou identificateur *)
        | ['_' 'A'-'Z' 'a'-'z'] ['A'-'Z' 'a'-'z' '\'' '_' '0'-'9'] *
                {
                        let lxm = Lxm.make lexbuf in
                        let x = is_a_keyword ( Lxm.str lxm ) in
                        match x with
                                  None -> TK_IDENT ( lxm )
                                | Some keyw -> keyw ( lxm ) 
                }
        | _    { TK_ERROR ( Lxm.make lexbuf ) }

and comment_par = parse
          "*)" 
                { }
        | "\n" 
                {
                        Lxm.new_line ( lexbuf );
                        comment_par lexbuf      
                }
        | eof
                {
                        raise(Lexical_error("unterminated comment", 
                                            Lxm.dummy "unterminated comment"))
                }
        |       _
                { comment_par lexbuf }

and comment_par_bis = parse
          "*/" 
                { }
        | "\n" 
                {
                        Lxm.new_line ( lexbuf );
                        comment_par_bis lexbuf  
                }
        | eof
                {
                        raise(Lexical_error("unterminated comment", 
                                            Lxm.dummy "unterminated comment"))
                }
        |       _
                { comment_par_bis lexbuf }

and comment_line = parse
        '\n'
                {
                        Lxm.new_line ( lexbuf );
                }
        | eof
                { }
        |       _
                { comment_line lexbuf }