--- /dev/null
+(*
+ * Copyright (C) 2009 Citrix Ltd.
+ * Author Prashanth Mundkur <firstname.lastname@citrix.com>
+ *
+ * This program is free software; you can redistribute it and/or modify
+ * it under the terms of the GNU Lesser General Public License as published
+ * by the Free Software Foundation; version 2.1 only. with the special
+ * exception on linking described in file LICENSE.
+ *
+ * This program is distributed in the hope that it will be useful,
+ * but WITHOUT ANY WARRANTY; without even the implied warranty of
+ * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+ * GNU Lesser General Public License for more details.
+ *)
+
+open Syntax
+
+let generate defn_list f =
+ Printf.printf "Generating conversions for %d definitions in %s.\n" (List.length defn_list) f
--- /dev/null
+(*
+ * Copyright (C) 2009 Citrix Ltd.
+ * Author Prashanth Mundkur <firstname.lastname@citrix.com>
+ *
+ * This program is free software; you can redistribute it and/or modify
+ * it under the terms of the GNU Lesser General Public License as published
+ * by the Free Software Foundation; version 2.1 only. with the special
+ * exception on linking described in file LICENSE.
+ *
+ * This program is distributed in the hope that it will be useful,
+ * but WITHOUT ANY WARRANTY; without even the implied warranty of
+ * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+ * GNU Lesser General Public License for more details.
+ *)
+
+open Syntax
+open Parser
+open Lexing
+
+let show_syntax_error e l =
+ let loc = Printf.sprintf "%s at line %d, char %d"
+ l.pos_fname l.pos_lnum (l.pos_cnum - l.pos_bol) in
+ let msg =
+ match e with
+ | Illegal_character c -> Printf.sprintf "Illegal character %c" c
+ | Invalid_ident s -> Printf.sprintf "Invalid/unsupported identifier %s" s
+ | Unmatched_comment -> Printf.sprintf "Unmatched comment"
+ | Unterminated_comment -> Printf.sprintf "Unterminated comment"
+ in
+ Printf.printf "%s: %s\n" loc msg;
+ exit 1
+
+let show_parse_error lexbuf =
+ let lxm = lexeme lexbuf in
+ let loc = Printf.sprintf "%s at line %d, char %d"
+ lexbuf.lex_curr_p.pos_fname lexbuf.lex_curr_p.pos_lnum
+ (lexbuf.lex_curr_p.pos_cnum - lexbuf.lex_curr_p.pos_bol) in
+ (match lxm with
+ | "" -> Printf.printf "%s: parsing error\n" loc
+ | _ -> Printf.printf "%s: parsing error at \"%s\"\n" loc lxm);
+ exit 1
+
+let parse_file file =
+ let f = open_in file in
+ let lexbuf = Lexing.from_channel f in
+ try
+ Lexer.init lexbuf file;
+ Parser.defn_list Lexer.main lexbuf
+ with
+ | Syntax_error (e, l) ->
+ show_syntax_error e l
+ | Parsing.Parse_error ->
+ show_parse_error lexbuf
+
+let default_output_filename f =
+ let dir, base = Filename.dirname f, Filename.basename f in
+ let stem = Filename.chop_extension base in
+ Filename.concat dir (stem ^ "_json_conv.ml")
+
+let gen_code defn_list f =
+ Codegen.generate defn_list f
+
+let () =
+ let input = ref "" in
+ let output = ref "" in
+
+ (* parse argv *)
+ let larg = [
+ ("-i", Arg.Set_string input, "input file");
+ ("-o", Arg.Set_string output, "output file");
+ ] in
+ let usage_msg = Printf.sprintf "%s -i <file> [-o <file>]" Sys.argv.(0) in
+ Arg.parse larg (fun s -> ()) usage_msg;
+
+ if !output = "" then output := default_output_filename !input;
+
+ match !input with
+ | "" -> Printf.printf "%s\n" usage_msg
+ | file -> gen_code (parse_file file) !output
--- /dev/null
+(*
+ * Copyright (C) 2009 Citrix Ltd.
+ * Author Prashanth Mundkur <firstname.lastname@citrix.com>
+ *
+ * This program is free software; you can redistribute it and/or modify
+ * it under the terms of the GNU Lesser General Public License as published
+ * by the Free Software Foundation; version 2.1 only. with the special
+ * exception on linking described in file LICENSE.
+ *
+ * This program is distributed in the hope that it will be useful,
+ * but WITHOUT ANY WARRANTY; without even the implied warranty of
+ * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+ * GNU Lesser General Public License for more details.
+ *)
+
+{
+
+open Lexing
+open Syntax
+open Parser
+
+let comment_depth = ref 0
+let comment_start = ref dummy_pos
+
+let line_num = ref 0
+
+let init lexbuf fname =
+ lexbuf.lex_curr_p <- { pos_fname = fname;
+ pos_lnum = 1;
+ pos_bol = 0;
+ pos_cnum = 0 }
+
+let raise_syntax_error e loc =
+ raise (Syntax_error (e, loc))
+
+}
+
+let letter = ['A'-'Z' 'a'-'z']
+
+(* The handling of '.' is a bit of a hack for now; not sure if it's
+ really needed. *)
+let ident_first = letter | '_'
+let ident_others = letter | ['0'-'9'] | '_' | '\'' | '.'
+let ident = ident_first ident_others*
+
+rule main = parse
+| [' ' '\009' '\012' '\r']+
+ { main lexbuf }
+| ['\n']
+ { new_line lexbuf;
+ main lexbuf
+ }
+| "*/"
+ { raise_syntax_error Unmatched_comment (lexeme_start_p lexbuf) }
+| "/*"
+ { comment_depth := 1;
+ comment_start := lexeme_start_p lexbuf;
+ comment lexbuf;
+ main lexbuf
+ }
+
+| eof { EOF }
+| "=" { EQUAL }
+| "*" { STAR }
+| ";" { SEMI }
+| ";;" { SEMISEMI }
+| ":" { COLON }
+| "|" { BAR }
+
+| "{" { LBRACE }
+| "}" { RBRACE }
+| "(" { LPAREN }
+| ")" { RPAREN }
+| "[" { LBRACK }
+| "]" { RBRACK }
+
+| "type" { TYPE }
+| "and" { AND }
+| "mutable" { MUTABLE }
+| "of" { OF }
+
+(* hardcoded type constructors; this could be handled more
+ intelligently later. *)
+
+| "option" { OPTION }
+| "list" { LIST }
+| "array" { ARRAY }
+
+| "string" { STRING }
+| "int" { INT }
+| "Int64.t" { INT64 }
+| "bool" { BOOL }
+
+(* general identifiers. we could handle the '.' here. *)
+| ident
+ { let str = lexeme lexbuf in
+ match String.get str 0 with
+ | 'A' .. 'Z' -> UIDENT str
+ | 'a' .. 'z' -> LIDENT str
+ | _ -> raise_syntax_error (Invalid_ident str) (lexeme_start_p lexbuf)
+ }
+| _
+ { raise_syntax_error (Illegal_character (lexeme_char lexbuf 0)) (lexeme_start_p lexbuf) }
+
+
+and comment = parse
+| "/*"
+ { incr comment_depth;
+ comment lexbuf
+ }
+| "*/"
+ { decr comment_depth;
+ if !comment_depth > 0 then comment lexbuf
+ }
+| ['\n']
+ { new_line lexbuf;
+ comment lexbuf
+ }
+| eof
+ { raise_syntax_error Unterminated_comment !comment_start }
+| _
+ { comment lexbuf }
--- /dev/null
+/*
+ * Copyright (C) 2009 Citrix Ltd.
+ * Author Prashanth Mundkur <firstname.lastname@citrix.com>
+ *
+ * This program is free software; you can redistribute it and/or modify
+ * it under the terms of the GNU Lesser General Public License as published
+ * by the Free Software Foundation; version 2.1 only. with the special
+ * exception on linking described in file LICENSE.
+ *
+ * This program is distributed in the hope that it will be useful,
+ * but WITHOUT ANY WARRANTY; without even the implied warranty of
+ * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+ * GNU Lesser General Public License for more details.
+ */
+
+
+%{
+
+open Syntax
+
+let raise_syntax_error e pos =
+ raise (Syntax_error (e, pos))
+
+%}
+
+/* keywords */
+%token TYPE AND MUTABLE OF
+%token OPTION LIST ARRAY STRING INT INT64 BOOL
+
+%token LBRACE RBRACE LPAREN RPAREN LBRACK RBRACK
+%token EQUAL STAR SEMI SEMISEMI COLON BAR
+%token EOF
+
+%token <string> UIDENT LIDENT
+
+%start defn_list
+
+%type <Syntax.type_defn list> defn_list
+
+%%
+
+defn_list:
+| defns EOF
+ { List.rev $1 }
+;
+
+defns:
+| defns top_defn_term
+ { $2 :: $1 }
+| /* epsilon */
+ { [] }
+;
+
+top_defn_term:
+| defn semi
+ { $1 }
+
+defn:
+| TYPE eqn
+ { [ $2 ] }
+
+| TYPE eqn AND defn_parts
+ { $2 :: (List.rev $4) }
+
+defn_parts:
+| defn_parts AND eqn
+ { $3 :: $1 }
+| eqn
+ { [ $1 ] }
+
+eqn:
+| LIDENT EQUAL repn
+ { ($1, $3) }
+;
+
+semi:
+| SEMISEMI
+ {}
+| /* epsilon */
+ {}
+
+repn:
+| expr
+ { $1 }
+| expr STAR tuple
+ { C_prod ($1 :: (List.rev $3)) }
+| record
+ { C_record (List.rev $1) }
+| variant
+ { C_variant (List.rev $1) }
+
+expr:
+| LPAREN expr RPAREN
+ { $2 }
+| LPAREN expr STAR tuple RPAREN
+ { C_prod ($2 :: (List.rev $4)) }
+| expr OPTION
+ { C_option $1 }
+| expr LIST
+ { C_list $1 }
+| expr ARRAY
+ { C_array $1 }
+| base
+ { C_base $1 }
+
+tuple:
+| tuple STAR expr
+ { $3 :: $1 }
+| expr
+ { [ $1 ] }
+
+base:
+| STRING { B_string }
+| INT { B_int }
+| INT64 { B_int64 }
+| BOOL { B_bool }
+| LIDENT { B_ident $1 }
+/* TODO:
+| UIDENT { raise_syntax_error (Invalid_ident $1) }
+*/
+
+record:
+| LBRACE field_decls RBRACE
+ { $2 }
+
+field_decls:
+| field_decls SEMI field_decl
+ { $3 :: $1 }
+| /* epsilon */
+ { [] }
+
+field_decl:
+| LIDENT COLON expr
+ { ($1, $3) }
+| MUTABLE LIDENT COLON expr
+ { ($2, $4) }
+
+variant:
+| variant BAR constr
+ { $3 :: $1 }
+| constr
+ { [ $1 ] }
+| /* epsilon */
+ { [] }
+
+constr:
+| UIDENT
+ { CD_prod ($1, []) }
+| UIDENT OF expr
+ { CD_prod ($1, [ $3 ]) }
+
+| UIDENT OF expr STAR tuple
+ { CD_prod ($1, ($3 :: (List.rev $5))) }
+
--- /dev/null
+(*
+ * Copyright (C) 2009 Citrix Ltd.
+ * Author Prashanth Mundkur <firstname.lastname@citrix.com>
+ *
+ * This program is free software; you can redistribute it and/or modify
+ * it under the terms of the GNU Lesser General Public License as published
+ * by the Free Software Foundation; version 2.1 only. with the special
+ * exception on linking described in file LICENSE.
+ *
+ * This program is distributed in the hope that it will be useful,
+ * but WITHOUT ANY WARRANTY; without even the implied warranty of
+ * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+ * GNU Lesser General Public License for more details.
+ *)
+
+type syntax_error =
+ | Illegal_character of char
+ | Invalid_ident of string
+ | Unmatched_comment
+ | Unterminated_comment
+
+exception Syntax_error of syntax_error * Lexing.position
+
+type base_type =
+ | B_string
+ | B_int
+ | B_int64
+ | B_bool
+ | B_ident of string
+
+type complex_type =
+ | C_base of base_type
+ | C_option of complex_type
+ | C_list of complex_type
+ | C_array of complex_type
+ | C_prod of complex_type list
+ | C_record of (string * complex_type) list
+ | C_variant of constr_decl list
+
+and constr_decl =
+ | CD_prod of string * complex_type list
+
+type type_defn = (string * complex_type) list
+
projects / xenclient / toolstack.git / commitdiff