-- There is a missing semicolon in the middle of this file; it -- complained that the LR1 parser has a stack more than 50 deep. So we -- increased the recover stack size. --EMACSCMD:(setq skip-recase-test t) pragma License (Modified_GPL); with Ada.Exceptions; with Ada.Strings.Bounded; with Ada.Text_IO; with SAL; with WisiToken.Semantic_Checks; package body Wisi is use WisiToken; Chars_Per_Int : constant Integer := Integer'Width; ---------- -- body subprogram specs (as needed), alphabetical function Indent_Nil_P (Indent : in Indent_Type) return Boolean; function Max_Anchor_ID (Data : in out Parse_Data_Type; First_Line : in Line_Number_Type; Last_Line : in Line_Number_Type) return Integer; function Paren_In_Anchor_Line (Data : in out Parse_Data_Type'Class; Anchor_Token : in Augmented_Token; Offset : in Integer) return Integer; ---------- -- body subprograms bodies, alphabetical function Image (Anchor_IDs : in Anchor_ID_Vectors.Vector) return String is use Ada.Strings.Unbounded; Result : Unbounded_String := +"("; begin for I in Anchor_IDs.First_Index .. Anchor_IDs.Last_Index loop Result := Result & Integer'Image (Anchor_IDs (I)); if I /= Anchor_IDs.Last_Index then Result := Result & ", "; else Result := Result & ")"; end if; end loop; return -Result; end Image; function Image (Indent : in Indent_Type) return String is begin case Indent.Label is when Not_Set => return "(" & Indent_Label'Image (Indent.Label) & ")"; when Int => return "(" & Indent_Label'Image (Indent.Label) & Integer'Image (Indent.Int_Indent) & ")"; when Anchor_Nil => return "(" & Indent_Label'Image (Indent.Label) & ", " & Image (Indent.Anchor_Nil_IDs) & ", nil)"; when Anchor_Int => return "(" & Indent_Label'Image (Indent.Label) & ", " & Image (Indent.Anchor_Int_IDs) & ", " & Integer'Image (Indent.Anchor_Int_Indent) & ")"; when Anchored => return "(" & Indent_Label'Image (Indent.Label) & ", " & Integer'Image (Indent.Anchored_ID) & ", " & Integer'Image (Indent.Anchored_Delta) & ")"; when Anchor_Anchored => return "(" & Indent_Label'Image (Indent.Label) & ", " & Image (Indent.Anchor_Anchored_IDs) & Integer'Image (Indent.Anchor_Anchored_ID) & ", " & Integer'Image (Indent.Anchor_Anchored_Delta) & ")"; end case; end Image; procedure Indent_Apply_Anchored (Delta_Indent : in Simple_Delta_Type; Indent : in out Indent_Type) with Pre => Delta_Indent.Label = Anchored -- comment after aspect_specification, before 'is' is begin -- [2] wisi-elisp-parse--apply-anchored; add Delta_Indent to Indent case Indent.Label is when Not_Set => Indent := (Anchored, Delta_Indent.Anchored_ID, Delta_Indent.Anchored_Delta); when Int => if Delta_Indent.Anchored_Accumulate then Indent := (Anchored, Delta_Indent.Anchored_ID, Indent.Int_Indent + Delta_Indent.Anchored_Delta); end if; when Anchor_Nil => Indent := (Anchor_Anchored, Indent.Anchor_Nil_IDs, Delta_Indent.Anchored_ID, Delta_Indent.Anchored_Delta); when Anchor_Int => if Delta_Indent.Anchored_Accumulate then Indent := (Anchor_Anchored, Indent.Anchor_Int_IDs, Delta_Indent.Anchored_ID, Delta_Indent.Anchored_Delta + Indent.Anchor_Int_Indent); end if; when Anchored | Anchor_Anchored => -- already anchored null; end case; end Indent_Apply_Anchored; procedure Indent_Apply_Int (Indent : in out Indent_Type; Offset : in Integer) is begin -- [2] wisi-elisp-parse--apply-int; add an Int indent to Indent case Indent.Label is when Not_Set => Indent := (Int, Offset); when Int => Indent.Int_Indent := Indent.Int_Indent + Offset; when Anchor_Nil => Indent := (Label => Anchor_Int, Anchor_Int_IDs => Indent.Anchor_Nil_IDs, Anchor_Int_Indent => Offset); when Anchor_Int => Indent.Anchor_Int_Indent := Indent.Anchor_Int_Indent + Offset; when Anchored | Anchor_Anchored => null; end case; end Indent_Apply_Int; procedure Indent_Line (Data : in out Parse_Data_Type; Line : in Line_Number_Type; Delta_Indent : in Delta_Type) is -- See note in Indent_Anchored_2 for why we can't use renames here. Indent : Indent_Type := Data.Indents (Line); begin case Delta_Indent.Label is when Simple => case Delta_Indent.Simple_Delta.Label is when None => null; when Int => Indent_Apply_Int (Indent, Delta_Indent.Simple_Delta.Int_Delta); when Anchored => Indent_Apply_Anchored (Delta_Indent.Simple_Delta, Indent); end case; when Hanging => if Delta_Indent.Hanging_Accumulate or Indent_Nil_P (Data.Indents (Line)) then if Line = Delta_Indent.Hanging_First_Line then -- Apply delta_1 case Delta_Indent.Hanging_Delta_1.Label is when None => null; when Int => Indent_Apply_Int (Indent, Delta_Indent.Hanging_Delta_1.Int_Delta); when Anchored => Indent_Apply_Anchored (Delta_Indent.Hanging_Delta_1, Indent); end case; else if Delta_Indent.Hanging_Paren_State = Data.Line_Paren_State (Line) then case Delta_Indent.Hanging_Delta_2.Label is when None => null; when Int => Indent_Apply_Int (Indent, Delta_Indent.Hanging_Delta_2.Int_Delta); when Anchored => Indent_Apply_Anchored (Delta_Indent.Hanging_Delta_2, Indent); end case; end if; end if; end if; end case; if Trace_Action > Extra then Ada.Text_IO.Put_Line (";; indent_line: " & Line_Number_Type'Image (Line) & " => " & Image (Indent)); end if; Data.Indents.Replace_Element (Line, Indent); end Indent_Line; function Indent_Nil_P (Indent : in Indent_Type) return Boolean is begin return Indent.Label in Not_Set | Anchor_Nil; end Indent_Nil_P; function Max_Anchor_ID (Data : in out Parse_Data_Type; First_Line : in Line_Number_Type; Last_Line : in Line_Number_Type) return Integer is Result : Integer := First_Anchor_ID - 1; begin for Line in First_Line .. Last_Line loop declare Indent : Indent_Type renames Data.Indents (Line); begin case Indent.Label is when Not_Set | Int => null; when Anchor_Nil => Result := Integer'Max (Result, Indent.Anchor_Nil_IDs (Indent.Anchor_Nil_IDs.First_Index)); when Anchor_Int => Result := Integer'Max (Result, Indent.Anchor_Int_IDs (Indent.Anchor_Int_IDs.First_Index)); when Anchored => Result := Integer'Max (Result, Indent.Anchored_ID); when Anchor_Anchored => Result := Integer'Max (Result, Indent.Anchor_Anchored_ID); end case; end; end loop; return Result; end Max_Anchor_ID; function Paren_In_Anchor_Line (Data : in out Parse_Data_Type'Class; Anchor_Token : in Augmented_Token; Offset : in Integer) return Integer is Left_Paren_ID : Token_ID renames Data.Left_Paren_ID; Right_Paren_ID : Token_ID renames Data.Right_Paren_ID; I : Base_Token_Index := Anchor_Token.First_Terminals_Index; Paren_Count : Integer := 0; Paren_Char_Pos : Buffer_Pos := Invalid_Buffer_Pos; Text_Begin_Pos : Buffer_Pos := Invalid_Buffer_Pos; begin -- [1] wisi-elisp-parse--paren-in-anchor-line. That uses elisp syntax-ppss; here -- we search Terminals. loop declare Tok : Augmented_Token renames Data.Terminals (I); begin if Tok.ID = Left_Paren_ID then Paren_Count := Paren_Count + 1; if Paren_Count = 1 then Paren_Char_Pos := Tok.Char_Region.First; end if; elsif Tok.ID = Right_Paren_ID then Paren_Count := Paren_Count - 1; end if; if Tok.First then Text_Begin_Pos := Tok.Char_Region.First; exit; end if; end; I := I - 1; end loop; if Paren_Char_Pos /= Invalid_Buffer_Pos and Text_Begin_Pos /= Invalid_Buffer_Pos then return 1 + Offset + Integer (Paren_Char_Pos - Text_Begin_Pos); else return Offset; end if; end Paren_In_Anchor_Line; procedure Put (Cache : in Navigate_Cache_Type) is package Bounded is new Ada.Strings.Bounded.Generic_Bounded_Length (Max => 2 + 11 * Chars_Per_Int); use Bounded; Line : Bounded_String := To_Bounded_String ("["); procedure Append (Item : in Nil_Buffer_Pos) is begin if Item.Set then Append (Line, Buffer_Pos'Image (Item.Item)); else Append (Line, " -1"); end if; end Append; begin Append (Line, Navigate_Cache_Code); Append (Line, Buffer_Pos'Image (Cache.Pos)); Append (Line, Token_ID'Image (Cache.Statement_ID)); Append (Line, Token_ID'Image (Cache.ID)); Append (Line, Integer'Image (Cache.Length)); Append (Line, Integer'Image (Navigate_Class_Type'Pos (Cache.Class))); Append (Cache.Containing_Pos); Append (Cache.Prev_Pos); Append (Cache.Next_Pos); Append (Cache.End_Pos); Append (Line, ']'); Ada.Text_IO.Put_Line (To_String (Line)); end Put; procedure Put (Cache : in WisiToken.Buffer_Region) is begin Ada.Text_IO.Put_Line ("[" & Name_Property_Code & Buffer_Pos'Image (Cache.First) & Buffer_Pos'Image (Cache.Last) & "]"); end Put; procedure Put (Cache : in Face_Cache_Type) is package Bounded is new Ada.Strings.Bounded.Generic_Bounded_Length (Max => 2 + 4 * Chars_Per_Int); use Bounded; Line : Bounded_String := To_Bounded_String ("["); begin if Cache.Face.Set then Append (Line, Face_Property_Code); Append (Line, Buffer_Pos'Image (Cache.Region.First)); Append (Line, Buffer_Pos'Image (Cache.Region.Last)); Append (Line, Integer'Image (Cache.Face.Item)); Append (Line, ']'); Ada.Text_IO.Put_Line (To_String (Line)); end if; end Put; procedure Put (Line_Number : in Line_Number_Type; Item : in Indent_Type) is begin -- All Anchors must be resolved at this point, but not all lines have -- an indent computed. A negative indent is an error in either the -- grammar indent rules or the algorithms in this package. case Item.Label is when Not_Set => -- Especially with partial parse, we have no idea what this indent should be. null; when Int => declare -- We can easily get negative indents when there are syntax errors. Ind : constant Integer := Integer'Max (0, Item.Int_Indent); begin Ada.Text_IO.Put_Line ('[' & Indent_Code & Line_Number_Type'Image (Line_Number) & Integer'Image (Ind) & ']'); end; when Anchor_Nil | Anchor_Int | Anchored | Anchor_Anchored => raise SAL.Programmer_Error with "Indent item has non-int label: " & Indent_Label'Image (Item.Label); end case; end Put; procedure Put (Item : in Parse.LR.Configuration; Terminals : in Augmented_Token_Arrays.Vector; Descriptor : in WisiToken.Descriptor; Embedded_Quote_Escape_Doubled : in Boolean) is use Ada.Containers; use Ada.Strings.Unbounded; use Parse.LR; use Parse.LR.Config_Op_Arrays, Parse.LR.Config_Op_Array_Refs; Line : Unbounded_String := To_Unbounded_String ("["); Last_Op : Config_Op := (Fast_Forward, WisiToken.Token_Index'Last); begin if Trace_Action > Detail then Ada.Text_IO.Put_Line (";; " & Parse.LR.Image (Item.Ops, Descriptor)); end if; Append (Line, Recover_Code); if Length (Item.Ops) = 0 then Append (Line, "]"); else for I in First_Index (Item.Ops) .. Last_Index (Item.Ops) loop declare Op : Config_Op renames Constant_Ref (Item.Ops, I); begin case Op.Op is when Fast_Forward => if Last_Op.Op in Insert then Append (Line, "][]]"); elsif Last_Op.Op in Delete then Append (Line, "]]"); end if; Last_Op := Op; when Undo_Reduce | Push_Back => null; when Insert => if Last_Op.Op = Fast_Forward then Append (Line, "["); Append (Line, Buffer_Pos'Image (Terminals (Op.Ins_Token_Index).Char_Region.First)); Append (Line, "["); elsif Last_Op.Op = Delete then Append (Line, "]]["); Append (Line, Buffer_Pos'Image (Terminals (Op.Ins_Token_Index).Char_Region.First)); Append (Line, "["); else -- Last_Op.Op = Insert null; end if; Append (Line, Token_ID'Image (Op.Ins_ID)); Last_Op := Op; when Delete => declare Skip : Boolean := False; begin if Last_Op.Op = Fast_Forward then Append (Line, "["); Append (Line, Buffer_Pos'Image (Terminals (Op.Del_Token_Index).Char_Region.First)); Append (Line, "[]["); elsif Last_Op.Op = Insert then Append (Line, "]["); elsif Last_Op.Op = Delete then if Embedded_Quote_Escape_Doubled and then ((Last_Op.Del_ID = Descriptor.String_1_ID and Op.Del_ID = Descriptor.String_1_ID) or (Last_Op.Del_ID = Descriptor.String_2_ID and Op.Del_ID = Descriptor.String_2_ID)) then declare Tok_1 : Augmented_Token renames Terminals (Last_Op.Del_Token_Index); Tok_2 : Augmented_Token renames Terminals (Op.Del_Token_Index); begin if Tok_1.Char_Region.Last + 1 = Tok_2.Char_Region.First then -- Buffer text was '"""', lexer repair changed it to '""""'. The -- repaired text looks like a single string with an embedded quote. -- But here, it is two STRING_LITERAL tokens. Don't send the second -- delete to elisp. See test/ada_mode-recover_string_quote_1.adb Skip := True; end if; end; end if; end if; if not Skip then Append (Line, Token_ID'Image (Op.Del_ID)); end if; end; Last_Op := Op; end case; end; end loop; case Last_Op.Op is when Fast_Forward => Append (Line, "]"); when Undo_Reduce | Push_Back => null; when Insert => Append (Line, "][]]]"); when Delete => Append (Line, "]]]"); end case; end if; Ada.Text_IO.Put_Line (To_String (Line)); end Put; procedure Resolve_Anchors (Data : in out Parse_Data_Type) is Begin_Indent : Integer renames Data.Begin_Indent; Anchor_Indent : array (First_Anchor_ID .. Data.Max_Anchor_ID) of Integer; begin if Trace_Action > Outline then Ada.Text_IO.New_Line; Ada.Text_IO.Put_Line (";; Begin_Indent: " & Integer'Image (Data.Begin_Indent)); for I in Data.Indents.First_Index .. Data.Indents.Last_Index loop Ada.Text_IO.Put_Line (";; " & Line_Number_Type'Image (I) & ", " & Image (Data.Indents (I))); end loop; Ada.Text_IO.Put_Line (";; resolve anchors"); end if; for I in Data.Indents.First_Index .. Data.Indents.Last_Index loop declare Indent : constant Indent_Type := Data.Indents (I); begin case Indent.Label is when Not_Set => -- Indent not computed, therefore not output. null; when Int => Data.Indents.Replace_Element (I, (Int, Indent.Int_Indent + Begin_Indent)); when Anchor_Nil => for I of Indent.Anchor_Nil_IDs loop Anchor_Indent (I) := Begin_Indent; end loop; Data.Indents.Replace_Element (I, (Int, Begin_Indent)); when Anchor_Int => for I of Indent.Anchor_Int_IDs loop Anchor_Indent (I) := Indent.Anchor_Int_Indent + Begin_Indent; end loop; Data.Indents.Replace_Element (I, (Int, Indent.Anchor_Int_Indent + Begin_Indent)); when Anchored => Data.Indents.Replace_Element (I, (Int, Anchor_Indent (Indent.Anchored_ID) + Indent.Anchored_Delta)); when Anchor_Anchored => declare Temp : constant Integer := Anchor_Indent (Indent.Anchor_Anchored_ID) + Indent.Anchor_Anchored_Delta; begin for I of Indent.Anchor_Anchored_IDs loop Anchor_Indent (I) := Temp; end loop; Data.Indents.Replace_Element (I, (Int, Temp)); end; end case; end; end loop; end Resolve_Anchors; procedure Set_End (Data : in out Parse_Data_Type; Containing_Pos : in Buffer_Pos; End_Pos : in Buffer_Pos) is use Navigate_Cursor_Lists; I : Cursor := Data.End_Positions.First; Delete_Cache : Boolean; Temp : Cursor; begin loop exit when not Has_Element (I); declare Cache : Navigate_Cache_Type renames Data.Navigate_Caches (Element (I)); begin if Cache.Pos in Containing_Pos .. End_Pos then Cache.End_Pos := (True, End_Pos); Delete_Cache := True; else Delete_Cache := False; end if; end; if Delete_Cache then Temp := Next (I); Delete (Data.End_Positions, I); I := Temp; else Next (I); end if; end loop; end Set_End; ---------- -- public subprograms (declaration order) procedure Initialize (Data : in out Parse_Data_Type; Lexer : in WisiToken.Lexer.Handle; Descriptor : access constant WisiToken.Descriptor; Source_File_Name : in String; Post_Parse_Action : in Post_Parse_Action_Type; Begin_Line : in Line_Number_Type; End_Line : in Line_Number_Type; Begin_Indent : in Integer; Params : in String) is pragma Unreferenced (Params); begin Data.Line_Begin_Pos.Set_First_Last (First => Begin_Line, Last => End_Line); -- + 1 for data on line following last line; see Lexer_To_Augmented. Data.Line_Paren_State.Set_First_Last (First => Begin_Line, Last => End_Line + 1); Data.Lexer := Lexer; Data.Descriptor := Descriptor; Data.Source_File_Name := +Source_File_Name; Data.Post_Parse_Action := Post_Parse_Action; case Post_Parse_Action is when Navigate | Face => null; when Indent => Data.Indents.Set_First_Last (First => Begin_Line, Last => End_Line); Data.Begin_Indent := Begin_Indent; end case; Data.Reset; exception when E : others => raise SAL.Programmer_Error with "wisi.initialize: " & Ada.Exceptions.Exception_Name (E) & ": " & Ada.Exceptions.Exception_Message (E); end Initialize; overriding procedure Reset (Data : in out Parse_Data_Type) is begin Data.Terminals.Clear; Data.Leading_Non_Grammar.Clear; -- Data.Line_Begin_Pos set in Initialize, overwritten in Lexer_To_Augmented -- Data.Line_Begin_Token "" for S of Data.Line_Paren_State loop S := 0; end loop; Data.Current_Paren_State := 0; Data.Navigate_Caches.Finalize; Data.Navigate_Caches.Initialize; Data.End_Positions.Clear; Data.Name_Caches.Finalize; Data.Name_Caches.Initialize; Data.Face_Caches.Finalize; Data.Face_Caches.Initialize; for I in Data.Indents.First_Index .. Data.Indents.Last_Index loop Data.Indents.Replace_Element (I, (Label => Not_Set)); end loop; Data.Max_Anchor_ID := First_Anchor_ID - 1; end Reset; function Source_File_Name (Data : in Parse_Data_Type) return String is begin return -Data.Source_File_Name; end Source_File_Name; function Post_Parse_Action (Data : in Parse_Data_Type) return Post_Parse_Action_Type is begin return Data.Post_Parse_Action; end Post_Parse_Action; overriding procedure Lexer_To_Augmented (Data : in out Parse_Data_Type; Token : in Base_Token; Lexer : not null access WisiToken.Lexer.Instance'Class) is use all type Ada.Containers.Count_Type; begin if Lexer.First then Data.Line_Begin_Pos (Token.Line) := Token.Char_Region.First; if Token.Line > Data.Line_Begin_Pos.First_Index and then Data.Line_Begin_Pos (Token.Line - 1) = Invalid_Buffer_Pos then -- Previous token contains multiple lines; ie %code in wisitoken_grammar.wy declare First_Set_Line : Line_Number_Type; begin for Line in reverse Data.Line_Begin_Pos.First_Index .. Token.Line - 1 loop if Data.Line_Begin_Pos (Line) /= Invalid_Buffer_Pos then First_Set_Line := Line; exit; end if; end loop; for Line in First_Set_Line + 1 .. Token.Line - 1 loop Data.Line_Begin_Pos (Line) := Data.Line_Begin_Pos (First_Set_Line); -- good enough end loop; end; end if; end if; if Token.ID < Data.Descriptor.First_Terminal then -- Non-grammar token if Token.ID = Data.Descriptor.New_Line_ID then Data.Line_Paren_State (Token.Line + 1) := Data.Current_Paren_State; end if; if Data.Terminals.Length = 0 then Data.Leading_Non_Grammar.Append ((Token with Lexer.First)); else declare Containing_Token : Augmented_Token renames Data.Terminals (Data.Terminals.Last_Index); Trailing_Blank : constant Boolean := Token.ID = Data.Descriptor.New_Line_ID and (Containing_Token.Non_Grammar.Length > 0 and then Containing_Token.Non_Grammar (Containing_Token.Non_Grammar.Last_Index).ID = Data.Descriptor.New_Line_ID); begin if Lexer.First and (Token.ID in Data.First_Comment_ID .. Data.Last_Comment_ID or Trailing_Blank) then if Containing_Token.First_Trailing_Comment_Line = Invalid_Line_Number then Containing_Token.First_Trailing_Comment_Line := Token.Line; end if; Containing_Token.Last_Trailing_Comment_Line := Token.Line; end if; Containing_Token.Non_Grammar.Append ((Token with Lexer.First)); end; end if; else -- grammar token declare Temp : constant Augmented_Token := (Token.ID, Byte_Region => Token.Byte_Region, Line => Token.Line, Column => Token.Column, Char_Region => Token.Char_Region, Deleted => False, First => Lexer.First, Paren_State => Data.Current_Paren_State, First_Terminals_Index => Data.Terminals.Last_Index + 1, Last_Terminals_Index => Data.Terminals.Last_Index + 1, First_Indent_Line => (if Lexer.First then Token.Line else Invalid_Line_Number), Last_Indent_Line => (if Lexer.First then Token.Line else Invalid_Line_Number), First_Trailing_Comment_Line => Invalid_Line_Number, -- Set by Reduce Last_Trailing_Comment_Line => Invalid_Line_Number, Non_Grammar => <>); begin if Token.ID = Data.Left_Paren_ID then Data.Current_Paren_State := Data.Current_Paren_State + 1; elsif Token.ID = Data.Right_Paren_ID then Data.Current_Paren_State := Data.Current_Paren_State - 1; end if; Data.Terminals.Append (Temp); end; end if; end Lexer_To_Augmented; overriding procedure Delete_Token (Data : in out Parse_Data_Type; Deleted_Token_Index : in WisiToken.Token_Index) is use all type Ada.Containers.Count_Type; Deleted_Token : Augmented_Token renames Data.Terminals (Deleted_Token_Index); Prev_Token_Index : Base_Token_Index := Deleted_Token_Index - 1; Next_Token_Index : Base_Token_Index := Deleted_Token_Index + 1; begin if Deleted_Token.Deleted then -- This can happen if error recovery screws up. if WisiToken.Trace_Action > WisiToken.Detail then Ada.Text_IO.Put_Line (";; delete token again; ignored " & Image (Deleted_Token, Data.Descriptor.all)); end if; return; end if; if WisiToken.Trace_Action > WisiToken.Detail then Ada.Text_IO.Put_Line (";; delete token " & Image (Deleted_Token, Data.Descriptor.all)); end if; Deleted_Token.Deleted := True; if Deleted_Token.Non_Grammar.Length > 0 then -- Move Non_Grammar to previous non-deleted token loop exit when Prev_Token_Index = Base_Token_Index'First; exit when Data.Terminals (Prev_Token_Index).Deleted = False; Prev_Token_Index := Prev_Token_Index - 1; end loop; if Prev_Token_Index = Base_Token_Index'First then Deleted_Token.Non_Grammar (Deleted_Token.Non_Grammar.First_Index).First := Deleted_Token.First; Data.Leading_Non_Grammar.Append (Deleted_Token.Non_Grammar); else declare Prev_Token : Augmented_Token renames Data.Terminals (Prev_Token_Index); begin Prev_Token.Non_Grammar.Append (Deleted_Token.Non_Grammar); if Deleted_Token.First_Trailing_Comment_Line /= Invalid_Line_Number then if Prev_Token.First_Trailing_Comment_Line = Invalid_Line_Number then Prev_Token.First_Trailing_Comment_Line := Deleted_Token.First_Trailing_Comment_Line; end if; Prev_Token.Last_Trailing_Comment_Line := Deleted_Token.Last_Trailing_Comment_Line; end if; end; end if; end if; -- Data.Terminals.Last_Index is Wisi_EOI; it is never deleted loop exit when Data.Terminals (Next_Token_Index).Deleted = False; Next_Token_Index := Next_Token_Index + 1; exit when Next_Token_Index = Data.Terminals.Last_Index; end loop; if Deleted_Token.First and (Next_Token_Index = Data.Terminals.Last_Index or else Data.Terminals (Next_Token_Index).Line > Deleted_Token.Line) then -- Deleted_Token.Line is now blank; add to previous token non -- grammar. if Prev_Token_Index > Base_Token_Index'First then declare Prev_Token : Augmented_Token renames Data.Terminals (Prev_Token_Index); begin if Prev_Token.First_Trailing_Comment_Line = Invalid_Line_Number then Prev_Token.First_Trailing_Comment_Line := Deleted_Token.Line; Prev_Token.Last_Trailing_Comment_Line := Deleted_Token.Line; else if Prev_Token.First_Trailing_Comment_Line > Deleted_Token.Line then Prev_Token.First_Trailing_Comment_Line := Deleted_Token.Line; end if; if Prev_Token.Last_Trailing_Comment_Line < Deleted_Token.Line then Prev_Token.Last_Trailing_Comment_Line := Deleted_Token.Line; end if; end if; end; end if; end if; if Deleted_Token.First and Next_Token_Index < Data.Terminals.Last_Index then if not Data.Terminals (Next_Token_Index).First then declare Next_Token : Augmented_Token renames Data.Terminals (Next_Token_Index); begin Next_Token.First := True; Next_Token.First_Indent_Line := Deleted_Token.First_Indent_Line; Next_Token.Last_Indent_Line := Deleted_Token.Last_Indent_Line; end; end if; end if; end Delete_Token; overriding procedure Reduce (Data : in out Parse_Data_Type; Tree : in out Syntax_Trees.Tree'Class; Nonterm : in Syntax_Trees.Valid_Node_Index; Tokens : in Syntax_Trees.Valid_Node_Index_Array) is Aug_Nonterm : constant Augmented_Token_Access := new Augmented_Token' (ID => Tree.ID (Nonterm), Byte_Region => Tree.Byte_Region (Nonterm), others => <>); Trailing_Comment_Done : Boolean := False; begin Tree.Set_Augmented (Nonterm, Base_Token_Class_Access (Aug_Nonterm)); for I in reverse Tokens'Range loop -- 'reverse' to find token containing trailing comments; last -- non-virtual and non-empty token. if Tree.Byte_Region (Tokens (I)) /= Null_Buffer_Region then -- Token not entirely virtual declare Aug_Token : constant Aug_Token_Ref := Get_Aug_Token (Data, Tree, Tokens (I)); begin if Data.Post_Parse_Action = Indent then if Aug_Token.First_Terminals_Index /= Augmented_Token_Arrays.No_Index then Aug_Nonterm.First_Terminals_Index := Aug_Token.First_Terminals_Index; end if; if Aug_Nonterm.Last_Terminals_Index = Augmented_Token_Arrays.No_Index then Aug_Nonterm.Last_Terminals_Index := Aug_Token.Last_Terminals_Index; end if; Aug_Nonterm.First := Aug_Nonterm.First or Aug_Token.First; if Aug_Token.First_Indent_Line /= Invalid_Line_Number then Aug_Nonterm.First_Indent_Line := Aug_Token.First_Indent_Line; elsif Trailing_Comment_Done and Aug_Token.First_Trailing_Comment_Line /= Invalid_Line_Number then Aug_Nonterm.First_Indent_Line := Aug_Token.First_Trailing_Comment_Line; end if; if Aug_Nonterm.Last_Indent_Line = Invalid_Line_Number then if Trailing_Comment_Done and Aug_Token.Last_Trailing_Comment_Line /= Invalid_Line_Number then Aug_Nonterm.Last_Indent_Line := Aug_Token.Last_Trailing_Comment_Line; elsif Aug_Token.Last_Indent_Line /= Invalid_Line_Number then Aug_Nonterm.Last_Indent_Line := Aug_Token.Last_Indent_Line; end if; end if; if not Trailing_Comment_Done then Aug_Nonterm.First_Trailing_Comment_Line := Aug_Token.First_Trailing_Comment_Line; Aug_Nonterm.Last_Trailing_Comment_Line := Aug_Token.Last_Trailing_Comment_Line; Trailing_Comment_Done := True; end if; end if; -- Compute_Indent if Aug_Token.Line /= Invalid_Line_Number then Aug_Nonterm.Line := Aug_Token.Line; Aug_Nonterm.Column := Aug_Token.Column; end if; if Aug_Nonterm.Char_Region.First > Aug_Token.Char_Region.First then Aug_Nonterm.Char_Region.First := Aug_Token.Char_Region.First; end if; if Aug_Nonterm.Char_Region.Last < Aug_Token.Char_Region.Last then Aug_Nonterm.Char_Region.Last := Aug_Token.Char_Region.Last; end if; Aug_Nonterm.Paren_State := Aug_Token.Paren_State; end; end if; -- Aug_Token not virtual end loop; end Reduce; procedure Statement_Action (Data : in out Parse_Data_Type; Tree : in Syntax_Trees.Tree; Nonterm : in Syntax_Trees.Valid_Node_Index; Tokens : in Syntax_Trees.Valid_Node_Index_Array; Params : in Statement_Param_Array) is Nonterm_Tok : constant Aug_Token_Ref := Get_Aug_Token (Data, Tree, Nonterm); First_Item : Boolean := True; Start_Set : Boolean := False; Override_Start_Set : Boolean := False; Containing_Pos : Nil_Buffer_Pos := Nil; begin for Pair of Params loop if not (Pair.Index in Tokens'Range) then raise Fatal_Error with Error_Message (File_Name => -Data.Source_File_Name, Line => Nonterm_Tok.Line, Column => Nonterm_Tok.Column, Message => "wisi-statement-action: " & Trimmed_Image (Tree.Production_ID (Nonterm)) & " token index" & SAL.Peek_Type'Image (Pair.Index) & " not in tokens range (" & SAL.Peek_Type'Image (Tokens'First) & " .." & SAL.Peek_Type'Image (Tokens'Last) & "); bad grammar action."); elsif Tree.Byte_Region (Tokens (Pair.Index)) /= Null_Buffer_Region then declare use all type WisiToken.Syntax_Trees.Node_Label; Token : constant Aug_Token_Ref := (if Pair.Class = Statement_End and then Tree.Label (Tokens (Pair.Index)) = WisiToken.Syntax_Trees.Nonterm then To_Aug_Token_Ref (Data.Terminals (Tree.Max_Terminal_Index (Tokens (Pair.Index)))) else Get_Aug_Token (Data, Tree, Tokens (Pair.Index))); Cache_Pos : constant Buffer_Pos := Token.Char_Region.First; Cursor : Navigate_Cache_Trees.Cursor := Navigate_Cache_Trees.Find (Data.Navigate_Caches.Iterate, Cache_Pos, Direction => Navigate_Cache_Trees.Unknown); begin if Navigate_Cache_Trees.Has_Element (Cursor) then declare Cache : Navigate_Cache_Type renames Data.Navigate_Caches (Cursor); begin if Pair.Class = Statement_Start then if Start_Set then Cache.Class := Motion; else Cache.Class := Statement_Start; Start_Set := True; end if; elsif Override_Start_Set then Cache.Class := Statement_Start; Start_Set := True; else Cache.Class := Pair.Class; end if; Cache.Statement_ID := Tree.ID (Nonterm); Cache.Containing_Pos := Containing_Pos; end; else Cursor := Data.Navigate_Caches.Insert ((Pos => Cache_Pos, Statement_ID => Tree.ID (Nonterm), ID => Token.ID, Length => Length (Token.Char_Region), Class => (if Override_Start_Set then Statement_Start else Pair.Class), Containing_Pos => Containing_Pos, others => Nil)); end if; Data.End_Positions.Append (Cursor); if First_Item then First_Item := False; if Override_Start_Set or Pair.Class = Statement_Start then Override_Start_Set := False; Containing_Pos := (True, Token.Char_Region.First); -- Set containing on all contained caches declare use Navigate_Cache_Trees; Iterator : constant Navigate_Cache_Trees.Iterator := Data.Navigate_Caches.Iterate; Cursor : Navigate_Cache_Trees.Cursor := Find_In_Range (Iterator, Ascending, Nonterm_Tok.Char_Region.First + 1, -- don't set containing on start Nonterm_Tok.Char_Region.Last); begin loop exit when not Has_Element (Cursor); declare Cache : Navigate_Cache_Type renames Data.Navigate_Caches (Cursor); begin if not Cache.Containing_Pos.Set then Cache.Containing_Pos := Containing_Pos; end if; exit when Nonterm_Tok.Char_Region.Last < Cache.Pos + 1; end; Cursor := Iterator.Next (Cursor); end loop; end; end if; end if; if Pair.Class = Statement_End and Containing_Pos.Set then Set_End (Data, Containing_Pos.Item, Cache_Pos); end if; end; else -- Token.Byte_Region is null if First_Item and Pair.Class = Statement_Start then Override_Start_Set := True; end if; end if; end loop; end Statement_Action; procedure Name_Action (Data : in out Parse_Data_Type; Tree : in WisiToken.Syntax_Trees.Tree; Nonterm : in Syntax_Trees.Valid_Node_Index; Tokens : in WisiToken.Syntax_Trees.Valid_Node_Index_Array; Name : in WisiToken.Positive_Index_Type) is use all type WisiToken.Syntax_Trees.Node_Label; begin if not (Name in Tokens'Range) then declare Token : constant Aug_Token_Ref := Get_Aug_Token (Data, Tree, Tokens (Tokens'First)); begin raise Fatal_Error with Error_Message (File_Name => -Data.Source_File_Name, Line => Token.Line, Column => Token.Column, Message => "wisi-name-action: " & Trimmed_Image (Tree.Production_ID (Nonterm)) & " name (" & Trimmed_Image (Name) & ") not in Tokens range (" & SAL.Peek_Type'Image (Tokens'First) & " .." & SAL.Peek_Type'Image (Tokens'Last) & "); bad grammar action."); end; end if; if Tree.Label (Tokens (Name)) = Syntax_Trees.Virtual_Terminal then return; end if; declare use Name_Cache_Trees; Name_Token : constant Aug_Token_Ref := Get_Aug_Token (Data, Tree, Tokens (Name)); Cursor : constant Name_Cache_Trees.Cursor := Find (Data.Name_Caches.Iterate, Name_Token.Char_Region.First, Direction => Name_Cache_Trees.Unknown); begin if Name_Token.Char_Region = Null_Buffer_Region then return; elsif Has_Element (Cursor) then raise Fatal_Error with Error_Message (File_Name => -Data.Source_File_Name, Line => Name_Token.Line, Column => Name_Token.Column, Message => "wisi-name-action: name set twice."); else Data.Name_Caches.Insert (Name_Token.Char_Region); end if; end; end Name_Action; procedure Containing_Action (Data : in out Parse_Data_Type; Tree : in Syntax_Trees.Tree; Nonterm : in Syntax_Trees.Valid_Node_Index; Tokens : in Syntax_Trees.Valid_Node_Index_Array; Containing : in Positive_Index_Type; Contained : in Positive_Index_Type) is pragma Unreferenced (Data, Tree, Nonterm, Tokens, Containing, Contained); begin null; end Containing_Action; function "+" (Item : in Token_ID) return Token_ID_Lists.List is begin return Result : Token_ID_Lists.List do Result.Append (Item); end return; end "+"; function "&" (List : in Token_ID_Lists.List; Item : in Token_ID) return Token_ID_Lists.List is begin return Result : Token_ID_Lists.List := List do Result.Append (Item); end return; end "&"; function "&" (Left, Right : in Token_ID) return Token_ID_Lists.List is begin return Result : Token_ID_Lists.List do Result.Append (Left); Result.Append (Right); end return; end "&"; procedure Motion_Action (Data : in out Parse_Data_Type; Tree : in Syntax_Trees.Tree; Nonterm : in Syntax_Trees.Valid_Node_Index; Tokens : in Syntax_Trees.Valid_Node_Index_Array; Params : in Motion_Param_Array) is -- [2] wisi-motion-action use Navigate_Cache_Trees; use all type Ada.Containers.Count_Type; Start : Nil_Buffer_Pos := (Set => False); Iter : constant Iterator := Data.Navigate_Caches.Iterate; Prev_Cache_Cur : Cursor; Cache_Cur : Cursor; begin for Param of Params loop if Tree.Byte_Region (Tokens (Param.Index)) /= Null_Buffer_Region then declare use all type WisiToken.Syntax_Trees.Node_Label; Token : constant Aug_Token_Ref := Get_Aug_Token (Data, Tree, Tokens (Param.Index)); Region : constant Buffer_Region := Token.Char_Region; begin if not Start.Set then Start := (True, Region.First); end if; case Tree.Label (Tokens (Param.Index)) is when Shared_Terminal => Cache_Cur := Find (Iter, Region.First); when Virtual_Terminal | Virtual_Identifier => return; when Syntax_Trees.Nonterm => Is_Nonterm := True; if Tree.Is_Virtual (Tokens (Param.Index)) then return; elsif Param.ID = Invalid_Token_ID then Cache_Cur := Find (Iter, Region.First); else Cache_Cur := Find (Iter, Ascending, Region.First, Region.Last, Predicate'access); loop exit when not Has_Element (Cache_Cur); exit when Data.Navigate_Caches (Cache_Cur).Pos > Region.Last -- ERROR: missing semicolon if Data.Navigate_Caches (Cache_Cur).ID = Param.ID then Cache_Cur := No_Element; exit; end if; Cache_Cur := Next (Iter, Cache_Cur); end loop; end if; end case; if not Has_Element (Cache_Cur) then raise Fatal_Error with Error_Message (File_Name => -Data.Source_File_Name, Line => Token.Line, Column => Token.Column, Message => "wisi-motion-action: token " & WisiToken.Image (Token.ID, Data.Descriptor.all) & " has no cache; add to statement-action for " & Trimmed_Image (Tree.Production_ID (Nonterm)) & "."); end if; if Has_Element (Prev_Cache_Cur) then declare Cache : Navigate_Cache_Type renames Data.Navigate_Caches (Cache_Cur); begin if not Cache.Prev_Pos.Set then Cache.Prev_Pos := (True, Data.Navigate_Caches (Prev_Cache_Cur).Pos); end if; end; declare Prev_Cache : Navigate_Cache_Type renames Data.Navigate_Caches (Prev_Cache_Cur); begin if not Prev_Cache.Next_Pos.Set then Prev_Cache.Next_Pos := (True, Region.First); end if; end; end if; loop -- Set Prev_Cache_Cur to last motion cache in nonterm chain exit when not Cache_Cur.Next.Set; Cache_Cur := Find (Iter, Cache_Cur.Next.Pos); pragma Assert (Has_Element, Cache_Cur); -- otherwise there's a bug in this subprogram. end loop; Prev_Cache_Cur := Cache_Cur; end; end if; end loop; end Motion_Action; procedure Face_Apply_Action (Data : in out Parse_Data_Type; Tree : in Syntax_Trees.Tree; Nonterm : in Syntax_Trees.Valid_Node_Index; Tokens : in Syntax_Trees.Valid_Node_Index_Array; Params : in Face_Apply_Param_Array) is pragma Unreferenced (Nonterm); -- [2] wisi-face-apply-action use Face_Cache_Trees; Iter : constant Iterator := Data.Face_Caches.Iterate; Cache_Cur : Cursor; Suffix_Cur : Cursor; begin for Param of Params loop if Tree.Byte_Region (Tokens (Param.Index)) /= Null_Buffer_Region then declare Token : constant Aug_Token_Ref := Get_Aug_Token (Data, Tree, Tokens (Param.Index)); begin Cache_Cur := Find (Iter, Token.Char_Region.First, Direction => Ascending); if Has_Element (Cache_Cur) then declare Cache : Face_Cache_Type renames Data.Face_Caches (Cache_Cur); begin case Cache.Class is when Prefix => Cache.Face := (True, Param.Prefix_Face); -- Check for suffix Suffix_Cur := Next (Iter, Cache_Cur); if Has_Element (Suffix_Cur) then declare Suf_Cache : Face_Cache_Type renames Data.Face_Caches (Suffix_Cur); begin if Suffix = Suf_Cache.Class and Inside (Suf_Cache.Region.First, Token.Char_Region) then Suf_Cache.Face := (True, Param.Suffix_Face); end if; end; end if; when Suffix => Cache.Face := (True, Param.Suffix_Face); end case; end; else Data.Face_Caches.Insert ((Token.Char_Region, Suffix, (True, Param.Suffix_Face))); end if; end; end if; end loop; end Face_Apply_Action; procedure Face_Apply_List_Action (Data : in out Parse_Data_Type; Tree : in Syntax_Trees.Tree; Nonterm : in Syntax_Trees.Valid_Node_Index; Tokens : in Syntax_Trees.Valid_Node_Index_Array; Params : in Face_Apply_Param_Array) is pragma Unreferenced (Nonterm); -- [2] wisi-face-apply-list-action use Face_Cache_Trees; Iter : constant Iterator := Data.Face_Caches.Iterate; Cache_Cur : Cursor; begin for Param of Params loop if Tree.Byte_Region (Tokens (Param.Index)) /= Null_Buffer_Region then declare Token : constant Aug_Token_Ref := Get_Aug_Token (Data, Tree, Tokens (Param.Index)); begin Cache_Cur := Find_In_Range (Iter, Ascending, Token.Char_Region.First, Token.Char_Region.Last); loop exit when not Has_Element (Cache_Cur) or else Data.Face_Caches (Cache_Cur).Region.First > Token.Char_Region.Last; declare Cache : Face_Cache_Type renames Data.Face_Caches (Cache_Cur); begin case Cache.Class is when Prefix => Cache.Face := (True, Param.Prefix_Face); when Suffix => Cache.Face := (True, Param.Suffix_Face); end case; end; Cache_Cur := Next (Iter, Cache_Cur); end loop; end; end if; end loop; end Face_Apply_List_Action; procedure Face_Mark_Action (Data : in out Parse_Data_Type; Tree : in Syntax_Trees.Tree; Nonterm : in Syntax_Trees.Valid_Node_Index; Tokens : in Syntax_Trees.Valid_Node_Index_Array; Params : in Face_Mark_Param_Array) is pragma Unreferenced (Nonterm); -- [2] wisi-face-apply-action use Face_Cache_Trees; Iter : constant Iterator := Data.Face_Caches.Iterate; Cache_Cur : Cursor; begin for Param of Params loop if Tree.Byte_Region (Tokens (Param.Index)) /= Null_Buffer_Region then declare Token : constant Aug_Token_Ref := Get_Aug_Token (Data, Tree, Tokens (Param.Index)); begin Cache_Cur := Find (Iter, Token.Char_Region.First, Direction => Ascending); if Has_Element (Cache_Cur) then declare Cache : Face_Cache_Type renames Data.Face_Caches (Cache_Cur); Other_Cur : Cursor := Find_In_Range (Iter, Ascending, Cache.Region.Last + 1, Token.Char_Region.Last); Temp : Cursor; begin loop exit when not Has_Element (Other_Cur) or else Data.Face_Caches (Other_Cur).Region.First > Token.Char_Region.Last; Temp := Other_Cur; Other_Cur := Next (Iter, Other_Cur); Delete (Data.Face_Caches, Temp); end loop; Cache.Class := Param.Class; Cache.Region.Last := Token.Char_Region.Last; end; else Data.Face_Caches.Insert ((Token.Char_Region, Param.Class, (Set => False))); end if; end; end if; end loop; end Face_Mark_Action; procedure Face_Remove_Action (Data : in out Parse_Data_Type; Tree : in Syntax_Trees.Tree; Nonterm : in Syntax_Trees.Valid_Node_Index; Tokens : in Syntax_Trees.Valid_Node_Index_Array; Params : in Face_Remove_Param_Array) is pragma Unreferenced (Nonterm); -- [2] wisi-face-remove-action use Face_Cache_Trees; Iter : constant Iterator := Data.Face_Caches.Iterate; Cache_Cur : Cursor; Temp : Cursor; begin for I of Params loop if Tree.Byte_Region (Tokens (I)) /= Null_Buffer_Region then declare Token : constant Aug_Token_Ref := Get_Aug_Token (Data, Tree, Tokens (I)); begin Cache_Cur := Find_In_Range (Iter, Ascending, Token.Char_Region.First, Token.Char_Region.Last); loop exit when not Has_Element (Cache_Cur) or else Data.Face_Caches (Cache_Cur).Region.First > Token.Char_Region.Last; Temp := Cache_Cur; Cache_Cur := Next (Iter, Cache_Cur); Delete (Data.Face_Caches, Temp); end loop; end; end if; end loop; end Face_Remove_Action; function "+" (Item : in Integer) return Indent_Arg_Arrays.Vector is begin return Result : Indent_Arg_Arrays.Vector do Result.Append (Item); end return; end "+"; function "&" (List : in Indent_Arg_Arrays.Vector; Item : in Integer) return Indent_Arg_Arrays.Vector is begin return Result : Indent_Arg_Arrays.Vector := List do Result.Append (Item); end return; end "&"; function "&" (Left, Right : in Integer) return Indent_Arg_Arrays.Vector is begin return Result : Indent_Arg_Arrays.Vector do Result.Append (Left); Result.Append (Right); end return; end "&"; function Image (Item : in Simple_Indent_Param) return String is begin return "(" & Simple_Indent_Param_Label'Image (Item.Label) & (case Item.Label is when None => "", when Int => Integer'Image (Item.Int_Delta), when Anchored_Label => Positive_Index_Type'Image (Item.Anchored_Index) & "," & Integer'Image (Item.Anchored_Delta), when Language => "") & ")"; end Image; function Image (Item : in Indent_Param) return String is begin return "(" & Indent_Param_Label'Image (Item.Label) & ", " & (case Item.Label is when Simple => Image (Item.Param), when Hanging_Label => Image (Item.Hanging_Delta_1) & ", " & Image (Item.Hanging_Delta_2) & ")"); end Image; function Image (Item : in Indent_Pair) return String is begin return "(" & Image (Item.Code_Delta) & (if Item.Comment_Present then ", " & Image (Item.Comment_Delta) else "") & ")"; end Image; procedure Indent_Action_0 (Data : in out Parse_Data_Type'Class; Tree : in Syntax_Trees.Tree; Nonterm : in Syntax_Trees.Valid_Node_Index; Tokens : in Syntax_Trees.Valid_Node_Index_Array; Params : in Indent_Param_Array) is begin if Trace_Action > Outline then Ada.Text_IO.Put_Line (";; indent_action_0: " & Tree.Image (Nonterm, Data.Descriptor.all)); end if; -- [2] wisi-indent-action for I in Tokens'Range loop if Tree.Byte_Region (Tokens (I)) /= Null_Buffer_Region and I in Params'Range -- in some translated EBNF, not every token has an indent param then declare use all type WisiToken.Syntax_Trees.Node_Index; use all type SAL.Base_Peek_Type; Tree_Token : constant Syntax_Trees.Valid_Node_Index := Tokens (I); Token : constant Aug_Token_Ref := Get_Aug_Token (Data, Tree, Tree_Token); Pair : Indent_Pair renames Params (I); Code_Delta : Delta_Type; Comment_Param : Indent_Param; Comment_Param_Set : Boolean := False; Comment_Delta : Delta_Type; begin if Trace_Action > Detail then Ada.Text_IO.Put_Line (";; indent_action_0 a: " & Tree.Image (Tree_Token, Data.Descriptor.all) & ": " & Image (Pair)); end if; if Token.First_Indent_Line /= Invalid_Line_Number then Code_Delta := Indent_Compute_Delta (Data, Tree, Tokens, Pair.Code_Delta, Tree_Token, Indenting_Comment => False); Indent_Token_1 (Data, Token, Code_Delta, Indenting_Comment => False); end if; if Token.First_Trailing_Comment_Line /= Invalid_Line_Number then if Pair.Comment_Present then Comment_Param := Pair.Comment_Delta; Comment_Param_Set := True; elsif I < Tokens'Last then Comment_Param := Params (I + 1).Code_Delta; Comment_Param_Set := True; end if; if Comment_Param_Set then Comment_Delta := Indent_Compute_Delta (Data, Tree, Tokens, Comment_Param, Tree_Token, Indenting_Comment => True); Indent_Token_1 (Data, Token, Comment_Delta, Indenting_Comment => True); end if; end if; end; end if; end loop; end Indent_Action_0; procedure Indent_Action_1 (Data : in out Parse_Data_Type'Class; Tree : in Syntax_Trees.Tree; Nonterm : in Syntax_Trees.Valid_Node_Index; Tokens : in Syntax_Trees.Valid_Node_Index_Array; N : in Positive_Index_Type; Params : in Indent_Param_Array) is use all type Syntax_Trees.Node_Label; begin -- [2] wisi-indent-action* for I in Tokens'First .. N loop if Tree.Label (Tokens (I)) /= Virtual_Terminal and then Get_Aug_Token (Data, Tree, Tokens (I)).First then Indent_Action_0 (Data, Tree, Nonterm, Tokens, Params); return; end if; end loop; end Indent_Action_1; function Indent_Hanging_1 (Data : in out Parse_Data_Type; Tree : in Syntax_Trees.Tree; Tokens : in Syntax_Trees.Valid_Node_Index_Array; Tree_Indenting : in Syntax_Trees.Valid_Node_Index; Indenting_Comment : in Boolean; Delta_1 : in Simple_Indent_Param; Delta_2 : in Simple_Indent_Param; Option : in Boolean; Accumulate : in Boolean) return Delta_Type is Indenting_Token : constant Aug_Token_Ref := Get_Aug_Token (Data, Tree, Tree_Indenting); begin -- [2] wisi-elisp-parse--hanging-1 if Indenting_Comment then return Indent_Compute_Delta (Data, Tree, Tokens, (Simple, Delta_1), Tree_Indenting, Indenting_Comment); else return (Hanging, Hanging_First_Line => Indenting_Token.Line, Hanging_Paren_State => Indenting_Token.Paren_State, Hanging_Delta_1 => Indent_Compute_Delta (Data, Tree, Tokens, (Simple, Delta_1), Tree_Indenting, Indenting_Comment).Simple_Delta, Hanging_Delta_2 => (if (not Option) or Indenting_Token.Line = Indenting_Token.First_Indent_Line -- first token in tok is first on line then Indent_Compute_Delta (Data, Tree, Tokens, (Simple, Delta_2), Tree_Indenting, Indenting_Comment).Simple_Delta else Indent_Compute_Delta (Data, Tree, Tokens, (Simple, Delta_1), Tree_Indenting, Indenting_Comment).Simple_Delta), Hanging_Accumulate => Accumulate); end if; end Indent_Hanging_1; procedure Put_Language_Action (Data : in Parse_Data_Type; Content : in String) is pragma Unreferenced (Data); begin Ada.Text_IO.Put_Line ("[" & Language_Action_Code & Content & "]"); end Put_Language_Action; procedure Put (Data : in out Parse_Data_Type; Parser : in Parse.Base_Parser'Class) is use all type Ada.Containers.Count_Type; Last_Term : constant Base_Token_Index := Parser.Tree.Max_Terminal_Index (Parser.Tree.Root); function Get_Last_Char_Pos return Buffer_Pos is begin if Parser.Terminals.Length = 0 then -- All comments, or empty if Data.Leading_Non_Grammar.Length > 0 then return Data.Leading_Non_Grammar (Data.Leading_Non_Grammar.Last_Index).Char_Region.Last; else return Buffer_Pos'First; end if; else if Last_Term = Invalid_Token_Index then -- All grammar tokens inserted by recover if Data.Leading_Non_Grammar.Length > 0 then return Data.Leading_Non_Grammar (Data.Leading_Non_Grammar.Last_Index).Char_Region.Last; else return Buffer_Pos'First; end if; else if Data.Terminals (Last_Term).Non_Grammar.Length > 0 then return Data.Terminals (Last_Term).Non_Grammar (Data.Terminals (Last_Term).Non_Grammar.Last_Index).Char_Region.Last; else return Parser.Terminals (Last_Term).Char_Region.Last; end if; end if; end if; end Get_Last_Char_Pos; Last_Char_Pos : constant Buffer_Pos := Get_Last_Char_Pos; function Get_Last_Line return Line_Number_Type is begin for I in Data.Line_Begin_Pos.First_Index .. Data.Line_Begin_Pos.Last_Index loop if Data.Line_Begin_Pos (I) = Invalid_Buffer_Pos then raise SAL.Programmer_Error with "line_begin_pos" & Line_Number_Type'Image (I) & " invalid"; end if; if Data.Line_Begin_Pos (I) > Last_Char_Pos then if I > Line_Number_Type'First then return I - 1; else return I; end if; end if; end loop; return Data.Line_Begin_Pos.Last_Index; end Get_Last_Line; begin if Trace_Action > Outline then Ada.Text_IO.Put_Line (";; last_char_pos:" & Buffer_Pos'Image (Last_Char_Pos + 1) & " last_line:" & Line_Number_Type'Image (Get_Last_Line)); end if; -- +1 to match Emacs region Ada.Text_IO.Put_Line ('[' & End_Code & Buffer_Pos'Image (Last_Char_Pos + 1) & ']'); case Data.Post_Parse_Action is when Navigate => for Cache of Data.Navigate_Caches loop Put (Cache); end loop; for Cache of Data.Name_Caches loop Put (Cache); end loop; when Face => for Cache of Data.Face_Caches loop Put (Cache); end loop; when Indent => Resolve_Anchors (Data); if Trace_Action > Outline then Ada.Text_IO.Put_Line (";; indent leading non_grammar"); end if; for Token of Data.Leading_Non_Grammar loop if Token.First then Put (Token.Line, (Int, Data.Begin_Indent)); end if; end loop; -- It may be that not all lines in Data.Indents were parsed. if Trace_Action > Outline then Ada.Text_IO.Put_Line (";; indent grammar"); end if; for I in Data.Indents.First_Index .. Get_Last_Line loop Put (I, Data.Indents (I)); end loop; end case; end Put; procedure Put (Lexer_Errors : in Lexer.Error_Lists.List) is begin for Item of Lexer_Errors loop Ada.Text_IO.Put_Line ('[' & Lexer_Error_Code & Buffer_Pos'Image (Item.Char_Pos) & " ""lexer error" & (if Item.Recover_Char (1) = ASCII.NUL then """" elsif Item.Recover_Char (1) = '"' then """ ?\""" else """ ?" & Item.Recover_Char (1)) & "]"); if Item.Recover_Char (2) /= ASCII.NUL then raise SAL.Programmer_Error with "lexer error with non-ascii or multiple repair char"; end if; end loop; end Put; procedure Put (Data : in Parse_Data_Type; Lexer_Errors : in Lexer.Error_Lists.List; Parse_Errors : in Parse.LR.Parse_Error_Lists.List; Tree : in Syntax_Trees.Tree) is use all type SAL.Base_Peek_Type; use Ada.Text_IO; use Semantic_Checks; function Safe_Pos (Node : in Syntax_Trees.Valid_Node_Index) return Buffer_Pos is -- Return a reasonable position for the error at Node. -- -- In a successful parse with error recovery, Node is a terminal with -- an augmented token in Data.Terminals, so that is the first -- choice. -- -- If this is an error due to a bad recovery, Node may be a virtual -- token, with no position information, so we try to get information -- from its parent. use Syntax_Trees; N : Node_Index := Node; begin loop if Tree.Label (N) /= Virtual_Terminal then declare Ref : constant Aug_Token_Ref := Get_Aug_Token (Data, Tree, N); begin if Ref.Char_Region /= Null_Buffer_Region then return Ref.Element.Char_Region.First; end if; end; end if; N := Tree.Parent (N); exit when N = Invalid_Node_Index; end loop; return Buffer_Pos'First; end Safe_Pos; function Safe_Pos (Token : in Recover_Token) return Buffer_Pos is begin if Token.Name /= Null_Buffer_Region then return Token.Name.First; elsif Token.Byte_Region = Null_Buffer_Region then return Buffer_Pos'First; else return Token.Byte_Region.First; end if; end Safe_Pos; begin Put (Lexer_Errors); for Item of Parse_Errors loop -- We don't include parser id here; not very useful. case Item.Label is when Parse.LR.Action => Put_Line ('[' & Parser_Error_Code & Buffer_Pos'Image (Safe_Pos (Item.Error_Token)) & " ""syntax error: expecting " & Image (Item.Expecting, Data.Descriptor.all) & ", found '" & Image (Tree.ID (Item.Error_Token), Data.Descriptor.all) & "'""]"); when Parse.LR.Check => Put_Line ('[' & Check_Error_Code & Integer'Image (Semantic_Checks.Check_Status_Label'Pos (Item.Check_Status.Label)) & (case Item.Check_Status.Label is when Ok => "", when Error => Buffer_Pos'Image (Safe_Pos (Item.Check_Status.Begin_Name)) & Buffer_Pos'Image (Safe_Pos (Item.Check_Status.End_Name)) & " ""block name error""]")); when Parse.LR.Message => Put_Line ('[' & Parser_Error_Code & Buffer_Pos'Image (Buffer_Pos'First) & " """ & (-Item.Msg) & """]"); end case; if Item.Recover.Stack.Depth > 0 then Put (Item.Recover, Data.Terminals, Data.Descriptor.all, Data.Embedded_Quote_Escape_Doubled); end if; end loop; end Put; procedure Put_Error (Data : in Parse_Data_Type; Line_Number : in Line_Number_Type; Message : in String) is use Ada.Text_IO; begin Put_Line ("(error """ & Error_Message (-Data.Source_File_Name, Line_Number, 0, Message) & """)"); end Put_Error; ---------- -- Spec visible private subprograms, alphabetical function Image (Item : in Simple_Delta_Type) return String is begin return "(" & Simple_Delta_Labels'Image (Item.Label) & (case Item.Label is when None => "", when Int => Integer'Image (Item.Int_Delta), when Anchored => Integer'Image (Item.Anchored_ID) & Integer'Image (Item.Anchored_Delta) & " " & Boolean'Image (Item.Anchored_Accumulate)) & ")"; end Image; function Image (Item : in Delta_Type) return String is begin return "(" & Delta_Labels'Image (Item.Label) & (case Item.Label is when Simple => " " & Image (Item.Simple_Delta), when Hanging => Line_Number_Type'Image (Item.Hanging_First_Line) & Integer'Image (Item.Hanging_Paren_State) & " " & Image (Item.Hanging_Delta_1) & " " & Image (Item.Hanging_Delta_2) & " " & Boolean'Image (Item.Hanging_Accumulate)) & ")"; end Image; function Current_Indent_Offset (Data : in Parse_Data_Type; Anchor_Token : in Augmented_Token'Class; Offset : in Integer) return Integer is begin return Offset + Integer (Anchor_Token.Char_Region.First - Data.Line_Begin_Pos (Anchor_Token.Line)); end Current_Indent_Offset; function Find (Data : in Parse_Data_Type; ID : in Token_ID; Token : in Augmented_Token'Class) return Base_Token_Index is begin -- linear search for ID. for I in Token.First_Terminals_Index .. Token.Last_Terminals_Index loop if Data.Terminals (I).ID = ID then return I; end if; end loop; return Augmented_Token_Arrays.No_Index; end Find; function First_Line (Token : in Augmented_Token; Indenting_Comment : in Boolean) return Line_Number_Type is begin return (if Indenting_Comment then (if Token.First_Trailing_Comment_Line = Invalid_Line_Number then Token.Line else Token.First_Trailing_Comment_Line) else (if Token.First_Indent_Line = Invalid_Line_Number then Token.Line else Token.First_Indent_Line)); end First_Line; function Get_Aug_Token (Data : in Parse_Data_Type'Class; Tree : in Syntax_Trees.Tree'Class; Tree_Index : in Syntax_Trees.Valid_Node_Index) return Aug_Token_Ref is use all type Syntax_Trees.Node_Label; begin return (case Tree.Label (Tree_Index) is when Shared_Terminal => To_Aug_Token_Ref (Data.Terminals (Tree.Terminal (Tree_Index))), when Virtual_Terminal => raise SAL.Programmer_Error with "wisi_runtime.get_aug_token virtual terminal", when Virtual_Identifier => raise SAL.Programmer_Error with "wisi_runtime.get_aug_token virtual identifier", when Nonterm => To_Aug_Token_Ref (Tree.Augmented (Tree_Index))); end Get_Aug_Token; function Get_Text (Data : in Parse_Data_Type; Tree : in WisiToken.Syntax_Trees.Tree; Tree_Index : in WisiToken.Syntax_Trees.Valid_Node_Index) return String is use all type Syntax_Trees.Node_Label; begin case Tree.Label (Tree_Index) is when Shared_Terminal | Nonterm => return Data.Lexer.Buffer_Text (Tree.Byte_Region (Tree_Index)); when Virtual_Terminal | Virtual_Identifier => raise SAL.Programmer_Error; end case; end Get_Text; function Elisp_Escape_Quotes (Item : in String) return String is Result : String (Item'First .. Item'First + Item'Length * 2); Last : Integer := Item'First - 1; begin for I in Item'Range loop if Item (I) = '"' then Last := Last + 1; Result (Last) := '\'; end if; Last := Last + 1; Result (Last) := Item (I); end loop; return Result (Result'First .. Last); end Elisp_Escape_Quotes; overriding function Image (Item : in Augmented_Token; Descriptor : in WisiToken.Descriptor) return String is ID_Image : constant String := Image (Item.ID, Descriptor); begin if Item.Line /= Invalid_Line_Number and Trace_Action <= Detail then return "(" & ID_Image & Line_Number_Type'Image (Item.Line) & ":" & Trimmed_Image (Integer (Item.Column)) & ")"; elsif Item.Char_Region = Null_Buffer_Region then return "(" & ID_Image & ")"; else return "(" & ID_Image & ", " & Image (Item.Char_Region) & ")"; end if; end Image; function Indent_Anchored_2 (Data : in out Parse_Data_Type; Anchor_Line : in Line_Number_Type; Last_Line : in Line_Number_Type; Offset : in Integer; Accumulate : in Boolean) return Delta_Type is -- [2] wisi-elisp-parse--anchored-2; return an anchored delta use Anchor_ID_Vectors; -- We can't use a Reference here, because the Element in reference -- types is constrained (as are all allocated objects of access -- types; AARM 4.8 (6/3)), and we may need to change the Label. Indent : Indent_Type := Data.Indents (Anchor_Line); Anchor_ID : constant Integer := 1 + Max_Anchor_ID (Data, Anchor_Line, Last_Line); begin Data.Max_Anchor_ID := Integer'Max (Data.Max_Anchor_ID, Anchor_ID); case Indent.Label is when Not_Set => Indent := (Anchor_Nil, To_Vector (Anchor_ID, 1)); if Trace_Action > Extra then Ada.Text_IO.Put_Line (";; indent_anchored: " & Line_Number_Type'Image (Anchor_Line) & " => " & Image (Indent)); end if; when Int => Indent := (Anchor_Int, To_Vector (Anchor_ID, 1), Indent.Int_Indent); if Trace_Action > Extra then Ada.Text_IO.Put_Line (";; indent_anchored: " & Line_Number_Type'Image (Anchor_Line) & " => " & Image (Indent)); end if; when Anchor_Nil => Indent.Anchor_Nil_IDs := Anchor_ID & Indent.Anchor_Nil_IDs; when Anchor_Int => Indent.Anchor_Int_IDs := Anchor_ID & Indent.Anchor_Int_IDs; when Anchored => Indent := (Anchor_Anchored, To_Vector (Anchor_ID, 1), Indent.Anchored_ID, Indent.Anchored_Delta); when Anchor_Anchored => Indent.Anchor_Anchored_IDs := Anchor_ID & Indent.Anchor_Anchored_IDs; end case; Data.Indents.Replace_Element (Anchor_Line, Indent); return (Simple, (Anchored, Anchor_ID, Offset, Accumulate)); end Indent_Anchored_2; function Indent_Compute_Delta (Data : in out Parse_Data_Type'Class; Tree : in Syntax_Trees.Tree; Tokens : in Syntax_Trees.Valid_Node_Index_Array; Param : in Indent_Param; Tree_Indenting : in Syntax_Trees.Valid_Node_Index; Indenting_Comment : in Boolean) return Delta_Type is Indenting_Token : constant Aug_Token_Ref := Get_Aug_Token (Data, Tree, Tree_Indenting); begin -- [2] wisi-elisp-parse--indent-compute-delta, which evals wisi-anchored*, wisi-hanging*. case Param.Label is when Simple => case Param.Param.Label is when None => return (Simple, (Label => None)); when Int => return (Simple, (Int, Param.Param.Int_Delta)); when Anchored_Label => if Indenting_Token.Byte_Region = Null_Buffer_Region or Tree.Byte_Region (Tokens (Param.Param.Anchored_Index)) = Null_Buffer_Region then -- One of these is an entirely virtual token return Null_Delta; else declare Anchor_Token : constant Aug_Token_Ref := Get_Aug_Token (Data, Tree, Tokens (Param.Param.Anchored_Index)); begin case Anchored_Label'(Param.Param.Label) is when Anchored_0 => -- [2] wisi-anchored, wisi-anchored-1 return Indent_Anchored_2 (Data, Anchor_Line => Anchor_Token.Line, Last_Line => Indenting_Token.Last_Line (Indenting_Comment), Offset => Current_Indent_Offset (Data, Anchor_Token, Param.Param.Anchored_Delta), Accumulate => True); when Anchored_1 => -- [2] wisi-anchored% return Indent_Anchored_2 (Data, Anchor_Line => Anchor_Token.Line, Last_Line => Indenting_Token.Last_Line (Indenting_Comment), Offset => Paren_In_Anchor_Line (Data, Anchor_Token, Param.Param.Anchored_Delta), Accumulate => True); when Anchored_2 => -- [2] wisi-anchored%- return Indent_Anchored_2 (Data, Anchor_Line => Anchor_Token.Line, Last_Line => Indenting_Token.Last_Line (Indenting_Comment), Offset => Paren_In_Anchor_Line (Data, Anchor_Token, Param.Param.Anchored_Delta), Accumulate => False); when Anchored_3 => -- [2] wisi-anchored* if Indenting_Token.First then return Indent_Anchored_2 (Data, Anchor_Line => Anchor_Token.Line, Last_Line => Indenting_Token.Last_Line (Indenting_Comment), Offset => Current_Indent_Offset (Data, Anchor_Token, Param.Param.Anchored_Delta), Accumulate => True); else return Null_Delta; end if; when Anchored_4 => -- [2] wisi-anchored*- return Indent_Anchored_2 (Data, Anchor_Line => Anchor_Token.Line, Last_Line => Indenting_Token.Last_Line (Indenting_Comment), Offset => Current_Indent_Offset (Data, Anchor_Token, Param.Param.Anchored_Delta), Accumulate => False); end case; end; end if; when Language => return Param.Param.Function_Ptr (Data, Tree, Tokens, Tree_Indenting, Indenting_Comment, Param.Param.Args); end case; when Hanging_Label => case Hanging_Label'(Param.Label) is when Hanging_0 => -- wisi-hanging return Indent_Hanging_1 (Data, Tree, Tokens, Tree_Indenting, Indenting_Comment, Param.Hanging_Delta_1, Param.Hanging_Delta_2, Option => False, Accumulate => True); when Hanging_1 => -- wisi-hanging- return Indent_Hanging_1 (Data, Tree, Tokens, Tree_Indenting, Indenting_Comment, Param.Hanging_Delta_1, Param.Hanging_Delta_2, Option => False, Accumulate => False); when Hanging_2 => -- wisi-hanging% return Indent_Hanging_1 (Data, Tree, Tokens, Tree_Indenting, Indenting_Comment, Param.Hanging_Delta_1, Param.Hanging_Delta_2, Option => True, Accumulate => True); when Hanging_3 => -- wisi-hanging%- return Indent_Hanging_1 (Data, Tree, Tokens, Tree_Indenting, Indenting_Comment, Param.Hanging_Delta_1, Param.Hanging_Delta_2, Option => True, Accumulate => False); end case; end case; end Indent_Compute_Delta; procedure Indent_Token_1 (Data : in out Parse_Data_Type; Indenting_Token : in Augmented_Token'Class; Delta_Indent : in Delta_Type; Indenting_Comment : in Boolean) is -- Aplly Delta_Indent to Indenting_Token First_Line : constant Line_Number_Type := Indenting_Token.First_Line (Indenting_Comment); Last_Line : constant Line_Number_Type := Indenting_Token.Last_Line (Indenting_Comment); begin if Trace_Action > Detail then Ada.Text_IO.Put_Line (";; indent_token_1: " & Indenting_Token.Image (Data.Descriptor.all) & " " & Image (Delta_Indent) & Line_Number_Type'Image (First_Line) & " .." & Line_Number_Type'Image (Last_Line) & (if Indenting_Comment then " comment" else "")); end if; for Line in First_Line .. Last_Line loop if Data.Indent_Comment_Col_0 then declare use all type Ada.Text_IO.Count; Indent : Boolean := True; begin if Data.Line_Begin_Token.all (Line - 1) /= Augmented_Token_Arrays.No_Index then for Tok of Data.Terminals (Data.Line_Begin_Token.all (Line - 1)).Non_Grammar loop if Tok.Line = Line and then Tok.ID in Data.First_Comment_ID .. Data.Last_Comment_ID and then Tok.Column = 0 then Indent := False; exit; end if; end loop; end if; if Indent then Indent_Line (Data, Line, Delta_Indent); else Indent_Line (Data, Line, (Simple, (Int, 0))); end if; end; else Indent_Line (Data, Line, Delta_Indent); end if; end loop; end Indent_Token_1; function Last_Line (Token : in Augmented_Token; Indenting_Comment : in Boolean) return Line_Number_Type is begin return (if Indenting_Comment then (if Token.Last_Trailing_Comment_Line = Invalid_Line_Number then Token.Line else Token.Last_Trailing_Comment_Line) else (if Token.Last_Indent_Line = Invalid_Line_Number then Token.Line else Token.Last_Indent_Line)); end Last_Line; end Wisi;