⟦3b29fb419⟧

TextFile

with actor_tree;\r
\r
package body tad_material is\r
\r
procedure Create_New_Material (the_object : out object; the_Name : string) is\r
new_name : string(1..20) := (1..20 => ' ');\r
begin\r
  new_name(1..the_name'last) := the_name;\r
  the_object := object'(new_name, actor_tree.create_new_tree);\r
end Create_New_Material;\r
\r
procedure set_actors (the_object : in out object;\r
              the_actors : actor_tree.object) is\r
begin\r
  the_object.actors := the_actors;\r
end set_actors;\r
\r
procedure get_actors (the_object : object;\r
              the_actors : out actor_tree.object) is\r
begin\r
  the_actors := the_object.actors;\r
end get_actors;\r
\r
function compare_name (object1, object2 : object) return integer is\r
begin\r
  if object1.name = object2.name then\r
    return 0;\r
  end if;\r
  if object1.name > object2.name then\r
    return 1;\r
  else\r
    return -1;\r
  end if;\r
end compare_name;\r
\r
function what_name (the_object : object) return string is\r
begin\r
  return the_object.name;\r
end what_name;\r
\r
\r
end tad_material;\r
package body generic_tree is\r
\r
type son is (left, right);\r
current_node : object := void_tree;\r
\r
\r
function go_to_left_son return boolean is\r
ok : boolean := false;\r
begin\r
  if current_node /= void_tree then\r
    if current_node.left /= void_tree then\r
      current_node := current_node.left;\r
      ok := true;\r
    end if;\r
  end if;\r
  return ok;\r
end go_to_left_son;\r
\r
function go_to_right_son return boolean is\r
ok : boolean := false;\r
begin\r
  if current_node /= void_tree then\r
    if current_node.right /= void_tree then\r
      current_node := current_node.right;\r
      ok := true;\r
    end if;\r
  end if;\r
  return ok;\r
end go_to_right_son;\r
\r
function construct (the_element : element; on_son : son := right)\r
     return boolean is\r
tmp_node : object := new node'(contain => the_element,\r
                   left  => void_tree,\r
                   right => void_tree);\r
ok : boolean := false;\r
begin\r
  if current_node = void_tree then\r
    begin\r
      current_node := tmp_node;\r
      ok := true;\r
    end;\r
  elsif on_son = son'(left) then\r
       begin\r
     current_node.left := tmp_node;\r
     ok := true;\r
       end;\r
     else\r
       begin\r
     current_node.right := tmp_node;\r
     ok := true;\r
       end;\r
  end if;\r
  return ok;\r
end construct;\r
\r
function place_on_node(one_element : element) return boolean is\r
ok : boolean := false;\r
begin\r
  if (current_node /= void_tree) then\r
    begin\r
      if compare_key(current_node.contain, one_element) = 0 then\r
    return true;\r
      end if;\r
      if compare_key(current_node.contain, one_element)>0 then\r
    if go_to_left_son then\r
      ok := place_on_node(one_element);\r
    end if;\r
      else\r
    if go_to_right_son then\r
      ok := place_on_node(one_element);\r
    end if;\r
      end if;\r
    end;\r
  else\r
    ok := false;\r
  end if;\r
  return ok;\r
end place_on_node;\r
\r
procedure insert_element (the_object : in out object; the_element : element) is\r
ok : boolean;\r
begin\r
  current_node := the_object;\r
  if current_node /= void_tree then\r
    ok := place_on_node(the_element);\r
    if compare_key(current_node.contain, the_element)>0 then\r
      ok := construct(the_element, left);\r
    else\r
      ok := construct(the_element, right);\r
    end if;\r
  else\r
    ok := construct(the_element);\r
    the_object := current_node;\r
  end if;\r
end insert_element;\r
\r
procedure search_element(the_object : object; the_element : in out element) is\r
ok : boolean;\r
begin\r
  current_node := the_object;\r
  ok := place_on_node(the_element);\r
  the_element := current_node.contain;\r
end search_element;\r
\r
function create_new_tree return object is\r
begin\r
  return void_tree;\r
end create_new_tree;\r
\r
procedure change_element(the_object : in out object; the_element : element) is\r
ok : boolean;\r
begin\r
  current_node := the_object;\r
  if place_on_node(the_element) then\r
    current_node.contain := the_element;\r
  end if;\r
end change_element;\r
\r
function element_exist(the_object : object; the_element : element)\r
     return boolean is\r
begin\r
  current_node := the_object;\r
  return place_on_node(the_element);\r
end element_exist;\r
\r
\r
end generic_tree;\r
package body Token is
    type Pstring is access String;
    subtype Keyword_Token is Token.Object range L_Au .. L_Temps;
    type Keyword is array (Keyword_Token) of Pstring;
    The_Keywords : constant Keyword :=
       (L_Au => new String'("au"),
        L_Activer => new String'("activer"),
        L_Alors => new String'("alors"),
        L_Attendre => new String'("attendre"),
        L_Avec => new String'("avec"),
        L_Binaire => new String'("binaire"),
        L_Desactiver => new String'("desactiver"),
        L_Discret => new String'("discret"),
        L_En => new String'("en"),
        L_Est => new String'("est"),
        L_Experience => new String'("experience"),
        L_Faire => new String'("faire"),
        L_Fin => new String'("fin"),
        L_Fois => new String'("fois"),
        L_Fugitif => new String'("fugitif"),
        L_Heure => new String'("h"),
        L_Materiel => new String'("materiel"),
        L_Minute => new String'("min"),
        L_Puis => new String'("puis"),
        L_Repeter => new String'("repeter"),
        L_Scene => new String'("scene"),
        L_Seconde => new String'("s"),
        L_Si => new String'("si"),
        L_Spectacle => new String'("spectacle"),
        L_Station => new String'("station"),
        L_Temps => new String'("temps"),
        L_Temporel => new String'("temporel"));

    function Search_Token (S : String) return Token.Object is
    begin
        for I in Keyword_Token loop
        if S = The_Keywords (I).all then
                return I;
            end if;  
        end loop;  
        return L_Id;
    end Search_Token;
end Token;
with tad_material;\r
\r
\r
package body tad_global is\r
\r
procedure create_new_station (the_object : out object; the_name : string) is\r
new_name : string(1..20) := (1..20 => ' ');\r
begin\r
  new_name(1..the_name'last) := the_name;\r
  the_object := object'(new_name, 0, null);\r
end create_new_station;\r
\r
procedure set_material_type (the_object : in out object;\r
                 material_type : tad_material.object) is\r
begin\r
  the_object.material_type := new tad_material.object'(material_type);\r
end set_material_type;\r
\r
procedure set_station_number (the_object : in out object;\r
                  the_address : natural) is\r
begin\r
  the_object.station := the_address;\r
end set_station_number;\r
\r
function get_station_number (the_object : object) return natural is\r
begin\r
  return the_object.station;\r
end get_station_number;\r
\r
procedure get_material_type (the_object : object;\r
                 the_material_type : out tad_material.object) is\r
begin\r
  the_material_type := the_object.material_type.all;\r
end get_material_type;\r
\r
function compare_name(object1, object2 : object) return integer is\r
begin\r
  if object1.name = object2.name then\r
    return 0;\r
  end if;\r
  if object1.name > object2.name then\r
    return 1;\r
  else\r
    return -1;\r
  end if;\r
end compare_name;\r
\r
function export_address_pointer(the_object : object) return pnatural is\r
export : pnatural;\r
begin\r
  export.all := get_station_number(the_object);\r
  return export;\r
end export_address_pointer;\r
\r
\r
\r
end tad_global;\r
\r
with global_tree;\r
\r
package body the_global_tree is\r
\r
begin\r
  object := global_tree.create_new_tree;\r
end the_global_tree;with material_tree;\r
\r
package body the_material_tree is\r
\r
begin\r
  object := material_tree.create_new_tree;\r
end the_material_tree;with group_tree;\r
\r
package body tad_local is\r
\r
procedure Create_new_local_var (the_object : out object;\r
                the_name : string) is\r
new_name : string(1..20) := (1..20 => ' ');\r
begin\r
  new_name(1..the_name'last) := the_name;\r
  the_object := object'(new_name, notype, 0, group_tree.create_new_tree);\r
end create_new_local_var;\r
\r
procedure set_type (the_object : in out object;\r
            the_type : var_type) is\r
begin\r
  the_object.the_type := the_type;\r
end set_type;\r
\r
procedure set_value (the_object : in out object;\r
             the_value : natural) is\r
begin\r
  the_object.value := the_value;\r
end set_value;\r
\r
procedure set_members (the_object : in out object;\r
               the_members : group_tree.object) is\r
begin\r
  the_object.members := the_members;\r
end set_members;\r
\r
function get_type (the_object : object) return var_type is\r
begin\r
  return the_object.the_type;\r
end get_type;\r
\r
function get_value (the_object : object) return natural is\r
begin\r
  return the_object.value;\r
end get_value;\r
\r
function get_members (the_object : object) return group_tree.object is\r
begin\r
  return the_object.members;\r
end get_members;\r
\r
function compare_name(object1, object2 : object) return integer is\r
begin\r
  if object1.name = object2.name then\r
    return 0;\r
  end if;\r
  if object1.name > object2.name then\r
    return 1;\r
  else\r
    return -1;\r
  end if;\r
end compare_name;\r
\r
\r
function export_value_pointer(the_object : object) return pnatural is\r
export : pnatural;\r
begin\r
  export.all := get_value(the_object);\r
  return export;\r
end export_value_pointer;\r
\r
\r
function export_type_pointer(the_object : object)  return pvar_type is\r
export : pvar_type;\r
begin\r
  export.all := get_type(the_object);\r
  return export;\r
end export_type_pointer;\r
\r
\r
end tad_local;\r
\r
\r
\r
with scene_tree;\r
\r
package body the_scene_tree is\r
\r
begin\r
  object := scene_tree.create_new_tree;\r
end the_scene_tree;package body tad_parameter is\r
\r
procedure create_new_param (the_object : out object; the_order : natural) is\r
new_name : string(1..20) := ("noname              ");\r
begin\r
  the_object := object'(new_name, the_order);\r
end create_new_param;\r
\r
procedure set_name (the_object : in out object; the_name : string) is\r
begin\r
  the_object.name(1..the_name'last) := the_name;\r
end set_name;\r
\r
function get_order (the_object : object) return natural is\r
begin\r
  return the_object.order;\r
end get_order;\r
\r
function get_name (the_object : object) return string is\r
begin\r
  return the_object.name;\r
end get_name;\r
\r
function compare_order(object1, object2 : object) return integer is\r
begin\r
  return object1.order - object2.order;\r
end compare_order;\r
\r
end tad_parameter;\r
\r
\r
\r
with parameter_tree;\r
with local_tree;\r
with tad_abstract;\r
\r
package body tad_experience is\r
\r
procedure create_new_experience (the_object : out object; the_name : string) is\r
new_name : string(1..20) := (1..20 => ' ');\r
begin\r
  new_name(1..the_name'last) := the_name;\r
  the_object := object'(new_name,\r
            parameter_tree.create_new_tree,\r
            local_tree.create_new_tree,\r
            tad_abstract.create_new_tree);\r
end create_new_experience;\r
\r
procedure add_parameter (the_object : in out object;\r
             the_parameter : parameter_tree.object) is\r
begin\r
  the_object.params := the_parameter;\r
end add_parameter;\r
\r
procedure add_local_var (the_object : in out object;\r
             the_local_var : local_tree.object) is\r
begin\r
  the_object.local_var := the_local_var;\r
end add_local_var;\r
\r
procedure add_code (the_object : in out object;\r
            the_code : tad_abstract.pobject) is\r
begin\r
  the_object.code := the_code;\r
end add_code;\r
\r
function get_parameter (the_object : object) return parameter_tree.object is\r
begin\r
  return the_object.params;\r
end get_parameter;\r
\r
function get_local_var (the_object : object) return local_tree.object is\r
begin\r
  return the_object.local_var;\r
end get_local_var;\r
\r
function get_code (the_object : object) return tad_abstract.pobject is\r
begin\r
  return the_object.code;\r
end get_code;\r
\r
function compare_name (object1, object2 : object) return integer is\r
begin\r
  if object1.name = object2.name then\r
    return 0;\r
  end if;\r
  if object1.name > object2.name then\r
    return 1;\r
  else\r
    return -1;\r
  end if;\r
end compare_name;\r
\r
end tad_experience;\r
\r
\r
\r
with local_tree;\r
with tad_abstract;\r
\r
package body tad_scene is\r
\r
procedure create_new_scene (the_object : out object; the_name : string) is\r
new_name : string(1..20) := (1..20 => ' ');\r
begin\r
  new_name(1..the_name'last) := the_name;\r
  the_object := object'(new_name,\r
            local_tree.create_new_tree,\r
            tad_abstract.create_new_tree);\r
end create_new_scene;\r
\r
procedure add_local_var (the_object : in out object;\r
             the_local_var : local_tree.object) is\r
begin\r
  the_object.local_var := the_local_var;\r
end add_local_var;\r
\r
procedure add_code (the_object : in out object;\r
            the_code : tad_abstract.pobject) is\r
begin\r
  the_object.code := the_code;\r
end add_code;\r
\r
function get_local_var (the_object : object) return local_tree.object is\r
begin\r
  return the_object.local_var;\r
end get_local_var;\r
\r
function get_code (the_object : object) return tad_abstract.pobject is\r
begin\r
  return the_object.code;\r
end get_code;\r
\r
function compare_name (object1, object2 : object) return integer is\r
begin\r
  if object1.name = object2.name then\r
    return 0;\r
  end if;\r
  if object1.name > object2.name then\r
    return 1;\r
  else\r
    return -1;\r
  end if;\r
end compare_name;\r
\r
end tad_scene;\r
\r
\r
\r
\r
\r
\r
\r
\r
\r
\r
\r
with experience_tree;\r
\r
package body the_experience_tree is\r
\r
begin\r
  object := experience_tree.create_new_tree;\r
end the_experience_tree;with tad_global;\r
with global_tree;\r
with the_global_tree;\r
with tad_material;\r
\r
package body tad_group is\r
\r
procedure Create_New_Group_Member (the_object : out object;\r
                   the_Name : string) is\r
tmp : tad_global.object;\r
ptmp : pvar;\r
new_name : string(1..20) := (1..20 => ' ');\r
begin\r
  new_name(1..the_name'last) := the_name;\r
  tad_global.create_new_station(tmp, new_name);\r
  global_tree.search_element(the_global_tree.object, tmp);\r
  ptmp := new tad_global.object'(tmp);\r
  the_object := object'(new_name, ptmp);\r
end Create_New_Group_Member;\r
\r
function compare_name (object1, object2 : object) return integer is\r
begin\r
  if object1.name = object2.name then\r
    return 0;\r
  end if;\r
  if object1.name > object2.name then\r
    return 1;\r
  else\r
    return -1;\r
  end if;\r
end compare_name;\r
\r
function what_name (the_object : object) return string is\r
begin\r
  return the_object.name;\r
end what_name;\r
\r
function what_material (the_object : object) return tad_global.object is\r
begin\r
  return the_object.access_var.all;\r
end what_material;\r
\r
end tad_group;\r
\r
\r
package body abstract_tree is\r
\r
\r
function create_new_tree return object is\r
begin\r
  return 0;\r
end create_new_tree;\r
\r
end abstract_tree;\r
\r
\r
package body TAD_ACTOR is\r
\r
procedure Create_New_Actor (the_object : out object; \r
                the_Name : string; \r
                the_address : natural := 0) is\r
new_name : string(1..20) := (1..20 => ' ');\r
begin\r
  new_name(1..the_name'last) := the_name;\r
  the_object :=  object'(new_name, no_type, the_address);\r
end create_new_actor;\r
\r
procedure add_type (the_object : in out object; the_type : type_actor) is\r
begin\r
  the_object.actor_type := the_type;\r
end add_type;\r
\r
function compare_name (object1, object2 : object) return integer is\r
begin\r
  if object1.name = object2.name then\r
    return 0;\r
  end if;\r
  if object1.name > object2.name then\r
    return 1;\r
  else\r
    return -1;\r
  end if;\r
end compare_name;\r
\r
\r
function what_name (the_object : object) return string is\r
begin\r
  return the_object.name;\r
end what_name;\r
\r
function what_type (the_object : object) return type_actor is\r
begin\r
  return the_object.actor_type;\r
end what_type;\r
\r
function what_address (the_object : object) return natural is\r
begin\r
  return the_object.actor_address;\r
end what_address;\r
\r
function export_address_pointer(the_object : object) return pnatural is\r
export : pnatural;\r
begin\r
  export.all := what_address(the_object);\r
  return export;\r
end export_address_pointer;\r
\r
\r
end TAD_ACTOR;\r
with tad_global, global_tree;\r
with tad_material, material_tree;\r
with tad_actor, actor_tree;\r
\r
package body tad_abstract is\r
\r
function create_new_tree return tad_abstract.pobject is\r
begin\r
  null;\r
end create_new_tree;\r
\r
\r
\r
function actor_of_station_exist (station : pstring; actor : pstring)\r
                  return boolean is\r
begin\r
\r
  null;\r
\r
end actor_of_station_exist;\r
\r
end tad_abstract;\r
with tad_actor, actor_tree;\r
with tad_material, material_tree;\r
with the_material_tree;\r
with tad_global, global_tree;\r
with the_global_tree;\r
with tad_group, group_tree;\r
with tad_local, local_tree;\r
with tad_parameter, parameter_tree;\r
with tad_experience, experience_tree;\r
with the_experience_tree;\r
with tad_abstract, pointer_level;\r
with tad_scene, scene_tree;\r
with the_scene_tree;\r
with token;\r
\r
package body TDS is\r
\r
\r
type ptr_material   is access tad_material.object;\r
type ptr_actor      is access tad_actor.object;\r
type ptr_global     is access tad_global.object;\r
\r
\r
tmp_ptr_material   : ptr_material;  --\r
tmp_ptr_actor      : ptr_actor;     --\r
tmp_actor_tree     : actor_tree.object;    --\r
tmp_ptr_global     : ptr_global;  --\r
tmp_param_tree     : parameter_tree.object;   --\r
tmp_local_tree     : local_tree.object;   --\r
tmp_code_tree      : tad_abstract.pobject;    --\r
tmp_group_tree     : group_tree.object;   --\r
\r
\r
current_actor_address : natural := 0;\r
current_param_order   : natural := 1;\r
\r
Create_tree: boolean := true;\r
\r
\r
\r
function Create_New_Material (the_Name : pstring) return boolean is\r
the_object : tad_material.object;\r
Exist : boolean := False;\r
begin\r
  tad_material.create_new_material(the_object, the_name.all);\r
  Exist := material_tree.element_exist(the_material_tree.object, the_object);\r
  if Exist then\r
    return false;\r
  else\r
    begin\r
      current_actor_address := 0;\r
      tad_material.get_actors(the_object, tmp_actor_tree);\r
      material_tree.insert_element(the_material_tree.object, the_object);\r
      tmp_ptr_material := new tad_material.object'(the_object);\r
      return true;\r
    end;\r
  end if;\r
end Create_New_Material;\r
\r
\r
function add_actor (the_name : pstring) return boolean is\r
the_object : tad_actor.object;\r
exist : boolean := false;\r
begin\r
  tad_actor.create_new_actor(the_object, the_name.all, current_actor_address);\r
  Exist := actor_tree.element_Exist(tmp_actor_tree, the_object);\r
  if Exist then\r
    return false;\r
  else\r
    begin\r
      actor_tree.insert_element(tmp_actor_tree, the_object);\r
      current_actor_address := current_actor_address + 1;\r
      tmp_ptr_actor := new tad_actor.object'(the_object);\r
      return true;\r
    end;\r
  end if;\r
end add_actor;\r
\r
\r
function add_actor_type (the_type : Token.object) return boolean is\r
ok : boolean := false;\r
begin\r
  case the_type is\r
    when Token.L_BINAIRE  => tad_actor.add_type(tmp_ptr_actor.all,\r
                        tad_actor.binaire);\r
                 OK := true;\r
    when Token.L_DISCRET  => tad_actor.add_type(tmp_ptr_actor.all,\r
                        tad_actor.discret);\r
                 OK := true;\r
    when Token.L_FUGITIF  => tad_actor.add_type(tmp_ptr_actor.all,\r
                        tad_actor.fugitif);\r
                 OK := true;\r
    when Token.L_TEMPOREL => tad_actor.add_type(tmp_ptr_actor.all,\r
                        tad_actor.temporel);\r
                 OK := true;\r
    when others           => null;\r
  end case;\r
  return OK;\r
end add_actor_type;\r
\r
\r
function Compare_Current_Material_Name (the_name : pstring) return boolean is\r
the_object : tad_material.object;\r
begin\r
  tad_material.create_new_material(the_object, the_name.all);\r
  if tad_material.compare_name(the_object, tmp_ptr_material.all) = 0 then\r
    return true;\r
  else\r
    return false;\r
  end if;\r
end Compare_current_material_name;\r
\r
\r
function Create_New_Station (the_Name : pstring) return boolean is\r
the_object : tad_global.object;\r
exist : boolean := false;\r
begin\r
  tad_global.create_new_station(the_object, the_name.all);\r
  Exist := global_tree.element_Exist(the_global_tree.object, the_object);\r
  if Exist then\r
    return false;\r
  else\r
    begin\r
      global_tree.insert_element(the_global_tree.object, the_object);\r
      tmp_ptr_global := new tad_global.object'(the_object);\r
      return true;\r
    end;\r
  end if;\r
end Create_New_Station;\r
\r
\r
function Set_Station_Type (the_type : pstring)  return boolean is\r
the_object : tad_material.object;\r
exist : boolean := false;\r
begin\r
  tad_material.create_new_material(the_object, the_type.all);\r
  Exist := material_tree.element_Exist(the_material_tree.object, the_object);\r
  if Exist then\r
    begin\r
      tad_global.set_material_type(tmp_ptr_global.all, the_object);\r
      return true;\r
    end;\r
  else\r
    return false;\r
  end if;\r
end Set_Station_Type;\r
\r
\r
function Set_Station_Number (the_address : natural) return boolean is\r
begin\r
  tad_global.set_station_number(tmp_ptr_global.all, the_address);\r
  return true;\r
end Set_Station_Number;\r
\r
\r
function Create_New_Experience (the_Name : pstring) return boolean is\r
the_object : tad_experience.object;\r
exist : boolean := false;\r
begin\r
  create_tree := true;  --creation de l'arbre abstrait\r
  tad_experience.create_new_experience(the_object, the_name.all);\r
  Exist := experience_tree.element_Exist(the_experience_tree.object, the_object);\r
  if Exist then\r
    return false;\r
  else\r
    begin\r
      experience_tree.insert_element(the_experience_tree.object, the_object);\r
      tmp_param_tree := tad_experience.get_parameter(the_object);\r
      tmp_local_tree := tad_experience.get_local_var(the_object);\r
      tmp_code_tree  := tad_experience.get_code(the_object);\r
      current_param_order := 1;\r
      return true;\r
    end;\r
  end if;\r
end Create_New_Experience;\r
\r
\r
function Add_Experience_Parameter (the_Name : pstring) return boolean is\r
para_object : tad_parameter.object;\r
begin\r
  tad_parameter.create_new_param(para_object, current_param_order);\r
  tad_parameter.set_name(para_object, the_name.all);\r
  parameter_tree.insert_element(tmp_param_tree, para_object);\r
  if set_local_variable(the_name) then\r
    begin\r
      current_param_order := current_param_order + 1;\r
      return true;\r
    end;\r
  else\r
    return false;\r
  end if;\r
end Add_Experience_Parameter;\r
\r
\r
function Create_New_Scene (the_Name : pstring) return boolean is\r
the_object : tad_scene.object;\r
exist : boolean := false;\r
begin\r
  create_tree := true;  --creation de l'arbre abstrait\r
  tad_scene.create_new_scene(the_object, the_name.all);\r
  Exist := scene_tree.element_Exist(the_scene_tree.object, the_object);\r
  if Exist then\r
    return false;\r
  else\r
    begin\r
      scene_tree.insert_element(the_scene_tree.object, the_object);\r
      tmp_local_tree := local_tree.create_new_tree;\r
      tad_scene.add_local_var(the_object, tmp_local_tree);\r
      tmp_code_tree  := tad_scene.get_code(the_object);\r
      return true;\r
    end;\r
  end if;\r
end Create_New_Scene;\r
\r
\r
function Create_Spectacle return boolean is\r
begin\r
  create_tree := true; --creation de l'arbre abstrait\r
  return true;\r
end Create_Spectacle;\r
\r
\r
function Set_Local_Variable (the_name : pstring) return boolean is\r
the_object : tad_local.object;\r
Exist : boolean := false;\r
begin\r
  tad_local.create_new_local_var(the_object, the_name.all);\r
  Exist := local_tree.element_exist(tmp_local_tree, the_object);\r
  if exist then\r
    return false;\r
  else\r
    begin\r
      local_tree.insert_element(tmp_local_tree, the_object);\r
      return true;\r
    end;\r
  end if;\r
end Set_Local_Variable;\r
\r
\r
function Set_Local_Group (the_name : pstring) return boolean is\r
the_object : tad_local.object;\r
Exist : boolean := false;\r
begin\r
  tad_local.create_new_local_var(the_object, the_name.all);\r
  Exist := local_tree.element_exist(tmp_local_tree, the_object);\r
  if exist then\r
    return false;\r
  else\r
    begin\r
      tad_local.set_type(the_object, tad_local.groupe);\r
      local_tree.insert_element(tmp_local_tree, the_object);\r
      tmp_group_tree := tad_local.get_members(the_object);\r
      return true;\r
    end;\r
  end if;\r
end Set_Local_Group;\r
\r
\r
function Add_Local_Group_Member (the_name : pstring) return boolean is\r
global_object : tad_global.object;\r
group_object  : tad_group.object;\r
Exist : boolean := false;\r
begin\r
  tad_global.create_new_station(global_object, the_name.all);\r
  exist := global_tree.element_exist(the_global_tree.object, global_object);\r
  if exist then\r
    begin\r
      tad_group.create_new_group_member(group_object, the_name.all);\r
      exist := group_tree.element_exist(tmp_group_tree, group_object);\r
      if exist then\r
    return false;\r
      else\r
    begin\r
      group_tree.insert_element(tmp_group_tree, group_object);\r
      return true;\r
    end;\r
      end if;\r
    end;\r
  else\r
    return false;\r
  end if;\r
end Add_Local_Group_Member;\r
\r
\r
--------------------------------------------------------------------------\r
--------------------------------------------------------------------------\r
-- primitives de creation de l'arbre abstrait\r
--------------------------------------------------------------------------\r
--------------------------------------------------------------------------\r
\r
procedure Syntax_Error is\r
begin\r
  create_tree := false;\r
end Syntax_Error;\r
\r
\r
\r
\r
function MKNode_Scene (the_name : pString) return boolean is\r
OK : boolean := false;\r
the_scene : tad_scene.object;\r
chain : tad_abstract.object(tad_abstract.chainage);\r
the_node : tad_abstract.object(tad_abstract.scene);\r
begin\r
  if create_tree then\r
    begin\r
      tad_scene.create_new_scene(the_scene, the_name.all);\r
      if scene_tree.element_exist(the_scene_tree.object, the_scene) then\r
    begin\r
      tmp_code_tree.all := chain;\r
      chain.left.all := the_node;\r
      tmp_code_tree := chain.right;\r
      the_node.right := tad_scene.get_code(the_scene);\r
      OK := true;\r
    end;\r
      else\r
    OK := false;\r
      end if;\r
    end;\r
  else\r
    OK := true;\r
  end if;\r
  return OK;\r
end MKNode_Scene;\r
\r
\r
function MKNode_Puis return boolean is\r
OK : boolean := false;\r
chain : tad_abstract.object(tad_abstract.chainage);\r
the_node : tad_abstract.object(tad_abstract.puis);\r
begin\r
  if create_tree then\r
    begin\r
      tmp_code_tree.all := chain;\r
      chain.left.all := the_node;\r
      tmp_code_tree := chain.right;\r
      OK := true;\r
    end;\r
  else\r
    OK := true;\r
  end if;\r
  return OK;\r
end MKNode_Puis;\r
\r
\r
function MKNode_Attendre (the_name : pString;\r
              the_type : Token.object) return boolean is\r
OK : boolean := false;\r
chain : tad_abstract.object(tad_abstract.chainage);\r
the_node : tad_abstract.object(tad_abstract.attendre);\r
type_node : tad_abstract.node_name;\r
begin\r
  if create_tree then\r
    begin\r
      case the_type is\r
    when token.L_Id   => declare\r
                   the_var : tad_local.object;\r
                 begin\r
                   tad_local.create_new_Local_Var(the_var,\r
                                  the_name.all);\r
                   if local_tree.element_exist(tmp_local_tree,\r
                               the_var) then\r
                 begin\r
                   type_node := tad_abstract.Feuille_Id;\r
                   OK := true;\r
                 end;\r
                   end if;\r
                 end;\r
    when token.L_Time => type_node := tad_abstract.feuille_Temp;\r
                 OK := true;\r
    when token.L_Int  => OK := false;\r
    when others       => OK := false;\r
      end case;\r
      if OK then\r
    begin\r
      tmp_code_tree.all := chain;\r
      chain.left.all := the_node;\r
      tmp_code_tree := chain.right;\r
        declare\r
          use tad_abstract;\r
          the_leaf : tad_abstract.object(type_node);\r
        begin\r
          the_node.left.all := the_leaf;\r
          if (type_node = node_name'(feuille_temp)) then\r
        the_leaf.valeur := natural'value(the_name.all);\r
          end if;\r
          if (type_node = node_name'(feuille_Id)) then\r
        the_leaf.nom.all := the_name.all;\r
          end if;\r
        end;\r
    end;\r
      end if;\r
    end;\r
  else\r
    OK := true;\r
  end if;\r
  return OK;\r
end MKNode_Attendre;\r
\r
\r
function MKNode_Faire return boolean is\r
OK : boolean := false;\r
chain : tad_abstract.object(tad_abstract.chainage);\r
the_node : tad_abstract.object(tad_abstract.faire);\r
begin\r
  if create_tree then\r
    begin\r
      tmp_code_tree.all := chain;\r
      chain.left.all := the_node;\r
      tmp_code_tree := chain.right;\r
      pointer_level.enter(tmp_code_tree);\r
      tmp_code_tree := the_node.left;\r
      OK := true;\r
    end;\r
  else\r
    OK := true;\r
  end if;\r
  return OK;\r
end MKNode_Faire;\r
\r
\r
function MKNode_Fin_Faire return boolean is\r
OK : boolean := false;\r
begin\r
  if create_tree then\r
    begin\r
      tmp_code_tree := pointer_level.release;\r
      OK := true;\r
    end;\r
  else\r
    OK := true;\r
  end if;\r
  return OK;\r
end MKNode_Fin_Faire;\r
\r
\r
function MKNode_Au_Temps (Value : pString;\r
              the_type : Token.object) return boolean is\r
OK : boolean := false;\r
chain : tad_abstract.object(tad_abstract.chainage);\r
the_node : tad_abstract.object(tad_abstract.attendre);\r
type_node : tad_abstract.node_name;\r
begin\r
  if create_tree then\r
    begin\r
      case the_type is\r
    when token.L_Id   => declare\r
                   the_var : tad_local.object;\r
                 begin\r
                   tad_local.create_new_Local_Var(the_var,\r
                                  Value.all);\r
                   if local_tree.element_exist(tmp_local_tree,\r
                               the_var) then\r
                 begin\r
                   type_node := tad_abstract.Feuille_Id;\r
                   OK := true;\r
                 end;\r
                   end if;\r
                 end;\r
    when token.L_Time => type_node := tad_abstract.feuille_Temp;\r
                 OK := true;\r
    when token.L_Int  => OK := false;\r
    when others       => OK := false;\r
      end case;\r
      if OK then\r
    begin\r
      tmp_code_tree.all := chain;\r
      chain.left.all := the_node;\r
      tmp_code_tree := chain.right;\r
        declare\r
          use tad_abstract;\r
          the_leaf : tad_abstract.object(type_node);\r
        begin\r
          the_node.left.all := the_leaf;\r
          if (type_node = node_name'(feuille_temp)) then\r
        the_leaf.valeur := natural'value(Value.all);\r
          end if;\r
          if (type_node = node_name'(feuille_Id)) then\r
        the_leaf.nom.all := Value.all;\r
          end if;\r
        end;\r
    end;\r
      end if;\r
    end;\r
  else\r
    OK := true;\r
  end if;\r
  return OK;\r
end MKNode_Au_Temps;\r
\r
\r
function MKNode_Si_Cond return boolean is\r
OK : boolean := false;\r
chain : tad_abstract.object(tad_abstract.chainage);\r
the_node : tad_abstract.object(tad_abstract.Si);\r
begin\r
  if create_tree then\r
    begin\r
      tmp_code_tree.all := chain;\r
      chain.left.all := the_node;\r
      tmp_code_tree := chain.right;\r
      pointer_level.enter(tmp_code_tree);\r
      pointer_level.enter(the_node.right);\r
      pointer_level.enter(the_node.left);\r
      tmp_code_tree := null;\r
      OK := true;\r
    end;\r
  else\r
    OK := true;\r
  end if;\r
  return OK;\r
end MKNode_Si_Cond;\r
\r
\r
function MKNode_Operateur (Operateur_type : Token.object) return boolean is\r
OK : boolean := false;\r
node_type : tad_abstract.node_name;\r
begin\r
  if create_tree then\r
    begin\r
      case Operateur_type is\r
    when token.L_Egal        => node_type := tad_abstract.N_Egal;\r
                    OK := true;\r
    when token.L_Inf         => node_type := tad_abstract.N_Inf;\r
                    OK := true;\r
    when token.L_Sup         => node_type := tad_abstract.N_Sup;\r
                    OK := true;\r
    when token.L_Inf_ou_Egal => node_type := tad_abstract.N_Inf_Egal;\r
                    OK := true;\r
    when token.L_Sup_ou_Egal => node_type := tad_abstract.N_Sup_Egal;\r
                    OK := true;\r
    when others              => OK := false;\r
      end case;\r
    declare\r
      the_node : tad_abstract.object(node_type);\r
    begin\r
      the_node.left := tmp_code_tree;\r
      tmp_code_tree := pointer_level.release;\r
      tmp_code_tree.all := the_node;\r
      tmp_code_tree := the_node.right;\r
    end;\r
      OK := true;\r
    end;\r
  else\r
    OK := true;\r
  end if;\r
  return OK;\r
end MKNode_Operateur;\r
\r
\r
function MKNode_Si_Alors return boolean is\r
OK : boolean := false;\r
begin\r
  if create_tree then\r
    begin\r
      tmp_code_tree := pointer_level.release;\r
      OK := true;\r
    end;\r
  else\r
    OK := true;\r
  end if;\r
  return OK;\r
end MKNode_Si_Alors;\r
\r
\r
function MKNode_Fin_Si return boolean is\r
OK : boolean := false;\r
begin\r
  if create_tree then\r
    begin\r
      tmp_code_tree := pointer_level.release;\r
      OK := true;\r
    end;\r
  else\r
    OK := true;\r
  end if;\r
  return OK;\r
end MKNode_Fin_Si;\r
\r
\r
function MKNode_Repeter (Value : pString;\r
             the_type : Token.object) return boolean is\r
OK : boolean := false;\r
chain : tad_abstract.object(tad_abstract.chainage);\r
the_node : tad_abstract.object(tad_abstract.repeter);\r
type_node : tad_abstract.node_name;\r
begin\r
  if create_tree then\r
    begin\r
      case the_type is\r
    when token.L_Id   => declare\r
                   the_var : tad_local.object;\r
                 begin\r
                   tad_local.create_new_Local_Var(the_var,\r
                                  value.all);\r
                   if local_tree.element_exist(tmp_local_tree,\r
                               the_var) then\r
                 begin\r
                   type_node := tad_abstract.Feuille_Id;\r
                   OK := true;\r
                 end;\r
                   end if;\r
                 end;\r
    when token.L_Int  => type_node := tad_abstract.feuille_entier;\r
                 OK := true;\r
    when token.L_Time => OK := false;\r
    when others       => OK := false;\r
      end case;\r
      if OK then\r
    begin\r
      tmp_code_tree.all := chain;\r
      chain.left.all := the_node;\r
      pointer_level.enter(chain.right);\r
      tmp_code_tree := the_node.right;\r
        declare\r
          use tad_abstract;\r
          the_leaf : tad_abstract.object(type_node);\r
        begin\r
          the_node.left.all := the_leaf;\r
          if (type_node = node_name'(feuille_entier)) then\r
        the_leaf.valeur := natural'value(value.all);\r
          end if;\r
          if (type_node = node_name'(feuille_Id)) then\r
        the_leaf.nom.all := value.all;\r
          end if;\r
        end;\r
    end;\r
      end if;\r
    end;\r
  else\r
    OK := true;\r
  end if;\r
  return OK;\r
end MKNode_Repeter;\r
\r
\r
function MKNode_Fin_Repeter return boolean is\r
OK : boolean := false;\r
begin\r
  if create_tree then\r
    begin\r
      tmp_code_tree := pointer_level.release;\r
      OK := true;\r
    end;\r
  else\r
    OK := true;\r
  end if;\r
  return OK;\r
end MKNode_Fin_Repeter;\r
\r
\r
function MKNode_Activer (Station : pString;\r
             Actor : pString) return boolean is\r
OK : boolean := false;\r
chain : tad_abstract.object(tad_abstract.chainage);\r
the_node : tad_abstract.object(tad_abstract.activer);\r
station_leaf : tad_abstract.object(tad_abstract.feuille_station);\r
actor_leaf : tad_abstract.object(tad_abstract.feuille_acteur);\r
the_station : tad_global.object;\r
the_material : tad_material.object;\r
the_actor_tree : actor_tree.object;\r
the_actor : tad_actor.object;\r
begin\r
  if create_tree then\r
    begin\r
      tad_global.create_new_station(the_station, station.all);\r
      if global_tree.element_exist(the_global_tree.object, the_station) then\r
    begin\r
      OK := true;\r
      station_leaf.station := tad_global.get_station_number(the_station);\r
      tad_global.get_material_type(the_station, the_material);\r
      tad_material.get_actors(the_material, the_actor_tree);\r
      tad_actor.create_new_actor(the_actor, actor.all);\r
      if actor_tree.element_exist(the_actor_tree, the_actor) then\r
        begin\r
          actor_leaf.acteur := tad_actor.what_address(the_actor);\r
          the_node.left.all := station_leaf;\r
          the_node.right.all := actor_leaf;\r
          tmp_code_tree.all := chain;\r
          chain.right.all := the_node;\r
          tmp_code_tree := chain.left;\r
        end;\r
      else\r
        OK := false;\r
      end if;\r
    end;\r
      else\r
    OK := false;\r
      end if;\r
    end;\r
  else\r
    OK := true;\r
  end if;\r
  return OK;\r
end MKNode_Activer;\r
\r
\r
function MKNode_Desactiver (Station : pString;\r
                Actor : pString) return boolean is\r
OK : boolean := false;\r
chain : tad_abstract.object(tad_abstract.chainage);\r
the_node : tad_abstract.object(tad_abstract.desactiver);\r
station_leaf : tad_abstract.object(tad_abstract.feuille_station);\r
actor_leaf : tad_abstract.object(tad_abstract.feuille_acteur);\r
the_station : tad_global.object;\r
the_material : tad_material.object;\r
the_actor_tree : actor_tree.object;\r
the_actor : tad_actor.object;\r
begin\r
  if create_tree then\r
    begin\r
      tad_global.create_new_station(the_station, station.all);\r
      if global_tree.element_exist(the_global_tree.object, the_station) then\r
    begin\r
      OK := true;\r
      station_leaf.station := tad_global.get_station_number(the_station);\r
      tad_global.get_material_type(the_station, the_material);\r
      tad_material.get_actors(the_material, the_actor_tree);\r
      tad_actor.create_new_actor(the_actor, actor.all);\r
      if actor_tree.element_exist(the_actor_tree, the_actor) then\r
        begin\r
          actor_leaf.acteur := tad_actor.what_address(the_actor);\r
          the_node.left.all := station_leaf;\r
          the_node.right.all := actor_leaf;\r
          tmp_code_tree.all := chain;\r
          chain.right.all := the_node;\r
          tmp_code_tree := chain.left;\r
        end;\r
      else\r
        OK := false;\r
      end if;\r
    end;\r
      else\r
    OK := false;\r
      end if;\r
    end;\r
  else\r
    OK := true;\r
  end if;\r
  return OK;\r
end MKNode_Desactiver;\r
\r
\r
function MKNode_Experience (the_name : pString) return boolean is\r
OK : boolean := false;\r
the_exp : tad_experience.object;\r
chain : tad_abstract.object(tad_abstract.chainage);\r
the_node : tad_abstract.object(tad_abstract.exp);\r
begin\r
  if create_tree then\r
    begin\r
      tad_experience.create_new_experience(the_exp, the_name.all);\r
      if experience_tree.element_exist(the_experience_tree.object,\r
                       the_exp) then\r
    begin\r
      tmp_code_tree.all := chain;\r
      chain.left.all := the_node;\r
      tmp_code_tree := chain.right;\r
      the_node.left := tad_experience.get_code(the_exp);\r
      pointer_level.enter(tmp_code_tree);\r
      tmp_code_tree := the_node.right;\r
      OK := true;\r
    end;\r
      else\r
    OK := false;\r
      end if;\r
    end;\r
  else\r
    OK := true;\r
  end if;\r
  return OK;\r
end MKNode_Experience;\r
\r
\r
function MKNode_Param (Value : pString;\r
               the_type : Token.object) return boolean is\r
OK : boolean := false;\r
type_node : tad_abstract.node_name;\r
the_node : tad_abstract.object(tad_abstract.param);\r
begin\r
  if create_tree then\r
    begin\r
      case the_type is\r
    when token.L_Id   => declare\r
                   the_var : tad_local.object;\r
                 begin\r
                   tad_local.create_new_Local_Var(the_var,\r
                                  value.all);\r
                   if local_tree.element_exist(tmp_local_tree,\r
                               the_var) then\r
                 begin\r
                   type_node := tad_abstract.Feuille_Id;\r
                   OK := true;\r
                 end;\r
                   end if;\r
                 end;\r
    when token.L_Int  => type_node := tad_abstract.feuille_entier;\r
                 OK := true;\r
    when token.L_Time => type_node := tad_abstract.feuille_temp;\r
                 OK := true;\r
    when others       => OK := false;\r
      end case;\r
      if OK then\r
    begin\r
      tmp_code_tree.all := the_node;\r
      tmp_code_tree := the_node.right;\r
        declare\r
          use tad_abstract;\r
          the_leaf : tad_abstract.object(type_node);\r
        begin\r
          the_node.left.all := the_leaf;\r
        case type_node is\r
          when node_name'(feuille_entier) =>\r
                  the_leaf.valeur := natural'value(value.all);\r
          when node_name'(feuille_temp)   =>\r
                  the_leaf.valeur := natural'value(value.all);\r
          when node_name'(feuille_Id)     =>\r
                  the_leaf.nom.all:= value.all;\r
          when others                     => OK := false;\r
        end case;\r
        end;\r
    end;\r
      end if;\r
    end;\r
  else\r
    OK := true;\r
  end if;\r
  return OK;\r
end MKNode_Param;\r
\r
\r
function MKNode_Fin_Param return boolean is\r
OK : boolean := false;\r
begin\r
  if create_tree then\r
    begin\r
      tmp_code_tree := pointer_level.release;\r
      OK := true;\r
    end;\r
  else\r
    OK := true;\r
  end if;\r
  return OK;\r
end MKNode_Fin_Param;\r
\r
\r
function MKNode_Fugitif (Station : pString;\r
             Actor : pString) return boolean is\r
OK : boolean := false;\r
chain : tad_abstract.object(tad_abstract.chainage);\r
the_node : tad_abstract.object(tad_abstract.fugitif);\r
station_leaf : tad_abstract.object(tad_abstract.feuille_station);\r
actor_leaf : tad_abstract.object(tad_abstract.feuille_acteur);\r
the_station : tad_global.object;\r
the_material : tad_material.object;\r
the_actor_tree : actor_tree.object;\r
the_actor : tad_actor.object;\r
begin\r
  if create_tree then\r
    begin\r
      tad_global.create_new_station(the_station, station.all);\r
      if global_tree.element_exist(the_global_tree.object, the_station) then\r
    begin\r
      OK := true;\r
      station_leaf.station := tad_global.get_station_number(the_station);\r
      tad_global.get_material_type(the_station, the_material);\r
      tad_material.get_actors(the_material, the_actor_tree);\r
      tad_actor.create_new_actor(the_actor, actor.all);\r
      if actor_tree.element_exist(the_actor_tree, the_actor) then\r
        begin\r
          actor_leaf.acteur := tad_actor.what_address(the_actor);\r
          the_node.left.all := station_leaf;\r
          the_node.right.all := actor_leaf;\r
          tmp_code_tree.all := chain;\r
          chain.right.all := the_node;\r
          tmp_code_tree := chain.left;\r
        end;\r
      else\r
        OK := false;\r
      end if;\r
    end;\r
      else\r
    OK := false;\r
      end if;\r
    end;\r
  else\r
    OK := true;\r
  end if;\r
  return OK;\r
end MKNode_Fugitif;\r
\r
\r
function MKNode_Temporel (Station : pString;\r
              Actor : pString;\r
              Value : pString;\r
              the_type : Token.object;\r
              Time : pString;\r
              the_time_type : Token.object) return boolean is\r
OK : boolean := false;\r
chain : tad_abstract.object(tad_abstract.chainage);\r
type_node : tad_abstract.node_name;\r
the_node : tad_abstract.object(tad_abstract.discret);\r
the_sec_node : tad_abstract.object(tad_abstract.qui);\r
station_leaf : tad_abstract.object(tad_abstract.feuille_station);\r
actor_leaf : tad_abstract.object(tad_abstract.feuille_acteur);\r
the_station : tad_global.object;\r
the_material : tad_material.object;\r
the_actor_tree : actor_tree.object;\r
the_actor : tad_actor.object;\r
begin\r
  if create_tree then\r
    begin\r
      tad_global.create_new_station(the_station, station.all);\r
      if global_tree.element_exist(the_global_tree.object, the_station) then\r
    begin\r
      OK := true;\r
      station_leaf.station := tad_global.get_station_number(the_station);\r
      tad_global.get_material_type(the_station, the_material);\r
      tad_material.get_actors(the_material, the_actor_tree);\r
      tad_actor.create_new_actor(the_actor, actor.all);\r
      if actor_tree.element_exist(the_actor_tree, the_actor) then\r
        begin\r
          actor_leaf.acteur := tad_actor.what_address(the_actor);\r
          the_node.left.all := station_leaf;\r
          the_node.right.all := the_sec_node;\r
          tmp_code_tree.all := chain;\r
          chain.right.all := the_node;\r
          tmp_code_tree := chain.left;\r
          the_sec_node.left.all := actor_leaf;\r
\r
      case the_type is\r
    when token.L_Id   => declare\r
                   the_var : tad_local.object;\r
                 begin\r
                   tad_local.create_new_Local_Var(the_var,\r
                                  value.all);\r
                   if local_tree.element_exist(tmp_local_tree,\r
                               the_var) then\r
                 begin\r
                   type_node := tad_abstract.Feuille_Id;\r
                   OK := true;\r
                 end;\r
                   end if;\r
                 end;\r
    when token.L_Int  => type_node := tad_abstract.feuille_entier;\r
                 OK := true;\r
    when token.L_Time => OK := false;\r
    when others       => OK := false;\r
      end case;\r
      if OK then\r
    begin\r
        declare\r
          use tad_abstract;\r
          the_leaf : tad_abstract.object(type_node);\r
        begin\r
          the_sec_node.right.all := the_leaf;\r
        case type_node is\r
          when node_name'(feuille_entier) =>\r
                  the_leaf.valeur := natural'value(value.all);\r
          when node_name'(feuille_Id)     =>\r
                  the_leaf.nom.all:= value.all;\r
          when others                     => OK := false;\r
        end case;\r
        end;\r
    end;\r
      end if;\r
\r
      case the_time_type is\r
    when token.L_Id   => declare\r
                   the_var : tad_local.object;\r
                 begin\r
                   tad_local.create_new_Local_Var(the_var,\r
                                  time.all);\r
                   if local_tree.element_exist(tmp_local_tree,\r
                               the_var) then\r
                 begin\r
                   type_node := tad_abstract.Feuille_Id;\r
                   OK := true;\r
                 end;\r
                   end if;\r
                 end;\r
    when token.L_Time  => type_node := tad_abstract.feuille_temp;\r
                 OK := true;\r
    when token.L_Int  => OK := false;\r
    when others       => OK := false;\r
      end case;\r
      if OK then\r
    begin\r
        declare\r
          use tad_abstract;\r
          the_leaf : tad_abstract.object(type_node);\r
        begin\r
          the_sec_node.right.all := the_leaf;\r
        case type_node is\r
          when node_name'(feuille_temp) =>\r
                  the_leaf.valeur := natural'value(time.all);\r
          when node_name'(feuille_Id)     =>\r
                  the_leaf.nom.all:= time.all;\r
          when others                     => OK := false;\r
        end case;\r
        end;\r
    end;\r
      end if;\r
\r
\r
        end;\r
      else\r
        OK := false;\r
      end if;\r
\r
    end;\r
      else\r
    OK := false;\r
      end if;\r
    end;\r
  else\r
    OK := true;\r
  end if;\r
  return OK;\r
end MKNode_Temporel;\r
\r
\r
function MKNode_Discret (Station : pString;\r
             Actor : pString;\r
             Value : pString;\r
             the_type : Token.object) return boolean is\r
OK : boolean := false;\r
chain : tad_abstract.object(tad_abstract.chainage);\r
type_node : tad_abstract.node_name;\r
the_node : tad_abstract.object(tad_abstract.discret);\r
the_sec_node : tad_abstract.object(tad_abstract.qui);\r
station_leaf : tad_abstract.object(tad_abstract.feuille_station);\r
actor_leaf : tad_abstract.object(tad_abstract.feuille_acteur);\r
the_station : tad_global.object;\r
the_material : tad_material.object;\r
the_actor_tree : actor_tree.object;\r
the_actor : tad_actor.object;\r
begin\r
  if create_tree then\r
    begin\r
      tad_global.create_new_station(the_station, station.all);\r
      if global_tree.element_exist(the_global_tree.object, the_station) then\r
    begin\r
      OK := true;\r
      station_leaf.station := tad_global.get_station_number(the_station);\r
      tad_global.get_material_type(the_station, the_material);\r
      tad_material.get_actors(the_material, the_actor_tree);\r
      tad_actor.create_new_actor(the_actor, actor.all);\r
      if actor_tree.element_exist(the_actor_tree, the_actor) then\r
        begin\r
          actor_leaf.acteur := tad_actor.what_address(the_actor);\r
          the_node.left.all := station_leaf;\r
          the_node.right.all := the_sec_node;\r
          tmp_code_tree.all := chain;\r
          chain.right.all := the_node;\r
          tmp_code_tree := chain.left;\r
          the_sec_node.left.all := actor_leaf;\r
\r
      case the_type is\r
    when token.L_Id   => declare\r
                   the_var : tad_local.object;\r
                 begin\r
                   tad_local.create_new_Local_Var(the_var,\r
                                  value.all);\r
                   if local_tree.element_exist(tmp_local_tree,\r
                               the_var) then\r
                 begin\r
                   type_node := tad_abstract.Feuille_Id;\r
                   OK := true;\r
                 end;\r
                   end if;\r
                 end;\r
    when token.L_Int  => type_node := tad_abstract.feuille_entier;\r
                 OK := true;\r
    when token.L_Time => OK := false;\r
    when others       => OK := false;\r
      end case;\r
      if OK then\r
    begin\r
        declare\r
          use tad_abstract;\r
          the_leaf : tad_abstract.object(type_node);\r
        begin\r
          the_sec_node.right.all := the_leaf;\r
        case type_node is\r
          when node_name'(feuille_entier) =>\r
                  the_leaf.valeur := natural'value(value.all);\r
          when node_name'(feuille_Id)     =>\r
                  the_leaf.nom.all:= value.all;\r
          when others                     => OK := false;\r
        end case;\r
        end;\r
    end;\r
      end if;\r
\r
\r
        end;\r
      else\r
        OK := false;\r
      end if;\r
\r
    end;\r
      else\r
    OK := false;\r
      end if;\r
    end;\r
  else\r
    OK := true;\r
  end if;\r
  return OK;\r
end MKNode_Discret;\r
\r
\r
function MKNode_Eval (value : pString;\r
              the_type : Token.object;\r
              Operator : Token.object := Token.L_UNK) return boolean is\r
OK : boolean := false;\r
begin\r
  if create_tree then\r
    begin\r
      null;\r
    end;\r
  else\r
    OK := true;\r
  end if;\r
  return OK;\r
end MKNode_Eval;\r
\r
\r
function MKNode_Priorite (Priority : Token.object) return boolean is\r
OK : boolean := false;\r
the_node : tad_abstract.object(tad_abstract.N_Parent);\r
begin\r
  if create_tree then\r
    begin\r
      case priority is\r
    when token.L_Parentheseg =>\r
                    tmp_code_tree.all := the_node;\r
                    pointer_level.enter(tmp_code_tree);\r
                    tmp_code_tree := the_node.left;\r
                    OK := true;\r
    when token.L_Parenthesed => tmp_code_tree := pointer_level.release;\r
                    OK := true;\r
    when others              => OK := false;\r
      end case;\r
    end;\r
  else\r
    OK := true;\r
  end if;\r
  return OK;\r
end MKNode_Priorite;\r
\r
\r
end TDS;\r
\r
\r
\r
\r
\r
\r
\r
\r
\r
\r
with tad_abstract;\r
\r
package body pointer_level is\r
\r
  type ptr_array is array(1..100) of tad_abstract.pobject;\r
\r
  the_pointer_array : ptr_array;\r
  index : natural := 0;\r
\r
\r
procedure enter(pointer : tad_abstract.pobject) is\r
begin\r
  index := index + 1;\r
  the_pointer_array(index) := pointer;\r
end enter;\r
\r
function release return tad_abstract.pobject is\r
tmp : tad_abstract.pobject;\r
begin\r
  if index /= 0 then\r
    begin\r
      tmp := the_pointer_array(index);\r
      index := index -1;\r
    end;\r
  else\r
    tmp := null;\r
  end if;\r
  return tmp;\r
end release;\r
\r
end pointer_level;\r
\r
▶1a◀
DataMuseum.dk

Rational R1000/400 Tapes

⟦3b29fb419⟧ TextFile

Derivation

TextFile
