source: trunk/ada-2012/src/lexer/gela-plain_symbol_sets.adb@ 362

Last change on this file since 362 was 362, checked in by Maxim Reznik, 6 years ago

Change list expansion

Traverse of list was changed in prev commit. Now lists are processed in
depth-first order left-to-right. So corresponding list representation is
LIST ::= item LIST<tail>; instead of previous
LIST ::= LIST<head> item;

So change AG generator and AG rules.
Construction and iteration of symbol list is changed also.

File size: 20.8 KB
Line 
1with League.Characters;
2with League.String_Vectors;
3
4package body Gela.Plain_Symbol_Sets is
5
6 use Gela.Lexical_Types;
7
8 function To_Operator_Symbol
9 (Text : League.Strings.Universal_String) return First_Symbols;
10 -- Return symbol corresponding to an operator (rem mod not xor or abs and)
11 -- or '0' otherwise
12
13 -- Cast List_Index into SYmbol/Symbol_List and backward
14 function To_Symbol
15 (Value : List_Index) return Gela.Lexical_Types.Symbol;
16 function To_Symbol_List (List : List_Index) return List_Symbol;
17 function From_Symbol
18 (Value : Gela.Lexical_Types.Symbol) return List_Index;
19 function From_Symbol_List (List : List_Symbol) return List_Index;
20
21 Map_1 : constant array (Wide_Wide_Character range '&' .. '>') of
22 First_Symbols :=
23 ('<' => Token_Kind'Pos (Less_Token),
24 '=' => Token_Kind'Pos (Equal_Token),
25 '>' => Token_Kind'Pos (Greater_Token),
26 '-' => Token_Kind'Pos (Hyphen_Token),
27 '/' => Token_Kind'Pos (Slash_Token),
28 '*' => Token_Kind'Pos (Star_Token),
29 '&' => Token_Kind'Pos (Ampersand_Token),
30 '+' => Token_Kind'Pos (Plus_Token),
31 others => 0);
32 -- Single char operators
33
34 Map_2 : constant array (Wide_Wide_Character range '/' .. '>') of
35 First_Symbols :=
36 ('<' => Token_Kind'Pos (Less_Or_Equal_Token),
37 '/' => Token_Kind'Pos (Inequality_Token),
38 '>' => Token_Kind'Pos (Greater_Or_Equal_Token),
39 others => 0);
40 -- First char of two chars operator (<=, /=, >=)
41
42 Power_Value : constant Operator_Symbol :=
43 Token_Kind'Pos (Double_Star_Token);
44 -- ** operator symbol
45
46 -- Images of predefined operators
47 A1 : constant array (Symbol range 1 .. 8) of Wide_Wide_String (1 .. 3) :=
48 ("""<""", """=""", """>""", """-""",
49 """/""", """*""", """&""", """+""");
50 A2 : constant array (Symbol range 9 .. 13) of Wide_Wide_String (1 .. 4)
51 := ("""<=""", """>=""", """/=""", """**""", """or""");
52 A3 : constant array (Symbol range 14 .. 19) of Wide_Wide_String (1 .. 5)
53 := ("""and""", """xor""", """mod""", """rem""", """abs""", """not""");
54
55 -----------------
56 -- Create_List --
57 -----------------
58
59 overriding procedure Create_List
60 (Self : in out Symbol_Set;
61 Head : Gela.Lexical_Types.Symbol;
62 Tail : Gela.Lexical_Types.Symbol_List :=
63 Gela.Lexical_Types.Empty_Symbol_List;
64 Value : out Gela.Lexical_Types.Symbol_List)
65 is
66 Node : constant List_Node := (Head, Gela.Lexical_Types.Symbol (Tail));
67 Cursor : List_Maps.Cursor;
68 begin
69 if Tail = Gela.Lexical_Types.Empty_Symbol_List then
70 -- Symbol and Symbol_List have the same encoding, just cast.
71 Value := Gela.Lexical_Types.Symbol_List (Head);
72 return;
73 end if;
74
75 Cursor := Self.List_Map.Find (Node);
76
77 if List_Maps.Has_Element (Cursor) then
78 Value := To_Symbol_List (List_Maps.Element (Cursor));
79 else
80 Self.Lists.Append (Node);
81 Self.List_Map.Insert (Node, Self.Lists.Last_Index);
82 Value := To_Symbol_List (Self.Lists.Last_Index);
83 end if;
84 end Create_List;
85
86 -----------------
87 -- Create_List --
88 -----------------
89
90 overriding procedure Create_List
91 (Self : in out Symbol_Set;
92 Head : Gela.Lexical_Types.Symbol_List;
93 Tail : Gela.Lexical_Types.Symbol_List;
94 Value : out Gela.Lexical_Types.Symbol_List) is
95 begin
96 if Head = Empty_Symbol_List then
97 Value := Tail;
98 else
99 Self.Create_List (Head => Self.Tail (Head),
100 Tail => Tail,
101 Value => Value);
102
103 Self.Create_List (Head => Self.Head (Head),
104 Tail => Value,
105 Value => Value);
106 end if;
107 end Create_List;
108
109 -----------
110 -- Fetch --
111 -----------
112
113 overriding procedure Fetch
114 (Self : in out Symbol_Set;
115 Image : League.Strings.Universal_String;
116 Value : out Gela.Lexical_Types.Symbol) is
117 begin
118 if Image.Element (1).To_Wide_Wide_Character in ''' | '"' | '%' then
119 Value := Self.Get (Image);
120 return;
121 elsif Image.Index ('.') > 0 then
122 declare
123 List : League.String_Vectors.Universal_String_Vector;
124 Suffix : Gela.Lexical_Types.Symbol;
125 begin
126 List := Image.Split ('.');
127 Self.Fetch (List.Element (1), Value);
128
129 for J in 2 .. List.Length loop
130 Self.Fetch (List.Element (J), Suffix);
131 Self.Join (Value, Suffix, Value);
132 end loop;
133
134 return;
135 end;
136 end if;
137
138 declare
139 Cursor : String_Maps.Cursor := Self.Original.Find (Image);
140 Folded : League.Strings.Universal_String;
141 begin
142 if String_Maps.Has_Element (Cursor) then
143 Value := String_Maps.Element (Cursor);
144 return;
145 end if;
146
147 Folded := Image.To_Simple_Casefold;
148 Cursor := Self.Folded.Find (Folded);
149
150 if String_Maps.Has_Element (Cursor) then
151 Value := String_Maps.Element (Cursor);
152 return;
153 end if;
154
155 Self.Values.Append ((Original => Image, Folded => Folded));
156 Value := Gela.Lexical_Types.Symbol (Self.Values.Last_Index);
157 Self.Original.Insert (Image, Value);
158 Self.Folded.Insert (Folded, Value);
159 end;
160 end Fetch;
161
162 ------------
163 -- Folded --
164 ------------
165
166 overriding function Folded
167 (Self : Symbol_Set;
168 Value : Gela.Lexical_Types.Symbol)
169 return League.Strings.Universal_String
170 is
171 use type League.Strings.Universal_String;
172 begin
173 if Value not in Simple_Symbol then
174 return Folded (Self, Self.Prefix (Value)) & '.' &
175 Folded (Self, Self.Selector (Value));
176 elsif Value < 16#11_0000# then
177 return Self.Image (Value);
178 else
179 return Self.Values.Element (Symbol_Index (Value)).Folded;
180 end if;
181 end Folded;
182
183 -----------------
184 -- From_Symbol --
185 -----------------
186
187 function From_Symbol
188 (Value : Gela.Lexical_Types.Symbol) return List_Index is
189 begin
190 return List_Index (Value - Compound_Symbol'First);
191 end From_Symbol;
192
193 ----------------------
194 -- From_Symbol_List --
195 ----------------------
196
197 function From_Symbol_List (List : List_Symbol) return List_Index is
198 begin
199 return List_Index (List - List_Symbol'First);
200 end From_Symbol_List;
201
202 ---------
203 -- Get --
204 ---------
205
206 overriding function Get
207 (Self : Symbol_Set;
208 Image : League.Strings.Universal_String)
209 return Gela.Lexical_Types.Symbol
210 is
211 use type League.Characters.Universal_Character;
212
213 Length : constant Natural := Image.Length;
214 First : constant Wide_Wide_Character :=
215 Image.Element (1).To_Wide_Wide_Character;
216 Char : Wide_Wide_Character;
217 begin
218 if First = ''' then -- Character literal
219 return Wide_Wide_Character'Pos
220 (Image.Element (2).To_Wide_Wide_Character);
221 elsif First /= '"' then -- Identifier
222 if Image.Index ('.') > 0 then -- Compound name
223 declare
224 List : League.String_Vectors.Universal_String_Vector;
225 Suffix : Gela.Lexical_Types.Symbol;
226 Value : Gela.Lexical_Types.Symbol;
227 Node : List_Node;
228 Cursor : List_Maps.Cursor;
229 begin
230 List := Image.Split ('.');
231 Value := Self.Get (List.Element (1));
232
233 if Value = Gela.Lexical_Types.No_Symbol then
234 return Gela.Lexical_Types.No_Symbol;
235 end if;
236
237 for J in 2 .. List.Length loop
238 Suffix := Self.Get (List.Element (J));
239 Node := (Value, Suffix);
240 Cursor := Self.List_Map.Find (Node);
241
242 if List_Maps.Has_Element (Cursor) then
243 Value := To_Symbol (List_Maps.Element (Cursor));
244 else
245 return Gela.Lexical_Types.No_Symbol;
246 end if;
247 end loop;
248
249 return Value;
250 end;
251 end if;
252
253 declare
254 Cursor : String_Maps.Cursor := Self.Original.Find (Image);
255 begin
256 if String_Maps.Has_Element (Cursor) then
257 return String_Maps.Element (Cursor);
258 end if;
259
260 Cursor := Self.Folded.Find (Image.To_Simple_Casefold);
261
262 if String_Maps.Has_Element (Cursor) then
263 return String_Maps.Element (Cursor);
264 end if;
265
266 return Gela.Lexical_Types.No_Symbol;
267 end;
268 elsif Length = 3 then -- String literal (one charater) "#"
269 Char := Image.Element (2).To_Wide_Wide_Character;
270
271 if Char in Map_1'Range then
272 return Map_1 (Char);
273 end if;
274 elsif Length = 4 then -- String literal (two charaters) "##"
275 if Image.Element (3) = '=' then
276 Char := Image.Element (2).To_Wide_Wide_Character;
277
278 if Char in Map_2'Range then
279 return Map_2 (Char);
280 end if;
281 elsif Image.Element (2) = '*' and Image.Element (3) = '*' then
282 return Power_Value;
283 else -- This could be "or"
284 return To_Operator_Symbol (Image);
285 end if;
286 elsif Length = 5 then -- String literal (three charaters) "###"
287 return To_Operator_Symbol (Image);
288 end if;
289
290 return Gela.Lexical_Types.No_Symbol;
291 end Get;
292
293 ----------
294 -- Hash --
295 ----------
296
297 function Hash (Item : List_Node) return Ada.Containers.Hash_Type is
298 use type Ada.Containers.Hash_Type;
299 begin
300 return Ada.Containers.Hash_Type (Item.Right) * 3571 +
301 Ada.Containers.Hash_Type (Item.Left);
302 end Hash;
303
304 ----------
305 -- Head --
306 ----------
307
308 overriding function Head
309 (Self : Symbol_Set;
310 Value : Gela.Lexical_Types.Symbol_List)
311 return Gela.Lexical_Types.Symbol is
312 begin
313 if Value in List_Symbol then
314 declare
315 Index : constant List_Index := From_Symbol_List (Value);
316 Node : constant List_Node := Self.Lists.Element (Index);
317 begin
318 return Node.Left;
319 end;
320 else
321 -- Symbol and Symbol_List have the same encoding, just cast.
322 return Gela.Lexical_Types.Symbol (Value);
323 end if;
324 end Head;
325
326 -----------
327 -- Image --
328 -----------
329
330 overriding function Image
331 (Self : Symbol_Set;
332 Value : Gela.Lexical_Types.Symbol)
333 return League.Strings.Universal_String
334 is
335 use type League.Strings.Universal_String;
336 begin
337 case Value is
338 when 0 =>
339 return League.Strings.Empty_Universal_String;
340 when Operator_Symbol =>
341 return Self.Operator (Value);
342 when 20 .. 16#10_FFFF# =>
343 declare
344 Result : Wide_Wide_String := "'_'";
345 begin
346 Result (2) := Wide_Wide_Character'Val (Value);
347 return League.Strings.To_Universal_String (Result);
348 end;
349 when 16#11_0000# .. Simple_Symbol'Last =>
350 return Self.Values.Element (Symbol_Index (Value)).Original;
351 when Compound_Symbol =>
352 return Self.Image (Self.Prefix (Value)) & '.' &
353 Self.Image (Self.Selector (Value));
354 when others =>
355 raise Constraint_Error;
356 end case;
357 end Image;
358
359 ----------------
360 -- Initialize --
361 ----------------
362
363 not overriding procedure Initialize (Self : in out Symbol_Set) is
364 pragma Warnings (Off); -- Disable unreferenced warning for literals
365 type Predefined_Symbol_Name is
366 (All_Calls_Remote_Symbol,
367 Assert_Symbol,
368 Assertion_Policy_Symbol,
369 Asynchronous_Symbol,
370 Atomic_Symbol,
371 Atomic_Components_Symbol,
372 Attach_Handler_Symbol,
373 Controlled_Symbol,
374 Convention_Symbol,
375 Detect_Blocking_Symbol,
376 Discard_Names_Symbol,
377 Elaborate_Symbol,
378 Elaborate_All_Symbol,
379 Elaborate_Body_Symbol,
380 Export_Symbol,
381 Import_Symbol,
382 Inline_Symbol,
383 Inspection_Point_Symbol,
384 Interrupt_Handler_Symbol,
385 Interrupt_Priority_Symbol,
386 Linker_Options_Symbol,
387 List_Symbol,
388 Locking_Policy_Symbol,
389 No_Return_Symbol,
390 Normalize_Scalars_Symbol,
391 Optimize_Symbol,
392 Pack_Symbol,
393 Page_Symbol,
394 Partition_Elaboration_Policy_Symbol,
395 Preelaborable_Initialization_Symbol,
396 Preelaborate_Symbol,
397 Priority_Specific_Dispatching_Symbol,
398 Profile_Symbol,
399 Pure_Symbol,
400 Queuing_Policy_Symbol,
401 Relative_Deadline_Symbol,
402 Remote_Call_Interface_Symbol,
403 Remote_Types_Symbol,
404 Restrictions_Symbol,
405 Reviewable_Symbol,
406 Shared_Passive_Symbol,
407 Suppress_Symbol,
408 Task_Dispatching_Policy_Symbol,
409 Unchecked_Union_Symbol,
410 Unsuppress_Symbol,
411 Volatile_Symbol,
412 Volatile_Components_Symbol,
413 Access_Symbol,
414 Address_Symbol,
415 Adjacent_Symbol,
416 Aft_Symbol,
417 Alignment_Symbol,
418 Base_Symbol,
419 Bit_Order_Symbol,
420 Body_Version_Symbol,
421 Callable_Symbol,
422 Caller_Symbol,
423 Ceiling_Symbol,
424 Class_Symbol,
425 Component_Size_Symbol,
426 Compose_Symbol,
427 Constrained_Symbol,
428 Copy_Sign_Symbol,
429 Count_Symbol,
430 Definite_Symbol,
431 Delta_Symbol,
432 Denorm_Symbol,
433 Digits_Symbol,
434 Exponent_Symbol,
435 External_Tag_Symbol,
436 First_Symbol,
437 First_Bit_Symbol,
438 Floor_Symbol,
439 Fore_Symbol,
440 Fraction_Symbol,
441 Identity_Symbol,
442 Image_Symbol,
443 Input_Symbol,
444 Last_Symbol,
445 Last_Bit_Symbol,
446 Leading_Part_Symbol,
447 Length_Symbol,
448 Machine_Symbol,
449 Machine_Emax_Symbol,
450 Machine_Emin_Symbol,
451 Machine_Mantissa_Symbol,
452 Machine_Overflows_Symbol,
453 Machine_Radix_Symbol,
454 Machine_Rounding_Symbol,
455 Machine_Rounds_Symbol,
456 Max_Symbol,
457 Max_Size_In_Storage_Elements_Symbol,
458 Min_Symbol,
459 Mod_Symbol,
460 Model_Symbol,
461 Model_Emin_Symbol,
462 Model_Epsilon_Symbol,
463 Model_Mantissa_Symbol,
464 Model_Small_Symbol,
465 Modulus_Symbol,
466 Output_Symbol,
467 Partition_ID_Symbol,
468 Pos_Symbol,
469 Position_Symbol,
470 Pred_Symbol,
471 Priority_Symbol,
472 Range_Symbol,
473 Read_Symbol,
474 Remainder_Symbol,
475 Round_Symbol,
476 Rounding_Symbol,
477 Safe_First_Symbol,
478 Safe_Last_Symbol,
479 Scale_Symbol,
480 Scaling_Symbol,
481 Signed_Zeros_Symbol,
482 Size_Symbol,
483 Small_Symbol,
484 Storage_Pool_Symbol,
485 Storage_Size_Symbol,
486 Stream_Size_Symbol,
487 Succ_Symbol,
488 Tag_Symbol,
489 Terminated_Symbol,
490 Truncation_Symbol,
491 Unbiased_Rounding_Symbol,
492 Unchecked_Access_Symbol,
493 Val_Symbol,
494 Valid_Symbol,
495 Value_Symbol,
496 Version_Symbol,
497 Wide_Image_Symbol,
498 Wide_Value_Symbol,
499 Wide_Wide_Image_Symbol,
500 Wide_Wide_Value_Symbol,
501 Wide_Wide_Width_Symbol,
502 Wide_Width_Symbol,
503 Width_Symbol,
504 Write_Symbol,
505 Standard_Symbol,
506 Boolean_Symbol,
507 Integer_Symbol,
508 Float_Symbol,
509 Character_Symbol,
510 Wide_Character_Symbol,
511 Wide_Wide_Character_Symbol,
512 String_Symbol,
513 Wide_String_Symbol,
514 Wide_Wide_String_Symbol,
515 Duration_Symbol);
516 pragma Warnings (On);
517
518 function To_Mixed_Case
519 (Name : Wide_Wide_String) return League.Strings.Universal_String;
520
521 -------------------
522 -- To_Mixed_Case --
523 -------------------
524
525 function To_Mixed_Case
526 (Name : Wide_Wide_String) return League.Strings.Universal_String
527 is
528 List : League.String_Vectors.Universal_String_Vector;
529 Image : League.Strings.Universal_String;
530 Upper : constant League.Strings.Universal_String :=
531 League.Strings.To_Universal_String (Name);
532 begin
533 List := Upper.Split ('_');
534
535 for K in 1 .. List.Length loop
536 Image := List.Element (K).To_Lowercase;
537 Image.Replace (1, 1, List.Element (K).Slice (1, 1));
538 List.Replace (K, Image);
539 end loop;
540
541 Image := List.Join ('_');
542
543 return Image;
544 end To_Mixed_Case;
545
546 Ignore : Gela.Lexical_Types.Symbol;
547 begin
548 for J in A1'Range loop
549 Self.Operator (J) := League.Strings.To_Universal_String (A1 (J));
550 end loop;
551
552 for J in A2'Range loop
553 Self.Operator (J) := League.Strings.To_Universal_String (A2 (J));
554 end loop;
555
556 for J in A3'Range loop
557 Self.Operator (J) := League.Strings.To_Universal_String (A3 (J));
558 end loop;
559
560 for J in Self.Operator'Range loop
561 Self.Fetch (Self.Operator (J), Ignore);
562 end loop;
563
564 for J in Predefined_Symbol_Name'Range loop
565 declare
566 Name : constant Wide_Wide_String :=
567 Predefined_Symbol_Name'Wide_Wide_Image (J);
568 Image : constant League.Strings.Universal_String :=
569 To_Mixed_Case (Name (1 .. Name'Last - 7));
570 begin
571 Self.Fetch (Image, Ignore);
572
573 if Ignore /= 16#11_0000# + Predefined_Symbol_Name'Pos (J) then
574 raise Constraint_Error;
575 end if;
576 end;
577 end loop;
578 end Initialize;
579
580 ----------
581 -- Join --
582 ----------
583
584 overriding procedure Join
585 (Self : in out Symbol_Set;
586 Left : Gela.Lexical_Types.Symbol;
587 Right : Gela.Lexical_Types.Symbol;
588 Value : out Gela.Lexical_Types.Symbol)
589 is
590 Node : constant List_Node := (Left, Right);
591 Cursor : constant List_Maps.Cursor := Self.List_Map.Find (Node);
592 begin
593 if List_Maps.Has_Element (Cursor) then
594 Value := To_Symbol (List_Maps.Element (Cursor));
595 else
596 Self.Lists.Append (Node);
597 Self.List_Map.Insert (Node, Self.Lists.Last_Index);
598 Value := To_Symbol (Self.Lists.Last_Index);
599 end if;
600 end Join;
601
602 ------------
603 -- Prefix --
604 ------------
605
606 overriding function Prefix
607 (Self : Symbol_Set;
608 Value : Gela.Lexical_Types.Symbol)
609 return Gela.Lexical_Types.Symbol is
610 begin
611 if Value in Simple_Symbol then
612 return Gela.Lexical_Types.No_Symbol;
613 else
614 return Self.Lists.Element (From_Symbol (Value)).Left;
615 end if;
616 end Prefix;
617
618 --------------
619 -- Selector --
620 --------------
621
622 overriding function Selector
623 (Self : Symbol_Set;
624 Value : Gela.Lexical_Types.Symbol)
625 return Gela.Lexical_Types.Symbol is
626 begin
627 if Value in Simple_Symbol then
628 return Value;
629 else
630 return Self.Lists.Element (From_Symbol (Value)).Right;
631 end if;
632 end Selector;
633
634 ----------
635 -- Tail --
636 ----------
637
638 overriding function Tail
639 (Self : Symbol_Set;
640 Value : Gela.Lexical_Types.Symbol_List)
641 return Gela.Lexical_Types.Symbol_List is
642 begin
643 if Value in List_Symbol then
644 declare
645 Index : constant List_Index := From_Symbol_List (Value);
646 Node : constant List_Node := Self.Lists.Element (Index);
647 begin
648 -- Symbol and Symbol_List have the same encoding, just cast.
649 return Gela.Lexical_Types.Symbol_List (Node.Right);
650 end;
651 else
652 return Gela.Lexical_Types.Empty_Symbol_List;
653 end if;
654 end Tail;
655
656 ------------------------
657 -- To_Operator_Symbol --
658 ------------------------
659
660 function To_Operator_Symbol
661 (Text : League.Strings.Universal_String) return First_Symbols
662 is
663 X : constant Wide_Wide_String :=
664 Text.Slice (2, Text.Length - 1).To_Simple_Casefold.To_Wide_Wide_String;
665 begin
666 if X = "abs" then
667 return Token_Kind'Pos (Abs_Token);
668 elsif X = "and" then
669 return Token_Kind'Pos (And_Token);
670 elsif X = "mod" then
671 return Token_Kind'Pos (Mod_Token);
672 elsif X = "not" then
673 return Token_Kind'Pos (Not_Token);
674 elsif X = "or" then
675 return Token_Kind'Pos (Or_Token);
676 elsif X = "rem" then
677 return Token_Kind'Pos (Rem_Token);
678 elsif X = "xor" then
679 return Token_Kind'Pos (Xor_Token);
680 else
681 return 0;
682 end if;
683 end To_Operator_Symbol;
684
685 ---------------
686 -- To_Symbol --
687 ---------------
688
689 function To_Symbol
690 (Value : List_Index)
691 return Gela.Lexical_Types.Symbol is
692 begin
693 return Gela.Lexical_Types.Symbol (Value) + Compound_Symbol'First;
694 end To_Symbol;
695
696 --------------------
697 -- To_Symbol_List --
698 --------------------
699
700 function To_Symbol_List (List : List_Index) return List_Symbol is
701 begin
702 return Gela.Lexical_Types.Symbol_List (List) + List_Symbol'First;
703 end To_Symbol_List;
704
705end Gela.Plain_Symbol_Sets;
Note: See TracBrowser for help on using the repository browser.