File : prj-attr.adb
1 ------------------------------------------------------------------------------
2 -- --
3 -- GNAT COMPILER COMPONENTS --
4 -- --
5 -- P R J . A T T R --
6 -- --
7 -- B o d y --
8 -- --
9 -- Copyright (C) 2001-2015, Free Software Foundation, Inc. --
10 -- --
11 -- GNAT is free software; you can redistribute it and/or modify it under --
12 -- terms of the GNU General Public License as published by the Free Soft- --
13 -- ware Foundation; either version 3, or (at your option) any later ver- --
14 -- sion. GNAT is distributed in the hope that it will be useful, but WITH- --
15 -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY --
16 -- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License --
17 -- for more details. You should have received a copy of the GNU General --
18 -- Public License distributed with GNAT; see file COPYING3. If not, go to --
19 -- http://www.gnu.org/licenses for a complete copy of the license. --
20 -- --
21 -- GNAT was originally developed by the GNAT team at New York University. --
22 -- Extensive contributions were provided by Ada Core Technologies Inc. --
23 -- --
24 ------------------------------------------------------------------------------
25
26 with Osint;
27 with Prj.Com; use Prj.Com;
28
29 with GNAT.Case_Util; use GNAT.Case_Util;
30
31 package body Prj.Attr is
32
33 use GNAT;
34
35 -- Data for predefined attributes and packages
36
37 -- Names are in lower case and end with '#' or 'D'
38
39 -- Package names are preceded by 'P'
40
41 -- Attribute names are preceded by two or three letters:
42
43 -- The first letter is one of
44 -- 'S' for Single
45 -- 's' for Single with optional index
46 -- 'L' for List
47 -- 'l' for List of strings with optional indexes
48
49 -- The second letter is one of
50 -- 'V' for single variable
51 -- 'A' for associative array
52 -- 'a' for case insensitive associative array
53 -- 'b' for associative array, case insensitive if file names are case
54 -- insensitive
55 -- 'c' same as 'b', with optional index
56
57 -- The third optional letter is
58 -- 'R' the attribute is read-only
59 -- 'O' others is allowed as an index for an associative array
60
61 -- If the character after the name in lower case letter is a 'D' (for
62 -- default), then 'D' must be followed by an enumeration value of type
63 -- Attribute_Default_Value, followed by a '#'.
64
65 -- Example:
66 -- "SVobject_dirDdot_value#"
67
68 -- End is indicated by two consecutive '#'.
69
70 Initialization_Data : constant String :=
71
72 -- project level attributes
73
74 -- General
75
76 "SVRname#" &
77 "SVRproject_dir#" &
78 "lVmain#" &
79 "LVlanguages#" &
80 "Lbroots#" &
81 "SVexternally_built#" &
82
83 -- Directories
84
85 "SVobject_dirDdot_value#" &
86 "SVexec_dirDobject_dir_value#" &
87 "LVsource_dirsDdot_value#" &
88 "Lainherit_source_path#" &
89 "LVexcluded_source_dirs#" &
90 "LVignore_source_sub_dirs#" &
91
92 -- Source files
93
94 "LVsource_files#" &
95 "LVlocally_removed_files#" &
96 "LVexcluded_source_files#" &
97 "SVsource_list_file#" &
98 "SVexcluded_source_list_file#" &
99 "LVinterfaces#" &
100
101 -- Projects (in aggregate projects)
102
103 "LVproject_files#" &
104 "LVproject_path#" &
105 "SAexternal#" &
106
107 -- Libraries
108
109 "SVlibrary_dir#" &
110 "SVlibrary_name#" &
111 "SVlibrary_kind#" &
112 "SVlibrary_version#" &
113 "LVlibrary_interface#" &
114 "SVlibrary_standalone#" &
115 "LVlibrary_encapsulated_options#" &
116 "SVlibrary_encapsulated_supported#" &
117 "SVlibrary_auto_init#" &
118 "LVleading_library_options#" &
119 "LVlibrary_options#" &
120 "Lalibrary_rpath_options#" &
121 "SVlibrary_src_dir#" &
122 "SVlibrary_ali_dir#" &
123 "SVlibrary_gcc#" &
124 "SVlibrary_symbol_file#" &
125 "SVlibrary_symbol_policy#" &
126 "SVlibrary_reference_symbol_file#" &
127
128 -- Configuration - General
129
130 "SVdefault_language#" &
131 "LVrun_path_option#" &
132 "SVrun_path_origin#" &
133 "SVseparate_run_path_options#" &
134 "Satoolchain_version#" &
135 "Satoolchain_description#" &
136 "Saobject_generated#" &
137 "Saobjects_linked#" &
138 "SVtargetDtarget_value#" &
139 "SaruntimeDruntime_value#" &
140
141 -- Configuration - Libraries
142
143 "SVlibrary_builder#" &
144 "SVlibrary_support#" &
145
146 -- Configuration - Archives
147
148 "LVarchive_builder#" &
149 "LVarchive_builder_append_option#" &
150 "LVarchive_indexer#" &
151 "SVarchive_suffix#" &
152 "LVlibrary_partial_linker#" &
153
154 -- Configuration - Shared libraries
155
156 "SVshared_library_prefix#" &
157 "SVshared_library_suffix#" &
158 "SVsymbolic_link_supported#" &
159 "SVlibrary_major_minor_id_supported#" &
160 "SVlibrary_auto_init_supported#" &
161 "LVshared_library_minimum_switches#" &
162 "LVlibrary_version_switches#" &
163 "SVlibrary_install_name_option#" &
164 "Saruntime_library_dir#" &
165 "Saruntime_source_dir#" &
166
167 -- package Naming
168 -- Some attributes are obsolescent, and renamed in the tree (see
169 -- Prj.Dect.Rename_Obsolescent_Attributes).
170
171 "Pnaming#" &
172 "Saspecification_suffix#" & -- Always renamed to "spec_suffix" in tree
173 "Saspec_suffix#" &
174 "Saimplementation_suffix#" & -- Always renamed to "body_suffix" in tree
175 "Sabody_suffix#" &
176 "SVseparate_suffix#" &
177 "SVcasing#" &
178 "SVdot_replacement#" &
179 "saspecification#" & -- Always renamed to "spec" in project tree
180 "saspec#" &
181 "saimplementation#" & -- Always renamed to "body" in project tree
182 "sabody#" &
183 "Laspecification_exceptions#" &
184 "Laimplementation_exceptions#" &
185
186 -- package Compiler
187
188 "Pcompiler#" &
189 "Ladefault_switches#" &
190 "LcOswitches#" &
191 "SVlocal_configuration_pragmas#" &
192 "Salocal_config_file#" &
193
194 -- Configuration - Compiling
195
196 "Sadriver#" &
197 "Salanguage_kind#" &
198 "Sadependency_kind#" &
199 "Larequired_switches#" &
200 "Laleading_required_switches#" &
201 "Latrailing_required_switches#" &
202 "Lapic_option#" &
203 "Sapath_syntax#" &
204 "Lasource_file_switches#" &
205 "Saobject_file_suffix#" &
206 "Laobject_file_switches#" &
207 "Lamulti_unit_switches#" &
208 "Samulti_unit_object_separator#" &
209
210 -- Configuration - Mapping files
211
212 "Lamapping_file_switches#" &
213 "Samapping_spec_suffix#" &
214 "Samapping_body_suffix#" &
215
216 -- Configuration - Config files
217
218 "Laconfig_file_switches#" &
219 "Saconfig_body_file_name#" &
220 "Saconfig_body_file_name_index#" &
221 "Saconfig_body_file_name_pattern#" &
222 "Saconfig_spec_file_name#" &
223 "Saconfig_spec_file_name_index#" &
224 "Saconfig_spec_file_name_pattern#" &
225 "Saconfig_file_unique#" &
226
227 -- Configuration - Dependencies
228
229 "Ladependency_switches#" &
230 "Ladependency_driver#" &
231
232 -- Configuration - Search paths
233
234 "Lainclude_switches#" &
235 "Sainclude_path#" &
236 "Sainclude_path_file#" &
237 "Laobject_path_switches#" &
238
239 -- package Builder
240
241 "Pbuilder#" &
242 "Ladefault_switches#" &
243 "LcOswitches#" &
244 "Lcglobal_compilation_switches#" &
245 "Scexecutable#" &
246 "SVexecutable_suffix#" &
247 "SVglobal_configuration_pragmas#" &
248 "Saglobal_config_file#" &
249
250 -- package gnatls
251
252 "Pgnatls#" &
253 "LVswitches#" &
254
255 -- package Binder
256
257 "Pbinder#" &
258 "Ladefault_switches#" &
259 "LcOswitches#" &
260
261 -- Configuration - Binding
262
263 "Sadriver#" &
264 "Larequired_switches#" &
265 "Saprefix#" &
266 "Saobjects_path#" &
267 "Saobjects_path_file#" &
268
269 -- package Linker
270
271 "Plinker#" &
272 "LVrequired_switches#" &
273 "Ladefault_switches#" &
274 "LcOleading_switches#" &
275 "LcOswitches#" &
276 "LcOtrailing_switches#" &
277 "LVlinker_options#" &
278 "SVmap_file_option#" &
279
280 -- Configuration - Linking
281
282 "SVdriver#" &
283
284 -- Configuration - Response files
285
286 "SVmax_command_line_length#" &
287 "SVresponse_file_format#" &
288 "LVresponse_file_switches#" &
289
290 -- package Clean
291
292 "Pclean#" &
293 "LVswitches#" &
294 "Lasource_artifact_extensions#" &
295 "Laobject_artifact_extensions#" &
296 "LVartifacts_in_exec_dir#" &
297 "LVartifacts_in_object_dir#" &
298
299 -- package Cross_Reference
300
301 "Pcross_reference#" &
302 "Ladefault_switches#" &
303 "LbOswitches#" &
304
305 -- package Finder
306
307 "Pfinder#" &
308 "Ladefault_switches#" &
309 "LbOswitches#" &
310
311 -- package Pretty_Printer
312
313 "Ppretty_printer#" &
314 "Ladefault_switches#" &
315 "LbOswitches#" &
316
317 -- package gnatstub
318
319 "Pgnatstub#" &
320 "Ladefault_switches#" &
321 "LbOswitches#" &
322
323 -- package Check
324
325 "Pcheck#" &
326 "Ladefault_switches#" &
327 "LbOswitches#" &
328
329 -- package Eliminate
330
331 "Peliminate#" &
332 "Ladefault_switches#" &
333 "LbOswitches#" &
334
335 -- package Metrics
336
337 "Pmetrics#" &
338 "Ladefault_switches#" &
339 "LbOswitches#" &
340
341 -- package Ide
342
343 "Pide#" &
344 "Ladefault_switches#" &
345 "SVremote_host#" &
346 "SVprogram_host#" &
347 "SVcommunication_protocol#" &
348 "Sacompiler_command#" &
349 "SVdebugger_command#" &
350 "SVgnatlist#" &
351 "SVvcs_kind#" &
352 "SVvcs_file_check#" &
353 "SVvcs_log_check#" &
354 "SVdocumentation_dir#" &
355
356 -- package Install
357
358 "Pinstall#" &
359 "SVprefix#" &
360 "SVsources_subdir#" &
361 "SVexec_subdir#" &
362 "SVlib_subdir#" &
363 "SVproject_subdir#" &
364 "SVactive#" &
365 "LAartifacts#" &
366 "SVmode#" &
367 "SVinstall_name#" &
368
369 -- package Remote
370
371 "Premote#" &
372 "SVroot_dir#" &
373 "LVexcluded_patterns#" &
374 "LVincluded_patterns#" &
375 "LVincluded_artifact_patterns#" &
376
377 -- package Stack
378
379 "Pstack#" &
380 "LVswitches#" &
381
382 -- package Codepeer
383
384 "Pcodepeer#" &
385 "SVoutput_directory#" &
386 "SVdatabase_directory#" &
387 "SVmessage_patterns#" &
388 "SVadditional_patterns#" &
389 "LVswitches#" &
390 "LVexcluded_source_files#" &
391
392 -- package Prove
393
394 "Pprove#" &
395
396 -- package GnatTest
397
398 "Pgnattest#" &
399
400 "#";
401
402 Initialized : Boolean := False;
403 -- A flag to avoid multiple initialization
404
405 Package_Names : String_List_Access := new Strings.String_List (1 .. 20);
406 Last_Package_Name : Natural := 0;
407 -- Package_Names (1 .. Last_Package_Name) contains the list of the known
408 -- package names, coming from the Initialization_Data string or from
409 -- calls to one of the two procedures Register_New_Package.
410
411 procedure Add_Package_Name (Name : String);
412 -- Add a package name in the Package_Name list, extending it, if necessary
413
414 function Name_Id_Of (Name : String) return Name_Id;
415 -- Returns the Name_Id for Name in lower case
416
417 ----------------------
418 -- Add_Package_Name --
419 ----------------------
420
421 procedure Add_Package_Name (Name : String) is
422 begin
423 if Last_Package_Name = Package_Names'Last then
424 declare
425 New_List : constant Strings.String_List_Access :=
426 new Strings.String_List (1 .. Package_Names'Last * 2);
427 begin
428 New_List (Package_Names'Range) := Package_Names.all;
429 Package_Names := New_List;
430 end;
431 end if;
432
433 Last_Package_Name := Last_Package_Name + 1;
434 Package_Names (Last_Package_Name) := new String'(Name);
435 end Add_Package_Name;
436
437 --------------------------
438 -- Attribute_Default_Of --
439 --------------------------
440
441 function Attribute_Default_Of
442 (Attribute : Attribute_Node_Id) return Attribute_Default_Value
443 is
444 begin
445 if Attribute = Empty_Attribute then
446 return Empty_Value;
447 else
448 return Attrs.Table (Attribute.Value).Default;
449 end if;
450 end Attribute_Default_Of;
451
452 -----------------------
453 -- Attribute_Kind_Of --
454 -----------------------
455
456 function Attribute_Kind_Of
457 (Attribute : Attribute_Node_Id) return Attribute_Kind
458 is
459 begin
460 if Attribute = Empty_Attribute then
461 return Unknown;
462 else
463 return Attrs.Table (Attribute.Value).Attr_Kind;
464 end if;
465 end Attribute_Kind_Of;
466
467 -----------------------
468 -- Attribute_Name_Of --
469 -----------------------
470
471 function Attribute_Name_Of (Attribute : Attribute_Node_Id) return Name_Id is
472 begin
473 if Attribute = Empty_Attribute then
474 return No_Name;
475 else
476 return Attrs.Table (Attribute.Value).Name;
477 end if;
478 end Attribute_Name_Of;
479
480 --------------------------
481 -- Attribute_Node_Id_Of --
482 --------------------------
483
484 function Attribute_Node_Id_Of
485 (Name : Name_Id;
486 Starting_At : Attribute_Node_Id) return Attribute_Node_Id
487 is
488 Id : Attr_Node_Id := Starting_At.Value;
489
490 begin
491 while Id /= Empty_Attr
492 and then Attrs.Table (Id).Name /= Name
493 loop
494 Id := Attrs.Table (Id).Next;
495 end loop;
496
497 return (Value => Id);
498 end Attribute_Node_Id_Of;
499
500 ----------------
501 -- Initialize --
502 ----------------
503
504 procedure Initialize is
505 Start : Positive := Initialization_Data'First;
506 Finish : Positive := Start;
507 Current_Package : Pkg_Node_Id := Empty_Pkg;
508 Current_Attribute : Attr_Node_Id := Empty_Attr;
509 Is_An_Attribute : Boolean := False;
510 Var_Kind : Variable_Kind := Undefined;
511 Optional_Index : Boolean := False;
512 Attr_Kind : Attribute_Kind := Single;
513 Package_Name : Name_Id := No_Name;
514 Attribute_Name : Name_Id := No_Name;
515 First_Attribute : Attr_Node_Id := Attr.First_Attribute;
516 Read_Only : Boolean;
517 Others_Allowed : Boolean;
518 Default : Attribute_Default_Value;
519
520 function Attribute_Location return String;
521 -- Returns a string depending if we are in the project level attributes
522 -- or in the attributes of a package.
523
524 ------------------------
525 -- Attribute_Location --
526 ------------------------
527
528 function Attribute_Location return String is
529 begin
530 if Package_Name = No_Name then
531 return "project level attributes";
532
533 else
534 return "attribute of package """ &
535 Get_Name_String (Package_Name) & """";
536 end if;
537 end Attribute_Location;
538
539 -- Start of processing for Initialize
540
541 begin
542 -- Don't allow Initialize action to be repeated
543
544 if Initialized then
545 return;
546 end if;
547
548 -- Make sure the two tables are empty
549
550 Attrs.Init;
551 Package_Attributes.Init;
552
553 while Initialization_Data (Start) /= '#' loop
554 Is_An_Attribute := True;
555 case Initialization_Data (Start) is
556 when 'P' =>
557
558 -- New allowed package
559
560 Start := Start + 1;
561
562 Finish := Start;
563 while Initialization_Data (Finish) /= '#' loop
564 Finish := Finish + 1;
565 end loop;
566
567 Package_Name :=
568 Name_Id_Of (Initialization_Data (Start .. Finish - 1));
569
570 for Index in First_Package .. Package_Attributes.Last loop
571 if Package_Name = Package_Attributes.Table (Index).Name then
572 Osint.Fail ("duplicate name """
573 & Initialization_Data (Start .. Finish - 1)
574 & """ in predefined packages.");
575 end if;
576 end loop;
577
578 Is_An_Attribute := False;
579 Current_Attribute := Empty_Attr;
580 Package_Attributes.Increment_Last;
581 Current_Package := Package_Attributes.Last;
582 Package_Attributes.Table (Current_Package) :=
583 (Name => Package_Name,
584 Known => True,
585 First_Attribute => Empty_Attr);
586 Start := Finish + 1;
587
588 Add_Package_Name (Get_Name_String (Package_Name));
589
590 when 'S' =>
591 Var_Kind := Single;
592 Optional_Index := False;
593
594 when 's' =>
595 Var_Kind := Single;
596 Optional_Index := True;
597
598 when 'L' =>
599 Var_Kind := List;
600 Optional_Index := False;
601
602 when 'l' =>
603 Var_Kind := List;
604 Optional_Index := True;
605
606 when others =>
607 raise Program_Error;
608 end case;
609
610 if Is_An_Attribute then
611
612 -- New attribute
613
614 Start := Start + 1;
615 case Initialization_Data (Start) is
616 when 'V' =>
617 Attr_Kind := Single;
618
619 when 'A' =>
620 Attr_Kind := Associative_Array;
621
622 when 'a' =>
623 Attr_Kind := Case_Insensitive_Associative_Array;
624
625 when 'b' =>
626 if Osint.File_Names_Case_Sensitive then
627 Attr_Kind := Associative_Array;
628 else
629 Attr_Kind := Case_Insensitive_Associative_Array;
630 end if;
631
632 when 'c' =>
633 if Osint.File_Names_Case_Sensitive then
634 Attr_Kind := Optional_Index_Associative_Array;
635 else
636 Attr_Kind :=
637 Optional_Index_Case_Insensitive_Associative_Array;
638 end if;
639
640 when others =>
641 raise Program_Error;
642 end case;
643
644 Start := Start + 1;
645
646 Read_Only := False;
647 Others_Allowed := False;
648 Default := Empty_Value;
649
650 if Initialization_Data (Start) = 'R' then
651 Read_Only := True;
652 Default := Read_Only_Value;
653 Start := Start + 1;
654
655 elsif Initialization_Data (Start) = 'O' then
656 Others_Allowed := True;
657 Start := Start + 1;
658 end if;
659
660 Finish := Start;
661
662 while Initialization_Data (Finish) /= '#'
663 and then
664 Initialization_Data (Finish) /= 'D'
665 loop
666 Finish := Finish + 1;
667 end loop;
668
669 Attribute_Name :=
670 Name_Id_Of (Initialization_Data (Start .. Finish - 1));
671
672 if Initialization_Data (Finish) = 'D' then
673 Start := Finish + 1;
674
675 Finish := Start;
676 while Initialization_Data (Finish) /= '#' loop
677 Finish := Finish + 1;
678 end loop;
679
680 declare
681 Default_Name : constant String :=
682 Initialization_Data (Start .. Finish - 1);
683 pragma Unsuppress (All_Checks);
684 begin
685 Default := Attribute_Default_Value'Value (Default_Name);
686 exception
687 when Constraint_Error =>
688 Osint.Fail
689 ("illegal default value """ &
690 Default_Name &
691 """ for attribute " &
692 Get_Name_String (Attribute_Name));
693 end;
694 end if;
695
696 Attrs.Increment_Last;
697
698 if Current_Attribute = Empty_Attr then
699 First_Attribute := Attrs.Last;
700
701 if Current_Package /= Empty_Pkg then
702 Package_Attributes.Table (Current_Package).First_Attribute
703 := Attrs.Last;
704 end if;
705
706 else
707 -- Check that there are no duplicate attributes
708
709 for Index in First_Attribute .. Attrs.Last - 1 loop
710 if Attribute_Name = Attrs.Table (Index).Name then
711 Osint.Fail ("duplicate attribute """
712 & Initialization_Data (Start .. Finish - 1)
713 & """ in " & Attribute_Location);
714 end if;
715 end loop;
716
717 Attrs.Table (Current_Attribute).Next :=
718 Attrs.Last;
719 end if;
720
721 Current_Attribute := Attrs.Last;
722 Attrs.Table (Current_Attribute) :=
723 (Name => Attribute_Name,
724 Var_Kind => Var_Kind,
725 Optional_Index => Optional_Index,
726 Attr_Kind => Attr_Kind,
727 Read_Only => Read_Only,
728 Others_Allowed => Others_Allowed,
729 Default => Default,
730 Next => Empty_Attr);
731 Start := Finish + 1;
732 end if;
733 end loop;
734
735 Initialized := True;
736 end Initialize;
737
738 ------------------
739 -- Is_Read_Only --
740 ------------------
741
742 function Is_Read_Only (Attribute : Attribute_Node_Id) return Boolean is
743 begin
744 return Attrs.Table (Attribute.Value).Read_Only;
745 end Is_Read_Only;
746
747 ----------------
748 -- Name_Id_Of --
749 ----------------
750
751 function Name_Id_Of (Name : String) return Name_Id is
752 begin
753 Name_Len := 0;
754 Add_Str_To_Name_Buffer (Name);
755 To_Lower (Name_Buffer (1 .. Name_Len));
756 return Name_Find;
757 end Name_Id_Of;
758
759 --------------------
760 -- Next_Attribute --
761 --------------------
762
763 function Next_Attribute
764 (After : Attribute_Node_Id) return Attribute_Node_Id
765 is
766 begin
767 if After = Empty_Attribute then
768 return Empty_Attribute;
769 else
770 return (Value => Attrs.Table (After.Value).Next);
771 end if;
772 end Next_Attribute;
773
774 -----------------------
775 -- Optional_Index_Of --
776 -----------------------
777
778 function Optional_Index_Of (Attribute : Attribute_Node_Id) return Boolean is
779 begin
780 if Attribute = Empty_Attribute then
781 return False;
782 else
783 return Attrs.Table (Attribute.Value).Optional_Index;
784 end if;
785 end Optional_Index_Of;
786
787 function Others_Allowed_For
788 (Attribute : Attribute_Node_Id) return Boolean
789 is
790 begin
791 if Attribute = Empty_Attribute then
792 return False;
793 else
794 return Attrs.Table (Attribute.Value).Others_Allowed;
795 end if;
796 end Others_Allowed_For;
797
798 -----------------------
799 -- Package_Name_List --
800 -----------------------
801
802 function Package_Name_List return Strings.String_List is
803 begin
804 return Package_Names (1 .. Last_Package_Name);
805 end Package_Name_List;
806
807 ------------------------
808 -- Package_Node_Id_Of --
809 ------------------------
810
811 function Package_Node_Id_Of (Name : Name_Id) return Package_Node_Id is
812 begin
813 for Index in Package_Attributes.First .. Package_Attributes.Last loop
814 if Package_Attributes.Table (Index).Name = Name then
815 if Package_Attributes.Table (Index).Known then
816 return (Value => Index);
817 else
818 return Unknown_Package;
819 end if;
820 end if;
821 end loop;
822
823 -- If there is no package with this name, return Empty_Package
824
825 return Empty_Package;
826 end Package_Node_Id_Of;
827
828 ----------------------------
829 -- Register_New_Attribute --
830 ----------------------------
831
832 procedure Register_New_Attribute
833 (Name : String;
834 In_Package : Package_Node_Id;
835 Attr_Kind : Defined_Attribute_Kind;
836 Var_Kind : Defined_Variable_Kind;
837 Index_Is_File_Name : Boolean := False;
838 Opt_Index : Boolean := False;
839 Default : Attribute_Default_Value := Empty_Value)
840 is
841 Attr_Name : Name_Id;
842 First_Attr : Attr_Node_Id := Empty_Attr;
843 Curr_Attr : Attr_Node_Id;
844 Real_Attr_Kind : Attribute_Kind;
845
846 begin
847 if Name'Length = 0 then
848 Fail ("cannot register an attribute with no name");
849 raise Project_Error;
850 end if;
851
852 if In_Package = Empty_Package then
853 Fail ("attempt to add attribute """
854 & Name
855 & """ to an undefined package");
856 raise Project_Error;
857 end if;
858
859 Attr_Name := Name_Id_Of (Name);
860
861 First_Attr :=
862 Package_Attributes.Table (In_Package.Value).First_Attribute;
863
864 -- Check if attribute name is a duplicate
865
866 Curr_Attr := First_Attr;
867 while Curr_Attr /= Empty_Attr loop
868 if Attrs.Table (Curr_Attr).Name = Attr_Name then
869 Fail ("duplicate attribute name """
870 & Name
871 & """ in package """
872 & Get_Name_String
873 (Package_Attributes.Table (In_Package.Value).Name)
874 & """");
875 raise Project_Error;
876 end if;
877
878 Curr_Attr := Attrs.Table (Curr_Attr).Next;
879 end loop;
880
881 Real_Attr_Kind := Attr_Kind;
882
883 -- If Index_Is_File_Name, change the attribute kind if necessary
884
885 if Index_Is_File_Name and then not Osint.File_Names_Case_Sensitive then
886 case Attr_Kind is
887 when Associative_Array =>
888 Real_Attr_Kind := Case_Insensitive_Associative_Array;
889
890 when Optional_Index_Associative_Array =>
891 Real_Attr_Kind :=
892 Optional_Index_Case_Insensitive_Associative_Array;
893
894 when others =>
895 null;
896 end case;
897 end if;
898
899 -- Add the new attribute
900
901 Attrs.Increment_Last;
902 Attrs.Table (Attrs.Last) :=
903 (Name => Attr_Name,
904 Var_Kind => Var_Kind,
905 Optional_Index => Opt_Index,
906 Attr_Kind => Real_Attr_Kind,
907 Read_Only => False,
908 Others_Allowed => False,
909 Default => Default,
910 Next => First_Attr);
911
912 Package_Attributes.Table (In_Package.Value).First_Attribute :=
913 Attrs.Last;
914 end Register_New_Attribute;
915
916 --------------------------
917 -- Register_New_Package --
918 --------------------------
919
920 procedure Register_New_Package (Name : String; Id : out Package_Node_Id) is
921 Pkg_Name : Name_Id;
922 Found : Boolean := False;
923
924 begin
925 if Name'Length = 0 then
926 Fail ("cannot register a package with no name");
927 Id := Empty_Package;
928 return;
929 end if;
930
931 Pkg_Name := Name_Id_Of (Name);
932
933 for Index in Package_Attributes.First .. Package_Attributes.Last loop
934 if Package_Attributes.Table (Index).Name = Pkg_Name then
935 if Package_Attributes.Table (Index).Known then
936 Fail ("cannot register a package with a non unique name """
937 & Name
938 & """");
939 Id := Empty_Package;
940 return;
941
942 else
943 Found := True;
944 Id := (Value => Index);
945 exit;
946 end if;
947 end if;
948 end loop;
949
950 if not Found then
951 Package_Attributes.Increment_Last;
952 Id := (Value => Package_Attributes.Last);
953 end if;
954
955 Package_Attributes.Table (Id.Value) :=
956 (Name => Pkg_Name,
957 Known => True,
958 First_Attribute => Empty_Attr);
959
960 Add_Package_Name (Get_Name_String (Pkg_Name));
961 end Register_New_Package;
962
963 procedure Register_New_Package
964 (Name : String;
965 Attributes : Attribute_Data_Array)
966 is
967 Pkg_Name : Name_Id;
968 Attr_Name : Name_Id;
969 First_Attr : Attr_Node_Id := Empty_Attr;
970 Curr_Attr : Attr_Node_Id;
971 Attr_Kind : Attribute_Kind;
972
973 begin
974 if Name'Length = 0 then
975 Fail ("cannot register a package with no name");
976 raise Project_Error;
977 end if;
978
979 Pkg_Name := Name_Id_Of (Name);
980
981 for Index in Package_Attributes.First .. Package_Attributes.Last loop
982 if Package_Attributes.Table (Index).Name = Pkg_Name then
983 Fail ("cannot register a package with a non unique name """
984 & Name
985 & """");
986 raise Project_Error;
987 end if;
988 end loop;
989
990 for Index in Attributes'Range loop
991 Attr_Name := Name_Id_Of (Attributes (Index).Name);
992
993 Curr_Attr := First_Attr;
994 while Curr_Attr /= Empty_Attr loop
995 if Attrs.Table (Curr_Attr).Name = Attr_Name then
996 Fail ("duplicate attribute name """
997 & Attributes (Index).Name
998 & """ in new package """
999 & Name
1000 & """");
1001 raise Project_Error;
1002 end if;
1003
1004 Curr_Attr := Attrs.Table (Curr_Attr).Next;
1005 end loop;
1006
1007 Attr_Kind := Attributes (Index).Attr_Kind;
1008
1009 if Attributes (Index).Index_Is_File_Name
1010 and then not Osint.File_Names_Case_Sensitive
1011 then
1012 case Attr_Kind is
1013 when Associative_Array =>
1014 Attr_Kind := Case_Insensitive_Associative_Array;
1015
1016 when Optional_Index_Associative_Array =>
1017 Attr_Kind :=
1018 Optional_Index_Case_Insensitive_Associative_Array;
1019
1020 when others =>
1021 null;
1022 end case;
1023 end if;
1024
1025 Attrs.Increment_Last;
1026 Attrs.Table (Attrs.Last) :=
1027 (Name => Attr_Name,
1028 Var_Kind => Attributes (Index).Var_Kind,
1029 Optional_Index => Attributes (Index).Opt_Index,
1030 Attr_Kind => Attr_Kind,
1031 Read_Only => False,
1032 Others_Allowed => False,
1033 Default => Attributes (Index).Default,
1034 Next => First_Attr);
1035 First_Attr := Attrs.Last;
1036 end loop;
1037
1038 Package_Attributes.Increment_Last;
1039 Package_Attributes.Table (Package_Attributes.Last) :=
1040 (Name => Pkg_Name,
1041 Known => True,
1042 First_Attribute => First_Attr);
1043
1044 Add_Package_Name (Get_Name_String (Pkg_Name));
1045 end Register_New_Package;
1046
1047 ---------------------------
1048 -- Set_Attribute_Kind_Of --
1049 ---------------------------
1050
1051 procedure Set_Attribute_Kind_Of
1052 (Attribute : Attribute_Node_Id;
1053 To : Attribute_Kind)
1054 is
1055 begin
1056 if Attribute /= Empty_Attribute then
1057 Attrs.Table (Attribute.Value).Attr_Kind := To;
1058 end if;
1059 end Set_Attribute_Kind_Of;
1060
1061 --------------------------
1062 -- Set_Variable_Kind_Of --
1063 --------------------------
1064
1065 procedure Set_Variable_Kind_Of
1066 (Attribute : Attribute_Node_Id;
1067 To : Variable_Kind)
1068 is
1069 begin
1070 if Attribute /= Empty_Attribute then
1071 Attrs.Table (Attribute.Value).Var_Kind := To;
1072 end if;
1073 end Set_Variable_Kind_Of;
1074
1075 ----------------------
1076 -- Variable_Kind_Of --
1077 ----------------------
1078
1079 function Variable_Kind_Of
1080 (Attribute : Attribute_Node_Id) return Variable_Kind
1081 is
1082 begin
1083 if Attribute = Empty_Attribute then
1084 return Undefined;
1085 else
1086 return Attrs.Table (Attribute.Value).Var_Kind;
1087 end if;
1088 end Variable_Kind_Of;
1089
1090 ------------------------
1091 -- First_Attribute_Of --
1092 ------------------------
1093
1094 function First_Attribute_Of
1095 (Pkg : Package_Node_Id) return Attribute_Node_Id
1096 is
1097 begin
1098 if Pkg = Empty_Package or else Pkg = Unknown_Package then
1099 return Empty_Attribute;
1100 else
1101 return
1102 (Value => Package_Attributes.Table (Pkg.Value).First_Attribute);
1103 end if;
1104 end First_Attribute_Of;
1105
1106 end Prj.Attr;