Commit c350c1f0 authored by bguillaum's avatar bguillaum

review of identifiers handling in lexer and parser

git-svn-id: svn+ssh://scm.gforge.inria.fr/svn/semagramme/libcaml-grew/trunk@8578 7838e531-6607-4d57-9587-6c381814729c
parent 8c1ade1c
......@@ -15,81 +15,91 @@ open Grew_types
(* ================================================================================ *)
module Ast = struct
let dot_split s = Str.split (Str.regexp "\\.") s
let get_single s = match dot_split s with
| [one] -> one
| _ -> Error.build "The identifier '%s' contains the '.' symbol" s
(* ---------------------------------------------------------------------- *)
(* complex_id: V, V#alpha, V.cat, V#alpha.cat, p_obj.loc *)
type complex_id =
| No_sharp of string
| Sharp of string * string
(* general function for checking that an identifier is of the right kind *)
let check_special name allowed s =
let sp = Str.full_split (Str.regexp "#\\|\\.\\|:\\|\\*") s in
try
match List.find
(function
| Str.Delim d when not (List.mem d allowed) -> true
| _ -> false
) sp
with
| Str.Delim wrong_char ->
Error.build "The identifier '%s' is not a valid %s, the character '%s' is illegal" s name wrong_char
| Str.Text _ -> Error.bug "[Grew_ast.check_special]"
with
| Not_found -> ()
let complex_id_to_string = function
| No_sharp x -> x
| Sharp (x,y) -> x ^ "#" ^ y
(* ---------------------------------------------------------------------- *)
(* simple_ident: cat *)
type simple_ident = Id.name
let parse_simple_ident s = check_special "simple ident" [] s; s
let is_simple_ident s = try ignore (parse_simple_ident s); true with _ -> false
let dump_simple_ident name = name
(* ---------------------------------------------------------------------- *)
(* simple_id: V *)
type simple_id = Id.name
(* label_ident: D:mod.dis *)
type label_ident = string
let parse_label_ident s = check_special "label ident" [":"; "."] s; s
let dump_label_ident name = name
let simple_id_of_ci ci = match ci with
| No_sharp s -> get_single s
| Sharp _ -> Error.build "The identifier '%s' must be simple (without '#' symbol)" (complex_id_to_string ci)
let is_simple = function
| No_sharp s when List.length (dot_split s) = 1 -> true
| _ -> false
(* ---------------------------------------------------------------------- *)
(* pattern_label_ident: D:mod.* *)
type pattern_label_ident = string
let parse_pattern_label_ident s = check_special "label ident" [":"; "."; "*"] s; s
let dump_pattern_label_ident name = name
(* ---------------------------------------------------------------------- *)
(* label_id: p_obj.loc x.y.z *)
type label_id = string
(* feature_ident: V.cat *)
type feature_ident = Id.name * feature_name
let parse_feature_ident s =
check_special "feature ident" ["."] s;
match Str.full_split (Str.regexp "\\.") s with
| [Str.Text base; Str.Delim "."; Str.Text fn] -> (base, fn)
| _ -> Error.build "The identifier '%s' must be a feature identifier (with exactly one '.' symbol, like \"V.cat\" for instance)" s
let dump_feature_ident (name, feat_name) = sprintf "%s.%s" name feat_name
let label_id_of_ci ci = match ci with
| No_sharp s -> s
| Sharp _ -> Error.build "The identifier '%s' must be a label (without '#' symbol)" (complex_id_to_string ci)
(* ---------------------------------------------------------------------- *)
(* act_id: V, V#alpha *)
type act_id = Id.name * string option
(* command_node_id: V, V#alpha *)
type command_node_ident =
| No_sharp of Id.name
| Sharp of Id.name * string
let parse_command_node_ident s =
check_special "feature ident" ["#"] s;
match Str.full_split (Str.regexp "#") s with
| [Str.Text base; Str.Delim "#"; Str.Text ext] -> Sharp (base, ext)
| [Str.Text base] -> No_sharp base
| _ -> Error.build "The identifier '%s' must be a command node identifier (with at most one '#' symbol)" s
let dump_command_node_ident = function
| No_sharp x -> x
| Sharp (x,y) -> x ^ "#" ^ y
let act_id_of_ci = function
| No_sharp s -> (get_single s, None)
| Sharp (s1,s2) -> (get_single s1, Some (get_single s2))
let act_id_to_string = function
| (base, None) -> base
| (base, Some ln) -> sprintf "%s#%s" base ln
let base_command_node_ident = function
| No_sharp x -> x
| Sharp (x,y) -> x
(* ---------------------------------------------------------------------- *)
(* simple_qfn: V.cat *)
type simple_qfn = Id.name * feature_name
let simple_qfn_of_ci ci = match ci with
| No_sharp s ->
(match dot_split s with
| [base;fn] -> (base, fn)
| _ -> Error.build "The identifier '%s' must be a qualified feature name (with one '.' symbol)" s
)
| Sharp _ -> Error.build "The identifier '%s' must be a qualified feature name (without '#' symbol)" (complex_id_to_string ci)
let simple_qfn_to_string (name, feat_name) = sprintf "%s.%s" name feat_name
(* command_feature_ident: V.cat, V#alpha.cat *)
type command_feature_ident = command_node_ident * feature_name
let parse_command_feature_ident s =
check_special "feature ident" ["."; "#"] s;
match Str.full_split (Str.regexp "#\\|\\.") s with
| [Str.Text base; Str.Delim "#"; Str.Text ext; Str.Delim "."; Str.Text feature_name] -> (Sharp (base, ext), feature_name)
| [Str.Text base; Str.Delim "."; Str.Text feature_name] -> (No_sharp base, feature_name)
| _ -> Error.build "The identifier '%s' must be a command feature identifier (with exactly one '.' symbol and at most one '#' symbol in the left part)" s
(* ---------------------------------------------------------------------- *)
(* act_qfn: V.cat, V#alpha.cat *)
type act_qfn = act_id * feature_name
let act_qfn_of_ci = function
| No_sharp s ->
(match dot_split s with
| [base;fn] -> ((base, None), fn)
| _ -> Error.build "The identifier '%s' must be a qualified feature name (with one '.' symbol)" s
)
| Sharp (base, s) ->
(match dot_split s with
| [ext;fn] -> ((get_single base, Some ext), fn)
| _ -> Error.build "The identifier '%s' must be a qualified feature name (with one '.' symbol)" s
)
let dump_command_feature_ident = function
| (No_sharp base, feature_name) -> sprintf "%s.%s" base feature_name
| (Sharp (base,ext), feature_name) -> sprintf "%s#%s.%s" base ext feature_name
(* ---------------------------------------------------------------------- *)
type feature_kind =
| Equality of feature_value list
| Disequality of feature_value list
......@@ -133,9 +143,9 @@ module Ast = struct
| Cst_out of Id.name
| End of Id.name * edge_label list (* (target, labels) *)
| Cst_in of Id.name
| Feature_eq of simple_qfn * simple_qfn
| Feature_diseq of simple_qfn * simple_qfn
| Feature_ineq of ineq * simple_qfn * simple_qfn
| Feature_eq of feature_ident * feature_ident
| Feature_diseq of feature_ident * feature_ident
| Feature_ineq of ineq * feature_ident * feature_ident
type const = u_const * Loc.t
type basic = {
......@@ -155,24 +165,24 @@ module Ast = struct
}
type concat_item =
| Qfn_item of complex_id (* Warning: either a simple string (without .) of a real qualified feature_name *)
| Qfn_item of feature_ident
| String_item of string
| Param_item of string
type u_command =
| Del_edge_expl of (act_id * act_id * edge_label)
| Del_edge_expl of (command_node_ident * command_node_ident * edge_label)
| Del_edge_name of string
| Add_edge of (act_id * act_id * edge_label)
| Shift_in of (act_id * act_id)
| Shift_out of (act_id * act_id)
| Shift_edge of (act_id * act_id)
| Merge_node of (act_id * act_id)
| New_neighbour of (Id.name * act_id * edge_label)
| Del_node of act_id
| Activate of act_id
| Del_feat of act_qfn
| Update_feat of act_qfn * concat_item list
| Add_edge of (command_node_ident * command_node_ident * edge_label)
| Shift_in of (command_node_ident * command_node_ident)
| Shift_out of (command_node_ident * command_node_ident)
| Shift_edge of (command_node_ident * command_node_ident)
| Merge_node of (command_node_ident * command_node_ident)
| New_neighbour of (Id.name * command_node_ident * edge_label)
| Del_node of command_node_ident
| Activate of command_node_ident
| Del_feat of command_feature_ident
| Update_feat of command_feature_ident * concat_item list
type command = u_command * Loc.t
(* the [rule] type is used for 3 kids of module items:
......
......@@ -12,36 +12,49 @@ open Grew_base
open Grew_types
module Ast : sig
(* ---------------------------------------------------------------------- *)
(* simple_ident: V.cat *)
type simple_ident = Id.name
val parse_simple_ident: string -> simple_ident
val is_simple_ident: string -> bool
val dump_simple_ident: simple_ident -> string
(* ---------------------------------------------------------------------- *)
(* label_ident: D:mod.dis *)
type label_ident = string
val parse_label_ident: string -> label_ident
val dump_label_ident: label_ident -> string
(* ---------------------------------------------------------------------- *)
(* pattern_label_ident: D:mod.* *)
type pattern_label_ident = string
val parse_pattern_label_ident: string -> pattern_label_ident
val dump_pattern_label_ident: pattern_label_ident -> string
(* ---------------------------------------------------------------------- *)
(* feature_ident: V.cat *)
type feature_ident = Id.name * feature_name
val parse_feature_ident: string -> feature_ident
val dump_feature_ident: feature_ident -> string
(* -------------------------------------------------------------------------------- *)
(* complex_id: V, V#alpha, V.cat, V#alpha.cat, p_obj.loc *)
type complex_id =
(* command_node_ident: V, V#alpha, V.cat, V#alpha.cat, p_obj.loc *)
type command_node_ident =
| No_sharp of string
| Sharp of string * string
val complex_id_to_string: complex_id -> string
(* simple_id: V *)
type simple_id = Id.name
val simple_id_of_ci: complex_id -> string
val is_simple: complex_id -> bool
(* label_id: V *)
type label_id = Id.name
val label_id_of_ci: complex_id -> string
(* act_id: V, V#alpha *)
type act_id = Id.name * string option
val act_id_of_ci: complex_id -> act_id
val act_id_to_string: act_id -> string
val parse_command_node_ident: string -> command_node_ident
val dump_command_node_ident: command_node_ident -> string
(* simple_qfn: V.cat *)
type simple_qfn = Id.name * feature_name
val simple_qfn_of_ci: complex_id -> simple_qfn
val simple_qfn_to_string: simple_qfn -> string
val base_command_node_ident: command_node_ident -> string
(* act_id: V.cat, V#alpha.cat *)
type act_qfn = act_id * feature_name
val act_qfn_of_ci: complex_id -> act_qfn
(* ---------------------------------------------------------------------- *)
(* command_feature_ident: V.cat, V#alpha.cat *)
type command_feature_ident = command_node_ident * feature_name
val parse_command_feature_ident: string -> command_feature_ident
val dump_command_feature_ident: command_feature_ident -> string
(* ---------------------------------------------------------------------- *)
type feature_kind =
| Equality of feature_value list
| Disequality of feature_value list
......@@ -80,9 +93,9 @@ module Ast : sig
| Cst_out of Id.name
| End of Id.name * edge_label list (* (target, labels) *)
| Cst_in of Id.name
| Feature_eq of simple_qfn * simple_qfn
| Feature_diseq of simple_qfn * simple_qfn
| Feature_ineq of ineq * simple_qfn * simple_qfn
| Feature_eq of feature_ident * feature_ident
| Feature_diseq of feature_ident * feature_ident
| Feature_ineq of ineq * feature_ident * feature_ident
type const = u_const * Loc.t
type basic = {
......@@ -97,24 +110,24 @@ module Ast : sig
}
type concat_item =
| Qfn_item of complex_id
| Qfn_item of feature_ident
| String_item of string
| Param_item of string
type u_command =
| Del_edge_expl of (act_id * act_id * edge_label)
| Del_edge_expl of (command_node_ident * command_node_ident * edge_label)
| Del_edge_name of string
| Add_edge of (act_id * act_id * edge_label)
| Shift_in of (act_id * act_id)
| Shift_out of (act_id * act_id)
| Shift_edge of (act_id * act_id)
| Merge_node of (act_id * act_id)
| New_neighbour of (Id.name * act_id * edge_label)
| Del_node of act_id
| Activate of act_id
| Del_feat of act_qfn
| Update_feat of act_qfn * concat_item list
| Add_edge of (command_node_ident * command_node_ident * edge_label)
| Shift_in of (command_node_ident * command_node_ident)
| Shift_out of (command_node_ident * command_node_ident)
| Shift_edge of (command_node_ident * command_node_ident)
| Merge_node of (command_node_ident * command_node_ident)
| New_neighbour of (Id.name * command_node_ident * edge_label)
| Del_node of command_node_ident
| Activate of command_node_ident
| Del_feat of command_feature_ident
| Update_feat of command_feature_ident * concat_item list
type command = u_command * Loc.t
type rule = {
......
......@@ -69,16 +69,22 @@ module Command = struct
(* kai stands for "known act ident", kei for "known edge ident" *)
let pid_of_act_id loc = function
| (node_name, Some n) -> Act (Pid.Pos (Id.build ~loc node_name table), n)
| (node_name, None) ->
| Ast.Sharp (node_name, n) -> Act (Pid.Pos (Id.build ~loc node_name table), n)
| Ast.No_sharp (node_name) ->
try (* TODO: remove with activate *)
Pat (Pid.Pos (Id.build ~loc node_name table))
with _ -> New node_name in
let pid_of_node_id loc node_id = Pat (Pid.Pos (Id.build ~loc node_id table)) in
(* check that an act_id is well-defined earlier *)
let check_act_id loc act_id kai =
if not (List.mem act_id kai)
then Error.build ~loc "Unbound node identifier \"%s\"" (Ast.act_id_to_string act_id) in
then Error.build ~loc "Unbound node identifier \"%s\"" (Ast.dump_command_node_ident act_id) in
let check_node_id loc node_id kai =
if not (List.mem (Ast.No_sharp node_id) kai)
then Error.build ~loc "Unbound node identifier \"%s\"" node_id in
(* check that the edge_id is defined in the pattern *)
let check_edge loc edge_id kei =
......@@ -124,7 +130,7 @@ module Command = struct
| (Ast.New_neighbour (new_id, ancestor, label), loc) ->
check_act_id loc ancestor kai;
if List.mem (new_id, None) kai
if List.mem (Ast.No_sharp new_id) kai
then Error.build ~loc "Node identifier \"%s\" is already used" new_id;
let edge = G_edge.make ~loc ~locals label in
......@@ -134,23 +140,23 @@ module Command = struct
(NEW_NEIGHBOUR
(new_id,
edge,
Pid.Pos (Id.build ~loc (fst ancestor) table)
Pid.Pos (Id.build ~loc (Ast.base_command_node_ident ancestor) table)
), loc),
((new_id, None)::kai, kei)
((Ast.No_sharp new_id)::kai, kei)
)
with not_found ->
Log.fcritical "[GRS] tries to build a command New_neighbour (%s) on node %s which is not in the pattern %s"
(G_edge.to_string edge)
(fst ancestor)
(Ast.base_command_node_ident ancestor)
(Loc.to_string loc)
end
| (Ast.Activate act_n, loc) ->
begin
match act_n with
| (_,None) -> Error.build ~loc "Cannot activate a pattern node"
| (src, Some suffix) ->
check_act_id loc (src,None) kai;
| Ast.No_sharp _ -> Error.build ~loc "Cannot activate a pattern node"
| Ast.Sharp (src, suffix) ->
check_act_id loc (Ast.No_sharp src) kai;
if not (List.mem suffix suffixes) then Error.build ~loc "Undefined suffix \"%s\"" suffix;
((ACT_NODE (pid_of_act_id loc act_n), loc), (act_n :: kai, kei))
end
......@@ -170,13 +176,10 @@ module Command = struct
check_act_id loc act_id kai;
let items = List.map
(function
(* special case of a simple identifier understood as a string *)
| Ast.Qfn_item ci when Ast.is_simple ci -> String (Ast.complex_id_to_string ci)
| Ast.Qfn_item ci ->
let (act_id,feature_name) = Ast.act_qfn_of_ci ci in
check_act_id loc act_id kai;
| Ast.Qfn_item (node_id,feature_name) ->
check_node_id loc node_id kai;
Domain.check_feature_name ~loc feature_name;
Feat (pid_of_act_id loc act_id, feature_name)
Feat (pid_of_node_id loc node_id, feature_name)
| Ast.String_item s -> String s
| Ast.Param_item var ->
match param with
......
......@@ -59,10 +59,10 @@ module Command : sig
val build:
?param: (string list * string list) ->
(Ast.act_id list * string list) ->
(Ast.command_node_ident list * string list) ->
Id.table ->
Label.decl array ->
suffix list ->
Ast.command ->
t * (Ast.act_id list * string list)
t * (Ast.command_node_ident list * string list)
end (* module Command *)
......@@ -42,7 +42,7 @@ let html_header ?css_file ?title ?(add_lines=[]) buff =
module Html_doc = struct
let string_of_concat_item = function
| Ast.Qfn_item id -> sprintf "%s" (Ast.complex_id_to_string id)
| Ast.Qfn_item id -> sprintf "%s" (Ast.dump_feature_ident id)
| Ast.String_item s -> sprintf "\"%s\"" s
| Ast.Param_item var -> sprintf "%s" var
......@@ -51,22 +51,22 @@ module Html_doc = struct
if li_html then bprintf buff "<li>";
(match u_command with
| Ast.Del_edge_expl (n1,n2,label) ->
bprintf buff "del_edge %s -[%s]-> %s" (Ast.act_id_to_string n1) label (Ast.act_id_to_string n2)
bprintf buff "del_edge %s -[%s]-> %s" (Ast.dump_command_node_ident n1) label (Ast.dump_command_node_ident n2)
| Ast.Del_edge_name name -> bprintf buff "del_edge %s" name
| Ast.Add_edge (n1,n2,label) ->
bprintf buff "add_edge %s -[%s]-> %s" (Ast.act_id_to_string n1) label (Ast.act_id_to_string n2)
bprintf buff "add_edge %s -[%s]-> %s" (Ast.dump_command_node_ident n1) label (Ast.dump_command_node_ident n2)
| Ast.Shift_in (n1,n2) ->
bprintf buff "shift_in %s ==> %s" (Ast.act_id_to_string n1) (Ast.act_id_to_string n2)
| Ast.Shift_out (n1,n2) -> bprintf buff "shift_out %s ==> %s" (Ast.act_id_to_string n1) (Ast.act_id_to_string n2)
| Ast.Shift_edge (n1,n2) -> bprintf buff "shift %s ==> %s" (Ast.act_id_to_string n1) (Ast.act_id_to_string n2)
| Ast.Merge_node (n1,n2) -> bprintf buff "merge %s ==> %s" (Ast.act_id_to_string n1) (Ast.act_id_to_string n2)
| Ast.New_neighbour (n1,n2,label) -> bprintf buff "add_node %s: <-[%s]- %s" n1 label (Ast.act_id_to_string n2)
| Ast.Activate act_id -> bprintf buff "activate %s" (Ast.act_id_to_string act_id)
| Ast.Del_node act_id -> bprintf buff "del_node %s" (Ast.act_id_to_string act_id)
bprintf buff "shift_in %s ==> %s" (Ast.dump_command_node_ident n1) (Ast.dump_command_node_ident n2)
| Ast.Shift_out (n1,n2) -> bprintf buff "shift_out %s ==> %s" (Ast.dump_command_node_ident n1) (Ast.dump_command_node_ident n2)
| Ast.Shift_edge (n1,n2) -> bprintf buff "shift %s ==> %s" (Ast.dump_command_node_ident n1) (Ast.dump_command_node_ident n2)
| Ast.Merge_node (n1,n2) -> bprintf buff "merge %s ==> %s" (Ast.dump_command_node_ident n1) (Ast.dump_command_node_ident n2)
| Ast.New_neighbour (n1,n2,label) -> bprintf buff "add_node %s: <-[%s]- %s" n1 label (Ast.dump_command_node_ident n2)
| Ast.Activate act_id -> bprintf buff "activate %s" (Ast.dump_command_node_ident act_id)
| Ast.Del_node act_id -> bprintf buff "del_node %s" (Ast.dump_command_node_ident act_id)
| Ast.Update_feat ((act_id, feat_name),item_list) ->
bprintf buff "%s.%s = %s" (Ast.act_id_to_string act_id) feat_name (List_.to_string string_of_concat_item " + " item_list)
bprintf buff "%s.%s = %s" (Ast.dump_command_node_ident act_id) feat_name (List_.to_string string_of_concat_item " + " item_list)
| Ast.Del_feat (act_id, feat_name) ->
bprintf buff "del_feat %s.%s" (Ast.act_id_to_string act_id) feat_name
bprintf buff "del_feat %s.%s" (Ast.dump_command_node_ident act_id) feat_name
);
if li_html then bprintf buff "</li>\n" else bprintf buff ";\n"
......@@ -107,12 +107,12 @@ module Html_doc = struct
| Ast.End (ident,labels) ->
bprintf buff "* -[%s]-> %s" (List_.to_string (fun x->x) "|" labels) ident
| Ast.Cst_in ident -> bprintf buff "* -> %s" ident
| Ast.Feature_eq (qfn_l, qfn_r) ->
bprintf buff "%s = %s" (Ast.simple_qfn_to_string qfn_l) (Ast.simple_qfn_to_string qfn_r);
| Ast.Feature_diseq (qfn_l, qfn_r) ->
bprintf buff "%s <> %s" (Ast.simple_qfn_to_string qfn_l) (Ast.simple_qfn_to_string qfn_r);
| Ast.Feature_ineq (ineq, qfn_l, qfn_r) ->
bprintf buff "%s %s %s" (Ast.simple_qfn_to_string qfn_l) (Ast.string_of_ineq ineq) (Ast.simple_qfn_to_string qfn_r)
| Ast.Feature_eq (feat_id_l, feat_id_r) ->
bprintf buff "%s = %s" (Ast.dump_feature_ident feat_id_l) (Ast.dump_feature_ident feat_id_r);
| Ast.Feature_diseq (feat_id_l, feat_id_r) ->
bprintf buff "%s <> %s" (Ast.dump_feature_ident feat_id_l) (Ast.dump_feature_ident feat_id_r);
| Ast.Feature_ineq (ineq, feat_id_l, feat_id_r) ->
bprintf buff "%s %s %s" (Ast.dump_feature_ident feat_id_l) (Ast.string_of_ineq ineq) (Ast.dump_feature_ident feat_id_r)
);
bprintf buff "\n"
......
......@@ -155,18 +155,18 @@ module Rule = struct
| (Ast.Cst_in id, loc) ->
Cst_in (pid_of_name loc id, P_edge.all)
| (Ast.Feature_eq (qfn1, qfn2), loc) ->
let (node_name1, feat_name1) = qfn1
and (node_name2, feat_name2) = qfn2 in
| (Ast.Feature_eq (feat_id1, feat_id2), loc) ->
let (node_name1, feat_name1) = feat_id1
and (node_name2, feat_name2) = feat_id2 in
Feature_eq (pid_of_name loc node_name1, feat_name1, pid_of_name loc node_name2, feat_name2)
| (Ast.Feature_diseq (qfn1, qfn2), loc) ->
let (node_name1, feat_name1) = qfn1
and (node_name2, feat_name2) = qfn2 in
| (Ast.Feature_diseq (feat_id1, feat_id2), loc) ->
let (node_name1, feat_name1) = feat_id1
and (node_name2, feat_name2) = feat_id2 in
Feature_diseq (pid_of_name loc node_name1, feat_name1, pid_of_name loc node_name2, feat_name2)
| (Ast.Feature_ineq (ineq, qfn1, qfn2), loc) ->
let (node_name1, feat_name1) = qfn1
and (node_name2, feat_name2) = qfn2 in
| (Ast.Feature_ineq (ineq, feat_id1, feat_id2), loc) ->
let (node_name1, feat_name1) = feat_id1
and (node_name2, feat_name2) = feat_id2 in
Feature_ineq (ineq, pid_of_name loc node_name1, feat_name1, pid_of_name loc node_name2, feat_name2)
let build_neg_basic ?pat_vars ?(locals=[||]) pos_table basic_ast =
......@@ -266,7 +266,7 @@ module Rule = struct
(* ====================================================================== *)
let build_commands ?param ?(locals=[||]) suffixes pos pos_table ast_commands =
let known_act_ids = List.map (fun x -> (x,None)) (Array.to_list pos_table) in
let known_act_ids = List.map (fun x -> (Ast.No_sharp x)) (Array.to_list pos_table) in
let known_edge_ids = get_edge_ids pos in
let rec loop (kai,kei) = function
......
This diff is collapsed.
......@@ -17,7 +17,7 @@ module Grew_parser = struct
exception Parse_error of (string * Loc.t option)
(* ------------------------------------------------------------------------------------------*)
(** general fucntion to handle parse errors *)
(** general function to handle parse errors *)
let parse_handle file fct lexbuf =
try fct lexbuf with
| Lexer.Error msg ->
......
......@@ -36,12 +36,34 @@
let digit = ['0'-'9']
let letter = ['a'-'z' 'A'-'Z']
(* an identifier is either a single letter, "_", or its lenght is >=2 and it doesn't end with a '-' *)
let ident = (letter | '_') | (letter | '_') (letter | digit | '_' | '.' | '\'' | '-')* (letter | digit | '_' | '\'')
(* a general_ident is an arbitrary sequence of:
- letter
- digit
- underscore '_'
- dash '-'
for basic ident construction and
- dot '.'
- colon ':'
- sharp '#'
- star '*'
The first characted cannot be a digit, a sharp or a colon (to avoid confusion).
*)
let label_ident =
(letter | '_' | '-' | '.' | '*') (letter | digit | '_' | '\'' | '-' | '.' | ':' | '*')*
let general_ident =
(letter | '_' | '*') |
(letter | '_' | '.' ) (letter | digit | '_' | '\'' | '-' | '.' | '#')* (letter | digit | '_' | '\'' | '.')
let hex = ['0'-'9' 'a'-'f' 'A'-'F']
let color = hex hex hex hex hex hex | hex hex hex
(* ------------------------------------------------------------------------------- *)
(* Rules *)
(* ------------------------------------------------------------------------------- *)
rule comment target = parse
| '\n' { incr Parser_global.current_line; Lexing.new_line lexbuf; target lexbuf }
| _ { comment target lexbuf }
......@@ -88,7 +110,42 @@ and lp_lex target = parse
| _ as c { bprintf buff "%c" c; lp_lex target lexbuf }
| "#END" [' ' '\t']* '\n' { incr Parser_global.current_line; LEX_PAR (Str.split (Str.regexp "\n") (Buffer.contents buff)) }
(* The lexer must be different when label_ident are parsed. The [global] lexer calls either
[label_parser] or [standard] depending on the flag [Parser_global.label_flag].
Difference are:
- a label_ident may contain ':' (like in D:suj:obj) and ':' is a token elsewhere
- a label_ident may contain '-' anywhere (like "--" in Tiger) but '-' is fordiden as the first or last character elsewhere
*)
and global = parse
| "" { if !Parser_global.label_flag
then label_parser global lexbuf
else standard global lexbuf
}
and label_parser target = parse
| [' ' '\t'] { global lexbuf }
| "/*" { comment_multi global lexbuf }
| '%' { comment global lexbuf }
| '\n' { incr Parser_global.current_line; Lexing.new_line lexbuf; global lexbuf}
| '{' { LACC }
| '}' { Parser_global.label_flag := false; RACC }
| ',' { COMA }
| '|' { PIPE }
| '@' general_ident as cmd_var { AROBAS_ID cmd_var }
| "@#" color as col { COLOR col }
| label_ident as id { ID id }
| '"' { Buffer.clear buff; string_lex global lexbuf }
| "]->" { Parser_global.label_flag := false; LTR_EDGE_RIGHT }
| "]-" { Parser_global.label_flag := false; RTL_EDGE_RIGHT }
| _ as c { raise (Error (sprintf "At line %d: unexpected character '%c'" (lexbuf.Lexing.lex_start_p.Lexing.pos_lnum) c)) }
and standard target = parse
| [' ' '\t'] { global lexbuf }
| "%--" { comment_multi_doc global lexbuf }
......@@ -103,7 +160,7 @@ and global = parse
| "features" { FEATURES }
| "feature" { FEATURE }
| "file" { FILE }
| "labels" { LABELS }
| "labels" { Parser_global.label_flag := true; LABELS }
| "suffixes" { SUFFIXES }