Re : [Caml-list] camlp4 stream parser syntax

[Matthieu Wipliez <mwipliez@yahoo.fr>]

[-- Attachment #1: Type: text/plain, Size: 1262 bytes --]

Joel asked me the parser so I gave it to him, but maybe it can be of use for others, so here it is.
Apart from the code specific to the application, it gives a good example of a complete Camlp4 lexer/parser for a language.

Note that for the lexer I started from a custom lexer made by Pietro Abate ( https://www.cduce.org/~abate/how-add-a-custom-lexer-camlp4 ) from the cduce lexer.

Cheers,
Matthieu



----- Message d'origine ----
> Swings and roundabouts, IMHO. Camlp4 is higher level, more capable and the 
> syntax is clearer but the documentation is so poor that I have given up every 
> time I have tried to use it either because the default lexer was insufficient 
> or because I could not figure out how to extract the necessary data from the 
> OCaml grammar.
> 
> Matthieu's example looks fantastic though...
> 
> -- 
> Dr Jon Harrop, Flying Frog Consultancy Ltd.
> http://www.ffconsultancy.com/?e
> 
> _______________________________________________
> Caml-list mailing list. Subscription management:
> http://yquem.inria.fr/cgi-bin/mailman/listinfo/caml-list
> Archives: http://caml.inria.fr
> Beginner's list: http://groups.yahoo.com/group/ocaml_beginners
> Bug reports: http://caml.inria.fr/bin/caml-bugs



      

[-- Attachment #2: cal_parser.ml --]
[-- Type: application/octet-stream, Size: 27492 bytes --]

(*****************************************************************************)
(* Cal2C                                                                     *)
(* Copyright (c) 2007-2008, IETR/INSA of Rennes.                             *)
(* All rights reserved.                                                      *)
(*                                                                           *)
(* This software is governed by the CeCILL-B license under French law and    *)
(* abiding by the rules of distribution of free software. You can  use,      *)
(* modify and/ or redistribute the software under the terms of the CeCILL-B  *)
(* license as circulated by CEA, CNRS and INRIA at the following URL         *)
(* "http://www.cecill.info".                                                 *)
(*                                                                           *)
(* Matthieu WIPLIEZ <Matthieu.Wipliez@insa-rennes.fr                         *)
(*****************************************************************************)

open Cal2c_util
open Printf

let time = ref 0.

(* Camlp4 stuff *)
module Camlp4Loc = Camlp4.Struct.Loc
module Lexer = Cal_lexer.Make(Camlp4Loc)
module Gram = Camlp4.Struct.Grammar.Static.Make(Lexer)

(** [convert_loc _loc] returns a [Loc.t] from a [Camlp4.Struct.Loc.t]. *)
let convert_loc _loc =
	let (file_name, start_line, start_bol, start_off,
		stop_line, stop_bol, stop_off, _) = Camlp4Loc.to_tuple _loc in
	{
		Loc.file_name = file_name;
		Loc.start = {Loc.line = start_line; Loc.bol = start_bol; Loc.off = start_off };
		Loc.stop = {Loc.line = stop_line; Loc.bol = stop_bol; Loc.off = stop_off };
	}

open Lexer

(*****************************************************************************)
(*****************************************************************************)
(*****************************************************************************)

(** [bop _loc e1 op e2] returns [Calast.ExprBOp (convert_loc _loc, e1, op, e2)] *)
let bop _loc e1 op e2 = Calast.ExprBOp (convert_loc _loc, e1, op, e2)

(** [uop _loc e1 op e2] returns [Calast.ExprUOp (convert_loc _loc, e, op)] *)
let uop _loc op e = Calast.ExprUOp (convert_loc _loc, op, e)

(*****************************************************************************)
(*****************************************************************************)
(*****************************************************************************)
(* Type definitions *)

(** Defines different kinds of type attributes. *)
type type_attr =
	| ExprAttr of Calast.expr (** A type attribute that references an expression. *)
	| TypeAttr of Calast.type_def (** A type attribute that references a type. *)

(** [find_size _loc typeAttrs] attemps to find a [type_attr] named ["size"]
 that is an [ExprAttr]. The function returns a [Calast.expr]. *)
let find_size _loc typeAttrs =
	let attr = 
		List.assoc "size" typeAttrs
	in
  match attr with
		| ExprAttr e -> e
		| _ ->
		  Asthelper.failwith (convert_loc _loc) "size must be an expression!"

(** [find_type _loc typeAttrs] attemps to find a [type_attr] named ["type"]
 that is an [TypeAttr]. The function returns a [Calast.type_def]. *)
let find_type _loc typeAttrs =
	let attr = 
		List.assoc "type" typeAttrs
	in
  match attr with
		| TypeAttr t -> t
		| _ -> Asthelper.failwith (convert_loc _loc) "type must be a type!"

(** [find_size_or_default _loc typeAttrs] attemps to find a [type_attr]
 named ["size"] that is an [ExprAttr]. If not found, the function returns the
 default size given as an [int]. *)
let find_size_or_default _loc typeAttrs default =
	(* size in bits *)
	try
		find_size _loc typeAttrs
	with Not_found ->
  	(* no size information found, assuming "default" bits. *)
  	Calast.ExprInt (convert_loc _loc, default)

(** [type_of_typeDef _loc name typeAttrs] returns a [Calast.type_def] from a
 name and type attributes that were parsed. *)
let type_of_typeDef _loc name typeAttrs =
	match name with
		| "bool" -> Calast.TypeBool
		| "int" -> Calast.TypeInt (find_size_or_default _loc typeAttrs 32)
		| "list" ->
			Asthelper.failwith (convert_loc _loc)
				"The type \"list\" is deprecated. Please use \"List\"."
		| "List" ->
			(* get a type *)
			let t =
				try
					find_type _loc typeAttrs
			  with Not_found ->
			    Asthelper.failwith (convert_loc _loc)
						"RVC-CAL requires that all lists have a type."
			in
			
			(* and a size in number of elements *)
			let size =
				try
					find_size _loc typeAttrs
				with Not_found ->
			    Asthelper.failwith (convert_loc _loc)
						"RVC-CAL requires that all lists have a size."
			in
			Calast.TypeList (t, size)
    | "string" ->
			Asthelper.failwith (convert_loc _loc)
				"The type \"string\" is deprecated. Please use \"String\"."
		| "String" -> Calast.TypeStr
		| "uint" -> Calast.TypeUint (find_size_or_default _loc typeAttrs 32)
		| t ->
			let message = "The type \"" ^ t ^ "\" is not known.\n\
			  Did you want to declare a variable \"" ^ t ^ "\"? \
				If that is the case please specify its type." in
			Asthelper.failwith (convert_loc _loc) message

(*****************************************************************************)
(*****************************************************************************)
(*****************************************************************************)
(* Actor definitions. *)

(** Defines different kinds of actor declarations. *)
type actor_decl =
	| Action of Calast.action (** An action of type [Calast.action]. *)
	| FuncDecl of Calast.func (** A function declaration at the actor level. *)
	| Initialization of Calast.action (** An initialization action of type [Calast.action]. *) 
	| PriorityOrder of Calast.tag list list (** An actor declaration of type priority order. *)
	| ProcDecl of Calast.proc (** A procedure declaration at the actor level. *)
	| VarDecl of Calast.var_info (** A variable declaration at the actor level. *)

let get_something pred map declarations =
	let (actions, declarations) = List.partition pred declarations in
	let actions = List.map map actions in
	(actions, declarations)

(** [get_actions declarations] returns a tuple [(actions, declarations)] where
 actions is a list of actions and declarations the remaining declarations. *)
let get_actions declarations =
	get_something
		(function Action _ -> true | _ -> false)
	  (function | Action a -> a | _ -> failwith "never happens")
		declarations

(** [get_funcs declarations] returns a tuple [(funcs, declarations)] where
 funcs is a list of function declarations and [declarations] the
 remaining declarations. *)
let get_funcs declarations =
	get_something
		(function FuncDecl _ -> true | _ -> false)
	  (function | FuncDecl f -> f | _ -> failwith "never happens")
		declarations

(** [get_priorities declarations] returns a tuple [(priorities, declarations)] where
 priorities is a list of priorities and declarations the remaining declarations. *)
let get_priorities declarations =
	let (priorities, declarations) =
		get_something
			(function PriorityOrder _ -> true | _ -> false)
		  (function | PriorityOrder p -> p | _ -> failwith "never happens")
			declarations
	in
	let priorities = List.flatten priorities in
	(priorities, declarations)

(** [get_funcs declarations] returns a tuple [(funcs, declarations)] where
 funcs is a list of function declarations and [declarations] the
 remaining declarations. *)
let get_procs declarations =
	get_something
		(function ProcDecl _ -> true | _ -> false)
	  (function | ProcDecl p -> p | _ -> failwith "never happens")
		declarations

(** [get_initializes declarations] returns a tuple [(initializes, declarations)]
 where initializes is a list of initialize and declarations the remaining
 declarations. *)
let get_initializes declarations =
	get_something
		(function Initialization _ -> true | _ -> false)
	  (function | Initialization i -> i | _ -> failwith "never happens")
		declarations

(** [get_vars declarations] returns a tuple [(vars, declarations)] where
 vars is a list of local variable declarations and [declarations] the
 remaining declarations. *)
let get_vars declarations =
	get_something
		(function VarDecl _ -> true | _ -> false)
	  (function | VarDecl v -> v | _ -> failwith "never happens")
		declarations

let var assignable global loc name t v =
	{ Calast.v_assignable = assignable;
		v_global = global;
		v_loc = loc;
		v_name = name;
		v_type = t;
		v_value = v }

(*****************************************************************************)
(*****************************************************************************)
(*****************************************************************************)
(* Rule declarations *)
let actor = Gram.Entry.mk "actor"
let actorActionOrInit = Gram.Entry.mk "actorActionOrInit"
let actorDeclarations = Gram.Entry.mk "actorDeclarations"
let actorImport = Gram.Entry.mk "actorImport"
let actorPars = Gram.Entry.mk "actorPars"
let actorPortDecls = Gram.Entry.mk "actorPortDecls"

let action = Gram.Entry.mk "action"
let actionChannelSelector = Gram.Entry.mk "actionChannelSelector"
let actionChannelSelectorNames = Gram.Entry.mk "actionChannelSelectorNames"
let actionDelay = Gram.Entry.mk "actionDelay"
let actionGuards = Gram.Entry.mk "actionGuards"
let actionInputs = Gram.Entry.mk "actionInputs"
let actionOutputs = Gram.Entry.mk "actionOutputs"
let actionRepeat = Gram.Entry.mk "actionRepeat"
let actionStatements = Gram.Entry.mk "actionStatements"
let actionTag = Gram.Entry.mk "actionTag"
let actionTokenNames = Gram.Entry.mk "actionTokenNames"

let expression = Gram.Entry.mk "expression"
let expressionGenerators = Gram.Entry.mk "expressionGenerators"
let expressionGeneratorsOpt = Gram.Entry.mk "expressionGeneratorsOpt"
let expressions = Gram.Entry.mk "expressions"
let ident = Gram.Entry.mk "ident"

let initializationAction = Gram.Entry.mk "initializationAction"

let qualifiedId = Gram.Entry.mk "qualifiedId"

let priorityInequality = Gram.Entry.mk "priorityInequality"
let priorityOrder = Gram.Entry.mk "priorityOrder"
let schedule = Gram.Entry.mk "schedule"
let stateTransition = Gram.Entry.mk "stateTransition"
let stateTransitions = Gram.Entry.mk "stateTransitions"

let statements = Gram.Entry.mk "statements"
let statementForEachIdents = Gram.Entry.mk "statementForEachIdents"
let statementIfElseOpt = Gram.Entry.mk "statementIfElseOpt"

let typeAttrs = Gram.Entry.mk "typeAttrs"
let typeDef = Gram.Entry.mk "typeDef"
let typePars = Gram.Entry.mk "typePars"
let typeParsOpt = Gram.Entry.mk "typeParsOpt"

let varDecl = Gram.Entry.mk "varDecl"
let varDeclFunctionParams = Gram.Entry.mk "varDeclFunctionParams"
let varDeclNoExpr = Gram.Entry.mk "varDeclNoExpr"
let varDecls = Gram.Entry.mk "varDecls"
let varDeclsAndDoOpt = Gram.Entry.mk "varDeclsAndDoOpt"
let varDeclsOpt = Gram.Entry.mk "varDeclsOpt"

(* Grammar definition *)
EXTEND Gram

  (***************************************************************************)
  (* an action. *)
  action: [
		[ inputs = actionInputs; "==>"; outputs = actionOutputs;
		  guards = actionGuards;
			OPT actionDelay;
			decls = varDeclsOpt;
		  stmts = actionStatements;
		  "end" ->
			{
				Calast.a_guards = guards;
				a_inputs = inputs;
				a_loc = convert_loc _loc;
				a_outputs = outputs;
				a_stmts = stmts;
				a_tag = []; (* the tag is filled in the actorDeclarations rule. *)
				a_vars = decls;
			}
		]
	];
	
	actionChannelSelector: [
		[ actionChannelSelectorNames ->
			Asthelper.failwith (convert_loc _loc)
				"RVC-CAL does not support channel selectors." ]
	];
	
	actionChannelSelectorNames: [ [ "at" | "at*" | "any" | "all" ] ];
	
	actionDelay: [ [ "delay"; expression ->
		Asthelper.failwith (convert_loc _loc)
			"RVC-CAL does not permit the use of delay." ] ];
	
	actionGuards: [ [ "guard"; e = expressions -> e | -> [] ] ];

	(* action inputs *)
	actionInputs: [
		[ l = LIST0 [
			"["; tokens = actionTokenNames; "]"; repeat = actionRepeat; OPT actionChannelSelector ->
				("", tokens, repeat)
		| (_, portName) = ident; ":"; "["; tokens = actionTokenNames; "]"; repeat = actionRepeat; OPT actionChannelSelector ->
				(portName, tokens, repeat)
		] SEP "," -> l ]
	];

	(* action outputs *)
	actionOutputs: [
		[ l = LIST0 [
		  "["; exprs = expressions; "]"; repeat = actionRepeat; OPT actionChannelSelector ->
				("", exprs, repeat)
		| (_, portName) = ident; ":"; "["; exprs = expressions; "]"; repeat = actionRepeat; OPT actionChannelSelector ->
				(portName, exprs, repeat)
		] SEP "," -> l ]
	];
	
	actionRepeat: [
		[ "repeat"; e = expression -> e
		| -> Calast.ExprInt (convert_loc _loc, 1) ]
	];
	
	actionStatements: [ [ "do"; s = statements -> s | -> [] ] ];
	
	actionTag: [ [ tag = LIST1 [ (_, id) = ident -> id ] SEP "." -> tag ] ];
	
	actionTokenNames: [
		[	tokens = LIST0 [ (loc, id) = ident -> (loc, id) ] SEP "," -> tokens ]
	];
	
	(***************************************************************************)
  (* a CAL actor. *)
  actor: [
		[ LIST0 actorImport; "actor"; (_, name) = ident; typeParsOpt;
		  "("; parameters = actorPars; ")";
			inputs = actorPortDecls; "==>"; outputs = actorPortDecls; ":";
			declarations1 = actorDeclarations;
			fsm = OPT schedule;
			declarations2 = actorDeclarations;
			"end"; `EOI ->
				let declarations = List.append declarations1 declarations2 in
				let (actions, declarations) = get_actions declarations in
				let (funcs, declarations) = get_funcs declarations in
				let (priorities, declarations) = get_priorities declarations in
				let (procs, declarations) = get_procs declarations in
				let (vars, declarations) = get_vars declarations in
				let (_initializes, declarations) = get_initializes declarations in
				assert (declarations = []);
				{
	        Calast.ac_actions = actions;
	        ac_fsm = fsm;
					ac_funcs = funcs;
	        ac_inputs = inputs;
	        ac_name = name;
	        ac_outputs = outputs;
	        ac_parameters = parameters;
	        ac_priorities = priorities;
	        ac_procs = procs;
	        ac_vars = vars;
	      }
		]
	];
	
	actorActionOrInit: [
		[ "action"; a = action -> Action a
		| "initialize"; i = initializationAction -> Initialization i ]
	];
	
	(* declarations in the actor body. A few rules are duplicated here because
	 the grammar is not LL(1). In contrast with CLR, functions and procedures
	 may only be declared at this level. Cal2C does not support nested function
	 declarations. *) 
	actorDeclarations: [
		[ l = LIST0 [
			"action"; a = action -> Action a
		| "function"; (_, n) = ident; "("; p = varDeclFunctionParams; ")";
		    "-->"; t = typeDef; v = varDeclsOpt; ":"; e = expression; "end" ->
			FuncDecl {
				Calast.f_decls = v;
				f_expr = e;
				f_loc = convert_loc _loc;
				f_name = n;
				f_params = p;
				f_return = t;
			}
		| "procedure"; (_, n) = ident; "("; p = varDeclFunctionParams; ")";
		  v = varDeclsOpt; "begin"; s = statements; "end" ->
			ProcDecl {
				Calast.p_decls = v;
				p_loc = convert_loc _loc;
				p_name = n;
				p_params = p;
				p_stmts = s
			}
		| "initialize"; i = initializationAction -> Initialization i
		| "priority"; p = priorityOrder -> PriorityOrder p

		| (_, tag) = ident; ":"; a = actorActionOrInit ->
			(match a with
				| Action a -> Action {a with Calast.a_tag = [tag]}
				| Initialization a -> Initialization {a with Calast.a_tag = [tag]}
				| _ -> failwith "never happens")
		| (_, tag) = ident; "."; tags = actionTag; ":"; a = actorActionOrInit ->
			(match a with
				| Action a -> Action {a with Calast.a_tag = tag :: tags}
				| Initialization a -> Initialization {a with Calast.a_tag = tag :: tags}
				| _ -> failwith "never happens")
		
		| ident; "["; typePars; "]" ->
			Asthelper.failwith (convert_loc _loc) "RVC-CAL does not support type parameters."

		| (_, name) = ident; (var_loc, var_name) = ident; ";" ->
			  let t = type_of_typeDef _loc name [] in
				VarDecl (var true true var_loc var_name t None)

		| (_, name) = ident; (var_loc, var_name) = ident; "="; e = expression; ";" ->
			  let t = type_of_typeDef _loc name [] in
				VarDecl (var false true var_loc var_name t (Some e))

		| (_, name) = ident; (var_loc, var_name) = ident; ":="; e = expression; ";" ->
			  let t = type_of_typeDef _loc name [] in
				VarDecl (var true true var_loc var_name t (Some e))

		| (_, name) = ident; "("; attrs = typeAttrs; ")"; (var_loc, var_name) = ident; ";" ->
			  let t = type_of_typeDef _loc name attrs in
				VarDecl (var true true var_loc var_name t None)

		| (_, name) = ident; "("; attrs = typeAttrs; ")";
		  (var_loc, var_name) = ident; "="; e = expression; ";" ->
			  let t = type_of_typeDef _loc name attrs in
				VarDecl (var false true var_loc var_name t (Some e))

		| (_, name) = ident; "("; attrs = typeAttrs; ")";
		  (var_loc, var_name) = ident; ":="; e = expression; ";" ->
			  let t = type_of_typeDef _loc name attrs in
				VarDecl (var true true var_loc var_name t (Some e))

    | (_, i) = ident; ";" ->
			Asthelper.failwith (convert_loc _loc)
				("Missing type for declaration of \"" ^ i ^ "\".")
		| (_, i) = ident; "="; expression; ";" ->
			Asthelper.failwith (convert_loc _loc)
				("Missing type for declaration of \"" ^ i ^ "\".")
		| (_, i) = ident; ":="; expression; ";" ->
			Asthelper.failwith (convert_loc _loc)
				("Missing type for declaration of \"" ^ i ^ "\".")
				
		] -> l ]
	];
	
	(* stuff imported by the current actor *)
	actorImport: [
		[ "import"; "all"; qualifiedId; ";" -> ()
		| "import"; qualifiedId; ";" -> () ]
	];
	
	(* actor parameters: type, name and optional expression. *)
	actorPars: [
		[ parameters = LIST0 [
			t = typeDef; (_, name) = ident; v = OPT [ "="; e = expression -> e ] -> 
			var false true (convert_loc _loc) name t v
		] SEP "," -> parameters ]
	];
	
	(* a port declaration: "multi" or not, type and identifier. *)
	actorPortDecls: [
		[ l = LIST0 [
			OPT "multi"; t = typeDef; (_, name) = ident ->
			var false true (convert_loc _loc) name t None
		] SEP "," -> l ]
	];
	
	(***************************************************************************)
  (* expressions. *)	
	expression: [
		"top"
		  [	"["; e = expressions; g = expressionGeneratorsOpt; "]" ->
				Calast.ExprList (convert_loc _loc, e, g)
			| "if"; e1 = SELF; "then"; e2 = expression; "else"; e3 = expression; "end" ->
				Calast.ExprIf (convert_loc _loc, e1, e2, e3) ]
	| "or"
		  [	e1 = SELF; "or"; e2 = SELF -> bop _loc e1 Calast.BOpOr e2 ]
	| "and"
			[ e1 = SELF; "and"; e2 = SELF -> bop _loc e1 Calast.BOpAnd e2 ]
	| "cmp"
	    [ e1 = SELF; "="; e2 = SELF -> bop _loc e1 Calast.BOpEQ e2
			| e1 = SELF; "!="; e2 = SELF -> bop _loc e1 Calast.BOpNE e2
			| e1 = SELF; "<"; e2 = SELF -> bop _loc e1 Calast.BOpLT e2
			| e1 = SELF; "<="; e2 = SELF -> bop _loc e1 Calast.BOpLE e2
			| e1 = SELF; ">"; e2 = SELF -> bop _loc e1 Calast.BOpGT e2
			| e1 = SELF; ">="; e2 = SELF -> bop _loc e1 Calast.BOpGE e2	]
	|	"add"
      [ e1 = SELF; "+"; e2 = SELF -> bop _loc e1 Calast.BOpPlus e2
      | e1 = SELF; "-"; e2 = SELF -> bop _loc e1 Calast.BOpMinus e2 ]
	| "mul"
		  [ e1 = SELF; "div"; e2 = SELF -> bop _loc e1 Calast.BOpDivInt e2
      | e1 = SELF; "mod"; e2 = SELF -> bop _loc e1 Calast.BOpMod e2
			| e1 = SELF; "*"; e2 = SELF -> bop _loc e1 Calast.BOpTimes e2
      | e1 = SELF; "/"; e2 = SELF -> bop _loc e1 Calast.BOpDiv e2 ]
	| "exp"
	    [ e1 = SELF; "^"; e2 = SELF -> bop _loc e1 Calast.BOpExp e2 ]
	| "unary"
		  [	"-"; e = SELF -> uop _loc Calast.UOpMinus e
			| "not"; e = SELF -> uop _loc Calast.UOpNot e
			| "#"; e = SELF -> uop _loc Calast.UOpNbElts e ]
	| "simple"
			[ "("; e = SELF; ")" -> e
			| "true" -> Calast.ExprBool (convert_loc _loc, true)
			| "false" -> Calast.ExprBool (convert_loc _loc, false)
			| (i, _) = INT -> Calast.ExprInt (convert_loc _loc, i)
			| (s, _) = STRING -> Calast.ExprStr (convert_loc _loc, s)
			| (_, v) = ident; "("; el = expressions; ")" ->
				Calast.ExprCall (convert_loc _loc, v, el)
			| (loc, v) = ident; el = LIST1 [ "["; e = expression; "]" -> e ] ->
				Calast.ExprIdx (convert_loc _loc, (loc, v), el)
			| (loc, v) = ident -> Calast.ExprVar (loc, v) ]
	];
	
	expressionGenerators: [
		[ l = LIST1 [
			"for"; t = typeDef; (loc, name) = ident; "in"; e = expression ->
				let var = var false false loc name t None in
				(var, e) ] SEP "," -> l ]
	];
	
	expressionGeneratorsOpt: [ [ ":"; g = expressionGenerators -> g | -> [] ] ]; 
	
	expressions: [ [ l = LIST0 [ e = expression -> e ] SEP "," -> l ] ];
	
	ident: [ [ s = IDENT -> (convert_loc _loc, s) ] ];
	
	(***************************************************************************)
	(* initialization action. *)
	initializationAction: [
		[ "==>"; outputs = actionOutputs;
		  guards = actionGuards; OPT actionDelay; decls = varDeclsOpt;
		  stmts = actionStatements;
		  "end" ->
			{
				Calast.a_guards = guards;
				a_inputs = [];
				a_loc = convert_loc _loc;
				a_outputs = outputs;
				a_stmts = stmts;
				a_tag = []; (* the tag is filled in the actorDeclarations rule. *)
				a_vars = decls;
			}
		]
	];
	
	(***************************************************************************)
	qualifiedId: [ [ qid = LIST1 [ id = ident -> id ] SEP "." -> qid ] ];
	
	(***************************************************************************)
	(* schedule and priorities. We only support FSM schedules. *)
	priorityInequality: [
		[ tag = actionTag; ">"; tags = LIST1 [a = actionTag -> a ] SEP ">" -> tag :: tags ]
	];
	
	priorityOrder: [ [ l = LIST0 [ p = priorityInequality; ";" -> p ]; "end" -> l ] ];
	
	schedule: [
		[ "schedule"; "fsm"; (_, first_state) = ident; ":";
		  transitions = stateTransitions; "end" -> (first_state, transitions)
		| "schedule"; "regexp" ->
			Asthelper.failwith (convert_loc _loc) "RVC-CAL does not support \"regexp\" schedules."
		]
	];
	
	stateTransition: [
    [ (_, from_state) = ident; "("; action = actionTag; ")"; "-->"; (_, to_state) = ident; ";" ->
			(from_state, action, to_state) ]
	];
	
	stateTransitions: [ [ l = LIST0 [ t = stateTransition -> t ] -> l ] ];
	
	(***************************************************************************)
	(* statements: while, for, if... *)
	statements: [
		[ l = LIST0 [
			"begin"; decls = varDeclsAndDoOpt; st = statements; "end" ->
			Calast.StmtBlock (convert_loc _loc, decls, st)
		| "choose" ->
			Asthelper.failwith (convert_loc _loc)
				"RVC-CAL does not support the \"choose\" statement."
		| "for" ->
			Asthelper.failwith (convert_loc _loc)
				"RVC-CAL does not support the \"for\" statement, please use \"foreach\" instead."
		| "foreach"; var = varDeclNoExpr; "in"; e = expression;
			v = varDeclsOpt; "do"; s = statements; "end" ->
			Calast.StmtForeach (convert_loc _loc, var, e, v, s)
		| "foreach"; typeDef; ident; "in"; expression; ".."; expression ->
			Asthelper.failwith (convert_loc _loc)
				"RVC-CAL does not support the \"..\" construct, please use \"Integers\" instead."
		| "if"; e = expression; "then"; s1 = statements; s2 = statementIfElseOpt; "end" ->
			Calast.StmtIf (convert_loc _loc, e, s1, s2)
		| "while"; e = expression; decls = varDeclsOpt; "do"; s = statements; "end" ->
			Calast.StmtWhile (convert_loc _loc, e, decls, s)
		| (loc, v) = ident; "["; el = expressions; "]"; ":="; e = expression; ";" ->
			Calast.StmtInstr (convert_loc _loc,
				[Calast.InstrAssignArray (convert_loc _loc, (loc, v), el, e)])
		| (_, v) = ident; "."; (_, f) = ident; ":="; e = expression; ";" ->
			Calast.StmtInstr (convert_loc _loc,
				[Calast.InstrAssignField (convert_loc _loc, v, f, e)])
		| (loc, v) = ident; ":="; e = expression; ";" ->
			Calast.StmtInstr (convert_loc _loc,
				[Calast.InstrAssignVar (convert_loc _loc, (loc, v), e)])
		| (_, v) = ident; "("; el = expressions; ")"; ";" ->
			Calast.StmtInstr (convert_loc _loc,
				[Calast.InstrCall (convert_loc _loc, v, el)])
		| (_, v) = ident; "."; (_, m) = ident; "("; el = expressions; ")";
		  LIST0 [ "."; ident; "("; expressions; ")" ]; ";" ->
			Calast.StmtInstr (convert_loc _loc,
				[Calast.InstrCallMethod (convert_loc _loc, v, m, el)])
		] -> l ]
	];
	
	statementForEachIdents: [ [ l = LIST1 [ t = typeDef; (loc, name) = ident ->
		var false false loc name t None
	] -> l ] ];
	
	statementIfElseOpt: [ [ "else"; s = statements -> s | -> [] ] ];
	
	(***************************************************************************)
	(* a type attribute, such as "type:" and "size=" *)
	typeAttrs: [
		[ l = LIST0 [
			(_, attr) = ident; ":"; t = typeDef -> (attr, TypeAttr t)
		| (_, attr) = ident; "="; e = expression -> (attr, ExprAttr e)
		] SEP "," -> l ]
	];

	(* a type definition: bool, int(size=5), list(type:int, size=10)... *)	
	typeDef: [
		[ (_, name) = ident -> type_of_typeDef _loc name []
		| ident; "["; typePars; "]" ->
			Asthelper.failwith (convert_loc _loc) "RVC-CAL does not support type parameters."
		| (_, name) = ident; "("; attrs = typeAttrs; ")" ->
			  type_of_typeDef _loc name attrs ]
	];
	
	(* type parameters, not supported at this point. *)
	typePars: [ [ LIST0 [ IDENT -> () | IDENT; "<"; typeDef -> ()	] SEP "," -> () ] ];
	
	typeParsOpt: [
		[ "["; typePars; "]" ->
			Asthelper.failwith (convert_loc _loc) "RVC-CAL does not support type parameters."
		| ]
	];
	
	(***************************************************************************)
	(* variable declarations. *)
	
	(* we do not support nested declarations of functions nor procedures. *)
	varDecl: [
		[ t = typeDef; (loc, name) = ident; "="; e = expression ->
			var false false loc name t (Some e)
		| t = typeDef; (loc, name) = ident; ":="; e = expression ->
			var true false loc name t (Some e)
		| t = typeDef; (loc, name) = ident -> var true false loc name t None ]
	];
	
	
	(* t = typeDef; (loc, name) = ident -> var false false loc name t None	*)
	varDeclFunctionParams: [
		[ l = LIST0
			[ t = typeDef; (loc, name) = ident -> var true false loc name t None
		] SEP "," -> l ]
	];

	varDeclNoExpr: [
		[ t = typeDef; (loc, name) = ident -> var false false loc name t None
		]
	];
	
	varDecls: [ [ l = LIST1 [ v = varDecl -> v] SEP "," -> l ] ];
	
	varDeclsAndDoOpt: [ [ "var"; decls = varDecls; "do" -> decls | -> [] ] ];
	
	varDeclsOpt: [ [ "var"; decls = varDecls -> decls | -> [] ] ];
END

(*****************************************************************************)
(* additional grammar for -D <type> <name> = <value> *)

let arg = Gram.Entry.mk "arg"

(* Grammar definition *)
EXTEND Gram

  arg: [
		[ (loc, name) = ident; "="; e = expression ->
			var false true loc name Calast.TypeUnknown (Some e) ]
	];

END

let parse_with_msg f rule loc stream =
	try
		f rule loc stream
	with Camlp4Loc.Exc_located (loc, exn) ->
		(match exn with
			| Stream.Error err -> fprintf stderr "%s\n%s\n" (Camlp4Loc.to_string loc) err
			| _ -> fprintf stderr "%s\n%s\n" (Camlp4Loc.to_string loc) (Printexc.to_string exn));
		exit (-1)

(** [parse_actor path] parses the file whose absolute path is given by [path]
 and returns a [Calast.actor]. If anything goes wrong, Cal2C exists. *)
let parse_actor file =
	let t1 = Sys.time () in
	let ch = open_in file in
	let actor =
		parse_with_msg Gram.parse actor (Loc.mk file) (Stream.of_channel ch)
	in
	close_in ch;
	let t2 = Sys.time () in
	time := !time +. t2 -. t1;
	actor

(** [parse_arg str] parses the string [str] as a variable declaration,
 and returns a [Calast.var_decl]. If anything goes wrong, Cal2C exits. *)
let parse_arg str =
	parse_with_msg Gram.parse arg (Loc.mk str) (Stream.of_string str)

let parse_expr str =
	parse_with_msg Gram.parse expression (Loc.mk str) (Stream.of_string str)