OpenCores
URL https://opencores.org/ocsvn/openrisc_2011-10-31/openrisc_2011-10-31/trunk

Subversion Repositories openrisc_2011-10-31

[/] [openrisc/] [trunk/] [gnu-src/] [gcc-4.5.1/] [gcc/] [ada/] [prj-attr.adb] - Blame information for rev 281

Details | Compare with Previous | View Log

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

powered by: WebSVN 2.1.0

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