OpenCores
URL https://opencores.org/ocsvn/openrisc/openrisc/trunk

Subversion Repositories openrisc

[/] [openrisc/] [trunk/] [gnu-dev/] [or1k-gcc/] [gcc/] [ada/] [prj-attr.adb] - Blame information for rev 706

Details | Compare with Previous | View Log

Line No. Rev Author Line
1 706 jeremybenn
------------------------------------------------------------------------------
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-2011, 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 '#'
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' to indicate that the attribute is read-only
59
   --     'O' to indicate that others is allowed as an index for an associative
60
   --     array
61
 
62
   --  End is indicated by two consecutive '#'
63
 
64
   Initialization_Data : constant String :=
65
 
66
   --  project level attributes
67
 
68
   --  General
69
 
70
   "SVRname#" &
71
   "SVRproject_dir#" &
72
   "lVmain#" &
73
   "LVlanguages#" &
74
   "Lbroots#" &
75
   "SVexternally_built#" &
76
 
77
   --  Directories
78
 
79
   "SVobject_dir#" &
80
   "SVexec_dir#" &
81
   "LVsource_dirs#" &
82
   "Lainherit_source_path#" &
83
   "LVexcluded_source_dirs#" &
84
   "LVignore_source_sub_dirs#" &
85
 
86
   --  Source files
87
 
88
   "LVsource_files#" &
89
   "LVlocally_removed_files#" &
90
   "LVexcluded_source_files#" &
91
   "SVsource_list_file#" &
92
   "SVexcluded_source_list_file#" &
93
   "LVinterfaces#" &
94
 
95
   --  Projects (in aggregate projects)
96
 
97
   "LVproject_files#" &
98
   "LVproject_path#" &
99
   "SAexternal#" &
100
 
101
   --  Libraries
102
 
103
   "SVlibrary_dir#" &
104
   "SVlibrary_name#" &
105
   "SVlibrary_kind#" &
106
   "SVlibrary_version#" &
107
   "LVlibrary_interface#" &
108
   "SVlibrary_standalone#" &
109
   "LVlibrary_encapsulated_options#" &
110
   "SVlibrary_encapsulated_supported#" &
111
   "SVlibrary_auto_init#" &
112
   "LVleading_library_options#" &
113
   "LVlibrary_options#" &
114
   "SVlibrary_src_dir#" &
115
   "SVlibrary_ali_dir#" &
116
   "SVlibrary_gcc#" &
117
   "SVlibrary_symbol_file#" &
118
   "SVlibrary_symbol_policy#" &
119
   "SVlibrary_reference_symbol_file#" &
120
 
121
   --  Configuration - General
122
 
123
   "SVdefault_language#" &
124
   "LVrun_path_option#" &
125
   "SVrun_path_origin#" &
126
   "SVseparate_run_path_options#" &
127
   "Satoolchain_version#" &
128
   "Satoolchain_description#" &
129
   "Saobject_generated#" &
130
   "Saobjects_linked#" &
131
   "SVtarget#" &
132
 
133
   --  Configuration - Libraries
134
 
135
   "SVlibrary_builder#" &
136
   "SVlibrary_support#" &
137
 
138
   --  Configuration - Archives
139
 
140
   "LVarchive_builder#" &
141
   "LVarchive_builder_append_option#" &
142
   "LVarchive_indexer#" &
143
   "SVarchive_suffix#" &
144
   "LVlibrary_partial_linker#" &
145
 
146
   --  Configuration - Shared libraries
147
 
148
   "SVshared_library_prefix#" &
149
   "SVshared_library_suffix#" &
150
   "SVsymbolic_link_supported#" &
151
   "SVlibrary_major_minor_id_supported#" &
152
   "SVlibrary_auto_init_supported#" &
153
   "LVshared_library_minimum_switches#" &
154
   "LVlibrary_version_switches#" &
155
   "SVlibrary_install_name_option#" &
156
   "Saruntime_library_dir#" &
157
   "Saruntime_source_dir#" &
158
 
159
   --  package Naming
160
   --  Some attributes are obsolescent, and renamed in the tree (see
161
   --  Prj.Dect.Rename_Obsolescent_Attributes).
162
 
163
   "Pnaming#" &
164
   "Saspecification_suffix#" &  --  Always renamed to "spec_suffix" in tree
165
   "Saspec_suffix#" &
166
   "Saimplementation_suffix#" & --  Always renamed to "body_suffix" in tree
167
   "Sabody_suffix#" &
168
   "SVseparate_suffix#" &
169
   "SVcasing#" &
170
   "SVdot_replacement#" &
171
   "saspecification#" &  --  Always renamed to "spec" in project tree
172
   "saspec#" &
173
   "saimplementation#" & --  Always renamed to "body" in project tree
174
   "sabody#" &
175
   "Laspecification_exceptions#" &
176
   "Laimplementation_exceptions#" &
177
 
178
   --  package Compiler
179
 
180
   "Pcompiler#" &
181
   "Ladefault_switches#" &
182
   "LcOswitches#" &
183
   "SVlocal_configuration_pragmas#" &
184
   "Salocal_config_file#" &
185
 
186
   --  Configuration - Compiling
187
 
188
   "Sadriver#" &
189
   "Salanguage_kind#" &
190
   "Sadependency_kind#" &
191
   "Larequired_switches#" &
192
   "Laleading_required_switches#" &
193
   "Latrailing_required_switches#" &
194
   "Lapic_option#" &
195
   "Sapath_syntax#" &
196
   "Lasource_file_switches#" &
197
   "Saobject_file_suffix#" &
198
   "Laobject_file_switches#" &
199
   "Lamulti_unit_switches#" &
200
   "Samulti_unit_object_separator#" &
201
 
202
   --  Configuration - Mapping files
203
 
204
   "Lamapping_file_switches#" &
205
   "Samapping_spec_suffix#" &
206
   "Samapping_body_suffix#" &
207
 
208
   --  Configuration - Config files
209
 
210
   "Laconfig_file_switches#" &
211
   "Saconfig_body_file_name#" &
212
   "Saconfig_body_file_name_index#" &
213
   "Saconfig_body_file_name_pattern#" &
214
   "Saconfig_spec_file_name#" &
215
   "Saconfig_spec_file_name_index#" &
216
   "Saconfig_spec_file_name_pattern#" &
217
   "Saconfig_file_unique#" &
218
 
219
   --  Configuration - Dependencies
220
 
221
   "Ladependency_switches#" &
222
   "Ladependency_driver#" &
223
 
224
   --  Configuration - Search paths
225
 
226
   "Lainclude_switches#" &
227
   "Sainclude_path#" &
228
   "Sainclude_path_file#" &
229
 
230
   --  package Builder
231
 
232
   "Pbuilder#" &
233
   "Ladefault_switches#" &
234
   "LcOswitches#" &
235
   "Lcglobal_compilation_switches#" &
236
   "Scexecutable#" &
237
   "SVexecutable_suffix#" &
238
   "SVglobal_configuration_pragmas#" &
239
   "Saglobal_config_file#" &
240
 
241
   --  package gnatls
242
 
243
   "Pgnatls#" &
244
   "LVswitches#" &
245
 
246
   --  package Binder
247
 
248
   "Pbinder#" &
249
   "Ladefault_switches#" &
250
   "LcOswitches#" &
251
 
252
   --  Configuration - Binding
253
 
254
   "Sadriver#" &
255
   "Larequired_switches#" &
256
   "Saprefix#" &
257
   "Saobjects_path#" &
258
   "Saobjects_path_file#" &
259
 
260
   --  package Linker
261
 
262
   "Plinker#" &
263
   "LVrequired_switches#" &
264
   "Ladefault_switches#" &
265
   "LcOleading_switches#" &
266
   "LcOswitches#" &
267
   "LVlinker_options#" &
268
   "SVmap_file_option#" &
269
 
270
   --  Configuration - Linking
271
 
272
   "SVdriver#" &
273
   "LVexecutable_switch#" &
274
   "SVlib_dir_switch#" &
275
   "SVlib_name_switch#" &
276
 
277
   --  Configuration - Response files
278
 
279
   "SVmax_command_line_length#" &
280
   "SVresponse_file_format#" &
281
   "LVresponse_file_switches#" &
282
 
283
   --  package Cross_Reference
284
 
285
   "Pcross_reference#" &
286
   "Ladefault_switches#" &
287
   "LbOswitches#" &
288
 
289
   --  package Finder
290
 
291
   "Pfinder#" &
292
   "Ladefault_switches#" &
293
   "LbOswitches#" &
294
 
295
   --  package Pretty_Printer
296
 
297
   "Ppretty_printer#" &
298
   "Ladefault_switches#" &
299
   "LbOswitches#" &
300
 
301
   --  package gnatstub
302
 
303
   "Pgnatstub#" &
304
   "Ladefault_switches#" &
305
   "LbOswitches#" &
306
 
307
   --  package Check
308
 
309
   "Pcheck#" &
310
   "Ladefault_switches#" &
311
   "LbOswitches#" &
312
 
313
   --  package Synchronize
314
 
315
   "Psynchronize#" &
316
   "Ladefault_switches#" &
317
   "LbOswitches#" &
318
 
319
   --  package Eliminate
320
 
321
   "Peliminate#" &
322
   "Ladefault_switches#" &
323
   "LbOswitches#" &
324
 
325
   --  package Metrics
326
 
327
   "Pmetrics#" &
328
   "Ladefault_switches#" &
329
   "LbOswitches#" &
330
 
331
   --  package Ide
332
 
333
   "Pide#" &
334
   "Ladefault_switches#" &
335
   "SVremote_host#" &
336
   "SVprogram_host#" &
337
   "SVcommunication_protocol#" &
338
   "Sacompiler_command#" &
339
   "SVdebugger_command#" &
340
   "SVgnatlist#" &
341
   "SVvcs_kind#" &
342
   "SVvcs_file_check#" &
343
   "SVvcs_log_check#" &
344
   "SVdocumentation_dir#" &
345
 
346
   --  package Stack
347
 
348
   "Pstack#" &
349
   "LVswitches#" &
350
 
351
   "#";
352
 
353
   Initialized : Boolean := False;
354
   --  A flag to avoid multiple initialization
355
 
356
   Package_Names     : String_List_Access := new Strings.String_List (1 .. 20);
357
   Last_Package_Name : Natural := 0;
358
   --  Package_Names (1 .. Last_Package_Name) contains the list of the known
359
   --  package names, coming from the Initialization_Data string or from
360
   --  calls to one of the two procedures Register_New_Package.
361
 
362
   procedure Add_Package_Name (Name : String);
363
   --  Add a package name in the Package_Name list, extending it, if necessary
364
 
365
   function Name_Id_Of (Name : String) return Name_Id;
366
   --  Returns the Name_Id for Name in lower case
367
 
368
   ----------------------
369
   -- Add_Package_Name --
370
   ----------------------
371
 
372
   procedure Add_Package_Name (Name : String) is
373
   begin
374
      if Last_Package_Name = Package_Names'Last then
375
         declare
376
            New_List : constant Strings.String_List_Access :=
377
                         new Strings.String_List (1 .. Package_Names'Last * 2);
378
         begin
379
            New_List (Package_Names'Range) := Package_Names.all;
380
            Package_Names := New_List;
381
         end;
382
      end if;
383
 
384
      Last_Package_Name := Last_Package_Name + 1;
385
      Package_Names (Last_Package_Name) := new String'(Name);
386
   end Add_Package_Name;
387
 
388
   -----------------------
389
   -- Attribute_Kind_Of --
390
   -----------------------
391
 
392
   function Attribute_Kind_Of
393
     (Attribute : Attribute_Node_Id) return Attribute_Kind
394
   is
395
   begin
396
      if Attribute = Empty_Attribute then
397
         return Unknown;
398
      else
399
         return Attrs.Table (Attribute.Value).Attr_Kind;
400
      end if;
401
   end Attribute_Kind_Of;
402
 
403
   -----------------------
404
   -- Attribute_Name_Of --
405
   -----------------------
406
 
407
   function Attribute_Name_Of (Attribute : Attribute_Node_Id) return Name_Id is
408
   begin
409
      if Attribute = Empty_Attribute then
410
         return No_Name;
411
      else
412
         return Attrs.Table (Attribute.Value).Name;
413
      end if;
414
   end Attribute_Name_Of;
415
 
416
   --------------------------
417
   -- Attribute_Node_Id_Of --
418
   --------------------------
419
 
420
   function Attribute_Node_Id_Of
421
     (Name        : Name_Id;
422
      Starting_At : Attribute_Node_Id) return Attribute_Node_Id
423
   is
424
      Id : Attr_Node_Id := Starting_At.Value;
425
 
426
   begin
427
      while Id /= Empty_Attr
428
        and then Attrs.Table (Id).Name /= Name
429
      loop
430
         Id := Attrs.Table (Id).Next;
431
      end loop;
432
 
433
      return (Value => Id);
434
   end Attribute_Node_Id_Of;
435
 
436
   ----------------
437
   -- Initialize --
438
   ----------------
439
 
440
   procedure Initialize is
441
      Start             : Positive          := Initialization_Data'First;
442
      Finish            : Positive          := Start;
443
      Current_Package   : Pkg_Node_Id       := Empty_Pkg;
444
      Current_Attribute : Attr_Node_Id      := Empty_Attr;
445
      Is_An_Attribute   : Boolean           := False;
446
      Var_Kind          : Variable_Kind     := Undefined;
447
      Optional_Index    : Boolean           := False;
448
      Attr_Kind         : Attribute_Kind    := Single;
449
      Package_Name      : Name_Id           := No_Name;
450
      Attribute_Name    : Name_Id           := No_Name;
451
      First_Attribute   : Attr_Node_Id      := Attr.First_Attribute;
452
      Read_Only         : Boolean;
453
      Others_Allowed    : Boolean;
454
 
455
      function Attribute_Location return String;
456
      --  Returns a string depending if we are in the project level attributes
457
      --  or in the attributes of a package.
458
 
459
      ------------------------
460
      -- Attribute_Location --
461
      ------------------------
462
 
463
      function Attribute_Location return String is
464
      begin
465
         if Package_Name = No_Name then
466
            return "project level attributes";
467
 
468
         else
469
            return "attribute of package """ &
470
            Get_Name_String (Package_Name) & """";
471
         end if;
472
      end Attribute_Location;
473
 
474
   --  Start of processing for Initialize
475
 
476
   begin
477
      --  Don't allow Initialize action to be repeated
478
 
479
      if Initialized then
480
         return;
481
      end if;
482
 
483
      --  Make sure the two tables are empty
484
 
485
      Attrs.Init;
486
      Package_Attributes.Init;
487
 
488
      while Initialization_Data (Start) /= '#' loop
489
         Is_An_Attribute := True;
490
         case Initialization_Data (Start) is
491
            when 'P' =>
492
 
493
               --  New allowed package
494
 
495
               Start := Start + 1;
496
 
497
               Finish := Start;
498
               while Initialization_Data (Finish) /= '#' loop
499
                  Finish := Finish + 1;
500
               end loop;
501
 
502
               Package_Name :=
503
                 Name_Id_Of (Initialization_Data (Start .. Finish - 1));
504
 
505
               for Index in First_Package .. Package_Attributes.Last loop
506
                  if Package_Name = Package_Attributes.Table (Index).Name then
507
                     Osint.Fail ("duplicate name """
508
                                 & Initialization_Data (Start .. Finish - 1)
509
                                 & """ in predefined packages.");
510
                  end if;
511
               end loop;
512
 
513
               Is_An_Attribute := False;
514
               Current_Attribute := Empty_Attr;
515
               Package_Attributes.Increment_Last;
516
               Current_Package := Package_Attributes.Last;
517
               Package_Attributes.Table (Current_Package) :=
518
                 (Name             => Package_Name,
519
                  Known            => True,
520
                  First_Attribute  => Empty_Attr);
521
               Start := Finish + 1;
522
 
523
               Add_Package_Name (Get_Name_String (Package_Name));
524
 
525
            when 'S' =>
526
               Var_Kind       := Single;
527
               Optional_Index := False;
528
 
529
            when 's' =>
530
               Var_Kind       := Single;
531
               Optional_Index := True;
532
 
533
            when 'L' =>
534
               Var_Kind       := List;
535
               Optional_Index := False;
536
 
537
            when 'l' =>
538
               Var_Kind         := List;
539
               Optional_Index := True;
540
 
541
            when others =>
542
               raise Program_Error;
543
         end case;
544
 
545
         if Is_An_Attribute then
546
 
547
            --  New attribute
548
 
549
            Start := Start + 1;
550
            case Initialization_Data (Start) is
551
               when 'V' =>
552
                  Attr_Kind := Single;
553
 
554
               when 'A' =>
555
                  Attr_Kind := Associative_Array;
556
 
557
               when 'a' =>
558
                  Attr_Kind := Case_Insensitive_Associative_Array;
559
 
560
               when 'b' =>
561
                  if Osint.File_Names_Case_Sensitive then
562
                     Attr_Kind := Associative_Array;
563
                  else
564
                     Attr_Kind := Case_Insensitive_Associative_Array;
565
                  end if;
566
 
567
               when 'c' =>
568
                  if Osint.File_Names_Case_Sensitive then
569
                     Attr_Kind := Optional_Index_Associative_Array;
570
                  else
571
                     Attr_Kind :=
572
                       Optional_Index_Case_Insensitive_Associative_Array;
573
                  end if;
574
 
575
               when others =>
576
                  raise Program_Error;
577
            end case;
578
 
579
            Start := Start + 1;
580
 
581
            Read_Only := False;
582
            Others_Allowed := False;
583
 
584
            if Initialization_Data (Start) = 'R' then
585
               Read_Only := True;
586
               Start := Start + 1;
587
 
588
            elsif Initialization_Data (Start) = 'O' then
589
               Others_Allowed := True;
590
               Start := Start + 1;
591
            end if;
592
 
593
            Finish := Start;
594
 
595
            while Initialization_Data (Finish) /= '#' loop
596
               Finish := Finish + 1;
597
            end loop;
598
 
599
            Attribute_Name :=
600
              Name_Id_Of (Initialization_Data (Start .. Finish - 1));
601
            Attrs.Increment_Last;
602
 
603
            if Current_Attribute = Empty_Attr then
604
               First_Attribute := Attrs.Last;
605
 
606
               if Current_Package /= Empty_Pkg then
607
                  Package_Attributes.Table (Current_Package).First_Attribute
608
                    := Attrs.Last;
609
               end if;
610
 
611
            else
612
               --  Check that there are no duplicate attributes
613
 
614
               for Index in First_Attribute .. Attrs.Last - 1 loop
615
                  if Attribute_Name = Attrs.Table (Index).Name then
616
                     Osint.Fail ("duplicate attribute """
617
                                 & Initialization_Data (Start .. Finish - 1)
618
                                 & """ in " & Attribute_Location);
619
                  end if;
620
               end loop;
621
 
622
               Attrs.Table (Current_Attribute).Next :=
623
                 Attrs.Last;
624
            end if;
625
 
626
            Current_Attribute := Attrs.Last;
627
            Attrs.Table (Current_Attribute) :=
628
              (Name           => Attribute_Name,
629
               Var_Kind       => Var_Kind,
630
               Optional_Index => Optional_Index,
631
               Attr_Kind      => Attr_Kind,
632
               Read_Only      => Read_Only,
633
               Others_Allowed => Others_Allowed,
634
               Next           => Empty_Attr);
635
            Start := Finish + 1;
636
         end if;
637
      end loop;
638
 
639
      Initialized := True;
640
   end Initialize;
641
 
642
   ------------------
643
   -- Is_Read_Only --
644
   ------------------
645
 
646
   function Is_Read_Only (Attribute : Attribute_Node_Id) return Boolean is
647
   begin
648
      return Attrs.Table (Attribute.Value).Read_Only;
649
   end Is_Read_Only;
650
 
651
   ----------------
652
   -- Name_Id_Of --
653
   ----------------
654
 
655
   function Name_Id_Of (Name : String) return Name_Id is
656
   begin
657
      Name_Len := 0;
658
      Add_Str_To_Name_Buffer (Name);
659
      To_Lower (Name_Buffer (1 .. Name_Len));
660
      return Name_Find;
661
   end Name_Id_Of;
662
 
663
   --------------------
664
   -- Next_Attribute --
665
   --------------------
666
 
667
   function Next_Attribute
668
     (After : Attribute_Node_Id) return Attribute_Node_Id
669
   is
670
   begin
671
      if After = Empty_Attribute then
672
         return Empty_Attribute;
673
      else
674
         return (Value => Attrs.Table (After.Value).Next);
675
      end if;
676
   end Next_Attribute;
677
 
678
   -----------------------
679
   -- Optional_Index_Of --
680
   -----------------------
681
 
682
   function Optional_Index_Of (Attribute : Attribute_Node_Id) return Boolean is
683
   begin
684
      if Attribute = Empty_Attribute then
685
         return False;
686
      else
687
         return Attrs.Table (Attribute.Value).Optional_Index;
688
      end if;
689
   end Optional_Index_Of;
690
 
691
   function Others_Allowed_For
692
     (Attribute : Attribute_Node_Id) return Boolean
693
   is
694
   begin
695
      if Attribute = Empty_Attribute then
696
         return False;
697
      else
698
         return Attrs.Table (Attribute.Value).Others_Allowed;
699
      end if;
700
   end Others_Allowed_For;
701
 
702
   -----------------------
703
   -- Package_Name_List --
704
   -----------------------
705
 
706
   function Package_Name_List return Strings.String_List is
707
   begin
708
      return Package_Names (1 .. Last_Package_Name);
709
   end Package_Name_List;
710
 
711
   ------------------------
712
   -- Package_Node_Id_Of --
713
   ------------------------
714
 
715
   function Package_Node_Id_Of (Name : Name_Id) return Package_Node_Id is
716
   begin
717
      for Index in Package_Attributes.First .. Package_Attributes.Last loop
718
         if Package_Attributes.Table (Index).Name = Name then
719
            if Package_Attributes.Table (Index).Known then
720
               return (Value => Index);
721
            else
722
               return Unknown_Package;
723
            end if;
724
         end if;
725
      end loop;
726
 
727
      --  If there is no package with this name, return Empty_Package
728
 
729
      return Empty_Package;
730
   end Package_Node_Id_Of;
731
 
732
   ----------------------------
733
   -- Register_New_Attribute --
734
   ----------------------------
735
 
736
   procedure Register_New_Attribute
737
     (Name               : String;
738
      In_Package         : Package_Node_Id;
739
      Attr_Kind          : Defined_Attribute_Kind;
740
      Var_Kind           : Defined_Variable_Kind;
741
      Index_Is_File_Name : Boolean := False;
742
      Opt_Index          : Boolean := False)
743
   is
744
      Attr_Name       : Name_Id;
745
      First_Attr      : Attr_Node_Id := Empty_Attr;
746
      Curr_Attr       : Attr_Node_Id;
747
      Real_Attr_Kind  : Attribute_Kind;
748
 
749
   begin
750
      if Name'Length = 0 then
751
         Fail ("cannot register an attribute with no name");
752
         raise Project_Error;
753
      end if;
754
 
755
      if In_Package = Empty_Package then
756
         Fail ("attempt to add attribute """
757
               & Name
758
               & """ to an undefined package");
759
         raise Project_Error;
760
      end if;
761
 
762
      Attr_Name := Name_Id_Of (Name);
763
 
764
      First_Attr :=
765
        Package_Attributes.Table (In_Package.Value).First_Attribute;
766
 
767
      --  Check if attribute name is a duplicate
768
 
769
      Curr_Attr := First_Attr;
770
      while Curr_Attr /= Empty_Attr loop
771
         if Attrs.Table (Curr_Attr).Name = Attr_Name then
772
            Fail ("duplicate attribute name """
773
                  & Name
774
                  & """ in package """
775
                  & Get_Name_String
776
                     (Package_Attributes.Table (In_Package.Value).Name)
777
                  & """");
778
            raise Project_Error;
779
         end if;
780
 
781
         Curr_Attr := Attrs.Table (Curr_Attr).Next;
782
      end loop;
783
 
784
      Real_Attr_Kind := Attr_Kind;
785
 
786
      --  If Index_Is_File_Name, change the attribute kind if necessary
787
 
788
      if Index_Is_File_Name and then not Osint.File_Names_Case_Sensitive then
789
         case Attr_Kind is
790
            when Associative_Array =>
791
               Real_Attr_Kind := Case_Insensitive_Associative_Array;
792
 
793
            when Optional_Index_Associative_Array =>
794
               Real_Attr_Kind :=
795
                 Optional_Index_Case_Insensitive_Associative_Array;
796
 
797
            when others =>
798
               null;
799
         end case;
800
      end if;
801
 
802
      --  Add the new attribute
803
 
804
      Attrs.Increment_Last;
805
      Attrs.Table (Attrs.Last) :=
806
        (Name           => Attr_Name,
807
         Var_Kind       => Var_Kind,
808
         Optional_Index => Opt_Index,
809
         Attr_Kind      => Real_Attr_Kind,
810
         Read_Only      => False,
811
         Others_Allowed => False,
812
         Next           => First_Attr);
813
 
814
      Package_Attributes.Table (In_Package.Value).First_Attribute :=
815
        Attrs.Last;
816
   end Register_New_Attribute;
817
 
818
   --------------------------
819
   -- Register_New_Package --
820
   --------------------------
821
 
822
   procedure Register_New_Package (Name : String; Id : out Package_Node_Id) is
823
      Pkg_Name : Name_Id;
824
 
825
   begin
826
      if Name'Length = 0 then
827
         Fail ("cannot register a package with no name");
828
         Id := Empty_Package;
829
         return;
830
      end if;
831
 
832
      Pkg_Name := Name_Id_Of (Name);
833
 
834
      for Index in Package_Attributes.First .. Package_Attributes.Last loop
835
         if Package_Attributes.Table (Index).Name = Pkg_Name then
836
            Fail ("cannot register a package with a non unique name"""
837
                  & Name
838
                  & """");
839
            Id := Empty_Package;
840
            return;
841
         end if;
842
      end loop;
843
 
844
      Package_Attributes.Increment_Last;
845
      Id := (Value => Package_Attributes.Last);
846
      Package_Attributes.Table (Package_Attributes.Last) :=
847
        (Name             => Pkg_Name,
848
         Known            => True,
849
         First_Attribute  => Empty_Attr);
850
 
851
      Add_Package_Name (Get_Name_String (Pkg_Name));
852
   end Register_New_Package;
853
 
854
   procedure Register_New_Package
855
     (Name       : String;
856
      Attributes : Attribute_Data_Array)
857
   is
858
      Pkg_Name   : Name_Id;
859
      Attr_Name  : Name_Id;
860
      First_Attr : Attr_Node_Id := Empty_Attr;
861
      Curr_Attr  : Attr_Node_Id;
862
      Attr_Kind  : Attribute_Kind;
863
 
864
   begin
865
      if Name'Length = 0 then
866
         Fail ("cannot register a package with no name");
867
         raise Project_Error;
868
      end if;
869
 
870
      Pkg_Name := Name_Id_Of (Name);
871
 
872
      for Index in Package_Attributes.First .. Package_Attributes.Last loop
873
         if Package_Attributes.Table (Index).Name = Pkg_Name then
874
            Fail ("cannot register a package with a non unique name"""
875
                  & Name
876
                  & """");
877
            raise Project_Error;
878
         end if;
879
      end loop;
880
 
881
      for Index in Attributes'Range loop
882
         Attr_Name := Name_Id_Of (Attributes (Index).Name);
883
 
884
         Curr_Attr := First_Attr;
885
         while Curr_Attr /= Empty_Attr loop
886
            if Attrs.Table (Curr_Attr).Name = Attr_Name then
887
               Fail ("duplicate attribute name """
888
                     & Attributes (Index).Name
889
                     & """ in new package """
890
                     & Name
891
                     & """");
892
               raise Project_Error;
893
            end if;
894
 
895
            Curr_Attr := Attrs.Table (Curr_Attr).Next;
896
         end loop;
897
 
898
         Attr_Kind := Attributes (Index).Attr_Kind;
899
 
900
         if Attributes (Index).Index_Is_File_Name
901
           and then not Osint.File_Names_Case_Sensitive
902
         then
903
            case Attr_Kind is
904
               when Associative_Array =>
905
                  Attr_Kind := Case_Insensitive_Associative_Array;
906
 
907
               when Optional_Index_Associative_Array =>
908
                  Attr_Kind :=
909
                    Optional_Index_Case_Insensitive_Associative_Array;
910
 
911
               when others =>
912
                  null;
913
            end case;
914
         end if;
915
 
916
         Attrs.Increment_Last;
917
         Attrs.Table (Attrs.Last) :=
918
           (Name           => Attr_Name,
919
            Var_Kind       => Attributes (Index).Var_Kind,
920
            Optional_Index => Attributes (Index).Opt_Index,
921
            Attr_Kind      => Attr_Kind,
922
            Read_Only      => False,
923
            Others_Allowed => False,
924
            Next           => First_Attr);
925
         First_Attr := Attrs.Last;
926
      end loop;
927
 
928
      Package_Attributes.Increment_Last;
929
      Package_Attributes.Table (Package_Attributes.Last) :=
930
        (Name             => Pkg_Name,
931
         Known            => True,
932
         First_Attribute  => First_Attr);
933
 
934
      Add_Package_Name (Get_Name_String (Pkg_Name));
935
   end Register_New_Package;
936
 
937
   ---------------------------
938
   -- Set_Attribute_Kind_Of --
939
   ---------------------------
940
 
941
   procedure Set_Attribute_Kind_Of
942
     (Attribute : Attribute_Node_Id;
943
      To        : Attribute_Kind)
944
   is
945
   begin
946
      if Attribute /= Empty_Attribute then
947
         Attrs.Table (Attribute.Value).Attr_Kind := To;
948
      end if;
949
   end Set_Attribute_Kind_Of;
950
 
951
   --------------------------
952
   -- Set_Variable_Kind_Of --
953
   --------------------------
954
 
955
   procedure Set_Variable_Kind_Of
956
     (Attribute : Attribute_Node_Id;
957
      To        : Variable_Kind)
958
   is
959
   begin
960
      if Attribute /= Empty_Attribute then
961
         Attrs.Table (Attribute.Value).Var_Kind := To;
962
      end if;
963
   end Set_Variable_Kind_Of;
964
 
965
   ----------------------
966
   -- Variable_Kind_Of --
967
   ----------------------
968
 
969
   function Variable_Kind_Of
970
     (Attribute : Attribute_Node_Id) return Variable_Kind
971
   is
972
   begin
973
      if Attribute = Empty_Attribute then
974
         return Undefined;
975
      else
976
         return Attrs.Table (Attribute.Value).Var_Kind;
977
      end if;
978
   end Variable_Kind_Of;
979
 
980
   ------------------------
981
   -- First_Attribute_Of --
982
   ------------------------
983
 
984
   function First_Attribute_Of
985
     (Pkg : Package_Node_Id) return Attribute_Node_Id
986
   is
987
   begin
988
      if Pkg = Empty_Package then
989
         return Empty_Attribute;
990
      else
991
         return
992
           (Value => Package_Attributes.Table (Pkg.Value).First_Attribute);
993
      end if;
994
   end First_Attribute_Of;
995
 
996
end Prj.Attr;

powered by: WebSVN 2.1.0

© copyright 1999-2024 OpenCores.org, equivalent to Oliscience, all rights reserved. OpenCores®, registered trademark.