adabrowse_4.0.3/0000755000175000017500000000000010234242071011656 5ustar kenkenadabrowse_4.0.3/GPL.txt0000644000175000017500000004313110234241454013047 0ustar kenken GNU GENERAL PUBLIC LICENSE Version 2, June 1991 Copyright (C) 1989, 1991 Free Software Foundation, Inc. 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA Everyone is permitted to copy and distribute verbatim copies of this license document, but changing it is not allowed. Preamble The licenses for most software are designed to take away your freedom to share and change it. By contrast, the GNU General Public License is intended to guarantee your freedom to share and change free software--to make sure the software is free for all its users. This General Public License applies to most of the Free Software Foundation's software and to any other program whose authors commit to using it. (Some other Free Software Foundation software is covered by the GNU Library General Public License instead.) You can apply it to your programs, too. When we speak of free software, we are referring to freedom, not price. Our General Public Licenses are designed to make sure that you have the freedom to distribute copies of free software (and charge for this service if you wish), that you receive source code or can get it if you want it, that you can change the software or use pieces of it in new free programs; and that you know you can do these things. To protect your rights, we need to make restrictions that forbid anyone to deny you these rights or to ask you to surrender the rights. These restrictions translate to certain responsibilities for you if you distribute copies of the software, or if you modify it. For example, if you distribute copies of such a program, whether gratis or for a fee, you must give the recipients all the rights that you have. You must make sure that they, too, receive or can get the source code. And you must show them these terms so they know their rights. We protect your rights with two steps: (1) copyright the software, and (2) offer you this license which gives you legal permission to copy, distribute and/or modify the software. Also, for each author's protection and ours, we want to make certain that everyone understands that there is no warranty for this free software. If the software is modified by someone else and passed on, we want its recipients to know that what they have is not the original, so that any problems introduced by others will not reflect on the original authors' reputations. Finally, any free program is threatened constantly by software patents. We wish to avoid the danger that redistributors of a free program will individually obtain patent licenses, in effect making the program proprietary. To prevent this, we have made it clear that any patent must be licensed for everyone's free use or not licensed at all. The precise terms and conditions for copying, distribution and modification follow. GNU GENERAL PUBLIC LICENSE TERMS AND CONDITIONS FOR COPYING, DISTRIBUTION AND MODIFICATION 0. This License applies to any program or other work which contains a notice placed by the copyright holder saying it may be distributed under the terms of this General Public License. The "Program", below, refers to any such program or work, and a "work based on the Program" means either the Program or any derivative work under copyright law: that is to say, a work containing the Program or a portion of it, either verbatim or with modifications and/or translated into another language. (Hereinafter, translation is included without limitation in the term "modification".) Each licensee is addressed as "you". Activities other than copying, distribution and modification are not covered by this License; they are outside its scope. The act of running the Program is not restricted, and the output from the Program is covered only if its contents constitute a work based on the Program (independent of having been made by running the Program). Whether that is true depends on what the Program does. 1. You may copy and distribute verbatim copies of the Program's source code as you receive it, in any medium, provided that you conspicuously and appropriately publish on each copy an appropriate copyright notice and disclaimer of warranty; keep intact all the notices that refer to this License and to the absence of any warranty; and give any other recipients of the Program a copy of this License along with the Program. You may charge a fee for the physical act of transferring a copy, and you may at your option offer warranty protection in exchange for a fee. 2. You may modify your copy or copies of the Program or any portion of it, thus forming a work based on the Program, and copy and distribute such modifications or work under the terms of Section 1 above, provided that you also meet all of these conditions: a) You must cause the modified files to carry prominent notices stating that you changed the files and the date of any change. b) You must cause any work that you distribute or publish, that in whole or in part contains or is derived from the Program or any part thereof, to be licensed as a whole at no charge to all third parties under the terms of this License. c) If the modified program normally reads commands interactively when run, you must cause it, when started running for such interactive use in the most ordinary way, to print or display an announcement including an appropriate copyright notice and a notice that there is no warranty (or else, saying that you provide a warranty) and that users may redistribute the program under these conditions, and telling the user how to view a copy of this License. (Exception: if the Program itself is interactive but does not normally print such an announcement, your work based on the Program is not required to print an announcement.) These requirements apply to the modified work as a whole. If identifiable sections of that work are not derived from the Program, and can be reasonably considered independent and separate works in themselves, then this License, and its terms, do not apply to those sections when you distribute them as separate works. But when you distribute the same sections as part of a whole which is a work based on the Program, the distribution of the whole must be on the terms of this License, whose permissions for other licensees extend to the entire whole, and thus to each and every part regardless of who wrote it. Thus, it is not the intent of this section to claim rights or contest your rights to work written entirely by you; rather, the intent is to exercise the right to control the distribution of derivative or collective works based on the Program. In addition, mere aggregation of another work not based on the Program with the Program (or with a work based on the Program) on a volume of a storage or distribution medium does not bring the other work under the scope of this License. 3. You may copy and distribute the Program (or a work based on it, under Section 2) in object code or executable form under the terms of Sections 1 and 2 above provided that you also do one of the following: a) Accompany it with the complete corresponding machine-readable source code, which must be distributed under the terms of Sections 1 and 2 above on a medium customarily used for software interchange; or, b) Accompany it with a written offer, valid for at least three years, to give any third party, for a charge no more than your cost of physically performing source distribution, a complete machine-readable copy of the corresponding source code, to be distributed under the terms of Sections 1 and 2 above on a medium customarily used for software interchange; or, c) Accompany it with the information you received as to the offer to distribute corresponding source code. (This alternative is allowed only for noncommercial distribution and only if you received the program in object code or executable form with such an offer, in accord with Subsection b above.) The source code for a work means the preferred form of the work for making modifications to it. For an executable work, complete source code means all the source code for all modules it contains, plus any associated interface definition files, plus the scripts used to control compilation and installation of the executable. However, as a special exception, the source code distributed need not include anything that is normally distributed (in either source or binary form) with the major components (compiler, kernel, and so on) of the operating system on which the executable runs, unless that component itself accompanies the executable. If distribution of executable or object code is made by offering access to copy from a designated place, then offering equivalent access to copy the source code from the same place counts as distribution of the source code, even though third parties are not compelled to copy the source along with the object code. 4. You may not copy, modify, sublicense, or distribute the Program except as expressly provided under this License. Any attempt otherwise to copy, modify, sublicense or distribute the Program is void, and will automatically terminate your rights under this License. However, parties who have received copies, or rights, from you under this License will not have their licenses terminated so long as such parties remain in full compliance. 5. You are not required to accept this License, since you have not signed it. However, nothing else grants you permission to modify or distribute the Program or its derivative works. These actions are prohibited by law if you do not accept this License. Therefore, by modifying or distributing the Program (or any work based on the Program), you indicate your acceptance of this License to do so, and all its terms and conditions for copying, distributing or modifying the Program or works based on it. 6. Each time you redistribute the Program (or any work based on the Program), the recipient automatically receives a license from the original licensor to copy, distribute or modify the Program subject to these terms and conditions. You may not impose any further restrictions on the recipients' exercise of the rights granted herein. You are not responsible for enforcing compliance by third parties to this License. 7. If, as a consequence of a court judgment or allegation of patent infringement or for any other reason (not limited to patent issues), conditions are imposed on you (whether by court order, agreement or otherwise) that contradict the conditions of this License, they do not excuse you from the conditions of this License. If you cannot distribute so as to satisfy simultaneously your obligations under this License and any other pertinent obligations, then as a consequence you may not distribute the Program at all. For example, if a patent license would not permit royalty-free redistribution of the Program by all those who receive copies directly or indirectly through you, then the only way you could satisfy both it and this License would be to refrain entirely from distribution of the Program. If any portion of this section is held invalid or unenforceable under any particular circumstance, the balance of the section is intended to apply and the section as a whole is intended to apply in other circumstances. It is not the purpose of this section to induce you to infringe any patents or other property right claims or to contest validity of any such claims; this section has the sole purpose of protecting the integrity of the free software distribution system, which is implemented by public license practices. Many people have made generous contributions to the wide range of software distributed through that system in reliance on consistent application of that system; it is up to the author/donor to decide if he or she is willing to distribute software through any other system and a licensee cannot impose that choice. This section is intended to make thoroughly clear what is believed to be a consequence of the rest of this License. 8. If the distribution and/or use of the Program is restricted in certain countries either by patents or by copyrighted interfaces, the original copyright holder who places the Program under this License may add an explicit geographical distribution limitation excluding those countries, so that distribution is permitted only in or among countries not thus excluded. In such case, this License incorporates the limitation as if written in the body of this License. 9. The Free Software Foundation may publish revised and/or new versions of the General Public License from time to time. Such new versions will be similar in spirit to the present version, but may differ in detail to address new problems or concerns. Each version is given a distinguishing version number. If the Program specifies a version number of this License which applies to it and "any later version", you have the option of following the terms and conditions either of that version or of any later version published by the Free Software Foundation. If the Program does not specify a version number of this License, you may choose any version ever published by the Free Software Foundation. 10. If you wish to incorporate parts of the Program into other free programs whose distribution conditions are different, write to the author to ask for permission. For software which is copyrighted by the Free Software Foundation, write to the Free Software Foundation; we sometimes make exceptions for this. Our decision will be guided by the two goals of preserving the free status of all derivatives of our free software and of promoting the sharing and reuse of software generally. NO WARRANTY 11. BECAUSE THE PROGRAM IS LICENSED FREE OF CHARGE, THERE IS NO WARRANTY FOR THE PROGRAM, TO THE EXTENT PERMITTED BY APPLICABLE LAW. EXCEPT WHEN OTHERWISE STATED IN WRITING THE COPYRIGHT HOLDERS AND/OR OTHER PARTIES PROVIDE THE PROGRAM "AS IS" WITHOUT WARRANTY OF ANY KIND, EITHER EXPRESSED OR IMPLIED, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE. THE ENTIRE RISK AS TO THE QUALITY AND PERFORMANCE OF THE PROGRAM IS WITH YOU. SHOULD THE PROGRAM PROVE DEFECTIVE, YOU ASSUME THE COST OF ALL NECESSARY SERVICING, REPAIR OR CORRECTION. 12. IN NO EVENT UNLESS REQUIRED BY APPLICABLE LAW OR AGREED TO IN WRITING WILL ANY COPYRIGHT HOLDER, OR ANY OTHER PARTY WHO MAY MODIFY AND/OR REDISTRIBUTE THE PROGRAM AS PERMITTED ABOVE, BE LIABLE TO YOU FOR DAMAGES, INCLUDING ANY GENERAL, SPECIAL, INCIDENTAL OR CONSEQUENTIAL DAMAGES ARISING OUT OF THE USE OR INABILITY TO USE THE PROGRAM (INCLUDING BUT NOT LIMITED TO LOSS OF DATA OR DATA BEING RENDERED INACCURATE OR LOSSES SUSTAINED BY YOU OR THIRD PARTIES OR A FAILURE OF THE PROGRAM TO OPERATE WITH ANY OTHER PROGRAMS), EVEN IF SUCH HOLDER OR OTHER PARTY HAS BEEN ADVISED OF THE POSSIBILITY OF SUCH DAMAGES. END OF TERMS AND CONDITIONS How to Apply These Terms to Your New Programs If you develop a new program, and you want it to be of the greatest possible use to the public, the best way to achieve this is to make it free software which everyone can redistribute and change under these terms. To do so, attach the following notices to the program. It is safest to attach them to the start of each source file to most effectively convey the exclusion of warranty; and each file should have at least the "copyright" line and a pointer to where the full notice is found. Copyright (C) This program is free software; you can redistribute it and/or modify it under the terms of the GNU General Public License as published by the Free Software Foundation; either version 2 of the License, or (at your option) any later version. This program is distributed in the hope that it will be useful, but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License for more details. You should have received a copy of the GNU General Public License along with this program; if not, write to the Free Software Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA Also add information on how to contact you by electronic and paper mail. If the program is interactive, make it output a short notice like this when it starts in an interactive mode: Gnomovision version 69, Copyright (C) year name of author Gnomovision comes with ABSOLUTELY NO WARRANTY; for details type `show w'. This is free software, and you are welcome to redistribute it under certain conditions; type `show c' for details. The hypothetical commands `show w' and `show c' should show the appropriate parts of the General Public License. Of course, the commands you use may be called something other than `show w' and `show c'; they could even be mouse-clicks or menu items--whatever suits your program. You should also get your employer (if you work as a programmer) or your school, if any, to sign a "copyright disclaimer" for the program, if necessary. Here is a sample; alter the names: Yoyodyne, Inc., hereby disclaims all copyright interest in the program `Gnomovision' (which makes passes at compilers) written by James Hacker. , 1 April 1989 Ty Coon, President of Vice This General Public License does not permit incorporating your program into proprietary programs. If your program is a subroutine library, you may consider it more useful to permit linking proprietary applications with the library. If this is what you want to do, use the GNU Library General Public License instead of this License. adabrowse_4.0.3/util-pathes.adb0000644000175000017500000004316510234241454014602 0ustar kenken------------------------------------------------------------------------------- -- -- Copyright © 2001, 2002 by Thomas Wolf. --
-- This piece of software is free software; you can redistribute it and/or -- modify it under the terms of the GNU General Public License as published -- by the Free Software Foundation; either version 2, or (at your option) -- any later version. This software is distributed in the hope that it will -- be useful, but without any warranty; without even the implied -- warranty of merchantability or fitness for a particular purpose. -- See the GNU General Public License for more details. You should have -- received a copy of the GNU General Public License with this distribution, -- see file "GPL.txt". If not, write to the Free -- Software Foundation, 59 Temple Place - Suite 330, Boston, MA 02111-1307, -- USA. --
--
-- As a special exception from the GPL, if other files instantiate generics -- from this unit, or you link this unit with other files to produce an -- executable, this unit does not by itself cause the resulting executable -- to be covered by the GPL. This exception does not however invalidate any -- other reasons why the executable file might be covered by the GPL. --
-- -- -- Thomas Wolf (TW) -- -- -- -- Operations for manipulating file names. The package is intended for -- use on Windows or Unix systems. Upon elaboration, it tries to figure -- out the host operating system by examining the @PATH@ environment -- variable: if that contains Windows-looking pathes (i.e., a '\' is found -- before a any '/'), it assumes it's being used on Windows. If, on the -- other hand, it finds a '/' first, it assumes Unix. If it finds neither, -- it uses @GNAT.Os_Lib.Directory_Separator@ as its directory separator. -- (If you intend to use this package on a non-GNAT system, you'll have -- to change the body of this package as appropriate.) -- -- All operations in this package are pur string manipulation operations. -- There are no file system operations involved. -- -- -- -- -- -- -- -- 19-MAR-2002 TW Initial version. -- 03-MAY-2002 TW Added 'Drive' and 'Node'; various minor corrections. -- ------------------------------------------------------------------------------- pragma License (Modified_GPL); with Util.Environment; with Util.Strings; with GNAT.OS_Lib; pragma Elaborate_All (Util.Environment); pragma Elaborate_All (Util.Strings); package body Util.Pathes is -- Syntax: -- -- Windows: -- [(\\Node\{\}|Drive_Letter:{\})]{Name\{\}}[Base_Name][.Extension] -- where Name . and .. have special meanings. -- -- Unix: -- [/{/}]{Name/{/}][Base_Name][.Extension] -- where Name . and .. have special meanings. -- -- VMS: -- [Disk:]["["[Name]{.Dir_Name}"]"][Base_Name][.Extension][;Version] -- where Dir_Name . and "" have special meaning -- -- Mac: -- Not sure. I think it went like this: -- {Name:}[Base_Name][.Extension] -- where Name : has a special meaning. -- -- VMS and Mac are not done yet! use Util.Strings; ---------------------------------------------------------------------------- -- Internal operations: function Determine_Host_Separator return Character is Path : constant String := Util.Environment.Safe_Get ("PATH"); I : Natural := First_Index (Path, '\'); J : Natural := First_Index (Path, '/'); begin if I = 0 then I := Natural'Last; end if; if J = 0 then J := Natural'Last; end if; if I < J then return '\'; elsif J < I then return '/'; else return GNAT.OS_Lib.Directory_Separator; end if; end Determine_Host_Separator; Dir_Sep : constant Character := Determine_Host_Separator; function Node_End (Full_Name : in String; Separator : in Character) return Natural is begin -- Needs revision for VMS! if (Separator = '\' or else Separator = '/') and then Full_Name'Last > Full_Name'First + 1 and then Full_Name (Full_Name'First) = Separator and then Full_Name (Full_Name'First + 1) = Separator then declare I : constant Natural := First_Index (Full_Name (Full_Name'First + 2 .. Full_Name'Last), Separator); begin if I = 0 then return Full_Name'Last; else return I; end if; end; end if; return 0; end Node_End; function Drive_End (Full_Name : in String; Separator : in Character) return Natural is I : Natural := Node_End (Full_Name, Separator); begin if I = 0 then I := Full_Name'First; else if Full_Name (I) /= Separator then -- Only a node name! return 0; end if; I := I + 1; end if; if Separator = '\' and then I + 1 <= Full_Name'Last and then Is_In (Letters, Full_Name (I)) and then Full_Name (I + 1) = ':' then return I + 1; end if; -- Needs revision for VMS! return 0; end Drive_End; function Path_End (Full_Name : in String; Separator : in Character) return Natural is I : constant Natural := Node_End (Full_Name, Separator); begin if I > 0 and then Full_Name (I) /= Separator then return I; end if; return Natural'Max (Last_Index (Full_Name, Separator), Drive_End (Full_Name, Separator)); end Path_End; ---------------------------------------------------------------------------- function Directory_Separator return Character is begin return Dir_Sep; end Directory_Separator; function Extension (Full_Name : in String; Separator : in Character := Util.Pathes.Directory_Separator) return String is I : Natural := Path_End (Full_Name, Separator); J : Natural; begin if I = 0 then I := Full_Name'First; else I := I + 1; end if; J := Last_Index (Full_Name (I .. Full_Name'Last), '.'); if J <= I then return ""; else return Full_Name (J + 1 .. Full_Name'Last); end if; end Extension; function Name (Full_Name : in String; Separator : in Character := Directory_Separator) return String is I : constant Natural := Path_End (Full_Name, Separator); begin if I = 0 then return Full_Name; end if; return Full_Name (I + 1 .. Full_Name'Last); end Name; function Base_Name (Full_Name : in String; Separator : in Character := Directory_Separator) return String is I : Natural := Path_End (Full_Name, Separator); J : Natural; begin if I = 0 then I := Full_Name'First; else I := I + 1; end if; J := Last_Index (Full_Name (I .. Full_Name'Last), '.'); if J <= I then -- Also handles cases like ".cshrc". return Full_Name (I .. Full_Name'Last); else return Full_Name (I .. J - 1); end if; end Base_Name; function Path (Full_Name : in String; Separator : in Character := Directory_Separator) return String is I : constant Natural := Path_End (Full_Name, Separator); begin if I = 0 then return ""; end if; return Full_Name (Full_Name'First .. I); end Path; function Drive (Full_Name : in String; Separator : in Character := Directory_Separator) return String is I : Natural := Node_End (Full_Name, Separator); begin if I = 0 then I := Full_Name'First; else I := I + 1; end if; return Full_Name (I .. Drive_End (Full_Name (I .. Full_Name'Last), Separator)); end Drive; function Has_Drive (Full_Name : in String; Separator : in Character := Directory_Separator) return Boolean is I : Natural := Node_End (Full_Name, Separator); begin if I = 0 then I := Full_Name'First; else I := I + 1; end if; return Drive_End (Full_Name (I .. Full_Name'Last), Separator) > 0; end Has_Drive; function Node (Full_Name : in String; Separator : in Character := Directory_Separator) return String is begin return Full_Name (Full_Name'First .. Node_End (Full_Name, Separator)); end Node; function Has_Node (Full_Name : in String; Separator : in Character := Directory_Separator) return Boolean is begin return Node_End (Full_Name, Separator) > 0; end Has_Node; function Normalize (Path : in String; Separator : in Character := Directory_Separator) return String is begin if Path'Last < Path'First then return '.' & Separator; end if; if Drive_End (Path, Separator) = Path'Last then return Path; elsif Path (Path'Last) = Separator then return Path; else return Path & Separator; end if; end Normalize; function Parent (Path : in String; Separator : in Character := Directory_Separator) return String is function Up (Path : in String; Separator : in Character) return String is -- 'Path' is a cleaned-up path! I : Natural; begin if Path'Last = Path'First and then Path (Path'First) = Separator then raise Path_Error; -- Root in an absolute path elsif Path = '.' & Separator then return ".." & Separator; end if; I := Last_Index (Path (Path'First .. Path'Last - 1), Separator); if I = 0 then -- "something/", return "./" if Path (Path'First .. Path'Last - 1) = ".." then -- Oops, we already had "../": return "../../". return Path & Path; elsif Path (Path'First .. Path'Last - 1) = "." then -- We had "./", return "./../". return Path & ".." & Separator; else return '.' & Separator; end if; else if Path (I + 1 .. Path'Last - 1) = ".." then -- We have only a sequence of "../": add one more. return Path & ".." & Separator; else return Path (Path'First .. I); end if; end if; end Up; P : constant String := Clean (Path, Separator); I, J : Natural; begin I := Node_End (P, Separator); if I = 0 then I := P'First; else I := I + 1; end if; J := Drive_End (P (I .. P'Last), Separator); if J > 0 then if J = P'Last then return P & ".." & Separator; else return P (P'First .. J) & Up (P (J + 1 .. P'Last), Separator); end if; elsif I > 0 then if P (I) = Separator then return P (P'First .. I - 1) & Up (P (I .. P'Last), Separator); else -- Only a node name: cannot get the parent, for relative pathes -- are not allowed. raise Path_Error; end if; end if; -- Neither node name nor drive: return Up (P, Separator); end Parent; function Clean (Full_Name : in String; Separator : in Character := Directory_Separator) return String is function Clean_It (Path : in String; Separator : in Character) return String is Result : String (1 .. Path'Length + 1); K : Natural; begin K := Result'First; for I in Path'Range loop Result (K) := Path (I); if Path (I) = Separator then if K > Result'First + 2 and then Result (K - 1) = '.' and then Result (K - 2) = '.' and then Result (K - 3) = Separator then if K = Result'First + 3 then -- A path cannot start with "/../"! raise Path_Error; end if; declare J : constant Natural := Last_Index (Result (Result'First .. K - 4), Separator); begin if J > 0 then if Result (J + 1 .. K - 4) = ".." then -- We have "../../../", which is legal and can -- occur only at the beginning! null; else K := J; end if; else if K - 4 = Result'First and then Result (Result'First) = '.' then -- We have "./../", which should become "../". Result (Result'First + 1) := '.'; Result (Result'First + 2) := Separator; K := Result'First + 2; elsif Result (Result'First .. K - 4) = ".." then -- We have "../../" at the beginning! null; else -- We have "something/../", which should -- become "./". Result (Result'First) := '.'; Result (Result'First + 1) := Separator; K := Result'First + 1; end if; end if; end; elsif K > Result'First + 1 and then Result (K - 1) = '.' and then Result (K - 2) = Separator then K := K - 2; elsif K > Result'First and then Result (K - 1) = Separator then -- Eliminate extraneous separators. K := K - 1; end if; end if; K := K + 1; end loop; K := K - 1; if K >= Result'First and then Result (K) /= Separator then K := K + 1; Result (K) := Separator; end if; return Result (Result'First .. K); end Clean_It; I, J : Natural; begin I := Node_End (Full_Name, Separator); if I > 0 then if Full_Name (I) /= Separator then -- Only a node name, without terminating separator: return Full_Name & Separator; end if; -- Skip multiple separators: J := I + 1; while J <= Full_Name'Last and then Full_Name (J) = Separator loop J := J + 1; end loop; if J > I + 1 then return Clean (Full_Name (Full_Name'First .. I) & Full_Name (J .. Full_Name'Last)); end if; end if; J := Drive_End (Full_Name, Separator); if J > 0 then return Full_Name (Full_Name'First .. J) & Clean_It (Full_Name (J + 1 .. Full_Name'Last), Separator); end if; if I > 0 then return Full_Name (Full_Name'First .. I - 1) & Clean_It (Full_Name (I .. Full_Name'Last), Separator); end if; return Clean_It (Full_Name, Separator); end Clean; function Is_Absolute_Path (Name : in String; Separator : in Character := Directory_Separator) return Boolean is begin if Name'Last < Name'First then return False; end if; if Separator = ':' then -- Mac? It's been a while, but if I remember correctly, it went -- like this: return Name (Name'First) /= ':'; else -- Not Mac, i.e. Windows or Unix. if Name (Name'First) = Separator then return True; end if; if Drive_End (Name, Separator) > 0 then return True; end if; end if; return False; end Is_Absolute_Path; function Concat (Path : in String; File_Name : in String; Separator : in Character := Directory_Separator) return String is begin if Path'Last < Path'First then return File_Name; end if; if File_Name'Last < File_Name'First then return Path; end if; if Is_Absolute_Path (File_Name, Separator) then raise Path_Error; end if; return Normalize (Path, Separator) & File_Name; end Concat; function Replace_File_Name (Full_Name : in String; File_Name : in String; Separator : in Character := Directory_Separator) return String is begin return Concat (Path (Full_Name, Separator), File_Name, Separator); end Replace_File_Name; function Replace_Extension (Full_Name : in String; Extension : in String; Separator : in Character := Directory_Separator) return String is J : Natural := Path_End (Full_Name, Separator); begin if Full_Name'Last < Full_Name'First or else J = Full_Name'Last then raise Path_Error; end if; declare I : constant Natural := Last_Index (Full_Name, '.'); begin if J = 0 then J := Full_Name'First; else J := J + 1; end if; if I <= J then return Full_Name & '.' & Extension; else return Full_Name (Full_Name'First .. I) & Extension; end if; end; end Replace_Extension; end Util.Pathes; adabrowse_4.0.3/gal-containers-hash_tables.adb0000644000175000017500000002601710234241452017517 0ustar kenken------------------------------------------------------------------------------- -- -- Copyright (c) 2001, 2002 by Thomas Wolf. --
-- This piece of software is free software; you can redistribute it and/or -- modify it under the terms of the GNU General Public License as published -- by the Free Software Foundation; either version 2, or (at your option) -- any later version. This unit is distributed in the hope that it will be -- useful, but without any warranty; without even the implied -- warranty of merchantability or fitness for a particular purpose. -- See the GNU General Public License for more details. You should have -- received a copy of the GNU General Public License with this distribution, -- see file "GPL.txt". If not, write to the Free -- Software Foundation, 59 Temple Place - Suite 330, Boston, MA 02111-1307, -- USA. --
--
-- As a special exception from the GPL, if other files instantiate generics -- from this unit, or you link this unit with other files to produce an -- executable, this unit does not by itself cause the resulting executable -- to be covered by the GPL. This exception does not however invalidate any -- other reasons why the executable file might be covered by the GPL. --
-- --
-- Author:
-- Thomas Wolf (TW) --
twolf@acm.org
-- --
-- Purpose:
-- Provides dynamic hash tables. Internal collision resolution, automatic -- and explicit resizing. Collision chain index computation can be customized -- though Collision_Policies. Resizing can be controlled through -- load factors and Growth_Policies. --

-- This hash table does not allow associating additional data with the -- items stored. However, only a portion of type @Item@ might be the actual -- key, while additional components might hold associated data. In this -- case, both @Hash@ and "=" must work only on the key part -- of @Item@. --

-- Note that this hash table does not allow in-place modification of the -- items stored since this might result in violations of the internal -- consistency of the hash table. --

-- A slightly more powerful (but also slightly more complex to instantiate) -- hash table package taking separate @Key@ and @Item@ types and allowing -- in-place modifications of the items (but not the keys) is available in -- package GAL.ADT.Hash_Tables. --
-- --
-- Tasking semantics:
-- N/A. Not abortion-safe.
-- --
-- Storage semantics:
-- Dynamic storage allocation in a user-supplied storage pool.
-- -- ------------------------------------------------------------------------------- pragma License (Modified_GPL); -- generic -- type Item (<>) is private; -- -- with package Memory is new GAL.Storage.Memory (<>); -- -- Initial_Size : in GAL.Support.Hashing.Size_Type := 23; -- -- with function Hash (Element : in Item) return Hash_Type is <>; -- with function "=" (Left, Right : in Item) return Boolean is <>; -- -- with function Choose_Size -- (Suggested : in GAL.Support.Hashing.Hash_Type) -- return GAL.Support.Hashing.Hash_Type -- is GAL.Support.Hashing.Next_Prime; -- -- This function is called whenever the size of the hash table is to be -- -- defined. 'Suggested' is the suggested size of the new table; the -- -- function should then return a size that is >= Suggested. If it -- -- returns a smaller value anyway, the exception 'Container_Error' is -- -- raised. package body GAL.Containers.Hash_Tables is use GAL.Support; ---------------------------------------------------------------------------- procedure Insert (Table : in out Hash_Table; Element : in Item) is begin Impl.Insert (Table.Rep, Element, Null_Object); end Insert; procedure Insert (Table : in out Hash_Table; Element : access Item) is begin Impl.Insert (Table.Rep, Element.all, Null_Object); end Insert; ---------------------------------------------------------------------------- procedure Replace (Table : in out Hash_Table; Element : in Item) is begin Impl.Replace (Table.Rep, Element, Null_Object); end Replace; procedure Replace (Table : in out Hash_Table; Element : access Item) is begin Impl.Replace (Table.Rep, Element.all, Null_Object); end Replace; ---------------------------------------------------------------------------- procedure Delete (Table : in out Hash_Table; Element : in Item) is begin Impl.Delete (Table.Rep, Element); end Delete; procedure Delete (Table : in out Hash_Table; Element : access Item) is begin Impl.Delete (Table.Rep, Element.all); end Delete; ---------------------------------------------------------------------------- function Contains (Table : in Hash_Table; Element : in Item) return Boolean is begin return Impl.Contains (Table.Rep, Element); end Contains; function Contains (Table : in Hash_Table; Element : access Item) return Boolean is begin return Impl.Contains (Table.Rep, Element.all); end Contains; ---------------------------------------------------------------------------- function Nof_Elements (Table : in Hash_Table) return GAL.Support.Hashing.Hash_Type is begin return Impl.Nof_Elements (Table.Rep); end Nof_Elements; function Is_Empty (Table : in Hash_Table) return Boolean is begin return Impl.Is_Empty (Table.Rep); end Is_Empty; function Load (Table : in Hash_Table) return GAL.Support.Hashing.Load_Factor is begin return Impl.Load (Table.Rep); end Load; function Size (Table : in Hash_Table) return GAL.Support.Hashing.Hash_Type is begin return Impl.Size (Table.Rep); end Size; ---------------------------------------------------------------------------- procedure Swap (Left, Right : in out Hash_Table) is begin Impl.Swap (Left.Rep, Right.Rep); end Swap; ---------------------------------------------------------------------------- procedure Resize (Table : in out Hash_Table; New_Size : in GAL.Support.Hashing.Size_Type) is begin Impl.Resize (Table.Rep, New_Size); end Resize; ---------------------------------------------------------------------------- procedure Reset (Table : in out Hash_Table) is begin Impl.Reset (Table.Rep); end Reset; procedure Reset (Table : in out Hash_Table; New_Size : in GAL.Support.Hashing.Size_Type) is begin Impl.Reset (Table.Rep, New_Size); end Reset; procedure Reset (Table : in out Hash_Table; New_Size : in GAL.Support.Hashing.Size_Type; Resize_At : in GAL.Support.Hashing.Load_Factor) is begin Impl.Reset (Table.Rep, New_Size, Resize_At); end Reset; ---------------------------------------------------------------------------- procedure Merge (Result : in out Hash_Table; Source : in Hash_Table) is begin Impl.Merge (Result.Rep, Source.Rep); end Merge; procedure Merge (Result : in out Hash_Table; Source : in Hash_Table; Overwrite : in Boolean) is begin Impl.Merge (Result.Rep, Source.Rep, Overwrite); end Merge; ---------------------------------------------------------------------------- -- Collision policies: procedure Set_Collision_Policy (Table : in out Hash_Table; Policy : in GAL.Support.Hashing.Collision_Policy'Class) is begin Impl.Set_Collision_Policy (Table.Rep, Policy); end Set_Collision_Policy; procedure Remove_Collision_Policy (Table : in out Hash_Table) is begin Impl.Remove_Collision_Policy (Table.Rep); end Remove_Collision_Policy; function Get_Collision_Policy (Table : in Hash_Table) return GAL.Support.Hashing.Collision_Policy'Class is begin return Impl.Get_Collision_Policy (Table.Rep); end Get_Collision_Policy; ---------------------------------------------------------------------------- -- Growth management: procedure Set_Resize (Table : in out Hash_Table; Resize_At : in GAL.Support.Hashing.Load_Factor) is begin Impl.Set_Resize (Table.Rep, Resize_At); end Set_Resize; procedure Set_Growth_Policy (Table : in out Hash_Table; Policy : in GAL.Support.Hashing.Growth_Policy'Class) is begin Impl.Set_Growth_Policy (Table.Rep, Policy); end Set_Growth_Policy; procedure Remove_Growth_Policy (Table : in out Hash_Table) is begin Impl.Remove_Growth_Policy (Table.Rep); end Remove_Growth_Policy; function Has_Growth_Policy (Table : in Hash_Table) return Boolean is begin return Impl.Has_Growth_Policy (Table.Rep); end Has_Growth_Policy; function Get_Growth_Policy (Table : in Hash_Table) return GAL.Support.Hashing.Growth_Policy'Class is begin return Impl.Get_Growth_Policy (Table.Rep); end Get_Growth_Policy; ---------------------------------------------------------------------------- -- Traversals: procedure Action (V : in out Visitor; Key : in Item; Value : in out GAL.Support.Null_Type; Quit : in out Boolean) is pragma Warnings (Off, Value); -- silence -gnatwa begin Execute (Visitor'Class (V), Key, Quit); end Action; procedure Traverse (Table : in Hash_Table; V : in out Visitor'Class) is begin Impl.Traverse (Table.Rep, V, False); end Traverse; -- generic -- with procedure Execute -- (Value : in Item; -- Quit : in out Boolean); procedure Traverse_G (Table : in Hash_Table) is procedure Exec (Key : in Item; Value : in out GAL.Support.Null_Type; Quit : in out Boolean) is pragma Warnings (Off, Value); -- silence -gnatwa begin Execute (Key, Quit); end Exec; procedure Trav is new Impl.Traverse_G (Exec); begin Trav (Table.Rep); end Traverse_G; ---------------------------------------------------------------------------- -- Comparisons: function "=" (Left, Right : in Hash_Table) return Boolean is begin return Impl."=" (Left.Rep, Right.Rep); end "="; end GAL.Containers.Hash_Tables; adabrowse_4.0.3/gal-support.adb0000644000175000017500000000447210234241453014615 0ustar kenken------------------------------------------------------------------------------- -- -- Copyright (c) 2001, 2002 by Thomas Wolf. --
-- AdaBrowse is free software; you can redistribute it and/or modify it -- under the terms of the GNU General Public License as published by the -- Free Software Foundation; either version 2, or (at your option) any -- later version. AdaBrowse is distributed in the hope that it will be -- useful, but without any warranty; without even the implied -- warranty of merchantability or fitness for a particular purpose. -- See the GNU General Public License for more details. You should have -- received a copy of the GNU General Public License with this distribution, -- see file "GPL.txt". If not, write to the Free -- Software Foundation, 59 Temple Place - Suite 330, Boston, MA 02111-1307, -- USA. --
--
-- As a special exception from the GPL, if other files instantiate generics -- from this unit, or you link this unit with other files to produce an -- executable, this unit does not by itself cause the resulting executable -- to be covered by the GPL. This exception does not however invalidate any -- other reasons why the executable file might be covered by the GPL. --
-- --
-- Author:
-- Thomas Wolf (TW) --
twolf@acm.org
-- --
-- Purpose:
-- Root package for the support subsystem, which contains many generally -- useful operations. Most of them are generic to be as widely applicable -- as possible.
-- --
-- Tasking semantics:
-- N/A. Not abortion-safe.
-- --
-- Storage semantics:
-- No dynamic storage allocation.
-- -- ------------------------------------------------------------------------------- pragma License (Modified_GPL); package body GAL.Support is -- generic -- type Item is private; procedure Swap (Left, Right : in out Item) is Tmp : constant Item := Left; begin Left := Right; Right := Tmp; end Swap; end GAL.Support; adabrowse_4.0.3/asis2-spans.adb0000644000175000017500000005113410234241452014477 0ustar kenken------------------------------------------------------------------------------- -- -- This unit is part of the @Asis2@ ASIS secondary library. -- -- Copyright (c) 2002, 2003 by Thomas Wolf. --
-- AdaBrowse is free software; you can redistribute it and/or modify it -- under the terms of the GNU General Public License as published by the -- Free Software Foundation; either version 2, or (at your option) any -- later version. AdaBrowse is distributed in the hope that it will be -- useful, but without any warranty; without even the implied -- warranty of merchantability or fitness for a particular purpose. -- See the GNU General Public License for more details. You should have -- received a copy of the GNU General Public License with this distribution, -- see file "GPL.txt". If not, write to the Free -- Software Foundation, 59 Temple Place - Suite 330, Boston, MA 02111-1307, -- USA. --
--
-- As a special exception from the GPL, if other files instantiate generics -- from this unit, or you link this unit with other files to produce an -- executable, this unit does not by itself cause the resulting executable -- to be covered by the GPL. This exception does not however invalidate any -- other reasons why the executable file might be covered by the GPL. --
-- -- -- Thomas Wolf (TW) -- -- -- -- Utility routines working on text spans. -- -- -- -- 02-FEB-2002 TW First release as part of @AdaBrowse@. -- 20-MAR-2002 TW Added @Get_Span@. -- 24-APR-2002 TW Changed 'Find_Comment' and 'Expand_Comment' such that -- they catch trailing comments, too. -- 18-JUL-2003 TW Renamed from @AD.Spans@ to @Asis2.Spans@, changed the -- license, renamed @Get@ to @Find@, added the @As_Word@ -- and @In_Comment_Too@ parameters to @Find@ and -- @Through@, and added extensive comments, and removed -- (and re- implemented) things formerly imported from -- my @Util@ or @GAL@ subsystems because I wanted to keep -- the @Asis2@ independent of those other libraries, and -- also because I need to properly handle @Wide_String@s -- here. -- ------------------------------------------------------------------------------- pragma License (Modified_GPL); with Ada.Strings.Wide_Fixed; with Ada.Strings.Wide_Maps.Wide_Constants; with Asis.Compilation_Units; with Asis.Elements; with Asis.Exceptions; with Asis.Text; with Asis2.Text; package body Asis2.Spans is package ASF renames Ada.Strings.Wide_Fixed; package ASM renames Ada.Strings.Wide_Maps; package ASC renames Ada.Strings.Wide_Maps.Wide_Constants; use Asis2.Text; ---------------------------------------------------------------------------- function Is_Nil (Pos : in Position) return Boolean is begin return Pos = Nil_Position; end Is_Nil; ---------------------------------------------------------------------------- function "<" (Left, Right : in Position) return Boolean is use Asis.Text; begin if Left.Line = Right.Line then return Left.Column < Right.Column; else return Left.Line < Right.Line; end if; end "<"; function "<=" (Left, Right : in Position) return Boolean is begin return not (Right < Left); end "<="; function ">" (Left, Right : in Position) return Boolean is begin return Right < Left; end ">"; function ">=" (Left, Right : in Position) return Boolean is begin return not (Left < Right); end ">="; ---------------------------------------------------------------------------- function Start (Span : in Asis.Text.Span) return Position is begin if Asis.Text.Is_Nil (Span) then return Nil_Position; else return Position'(Span.First_Line, Span.First_Column); end if; end Start; function Stop (Span : in Asis.Text.Span) return Position is begin if Asis.Text.Is_Nil (Span) then return Nil_Position; else return Position'(Span.Last_Line, Span.Last_Column); end if; end Stop; ---------------------------------------------------------------------------- procedure Set_Start (Span : in out Asis.Text.Span; Pos : in Position) is begin if Pos = Nil_Position then Span.First_Line := 1; Span.First_Column := 1; else Span.First_Line := Pos.Line; Span.First_Column := Pos.Column; end if; end Set_Start; procedure Set_Stop (Span : in out Asis.Text.Span; Pos : in Position) is begin Span.Last_Line := Pos.Line; Span.Last_Column := Pos.Column; end Set_Stop; ---------------------------------------------------------------------------- function Get_Checked_Span (Element : in Asis.Element) return Asis.Text.Span is begin return Asis.Text.Element_Span (Element); exception when Asis.Exceptions.ASIS_Failed => return Asis.Text.Nil_Span; end Get_Checked_Span; ---------------------------------------------------------------------------- procedure Search (Element : in Asis.Element; Span : in out Asis.Text.Span; Pattern : in Wide_String; Direction : in Ada.Strings.Direction := Ada.Strings.Forward; From : in Position := Nil_Position; Words_Only : in Boolean := True; Comments_Too : in Boolean := False) is use type Ada.Strings.Direction; function Is_Word (Source : in Wide_String; Start, Stop : in Natural) return Boolean; pragma Inline (Is_Word); function Is_Word (Source : in Wide_String; Start, Stop : in Natural) return Boolean is Dash : constant Wide_Character := '_'; begin if not Words_Only then return True; end if; declare Blank_Left : constant Boolean := Start <= Source'First or else (Source (Start - 1) /= Dash and then not ASM.Is_In (Source (Start - 1), ASC.Alphanumeric_Set)); Blank_Right : constant Boolean := Stop >= Source'Last or else (Source (Stop + 1) /= Dash and then not ASM.Is_In (Source (Stop + 1), ASC.Alphanumeric_Set)); begin return Blank_Left and Blank_Right; end; end Is_Word; function Find_Forward (Source : in Wide_String; Pattern : in Wide_String) return Natural is I : Natural := 0; J : Natural := Source'First; Length : constant Natural := Pattern'Length; begin while J + Length - 1 <= Source'Last loop I := ASF.Index (Source (J .. Source'Last), Pattern); exit when I = 0 or else Is_Word (Source (J .. Source'Last), I, I + Length - 1); I := 0; J := J + Length + 1; end loop; return I; end Find_Forward; function Find_Backward (Source : in Wide_String; Pattern : in Wide_String) return Natural is I : Natural := 0; J : Integer := Source'Last; Length : constant Natural := Pattern'Length; begin while J >= Source'First + Length - 1 loop I := ASF.Index (Source (Source'First .. J), Pattern, Ada.Strings.Backward); exit when I = 0 or else Is_Word (Source (Source'First .. J), I, I + Length - 1); I := 0; J := J - Length - 1; end loop; return I; end Find_Backward; function Get_Line (Line : in Asis.Text.Line) return Wide_String is begin if Comments_Too then return Asis.Text.Line_Image (Line); else return Asis.Text.Non_Comment_Image (Line); end if; end Get_Line; begin if Pattern'Last < Pattern'First or else Asis.Text.Is_Nil (Span) then Span := Asis.Text.Nil_Span; return; end if; if From /= Nil_Position then if Direction = Ada.Strings.Forward then Set_Start (Span, From); else Set_Stop (Span, From); end if; end if; declare Lines : constant Asis.Text.Line_List := Asis.Text.Lines (Element, Span); Col : Asis.Text.Character_Position; Line : Asis.Text.Line_Number := Span.First_Line; Pat : constant Wide_String := To_Lower (Pattern); begin if Direction = Ada.Strings.Forward then for I in Lines'Range loop Col := Find_Forward (To_Lower (Get_Line (Lines (I))), Pat); if Col > 0 then Line := I; exit; end if; end loop; else for I in reverse Lines'Range loop Col := Find_Backward (To_Lower (Get_Line (Lines (I))), Pat); if Col > 0 then Line := I; exit; end if; end loop; end if; if Col > 0 then Span := Asis.Text.Span'(First_Line => Line, First_Column => Col, Last_Line => Line, Last_Column => Col + Pattern'Length - 1); else Span := Asis.Text.Nil_Span; end if; end; end Search; ---------------------------------------------------------------------------- function Get_Span (Element : in Asis.Element) return Asis.Text.Span is Result : Asis.Text.Span := Get_Checked_Span (Element); begin if not Asis.Text.Is_Nil (Result) then -- Now expand the span to encompass the "private" of private library -- unit declarations! (Yes, I know that this is not quite correct -- in terms of the Ada syntax. But it is useful, because it allows -- me to treat private library unit declarations just like public -- ones. In fact, I think that's the way it should be, even in ASIS.) declare use Asis.Compilation_Units; use Asis.Elements; use Asis; Unit : constant Asis.Compilation_Unit := Enclosing_Compilation_Unit (Element); begin if Is_Equal (Element, Unit_Declaration (Unit)) then if Unit_Class (Unit) = A_Private_Declaration then declare Span : Asis.Text.Span := Result; -- ASIS-for-GNAT-3.16a (and probably 3.15p, too!) has a -- bug here; the "private" isn't included either! Hence -- we use the unit declaration's span and set the start -- to (1, 1)! Reported as C530-002. Clauses : constant Asis.Context_Clause_List := Context_Clause_Elements (Unit, True); begin Set_Start (Span, Position'(1, 1)); -- Restrict the span such that we only search up to the -- end of the context clauses. if Clauses'Length > 0 then declare Stop_At : constant Asis.Text.Span := Get_Checked_Span (Clauses (Clauses'Last)); begin if not Asis.Text.Is_Nil (Stop_At) then Set_Start (Span, Stop (Stop_At)); end if; end; end if; Search (Element, Span, "private", Ada.Strings.Backward, Start (Result)); if not Asis.Text.Is_Nil (Span) then Set_Start (Result, Start (Span)); end if; end; end if; -- private? else -- Ok, it's not a unit declaration. Now there is another -- problem with private types with discriminants. ASIS-for-GNAT -- 3.16a only searches up to the next semicolon to determine -- the end of the span, but one needs to search to the first -- semicolon following the keyword "private"! -- This corrects bug C602-001 in ASIS-for-GNAT 3.16a. if Declaration_Kind (Element) = A_Private_Type_Declaration then declare Span : Asis.Text.Span := Result; Stop_At : constant Asis.Text.Span := Get_Span (Enclosing_Element (Element)); begin Set_Stop (Span, Stop (Stop_At)); Search (Element, Span, "private", Ada.Strings.Forward, Start (Span)); if not Asis.Text.Is_Nil (Span) then declare From : constant Position := Stop (Span); begin Set_Stop (Span, Stop (Stop_At)); Search (Element, Span, ";", Ada.Strings.Forward, From, False); if not Asis.Text.Is_Nil (Span) then Set_Stop (Result, Stop (Span)); end if; end; end if; end; elsif Definition_Kind (Element) = A_Private_Type_Definition then -- Set the span to the span of the "private" keyword. First -- get the *declaration's* span using a recursive call: declare Span : Asis.Text.Span := Get_Span (Enclosing_Element (Element)); begin Search (Element, Span, "private", Ada.Strings.Backward, Stop (Span)); if not Asis.Text.Is_Nil (Span) then Result := Span; end if; end; end if; end if; end; end if; return Result; end Get_Span; ---------------------------------------------------------------------------- function Find (Element : in Asis.Element; Pattern : in Wide_String; Direction : in Ada.Strings.Direction := Ada.Strings.Forward; From : in Position := Nil_Position; As_Word : in Boolean := True; In_Comments_Too : in Boolean := False) return Asis.Text.Span is Result : Asis.Text.Span := Get_Span (Element); begin Search (Element, Result, Pattern, Direction, From, As_Word, In_Comments_Too); return Result; end Find; function Through (Element : in Asis.Element; Pattern : in Wide_String; Direction : in Ada.Strings.Direction := Ada.Strings.Forward; From : in Position := Nil_Position; As_Word : in Boolean := True; In_Comments_Too : in Boolean := False) return Asis.Text.Span is Found_At : Asis.Text.Span := Find (Element, Pattern, Direction, From, As_Word, In_Comments_Too); use type Ada.Strings.Direction; begin if not Asis.Text.Is_Nil (Found_At) then if Direction = Ada.Strings.Forward then Set_Start (Found_At, Start (Get_Span (Element))); else Set_Stop (Found_At, Stop (Get_Span (Element))); end if; end if; return Found_At; end Through; ---------------------------------------------------------------------------- function Find_Comment (Element : in Asis.Element; From : in Asis.Text.Line_Number_Positive; Direction : in Ada.Strings.Direction := Ada.Strings.Forward) return Position is use Asis.Text; use type Ada.Strings.Direction; Result : Position := Nil_Position; Check_Line : Asis.Text.Line_Number := From; begin if Direction = Ada.Strings.Backward then while Check_Line > 1 loop Check_Line := Check_Line - 1; declare Lines : constant Line_List := Asis.Text.Lines (Element, Check_Line, Check_Line); begin if not Is_Nil (Lines (Lines'First)) then exit when Trim (Non_Comment_Image (Lines (Lines'First)))'Length > 0; if Trim (Comment_Image (Lines (Lines'First)))'Length > 0 then -- We do have a comment on that line! Result := (Check_Line, Length (Lines (Lines'First))); exit; end if; end if; end; end loop; else declare Maximum : constant Position := Stop (Compilation_Span (Element)); First : constant Line_Number := Check_Line; begin while Check_Line < Maximum.Line loop declare Lines : constant Line_List := Asis.Text.Lines (Element, Check_Line, Check_Line); begin if not Is_Nil (Lines (Lines'First)) then exit when Check_Line > First and then Trim (Non_Comment_Image (Lines (Lines'First)))'Length > 0; if Trim (Comment_Image (Lines (Lines'First)))'Length > 0 then -- We do have a comment on that line! Result := (Check_Line, 1); exit; end if; end if; end; Check_Line := Check_Line + 1; end loop; end; end if; return Result; end Find_Comment; ---------------------------------------------------------------------------- function Expand_Comment (Element : in Asis.Element; From : in Position; Direction : in Ada.Strings.Direction := Ada.Strings.Forward) return Position is use Asis.Text; use type Ada.Strings.Direction; Result : Position; Check : Position := From; begin if Is_Nil (Check) then raise Program_Error; end if; if Direction = Ada.Strings.Backward then Result := (Check.Line, 1); while Check.Line > 1 loop Check.Line := Check.Line - 1; declare Lines : constant Line_List := Asis.Text.Lines (Element, Check.Line, Check.Line); begin exit when Is_Nil (Lines (Lines'First)) or else Trim (Non_Comment_Image (Lines (Lines'First)))'Length > 0 or else Trim (Comment_Image (Lines (Lines'First)))'Length = 0; end; Result.Line := Check.Line; end loop; else declare Maximum : constant Position := Stop (Compilation_Span (Element)); First : constant Line_Number := Check.Line; begin Result := Nil_Position; while Check.Line <= Maximum.Line loop declare Lines : constant Line_List := Asis.Text.Lines (Element, Check.Line, Check.Line); begin exit when Is_Nil (Lines (Lines'First)) or else (Check.Line > First and then Trim (Non_Comment_Image (Lines (Lines'First)))'Length > 0); exit when Trim (Comment_Image (Lines (Lines'First)))'Length = 0; Result := (Check.Line, Length (Lines (Lines'First))); end; Check.Line := Check.Line + 1; end loop; end; end if; return Result; end Expand_Comment; end Asis2.Spans; adabrowse_4.0.3/ad-descriptions.adb0000644000175000017500000006046310234241447015435 0ustar kenken------------------------------------------------------------------------------- -- -- This file is part of AdaBrowse. -- -- Copyright (c) 2002 by Thomas Wolf. --
-- AdaBrowse is free software; you can redistribute it and/or modify it -- under the terms of the GNU General Public License as published by the -- Free Software Foundation; either version 2, or (at your option) any -- later version. AdaBrowse is distributed in the hope that it will be -- useful, but without any warranty; without even the implied -- warranty of merchantability or fitness for a particular purpose. -- See the GNU General Public License for more details. You should have -- received a copy of the GNU General Public License with this distribution, -- see file "GPL.txt". If not, write to the Free -- Software Foundation, 59 Temple Place - Suite 330, Boston, MA 02111-1307, -- USA. --
-- --
-- Author:
-- Thomas Wolf (TW) --
twolf@acm.org
-- --
-- Purpose:
-- Storage of description definitions.
-- -- ------------------------------------------------------------------------------- pragma License (GPL); with Ada.Exceptions; with Ada.Strings.Maps; with Ada.Unchecked_Deallocation; with AD.Config; with AD.Text_Utilities; with Asis; with Asis.Declarations; with Asis.Elements; with Asis.Text; with Asis2.Spans; with Util.Strings; package body AD.Descriptions is package ASM renames Ada.Strings.Maps; use Asis; use Asis.Declarations; use Asis.Elements; use Asis.Text; use Asis2.Spans; use AD.Text_Utilities; use Util.Strings; procedure Free is new Ada.Unchecked_Deallocation (Finders, Finders_Ptr); type Handle is access Finders_Ptr; procedure Free is new Ada.Unchecked_Deallocation (Finders_Ptr, Handle); type Desc is record Is_Default : Boolean; Ptr : Handle; end record; Comment_Finders : array (Item_Classes) of Desc; subtype Default_Count is Natural range 0 .. 2; type Default_Desc (N : Default_Count := 0) is record Super : Item_Classes; Find : Finders (1 .. N); end record; Defaults : constant array (Item_Classes) of Default_Desc := (No_Item_Class => (0, No_Item_Class, (others => (None, 0))), Item_Context_Clause => (1, Item_Context_Clause, (1 => (After, 1))), Item_Clause => (1, Item_Clause, (1 => (After, 1))), Item_Constant => (1, Item_Constant, (1 => (After, 1))), Item_Container => (2, Item_Container, ((Before, Unlimited), (Inside, Unlimited))), Item_Exception => (1, Item_Exception, (1 => (After, 1))), Item_Instantiation => (1, Item_Subprogram, (1 => (After, 1))), Item_Library => (2, Item_Library, ((Before, Unlimited), (After, Unlimited))), Item_Library_Instantiation => (0, Item_Library, (others => (None, 0))), Item_Library_Package => (0, Item_Library, (others => (None, 0))), Item_Library_Renaming => (0, Item_Library, (others => (None, 0))), Item_Library_Subprogram => (0, Item_Library, (others => (None, 0))), Item_Object => (1, Item_Object, (1 => (After, 1))), Item_Package => (0, Item_Container, (others => (None, 0))), Item_Pragma => (1, Item_Pragma, (1 => (After, 1))), Item_Protected => (0, Item_Container, (others => (None, 0))), Item_Renaming => (1, Item_Subprogram, (1 => (After, 1))), Item_Rep_Clause => (1, Item_Rep_Clause, (1 => (After, 1))), Item_Subprogram => (1, Item_Subprogram, (1 => (After, 1))), Item_Task => (0, Item_Container, (others => (None, 0))), Item_Type => (2, Item_Type, ((After, 1), (Before, Unlimited))) ); ---------------------------------------------------------------------------- procedure Reset (The_Class : in Item_Classes) is begin if Comment_Finders (The_Class).Is_Default then return; end if; if Defaults (The_Class).Super = The_Class then Free (Comment_Finders (The_Class).Ptr.all); Comment_Finders (The_Class).Ptr.all := new Finders'(Defaults (The_Class).Find); else Free (Comment_Finders (The_Class).Ptr.all); Free (Comment_Finders (The_Class).Ptr); Comment_Finders (The_Class).Ptr := Comment_Finders (Defaults (The_Class).Super).Ptr; end if; Comment_Finders (The_Class).Is_Default := True; end Reset; procedure Set (The_Class : in Item_Classes; To : in Finders) is begin if The_Class = No_Item_Class then raise Program_Error; end if; if Comment_Finders (The_Class).Is_Default and then Defaults (The_Class).Super /= The_Class then -- A subclass at its default setting: shares the parent data -- structure. Hence we need to create a new one. Comment_Finders (The_Class).Ptr := new Finders_Ptr; else -- It has its own data structure. Free (Comment_Finders (The_Class).Ptr.all); end if; Comment_Finders (The_Class).Ptr.all := new Finders'(To); Comment_Finders (The_Class).Is_Default := False; end Set; ---------------------------------------------------------------------------- procedure Parse (Selector : in String; Value : in String) is function Parse_List (Value : in String) return Finders is function Parse_Finder (Value : in String) return Comment_Finder is Result : Comment_Finder := (None, 0); N : Natural; begin if Is_Prefix (Value, "after") then Result.Where := After; N := 5; elsif Is_Prefix (Value, "before") then Result.Where := Before; N := 6; elsif Is_Prefix (Value, "inside") then Result.Where := Inside; N := 6; elsif Value = "none" then return Result; end if; if Result.Where = None then Ada.Exceptions.Raise_Exception (AD.Config.Invalid_Config'Identity, "unknown location """ & Value & '"'); end if; if Value'Length = N then Result.How_Far := Unlimited; return Result; end if; -- "(number)" must be following. N := Index (Value (Value'First + N .. Value'Last), '('); if N = 0 then Ada.Exceptions.Raise_Exception (AD.Config.Invalid_Config'Identity, "invalid location """ & Value & '"'); end if; declare I : constant Natural := N; J : constant Natural := Index (Value (N + 1 .. Value'Last), ')'); Limit : Integer := -1; begin if J = Value'Last then begin Limit := Integer'Value (Value (I + 1 .. J - 1)); exception when others => Limit := -1; end; end if; if Limit < 0 then Ada.Exceptions.Raise_Exception (AD.Config.Invalid_Config'Identity, "invalid location """ & Value & '"'); end if; Result.How_Far := Limit; end; return Result; end Parse_Finder; I, J : Natural; begin -- Parse_List I := Value'First; while I <= Value'Last loop J := Index (Value, ','); if J = 0 then J := Value'Last + 1; end if; declare Item : constant String := To_Lower (Trim (Value (I .. J - 1))); begin if Item'Last >= Item'First then return Parse_Finder (Item) & Parse_List (Value (J + 1 .. Value'Last)); end if; end; I := J + 1; end loop; declare Null_Finders : Finders (2 .. 1); begin return Null_Finders; end; end Parse_List; The_Class : Item_Classes; begin -- Parse begin The_Class := Item_Classes'Value ("ITEM_" & To_Upper (Selector)); exception when Constraint_Error => Ada.Exceptions.Raise_Exception (AD.Config.Invalid_Config'Identity, "unknown selector """ & Selector & '"'); end; declare Where : constant Finders := Parse_List (Value); begin if Where'Last < Where'First then Reset (The_Class); else -- Check semantics: only containers and library items can have -- 'Inside'! if Defaults (The_Class).Super /= Item_Container and then Defaults (The_Class).Super /= Item_Library then for I in Where'Range loop if Where (I).Where = Inside then Ada.Exceptions.Raise_Exception (AD.Config.Invalid_Config'Identity, "this description selector cannot have an " & """Inside"" location"); end if; end loop; end if; -- It's ok. Set (The_Class, Where); end if; end; end Parse; ---------------------------------------------------------------------------- function Item_Class (Item : in Asis.Element) return Item_Classes is begin case Element_Kind (Item) is when A_Clause => case Clause_Kind (Item) is when A_Representation_Clause | A_Component_Clause => return Item_Rep_Clause; when A_With_Clause => return Item_Context_Clause; when A_Use_Package_Clause | A_Use_Type_Clause => -- It's a context clause if it occurs before the start -- of that compilation unit's declaration. declare Decl : constant Declaration := Unit_Declaration (Enclosing_Compilation_Unit (Item)); begin if Is_Nil (Decl) or else Start (Get_Span (Decl)) > Stop (Get_Span (Item)) then return Item_Context_Clause; end if; return Item_Clause; end; when others => return Item_Clause; end case; when A_Pragma => return Item_Pragma; when A_Declaration => case Declaration_Kind (Item) is when An_Exception_Renaming_Declaration | An_Exception_Declaration => return Item_Exception; when A_Task_Type_Declaration => if Is_Nil (Type_Declaration_View (Item)) then return Item_Type; else return Item_Task; end if; when A_Single_Task_Declaration => if Is_Nil (Object_Declaration_View (Item)) then return Item_Object; else return Item_Task; end if; when A_Protected_Type_Declaration | A_Single_Protected_Declaration => return Item_Protected; when A_Package_Declaration | A_Generic_Package_Declaration => if Is_Equal (Item, Unit_Declaration (Enclosing_Compilation_Unit (Item))) then return Item_Library_Package; else return Item_Package; end if; when A_Procedure_Declaration | A_Function_Declaration | A_Generic_Procedure_Declaration | A_Generic_Function_Declaration => if Is_Equal (Item, Unit_Declaration (Enclosing_Compilation_Unit (Item))) then return Item_Library_Subprogram; else return Item_Subprogram; end if; when A_Procedure_Renaming_Declaration | A_Function_Renaming_Declaration | A_Package_Renaming_Declaration | A_Generic_Procedure_Renaming_Declaration | A_Generic_Function_Renaming_Declaration | A_Generic_Package_Renaming_Declaration => if Is_Equal (Item, Unit_Declaration (Enclosing_Compilation_Unit (Item))) then return Item_Library_Renaming; else return Item_Renaming; end if; when A_Procedure_Instantiation | A_Function_Instantiation | A_Package_Instantiation => if Is_Equal (Item, Unit_Declaration (Enclosing_Compilation_Unit (Item))) then return Item_Library_Instantiation; else return Item_Instantiation; end if; when An_Entry_Declaration => return Item_Subprogram; when A_Constant_Declaration | A_Deferred_Constant_Declaration | An_Integer_Number_Declaration | A_Real_Number_Declaration => return Item_Constant; when A_Variable_Declaration | A_Component_Declaration | An_Object_Renaming_Declaration => -- Components can occur as the items in the private part of -- a protected type or object. return Item_Object; when others => if (Declaration_Kind (Item) in A_Type_Declaration) or else (Declaration_Kind (Item) = A_Subtype_Declaration) then return Item_Type; end if; end case; -- Declaration_Kind when others => null; end case; -- Element_Kind return No_Item_Class; end Item_Class; function Is_Container (Class : in Item_Classes) return Boolean is begin return Defaults (Class).Super = Item_Container or else Class = Item_Library_Package; end Is_Container; function Get_Finders (The_Class : in Item_Classes) return Finders_Ptr is begin return Comment_Finders (The_Class).Ptr.all; end Get_Finders; ---------------------------------------------------------------------------- type Text_Range; type Range_Ptr is access Text_Range; type Text_Range is record Start : Asis.Text.Line_Number; Stop : Asis.Text.Line_Number; Next : Range_Ptr; end record; procedure Free is new Ada.Unchecked_Deallocation (Text_Range, Range_Ptr); Anchor : Range_Ptr; procedure Take (Span : Asis.Text.Span) is P, Q : Range_Ptr; First : constant Line_Number := Start (Span).Line; Last : constant Line_Number := Stop (Span).Line; begin P := Anchor; -- There can be no overlaps! while P /= null and then Last < P.Stop loop Q := P; P := P.Next; end loop; if Q = null then Anchor := new Text_Range'(First, Last, P); else Q.Next := new Text_Range'(First, Last, P); end if; end Take; function Is_Taken (Pos : Asis.Text.Line_Number) return Boolean is P : Range_Ptr := Anchor; begin while P /= null and then Pos <= P.Stop loop if Pos >= P.Start then return True; end if; P := P.Next; end loop; return False; end Is_Taken; procedure Clear_Comments is P, Q : Range_Ptr; begin P := Anchor; while P /= null loop Q := P; P := P.Next; Free (Q); end loop; Anchor := null; end Clear_Comments; function Get_Name (Decl : in Asis.Declaration) return Asis.Element is All_Names : constant Name_List := Names (Decl); begin return All_Names (All_Names'First); end Get_Name; procedure Find_Comment (Unit : in Asis.Element; From : in Position; Limit : in Integer; Span : in out Asis.Text.Span; Direction : in Ada.Strings.Direction := Ada.Strings.Forward) is -- 'Span' is initially nil! use type Ada.Strings.Direction; Comment_Pos : Position; begin if Is_Nil (From) then return; end if; if Direction = Ada.Strings.Backward then Comment_Pos := Find_Comment (Unit, From.Line, Ada.Strings.Backward); if Is_Nil (Comment_Pos) or else (Limit >= 0 and then Integer (From.Line - Comment_Pos.Line - 1) > Limit) or else Is_Taken (Comment_Pos.Line) then return; end if; Set_Stop (Span, Comment_Pos); Set_Start (Span, Expand_Comment (Unit, Comment_Pos, Ada.Strings.Backward)); else Comment_Pos := Find_Comment (Unit, From.Line); if Is_Nil (Comment_Pos) or else (Limit >= 0 and then Integer (Comment_Pos.Line - From.Line - 1) > Limit) or else Is_Taken (Comment_Pos.Line) then return; end if; Set_Start (Span, Comment_Pos); Set_Stop (Span, Expand_Comment (Unit, Comment_Pos)); end if; Comment_Pos := Start (Span); if Comment_Pos.Line = Stop (Span).Line then -- A one-liner... if it is empty after we've stripped out any blanks -- and dashes, it is not a comment after all! declare use type ASM.Character_Set; L : constant Line_List := Asis.Text.Lines (Unit, Span); S : constant String := Trim (To_String (Comment_Image (L (L'First))), Blanks or ASM.To_Set ("-"), Blanks or ASM.To_Set ("-")); begin if S'Last < S'First then Span := Asis.Text.Nil_Span; end if; end; end if; end Find_Comment; procedure Find (Self : in Comment_Finder; Item : in Asis.Element; Span : out Asis.Text.Span; Class : in Item_Classes := No_Item_Class) is begin Span := Asis.Text.Nil_Span; if Self.Where = None then return; end if; declare The_Span : constant Asis.Text.Span := Get_Span (Item); begin Find (Self, Item, Start (The_Span), Stop (The_Span), Span, Class); end; end Find; ---------------------------------------------------------------------------- procedure Find (Self : in Comment_Finder; Item : in Asis.Element; From : in Asis2.Spans.Position; To : in Asis2.Spans.Position; Span : out Asis.Text.Span; Class : in Item_Classes := No_Item_Class) is The_Class : Item_Classes := Class; Front, Back, Inner : Position; begin Span := Asis.Text.Nil_Span; if Self.Where = None then return; end if; Front := From; Back := To; if The_Class = No_Item_Class then The_Class := Item_Class (Item); end if; if The_Class = No_Item_Class then return; end if; if Defaults (The_Class).Super = Item_Container then -- Find the end of the header case Declaration_Kind (Item) is when A_Task_Type_Declaration | A_Protected_Type_Declaration => declare Before_Is : Asis.Element := Discriminant_Part (Item); begin if Is_Nil (Before_Is) then Before_Is := Get_Name (Item); end if; Inner := Stop (Through (Item, "is", From => Stop (Get_Span (Before_Is)))); end; when A_Single_Task_Declaration | A_Single_Protected_Declaration | A_Package_Declaration | A_Generic_Package_Declaration => Inner := Stop (Through (Item, "is", From => Stop (Get_Span (Get_Name (Item))))); when others => -- Not a container null; end case; elsif Defaults (The_Class).Super = Item_Library then -- Front is before the context clauses; Inner is the beginning of -- the item, Back is the end of the item, or, if it is a package, -- the end of the header. Inner := Front; declare Clauses : constant Context_Clause_List := Context_Clause_Elements (Enclosing_Compilation_Unit (Item), True); begin if Clauses'Last >= Clauses'First then Front := Start (Get_Span (Clauses (Clauses'First))); if Is_Nil (Front) then Front := Inner; end if; end if; end; if The_Class = Item_Library_Package then -- Find the end of the header, i.e. the "is" after the package -- name. Back := Stop (Through (Item, "is", From => Stop (Get_Span (Get_Name (Item))))); end if; end if; -- All right, we now have the three positions we (may) need. declare Unit : constant Declaration := Unit_Declaration (Enclosing_Compilation_Unit (Item)); begin case Self.Where is when Before => Find_Comment (Unit, Front, Self.How_Far, Span, Ada.Strings.Backward); when Inside => if Defaults (The_Class).Super = Item_Library then -- Search backwards; 'Inner' is the beginning of the unit. Find_Comment (Unit, Inner, Self.How_Far, Span, Ada.Strings.Backward); else Find_Comment (Unit, Inner, Self.How_Far, Span); end if; when After => Find_Comment (Unit, Back, Self.How_Far, Span); when None => raise Program_Error; end case; end; if not Is_Nil (Span) then Take (Span); end if; end Find; begin -- AD.Descriptions.BODY for I in Comment_Finders'Range loop if I = No_Item_Class then Comment_Finders (I).Ptr := null; elsif Defaults (I).Super = I then Comment_Finders (I).Ptr := new Finders_Ptr; Comment_Finders (I).Ptr.all := new Finders'(Defaults (I).Find); end if; end loop; for I in Comment_Finders'Range loop Comment_Finders (I).Is_Default := True; if Defaults (I).Super /= I then Comment_Finders (I).Ptr := Comment_Finders (Defaults (I).Super).Ptr; end if; end loop; end AD.Descriptions; adabrowse_4.0.3/ad-setup.ads0000644000175000017500000000034510234241500014067 0ustar kenken-- This file has been automatically generated. pragma License (GPL); package AD.Setup is pragma Pure; GNAT_Name : constant String; private GNAT_Name : constant String := "gcc"; end AD.Setup; adabrowse_4.0.3/simple_test/0000755000175000017500000000000010234241457014215 5ustar kenkenadabrowse_4.0.3/simple_test/test-enum.ads0000644000175000017500000000022510234241455016624 0ustar kenkenpackage Test.Enum is type Enumeration is (A, B, C, D); type XYZ is new Integer; procedure Do_Bar (X : in out XYZ); end Test.Enum; adabrowse_4.0.3/simple_test/test-use_signature.ads0000644000175000017500000000075310234241457020545 0ustar kenkenwith Test.Signature; generic with package X_Formal is new Test.Signature (<>); package Test.Use_Signature is procedure Y_Proc (A, B : in X_Formal.X); -- The cross-reference on X in this procedure -- declaration should go to -- test-signature.html#2. -- If it doesn't, check procedure Write_Reference in -- file ad-writers.adb in the AdaBrowse sources. end Test.Use_Signature; adabrowse_4.0.3/simple_test/files.txt0000644000175000017500000000051410234241455016056 0ustar kenkentest-ch.ads test-enum.ads test-enum_use.ads test-g4.ads test-gen-err.ads test-gen.ads test-gen2.ads test-gen3.ads test-genpkg.ads test-privstuff.ads test-signature.ads test-sig_instance.ads test-swap.ads test-swap_int.ads test-tasking.ads test-use_genpkg.ads test-use_instance.ads test-use_signature.ads test.ads adabrowse_4.0.3/simple_test/test-signature.adb0000644000175000017500000000020310234241456017635 0ustar kenkenpackage body Test.Signature is procedure X_Proc (A, B : in out X) is begin B := A; end X_Proc; end Test.Signature; adabrowse_4.0.3/simple_test/test.cfg0000644000175000017500000000277410234241457015667 0ustar kenken# Test config file for user-defined HTML tags. user_tag.AUTHOR = Thomas Wolf\\ #user_tag.AUTHOR = #user_tag.NOT_ALLOWED = user_tag.AUTHOR = user_tag.LEVEL_2 = %First_Name %last_name #user_tag.H1 = Predefined tags cannot be redefined! user_tag.COPYRIGHT.Before = Copyright © user_tag.COPYRIGHT.After = by user_tag.PURPOSE.Before =
Purpose:
user_tag.PURPOSE.After =
user_tag.INCLUDE_GMGPL.Include = \ ${ADABROWSE_HOME-.}\simple_test\gmgpl.txt #user_tag.DATE.set = ${TEST_VAR-${ADABROWSE_HOME-.}}\nasty user_tag.DATE.set = date /t Include_File = ${ADABROWSE_HOME:-.}\simple_test.cfg Include_File = user_tag.var1.variable = $ADABROWSE_HOME\\ ${$} $@ $@$$ $@\$$ $@\\$$ ${$:-.} ${TEST_VAR-${ADABROWSE_HOME-$$}}\hello # The following is the example from the user's guide. This is just to illustrate the # use of an 'execute' filter! Note that this may produce invalid output if the comment # block contains HTML markup. To achieve the same effect as this particular external # command, but with the guarantee that it won't produce invalid HTML from valid # input, use a 'lines' filter! # Format."--!" = execute lf (sed -e"s/^\(.*\)
$/\1/" \ # Remove
s # -e"s/[[:blank:]]/\ /g" \ # Replace white space # -e"s/^\(.*\)$/\1
/") | \ # Add
s # plain Format."--!" = expand | strip_comments | shortcut | plain | lines adabrowse_4.0.3/simple_test/test-sig_instance.ads0000644000175000017500000000012710234241456020330 0ustar kenkenwith Test.Signature; package Test.Sig_Instance is new Test.Signature (Integer); adabrowse_4.0.3/simple_test/gmgpl.txt0000644000175000017500000000221010234241455016055 0ustar kenken
AdaBrowse is free software; you can redistribute it and/or modify it under the terms of the GNU General Public License as published by the Free Software Foundation; either version 2, or (at your option) any later version. AdaBrowse is distributed in the hope that it will be useful, but without any warranty; without even the implied warranty of merchantability or fitness for a particular purpose. See the GNU General Public License for more details. You should have received a copy of the GNU General Public License with this distribution, see file "GPL.txt". If not, write to the Free Software Foundation, 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA.
As a special exception from the GPL, if other files instantiate generics from this unit, or you link this unit with other files to produce an executable, this unit does not by itself cause the resulting executable to be covered by the GPL. This exception does not however invalidate any other reasons why the executable file might be covered by the GPL.
adabrowse_4.0.3/simple_test/test-gen-err.adb0000644000175000017500000000022010234241456017172 0ustar kenken-- generic package body Test.Gen.Err is procedure Do_X (X : in Mix_In'Class) is begin null; end Do_X; end Test.Gen.Err; adabrowse_4.0.3/simple_test/test-gen.adb0000644000175000017500000000056010234241456016413 0ustar kenken-- generic -- type Base is new Root with private; package body Test.Gen is procedure Do_C (M : in Mix_In) is begin null; end Do_C; procedure Do_C (M : in Mix_In; X : in Natural) is begin null; end Do_C; procedure Do_Acc (Y : in Mix_In) is begin null; end Do_Acc; end Test.Gen; adabrowse_4.0.3/simple_test/test-use_genpkg.ads0000644000175000017500000000041510234241457020012 0ustar kenkenwith Test.GenPkg; package Test.Use_GenPkg is package My_Gen is new Test.GenPkg.Generic_Package (Integer); package Inner_Gen is new My_Gen.Inner (Integer); procedure Dummy (V : in Inner_Gen.Handler; X : Integer); end Test.Use_GenPkg; adabrowse_4.0.3/simple_test/test-gen2.ads0000644000175000017500000000015310234241456016514 0ustar kenkenwith Test.Gen; generic package Test.Gen2 renames Test.Gen; -- This is just a renaming for test purposes. adabrowse_4.0.3/simple_test/test-gen.ads0000644000175000017500000000073710234241456016442 0ustar kenkengeneric type Base is new Root with private; package Test.Gen is pragma Elaborate_Body; type Mix_In is new Base with null record; procedure Do_C (M : in Mix_In); procedure Do_C (M : in Mix_In; X : in Natural); procedure Do_Acc (Y : in Mix_In); -- We have a comment here! My_Exception : exception renames an_exception; Some_Exception : exception; pragma Inline (Do_Acc); -- Let's inline this... end Test.Gen; adabrowse_4.0.3/simple_test/test-gen-err.ads0000644000175000017500000000014410234241456017220 0ustar kenkengeneric package Test.Gen.Err is procedure Do_X (X : in Mix_In'Class); end Test.Gen.Err; adabrowse_4.0.3/simple_test/test-enum_use.ads0000644000175000017500000000040610234241455017501 0ustar kenkenwith Test.Enum; package Test.Enum_Use is use Test.Enum; type My_Enum is new Enumeration; X : constant My_Enum := C; type ZXY is new XYZ; procedure Do_Foo (X : in out ZXY) renames Do_Bar; Q : ZXY := 17 + ZXY (3); end Test.Enum_Use; adabrowse_4.0.3/simple_test/test-ch.ads0000644000175000017500000001203210234241455016251 0ustar kenken------------------------------------------------------------------------------- -- -- -- -- Author: <twolf@acm.org> -- -- @Test@ -- -- @Test@ -- -- 
--     This is
--     a @Test  @Test@  @Test."<="@
--
-- -- This comment is before the context clauses. Such a "header" comment is -- taken by adabrowse to build the synopsis section. -- -- Note how empty lines generate new HTML paragraphs. ---------------------------------------------------------------- -- 
--     Unless
--
--     we are in a
--
--        preformatted block.
--
------------------------------------------------------------------------------- -- adabrowse -- builds an index of known child packages (see e.g. package Test and also an index of types. For (tagged) -- record types, private types, and types derived from those, this index -- also contains a list of all primitive operations. -- -- In the example below, note --
    --
  • that type Child has even -- Do_B as an inherited primitive operation. --

    --
  • that the cross-reference on "is new XYZ.Mix_In" goes to -- the generic template, not to -- the instantiation "XYZ"! --

    --
  • that the private part is not displayed! --
-- ------------------------------------------------------------------------------- with GAL; with Test.Gen2; with Test.Gen3; with Test.G4; with Test.Swap; with Test.Use_Instance; ----------------------------- -- This is a block comment -- ----------------------------- package Test.Ch is use GAL; Ex_A, Ex_B : exception; -- Two exception with a trailing comment. type Int_Ptr is access all Integer; Test_Var : Boolean := Float'signed_zeros; Deferred : constant Natural; Max : constant Natural := Natural'last; -- A constant. Test2 : Boolean := Max > 65536; test3 : Boolean := test2 and then test_var; -- The funny formatting is on purpose here! type Length is new Natural; type Area is new Natural; function "*" (A, B : in Length) return Length is abstract; function "*" (A, B : in Area) return Area is abstract; function "*" (A, B : in Length) return Area; Q, R, S : Integer; -- Empty line above. A_Meter : constant Length := 1; A_Square_Meter : constant Area := A_Meter * A_Meter; Four_Square_Meters : constant Area := "*" (A_Meter + A_Meter, A_Meter + A_Meter); package XYZ is new Test.Gen2 (Base => Test.Parent); -- A generic instantiation. package XYZ_2 is new Test.Gen3 (Base => Test.Parent); package XYZ_3 is new Test.G4 (Base => Test.Parent); type Child is new XYZ.Mix_In with null record; -- A derivation from a type declared in the generic template. procedure Do_D (C : in out Child); -- The first operation -- -- of this type. function Quark (X : in Integer) return Integer; procedure Swap is new Test.Swap (Integer); Another_Exception : exception renames An_Exception; -- A renaming -- from the parent package Yet_Another_Exception : exception renames XYZ.My_Exception; -- A renaming from the generic instantiation. -- -- We'll see what this gives. Gen_Exc : exception renames XYZ.Some_Exception; A, B, C : Natural := Max; Quork : Integer := Quark (X => A); An_Int : constant := 42; -- A named integral number. D : Natural := An_Int; for D'Alignment use 4; -- A nested package package Inner is -- This one has two comments! type Another_Type is record A : Integer; end record; -- We have a trailing comment here! -- This type is here just for fun. procedure Q (A : in out Another_Type); -- And this is a primitive -- operation of type 'Another_Type'. -- It performs a classic foo, followed by a bar, -- and raises Another_Exception if A.A is negative. Min : Integer := (- Max) + 42; -- Just for fun. end inner; procedure Test_R (X : integer := R); for Int_Ptr'Storage_Size use 0; procedure Do_E (C : in Child); -- The second 'Child' operation. -- --! --! This should be a line. --! And so should this. --! --! And an empty line above. --! -- Yeah! A_Number : constant := 1.23456789; -- A named real number procedure Dummy (A, B : in Integer) renames Test.Use_Instance.Y_Proc; type My_Rec; type My_Ptr is access all My_Rec; type My_Rec is record A : Integer; P : My_Ptr; end record; procedure my_rec_prim (M : in out my_rec); private A_Private_Int : constant := 42; X : Integer := 0; Deferred : constant Natural := 42; type To_Be_Completed; type TBC_Ptr is access all To_Be_Completed; end Test.Ch; adabrowse_4.0.3/simple_test/test-use_signature.adb0000644000175000017500000000022510234241457020516 0ustar kenkenpackage body Test.Use_Signature is procedure Y_Proc (A, B : in X_Formal.X) is begin null; end Y_Proc; end Test.Use_Signature; adabrowse_4.0.3/simple_test/test-swap.adb0000644000175000017500000000015210234241456016611 0ustar kenkenprocedure Test.Swap (A, B : in out Item) is Tmp : Item := A; begin A := B; B := Tmp; end Test.Swap; adabrowse_4.0.3/simple_test/test-signature.ads0000644000175000017500000000016510234241456017665 0ustar kenkengeneric type X is private; package Test.Signature is procedure X_Proc (A, B : in out X); end Test.Signature; adabrowse_4.0.3/simple_test/test-genpkg.adb0000644000175000017500000000053210234241456017114 0ustar kenkenpackage body Test.GenPkg is -- generic -- type The_Type is private; package body Generic_Package is Q : Handler; procedure Set_Handler (X : The_Type; P : Handler) is pragma Warnings (Off, X); begin Q := P; end Set_Handler; end Generic_Package; end Test.GenPkg; adabrowse_4.0.3/simple_test/test-gen3.ads0000644000175000017500000000015210234241456016514 0ustar kenkenwith Test.Gen; generic package Test.Gen3 renames Test.Gen; -- This is just a renaming for test purposes. adabrowse_4.0.3/simple_test/test-swap.ads0000644000175000017500000000023010234241456016627 0ustar kenkengeneric type Item is private; procedure Test.Swap (A, B : in out Item); pragma Inline (Test.Swap); pragma Elaborate_Body (Test.Swap); -- A comment adabrowse_4.0.3/simple_test/test.ads0000644000175000017500000000156510234241457015674 0ustar kenken----------------------------------------------------------------------- -- -- 2002 -- -- -- -- -- Just a test package. -- -- -- This is not a user-defined tag. -- -- Generated on . -- -- -- ----------------------------------------------------------------------- package Test is type Root is tagged null record; procedure Do_A (R : in out Root); type Parent is new Root with null record; procedure Do_B (P : in out Parent); procedure Do_Acc (P : access Parent); procedure Do_Acc (P : in Parent); An_Exception : exception; -- This is just a test exception. procedure Do_X (X : in Root'Class); end Test; adabrowse_4.0.3/simple_test/test-genpkg.ads0000644000175000017500000000073110234241456017136 0ustar kenkenpackage Test.GenPkg is generic type The_Type is private; package Generic_Package is type Handler is access function (X : The_Type) return Natural; procedure Set_Handler (X : The_Type; P : Handler); generic type Second_Type is private; package Inner is type Handler is access function (X : The_Type) return Second_Type; end Inner; end Generic_Package; end Test.GenPkg; adabrowse_4.0.3/simple_test/test-use_instance.ads0000644000175000017500000000020210234241457020335 0ustar kenkenwith Test.Sig_Instance; with Test.Use_Signature; package Test.Use_Instance is new Test.Use_Signature (Test.Sig_Instance); adabrowse_4.0.3/simple_test/test.css0000644000175000017500000000004110234241457015701 0ustar kenkenSPAN.comment { color: yellow } adabrowse_4.0.3/simple_test/test-swap_int.ads0000644000175000017500000000010510234241456017502 0ustar kenkenwith Test.Swap; procedure Test.Swap_Int is new Test.Swap (Integer); adabrowse_4.0.3/simple_test/test-g4.ads0000644000175000017500000000015210234241455016171 0ustar kenkenwith Test.Gen; generic package Test.G4 renames Test.Gen; -- This is just a renaming for test purposes. adabrowse_4.0.3/simple_test/test-privstuff.ads0000644000175000017500000000064110234241456017713 0ustar kenkenpackage Test.PrivStuff is type A_Type is private; type B_Type; type B_Type is record X : Natural := 0; end record; private type A_Type is tagged record X : B_Type; end record; type C_Type; type C_Type is new A_Type with null record; type D_Type is record X : Integer := - 1; end record; type E_Type; end Test.PrivStuff; adabrowse_4.0.3/simple_test/test-tasking.ads0000644000175000017500000000206710234241457017330 0ustar kenkenpackage Test.Tasking is N : constant := 100_000; task type T is end T; type T_Ptr is access all T; task type T2 (P : T_Ptr) is -- This is a second task type. entry A; entry B (Boolean) (X : in Integer); entry C (X : in Integer; Y : out Natural); private pragma Storage_Size (10_000); -- Give it a particular stack size. entry D (X : integer); end T2; task type T3 (P : access T2; X : Integer) is entry Start; entry Stop; end T3; A_Task_Ptr : T_Ptr; task T_Object is entry Start; entry Kill (Normal : in Boolean); end T_Object; protected type P is procedure A (X : in natural); function B (X : in integer) return Boolean; entry C (Boolean) (A, B, C : in T_Ptr); private Flag : Boolean := false; end P; protected Lock is entry Acquire; procedure Release; private Locked : Boolean := false; end Lock; end Test.Tasking; adabrowse_4.0.3/ad-predicates.adb0000644000175000017500000004726410234241451015051 0ustar kenken------------------------------------------------------------------------------- -- -- This file is part of AdaBrowse. -- -- Copyright (c) 2002 by Thomas Wolf. --
-- AdaBrowse is free software; you can redistribute it and/or modify it -- under the terms of the GNU General Public License as published by the -- Free Software Foundation; either version 2, or (at your option) any -- later version. AdaBrowse is distributed in the hope that it will be -- useful, but without any warranty; without even the implied -- warranty of merchantability or fitness for a particular purpose. -- See the GNU General Public License for more details. You should have -- received a copy of the GNU General Public License with this distribution, -- see file "GPL.txt". If not, write to the Free -- Software Foundation, 59 Temple Place - Suite 330, Boston, MA 02111-1307, -- USA. --
-- --
-- Author:
-- Thomas Wolf (TW) --
twolf@acm.org
-- --
-- Purpose:
-- Useful predicates on @Asis.Element@. All predicates return @False@ if -- called with inappropriate element kinds. -- -- Whereever the following descriptions specify "a declaration of", this -- also allows "a defining name in a declaration of". -- -- Wherever the following descriptions specify "a declaration of a type" or -- " a type declaration", this also allows "a type definition" of such a -- type. -- -- Mentions of "type" include generic formal types, "variable" includes -- generic formal "in out" objects, and so on. -- -- If @Element@ is an @Expression@, the predicates on types are also -- applicable, they refer to the type of the expression. If the @Expression@ -- is a name (identifier, operator, enumeration literal, or selected -- component), they refer to the referenced defining name.
-- -- ------------------------------------------------------------------------------- pragma License (GPL); with Ada.Exceptions; with Asis.Clauses; with Asis.Elements; with AD.Messages; with Asis2.Declarations; with Asis2.Naming; with Asis2.Predicates; package body AD.Predicates is ---------------------------------------------------------------------------- -- Units function Is_Private (Element : in Asis.Element) return Boolean is begin return Asis2.Predicates.Is_Private (Element); exception when E : others => AD.Messages.Debug (Ada.Exceptions.Exception_Information (E)); return False; end Is_Private; function Is_Separate (Element : in Asis.Element) return Boolean is begin return Asis2.Predicates.Is_Separate (Element); exception when E : others => AD.Messages.Debug (Ada.Exceptions.Exception_Information (E)); return False; end Is_Separate; function Is_Unit (Element : in Asis.Element) return Boolean is begin return Asis2.Predicates.Is_Unit (Element); exception when E : others => AD.Messages.Debug (Ada.Exceptions.Exception_Information (E)); return False; end Is_Unit; function Is_Child (Element : in Asis.Element) return Boolean is begin return Asis2.Predicates.Is_Child (Element); exception when E : others => AD.Messages.Debug (Ada.Exceptions.Exception_Information (E)); return False; end Is_Child; ---------------------------------------------------------------------------- -- Items function Is_Constant (Element : in Asis.Element) return Boolean is begin return Asis2.Predicates.Is_Constant (Element); exception when E : others => AD.Messages.Debug (Ada.Exceptions.Exception_Information (E)); return False; end Is_Constant; function Is_Variable (Element : in Asis.Element) return Boolean is begin return Asis2.Predicates.Is_Variable (Element); exception when E : others => AD.Messages.Debug (Ada.Exceptions.Exception_Information (E)); return False; end Is_Variable; function Is_Package (Element : in Asis.Element) return Boolean is begin return Asis2.Predicates.Is_Package (Element); exception when E : others => AD.Messages.Debug (Ada.Exceptions.Exception_Information (E)); return False; end Is_Package; function Is_Type (Element : in Asis.Element) return Boolean is begin return Asis2.Predicates.Is_Type (Element); exception when E : others => AD.Messages.Debug (Ada.Exceptions.Exception_Information (E)); return False; end Is_Type; function Is_Subtype (Element : in Asis.Element) return Boolean is begin return Asis2.Predicates.Is_Subtype (Element); exception when E : others => AD.Messages.Debug (Ada.Exceptions.Exception_Information (E)); return False; end Is_Subtype; -- Returns @True@ if @Element@ is a subtype declaration. function Is_Procedure (Element : in Asis.Element) return Boolean is begin return Asis2.Predicates.Is_Procedure (Element); exception when E : others => AD.Messages.Debug (Ada.Exceptions.Exception_Information (E)); return False; end Is_Procedure; function Is_Function (Element : in Asis.Element) return Boolean is begin return Asis2.Predicates.Is_Function (Element); exception when E : others => AD.Messages.Debug (Ada.Exceptions.Exception_Information (E)); return False; end Is_Function; function Is_Subprogram (Element : in Asis.Element) return Boolean is begin return Asis2.Predicates.Is_Subprogram (Element); exception when E : others => AD.Messages.Debug (Ada.Exceptions.Exception_Information (E)); return False; end Is_Subprogram; function Is_Entry (Element : in Asis.Element) return Boolean is begin return Asis2.Predicates.Is_Entry (Element); exception when E : others => AD.Messages.Debug (Ada.Exceptions.Exception_Information (E)); return False; end Is_Entry; ---------------------------------------------------------------------------- -- Types, Variables, and Constants. See RM 3.2 function Is_Elementary (Element : in Asis.Element) return Boolean is begin return Asis2.Predicates.Is_Elementary (Element); exception when E : others => AD.Messages.Debug (Ada.Exceptions.Exception_Information (E)); return False; end Is_Elementary; function Is_Scalar (Element : in Asis.Element) return Boolean is begin return Asis2.Predicates.Is_Scalar (Element); exception when E : others => AD.Messages.Debug (Ada.Exceptions.Exception_Information (E)); return False; end Is_Scalar; function Is_Discrete (Element : in Asis.Element) return Boolean is begin return Asis2.Predicates.Is_Discrete (Element); exception when E : others => AD.Messages.Debug (Ada.Exceptions.Exception_Information (E)); return False; end Is_Discrete; function Is_Enumeration (Element : in Asis.Element) return Boolean is begin return Asis2.Predicates.Is_Enumeration (Element); exception when E : others => AD.Messages.Debug (Ada.Exceptions.Exception_Information (E)); return False; end Is_Enumeration; function Is_Integral (Element : in Asis.Element) return Boolean is begin return Asis2.Predicates.Is_Integral (Element); exception when E : others => AD.Messages.Debug (Ada.Exceptions.Exception_Information (E)); return False; end Is_Integral; function Is_Signed (Element : in Asis.Element) return Boolean is begin return Asis2.Predicates.Is_Signed (Element); exception when E : others => AD.Messages.Debug (Ada.Exceptions.Exception_Information (E)); return False; end Is_Signed; function Is_Modular (Element : in Asis.Element) return Boolean is begin return Asis2.Predicates.Is_Modular (Element); exception when E : others => AD.Messages.Debug (Ada.Exceptions.Exception_Information (E)); return False; end Is_Modular; function Is_Real (Element : in Asis.Element) return Boolean is begin return Asis2.Predicates.Is_Real (Element); exception when E : others => AD.Messages.Debug (Ada.Exceptions.Exception_Information (E)); return False; end Is_Real; function Is_Float (Element : in Asis.Element) return Boolean is begin return Asis2.Predicates.Is_Float (Element); exception when E : others => AD.Messages.Debug (Ada.Exceptions.Exception_Information (E)); return False; end Is_Float; function Is_Fixed (Element : in Asis.Element) return Boolean is begin return Asis2.Predicates.Is_Fixed (Element); exception when E : others => AD.Messages.Debug (Ada.Exceptions.Exception_Information (E)); return False; end Is_Fixed; function Is_Ordinary_Fixed (Element : in Asis.Element) return Boolean is begin return Asis2.Predicates.Is_Ordinary_Fixed (Element); exception when E : others => AD.Messages.Debug (Ada.Exceptions.Exception_Information (E)); return False; end Is_Ordinary_Fixed; function Is_Decimal_Fixed (Element : in Asis.Element) return Boolean is begin return Asis2.Predicates.Is_Decimal_Fixed (Element); exception when E : others => AD.Messages.Debug (Ada.Exceptions.Exception_Information (E)); return False; end Is_Decimal_Fixed; function Is_Numeric (Element : in Asis.Element) return Boolean is begin return Asis2.Predicates.Is_Numeric (Element); end Is_Numeric; function Is_Access (Element : in Asis.Element) return Boolean is begin return Asis2.Predicates.Is_Access (Element); exception when E : others => AD.Messages.Debug (Ada.Exceptions.Exception_Information (E)); return False; end Is_Access; function Is_Access_To_Object (Element : in Asis.Element) return Boolean is begin return Asis2.Predicates.Is_Access_To_Object (Element); exception when E : others => AD.Messages.Debug (Ada.Exceptions.Exception_Information (E)); return False; end Is_Access_To_Object; function Is_Access_To_Subprogram (Element : in Asis.Element) return Boolean is begin return Asis2.Predicates.Is_Access_To_Subprogram (Element); exception when E : others => AD.Messages.Debug (Ada.Exceptions.Exception_Information (E)); return False; end Is_Access_To_Subprogram; function Is_Composite (Element : in Asis.Element) return Boolean is begin return Asis2.Predicates.Is_Composite (Element); exception when E : others => AD.Messages.Debug (Ada.Exceptions.Exception_Information (E)); return False; end Is_Composite; function Is_Array (Element : in Asis.Element) return Boolean is begin return Asis2.Predicates.Is_Array (Element); exception when E : others => AD.Messages.Debug (Ada.Exceptions.Exception_Information (E)); return False; end Is_Array; function Is_Record (Element : in Asis.Element) return Boolean is begin return Asis2.Predicates.Is_Record (Element); exception when E : others => AD.Messages.Debug (Ada.Exceptions.Exception_Information (E)); return False; end Is_Record; function Is_Tagged (Element : in Asis.Element) return Boolean is begin return Asis2.Predicates.Is_Tagged (Element); exception when E : others => AD.Messages.Debug (Ada.Exceptions.Exception_Information (E)); return False; end Is_Tagged; function Is_Task (Element : in Asis.Element) return Boolean is begin return Asis2.Predicates.Is_Task (Element); exception when E : others => AD.Messages.Debug (Ada.Exceptions.Exception_Information (E)); return False; end Is_Task; function Is_Protected (Element : in Asis.Element) return Boolean is begin return Asis2.Predicates.Is_Protected (Element); exception when E : others => AD.Messages.Debug (Ada.Exceptions.Exception_Information (E)); return False; end Is_Protected; function Is_Limited (Element : in Asis.Element) return Boolean is begin return Asis2.Predicates.Is_Limited (Element); exception when E : others => AD.Messages.Debug (Ada.Exceptions.Exception_Information (E)); return False; end Is_Limited; function Is_Class_Wide (Element : in Asis.Element) return Boolean is begin return Asis2.Predicates.Is_Class_Wide (Element); exception when E : others => AD.Messages.Debug (Ada.Exceptions.Exception_Information (E)); return False; end Is_Class_Wide; function Is_Controlled (Element : in Asis.Element) return Boolean is begin return Asis2.Predicates.Is_Controlled (Element); exception when E : others => AD.Messages.Debug (Ada.Exceptions.Exception_Information (E)); return False; end Is_Controlled; function Is_Private_Type (Element : in Asis.Element) return Boolean is begin return Asis2.Predicates.Is_Private_Type (Element); exception when E : others => AD.Messages.Debug (Ada.Exceptions.Exception_Information (E)); return False; end Is_Private_Type; function Is_Incomplete (Element : in Asis.Element) return Boolean is begin return Asis2.Predicates.Is_Incomplete (Element); exception when E : others => AD.Messages.Debug (Ada.Exceptions.Exception_Information (E)); return False; end Is_Incomplete; function Is_Aliased (Element : in Asis.Element) return Boolean is begin return Asis2.Predicates.Is_Aliased (Element); exception when E : others => AD.Messages.Debug (Ada.Exceptions.Exception_Information (E)); return False; end Is_Aliased; ---------------------------------------------------------------------------- -- Generics, renamings, and other stuff. function Is_Exception (Element : in Asis.Element) return Boolean is begin return Asis2.Predicates.Is_Exception (Element); exception when E : others => AD.Messages.Debug (Ada.Exceptions.Exception_Information (E)); return False; end Is_Exception; function Is_Renaming (Element : in Asis.Element) return Boolean is begin return Asis2.Predicates.Is_Renaming (Element); exception when E : others => AD.Messages.Debug (Ada.Exceptions.Exception_Information (E)); return False; end Is_Renaming; function Is_Generic (Element : in Asis.Element) return Boolean is begin return Asis2.Predicates.Is_Generic (Element); exception when E : others => AD.Messages.Debug (Ada.Exceptions.Exception_Information (E)); return False; end Is_Generic; function Is_Generic_Formal (Element : in Asis.Element) return Boolean is begin return Asis2.Predicates.Is_Generic_Formal (Element); exception when E : others => AD.Messages.Debug (Ada.Exceptions.Exception_Information (E)); return False; end Is_Generic_Formal; function Is_Instance (Element : in Asis.Element) return Boolean is begin return Asis2.Predicates.Is_Instance (Element); exception when E : others => AD.Messages.Debug (Ada.Exceptions.Exception_Information (E)); return False; end Is_Instance; function Is_Abstract (Element : in Asis.Element) return Boolean is begin return Asis2.Predicates.Is_Abstract (Element); exception when E : others => AD.Messages.Debug (Ada.Exceptions.Exception_Information (E)); return False; end Is_Abstract; function Is_Pragma (Element : in Asis.Element) return Boolean is begin return Asis2.Predicates.Is_Pragma (Element); exception when E : others => AD.Messages.Debug (Ada.Exceptions.Exception_Information (E)); return False; end Is_Pragma; function Is_Clause (Element : in Asis.Element) return Boolean is begin return Asis2.Predicates.Is_Clause (Element); exception when E : others => AD.Messages.Debug (Ada.Exceptions.Exception_Information (E)); return False; end Is_Clause; ---------------------------------------------------------------------------- -- Non-boolean queries function Unique_Name (Element : Asis.Element) return Wide_String is use Asis; use Asis.Elements; use Asis2.Naming; begin case Element_Kind (Element) is when A_Defining_Name => return Fully_Qualified_Name (Element); when A_Declaration => return Fully_Qualified_Name (Get_Name (Element)); when A_Pragma => return Container_Name (Element) & "." & Simple_Name (Element); when A_Clause => case Representation_Clause_Kind (Element) is when An_Attribute_Definition_Clause | An_Enumeration_Representation_Clause | A_Record_Representation_Clause => return Container_Name (Element) & "." & Simple_Name (Element); when others => null; end case; when others => null; end case; return ""; exception when E : others => AD.Messages.Debug (Ada.Exceptions.Exception_Information (E)); return ""; end Unique_Name; function Simple_Name (Element : in Asis.Element) return Wide_String is use Asis; use Asis.Elements; use Asis2.Declarations; use Asis2.Naming; begin case Element_Kind (Element) is when A_Defining_Name => if Is_Unit (Enclosing_Declaration (Element)) then return Full_Unit_Name (Enclosing_Compilation_Unit (Element)); else return Name_Definition_Image (Element); end if; when A_Declaration => return Get_Single_Name (Element); when A_Clause => case Representation_Clause_Kind (Element) is when An_Attribute_Definition_Clause | An_Enumeration_Representation_Clause | A_Record_Representation_Clause => return Name_Expression_Image (Asis.Clauses.Representation_Clause_Name (Element)); when others => null; end case; when A_Pragma => return Pragma_Name_Image (Element); when others => null; end case; return ""; exception when E : others => AD.Messages.Debug (Ada.Exceptions.Exception_Information (E)); return ""; end Simple_Name; end AD.Predicates; adabrowse_4.0.3/util-calendar.adb0000644000175000017500000001555510234241453015070 0ustar kenken------------------------------------------------------------------------------- -- -- Copyright © 2001, 2002 by Thomas Wolf. --
-- This piece of software is free software; you can redistribute it and/or -- modify it under the terms of the GNU General Public License as published -- by the Free Software Foundation; either version 2, or (at your option) -- any later version. This software is distributed in the hope that it will -- be useful, but without any warranty; without even the implied -- warranty of merchantability or fitness for a particular purpose. -- See the GNU General Public License for more details. You should have -- received a copy of the GNU General Public License with this distribution, -- see file "GPL.txt". If not, write to the Free -- Software Foundation, 59 Temple Place - Suite 330, Boston, MA 02111-1307, -- USA. --
--
-- As a special exception from the GPL, if other files instantiate generics -- from this unit, or you link this unit with other files to produce an -- executable, this unit does not by itself cause the resulting executable -- to be covered by the GPL. This exception does not however invalidate any -- other reasons why the executable file might be covered by the GPL. --
-- -- -- Thomas Wolf (TW) -- -- -- -- Root package of the calendar subsystem. Provides a day-of-week -- calculation for Gregorian dates. -- -- --
Literature:
--

See Christian Zeller; Kalender-Formeln, Acta Mathematica, vol. -- 9, pp. 131-136; Nov. 1886. (Yes, that's not -- a typo, it really appeared in eighteen-eightysix. In fact, that paper -- is an expanded version of an earlier one from 1883!) --

See also -- J.R. Stockton's page -- on Zeller's congruence.

-- -- -- 29-JUL-2002 TW Initial version. -- ------------------------------------------------------------------------------- pragma License (Modified_GPL); package body Util.Calendar is function Day_Of_Week (Year : in Ada.Calendar.Year_Number; Month : in Ada.Calendar.Month_Number; Day : in Ada.Calendar.Day_Number) return Weekday is Zeller : constant array (Ada.Calendar.Month_Number) of Natural := (6, 2, 1, 4, 6, 2, 4, 0, 3, 5, 1, 3); -- Precomputed table Zeller (Month) = ((13 * M - 1) / 5 + 6) mod 7 for -- M = 1 + (Month + 9) mod 12, i.e. M=1 for March, 10 for December, -- and 11 for January and 12 for February. -- -- Zeller's original formula used 26*(N+1)/10 instead of (13*M-1)/5, -- where N was 3 for March, 4 for April, 10 for December, and January -- was N=13; February N=14 of the preceeding year. His formula yielded -- 1 for Sunday, 2 for Monday, 6 for Friday, and zero for Saturday. -- For computers, that's not so nice. Our term relates to his as -- (26*(N+1)/10) mod 7 = (13*(M+3)/5) mod 7 = ((13*M-1)/5) mod 7 + 1, -- i.e. we map the result such that 0 is Sunday, 1 is Monday, and 6 is -- Saturday. -- -- The "+6" finally maps this such that 0 is Monday, 1 is Tuesday, 5 -- is Saturday, and 6 is Sunday, for modern usage (and ISO) considers -- Monday the first day of the week, not Sunday. -- -- Note: in his 1886 paper, Zeller proudly stated that his formula -- made it possible for the first time to compute the day of the week -- for any given date without auxiliary tables. For a computer implemen- -- tation, using such a precomputed table is faster, though. -- -- Also note that Zeller also gave a formula for the Julian calendar: -- -- Z := (Day + 26*(N+1)/10 + Y + Y/4 + 5 - Century) mod 7 -- -- or -- -- Z := (Day + 26*(N+1)/10 + Y + Y/4 + 5 + 6*Century) mod 7 -- -- to make the left-hand side always positive. With our month numbering, -- this would become -- -- Z := (Day + (13*M-1)/5 + Y + Y/4 + 5 + 6*Century + 6) mod 7, -- -- or -- -- Z := (Day + Zeller_J (Month) + Y + Y/4 + 6*Century) mod 7, -- -- with Zeller_J = (Zeller + 5) mod 7, i.e. 4, 0, 6, 2, 4, 0, 2, 5, 1, -- 3, 6, 1. Y, Century : Natural; begin -- This is Zeller's formula. Y := Natural (Year); if Month < 3 then Y := Y - 1; end if; Century := Y / 100; Y := Y mod 100; return Weekday'Val ((Natural (Day) + Zeller (Month) + Y + Y / 4 + Century / 4 + 5 * Century) mod 7); -- Zeller used "- 2 * Century" instead of "+ 5 * Century", but then -- the left operand of the "mod" may become negative. Now in Ada 95, -- that's not a problem, for "A mod B" is defined to return a result in -- the range 0 .. B-1 for all B > 0 regardless of the sign of A, but to -- facilitate porting this code to other programming languages where the -- "mod" operator may return negative values (as in C, where -30 % 7 -- yields -2), I chose to add 7 * Century (which won't change the final -- value because it's a multiple of 7). -- -- (A side note on the above: in C99 (ISO/IEC 9899:1999), -30 % 7 == -2 -- is required. In C90 (ISO/IEC 9899:1990), -30 % 7 could yield either -- -2 or 5, depending on the implementation. The only requirement was -- that (a/b)*b + a%b == a. (And -30 / 7 was allowed to yield either -- -4 or -5!) Most C90 implementations used truncation towards zero, -- because that's what most hardware does, and gave -30 / 7 = -4 and -- -30 % 7 == -2. But the C90 standard would also have allowed to use -- truncation towards -infinity: -30 / 7 == -5 and -30 % 7 == 5.) end Day_Of_Week; function Day_Of_Week (Date : in Ada.Calendar.Time) return Weekday is Day : Ada.Calendar.Day_Number; Month : Ada.Calendar.Month_Number; Year : Ada.Calendar.Year_Number; Secs : Ada.Calendar.Day_Duration; begin Ada.Calendar.Split (Date, Year, Month, Day, Secs); return Day_Of_Week (Year, Month, Day); end Day_Of_Week; procedure Split (Secs : in Ada.Calendar.Day_Duration; Hrs : out Hours_Type; Min : out Minutes_Type; Sec : out Seconds_Type; Frac : out Ada.Calendar.Day_Duration) is use Ada.Calendar; S : Natural := Natural (Secs); begin if Day_Duration (S) > Secs then S := S - 1; end if; Frac := Secs - Day_Duration (S); Hrs := Hours_Type (S / 3600); S := S mod 3600; Min := Minutes_Type (S / 60); Sec := Seconds_Type (S mod 60); end Split; end Util.Calendar; adabrowse_4.0.3/ad-version.adb0000644000175000017500000000425310234241457014410 0ustar kenken------------------------------------------------------------------------------- -- -- This file is part of AdaBrowse. -- -- Copyright (c) 2002 by Thomas Wolf. --
-- AdaBrowse is free software; you can redistribute it and/or modify it -- under the terms of the GNU General Public License as published by the -- Free Software Foundation; either version 2, or (at your option) any -- later version. AdaBrowse is distributed in the hope that it will be -- useful, but without any warranty; without even the implied -- warranty of merchantability or fitness for a particular purpose. -- See the GNU General Public License for more details. You should have -- received a copy of the GNU General Public License with this distribution, -- see file "GPL.txt". If not, write to the Free -- Software Foundation, 59 Temple Place - Suite 330, Boston, MA 02111-1307, -- USA. --
-- --
-- Author:
-- Thomas Wolf (TW) --
twolf@acm.org
-- --
-- Purpose:
-- Version information.
-- -- ------------------------------------------------------------------------------- pragma License (GPL); with Ada.Characters.Handling; with Asis.Implementation; package body AD.Version is use Ada.Characters.Handling; function Get_Asis_Version return String is begin return To_String (Asis.Implementation.ASIS_Implementor_Version); end Get_Asis_Version; function Get_Version return String is begin return "4.0.3"; end Get_Version; function Get_Maintainer return String is begin return ""; end Get_Maintainer; function Get_URL return String is begin return "http://home.tiscalinet.ch/t_wolf/tw/ada95/adabrowse/"; end Get_URL; function Time return String is begin return "2005-04-28"; end Time; end AD.Version; adabrowse_4.0.3/ad-indices-configuration.adb0000644000175000017500000001437410234241450017204 0ustar kenken------------------------------------------------------------------------------ -- -- This file is part of AdaBrowse. -- -- Copyright (c) 2002 by Thomas Wolf. --
-- AdaBrowse is free software; you can redistribute it and/or modify it -- under the terms of the GNU General Public License as published by the -- Free Software Foundation; either version 2, or (at your option) any -- later version. AdaBrowse is distributed in the hope that it will be -- useful, but without any warranty; without even the implied -- warranty of merchantability or fitness for a particular purpose. -- See the GNU General Public License for more details. You should have -- received a copy of the GNU General Public License with this distribution, -- see file "GPL.txt". If not, write to the Free -- Software Foundation, 59 Temple Place - Suite 330, Boston, MA 02111-1307, -- USA. --
-- --
-- Author:
-- Thomas Wolf (TW) --
twolf@acm.org
-- --
-- Purpose:
-- Index configuration.
-- -- ------------------------------------------------------------------------------- pragma License (GPL); with Ada.Exceptions; with Ada.Strings.Unbounded; with AD.Config; with AD.Expressions; with Util.Strings; package body AD.Indices.Configuration is package ASU renames Ada.Strings.Unbounded; use Util.Strings; procedure Parse (Key : in String; Value : in String) is procedure Parse (Idx : in Index_Ptr; Key : in String; Value : in String) is K : constant String := To_Lower (Key); begin if K = "file" then Set_File_Name (Idx, Value); elsif K = "title" then Set_Title (Idx, Value); elsif K = "rule" then begin Set_Rule (Idx, AD.Expressions.Parse (Value)); exception when E : AD.Expressions.Parse_Error => Ada.Exceptions.Raise_Exception (AD.Config.Invalid_Config'Identity, Ada.Exceptions.Exception_Message (E)); end; elsif K = "structured" then declare Flag : Boolean; begin Flag := Boolean'Value (To_Upper (Value)); Set_Structured (Idx, Flag); exception when others => Ada.Exceptions.Raise_Exception (AD.Config.Invalid_Config'Identity, "value must be either 'True' or 'False'"); end; elsif K = "empty" then Set_Empty (Idx, Value); else Ada.Exceptions.Raise_Exception (AD.Config.Invalid_Config'Identity, "unknown selector """ & Key & '"'); end if; end Parse; I : constant Natural := First_Index (Key, '.'); begin -- Key is Name.Selector. if I <= Key'First or else I = Key'Last or else Identifier (Key) /= I - 1 then Ada.Exceptions.Raise_Exception (AD.Config.Invalid_Config'Identity, "invalid index name """ & Key & "(must be an identifier " & "followed by a selector)"); end if; Parse (Get (Key (Key'First .. I - 1)), Key (I + 1 .. Key'Last), Value); end Parse; procedure Verify renames AD.Indices.Verify; type Idx_Desc is record Name : ASU.Unbounded_String; File_Name : ASU.Unbounded_String; Title : ASU.Unbounded_String; Rule : ASU.Unbounded_String; end record; Old_Indices : constant array (Index_Type) of Idx_Desc := (Unit_Index => (Name => ASU.To_Unbounded_String ("units"), File_Name => ASU.To_Unbounded_String ("index"), Title => ASU.To_Unbounded_String ("Unit Index"), Rule => ASU.To_Unbounded_String ("unit")), Subprogram_Index => (Name => ASU.To_Unbounded_String ("subprograms"), File_Name => ASU.To_Unbounded_String ("procidx"), Title => ASU.To_Unbounded_String ("Subprogram Index"), Rule => ASU.To_Unbounded_String ("subprogram and not protected")), Type_Index => (Name => ASU.To_Unbounded_String ("types"), File_Name => ASU.To_Unbounded_String ("typeidx"), Title => ASU.To_Unbounded_String ("Type Index"), Rule => ASU.To_Unbounded_String ("type or subtype"))); function Enter (Which : in Index_Type) return AD.Indices.Index_Ptr is P : constant AD.Indices.Index_Ptr := Get (ASU.To_String (Old_Indices (Which).Name)); begin if ASU.Length (P.File_Name) = 0 then Set_File_Name (P, ASU.To_String (Old_Indices (Which).File_Name)); end if; if ASU.Length (P.Title) = 0 then Set_Title (P, ASU.To_String (Old_Indices (Which).Title)); end if; if AD.Expressions.Is_Nil (P.Rule) then Set_Rule (P, AD.Expressions.Parse (ASU.To_String (Old_Indices (Which).Rule))); end if; return P; end Enter; procedure Enter_Index (Which : in Index_Type) is Unused : constant AD.Indices.Index_Ptr := Enter (Which); pragma Warnings (Off, Unused); -- silence -gnatwa begin null; end Enter_Index; procedure Set_File_Name (Which : in Index_Type; Name : in String) is P : constant AD.Indices.Index_Ptr := Enter (Which); begin Set_File_Name (P, Name); end Set_File_Name; procedure Set_Title (Which : in Index_Type; Title : in String) is P : constant AD.Indices.Index_Ptr := Enter (Which); begin Set_Title (P, Title); end Set_Title; procedure Set_Structured (Which : in Index_Type; Flag : in Boolean) is P : constant AD.Indices.Index_Ptr := Enter (Which); begin Set_Structured (P, Flag); end Set_Structured; end AD.Indices.Configuration; adabrowse_4.0.3/asis2-container_elements.adb0000644000175000017500000001425610234241452017235 0ustar kenken------------------------------------------------------------------------------- -- -- This unit is part of the @Asis2@ ASIS secondary library. -- -- Copyright (c) 2002, 2003 by Thomas Wolf. --
-- AdaBrowse is free software; you can redistribute it and/or modify it -- under the terms of the GNU General Public License as published by the -- Free Software Foundation; either version 2, or (at your option) any -- later version. AdaBrowse is distributed in the hope that it will be -- useful, but without any warranty; without even the implied -- warranty of merchantability or fitness for a particular purpose. -- See the GNU General Public License for more details. You should have -- received a copy of the GNU General Public License with this distribution, -- see file "GPL.txt". If not, write to the Free -- Software Foundation, 59 Temple Place - Suite 330, Boston, MA 02111-1307, -- USA. --
--
-- As a special exception from the GPL, if other files instantiate generics -- from this unit, or you link this unit with other files to produce an -- executable, this unit does not by itself cause the resulting executable -- to be covered by the GPL. This exception does not however invalidate any -- other reasons why the executable file might be covered by the GPL. --
-- -- -- Thomas Wolf (TW) -- -- -- -- Utility routines for container elements, i.e. packages and task or -- protected declarations or definitions. -- -- -- -- 04-JUN-2003 TW First release as part of @AdaBrowse@. -- 18-JUL-2003 TW Created from operations in @AD.Queries@. -- ------------------------------------------------------------------------------- pragma License (Modified_GPL); with Ada.Characters.Handling; with Ada.Exceptions; with Asis.Declarations; with Asis.Definitions; with Asis.Elements; with Asis.Exceptions; package body Asis2.Container_Elements is Package_Name : constant String := "Asis2.Container_Elements"; package ACH renames Ada.Characters.Handling; use Asis; use Asis.Declarations; use Asis.Definitions; use Asis.Elements; function Has_Private (Element : in Asis.Element) return Boolean is begin case Declaration_Kind (Element) is when A_Package_Declaration | A_Generic_Package_Declaration => return Asis.Declarations.Is_Private_Present (Element); when A_Task_Type_Declaration | A_Protected_Type_Declaration => return Asis.Definitions.Is_Private_Present (Type_Declaration_View (Element)); when A_Single_Task_Declaration | A_Single_Protected_Declaration => return Asis.Definitions.Is_Private_Present (Object_Declaration_View (Element)); when Not_A_Declaration => case Definition_Kind (Element) is when A_Task_Definition | A_Protected_Definition => return Asis.Definitions.Is_Private_Present (Element); when others => null; end case; when others => null; end case; return False; end Has_Private; function Visible_Items (Element : in Asis.Element; Include_Pragmas : in Boolean := False) return Asis.Declarative_Item_List is begin case Declaration_Kind (Element) is when A_Package_Declaration | A_Generic_Package_Declaration => return Visible_Part_Declarative_Items (Element, Include_Pragmas); when A_Task_Type_Declaration | A_Protected_Type_Declaration => return Visible_Part_Items (Type_Declaration_View (Element), Include_Pragmas); when A_Single_Task_Declaration | A_Single_Protected_Declaration => return Visible_Part_Items (Object_Declaration_View (Element), Include_Pragmas); when Not_A_Declaration => case Definition_Kind (Element) is when A_Task_Definition | A_Protected_Definition => return Visible_Part_Items (Element, Include_Pragmas); when others => null; end case; when others => null; end case; Ada.Exceptions.Raise_Exception (Asis.Exceptions.ASIS_Inappropriate_Element'Identity, "This element is not allowed in " & Package_Name & ".Visible_Items: " & ACH.To_String (Debug_Image (Element))); return Asis.Nil_Element_List; end Visible_Items; function Private_Items (Element : in Asis.Element; Include_Pragmas : in Boolean := False) return Asis.Declarative_Item_List is begin case Declaration_Kind (Element) is when A_Package_Declaration | A_Generic_Package_Declaration => return Private_Part_Declarative_Items (Element, Include_Pragmas); when A_Task_Type_Declaration | A_Protected_Type_Declaration => return Private_Part_Items (Type_Declaration_View (Element), Include_Pragmas); when A_Single_Task_Declaration | A_Single_Protected_Declaration => return Private_Part_Items (Object_Declaration_View (Element), Include_Pragmas); when Not_A_Declaration => case Definition_Kind (Element) is when A_Task_Definition | A_Protected_Definition => return Private_Part_Items (Element, Include_Pragmas); when others => null; end case; when others => null; end case; Ada.Exceptions.Raise_Exception (Asis.Exceptions.ASIS_Inappropriate_Element'Identity, "This element is not allowed in " & Package_Name & ".Private_Items: " & ACH.To_String (Debug_Image (Element))); return Asis.Nil_Element_List; end Private_Items; end Asis2.Container_Elements; adabrowse_4.0.3/ad-config.ads0000644000175000017500000000326110234241442014201 0ustar kenken------------------------------------------------------------------------------- -- -- This file is part of AdaBrowse. -- -- Copyright (c) 2002 by Thomas Wolf. --
-- AdaBrowse is free software; you can redistribute it and/or modify it -- under the terms of the GNU General Public License as published by the -- Free Software Foundation; either version 2, or (at your option) any -- later version. AdaBrowse is distributed in the hope that it will be -- useful, but without any warranty; without even the implied -- warranty of merchantability or fitness for a particular purpose. -- See the GNU General Public License for more details. You should have -- received a copy of the GNU General Public License with this distribution, -- see file "GPL.txt". If not, write to the Free -- Software Foundation, 59 Temple Place - Suite 330, Boston, MA 02111-1307, -- USA. --
-- --
-- Author:
-- Thomas Wolf (TW) --
twolf@acm.org
-- --
-- Purpose:
-- Configuration file management.
-- -- ------------------------------------------------------------------------------- pragma License (GPL); package AD.Config is Invalid_Config : exception; procedure Configure (File_Name : in String); function Get_Nof_Config_Files return Natural; function Get_Config_Files return String; function Get_Reorder return Boolean; end AD.Config; adabrowse_4.0.3/ad-projects.ads0000644000175000017500000001123410234241444014566 0ustar kenken------------------------------------------------------------------------------- -- -- This file is part of AdaBrowse. -- -- Copyright (c) 2002 by Thomas Wolf. --
-- AdaBrowse is free software; you can redistribute it and/or modify it -- under the terms of the GNU General Public License as published by the -- Free Software Foundation; either version 2, or (at your option) any -- later version. AdaBrowse is distributed in the hope that it will be -- useful, but without any warranty; without even the implied -- warranty of merchantability or fitness for a particular purpose. -- See the GNU General Public License for more details. You should have -- received a copy of the GNU General Public License with this distribution, -- see file "GPL.txt". If not, write to the Free -- Software Foundation, 59 Temple Place - Suite 330, Boston, MA 02111-1307, -- USA. --
-- --
-- Author:
-- Thomas Wolf (TW) --
twolf@acm.org
-- --
-- Purpose:
-- Configuration file management.
-- -- ------------------------------------------------------------------------------- pragma License (GPL); with Ada.Text_IO; package AD.Projects is Project_Error : exception; procedure Handle_Project_File (Name : in String); -- Reads, parses, and processes a GNAT project file, then extracts the -- object pathes ("-T") that will later be passed on to ASIS. -- -- "-T" options given on the command line to AdaBrowse alwaysAdaBrowse_Configurations", -- which may be either a single string or a string list, it uses that -- variables value, interpretes the string(s) as the file names of -- AdaBrowse configuration files and processes each of them in the order -- given. (If the file names contain pathes, these are, as usual, inter- -- preted relative to the directory where the configuration file resides.) -- -- (Note: inside configuration files, path names are relative to the -- current directory, i.e. the one adabrowse was started in. To use pathes -- relative to the configuration file location use the special environment -- variable $@.) -- -- If it finds, in the root project file or in one of the projects it -- extends, a variable named "AdaBrowse_Output", which must -- have a single string as its value, it uses that variable's value as -- the specification of a directory (relative to the directory where the -- project file itself is) where the generated HTML output shall go. -- -- A "-o" option on the command line may override this setting! -- -- Note: the AdaBrowse driver requires either a "-f" option, or, if there -- is none, a "-P" options specifying a project file. If a project file is -- specified and no "-f" option is given, AdaBrowse will process all specs -- from the source files of the root project. -- -- Warning: if a project file is given, the compile command is changed to -- "gnat compile -P", if it starts with the default compiler -- name (which is "gcc" -- or "gnatgcc" on some Linux installations.) -- -- The AdaBrowse currently doesn't handle the other project-related -- switches of GNAT tools, i.e. "-X" and "-vP". To define values for -- external references, use environment variables; and the verbosity -- level of the project manager is always set to the default. -- -- If any errors occur, @Project_Error@ is raised. procedure Get_Source_File_List (File : in out Ada.Text_IO.File_Type); -- Writes the names of the source files to @File@. function Get_Tree_Directory return String; -- Returns tree directory distilled from the project file. function Get_Output_Directory return String; -- Returns the output directory defined in the project file, or an empty -- string, if none is defined. function Get_Project_File_Name return String; function Project_Version return String; -- Returns "p" if projects are supported, and an empty string otherwise. procedure Reset (On_Error : in Boolean); -- Call to close the project manager. procedure Define_Variable (Name : in String; Value : in String); procedure Initialize; end AD.Projects; adabrowse_4.0.3/ad.ads0000644000175000017500000000270610234241445012744 0ustar kenken------------------------------------------------------------------------------- -- -- This file is part of AdaBrowse. -- -- Copyright (c) 2002 by Thomas Wolf. --
-- AdaBrowse is free software; you can redistribute it and/or modify it -- under the terms of the GNU General Public License as published by the -- Free Software Foundation; either version 2, or (at your option) any -- later version. AdaBrowse is distributed in the hope that it will be -- useful, but without any warranty; without even the implied -- warranty of merchantability or fitness for a particular purpose. -- See the GNU General Public License for more details. You should have -- received a copy of the GNU General Public License with this distribution, -- see file "GPL.txt". If not, write to the Free -- Software Foundation, 59 Temple Place - Suite 330, Boston, MA 02111-1307, -- USA. --
-- --
-- Author:
-- Thomas Wolf (TW) --
twolf@acm.org
-- --
-- Purpose:
-- Root package of the AD subsytem.
-- -- ------------------------------------------------------------------------------- pragma License (GPL); package AD is pragma Pure; -- This package is empty. end AD; adabrowse_4.0.3/ad-scanner.adb0000644000175000017500000021136310234241451014350 0ustar kenken------------------------------------------------------------------------------- -- -- This file is part of AdaBrowse. -- -- Copyright (c) 2002 by Thomas Wolf. --
-- AdaBrowse is free software; you can redistribute it and/or modify it -- under the terms of the GNU General Public License as published by the -- Free Software Foundation; either version 2, or (at your option) any -- later version. AdaBrowse is distributed in the hope that it will be -- useful, but without any warranty; without even the implied -- warranty of merchantability or fitness for a particular purpose. -- See the GNU General Public License for more details. You should have -- received a copy of the GNU General Public License with this distribution, -- see file "GPL.txt". If not, write to the Free -- Software Foundation, 59 Temple Place - Suite 330, Boston, MA 02111-1307, -- USA. --
-- --
-- Author:
-- Thomas Wolf (TW) --
twolf@acm.org
-- --
-- Purpose:
-- Traversal of the ASIS tree and HTML generation.
-- -- ------------------------------------------------------------------------------- pragma License (GPL); with Ada.Exceptions; with Ada.Strings.Wide_Unbounded; with Asis.Iterator; pragma Elaborate_All (Asis.Iterator); with Asis.Compilation_Units; with Asis.Declarations; with Asis.Elements; with Asis.Expressions; with Asis.Text; with Asis2.Container_Elements; with Asis2.Declarations; with Asis2.Naming; with Asis2.Spans; with Asis2.Text; with AD.Crossrefs; with AD.Descriptions; with AD.Filters; with AD.Indices; with AD.Item_Lists; with AD.Messages.Inline; with AD.Options; with AD.Predicates; with AD.Queries; with AD.Text_Utilities; with AD.Writers; with GAL.Sorting; with GAL.Support; package body AD.Scanner is package A_D renames Asis.Declarations; package A_T renames Asis.Text; package WASU renames Ada.Strings.Wide_Unbounded; use AD.Descriptions; use AD.Item_Lists; use AD.Printers; use AD.Text_Utilities; use AD.Writers; use Asis; use Asis.Compilation_Units; use Asis.Declarations; use Asis.Elements; use Asis.Expressions; use Asis.Text; use Asis2.Naming; use Asis2.Spans; ---------------------------------------------------------------------------- function Smaller_Name (Left, Right : in Asis.Declaration) return Boolean is L : constant Defining_Name := Get_Name (Left); R : constant Defining_Name := Get_Name (Right); L_S : constant Wide_String := Asis2.Text.To_Lower (Name_Definition_Image (L)); R_S : constant Wide_String := Asis2.Text.To_Lower (Name_Definition_Image (R)); begin if L_S = R_S then -- Sort by position! return Start (Get_Span (L)) < Start (Get_Span (R)); else return L_S < R_S; end if; end Smaller_Name; ---------------------------------------------------------------------------- type Scan_State is new AD.Writers.Write_State with record Reporter : aliased AD.Messages.Inline.Error_Reporter; Traverse_Top : Asis.Element := Nil_Element; -- The top element in a traversal. We use this in 'Post_Visit' to -- omit a newline on the very last line of an element. This helps -- avoid unnecessary empty lines between an items. end record; -- Note: originally, I had a 'Traverse_Level : Natural' component that -- counted the nesting depth within 'Traverse' (Inc in 'Pre', dec in -- 'Post'). However, this turned out to fail for ASIS-for-GNAT 3.14p: in -- a declaration, it would call only 'Pre' for the defining name, but -- never call 'Post', with the result that I ended up with a nesting -- depth of 1 at the very end, and thus couldn't reliably determine when -- to omit that dreaded newline. Hence the above approach with storing the -- whole element: if in 'Post' the current element equals 'Traverse_Top', -- we're at the end. -- -- Note that the ASIS behavior of not calling 'Post' is not an error, it -- is the defined behavior of Asis.Iterator.Traverse_Element! 'Pre' -- handles the defining name by calling 'Handle_Defining_Name', which -- sets the control to 'Abandon_Children', and in such a case, the -- standard iterator doesn't call the corresponding 'Post'... I think this -- is a lousy spec, but if it's the standard, I can't change it. ---------------------------------------------------------------------------- procedure Write_Comment (Element : in Asis.Element; Span : in A_T.Span; State : in out Scan_State) is -- 'Span' comprises all comment lines. Starts at column 1 and ends -- at the end of the last line. begin if Is_Nil (Span) then return; end if; begin AD.Printers.Write_Comment (State.The_Printer, A_T.Lines (Element, Span)); exception when E : AD.Filters.Recursive_Expansion => Ada.Exceptions.Raise_Exception (AD.Filters.Recursive_Expansion'Identity, Ada.Exceptions.Exception_Message (E) & " (in comment from lines" & Asis.Text.Line_Number'Image (Span.First_Line) & " to" & Asis.Text.Line_Number'Image (Span.Last_Line) & ") in unit " & To_String (Full_Unit_Name (Enclosing_Compilation_Unit (State.Unit)))); end; end Write_Comment; procedure Write_Comments (Element : in Asis.Element; List : in Comment_Ptr; State : in out Scan_State) is P : Comment_Ptr := List; begin while P /= null loop Write_Comment (Element, P.Span, State); P := P.Next; end loop; end Write_Comments; ---------------------------------------------------------------------------- procedure Handle_Defining_Name (Element : in Declaration; Control : in out Traverse_Control; State : in out Scan_State; Do_Anchor : in Boolean := True); ---------------------------------------------------------------------------- procedure Post_Visit (Element : in Asis.Element; Control : in out Traverse_Control; State : in out Scan_State) is -- Write anything of that element that hasn't been written yet. begin if Control = Terminate_Immediately then null; end if; -- The above if serves only to silence GNAT -gnatwa. 'Control' can never -- be Terminate_Immediately here! Write (Element, State); if not Is_Equal (State.Traverse_Top, Element) then Terminate_Line (State); end if; end Post_Visit; procedure Pre_Visit (Element : in Asis.Element; Control : in out Traverse_Control; State : in out Scan_State); procedure Traverse is new Asis.Iterator.Traverse_Element (Scan_State, Pre_Visit, Post_Visit); -- Our main traversal routine, which does most of the job. We just handle -- a few elements specially (anything that might deserve a cross-reference -- or an anchor), the rest is just skipped. Note that we never see a -- declaration in 'Traverse', these are handled explicitly in procedure -- 'Handle_Declaration' below. We just use 'Traverse' to traverse and -- crossref the contents of a declaration (or a pragma) itself. procedure Pre_Visit (Element : in Asis.Element; Control : in out Traverse_Control; State : in out Scan_State) is -- Handle anything that needs handling; just keep traversing for all -- other elements. They'll be written eventually when the stuff before -- some element we're handling is written (see AD.Writers), or in -- 'Post_Visit' above. begin case Element_Kind (Element) is when An_Expression => case Expression_Kind (Element) is when An_Identifier => -- Only generate a cross-ref if it isn't the selector name -- of a named parameter association. declare Cont : constant Asis.Element := Enclosing_Element (Element); begin if Element_Kind (Cont) /= An_Association or else Association_Kind (Cont) /= A_Parameter_Association or else not Is_Equal (Element, Formal_Parameter (Cont)) then Write_Reference (Element, State); Terminate_Line (State); end if; -- else don't do anything, it'll be written as part of -- some 'Write_Before' call later on. end; when An_Operator_Symbol | An_Enumeration_Literal => Write_Reference (Element, State); Terminate_Line (State); when An_Attribute_Reference => -- Needs to be handled separately because the attribute is -- to be formatted specially. Control := Continue; Traverse (Prefix (Element), Control, State); Write_Attribute (Attribute_Designator_Identifier (Element), State); Terminate_Line (State); Control := Abandon_Children; when A_Function_Call => -- Need to handle function calls of dyadic operators that -- are inlined (as in "A + B") specially. We traverse first -- the function name ("+", in this case), and then the -- parameters. But this screws up the text sequence! if not Is_Prefix_Call (Element) and then Expression_Kind (Prefix (Element)) = An_Operator_Symbol then -- Attention: In ASIS-for-GNAT 3.14p, Is_Prefix_Call -- returns False for a unary operator as in "(- A)", -- although that always is a prefix call! -- -- We therefore need to check the number of parameters -- below, even though it should be clear that any -- non-prefix call must have exactly two parameters! declare Params : constant Association_List := Function_Call_Parameters (Element); begin if Params'Last = Params'First + 1 then -- We have exactly two parameters! (And it can't -- be a named notation, se we need only care about -- the actual parameters.) Control := Continue; Traverse (Actual_Parameter (Params (Params'First)), Control, State); Control := Continue; Traverse (Prefix (Element), Control, State); Control := Continue; Traverse (Actual_Parameter (Params (Params'First + 1)), Control, State); Control := Abandon_Children; end if; end; end if; when others => null; end case; when A_Defining_Name => -- Only generate an anchor if the defining name is not a -- parameter name of some subprogram or entry! declare Decl : constant Asis.Element := Asis2.Declarations.Enclosing_Declaration (Element); begin Handle_Defining_Name (Element, Control, State, Declaration_Kind (Decl) /= A_Parameter_Specification); Terminate_Line (State); end; when An_Association => case Association_Kind (Element) is when A_Generic_Association => -- Work-around for another ASIS-for-GNAT 3.14p bug: if -- we let 'Traverse_Element' handle this itself, it -- crashes sometimes!! So far observed only for one case -- where the formal was an operator symbol, but just to be -- on the safe side, we also guard the actual parameter. Control := Continue; declare Formal : Asis.Element; begin begin Formal := Formal_Parameter (Element); exception when others => AD.Printers.Inline_Error (State.The_Printer, "ASIS crash on generic formal parameter!"); Formal := Nil_Element; end; if not Is_Nil (Formal) then Traverse (Formal, Control, State); end if; end; Control := Continue; declare Actual : Asis.Expression; begin begin Actual := Actual_Parameter (Element); exception when others => AD.Printers.Inline_Error (State.The_Printer, "ASIS crash on generic actual parameter!"); Actual := Nil_Element; end; if not Is_Nil (Actual) then Traverse (Actual, Control, State); end if; end; -- Note: even if ASIS crashes and we don't traverse part -- of the association, its program text will still be -- written in 'Post_Visit'. It just won't have cross- -- references. Control := Abandon_Children; when others => -- Nothing to do. null; end case; when A_Pragma => -- Generate an anchor... Write_Special_Anchor (Element, State); -- ...and then just continue... when A_Clause => case Representation_Clause_Kind (Element) is when An_Attribute_Definition_Clause | An_Enumeration_Representation_Clause | A_Record_Representation_Clause => Write_Special_Anchor (Element, State); when others => null; end case; when others => -- Nothing to do. null; end case; end Pre_Visit; ---------------------------------------------------------------------------- procedure Add_To_Index (State : in out Scan_State; Element : in Asis.Element; Is_Private : in Boolean) is begin case Element_Kind (Element) is when A_Declaration => if not Is_Private or else AD.Options.Private_Too then -- Special cases for types. There can be some funny cases: -- (1) An incomplete type declaration: if there's a full -- declaration for it, don't do anything: we'll process -- the full declaration later. If there's no full decl, -- (implies 'Is_Private'), then do it. -- (2) Is_Private is True and there's a public view of the -- type: don't generate an index entry, we'll have one -- for the public view already! if Declaration_Kind (Element) = An_Incomplete_Type_Declaration and then not Is_Nil (Corresponding_Type_Declaration (Element)) then -- We have an incomplete type declaration, and there is -- a full type declaration. Note that both the incomplete -- and the full decl are either in the public or in the -- private part. There cannot be an incomplete decl in -- the public part, and the corresponding full decl in -- the private part. return; elsif Is_Private and then AD.Predicates.Is_Type (Element) then declare Other : constant Declaration := Corresponding_Type_Declaration (Element); begin if not Is_Nil (Other) and then Declaration_Kind (Other) /= An_Incomplete_Type_Declaration then -- We're in the private part, and there exists a -- public view of the type. return; end if; end; end if; declare Names : constant Asis.Name_List := A_D.Names (Element); XRef : AD.Crossrefs.Cross_Reference; begin for I in Names'Range loop declare Name : Asis.Defining_Name := Names (I); begin -- Special case for constants: if there is a -- corresponding deferred constant declaration, -- we'll already have an entry for that one, and we -- thus skip this name. Note that we need to be in -- the private part for all this to be true. if Is_Private and then Declaration_Kind (Element) = A_Constant_Declaration and then not Is_Nil (Corresponding_Constant_Declaration (Name)) then -- Skip it! null; else if Defining_Name_Kind (Name) = A_Defining_Expanded_Name then Name := Defining_Selector (Name); end if; XRef := AD.Crossrefs.Crossref_Name (Name, State.Unit, State.Reporter'Access); if XRef.Is_Top_Unit then XRef.Image := XRef.Full_Unit_Name; end if; AD.Indices.Add (Name, XRef, Is_Private); end if; end; end loop; end; end if; when A_Pragma => -- Why did I ever have the funny idea that somebody might want -- a pragma index? declare XRef : AD.Crossrefs.Cross_Reference := AD.Crossrefs.Crossref_Special (Element, State.Unit); begin AD.Indices.Add (Element, XRef, Is_Private); end; when A_Clause => case Representation_Clause_Kind (Element) is when An_Attribute_Definition_Clause | An_Enumeration_Representation_Clause | A_Record_Representation_Clause => declare XRef : AD.Crossrefs.Cross_Reference := AD.Crossrefs.Crossref_Special (Element, State.Unit); begin AD.Indices.Add (Element, XRef, Is_Private); end; when others => null; end case; when others => null; end case; end Add_To_Index; procedure Write_Item (Items : in Item_Table; Current : in Natural; State : in out Scan_State; Top_Level : in Boolean := False) is Null_Items : Item_Table (2 .. 1); Index : Index_Table := (1 => Current) & Collect_Subordinates (Items, Null_Items, Items (Current).Sub); Ctrl : Traverse_Control; procedure XRef_Other_Decl (Other : in Declaration; State : in out Scan_State; Text : in String) is begin if not Is_Nil (Other) then AD.Printers.Other_Declaration (State.The_Printer, AD.Crossrefs.Crossref_Name (Get_Name (Other), State.Unit, State.Reporter'Access), Text); end if; end XRef_Other_Decl; begin Sort_Subordinates (Index (Index'First + 1 .. Index'Last), Items, Null_Items); -- First the rep clauses, then the pragmas, both ordered by name. AD.Printers.Open_Section (State.The_Printer, Snippet_Section); for I in Index'Range loop declare Pos : Position := Start (Get_Span (Items (Index (I)).Element)); begin if Pos.Line = 1 then Pos.Column := 1; end if; State.Write_From := Pos; State.Last_Written := (Pos.Line, Pos.Column - 1); State.Indent := Pos.Column - 1; end; if I > Index'First then -- Ok, the main item has been written. What follows are pragmas -- and rep clauses, which we still need to add to the indices! Add_To_Index (State, Items (Index (I)).Element, Items (Index (Index'First)).Is_Private); -- Yes, we take the 'Is_Private' flag from the main item! end if; -- if Top_Level then -- Check_Private_Unit (State, Items (Index (I)).Element); -- end if; Ctrl := Continue; State.Traverse_Top := Items (Index (I)).Element; Traverse (Items (Index (I)).Element, Ctrl, State); -- Try to generate a cross-reference to the full type declaration. -- Note: if the element is not a declaration at all (but a pragma -- or a rep clause), 'Declaration_Kind' will simply return -- 'Not_A_Declaration' and *not* raise an exception. case Declaration_Kind (Items (Index (I)).Element) is when An_Incomplete_Type_Declaration => XRef_Other_Decl (Corresponding_Type_Declaration (Items (Index (I)).Element), State, "Full declaration"); when A_Private_Type_Declaration | A_Private_Extension_Declaration => if AD.Options.Private_Too then XRef_Other_Decl (Corresponding_Type_Declaration (Items (Index (I)).Element), State, "Full declaration"); end if; when An_Ordinary_Type_Declaration | A_Task_Type_Declaration | A_Protected_Type_Declaration => declare Other : constant Declaration := Corresponding_Type_Declaration (Items (Index (I)).Element); begin if not Is_Nil (Other) then if Declaration_Kind (Other) = An_Incomplete_Type_Declaration then XRef_Other_Decl (Other, State, "Incomplete declaration"); elsif Items (Index (I)).Is_Private then -- Actually, if it's not an incomplete declaration, -- we should always be processing a full decl in the -- private part! XRef_Other_Decl (Other, State, "Public view"); end if; end if; end; when others => null; end case; if I < Index'Last then New_Line (State.The_Printer); end if; end loop; AD.Printers.Close_Section (State.The_Printer, Snippet_Section); -- Then write any comments of these items: declare Have_Comments : Boolean := False; From : Natural; begin if Top_Level then From := Index'First + 1; else From := Index'First; end if; for I in From .. Index'Last loop if Items (Index (I)).List /= null then Have_Comments := True; exit; end if; end loop; if Have_Comments then AD.Printers.Open_Section (State.The_Printer, Description_Section); for I in From .. Index'Last loop Write_Comments (Items (Index (I)).Element, Items (Index (I)).List, State); end loop; AD.Printers.Close_Section (State.The_Printer, Description_Section); end if; end; end Write_Item; ---------------------------------------------------------------------------- generic with function Matches (Kind : in Declaration_Kinds) return Boolean; function Extract_Declarations (From : in Declarative_Item_List; Sorted : in Boolean) return Declarative_Item_List; -- generic -- with function Matches (Kind : in Declaration_Kinds) return Boolean; function Extract_Declarations (From : in Declarative_Item_List; Sorted : in Boolean) return Declarative_Item_List is Result : Declarative_Item_List (From'Range); N : Natural := Result'First - 1; procedure Sort is new GAL.Sorting.Sort_G (List_Index, Asis.Element, Declarative_Item_List, Smaller_Name); begin for I in From'Range loop if Matches (Declaration_Kind (From (I))) then N := N + 1; Result (N) := From (I); end if; end loop; if N > Result'First and then Sorted then Sort (Result (Result'First .. N)); end if; return Result (Result'First .. N); end Extract_Declarations; ---------------------------------------------------------------------------- procedure Handle_Children (The_Unit : in Compilation_Unit; State : in out Scan_State; Table_Opened : in out Boolean) is -- Build and output an index of known child units of the top-level -- libarary unit. Children : Compilation_Unit_List := Corresponding_Children (The_Unit); function Smaller (Left, Right : in Compilation_Unit) return Boolean is begin return Asis2.Text.To_Lower (Full_Unit_Name (Left)) < Asis2.Text.To_Lower (Full_Unit_Name (Right)); end Smaller; procedure Sort is new GAL.Sorting.Sort_G (List_Index, Compilation_Unit, Compilation_Unit_List, Smaller); procedure Swap is new GAL.Support.Swap (Compilation_Unit); N : Natural := 0; I : Natural := 0; begin -- Handle_Children if Children'Last >= Children'First then -- Attention, we have both specs and bodies here! First throw out the -- bodies! N := Children'Last; I := Children'First; while I <= N loop case Declaration_Kind (Unit_Declaration (Children (I))) is when A_Package_Body_Declaration | A_Procedure_Body_Declaration | A_Function_Body_Declaration => if I < N then Swap (Children (I), Children (N)); end if; N := N - 1; when others => I := I + 1; end case; end loop; -- If we had *only* bodies, give up. if N < Children'First then return; end if; -- The index is to be sorted alphabetically! Sort (Children (Children'First .. N)); if not Table_Opened then AD.Printers.Open_Section (State.The_Printer, Content_Section); Table_Opened := True; end if; AD.Printers.Open_Section (State.The_Printer, Children_Section); for I in Children'First .. N loop declare Name : constant Defining_Name := Get_Name (Unit_Declaration (Children (I))); -- They're children, so they all are defining expanded names! XRef : AD.Crossrefs.Cross_Reference := AD.Crossrefs.Crossref_Name (Defining_Selector (Name), State.Unit, State.Reporter'Access); begin XRef.Image := WASU.To_Unbounded_Wide_String (Name_Definition_Image (Name)); AD.Printers.Add_Child (State.The_Printer, Get_Item_Kind (Unit_Declaration (Children (I))), Unit_Class (Children (I)) = A_Private_Declaration, XRef); end; end loop; AD.Printers.Close_Section (State.The_Printer, Children_Section); end if; end Handle_Children; ---------------------------------------------------------------------------- procedure Handle_Clauses (The_Unit : in Compilation_Unit; State : in out Scan_State; Item : in Item_Desc) is -- Write the context clauses in their own section. Clauses : constant Context_Clause_List := Context_Clause_Elements (The_Unit, True); begin if Clauses'Last < Clauses'First then return; end if; AD.Printers.Open_Section (State.The_Printer, Dependencies_Section); AD.Printers.Open_Section (State.The_Printer, Snippet_Section); for I in Clauses'Range loop declare Ctrl : Traverse_Control := Continue; begin -- Never suppress any newlines: State.Traverse_Top := Nil_Element; Traverse (Clauses (I), Ctrl, State); end; end loop; AD.Printers.Close_Section (State.The_Printer, Snippet_Section); if Item.List /= null then AD.Printers.Open_Section (State.The_Printer, Description_Section); Write_Comments (Item.Element, Item.List, State); AD.Printers.Close_Section (State.The_Printer, Description_Section); end if; AD.Printers.Close_Section (State.The_Printer, Dependencies_Section); end Handle_Clauses; ---------------------------------------------------------------------------- -- Produce a cross-ref table of all objects of a given class declared in -- the package. procedure Handle_Objects (Items : in out Item_Table; Index : in out Index_Table; Current : in out Natural; State : in out Scan_State; Class : in Item_Classes) is procedure Write_Object (Items : in Item_Table; Current : in Natural; State : in out Scan_State) is Original : Scan_State := State; begin AD.Printers.Open_Item (State.The_Printer, AD.Crossrefs.Null_Crossref, AD.Printers.Get_Item_Kind (Items (Current).Element)); Write_Item (Items, Current, State); AD.Printers.Close_Item (State.The_Printer); State := Original; end Write_Object; N : Natural; begin N := Current; while N <= Index'Last and then Items (Index (N)).Class = Class and then not Items (Index (N)).Is_Private loop N := N + 1; end loop; N := N - 1; if N >= Current then Sort_By_Name (Items, Index (Current .. N)); if Class = Item_Constant then AD.Printers.Open_Section (State.The_Printer, Constants_Section); else AD.Printers.Open_Section (State.The_Printer, Variables_Section); end if; for I in Current .. N loop Add_To_Index (State, Items (Index (I)).Element, Items (Index (I)).Is_Private); Write_Object (Items, Index (I), State); Items (Index (I)).Done := True; end loop; if Class = Item_Constant then AD.Printers.Close_Section (State.The_Printer, Constants_Section); else AD.Printers.Close_Section (State.The_Printer, Variables_Section); end if; Current := N + 1; end if; end Handle_Objects; ---------------------------------------------------------------------------- -- Produce a cross-ref table of all exceptions declared in the package. procedure Handle_Exceptions (Items : in out Item_Table; Index : in out Index_Table; Current : in out Natural; State : in out Scan_State) is procedure Write_Exception (Exc : in Item_Desc; State : in out Scan_State) is function Unwind_Renames (Decl : in Declaration) return Asis.Element is -- Corresponding_Base_Entity sometimes returns an expression in -- an implicit spec due to an instantiation, in which case things -- get pretty hairy (see comment below). This routine never -- returns implicit things, but always the expression from the -- template. D : Asis.Element := Decl; B : Asis.Element; begin loop B := Renamed_Entity (D); D := Asis2.Declarations.Name_Definition (B); if Is_Part_Of_Instance (D) then -- Get the name in the template! D := Asis2.Declarations.Enclosing_Declaration (AD.Queries.Expand_Generic (D, State.Reporter'Access)); end if; exit when Declaration_Kind (D) /= An_Exception_Renaming_Declaration; end loop; return B; end Unwind_Renames; Original : Scan_State := State; begin AD.Printers.Open_Section (State.The_Printer, Exception_Section); declare Names : constant Name_List := A_D.Names (Exc.Element); begin for I in Names'Range loop AD.Printers.Add_Exception (State.The_Printer, AD.Crossrefs.Crossref_Name (Names (I), State.Unit, State.Reporter'Access)); end loop; end; if Declaration_Kind (Exc.Element) = An_Exception_Renaming_Declaration then declare Direct_Rename : constant Asis.Expression := Renamed_Entity (Exc.Element); Ctrl : Traverse_Control := Continue; begin State.Write_From := Start (Get_Span (Direct_Rename)); if not Is_Nil (State.Write_From) then State.Last_Written := (State.Write_From.Line, State.Write_From.Column - 1); AD.Printers.Open_Section (State.The_Printer, Exception_Rename_Section); -- Never generate a newline: State.Traverse_Top := Direct_Rename; Traverse (Direct_Rename, Ctrl, State); AD.Printers.Close_Section (State.The_Printer, Exception_Rename_Section); declare Ultimately : constant Asis.Element := Unwind_Renames (Exc.Element); -- Corresponding_Base_Entity may return an expression -- in an implicit generic spec due to an instantiation, -- and to get the true element from the generic template, -- we'd have to go out of our way an first find the -- declaration containing the expression, and then do -- Renamed_Entity (Enclosing_Declaration -- (Expand_Generic (Get_Name (Decl)))). -- It took me a while to figure that one out, and in the -- meantime, I already had 'Unwind_Renames' written, so -- I prefer to stick with my own routine. begin if not Is_Equal (Ultimately, Direct_Rename) then State.Write_From := Start (Get_Span (Ultimately)); if not Is_Nil (State.Write_From) then State.Last_Written := (State.Write_From.Line, State.Write_From.Column - 1); -- The text may be in some other unit! State.Unit := Unit_Declaration (Enclosing_Compilation_Unit (Ultimately)); AD.Printers.Open_Section (State.The_Printer, Ultimate_Exception_Section); Ctrl := Continue; -- Never generate a newline: State.Traverse_Top := Ultimately; Traverse (Ultimately, Ctrl, State); AD.Printers.Close_Section (State.The_Printer, Ultimate_Exception_Section); end if; end if; end; end if; end; end if; State := Original; if Exc.List /= null then AD.Printers.Open_Section (State.The_Printer, Description_Section); Write_Comments (Exc.Element, Exc.List, State); AD.Printers.Close_Section (State.The_Printer, Description_Section); end if; AD.Printers.Close_Section (State.The_Printer, Exception_Section); State := Original; end Write_Exception; N : Natural; begin N := Current; while N <= Index'Last and then Items (Index (N)).Class = Item_Exception and then not Items (Index (N)).Is_Private loop N := N + 1; end loop; -- Only visible ones! N := N - 1; if N >= Current then Sort_By_Name (Items, Index (Current .. N)); AD.Printers.Open_Section (State.The_Printer, Exceptions_Section); for I in Current .. N loop Add_To_Index (State, Items (Index (I)).Element, Items (Index (I)).Is_Private); Write_Exception (Items (Index (I)), State); Items (Index (I)).Done := True; end loop; AD.Printers.Close_Section (State.The_Printer, Exceptions_Section); Current := N + 1; end if; end Handle_Exceptions; ---------------------------------------------------------------------------- -- Produce a cross-ref table of all types declared in the package. Translation : constant array (AD.Queries.Operation_Kind) of AD.Printers.Operation_Kind := (AD.Queries.Overridden_Operation => AD.Printers.Overridden_Operation, AD.Queries.New_Operation => AD.Printers.Own_Operation, AD.Queries.Inherited_Operation => AD.Printers.Inherited_Operation, AD.Queries.Inherited_Original_Operation => AD.Printers.Inherited_Original_Operation ); procedure Handle_Types (Element : in Asis.Element; State : in out Scan_State) is -- Generate a cross-referenced table of all types and their primitive -- operations. 'Element' is a top-level package declaration. Note: we -- only include the visible types, and we also do not include subtype -- declarations in the per-unit type index. procedure Write_Type (Decl : in Declaration; State : in out Scan_State) is use type AD.Queries.Operation_Kind; procedure Write (Ops : in AD.Queries.Operation_List; I : in out Natural; Kind : in AD.Queries.Operation_Kind; State : in out Scan_State) is Header_Written : Boolean := False; begin while I <= Ops'Last and then Ops (I).Kind = Kind loop if not Header_Written then AD.Printers.Open_Operation_List (State.The_Printer, Translation (Kind)); Header_Written := True; end if; AD.Printers.Add_Type_Operation (State.The_Printer, AD.Crossrefs.Crossref_Name (Get_Name (Ops (I).Decl), State.Unit, State.Reporter'Access)); I := I + 1; end loop; if Header_Written then AD.Printers.Close_Operation_List (State.The_Printer); end if; end Write; function Smaller (Left, Right : in AD.Queries.Operation_Description) return Boolean is begin if Left.Kind /= Right.Kind then return Left.Kind < Right.Kind; else return Smaller_Name (Left.Decl, Right.Decl); end if; end Smaller; procedure Sort is new GAL.Sorting.Sort_G (Positive, AD.Queries.Operation_Description, AD.Queries.Operation_List, Smaller); procedure Purge (Ops : in out AD.Queries.Operation_List; Last : out Natural) is -- Remove all 'Inherited_Original_Operation's that are not in an -- application defined unit. Change all others to simple -- 'Inherited_Operations'. Set 'Last' to reflect the last index -- still containing a valid operation. I : Natural; procedure Swap is new GAL.Support.Swap (AD.Queries.Operation_Description); begin Last := Ops'Last; I := Ops'First; while I <= Last loop if Ops (I).Kind = AD.Queries.Inherited_Original_Operation then -- if Unit_Origin -- (Enclosing_Compilation_Unit (Ops (I).Decl)) /= -- An_Application_Unit if not AD.Crossrefs.Crossref_To_Unit (Enclosing_Compilation_Unit (Ops (I).Decl)) then if I < Last then Swap (Ops (I), Ops (Last)); end if; Last := Last - 1; else Ops (I).Kind := AD.Queries.Inherited_Operation; I := I + 1; end if; else I := I + 1; end if; end loop; end Purge; begin -- Write_Type declare XRef : AD.Crossrefs.Cross_Reference := AD.Crossrefs.Crossref_Name (Get_Name (Decl), State.Unit, State.Reporter'Access); begin AD.Printers.Open_Section (State.The_Printer, Type_Section); AD.Printers.Type_Name (State.The_Printer, XRef); end; case Declaration_Kind (Decl) is when A_Task_Type_Declaration => AD.Printers.Type_Kind (State.The_Printer, "task type"); when A_Protected_Type_Declaration => AD.Printers.Type_Kind (State.The_Printer, "protected type"); when An_Incomplete_Type_Declaration => -- Actually this shouldn't ever happen. We can have an -- incomplete type here only if we're in the private part of -- a package spec, but we don't traverse those anyway. AD.Printers.Type_Kind (State.The_Printer, "incomplete type"); AD.Printers.Close_Section (State.The_Printer, Type_Section); return; when others => case Trait_Kind (Decl) is when A_Limited_Trait | A_Limited_Private_Trait => AD.Printers.Type_Kind (State.The_Printer, "limited type"); when An_Abstract_Trait | An_Abstract_Private_Trait => AD.Printers.Type_Kind (State.The_Printer, "abstract type"); when An_Abstract_Limited_Trait | An_Abstract_Limited_Private_Trait => AD.Printers.Type_Kind (State.The_Printer, "abstract limited type"); when others => null; end case; end case; declare Parent : constant Declaration := AD.Queries.Ancestor_Type (Decl); Primitives : AD.Queries.Operation_List := AD.Queries.Primitive_Operations (Decl); I : Natural; Last : Natural; begin if not Is_Nil (Parent) then AD.Printers.Parent_Type (State.The_Printer, AD.Crossrefs.Crossref_Name (Get_Name (Parent), State.Unit, State.Reporter'Access)); end if; if Primitives'Last >= Primitives'First then Purge (Primitives, Last); if Last >= Primitives'First then Sort (Primitives (Primitives'First .. Last)); I := Primitives'First; AD.Printers.Open_Section (State.The_Printer, Operations_Section); for Kind in AD.Queries.Operation_Kind loop Write (Primitives (Primitives'First .. Last), I, Kind, State); end loop; AD.Printers.Close_Section (State.The_Printer, Operations_Section); end if; end if; end; AD.Printers.Close_Section (State.The_Printer, Type_Section); end Write_Type; function Is_A_Type_Declaration (Kind : in Declaration_Kinds) return Boolean is begin return Kind in A_Type_Declaration; -- This does *not* include subtypes! end Is_A_Type_Declaration; function Extract_Types is new Extract_Declarations (Is_A_Type_Declaration); Types : constant Declarative_Item_List := Extract_Types (Visible_Part_Declarative_Items (Element, False), True); -- Collects all the types from the visible declarations. begin if Types'Last >= Types'First then AD.Printers.Open_Section (State.The_Printer, Type_Summary_Section); for I in Types'Range loop if Declaration_Kind (Types (I)) = An_Incomplete_Type_Declaration then -- The next one *must* be the full type declaration. Hence -- just skip the incomplete type decl. if I = Types'Last or else not Is_Equal (Types (I + 1), Corresponding_Type_Declaration (Types (I))) then -- Actually, we shouldn't ever get here, because incomplete -- types without completion are allowed in the private part -- of a package spec only, and we don't traverse that in -- the first place. Write_Type (Types (I), State); end if; else Write_Type (Types (I), State); end if; end loop; AD.Printers.Close_Section (State.The_Printer, Type_Summary_Section); end if; end Handle_Types; ---------------------------------------------------------------------------- procedure Handle_Declaration (Items : in Item_Table; Current : in Natural; State : in out Scan_State; Is_Last : in Boolean; Top_Level : in Boolean := False) is procedure Write_Generic_Formals (Decl : in Declaration; State : in out Scan_State) is -- Write the generic formals, if any. begin case Declaration_Kind (Decl) is when A_Generic_Package_Declaration | A_Generic_Function_Declaration | A_Generic_Procedure_Declaration => declare Ctrl : Traverse_Control; Generic_Formals : constant Element_List := Generic_Formal_Part (Decl, True); begin for I in Generic_Formals'Range loop Ctrl := Continue; -- Never suppress any newlines: State.Traverse_Top := Nil_Element; Traverse (Generic_Formals (I), Ctrl, State); end loop; end; when others => null; end case; end Write_Generic_Formals; procedure Write_Container (Items : in Item_Table; Current : in Natural; State : in out Scan_State; Is_Last : in Boolean; Top_Level : in Boolean) is Old_Indent : constant Character_Position := State.Indent; Kind : constant Declaration_Kinds := Declaration_Kind (Items (Current).Element); Table_Opened : Boolean := False; Contained_Items : Item_Table := Find_Items (Items (Current).Element); For_Container : Natural; begin Group_Items (Contained_Items, For_Container); Add_To_Index (State, Items (Current).Element, Items (Current).Is_Private); declare Name : Defining_Name := Get_Name (Items (Current).Element); begin if Defining_Name_Kind (Name) = A_Defining_Expanded_Name then Name := Defining_Selector (Name); end if; AD.Printers.Open_Container (State.The_Printer, AD.Crossrefs.Crossref_Name (Name, State.Unit, State.Reporter'Access), Get_Item_Kind (Items (Current).Element), Get_Single_Name (Items (Current).Element)); end; AD.Printers.Open_Section (State.The_Printer, Header_Section); declare Pos : Position := Start (Get_Span (Items (Current).Element)); begin if Pos.Line = 1 then Pos.Column := 1; end if; State.Write_From := Pos; State.Last_Written := (Pos.Line, Pos.Column - 1); State.Indent := Pos.Column - 1; end; Write_Generic_Formals (Items (Current).Element, State); -- Complete the header: write everything up to and including the -- defining name, then write everything up to and including the -- "is", and then write all following items belonging to this one. -- Finally, write the comments for all items (excluding the current -- item (and the context clauses) if we're on top level. declare Name : constant Defining_Name := Get_Name (Items (Current).Element); Ctrl : Traverse_Control := Continue; begin State.Traverse_Top := Nil_Element; Handle_Defining_Name (Name, Ctrl, State); Terminate_Line (State); -- If it's a task or protected type, it may have discriminants -- here... if Kind = A_Task_Type_Declaration or else Kind = A_Protected_Type_Declaration then declare Discriminants : constant Asis.Element := Discriminant_Part (Items (Current).Element); Ctrl : Traverse_Control := Continue; begin if not Is_Nil (Discriminants) then -- Never suppress any newlines: State.Traverse_Top := Nil_Element; Traverse (Discriminants, Ctrl, State); end if; end; end if; -- Find the 'is' and write it. declare To_Write : A_T.Span := Through (State.Unit, "is", From => State.Last_Written); begin Set_Start (To_Write, State.Write_From); Write_Span (To_Write, State); New_Line (State.The_Printer); end; end; AD.Printers.Close_Section (State.The_Printer, Header_Section); -- Now write any object belonging to this one (rep clauses, pragmas), -- and then write the comments, if any. declare Index : Index_Table := (1 => Current) & Collect_Subordinates (Items, Contained_Items, Items (Current).Sub, For_Container); Ctrl : Traverse_Control; begin if Index'Last > Index'First then AD.Printers.Open_Section (State.The_Printer, Content_Section); AD.Printers.Open_Section (State.The_Printer, Top_Item_Section); AD.Printers.Open_Section (State.The_Printer, Snippet_Section); Table_Opened := True; Sort_Subordinates (Index (Index'First + 1 .. Index'Last), Items, Contained_Items); for I in Index'First + 1 .. Index'Last loop declare This : Asis.Element; begin if Index (I) < 0 then This := Contained_Items (-Index (I)).Element; else This := Items (Index (I)).Element; end if; -- TBD: Produce anchor; add to index declare Pos : Position := Start (Get_Span (This)); begin if Pos.Line = 1 then Pos.Column := 1; end if; State.Write_From := Pos; State.Last_Written := (Pos.Line, Pos.Column - 1); State.Indent := Pos.Column - 1; end; Ctrl := Continue; State.Traverse_Top := This; Traverse (This, Ctrl, State); end; if I < Index'Last then New_Line (State.The_Printer); end if; end loop; AD.Printers.Close_Section (State.The_Printer, Snippet_Section); end if; -- First check that we do have comments: declare Have_Comments : Boolean := False; From : Natural; begin if Top_Level then From := Index'First + 1; else From := Index'First; end if; for I in From .. Index'Last loop if (Index (I) > 0 and then Items (Index (I)).List /= null) or else (Index (I) < 0 and then Contained_Items (-Index (I)).List /= null) then Have_Comments := True; exit; end if; end loop; if Have_Comments then if not Table_Opened then AD.Printers.Open_Section (State.The_Printer, Content_Section); AD.Printers.Open_Section (State.The_Printer, Top_Item_Section); Table_Opened := True; end if; AD.Printers.Open_Section (State.The_Printer, Description_Section); for I in From .. Index'Last loop if Index (I) > 0 then Write_Comments (Items (Index (I)).Element, Items (Index (I)).List, State); else Write_Comments (Contained_Items (-Index (I)).Element, Contained_Items (-Index (I)).List, State); end if; end loop; AD.Printers.Close_Section (State.The_Printer, Description_Section); end if; end; end; if Table_Opened then AD.Printers.Close_Section (State.The_Printer, Top_Item_Section); end if; -- And now go into it: declare Curr : Natural; In_Private : Boolean := False; Is_Package : constant Boolean := Kind = A_Generic_Package_Declaration or else Kind = A_Package_Declaration; Contained_Index : Index_Table := Build_Index (Contained_Items); begin if Is_Package and then Top_Level then Handle_Children (Enclosing_Compilation_Unit (Items (Current).Element), State, Table_Opened); end if; if Contained_Index'Last >= Contained_Index'First then if not Table_Opened then AD.Printers.Open_Section (State.The_Printer, Content_Section); Table_Opened := True; end if; Sort_Index (Contained_Items, Contained_Index); Curr := Contained_Index'First; if Is_Package then Handle_Exceptions (Contained_Items, Contained_Index, Curr, State); Handle_Types (Items (Current).Element, State); Handle_Objects (Contained_Items, Contained_Index, Curr, State, Item_Constant); Handle_Objects (Contained_Items, Contained_Index, Curr, State, Item_Object); end if; if Curr <= Contained_Index'Last then AD.Printers.Open_Section (State.The_Printer, Others_Section); while Curr <= Contained_Index'Last loop if Contained_Items (Contained_Index (Curr)).Is_Private then if not In_Private then AD.Printers.Add_Private (State.The_Printer, False); end if; In_Private := True; end if; Handle_Declaration (Contained_Items, Contained_Index (Curr), State, Curr = Contained_Index'Last); Curr := Curr + 1; end loop; AD.Printers.Close_Section (State.The_Printer, Others_Section); end if; Clear_Table (Contained_Items); end if; if not AD.Options.Private_Too and then Asis2.Container_Elements.Has_Private (Items (Current).Element) then if not Table_Opened then AD.Printers.Open_Section (State.The_Printer, Content_Section); Table_Opened := True; end if; AD.Printers.Add_Private (State.The_Printer, True); end if; if Table_Opened then AD.Printers.Close_Section (State.The_Printer, Content_Section); end if; end; -- Find the closing 'end': AD.Printers.Open_Section (State.The_Printer, Footer_Section); AD.Printers.Dump (State.The_Printer, "end "); -- Now write the name again (even if it didn't appear in the -- source!) declare Names : constant Name_List := A_D.Names (Items (Current).Element); Span : constant A_T.Span := Get_Span (Names (Names'First)); Ctrl : Traverse_Control := Continue; begin -- Now be careful to pretend that we're at the beginning, -- and that we have written everything on that same line -- before the name itself. State.Write_From := Start (Span); State.Last_Written := (State.Write_From.Line, State.Write_From.Column - 1); Handle_Defining_Name (Names (Names'First), Ctrl, State, False); AD.Printers.Dump (State.The_Printer, ";"); end; AD.Printers.Close_Section (State.The_Printer, Footer_Section); AD.Printers.Close_Container (State.The_Printer, Is_Last and then not Top_Level); State.Indent := Old_Indent; end Write_Container; procedure Write_Item (Items : in Item_Table; Current : in Natural; State : in out Scan_State; Is_Last : in Boolean; Top_Level : in Boolean) is Old_Indent : constant Character_Position := State.Indent; Kind : constant AD.Printers.Item_Kind := AD.Printers.Get_Item_Kind (Items (Current).Element); use type AD.Printers.Item_Kind; begin if Kind not in AD.Printers.Declaration_Item_Kind then AD.Printers.Open_Item (State.The_Printer, AD.Crossrefs.Null_Crossref, Kind); -- TBD: Produce anchor, add to indices. else Add_To_Index (State, Items (Current).Element, Items (Current).Is_Private); declare Name : Defining_Name := Get_Name (Items (Current).Element); begin if Defining_Name_Kind (Name) = A_Defining_Expanded_Name then Name := Defining_Selector (Name); end if; AD.Printers.Open_Item (State.The_Printer, AD.Crossrefs.Crossref_Name (Name, State.Unit, State.Reporter'Access), Kind, Get_Single_Name (Items (Current).Element)); end; end if; Write_Item (Items, Current, State, Top_Level); AD.Printers.Close_Item (State.The_Printer, Is_Last); State.Indent := Old_Indent; end Write_Item; begin if Top_Level then if Items (Current).List /= null then AD.Printers.Open_Section (State.The_Printer, Description_Section); Write_Comments (State.Unit, Items (Current).List, State); AD.Printers.Close_Section (State.The_Printer, Description_Section); end if; end if; if Is_Container (Items (Current).Class) then Write_Container (Items, Current, State, Is_Last, Top_Level); else Write_Item (Items, Current, State, Is_Last, Top_Level); end if; end Handle_Declaration; ---------------------------------------------------------------------------- procedure Handle_Defining_Name (Element : in Defining_Name; Control : in out Traverse_Control; State : in out Scan_State; Do_Anchor : in Boolean := True) is -- Generate an anchor for a defining name, so that it can be cross- -- referenced. Name : Defining_Name := Element; begin if Defining_Name_Kind (Name) = A_Defining_Expanded_Name then -- Try to generate cross-references for the prefix! (Fails some- -- times on Asis 2.0.R for GNAT 3.13p; the failure is handled in -- 'AD.Writers.Write_Reference'). Traverse (Defining_Prefix (Name), Control, State); Name := Defining_Selector (Name); end if; if Do_Anchor then Write_Name (Name, State); else Write (Name, State); end if; Control := Abandon_Children; end Handle_Defining_Name; ---------------------------------------------------------------------------- -- The only exported routine. procedure Scan (The_Unit : in Compilation_Unit; The_Printer : in AD.Printers.Printer_Ref) is -- Produce an HTML rendering of the given compilation unit. State : Scan_State; begin State.The_Printer := The_Printer; State.Reporter.The_Printer := The_Printer; State.Unit := Unit_Declaration (The_Unit); State.Write_From := Start (Compilation_Unit_Span (State.Unit)); -- Asis 2.0.R for GNAT 3.13p has a problem if the unit starts at the -- very beginning with a clause: the column is set to an arbitrary -- value. The above therefore sometimes causes some stuff at the very -- beginning not to be written. Correct that! -- -- This error seems to be corrected in the 3.14p version. if State.Write_From.Line = 1 then State.Write_From.Column := 1; end if; State.Indent := 0; declare Name : Defining_Name := Asis2.Naming.Get_Name (State.Unit); begin if Defining_Name_Kind (Name) = A_Defining_Expanded_Name then Name := Defining_Selector (Name); end if; AD.Printers.Open_Unit (State.The_Printer, AD.Printers.Get_Item_Kind (State.Unit), Full_Unit_Name (The_Unit), Unit_Class (The_Unit) = A_Private_Declaration, AD.Crossrefs.Crossref_Name (Name, State.Unit, State.Reporter'Access)); end; declare Items : Item_Table := Find_Items (The_Unit); Curr : Natural; begin if Items (Items'First).Is_Clause then Handle_Clauses (The_Unit, State, Items (Items'First)); Curr := Items'First + 1; else Curr := Items'First; end if; declare Index : constant Index_Table := Build_Index (Items (Curr .. Items'Last)); begin for I in Index'Range loop Handle_Declaration (Items, Index (I), State, Is_Last => I = Index'Last, Top_Level => True); end loop; end; Clear_Table (Items); Clear_Comments; end; AD.Printers.Close_Unit (State.The_Printer); end Scan; ---------------------------------------------------------------------------- end AD.Scanner; adabrowse_4.0.3/util.ads0000644000175000017500000000340310234241447013332 0ustar kenken------------------------------------------------------------------------------- -- -- Copyright © 2001, 2002 by Thomas Wolf. --
-- This piece of software is free software; you can redistribute it and/or -- modify it under the terms of the GNU General Public License as published -- by the Free Software Foundation; either version 2, or (at your option) -- any later version. This software is distributed in the hope that it will -- be useful, but without any warranty; without even the implied -- warranty of merchantability or fitness for a particular purpose. -- See the GNU General Public License for more details. You should have -- received a copy of the GNU General Public License with this distribution, -- see file "GPL.txt". If not, write to the Free -- Software Foundation, 59 Temple Place - Suite 330, Boston, MA 02111-1307, -- USA. --
--
-- As a special exception from the GPL, if other files instantiate generics -- from this unit, or you link this unit with other files to produce an -- executable, this unit does not by itself cause the resulting executable -- to be covered by the GPL. This exception does not however invalidate any -- other reasons why the executable file might be covered by the GPL. --
-- -- -- Thomas Wolf (TW) -- -- -- -- Root package of the utilities library. -- -- -- -- 28-FEB-2002 TW Initial version. -- ------------------------------------------------------------------------------- pragma License (Modified_GPL); package Util is pragma Pure; -- This package is empty. end Util; adabrowse_4.0.3/adabrowse.adb0000644000175000017500000000305010234241452014275 0ustar kenken------------------------------------------------------------------------------- -- -- This file is part of AdaBrowse. -- -- Copyright (c) 2002 by Thomas Wolf. --
-- AdaBrowse is free software; you can redistribute it and/or modify it -- under the terms of the GNU General Public License as published by the -- Free Software Foundation; either version 2, or (at your option) any -- later version. AdaBrowse is distributed in the hope that it will be -- useful, but without any warranty; without even the implied -- warranty of merchantability or fitness for a particular purpose. -- See the GNU General Public License for more details. You should have -- received a copy of the GNU General Public License with this distribution, -- see file "GPL.txt". If not, write to the Free -- Software Foundation, 59 Temple Place - Suite 330, Boston, MA 02111-1307, -- USA. --
-- --
-- Author:
-- Thomas Wolf (TW) --
twolf@acm.org
-- --
-- Purpose:
-- Main procedure of AdaBrowse.
-- -- ------------------------------------------------------------------------------- pragma License (GPL); with AD.Driver; procedure AdaBrowse is begin AD.Driver.Main; end AdaBrowse; adabrowse_4.0.3/gal-adt-hash_tables.ads0000644000175000017500000003706610234241445016153 0ustar kenken------------------------------------------------------------------------------- -- -- Copyright © 2001, 2002 by Thomas Wolf. --
-- This piece of software is free software; you can redistribute it and/or -- modify it under the terms of the GNU General Public License as published -- by the Free Software Foundation; either version 2, or (at your option) -- any later version. This software is distributed in the hope that it will -- be useful, but without any warranty; without even the implied -- warranty of merchantability or fitness for a particular purpose. -- See the GNU General Public License for more details. You should have -- received a copy of the GNU General Public License with this distribution, -- see file "GPL.txt". If not, write to the Free -- Software Foundation, 59 Temple Place - Suite 330, Boston, MA 02111-1307, -- USA. --
--
-- As a special exception from the GPL, if other files instantiate generics -- from this unit, or you link this unit with other files to produce an -- executable, this unit does not by itself cause the resulting executable -- to be covered by the GPL. This exception does not however invalidate any -- other reasons why the executable file might be covered by the GPL. --
-- -- -- Thomas Wolf (TW) -- -- -- -- Provides dynamic hash tables. Internal collision resolution, automatic -- and explicit resizing. Collision chain index computation can be -- customized though @Collision_Policies@. -- -- -- -- -- -- -- -- 20-DEC-2001 TW Initial version. -- 28-DEC-2001 TW Added growth policies. -- 24-APR-2002 TW Added the 'Choose_Size' generic formal function. -- ------------------------------------------------------------------------------- pragma License (Modified_GPL); with Ada.Finalization; with Ada.Streams; with GAL.Storage.Memory; with GAL.Support.Hashing; generic type Key_Type (<>) is private; type Item (<>) is private; with package Memory is new GAL.Storage.Memory (<>); Initial_Size : in GAL.Support.Hashing.Size_Type := 23; with function Hash (Element : in Key_Type) return GAL.Support.Hashing.Hash_Type is <>; with function "=" (Left, Right : in Key_Type) return Boolean is <>; with function Choose_Size (Suggested : in GAL.Support.Hashing.Hash_Type) return GAL.Support.Hashing.Hash_Type is GAL.Support.Hashing.Next_Prime; -- This function is called whenever the size of the hash table is to be -- defined. 'Suggested' is the suggested size of the new table; the -- function should then return a size that is >= Suggested. If it -- returns a smaller value anyway, the exception 'Container_Error' is -- raised. package GAL.ADT.Hash_Tables is pragma Elaborate_Body; ---------------------------------------------------------------------------- -- Exception renamings to facilitate usage of this package. Container_Empty : exception renames GAL.ADT.Container_Empty; Container_Full : exception renames GAL.ADT.Container_Full; Range_Error : exception renames GAL.ADT.Range_Error; Not_Found : exception renames GAL.ADT.Not_Found; Duplicate_Key : exception renames GAL.ADT.Duplicate_Key; Hash_Table_Empty : exception renames Container_Empty; Hash_Table_Full : exception renames Container_Full; Container_Error : exception renames GAL.ADT.Container_Error; ---------------------------------------------------------------------------- type Hash_Table is private; -- Hash tables are initially empty; no storage allocation occurs yet. -- Virgin hash tables do not resize themselves when full! -- -- Some routines specify explicit (minimum) sizes for a hash table. Note -- that an implementation is free to choose a larger size if it so -- desires. Null_Hash_Table : constant Hash_Table; type Item_Ptr is access all Item; for Item_Ptr'Storage_Size use 0; ---------------------------------------------------------------------------- procedure Swap (Left, Right : in out Hash_Table); -- Exchanges the two tables without making a temporary copy. ---------------------------------------------------------------------------- procedure Insert (Table : in out Hash_Table; Key : in Key_Type; Element : in Item); -- Raises @Container_Full@ if the hash table is full and automatic resizing -- is off (the table's resize load factor is 0.0), and @Duplicate_Key@ if -- if an item with an equal key already is in the table. procedure Insert (Table : in out Hash_Table; Key : in Key_Type; Element : access Item); ---------------------------------------------------------------------------- procedure Replace (Table : in out Hash_Table; Key : in Key_Type; Element : in Item); -- If the key already exists in the hash table, replaces the associated -- item. Otherwise inserts the element and its key. procedure Replace (Table : in out Hash_Table; Key : in Key_Type; Element : access Item); ---------------------------------------------------------------------------- procedure Delete (Table : in out Hash_Table; Key : in Key_Type); -- Raises @Container_Empty@ if the table is empty, and @Not_Found@ if the -- key is not in the table. procedure Delete (Table : in out Hash_Table; Key : in Key_Type; Element : out Item); ---------------------------------------------------------------------------- function Retrieve (Table : in Hash_Table; Key : in Key_Type) return Item; -- Raises @Container_Empty@ if the table is empty, and @Not_Found@ if the -- key is not in the table. function Contains (Table : in Hash_Table; Key : in Key_Type) return Boolean; -- Returns @False@ if the table is empty or the key is not in the table, -- @True@ if it is. ---------------------------------------------------------------------------- function Nof_Elements (Table : in Hash_Table) return GAL.Support.Hashing.Hash_Type; function Is_Empty (Table : in Hash_Table) return Boolean; function Load (Table : in Hash_Table) return GAL.Support.Hashing.Load_Factor; function Size (Table : in Hash_Table) return GAL.Support.Hashing.Hash_Type; ---------------------------------------------------------------------------- procedure Resize (Table : in out Hash_Table; New_Size : in GAL.Support.Hashing.Size_Type); -- Raises @Container_Error@ without modifying @Table@ if @New_Size@ is so -- small that the table couldn't hold all the elements it currently -- contains. -- -- An alternative would be not to change the table at all, without raising -- an exception. However, I think an attempt to shrink a hash table -- through @Resize@ below the current number of elements in the table -- should be seen as an application error. ---------------------------------------------------------------------------- procedure Reset (Table : in out Hash_Table); procedure Reset (Table : in out Hash_Table; New_Size : in GAL.Support.Hashing.Size_Type); procedure Reset (Table : in out Hash_Table; New_Size : in GAL.Support.Hashing.Size_Type; Resize_At : in GAL.Support.Hashing.Load_Factor); ---------------------------------------------------------------------------- procedure Merge (Result : in out Hash_Table; Source : in Hash_Table); -- Raises @Duplicate_Key@ without modifying @Result@ if @Source@ contains -- a key already in @Result@. procedure Merge (Result : in out Hash_Table; Source : in Hash_Table; Overwrite : in Boolean); -- Same as above, but different duplicate key handling: if @Overwrite@ is -- true, items already in @Result@ are overwritten by the items from -- @Source@; otherwise, the items in @Result@ remain unchanged. ---------------------------------------------------------------------------- -- Collision chain management. Every hash table has a collision policy; -- the default is to do double hashing. procedure Set_Collision_Policy (Table : in out Hash_Table; Policy : in GAL.Support.Hashing.Collision_Policy'Class); -- If @Table@ is not empty, this causes re-hashing! procedure Remove_Collision_Policy (Table : in out Hash_Table); -- If @Table@ is not empty, and the current policy is not already the -- default one, this causes re-hashing! procedure Set_Default_Collision_Policy (Table : in out Hash_Table) renames Remove_Collision_Policy; function Get_Collision_Policy (Table : in Hash_Table) return GAL.Support.Hashing.Collision_Policy'Class; -- Raises @Constraint_Error@ if the @Table@ does not have a collision -- policy, which implies that it has been assigned the @Null_Hash_Table@, -- and no insertions have yet taken place. ---------------------------------------------------------------------------- -- Growth management. See GAL.Containers.Vectors for more comments. By -- default, a hash table has no growth policy and therefore doesn't -- grow automatically but raises Container_Full in case (2) below. -- -- The increase operation is called to get the new size: -- -- 1. In 'Insert', if the resize load factor > 0.0 and the table's load -- would be greater after inserting. -- -- 2. In 'Insert', if no empty slot can be found. ---------------------------------------------------------------------------- procedure Set_Resize (Table : in out Hash_Table; Resize_At : in GAL.Support.Hashing.Load_Factor); -- If @Resize_At@ = 0.0, the table resizes only if it is full and a growth -- policy is set. procedure Set_Growth_Policy (Table : in out Hash_Table; Policy : in GAL.Support.Hashing.Growth_Policy'Class); -- Removes the current growth policy of @Table@ (if any), and installs a -- copy of @Policy@ as the table's new growth policy. procedure Remove_Growth_Policy (Table : in out Hash_Table); -- Removes the current growth policy of @Table@ (if any). procedure Set_Default_Growth_Policy (Table : in out Hash_Table) renames Remove_Growth_Policy; function Has_Growth_Policy (Table : in Hash_Table) return Boolean; -- Returns @True@ if a growth policy is defined for @Table@. function Get_Growth_Policy (Table : in Hash_Table) return GAL.Support.Hashing.Growth_Policy'Class; -- Raises @Constraint_Error@ if no growth policy has been set on @Table@. ---------------------------------------------------------------------------- -- Traversals: type Visitor is abstract tagged private; procedure Action (V : in out Visitor; Key : in Key_Type; Value : in out Item; Quit : in out Boolean); procedure Action (V : in out Visitor; Key : in Key_Type; Value : access Item; Quit : in out Boolean); procedure Traverse (Table : in Hash_Table; V : in out Visitor'Class; Reference : in Boolean := False); generic with procedure Execute (Key : in Key_Type; Value : in out Item; Quit : in out Boolean); procedure Traverse_G (Table : in Hash_Table); generic with procedure Execute (Key : in Key_Type; Value : access Item; Quit : in out Boolean); procedure Traverse_By_Reference_G (Table : in Hash_Table); ---------------------------------------------------------------------------- -- Comparisons function "=" (Left, Right : in Hash_Table) return Boolean; -- Returns true if the two hash tables contain the same number of elements -- with the same keys, False otherwise. generic with function "=" (Left, Right : in Item) return Boolean is <>; function Equals (Left, Right : in Hash_Table) return Boolean; -- Ditto, but also requires the values associated with the keys to be -- equal. ---------------------------------------------------------------------------- -- Unsafe pointer operations. All these operations return Item_Ptrs, which -- point directly into the list. Of course, such pointers are unsafe -- because they are not invalidated when the element pointed to is deleted. -- Item_Ptrs can thus become dangling, and any dereference of an Item_Ptr -- after the element pointed to has vanished is a bounded error. -- Nevertheless, Item_Ptrs are sometimes a convenient and efficient way -- to get at and work with the stored elements, especially if the element -- type is a large record. package Unsafe is function Retrieve (Table : in Hash_Table; Key : in Key_Type) return Item_Ptr; -- Returns @null@ if no such element exists in the hash table. end Unsafe; private function "=" (Left, Right : in Item) return Boolean is abstract; -- Make sure we don't use (the default) equality of items; we only want -- to use equality on keys! type Collision_Policy_Ptr is access all GAL.Support.Hashing.Collision_Policy'Class; for Collision_Policy_Ptr'Storage_Pool use Memory.Pool; type Growth_Policy_Ptr is access all GAL.Support.Hashing.Growth_Policy'Class; for Growth_Policy_Ptr'Storage_Pool use Memory.Pool; type Key_Ptr is access Key_Type; for Key_Ptr'Storage_Pool use Memory.Pool; type Data_Ptr is access all Item; for Data_Ptr'Storage_Pool use Memory.Pool; type Hash_State is (Empty, Deleted, Used); type Hash_Entry is record Key : Key_Ptr := null; Value : Data_Ptr := null; State : Hash_State := Empty; end record; type Mem is array (GAL.Support.Hashing.Hash_Type range <>) of Hash_Entry; type Ptr is access Mem; for Ptr'Storage_Pool use Memory.Pool; type Hash_Table is new Ada.Finalization.Controlled with record Count : GAL.Support.Hashing.Hash_Type := 0; Table : Ptr := null; Collisions : Collision_Policy_Ptr := null; Growth : Growth_Policy_Ptr := null; Resize_At : GAL.Support.Hashing.Load_Factor := 0.0; Initial_Size : GAL.Support.Hashing.Size_Type := GAL.ADT.Hash_Tables.Initial_Size; end record; procedure Adjust (Table : in out Hash_Table); procedure Finalize (Table : in out Hash_Table); -- Stream support: procedure Write (Stream : access Ada.Streams.Root_Stream_Type'Class; Table : in Hash_Table); procedure Read (Stream : access Ada.Streams.Root_Stream_Type'Class; Table : out Hash_Table); for Hash_Table'Write use Write; for Hash_Table'Read use Read; Null_Hash_Table : constant Hash_Table := (Ada.Finalization.Controlled with Count => 0, Table => null, Collisions => null, Growth => null, Resize_At => 0.0, Initial_Size => 1); pragma Inline (Insert, Replace); type Visitor is abstract tagged null record; end GAL.ADT.Hash_Tables; adabrowse_4.0.3/ad-known_units.adb0000644000175000017500000001217610234241450015275 0ustar kenken------------------------------------------------------------------------------- -- -- This file is part of AdaBrowse. -- -- Copyright (c) 2002 by Thomas Wolf. --
-- AdaBrowse is free software; you can redistribute it and/or modify it -- under the terms of the GNU General Public License as published by the -- Free Software Foundation; either version 2, or (at your option) any -- later version. AdaBrowse is distributed in the hope that it will be -- useful, but without any warranty; without even the implied -- warranty of merchantability or fitness for a particular purpose. -- See the GNU General Public License for more details. You should have -- received a copy of the GNU General Public License with this distribution, -- see file "GPL.txt". If not, write to the Free -- Software Foundation, 59 Temple Place - Suite 330, Boston, MA 02111-1307, -- USA. --
-- --
-- Author:
-- Thomas Wolf (TW) --
twolf@acm.org
-- --
-- Purpose:
-- Keeps a list of known filename/unitname pairs.
-- -- ------------------------------------------------------------------------------- pragma License (GPL); with GAL.ADT.Hash_Tables; with GAL.Support.Hashing; with GAL.Storage.Standard; pragma Elaborate_All (GAL.ADT.Hash_Tables); with Util.Pathes; with Util.Strings; package body AD.Known_Units is package ASU renames Ada.Strings.Unbounded; -- All right. We need several different access methods: -- case sensitive first, then case insensitive. Exact match, and -- basename match. We hash on the greatest common denominator: the -- case insensitive base name. Prefix : Boolean := False; Case_Insensitive : Boolean := False; function Equal (Left, Right : in String) return Boolean is function Match (Left, Right : in String) return Boolean is begin if not Case_Insensitive then return Left = Right; else return Util.Strings.Equal (Left, Right); end if; end Match; use Util.Pathes; begin -- Equal if Prefix then return Match (Base_Name (Left), Base_Name (Right)); else return Match (Left, Right); end if; end Equal; function Hash (S : in String) return GAL.Support.Hashing.Hash_Type is use Util.Pathes; begin return GAL.Support.Hashing.Hash_Case_Insensitive (Base_Name (S)); end Hash; type Unit_Desc is record File, Path, Unit : ASU.Unbounded_String; end record; package Units is new GAL.ADT.Hash_Tables (Key_Type => String, Item => Unit_Desc, Memory => GAL.Storage.Standard, Hash => Hash, "=" => Equal); Known : Units.Hash_Table; procedure Add (File_Name : in String; Unit_Name : in String) is New_Entry : Unit_Desc; The_Name : constant String := Util.Pathes.Name (File_Name); begin Prefix := False; Case_Insensitive := False; New_Entry.File := ASU.To_Unbounded_String (The_Name); New_Entry.Path := ASU.To_Unbounded_String (Util.Pathes.Path (File_Name)); New_Entry.Unit := ASU.To_Unbounded_String (Unit_Name); Units.Insert (Known, The_Name, New_Entry); exception when Units.Duplicate_Key => null; end Add; procedure Find (Given_File_Name : in String; Stored_File_Name : out Ada.Strings.Unbounded.Unbounded_String; Stored_Path : out Ada.Strings.Unbounded.Unbounded_String; Unit_Name : out Ada.Strings.Unbounded.Unbounded_String) is procedure Get (Key : in String; Found : out Boolean) is Item : Unit_Desc; begin Item := Units.Retrieve (Known, Key); Stored_File_Name := Item.File; Stored_Path := Item.Path; Unit_Name := Item.Unit; Found := True; exception when Units.Not_Found => Found := False; end Get; Found : Boolean; use Util.Pathes; The_Name : constant String := Name (Given_File_Name); begin Stored_File_Name := ASU.Null_Unbounded_String; Unit_Name := ASU.Null_Unbounded_String; if not Units.Is_Empty (Known) then for B in Boolean loop Prefix := False; Case_Insensitive := B; Get (The_Name, Found); if Found then return; end if; Get (Replace_Extension (The_Name, "ads"), Found); if Found then return; end if; Prefix := True; Get (Base_Name (The_Name), Found); if Found then return; end if; end loop; end if; end Find; begin Units.Set_Resize (Known, 0.75); declare Linear_Growth : GAL.Support.Hashing.Linear_Growth_Policy (50); begin Units.Set_Growth_Policy (Known, Linear_Growth); end; end AD.Known_Units; adabrowse_4.0.3/asis2-naming.ads0000644000175000017500000001203610234241445014645 0ustar kenken------------------------------------------------------------------------------- -- -- This unit is part of the @Asis2@ ASIS secondary library. -- -- Copyright (c) 2002, 2003 by Thomas Wolf. --
-- AdaBrowse is free software; you can redistribute it and/or modify it -- under the terms of the GNU General Public License as published by the -- Free Software Foundation; either version 2, or (at your option) any -- later version. AdaBrowse is distributed in the hope that it will be -- useful, but without any warranty; without even the implied -- warranty of merchantability or fitness for a particular purpose. -- See the GNU General Public License for more details. You should have -- received a copy of the GNU General Public License with this distribution, -- see file "GPL.txt". If not, write to the Free -- Software Foundation, 59 Temple Place - Suite 330, Boston, MA 02111-1307, -- USA. --
--
-- As a special exception from the GPL, if other files instantiate generics -- from this unit, or you link this unit with other files to produce an -- executable, this unit does not by itself cause the resulting executable -- to be covered by the GPL. This exception does not however invalidate any -- other reasons why the executable file might be covered by the GPL. --
-- -- -- Thomas Wolf (TW) -- -- -- -- Utility routines operating on naming expressions and defining names. -- -- -- -- 08-JUL-2003 TW Last release as part of @AdaBrowse@. -- 18-JUL-2003 TW Created from operations in @AD.Queries@. -- ------------------------------------------------------------------------------- pragma License (Modified_GPL); with Asis; package Asis2.Naming is pragma Elaborate_Body; procedure Verify_Name_Definition (Def : in out Asis.Defining_Name; Name : in Asis.Expression); -- Needed to correct bugs in ASIS-for-GNAT, which sometimes gets confused -- and finds the wrong name definitions when given an expression. @Def@ -- and @Name@ should be simple names. If their images are equal or differ -- only in casing, nothing is changed; otherwise, @Def@ is set to a -- @Nil_Element@. function Name_Expression_Image (Name : in Asis.Expression) return Wide_String; -- As @Name_Image@, but also accepts @A_Selected_Component@, and uses, -- whenever possible, the corresponding @Defining_Name_Image@ to construct -- the image instead of the program text of the expression. If @Name@ is -- @A_Selected_Component@, the resulting image will be a single line (i.e. -- no weird things between name components like comments, line breaks, and -- so on); individual name components will be separated by periods. -- -- Also accepts @An_Attribute_Reference@, provided its ultimate prefix is -- one of the above. function Name_Definition_Image (Name : in Asis.Defining_Name) return Wide_String; -- As @Defining_Name_Image@, but also accepts @A_Defining_Expanded_Name@, -- for which it will return the normalized image (i.e., no line breaks, -- comments, and other weird things; all one line, components separated -- by periods). function Get_Name (Decl : in Asis.Declaration) return Asis.Defining_Name; -- Returns the first defining name from a declaration. function Get_Single_Name (Decl : in Asis.Declaration) return Wide_String; -- Returns the defining name image of Get_Name (Decl) if the -- declaration declares only one name, or the empty string otherwise. function Full_Unit_Name (Unit : in Asis.Compilation_Unit) return Wide_String; -- A replacement for Asis.Compilation_Units.Full_Name, which -- is buggy in ASIS-for-GNAT 3.14p: it returns only the last name component -- for children that are generic instantiations. (At least for subprograms, -- I didn't test it for package instances that are children of some other -- package.) -- -- This function corrects that error. If the compilation unit's defining -- name is @A_Defining_Expanded_Name@ (i.e., it's a child unit), the -- prefixes are returned using (if possible) the capitalization used in -- the defining names of the parent units. function Container_Name (Element : in Asis.Element) return Wide_String; -- Returns the full name of the enclosing declaration of @Element@. All -- element kinds are appropriate. Returns an empty string for compilation -- unit declarations. function Fully_Qualified_Name (Name : in Asis.Defining_Name) return Wide_String; -- Returns the fully qualified name, i.e. the @Full_Unit_Name@ if @Name@ -- is the defining name of a compilation unit, and the @Container_Name@ -- followed by a dot and the @Name_Definition_Image@ of @Name@ otherwise. -- -- All @Defining_Name_Kinds@ are appropriate. end Asis2.Naming; adabrowse_4.0.3/gal-storage-default.ads0000644000175000017500000000725210234241446016211 0ustar kenken------------------------------------------------------------------------------- -- -- Copyright (c) 2001, 2002 by Thomas Wolf. --
-- This piece of software is free software; you can redistribute it and/or -- modify it under the terms of the GNU General Public License as published -- by the Free Software Foundation; either version 2, or (at your option) -- any later version. This unit is distributed in the hope that it will be -- useful, but without any warranty; without even the implied -- warranty of merchantability or fitness for a particular purpose. -- See the GNU General Public License for more details. You should have -- received a copy of the GNU General Public License with this distribution, -- see file "GPL.txt". If not, write to the Free -- Software Foundation, 59 Temple Place - Suite 330, Boston, MA 02111-1307, -- USA. --
--
-- As a special exception from the GPL, if other files instantiate generics -- from this unit, or you link this unit with other files to produce an -- executable, this unit does not by itself cause the resulting executable -- to be covered by the GPL. This exception does not however invalidate any -- other reasons why the executable file might be covered by the GPL. --
-- --
-- Author:
-- Thomas Wolf (TW) --
twolf@acm.org
-- --
-- Purpose:
-- A default storage pool that uses the pool of an arbitrary -- access-to-integer type.
-- --
-- Tasking semantics:
-- As all pools, fully task safe.
-- --
-- Storage semantics:
-- It's a storage pool, so of course it does dynamic storage -- allocations and deallocations.
-- -- ------------------------------------------------------------------------------- pragma License (Modified_GPL); with System.Storage_Pools; with System.Storage_Elements; package GAL.Storage.Default is pragma Elaborate_Body; type Manager is new System.Storage_Pools.Root_Storage_Pool with null record; -- A plain vanilla pool that is the same as the pool for an access-to- -- integer type. Note that it is entirely implementation-defined whether -- one may use this pool for other types as well. -- -- (Ada 95 *is* lacking a standardized feature to somehow define a -- "default" storage pool which, when given in a representation clause, -- would effectively make the system use whatever pool it'd use if there -- was no representation clause. It turns out that GNAT at least seems to -- use one pool for all types, so using 'Standard_Pool' below for the -- instantiations of the container packages works all right.) procedure Allocate (Pool : in out Manager; Storage_Address : out System.Address; Size : in System.Storage_Elements.Storage_Count; Alignment : in System.Storage_Elements.Storage_Count); procedure Deallocate (Pool : in out Manager; Storage_Address : in System.Address; Size : in System.Storage_Elements.Storage_Count; Alignment : in System.Storage_Elements.Storage_Count); function Storage_Size (Pool : in Manager) return System.Storage_Elements.Storage_Count; end GAL.Storage.Default; adabrowse_4.0.3/asis2.ads0000644000175000017500000000343110234241445013375 0ustar kenken------------------------------------------------------------------------------- -- -- This unit is part of the @Asis2@ ASIS secondary library. -- -- Copyright (c) 2003 by Thomas Wolf. --
-- AdaBrowse is free software; you can redistribute it and/or modify it -- under the terms of the GNU General Public License as published by the -- Free Software Foundation; either version 2, or (at your option) any -- later version. AdaBrowse is distributed in the hope that it will be -- useful, but without any warranty; without even the implied -- warranty of merchantability or fitness for a particular purpose. -- See the GNU General Public License for more details. You should have -- received a copy of the GNU General Public License with this distribution, -- see file "GPL.txt". If not, write to the Free -- Software Foundation, 59 Temple Place - Suite 330, Boston, MA 02111-1307, -- USA. --
--
-- As a special exception from the GPL, if other files instantiate generics -- from this unit, or you link this unit with other files to produce an -- executable, this unit does not by itself cause the resulting executable -- to be covered by the GPL. This exception does not however invalidate any -- other reasons why the executable file might be covered by the GPL. --
-- -- -- Thomas Wolf (TW) -- -- -- -- Root package of the @Asis2@ ASIS secondary library. -- -- -- -- 11-JUL-2003 TW Initial version. -- ------------------------------------------------------------------------------- pragma License (Modified_GPL); package Asis2 is pragma Pure; end Asis2; adabrowse_4.0.3/util-execution.ads0000644000175000017500000000531310234241447015335 0ustar kenken------------------------------------------------------------------------------- -- -- Copyright © 2001, 2002 by Thomas Wolf. --
-- This piece of software is free software; you can redistribute it and/or -- modify it under the terms of the GNU General Public License as published -- by the Free Software Foundation; either version 2, or (at your option) -- any later version. This software is distributed in the hope that it will -- be useful, but without any warranty; without even the implied -- warranty of merchantability or fitness for a particular purpose. -- See the GNU General Public License for more details. You should have -- received a copy of the GNU General Public License with this distribution, -- see file "GPL.txt". If not, write to the Free -- Software Foundation, 59 Temple Place - Suite 330, Boston, MA 02111-1307, -- USA. --
--
-- As a special exception from the GPL, if other files instantiate generics -- from this unit, or you link this unit with other files to produce an -- executable, this unit does not by itself cause the resulting executable -- to be covered by the GPL. This exception does not however invalidate any -- other reasons why the executable file might be covered by the GPL. --
-- -- -- -- -- Thomas Wolf (TW) -- -- -- -- Simple operations to execute a command in the OS environment. -- Implemented by calling the ISO-C standard function "@system@". -- -- Both versions of @Execute@ should be considered potentially blocking -- calls. -- -- Also provided is an interface to the ISO C standard function "@exit@", -- which should kill the process. -- -- -- -- -- -- -- -- 21-MAR-2002 TW Initial version. -- 25-OCT-2002 TW Added @Terminate_Process@. -- ------------------------------------------------------------------------------- pragma License (Modified_GPL); package Util.Execution is pragma Elaborate_Body; function Execute (Command : in String) return Integer; -- Return whatever the underlying "@system@" returns. The semantics of -- this return value is completely implementation-defined (in the ISO -- C standard). However, typical implementations return zero upon success, -- and a non-zero value upon failure. procedure Execute (Command : in String); -- Use this if you don't care about the return value of "@system@". procedure Terminate_Process (Status : in Integer := 0); -- ISO C's @exit@ function. end Util.Execution; adabrowse_4.0.3/ad-projects-impl_yes.adb0000644000175000017500000007643610234241451016401 0ustar kenken------------------------------------------------------------------------------- -- -- This file is part of AdaBrowse. -- -- Copyright (c) 2002 by Thomas Wolf. --
-- AdaBrowse is free software; you can redistribute it and/or modify it -- under the terms of the GNU General Public License as published by the -- Free Software Foundation; either version 2, or (at your option) any -- later version. AdaBrowse is distributed in the hope that it will be -- useful, but without any warranty; without even the implied -- warranty of merchantability or fitness for a particular purpose. -- See the GNU General Public License for more details. You should have -- received a copy of the GNU General Public License with this distribution, -- see file "GPL.txt". If not, write to the Free -- Software Foundation, 59 Temple Place - Suite 330, Boston, MA 02111-1307, -- USA. --
-- --
-- Author:
-- Thomas Wolf (TW) --
twolf@acm.org
-- --
-- Purpose:
-- Project manager implementation.
-- -- ------------------------------------------------------------------------------- pragma License (GPL); -- Standard library units with Ada.Exceptions; with Ada.Strings.Unbounded; with Ada.Text_IO; -- GNAT library units with GNAT.Directory_Operations; with GNAT.OS_Lib; -- GNAT project manager units: with Prj.Com; with Prj.Env; with Prj.Ext; with Prj.Pars; -- These GNAT units are in ASIS-for-GNAT: with Csets; with Namet; with Snames; with Stringt; with Types; -- Asis units: with Asis.Implementation; -- My own units: with AD.Config; with AD.File_Ops; with AD.Known_Units; with AD.Messages; with AD.Text_Utilities; with GAL.Containers.Simple; with GAL.Storage.Standard; pragma Elaborate_All (GAL.Containers.Simple); with Util.Files.Text_IO; with Util.Pathes; with Util.Strings; package body AD.Projects.Impl_Yes is -- Using the project manager is a bit tricky. First, we do have a dummy -- sdefault file, specifying dummy (null) default search pathes (we don't -- need them). -- -- Second, the GNAT 3.16a source distribution contains an osint.adb -- which imports a C function "update_path", with comes from a file -- "prefix.c" from the GCC sources, but which appears to be lacking -- from the GNAT source distribution and which furthermore would only -- complicate even further the build process. -- -- Since we do not need this anyway, we just provide yet another dummy -- function and export it under the name "update_path" and convention C. package Update_Path_Hack is end Update_Path_Hack; package body Update_Path_Hack is separate; -- It's separate because I don't want to clutter this code with references -- to Interfaces.C just because of such a stupid hack! package ASU renames Ada.Strings.Unbounded; AdaBrowse_Configurations : constant String := "AdaBrowse_Configurations"; AdaBrowse_Output : constant String := "AdaBrowse_Output"; AdaBrowse_Tree : constant String := "AdaBrowse_Tree_Dir"; Tree_Dir_Attribute : constant String := "Tree_Dir"; -- Support for future possible modification of the project manager! Output_Directory : ASU.Unbounded_String; Tree_Directory : ASU.Unbounded_String; Source_Directories : ASU.Unbounded_String; Project_File_Name : ASU.Unbounded_String; Own_Project_File : Boolean := False; Project_Manager_Activated : Boolean := False; Project_Manager_Initialized : Boolean := False; procedure Check_Asis_Inactive is begin if Asis.Implementation.Is_Initialized then -- Unfortunately, ASIS-for-GNAT also initializes the tables. The -- rule we follow in AdaBrowse is thus a very simple one: uses of -- ASIS and the project manager must not overlap. Which means that -- we must fail hard if ASIS already has been initialized. -- -- And also the call to Reset should come before the call to -- Asis.Implementation.Initialize, but we cannot enforce this. Ada.Exceptions.Raise_Exception (Program_Error'Identity, "Program logic error: ASIS already initialized!"); end if; end Check_Asis_Inactive; function To_Name_Id (Name : in String) return Types.Name_Id is begin -- GNAT (and its project manager) use lower case internally for user- -- defined names. Namet.Name_Buffer (1 .. Name'Length) := Name; Namet.Name_Len := Name'Length; return Namet.Name_Find; end To_Name_Id; function To_Name (Name : in Types.Name_Id) return String is use type Types.Name_Id; begin if Name in Types.Error_Name_Or_No_Name then return ""; end if; Namet.Get_Decoded_Name_String (Name); return Namet.Name_Buffer (1 .. Namet.Name_Len); end To_Name; function To_File_Name (Name : in Types.Name_Id) return String is use type Types.Name_Id; begin if Name in Types.Error_Name_Or_No_Name then return ""; end if; Namet.Get_Decoded_Name_String (Name); return AD.Text_Utilities.Canonical (Namet.Name_Buffer (1 .. Namet.Name_Len)); end To_File_Name; function To_File_Name (Name : in Types.String_Id) return String is -- This operation is unreferenced on the newer GNATs, but needed on the -- older GNAT versions. use type Types.String_Id; begin if Name = Types.No_String then return ""; end if; Stringt.String_To_Name_Buffer (Name); return AD.Text_Utilities.Canonical (Namet.Name_Buffer (1 .. Namet.Name_Len)); end To_File_Name; pragma Warnings (Off, To_File_Name); -- Switch off warnings for this operation. See comment above. function Make_Absolute (Path_Name : in String; Project : in Prj.Project_Id) return String is begin if Util.Pathes.Is_Absolute_Path (Path_Name) then return Path_Name; end if; return Util.Pathes.Concat (To_File_Name (Prj.Projects.Table (Project).Directory), Path_Name); end Make_Absolute; function Get_Parent (Project : in Prj.Project_Id) return Prj.Project_Id is separate; function Extends (Leaf_Project : in Prj.Project_Id; Other_Project : in Prj.Project_Id) return Boolean is use type Prj.Project_Id; Current : Prj.Project_Id := Leaf_Project; begin -- No project extends a non-existing project. if Other_Project = Prj.No_Project then return False; end if; while Current /= Other_Project and then Current /= Prj.No_Project loop Current := Get_Parent (Current); end loop; return Current = Other_Project; end Extends; type Unit_Desc is record Unit_Name : ASU.Unbounded_String; Spec_Name : ASU.Unbounded_String; Body_Name : ASU.Unbounded_String; end record; package Unit_Lists is new GAL.Containers.Simple (Unit_Desc, GAL.Storage.Standard); All_Units : Unit_Lists.Simple_Container; procedure Add_Unit (Unit_Name : in String; Spec_Name : in String; Body_Name : in String) is New_Unit : constant Unit_Desc := (Unit_Name => ASU.To_Unbounded_String (Unit_Name), Spec_Name => ASU.To_Unbounded_String (Spec_Name), Body_Name => ASU.To_Unbounded_String (Body_Name)); begin AD.Messages.Debug ("Adding " & Unit_Name & " Spec => " & Spec_Name & " Body => " & Body_Name); Unit_Lists.Add (New_Unit, All_Units); AD.Known_Units.Add (Spec_Name, Unit_Name); end Add_Unit; procedure Get_Units (Project : in Prj.Project_Id) is -- Add only the units from this project or from any extended projects, -- but not those from imported projects! use Prj.Com; function Get_File_Name (Info : in File_Name_Data) return String is function Get (Info : in File_Name_Data) return String is use type Types.Name_Id; begin if Info.Name in Types.Error_Name_Or_No_Name then return ""; end if; return To_File_Name (Info.Path); end Get; Name : constant String := Get (Info); begin if Name'Length = 0 then return Name; end if; return Make_Absolute (Name, Info.Project); end Get_File_Name; begin for Unit in Units.First .. Units.Last loop declare Info : constant Unit_Data := Units.Table (Unit); begin if Extends (Project, Info.File_Names (Specification).Project) then -- Note: make these filenames absolute! Add_Unit (Util.Strings.To_Mixed (To_Name (Info.Name)), Get_File_Name (Info.File_Names (Specification)), Get_File_Name (Info.File_Names (Body_Part))); end if; end; end loop; end Get_Units; procedure Get_Source_File_List (File : in out Ada.Text_IO.File_Type; For_Project : in Boolean) is function Quote (S : in String; Delim : in Character := '"'; Escape : in Character := '"') return String renames Util.Strings.Quote; begin if Unit_Lists.Nof_Elements (All_Units) = 0 then return; end if; declare First_Source : Boolean := True; procedure Process_Unit (Unit : in out Unit_Desc; Quit : in out Boolean) is begin if not For_Project then -- Extract only specs. if ASU.Length (Unit.Spec_Name) > 0 then -- We have a spec. Ada.Text_IO.Put_Line (File, "-- " & ASU.To_String (Unit.Unit_Name)); Ada.Text_IO.Put_Line (File, ASU.To_String (Unit.Spec_Name)); end if; else -- For project file: if ASU.Length (Unit.Spec_Name) > 0 then if not First_Source then Ada.Text_IO.Put (File, ", "); end if; First_Source := False; Ada.Text_IO.Put_Line (File, '"' & Quote (ASU.To_String (Unit.Spec_Name)) & '"'); end if; if ASU.Length (Unit.Body_Name) > 0 then if not First_Source then Ada.Text_IO.Put (File, ", "); end if; First_Source := False; Ada.Text_IO.Put_Line (File, '"' & Quote (ASU.To_String (Unit.Body_Name)) & '"'); end if; end if; Quit := False; end Process_Unit; procedure Traverse is new Unit_Lists.Traverse_G (Process_Unit); begin Traverse (All_Units); end; end Get_Source_File_List; procedure Handle_Project_File (Name : in String) is procedure Set (Path : in out ASU.Unbounded_String; From : in String; Option : in String) is begin declare Directories : constant String := Util.Strings.Replace (Source => From, What => "" & GNAT.OS_Lib.Path_Separator, By => ' ' & Option); begin if Directories'Length > 0 then Path := ASU.To_Unbounded_String (Option & Directories); end if; end; end Set; procedure Find_Variable (Project : in Prj.Project_Id; Name : in Types.Name_Id; Var : out Prj.Variable_Id; Found_In : out Prj.Project_Id; Recursive : in Boolean := True; Is_Attribute : in Boolean := False) is use Prj; use type Types.Name_Id; begin if Project = No_Project then Var := No_Variable; Found_In := No_Project; return; end if; if Is_Attribute then Var := Prj.Projects.Table (Project).Decl.Attributes; else Var := Prj.Projects.Table (Project).Decl.Variables; end if; while Var /= No_Variable loop -- Check the name. if Variable_Elements.Table (Var).Name = Name then Found_In := Project; return; end if; Var := Variable_Elements.Table (Var).Next; end loop; if Recursive then -- Check extended projects: Find_Variable (Get_Parent (Project), Name, Var, Found_In); else Var := No_Variable; end if; end Find_Variable; function Get_Variable (Variable_Name : in String; Project : in Prj.Project_Id; Is_Attribute : in Boolean) return String is function Kind_Name (Is_Attribute : in Boolean) return String is begin if Is_Attribute then return "Attribute"; else return "Variable"; end if; end Kind_Name; Kind : constant String := Kind_Name (Is_Attribute); use Prj; Var : Variable_Id := No_Variable; Found_In : Project_Id := No_Project; begin Find_Variable (Project, To_Name_Id (Util.Strings.To_Lower (Variable_Name)), Var, Found_In, Recursive => False, Is_Attribute => Is_Attribute); if Var = No_Variable then return ""; end if; declare Val : constant Variable_Value := Prj.Variable_Elements.Table (Var).Value; begin case Val.Kind is when Prj.Undefined => -- Shouldn't happen! null; when Prj.Single => return Make_Absolute (To_File_Name (Val.Value), Found_In); when others => Ada.Exceptions.Raise_Exception (Project_Error'Identity, Kind & ' ' & Variable_Name & " in project file " & To_File_Name (Prj.Projects.Table (Found_In).Path_Name) & " must be a single string!"); end case; end; return ""; end Get_Variable; function Get_Tree_Directory (Project : in Prj.Project_Id) return String is use Prj; function Get_Tree_Dir return String is begin Own_Project_File := False; -- Support for a maybe future Tree_Dir attribute: declare Path : constant String := Get_Variable (Tree_Dir_Attribute, Project, True); begin if Path'Length > 0 then return Make_Absolute (Path, Project); end if; end; Own_Project_File := True; -- Doesn't exist, use our variable: declare Path : constant String := Get_Variable (AdaBrowse_Tree, Project, False); begin return Make_Absolute (Path, Project); end; end Get_Tree_Dir; function Get_Obj_Dir return String is begin if Prj.Projects.Table (Project).Object_Directory not in Types.Error_Name_Or_No_Name then return Make_Absolute (To_File_Name (Prj.Projects.Table (Project).Object_Directory), Project); else return Make_Absolute ("", Project); end if; end Get_Obj_Dir; Tree_Dir : constant String := Get_Tree_Dir; Obj_Dir : constant String := Get_Obj_Dir; begin -- Check that the tree directory actually exists and is a directory: if not AD.File_Ops.Is_Directory (Tree_Dir) then Ada.Exceptions.Raise_Exception (Project_Error'Identity, "tree directory """ & Tree_Dir & """ doesn't exist?" & " (Project file " & To_File_Name (Prj.Projects.Table (Project).Path_Name) & ')'); end if; -- Check the project's object directory: if Util.Strings.Equal (Tree_Dir, Obj_Dir) then Ada.Exceptions.Raise_Exception (Project_Error'Identity, "tree and object directory must be different in project file " & To_File_Name (Prj.Projects.Table (Project).Path_Name)); end if; -- Tree_Dir and Obj_Dir are textually different. Now do a stronger -- check: create a file through one path and try to open it through -- the other. declare use Ada.Text_IO; File : File_Type; File_Name : ASU.Unbounded_String; Are_Equal : Boolean := False; begin AD.File_Ops.Create_Unique_File (File, File_Name, Util.Pathes.Concat (Tree_Dir, "ABTest"), "txt"); if ASU.Length (File_Name) > 0 then Put_Line (File, ASU.To_String (File_Name)); Close (File); begin Open (File, In_File, Util.Pathes.Concat (Obj_Dir, Util.Pathes.Name (ASU.To_String (File_Name)))); -- Oops, that worked! Check the content: declare Line : constant String := Util.Files.Text_IO.Get_Line (File); begin if Line = ASU.To_String (File_Name) then -- Yes, they are the same! Delete (File); Are_Equal := True; else -- Hmmm, apparently not. Close (File); Open (File, In_File, ASU.To_String (File_Name)); Delete (File); end if; end; exception when others => -- Didn't work, so I guess we may presume the two -- pathes really refer to different directories: begin Open (File, In_File, ASU.To_String (File_Name)); Delete (File); exception when others => if Is_Open (File) then Close (File); end if; end; end; else -- We were not able to create a unique file. Ada.Exceptions.Raise_Exception (Project_Error'Identity, "tree directory """ & Tree_Dir & """ isn't writeable?" & " (Project file " & To_File_Name (Prj.Projects.Table (Project).Path_Name) & ')'); end if; if Are_Equal then Ada.Exceptions.Raise_Exception (Project_Error'Identity, "tree and object directory appear to be the same " & "in project file " & To_File_Name (Prj.Projects.Table (Project).Path_Name)); end if; end; return Tree_Dir; end Get_Tree_Directory; procedure Generate_Renaming (File : in Ada.Text_IO.File_Type; Package_Name : in String; Parent_Name : in String; Parent_Project : in Prj.Project_Id) is begin -- Check that there is such a package. declare use Prj; use type Types.Name_Id; Package_Name_Id : constant Types.Name_Id := To_Name_Id (Util.Strings.To_Lower (Package_Name)); Ptr : Package_Id; begin Ptr := Prj.Projects.Table (Parent_Project).Decl.Packages; while Ptr /= No_Package loop exit when Packages.Table (Ptr).Name = Package_Name_Id and then Packages.Table (Ptr).Parent = No_Package; Ptr := Prj.Packages.Table (Ptr).Next; end loop; if Ptr = No_Package then return; end if; end; Ada.Text_IO.Put_Line (File, " package " & Package_Name & " renames " & Parent_Name & '.' & Package_Name & ';'); Ada.Text_IO.New_Line (File); end Generate_Renaming; procedure Import_Sources (File : in out Ada.Text_IO.File_Type) is begin Ada.Text_IO.Put_Line (File, " for Source_Files use ("); Get_Source_File_List (File, True); Ada.Text_IO.Put_Line (File, " ); -- End of sources"); Ada.Text_IO.New_Line (File); end Import_Sources; procedure Do_Config (File_Name : in String; In_Project : in Prj.Project_Id) is Current_Dir : constant String := GNAT.Directory_Operations.Get_Current_Dir; begin GNAT.Directory_Operations.Change_Dir (To_File_Name (Prj.Projects.Table (In_Project).Directory)); AD.Config.Configure (File_Name); GNAT.Directory_Operations.Change_Dir (Current_Dir); exception when others => GNAT.Directory_Operations.Change_Dir (Current_Dir); raise; end Do_Config; use type Prj.Project_Id; Project : Prj.Project_Id; begin Check_Asis_Inactive; if Project_Manager_Activated then Ada.Exceptions.Raise_Exception (Program_Error'Identity, "Program logic error: Project manager already active!"); end if; if not Project_Manager_Initialized then Ada.Exceptions.Raise_Exception (Program_Error'Identity, "Program logic error: Project manager not initialized!"); end if; Project_Manager_Activated := True; Own_Project_File := False; -- Set verbosity to default (i.e., quiet unless there are errors.) Prj.Pars.Set_Verbosity (Prj.Default); -- Parse the project file: Prj.Pars.Parse (Project => Project, Project_File_Name => Name); if Project = Prj.No_Project then Ada.Exceptions.Raise_Exception (Project_Error'Identity, "Project file '" & Name & "' processing failed."); end if; Project_File_Name := ASU.To_Unbounded_String (To_File_Name (Prj.Projects.Table (Project).Path_Name)); Output_Directory := ASU.To_Unbounded_String (Get_Variable (AdaBrowse_Output, Project, False)); Tree_Directory := ASU.To_Unbounded_String (Get_Tree_Directory (Project)); Set (Source_Directories, Prj.Env.Ada_Include_Path (Project).all, "-I"); Get_Units (Project); if Own_Project_File then -- Create a new copy of the project file just for AdaBrowse -- purposes with a unique name. declare use Ada.Text_IO; File : File_Type; File_Name : ASU.Unbounded_String; Parent_Project_Name : constant String := Util.Strings.To_Mixed (To_Name (Prj.Projects.Table (Project).Name)); begin AD.File_Ops.Create_Unique_File (File, File_Name, Util.Pathes.Concat (Util.Pathes.Path (To_File_Name (Prj.Projects.Table (Project).Path_Name)), "AB"), "gpr"); Put_Line (File, "-- This file has been generated automatically by AdaBrowse."); Put_Line (File, "-- It should be deleted before AdaBrowse terminates."); New_Line (File); Put_Line (File, "project " & Util.Pathes.Base_Name (ASU.To_String (File_Name))); Put_Line (File, " extends """ & Util.Pathes.Name (To_File_Name (Prj.Projects.Table (Project).Path_Name)) & '"'); Put_Line (File, "is"); New_Line (File); Put_Line (File, " for Object_Dir use """ & ASU.To_String (Tree_Directory) & """;"); New_Line (File); -- We need to import the sources, otherwise the project manager -- will still use the parent project's object directory! Import_Sources (File); -- Generate renamings for existing parent project's packages we -- need. Generate_Renaming (File, "Naming", Parent_Project_Name, Project); Generate_Renaming (File, "Builder", Parent_Project_Name, Project); Generate_Renaming (File, "Compiler", Parent_Project_Name, Project); -- I think that's it. Put_Line (File, "end " & Util.Pathes.Base_Name (ASU.To_String (File_Name)) & ';'); Close (File); Project_File_Name := File_Name; exception when E : others => AD.Messages.Debug ("Temp project file " & ASU.To_String (File_Name) & " FAILED: " & Ada.Exceptions.Exception_Information (E)); if Is_Open (File) then declare use type AD.Messages.Verbosity; begin if AD.Messages.Get_Mode = AD.Messages.Including_Debug then Close (File); else Delete (File); end if; end; end if; Ada.Exceptions.Raise_Exception (Project_Error'Identity, "Cannot create temporary project file!"); end; end if; -- Check for AdaBrowse_Configurations... Handle_Configurations : declare use Prj; Var : Variable_Id := No_Variable; Found_In : Project_Id := No_Project; begin Find_Variable (Project, To_Name_Id (Util.Strings.To_Lower (AdaBrowse_Configurations)), Var, Found_In); if Var = No_Variable then return; end if; Process_Variable : declare Val : constant Variable_Value := Prj.Variable_Elements.Table (Var).Value; begin case Val.Kind is when Prj.Undefined => -- Shouldn't happen! return; when Prj.Single => declare Output : constant String := To_File_Name (Val.Value); begin if Output'Length > 0 then Do_Config (Output, Found_In); end if; end; when Prj.List => Process_String_List : declare Ptr : Prj.String_List_Id := Val.Values; begin while Ptr /= Prj.Nil_String loop declare File_Name : constant String := To_File_Name (Prj.String_Elements.Table (Ptr).Value); begin if File_Name'Length > 0 then Do_Config (File_Name, Found_In); end if; end; Ptr := Prj.String_Elements.Table (Ptr).Next; end loop; end Process_String_List; end case; end Process_Variable; end Handle_Configurations; Prj.Reset; Namet.Reset_Name_Table; -- Just to be sure... exception when others => begin Prj.Reset; Namet.Reset_Name_Table; exception when others => null; end; raise; end Handle_Project_File; procedure Get_Source_File_List (File : in out Ada.Text_IO.File_Type) is begin Get_Source_File_List (File, False); end Get_Source_File_List; function Get_Source_Directories return String is begin return ASU.To_String (Source_Directories); end Get_Source_Directories; function Get_Tree_Directory return String is begin return ASU.To_String (Tree_Directory); end Get_Tree_Directory; function Get_Output_Directory return String is begin return ASU.To_String (Output_Directory); end Get_Output_Directory; function Get_Project_File_Name return String is begin return ASU.To_String (Project_File_Name); end Get_Project_File_Name; function Project_Version return String is begin return "p"; end Project_Version; procedure Reset (On_Error : in Boolean) is begin if not On_Error then if Own_Project_File then declare use Ada.Text_IO; File : File_Type; begin Open (File, Ada.Text_IO.In_File, ASU.To_String (Project_File_Name)); Delete (File); exception when E : others => if Is_Open (File) then Close (File); end if; AD.Messages.Debug ("Can't delete file """ & ASU.To_String (Project_File_Name) & """:" & Ada.Exceptions.Exception_Information (E)); end; end if; end if; end Reset; procedure Define_Variable (Name : in String; Value : in String) is begin if Project_Manager_Activated then return; end if; if not Project_Manager_Initialized then Ada.Exceptions.Raise_Exception (Program_Error'Identity, "Program logic error: Project manager not initialized!"); end if; Prj.Ext.Add (Name, Value); end Define_Variable; procedure Initialize is begin if Project_Manager_Initialized then Ada.Exceptions.Raise_Exception (Program_Error'Identity, "Program logic error: Project manager already initialized!"); end if; -- Do the required initializations: Csets.Initialize; Namet.Initialize; Snames.Initialize; Prj.Initialize; Project_Manager_Initialized := True; end Initialize; end AD.Projects.Impl_Yes; adabrowse_4.0.3/ad-projects-impl_no.ads0000644000175000017500000000431410234241444016222 0ustar kenken------------------------------------------------------------------------------- -- -- This file is part of AdaBrowse. -- -- Copyright (c) 2002 by Thomas Wolf. --
-- AdaBrowse is free software; you can redistribute it and/or modify it -- under the terms of the GNU General Public License as published by the -- Free Software Foundation; either version 2, or (at your option) any -- later version. AdaBrowse is distributed in the hope that it will be -- useful, but without any warranty; without even the implied -- warranty of merchantability or fitness for a particular purpose. -- See the GNU General Public License for more details. You should have -- received a copy of the GNU General Public License with this distribution, -- see file "GPL.txt". If not, write to the Free -- Software Foundation, 59 Temple Place - Suite 330, Boston, MA 02111-1307, -- USA. --
-- --
-- Author:
-- Thomas Wolf (TW) --
twolf@acm.org
-- --
-- Purpose:
-- A dummy project manager implementation for a non-existing project -- manager.
-- -- ------------------------------------------------------------------------------- pragma License (GPL); with Ada.Text_IO; private package AD.Projects.Impl_No is procedure Handle_Project_File (Name : in String); -- Raises @Project_Error@ with a descriptive error message. procedure Get_Source_File_List (File : in out Ada.Text_IO.File_Type); -- A no-op. function Get_Tree_Directory return String; -- Returns an empty string. function Get_Output_Directory return String; -- Returns an empty string. function Get_Project_File_Name return String; -- Returns an empty string. function Project_Version return String; -- Returns an empty string. procedure Reset (On_Error : in Boolean); procedure Define_Variable (Name : in String; Value : in String); procedure Initialize; end AD.Projects.Impl_No; adabrowse_4.0.3/gal-support-list_sort.ads0000644000175000017500000000531610234241446016656 0ustar kenken------------------------------------------------------------------------------- -- -- Copyright (c) 2001, 2002 by Thomas Wolf. --
-- AdaBrowse is free software; you can redistribute it and/or modify it -- under the terms of the GNU General Public License as published by the -- Free Software Foundation; either version 2, or (at your option) any -- later version. AdaBrowse is distributed in the hope that it will be -- useful, but without any warranty; without even the implied -- warranty of merchantability or fitness for a particular purpose. -- See the GNU General Public License for more details. You should have -- received a copy of the GNU General Public License with this distribution, -- see file "GPL.txt". If not, write to the Free -- Software Foundation, 59 Temple Place - Suite 330, Boston, MA 02111-1307, -- USA. --
--
-- As a special exception from the GPL, if other files instantiate generics -- from this unit, or you link this unit with other files to produce an -- executable, this unit does not by itself cause the resulting executable -- to be covered by the GPL. This exception does not however invalidate any -- other reasons why the executable file might be covered by the GPL. --
-- --
-- Author:
-- Thomas Wolf (TW) --
twolf@acm.org
-- --
-- Purpose:
-- Generic list sorting operation with O (n*log n) worst-case -- run-time complexity. -- --
-- Tasking semantics:
-- N/A. Not abortion-safe.
-- --
-- Storage semantics:
-- No dynamic storage allocation. Uses O (log n) stack -- space.
-- -- ------------------------------------------------------------------------------- pragma License (Modified_GPL); generic type Node (<>) is limited private; type Node_Ptr is access all Node; with function "<" (L, R : in Node_Ptr) return Boolean; with function Next (N : in Node_Ptr) return Node_Ptr; with procedure Set_Next (N, Next : in Node_Ptr); with procedure Post_Process (List, Last : in out Node_Ptr); procedure GAL.Support.List_Sort (List : in out Node_Ptr; Last : out Node_Ptr); pragma Elaborate_Body (GAL.Support.List_Sort); -- Sorts the list 'List' into ascending order according to '<'. Returns in -- 'List' the first element of the sorted list, and in 'Last' the last one. -- -- Calls 'Post_Process' after having sorted the list. adabrowse_4.0.3/gal-containers.ads0000644000175000017500000000455510234241446015273 0ustar kenken------------------------------------------------------------------------------- -- -- Copyright (c) 2001, 2002 by Thomas Wolf. --
-- This piece of software is free software; you can redistribute it and/or -- modify it under the terms of the GNU General Public License as published -- by the Free Software Foundation; either version 2, or (at your option) -- any later version. This unit is distributed in the hope that it will be -- useful, but without any warranty; without even the implied -- warranty of merchantability or fitness for a particular purpose. -- See the GNU General Public License for more details. You should have -- received a copy of the GNU General Public License with this distribution, -- see file "GPL.txt". If not, write to the Free -- Software Foundation, 59 Temple Place - Suite 330, Boston, MA 02111-1307, -- USA. --
--
-- As a special exception from the GPL, if other files instantiate generics -- from this unit, or you link this unit with other files to produce an -- executable, this unit does not by itself cause the resulting executable -- to be covered by the GPL. This exception does not however invalidate any -- other reasons why the executable file might be covered by the GPL. --
-- --
-- Author:
-- Thomas Wolf (TW) --
twolf@acm.org
-- --
-- Purpose:
-- Root package for my container subsystem.
-- -- ------------------------------------------------------------------------------- pragma License (Modified_GPL); with GAL.ADT; package GAL.Containers is pragma Pure; Container_Empty : exception renames GAL.ADT.Container_Empty; Container_Full : exception renames GAL.ADT.Container_Full; Range_Error : exception renames GAL.ADT.Range_Error; Not_Found : exception renames GAL.ADT.Not_Found; Duplicate_Key : exception renames GAL.ADT.Duplicate_Key; Container_Error : exception renames GAL.ADT.Container_Error; Unordered_Error : exception renames GAL.ADT.Unordered_Error; Navigation_Error : exception renames GAL.ADT.Navigation_Error; end GAL.Containers; adabrowse_4.0.3/ad-driver.adb0000644000175000017500000015363410234241447014225 0ustar kenken------------------------------------------------------------------------------- -- -- This file is part of AdaBrowse. -- -- Copyright (c) 2002 by Thomas Wolf. --
-- AdaBrowse is free software; you can redistribute it and/or modify it -- under the terms of the GNU General Public License as published by the -- Free Software Foundation; either version 2, or (at your option) any -- later version. AdaBrowse is distributed in the hope that it will be -- useful, but without any warranty; without even the implied -- warranty of merchantability or fitness for a particular purpose. -- See the GNU General Public License for more details. You should have -- received a copy of the GNU General Public License with this distribution, -- see file "GPL.txt". If not, write to the Free -- Software Foundation, 59 Temple Place - Suite 330, Boston, MA 02111-1307, -- USA. --
-- --
-- Author:
-- Thomas Wolf (TW) --
twolf@acm.org
-- --
-- Purpose:
-- Main procedure of AdaBrowse.
-- -- ------------------------------------------------------------------------------- pragma License (GPL); with Ada.Characters.Handling; with Ada.Command_Line; with Ada.Exceptions; with Ada.Text_IO; with Ada.Strings.Unbounded; with Ada.Unchecked_Deallocation; with Asis; with Asis.Errors; with Asis.Exceptions; with Asis.Compilation_Units; with Asis.Ada_Environments; with Asis.Implementation; with Asis2.Naming; with AD.Compiler; with AD.Config; with AD.Crossrefs; with AD.Environment; with AD.Exclusions; with AD.File_Ops; with AD.Filters; with AD.HTML; with AD.Indices.Configuration; with AD.Messages; with AD.Options; with AD.Printers; with AD.Printers.HTML; with AD.Printers.XML; with AD.Projects; with AD.Queries; with AD.Parameters; with AD.Parse; with AD.Scanner; with AD.Setup; with AD.Text_Utilities; with AD.User_Tags; with AD.Version; with Util.Pathes; with Util.Strings; pragma Elaborate_All (AD.Projects); pragma Elaborate_All (AD.Version); package body AD.Driver is package ACH renames Ada.Characters.Handling; package ASU renames Ada.Strings.Unbounded; package AIC renames AD.Indices.Configuration; use Ada.Text_IO; use AD.Messages; use AD.Printers; use AD.Text_Utilities; use Util.Strings; Help_Requested : exception; Command_Line_Error : exception; No_Tree_File : exception; Asis_Context : Asis.Context; Asis_Unit : Asis.Compilation_Unit; Tree_Dirs : ASU.Unbounded_String; Src_Dirs : ASU.Unbounded_String; O_Option_Set : Boolean := False; Has_Project : Boolean := False; Project_File : ASU.Unbounded_String; Pass_On_Options : ASU.Unbounded_String; Print_Src_Names : Boolean := False; type File_Ptr is access Ada.Text_IO.File_Type; Src_Files : File_Ptr; Tree_File_Name : ASU.Unbounded_String; Transitive_Closure : Boolean := False; Generate_Index : Boolean := False; General_Context_Tried : Boolean := False; General_Context_Open : Boolean := False; type Printer_Kinds is (HTML_Printer, XML_Printer, DocBook_Printer); type Printer_Set is array (Printer_Kinds) of Boolean; Enabled_Printers : Printer_Set := (others => False); The_Printer : AD.Printers.Printer_Ref := null; Version : constant String := AD.Version.Get_Version & AD.Projects.Project_Version & " (" & AD.Version.Time & " / " & AD.Version.Get_Asis_Version & ')'; package Handled_Units is procedure Add (Name : in String); function Exists (Name : in String) return Boolean; end Handled_Units; package body Handled_Units is separate; procedure Handle_Command_Line (Quit : out Boolean) is use Ada.Command_Line; procedure Check_Following (Curr, Last : in Natural; Name : in String) is begin if Curr > Last then Error (Name & " option must be followed by something."); raise Command_Line_Error; end if; end Check_Following; procedure Set_Index (Idx : in AIC.Index_Type; Last : in Natural; Curr : in out Natural) is begin AIC.Enter_Index (Idx); if Curr < Last then declare Next : constant String := Argument (Curr + 1); begin if Next = "-" or else Next (Next'First) /= '-' then Curr := Curr + 1; AIC.Set_File_Name (Idx, Next); end if; end; end if; end Set_Index; function Quote_If_Needed (S : in String) return String is begin if S'Length = 0 or else -- Empty string OR S (S'First) = '"' or else -- Already quoted OR Util.Strings.Next_Blank (S) = 0 -- No blanks then return S; end if; return Util.Strings.Quote (S, '"', '\'); end Quote_If_Needed; procedure Handle_External_Variable_Assignment (S : in String) is begin if S'Length <= 1 or else S (S'First) /= '"' then AD.Environment.Add (S); else if S (S'Last) /= '"' then -- Missing final quote? Error ("Unterminated quote in -X option: " & S); raise Command_Line_Error; end if; AD.Environment.Add (Util.Strings.Unquote (S (S'First + 1 .. S'Last - 1), '"', '\')); end if; exception when AD.Environment.Invalid_Variable_Assignment => Error ("Invalid -X option: " & S); raise Command_Line_Error; end Handle_External_Variable_Assignment; procedure Add_Directory (Flags : in out ASU.Unbounded_String; Flag : in String; Path : in String; Quoted : in Boolean) is Dir : constant String := Canonical (Path); begin if not AD.File_Ops.Is_Directory (Dir) then Error (Dir & " is an invalid directory (" & Flag & ')'); raise Command_Line_Error; end if; if Quoted then ASU.Append (Flags, ' ' & Quote_If_Needed (Flag & Dir)); else ASU.Append (Flags, ' ' & Flag & Dir); end if; end Add_Directory; F_Input : ASU.Unbounded_String; File_Name_Set : Boolean := False; I : Natural := 1; Print_Version : Boolean := False; N : constant Natural := Argument_Count; Max : Natural := N; -- Used to pass to 'Set_Index' in palce of 'Curr' to suppress the -- setting of the file name. begin if N = 0 then raise Help_Requested; end if; Quit := False; while I <= N loop declare S : constant String := Argument (I); begin if S = "-h" or else S = "-?" or else S = "-help" or else S = "--help" then raise Help_Requested; elsif S = "-G" then I := I + 1; Check_Following (I, N, S); while I <= N loop declare Next : constant String := To_Lower (Argument (I)); begin if Next = "html" then Enabled_Printers (HTML_Printer) := True; elsif Next = "xml" then Enabled_Printers (XML_Printer) := True; -- elsif Next = "docbook" then -- Enabled_Printers (DocBook_Printer) := True; else exit; end if; end; I := I + 1; end loop; I := I - 1; elsif S = "-g" then AD.Crossrefs.Set_Standard_Units (True); elsif S = "-l" then AD.Printers.Set_Line_Only; elsif S = "-v" or else S = "-version" or else S = "--version" then Print_Version := True; elsif S = "-o" then I := I + 1; Check_Following (I, N, S); if O_Option_Set then Error ("only one -o option may be given."); raise Command_Line_Error; end if; AD.Options.Set_Output_Name (Canonical (Argument (I))); O_Option_Set := True; elsif S'Length > 2 and then S (S'First .. S'First + 1) = "-o" then if O_Option_Set then Error ("only one -o option may be given."); raise Command_Line_Error; end if; AD.Options.Set_Output_Name (Canonical (S (S'First + 2 .. S'Last))); O_Option_Set := True; elsif S = "-f" then I := I + 1; Check_Following (I, N, S); if File_Name_Set then Warn ("Input already set; " & "ignoring option: " & S & ' ' & Argument (I)); else F_Input := ASU.To_Unbounded_String (Canonical (Argument (I))); File_Name_Set := True; end if; elsif S'Length > 2 and then S (S'First .. S'First + 1) = "-f" then if File_Name_Set then Warn ("Input already set; ignoring option: " & S); else F_Input := ASU.To_Unbounded_String (Canonical (S (S'First + 2 .. S'Last))); File_Name_Set := True; end if; elsif S = "-c" then I := I + 1; Check_Following (I, N, S); AD.Config.Configure (Canonical (Argument (I))); elsif S'Length > 2 and then S (S'First .. S'First + 1) = "-c" then AD.Config.Configure (Canonical (S (S'First + 2 .. S'Last))); elsif S = "-q" then AD.Messages.Set_Mode (AD.Messages.Only_Errors); elsif S'Length = 3 and then S (S'First .. S'First + 1) = "-w" then case S (S'First + 2) is when '0' | 'e' => AD.Messages.Set_Mode (AD.Messages.Only_Errors); when '1' | 'w' => AD.Messages.Set_Mode (AD.Messages.Errors_And_Warnings); when '2' | 'a' | 'i' => AD.Messages.Set_Mode (AD.Messages.All_Messages); when 'D' => AD.Messages.Set_Mode (AD.Messages.Including_Debug); AD.Messages.Debug ("Debug messages activated!"); when others => Error ("unknown warning level on command line."); raise Command_Line_Error; end case; elsif S = "-s" then I := I + 1; Check_Following (I, N, S); AD.HTML.Set_Style_Sheet (Argument (I)); elsif S'Length > 2 and then S (S'First .. S'First + 1) = "-s" then AD.HTML.Set_Style_Sheet (S (S'First + 2 .. S'Last)); elsif S = "-is" then Set_Index (AIC.Unit_Index, N, I); AIC.Set_Structured (AIC.Unit_Index, True); elsif S'Length > 3 and then S (S'First .. S'First + 2) = "-is" then Set_Index (AIC.Unit_Index, N, Max); AIC.Set_Structured (AIC.Unit_Index, True); AIC.Set_File_Name (AIC.Unit_Index, Canonical (S (S'First + 3 .. S'Last))); elsif S = "-i" then Set_Index (AIC.Unit_Index, N, I); AIC.Set_Structured (AIC.Unit_Index, False); elsif S'Length > 2 and then S (S'First .. S'First + 1) = "-i" then Set_Index (AIC.Unit_Index, N, Max); AIC.Set_Structured (AIC.Unit_Index, False); AIC.Set_File_Name (AIC.Unit_Index, Canonical (S (S'First + 2 .. S'Last))); elsif S = "-t" then Set_Index (AIC.Type_Index, N, I); elsif S'Length > 2 and then S (S'First .. S'First + 1) = "-t" then Set_Index (AIC.Type_Index, N, Max); AIC.Set_File_Name (AIC.Type_Index, Canonical (S (S'First + 2 .. S'Last))); elsif S = "-private" or else S = "--private" then AD.Options.Set_Private_Too (True); elsif S = "-p" then Set_Index (AIC.Subprogram_Index, N, I); elsif S'Length > 2 and then S (S'First .. S'First + 1) = "-p" then Set_Index (AIC.Subprogram_Index, N, Max); AIC.Set_File_Name (AIC.Subprogram_Index, Canonical (S (S'First + 2 .. S'Last))); elsif S = "-P" then I := I + 1; Check_Following (I, N, S); if Has_Project then Error ("only one -P option may be given."); raise Command_Line_Error; end if; Has_Project := True; Project_File := ASU.To_Unbounded_String (Canonical (Argument (I))); elsif S'Length > 2 and then S (S'First .. S'First + 1) = "-P" then if Has_Project then Error ("only one -P option may be given."); raise Command_Line_Error; end if; Has_Project := True; Project_File := ASU.To_Unbounded_String (Canonical (S (S'First + 2 .. S'Last))); elsif S = "-X" then -- External variable assignment. Applies to project files -- *and* to AdaBrowse config files subsequently read. -- Syntax: -X name=value or -X "name = value". I := I + 1; Check_Following (I, N, S); Handle_External_Variable_Assignment (Argument (I)); ASU.Append (Pass_On_Options, " -X" & Quote_If_Needed (Argument (I))); elsif S'Length > 2 and then S (S'First .. S'First + 1) = "-X" then Handle_External_Variable_Assignment (S (S'First + 2 .. S'Last)); ASU.Append (Pass_On_Options, " -X" & Quote_If_Needed (S (S'First + 2 .. S'Last))); elsif S = "-a" or else S = "-all" or else S = "--all" then Transitive_Closure := True; elsif S = "-x" then AD.Options.Set_Overwrite (False); elsif S = "-T" then -- Options for Asis. I := I + 1; Check_Following (I, N, S); if Next_Blank (Argument (I)) /= 0 then Error ("Directories for the -T option must not contain " & "white space; option = " & S & " """ & Argument (I) & '"'); raise Command_Line_Error; end if; Add_Directory (Tree_Dirs, "-T", Argument (I), False); elsif S'Length > 2 and then S (S'First .. S'First + 1) = "-T" then -- Options for Asis. if Next_Blank (S) /= 0 then Error ("Directories for the -T option must not contain " & "white space; option = " & S); raise Command_Line_Error; end if; Add_Directory (Tree_Dirs, "-T", S (S'First + 2 .. S'Last), False); elsif S = "-I" then -- Options for Asis. I := I + 1; Check_Following (I, N, S); Add_Directory (Src_Dirs, "-I", Argument (I), True); elsif S'Length > 2 and then S (S'First .. S'First + 1) = "-I" then -- Options for Asis Add_Directory (Src_Dirs, "-I", S (S'First + 2 .. S'Last), True); else Error ("Unknown command-line option: " & S); raise Command_Line_Error; end if; end; I := I + 1; end loop; if Print_Version then Put_Line (Current_Error, "AdaBrowse " & Version & "; Copyright (c) 2002, 2003 by Thomas Wolf"); if N = 1 then Quit := True; return; end if; end if; if Has_Project then begin AD.Projects.Handle_Project_File (ASU.To_String (Project_File)); exception when E : AD.Projects.Project_Error => Error (Ada.Exceptions.Exception_Message (E)); raise Command_Line_Error; end; end if; Generate_Index := AD.Indices.Has_Indices; if File_Name_Set then AD.Parameters.Set_Input (ASU.To_String (F_Input)); else if not Has_Project then Error ("No input file name! " & "(At least one of -f or -P must be given.)"); raise Command_Line_Error; else Info ("Processing all sources in project '" & ASU.To_String (Project_File) & '''); Print_Src_Names := True; Src_Files := new Ada.Text_IO.File_Type; Ada.Text_IO.Create (Src_Files.all, Ada.Text_IO.Out_File); AD.Projects.Get_Source_File_List (Src_Files.all); Ada.Text_IO.Reset (Src_Files.all, Ada.Text_IO.In_File); AD.Parameters.Set_Input (Ada.Text_IO.File_Access'(Src_Files.all'Unchecked_Access)); -- Actually, I think plain 'Access should work just as well, -- but unfortunately GNAT 3.15p complains. end if; end if; if Has_Project and then not O_Option_Set then declare Target : constant String := AD.Projects.Get_Output_Directory; begin if Target'Length > 0 then Info ("Output goes to " & Target); if Util.Pathes.Name (Target)'Length > 0 then AD.Options.Set_Output_Name (Target & Util.Pathes.Directory_Separator); else AD.Options.Set_Output_Name (Target); end if; O_Option_Set := True; end if; end; end if; if Generate_Index then if not AD.Parameters.Is_File and then not Transitive_Closure then Warn ("Index generation is only active if AdaBrowse is supposed " & "to process more than one unit. " & "(-f- or -f @file_name or -a or -P project_file)"); Generate_Index := False; elsif AD.Options.Output_Name = "-" then Warn ("Index generation turned off because output goes to " & "stdout. (-o- was given.)"); Generate_Index := False; end if; end if; -- Find out how many printers are enabled. declare Nof_Printers : Natural := 0; begin for I in Enabled_Printers'Range loop if Enabled_Printers (I) then Nof_Printers := Nof_Printers + 1; end if; end loop; if Nof_Printers = 0 then -- If no "-G" option was given, enable the HTML printer by -- default. Nof_Printers := 1; Enabled_Printers (HTML_Printer) := True; end if; if AD.Options.Output_Name = "-" and then Nof_Printers > 1 then Error ("Output must not go to stdout if more than one output " & "format is enabled (-G option)."); raise Command_Line_Error; end if; if AD.Parameters.Is_File or else Nof_Printers > 1 or else Transitive_Closure then AD.Options.Set_Processing_Mode (AD.Options.Multiple_Files); else AD.Options.Set_Processing_Mode (AD.Options.Single_File); end if; end; if Has_Project then declare Prj_Tree_Dir : constant String := AD.Projects.Get_Tree_Directory; begin if Prj_Tree_Dir'Last >= Prj_Tree_Dir'First then ASU.Append (Tree_Dirs, " -T" & Prj_Tree_Dir); end if; AD.Messages.Info ("Tree directory is " & Prj_Tree_Dir); end; -- We have to change the compile command to ensure that the project -- file gets passed along and the compiler thus has the environment -- it needs (configuration pragmas, naming schemes, etc.) -- Note: we also pass on -X options! AD.Compiler.Set_Compile_Command ("gnat compile -c -gnatc -gnatt -P" & AD.Projects.Get_Project_File_Name & ASU.To_String (Pass_On_Options)); end if; exception when Command_Line_Error => -- Check if there's a help option somewhere. If so, translate this -- into a Help_Requested. (This allows the user to simply re-use a -- command that previously terminated with a Command_Line_Error with -- an additional help option at the end to get the help. I find this -- personally useful because it saves typing; since most command -- shells support a "command history", I can get the help by typing -- -?, which is way faster than having to type -- adabrowse -?.) I := I + 1; -- We failed on argument I, so we only need to check the remaining -- arguments. while I <= N loop declare S : constant String := Argument (I); begin exit when S = "-?" or else S = "-h" or else S = "-help" or else S = "--help"; end; I := I + 1; end loop; if I <= N then raise Help_Requested; else raise; end if; end Handle_Command_Line; procedure Report (Debug_Only : Boolean := False) is use type AD.Messages.Verbosity; begin if not Debug_Only or else AD.Messages.Get_Mode = AD.Messages.Including_Debug then Put_Line (Current_Error, "*** Please report this error to " & AD.Version.Get_Maintainer & ", giving the AdaBrowse version,"); Put_Line (Current_Error, "host environment, GNAT version, and all input files" & " (Ada sources, style sheets "); Put_Line (Current_Error, "and configuration files)."); Put_Line (Current_Error, "This is AdaBrowse " & Version & "; Copyright (c) 2002, 2003 by Thomas Wolf"); end if; end Report; procedure Report_No_GNATC (E : in Ada.Exceptions.Exception_Occurrence; Asis_Info : in String) is begin Error ("Fatal ASIS failure. It seems like some tree files have"); Error ("been compiled with only ""-gnatt"" (no ""-gnatc"")."); Error ("Verify this, and if the error doesn't go away, re-run"); Error ("AdaBrowse with the ""-wD"" option to get more information."); Debug (Ada.Exceptions.Exception_Information (E)); Debug (Asis_Info); Report (Debug_Only => True); end Report_No_GNATC; procedure Recreate is -- Call the compiler (if any) to try to recreate the ASIS-information. -- Raises 'No_Tree' if a compilation command is set, but fails. If -- no compilation command is defined, nothing at all happens. Assumes -- 'Asis_Context' to be closed upon entry and, if compilation was -- successful, tries to open it. -- Hmmm... what happens here if the command reads from stdin, or -- does not return? For the time being, we just assume that compilers -- don't do such nasty things! Ok : Boolean := False; begin if AD.Compiler.Get_Compile_Command /= "" then Info ("Trying to recompile """ & AD.Parameters.Source_Name & """..."); AD.Compiler.Create_Unit (Util.Pathes.Concat (AD.Parameters.Path, AD.Parameters.Source_Name), Src_Dirs, Tree_Dirs, Tree_File_Name, Ok); if Ok then Info ("Recompilation of """ & AD.Parameters.Source_Name & """ was successful."); -- Success! Re-open the context and try again. Asis.Ada_Environments.Associate (The_Context => Asis_Context, Name => "AdaBrowse_Context", Parameters => To_Wide_String ("-C1 -FT -SA -T. " & ASU.To_String (Tree_File_Name))); Asis.Ada_Environments.Open (Asis_Context); else raise No_Tree_File; end if; end if; end Recreate; procedure Transform_Unit (Unit : in Asis.Compilation_Unit) is begin AD.Scanner.Scan (Unit, The_Printer); AD.User_Tags.Reset_Tags; exception when others => begin Asis.Ada_Environments.Close (Asis_Context); Asis.Ada_Environments.Dissociate (Asis_Context); Asis.Implementation.Finalize (""); exception when others => null; end; raise; end Transform_Unit; procedure Process_One_Unit is procedure Delete_ADT is begin if ASU.Length (Tree_File_Name) > 0 and then not Has_Project then -- We created a tree file: try to delete it! -- (But only if we're not working from a project file: project -- files have a tree directory, and that's ours!) declare ADT_Name : constant String := ASU.To_String (Tree_File_Name); begin AD.File_Ops.Delete (ADT_Name); -- And GNAT also creates a "*.ali" file... AD.File_Ops.Delete (ADT_Name (ADT_Name'First .. ADT_Name'Last - 3) & "ali"); end; end if; Tree_File_Name := ASU.Null_Unbounded_String; exception when others => -- Swallow the exception! Tree_File_Name := ASU.Null_Unbounded_String; end Delete_ADT; Skip_Unit : exception; use type Ada.Exceptions.Exception_Id; begin if Handled_Units.Exists (AD.Parameters.Unit_Name) then return; end if; if Print_Src_Names then Info ("Processing file """ & AD.Parameters.Source_Name & '"'); end if; -- Now try to open the Asis context. This is pretty complex. By default, -- we use all tree files, but if ASIS detects an inconsistency, we first -- need to hack around to properly detect that, then try to recompile -- the given file, and finally re-open the context with options telling -- ASIS to use only that new tree file. Init_Asis : declare Already_Tried_To_Create : Boolean := False; begin Initially : begin if not General_Context_Tried then General_Context_Tried := True; Asis.Ada_Environments.Associate (The_Context => Asis_Context, Name => "AdaBrowse_Context", Parameters => To_Wide_String ("-CA -FT -SA " & ASU.To_String (Tree_Dirs))); -- use "-FM -SA" (generate tree files as needed)? -- use "-I" (directories to search for sources) -- use "-T" (directories to search for trees) -- -- Default is "-CA -FT -SA" (all tree files found, no automatic -- tree generation, use all sources for consistency checks). -- -- Note that "-FM" requires "-SA"! Also note that it is -- absolutely unclear what happens with any generated tree -- files when the context is closed. Neither the ASIS-for-GNAT -- RM nor the UG say whether or not these files are deleted -- once the last context using them is closed... They also -- don't say where these files are created: in the current -- directory, in a directory given by a "-T" option, or in -- the system's temporary directory? Probably in the current -- directory, following the "gcc" command launched internally. -- -- Note: for the time being, we do not use "-FM": some ASIS -- queries (e.g. Corresponding_Children) are implemented only -- for "-FT"! Asis.Ada_Environments.Open (Asis_Context); General_Context_Open := True; elsif not General_Context_Open then Already_Tried_To_Create := True; Recreate; end if; exception when Asis.Exceptions.ASIS_Failed => if AD.Compiler.Get_Compile_Command = "" then raise; end if; -- ASIS-for-GNAT specific! declare Msg : constant String := Trim (To_String (Asis.Implementation.Diagnosis)); I : Natural := Index (Msg, " is inconsistent with a tree file"); begin if I = 0 then I := Index (Msg, "does not exist"); end if; if I > 0 then -- It *is* indeed a source-vs-tree -- inconsistency! Warn (Msg); -- Close the context again and try to recreate -- the ASIS info and then re-open the context. if Asis.Ada_Environments.Is_Open (Asis_Context) then Asis.Ada_Environments.Close (Asis_Context); end if; Asis.Ada_Environments.Dissociate (Asis_Context); General_Context_Open := False; Already_Tried_To_Create := True; Recreate; else raise; end if; end; end Initially; Asis_Unit := Asis.Compilation_Units.Library_Unit_Declaration (To_Wide_String (AD.Parameters.Unit_Name), Asis_Context); if Asis.Compilation_Units.Is_Nil (Asis_Unit) then -- Hmmm... might be a krunched file name: try to find the source -- file, and extract the unit name from the source! declare Full_Name : constant String := AD.File_Ops.Find (Util.Pathes.Concat (AD.Parameters.Path, AD.Parameters.Source_Name), Src_Dirs); begin if Full_Name'Last >= Full_Name'First then declare True_Name : constant String := AD.Parse.Get_Unit_Name (Full_Name); begin if True_Name'Last >= True_Name'First and then To_Lower (True_Name) /= To_Lower (AD.Parameters.Unit_Name) then if Handled_Units.Exists (True_Name) then raise Skip_Unit; end if; Info ("File """ & Full_Name & """ contains a unit named """ & True_Name & '"'); AD.Parameters.Set_Unit_Name (True_Name); Asis_Unit := Asis.Compilation_Units.Library_Unit_Declaration (To_Wide_String (True_Name), Asis_Context); end if; end; end if; end; end if; if Asis.Compilation_Units.Is_Nil (Asis_Unit) and then not (Already_Tried_To_Create) and then AD.Compiler.Get_Compile_Command /= "" then -- Not found: Close the context again and then try to generate the -- tree and re-open the context. Asis.Ada_Environments.Close (Asis_Context); Asis.Ada_Environments.Dissociate (Asis_Context); Warn ("Couldn't find unit """ & AD.Parameters.Unit_Name & """ in the library."); General_Context_Open := False; Recreate; -- Try again. Asis_Unit := Asis.Compilation_Units.Library_Unit_Declaration (To_Wide_String (AD.Parameters.Unit_Name), Asis_Context); end if; end Init_Asis; if Asis.Compilation_Units.Is_Nil (Asis_Unit) then -- Still not found: abandon! Asis.Ada_Environments.Close (Asis_Context); Asis.Ada_Environments.Dissociate (Asis_Context); raise Asis.Exceptions.ASIS_Inappropriate_Compilation_Unit; end if; Generate_Main : declare Unit_Name : constant String := To_String (Asis2.Naming.Full_Unit_Name (Asis_Unit)); begin if not Handled_Units.Exists (Unit_Name) then Handled_Units.Add (Unit_Name); if AD.Exclusions.Is_Excluded (To_Lower (Unit_Name)) then Info ("There's an EXCLUDE key in some configuration file for " & "the given unit """ & Unit_Name & """. Unit is skipped."); raise Skip_Unit; else Transform_Unit (Asis_Unit); end if; else if AD.Exclusions.Is_Excluded (To_Lower (Unit_Name)) then raise Skip_Unit; end if; end if; end Generate_Main; if Transitive_Closure then Generate_Closure : declare All_Units : constant Asis.Compilation_Unit_List := AD.Queries.Get_Dependents (Asis_Unit); begin for I in All_Units'Range loop if not Asis.Compilation_Units.Is_Equal (All_Units (I), Asis_Unit) then -- The "if" is just paranoia; I suppose we should never get -- back the unit itself. declare Unit_Name : constant String := To_String (Asis2.Naming.Full_Unit_Name (All_Units (I))); begin if not Handled_Units.Exists (Unit_Name) then Handled_Units.Add (Unit_Name); if AD.Exclusions.Skip (To_Lower (Unit_Name)) then Info ("The unit """ & Unit_Name & """ is excluded" & " by an EXCLUDE or NO_XREF key in some" & " configuration file."); else Transform_Unit (All_Units (I)); end if; end if; end; end if; end loop; end Generate_Closure; end if; -- No exception: successful termination if not General_Context_Open and then Asis.Ada_Environments.Is_Open (Asis_Context) then Asis.Ada_Environments.Close (Asis_Context); Asis.Ada_Environments.Dissociate (Asis_Context); end if; Delete_ADT; exception when E : others => if not General_Context_Open and then Asis.Ada_Environments.Is_Open (Asis_Context) then Asis.Ada_Environments.Close (Asis_Context); Asis.Ada_Environments.Dissociate (Asis_Context); end if; Delete_ADT; if Ada.Exceptions.Exception_Identity (E) /= Skip_Unit'Identity then raise; end if; end Process_One_Unit; procedure Init_Asis is ASIS_Version : constant String := AD.Version.Get_Asis_Version; Pattern_GNAT : constant String := "for GNAT"; Pattern_Pro : constant String := "Pro"; I : Natural; begin -- Search for "for GNAT", then skip blanks, then get a sequence of -- digits and periods. I := Util.Strings.First_Index (ASIS_Version, Pattern_GNAT); if I = 0 then -- Not an ASIS-for-GNAT? Asis.Implementation.Initialize (Parameters => ""); else I := Next_Non_Blank (ASIS_Version (I + Pattern_GNAT'Length .. ASIS_Version'Last)); -- Some GNAT versions may have a version string "for GNAT Pro x.yy"! if I /= 0 and then Is_Prefix (ASIS_Version (I .. ASIS_Version'Last), Pattern_Pro) then I := Next_Non_Blank (ASIS_Version (I + Pattern_Pro'Length .. ASIS_Version'Last)); end if; declare Major_Version : Natural := 3; Minor_Version : Natural := 15; begin if I /= 0 and then ACH.Is_Digit (ASIS_Version (I)) then Major_Version := Natural (Character'Pos (ASIS_Version (I)) - Character'Pos ('0')); I := I + 1; if I <= ASIS_Version'Last and then ASIS_Version (I) = '.' then declare J : Natural := I + 1; begin while J <= ASIS_Version'Last and then ACH.Is_Digit (ASIS_Version (J)) loop J := J + 1; end loop; if J > I + 1 then Minor_Version := Natural'Value (ASIS_Version (I + 1 .. J - 1)); end if; end; end if; end if; if Major_Version < 3 or else (Major_Version = 3 and then Minor_Version <= 15) then Asis.Implementation.Initialize (Parameters => "-ws"); -- "-ws" means "suppress all warnings". In particular, we want -- to suppress the warnings about some body tree files not -- being present. As we process only specs, we don't care: -- the body trees needed for generic instantiations are -- included in the specs containing these instantiations -- anyway. else -- Use from GNAT 3.16 on (3.16, 3.17, 5.00, ...) Asis.Implementation.Initialize (Parameters => "-ws -k -nbb"); -- "-k" means keep going; never, ever make the program quit. -- Hey, it's awful library design if a library can force the -- program using it to quit. Sergey, you'd better undo that -- immediately! -- -- "-nbb" tells ASIS not to generate a GNAT-style bug-box on -- stderr, giving instructions how to submit a bug report to -- ACT. For heaven's sake, what kind of nonsense is this?! It's -- the application using ASIS-for-GNAT that has the sole right -- to decide what to do in the presence of fatal errors, such -- as bugs in ASIS. Maybe it can work around the bugs, or tell -- the users to submit bug reports somewhere else (e.g., to -- report them to me!). end if; end; end if; end Init_Asis; procedure Shutdown (Normal : in Boolean) is begin if Asis.Ada_Environments.Is_Open (Asis_Context) then -- Must be the general context... Asis.Ada_Environments.Close (Asis_Context); Asis.Ada_Environments.Dissociate (Asis_Context); end if; if Normal and then Generate_Index then AD.Indices.Write (The_Printer); end if; AD.Parameters.Close; Asis.Implementation.Finalize (""); AD.Printers.Free (The_Printer); declare use type Ada.Text_IO.File_Access; procedure Free is new Ada.Unchecked_Deallocation (Ada.Text_IO.File_Type, File_Ptr); begin if Src_Files /= null then if Ada.Text_IO.Is_Open (Src_Files.all) then Ada.Text_IO.Close (Src_Files.all); end if; Free (Src_Files); end if; end; if Normal then AD.Projects.Reset (On_Error => False); Ada.Command_Line.Set_Exit_Status (Ada.Command_Line.Success); else AD.Projects.Reset (On_Error => True); Ada.Command_Line.Set_Exit_Status (Ada.Command_Line.Failure); end if; end Shutdown; procedure Main is begin -- AdaBrowse Main routine AD.Crossrefs.Set_Standard_Units (False); AD.Projects.Initialize; Parse_Command_Line : declare Quit : Boolean; begin Handle_Command_Line (Quit); if Quit then Ada.Command_Line.Set_Exit_Status (Ada.Command_Line.Success); return; end if; end Parse_Command_Line; AD.User_Tags.Verify; -- Set up the enabled printers. for I in Enabled_Printers'Range loop if Enabled_Printers (I) then case I is when HTML_Printer => The_Printer := The_Printer + Printer_Ref'(new AD.Printers.HTML.Printer); when XML_Printer => The_Printer := The_Printer + Printer_Ref'(new AD.Printers.XML.Printer); when DocBook_Printer => -- The_Printer := -- The_Printer + new AD.Printers.DocBook_Printer; null; end case; end if; end loop; -- Now initialize Asis. This is highly GNAT-specific! Init_Asis; -- Set up index management. if Generate_Index then AD.Indices.Verify; else AD.Indices.Disable; end if; -- Set the output directory. if AD.Options.Output_Directory = "" and then AD.Parameters.Path /= "" then AD.Options.Set_Output_Directory (AD.Parameters.Path); end if; -- Process the input files. loop Process_One_Unit; exit when not AD.Parameters.Advance_Input; end loop; Shutdown (True); exception when others => Exception_Handler : begin Shutdown (False); raise; exception when E : AD.Printers.Open_Failed | AD.Printers.Cannot_Overwrite | AD.Config.Invalid_Config | AD.Parameters.Input_Error | AD.Filters.Recursive_Expansion => Error (Ada.Exceptions.Exception_Message (E)); when No_Tree_File => Error ("Couldn't find unit """ & AD.Parameters.Unit_Name & """ in the library."); if AD.Compiler.Get_Compile_Command /= "" then if Index (AD.Version.Get_Version, "GNAT") > 0 then Error ("Couldn't find nor generate a tree " & "file. Try generating one "); Error ("using the command """ & AD.Setup.GNAT_Name & " -c -gnatc -gnatt ..."""); else Error ("Couldn't generate the necessary info " & "either with """ & AD.Compiler.Get_Compile_Command & " ..."""); end if; end if; when Asis.Exceptions.ASIS_Inappropriate_Compilation_Unit => Error ("Couldn't find unit """ & AD.Parameters.Unit_Name & """ in the library, or"); Error ("the file """ & AD.Parameters.Source_Name & """ does not contain any Ada spec."); Put_Line (Current_Error, "Type ""adabrowse -?"" for more information."); when Command_Line_Error => Put_Line (Current_Error, "Type ""adabrowse -?"" for more information."); when Help_Requested => AD.Messages.Help_Text; when E : others => declare use Ada.Exceptions; Handled : Boolean := False; begin if Exception_Identity (E) = Asis.Exceptions.ASIS_Failed'Identity then declare use Asis.Errors; begin case Asis.Implementation.Status is when Asis.Errors.Use_Error | Obsolete_Reference_Error => -- ASIS-for-GNAT specific! declare Msg : constant String := Trim (To_String (Asis.Implementation.Diagnosis)); begin if Index (Msg, " is inconsistent with a tree file") > 0 then Handled := True; Error (Msg); elsif Index (Msg, "not compile-only") > 0 then Handled := True; Report_No_GNATC (E, Trim (Msg)); end if; end; when Parameter_Error => Handled := True; Error (Trim (To_String (Asis.Implementation.Diagnosis))); when Not_Implemented_Error => Handled := True; Error ("ASIS doesn't implement a query!"); Error (Ada.Exceptions.Exception_Information (E)); Error (Trim (To_String (Asis.Implementation.Diagnosis))); Report; when others => declare Msg : constant String := To_String (Asis.Implementation.Diagnosis); begin if (First_Index (To_Lower (Msg), "constraint_error") > 0 and then First_Index (To_Lower (Msg), "namet.adb") > 0) or else (First_Index (To_Lower (Msg), "internal_implementation_error") > 0 and then First_Index (To_Lower (Msg), "a4g-contt-ut.adb") > 0) then Handled := True; Report_No_GNATC (E, Trim (Msg)); end if; end; end case; end; elsif Exception_Identity (E) = Program_Error'Identity then declare Msg : constant String := Exception_Message (E); begin if Is_Prefix (Msg, "Inconsistent versions") then Handled := True; Error (Msg); Put_Line (Current_Error, "**** AdaBrowse has been compiled for " & AD.Version.Get_Asis_Version & ','); Put_Line (Current_Error, "but some tree file has been generated by " & "some other compiler."); Put_Line (Current_Error, "Make sure that the tree files are generated " & "by the compiler above,"); Put_Line (Current_Error, "or rebuild AdaBrowse from the sources with " & "your other compiler."); end if; end; end if; if not Handled then Error ("An unexpected error occurred!"); Error (Ada.Exceptions.Exception_Information (E)); Error (Trim (To_String (Asis.Implementation.Diagnosis))); Report; end if; end; end Exception_Handler; end Main; end AD.Driver; adabrowse_4.0.3/ad-expressions.adb0000644000175000017500000006337110234241450015304 0ustar kenken------------------------------------------------------------------------------- -- -- This file is part of AdaBrowse. -- -- Copyright (c) 2002 by Thomas Wolf. --
-- AdaBrowse is free software; you can redistribute it and/or modify it -- under the terms of the GNU General Public License as published by the -- Free Software Foundation; either version 2, or (at your option) any -- later version. AdaBrowse is distributed in the hope that it will be -- useful, but without any warranty; without even the implied -- warranty of merchantability or fitness for a particular purpose. -- See the GNU General Public License for more details. You should have -- received a copy of the GNU General Public License with this distribution, -- see file "GPL.txt". If not, write to the Free -- Software Foundation, 59 Temple Place - Suite 330, Boston, MA 02111-1307, -- USA. --
-- --
-- Author:
-- Thomas Wolf (TW) --
twolf@acm.org
-- --
-- Purpose:
-- Parsing and evaluation of expressions; storage of expressions.
-- -- ------------------------------------------------------------------------------- pragma License (GPL); with Ada.Characters.Handling; with Ada.Exceptions; with Ada.Unchecked_Deallocation; with AD.Predicates; with GAL.ADT.Hash_Tables; with GAL.Storage.Standard; with GAL.Support.Hashing; with Util.Strings; pragma Elaborate_All (GAL.ADT.Hash_Tables); package body AD.Expressions is package ACH renames Ada.Characters.Handling; package ASU renames Ada.Strings.Unbounded; package Hashing is new GAL.ADT.Hash_Tables (Key_Type => String, Item => Expression, Memory => GAL.Storage.Standard, Hash => GAL.Support.Hashing.Hash_Case_Insensitive, "=" => Util.Strings.Equal); -- Initial_Size is the default (23); Macros : Hashing.Hash_Table; Predef : Hashing.Hash_Table; function Is_Nil (Expr : in Expression) return Boolean is begin return Expr.Ptr = null; end Is_Nil; function Is_Boolean (Expr : in Expression) return Boolean is begin return Expr.Ptr /= null and then Expr.Ptr.all in Bool_Exp'Class; end Is_Boolean; function Parse (Text : in String) return Expression is Curr : Natural := Text'First; -- Current position in 'Text'. procedure Error (Msg : in String) is begin Ada.Exceptions.Raise_Exception (Parse_Error'Identity, Msg); end Error; procedure Get (Name : in String; Expr : out Expression; Found : out Boolean) is begin Found := True; begin Expr := Hashing.Retrieve (Predef, Name); exception when Hashing.Not_Found => begin Expr := Hashing.Retrieve (Macros, Name); exception when Hashing.Container_Empty | Hashing.Not_Found => Found := False; Expr := Nil_Expression; end; end; end Get; procedure Skip (May_Fail : in Boolean := False) is Start : constant Natural := Curr; begin Curr := Util.Strings.Next_Non_Blank (Text (Curr .. Text'Last)); if not May_Fail and then Curr = 0 then Error ("Unexpected end of expression: " & Text (Start .. Text'Last)); end if; if Curr = 0 then Curr := Text'Last + 1; end if; end Skip; function Create (Op : in Operator; Left, Right : in Expression; Pos : in Natural) return Expression is -- Combine expressions, including semantic checks! function Create (Op : in Operator; Left, Right : in Expression; Pos : in Natural) return Expression_Ptr is begin case Op is when Op_Not => if not Is_Nil (Right) then Ada.Exceptions.Raise_Exception (Program_Error'Identity, "Error in expression parser: binary 'not' operator?!"); end if; if Left.Ptr.all not in Bool_Exp'Class then Error ("'not' needs boolean argument: " & Text (Pos .. Text'Last)); end if; return new Not_Exp'(Exp with Arg => Left); when Op_Or | Op_Xor | Op_And => if Left.Ptr.all not in Bool_Exp'Class or else Right.Ptr.all not in Bool_Exp'Class then Error ("boolean operator with string argument: " & Text (Pos .. Text'Last)); end if; if Op = Op_Or then return new Or_Exp'(Exp with Left => Left, Right => Right); elsif Op = Op_Xor then return new Xor_Exp'(Exp with Left => Left, Right => Right); else return new And_Exp'(Exp with Left => Left, Right => Right); end if; when Op_Eq | Op_Neq => if Left.Ptr.all in Bool_Exp'Class xor Right.Ptr.all in Bool_Exp'Class then Error ("equality operator with mixed arguments: " & Text (Pos .. Text'Last)); end if; declare Expr : constant Expression_Ptr := new Eq_Exp'(Exp with Left => Left, Right => Right); begin if Op = Op_Neq then return new Not_Exp' (Exp with Arg => (Ada.Finalization.Controlled with Ptr => Expr)); else return Expr; end if; end; when Op_Concat | Op_Prefix => if Left.Ptr.all not in String_Exp'Class or else Right.Ptr.all not in String_Exp'Class then Error ("'&' and '@' need string arguments: " & Text (Pos .. Text'Last)); end if; if Op = Op_Concat then return new Concat_Exp'(Exp with Left => Left, Right => Right); else return new Prefix_Exp'(Exp with Left => Left, Right => Right); end if; when others => Ada.Exceptions.Raise_Exception (Program_Error'Identity, "Error in expression parser (Op_None in Create)"); end case; return null; end Create; begin return (Ada.Finalization.Controlled with Ptr => Create (Op, Left, Right, Pos)); end Create; Precedence : constant array (Operator) of Natural := (Op_Not | Op_Concat => 1, Op_Prefix => 2, Op_Eq | Op_Neq => 3, Op_And => 4, Op_Or | Op_Xor => 5, Op_None => 6); Lowest_Precedence : constant Natural := Precedence (Op_None); Last_Op : Operator := Op_None; -- An operator precedence parser needs a one-token look-ahead. We could -- have implemented this by setting 'Curr' at the beginning of the last -- operator and later rescanning, but that would incur a higher -- overhead. Last_Pos : Natural := 0; -- But we still keep the position of the last operator for error -- reporting purposes! function Parse_Operator return Operator is -- Binary operators only! begin Skip (May_Fail => True); -- If nothing follows, we've hit the end of the expression. if Curr > Text'Last then return Op_None; end if; if Text (Curr) = ')' or else Text (Curr) = ';' then return Op_None; elsif Text (Curr) = '=' then Curr := Curr + 1; return Op_Eq; elsif Text (Curr) = '&' then Curr := Curr + 1; return Op_Concat; elsif Text (Curr) = '@' then Curr := Curr + 1; return Op_Prefix; elsif Curr < Text'Last and then Text (Curr .. Curr + 1) = "/=" then Curr := Curr + 2; return Op_Neq; else declare Found : Boolean; Expr : Expression; I : constant Natural := Util.Strings.Identifier (Text (Curr .. Text'Last)); Op : Operator := Op_None; begin if I = 0 then Error ("Operator missing: " & Text (Curr .. Text'Last)); end if; Get (Text (Curr .. I), Expr, Found); if not Found then Error ("Unknown function """ & Text (Curr .. I) & '"'); end if; if Expr.Ptr.all in Predefined'Class then Op := Predefined (Expr.Ptr.all).Op; else Error ("Operator missing: " & Text (Curr .. Text'Last)); end if; if Op = Op_Not then Error ("'not' not allowed here: " & Text (Curr .. Text'Last)); end if; Curr := I + 1; return Op; end; end if; end Parse_Operator; function Parse_Expr (Max_Op : in Natural := Lowest_Precedence) return Expression is function Parse_Term return Expression is function Parse_Factor return Expression is Expr : Expression; begin Last_Op := Op_None; Skip; if Text (Curr) = '(' then declare Start : constant Natural := Curr; begin Expr := Parse_Expr; Last_Op := Op_None; Skip (May_Fail => True); -- We allow failing because we want to emit a more -- meaningful error message. if Curr > Text'Last or else Text (Curr) /= ')' then Error ("Missing ')': " & Text (Start .. Curr - 1)); end if; Curr := Curr + 1; end; elsif Text (Curr) = '"' then -- String literal: declare Start : constant Natural := Curr; I : constant Natural := Util.Strings.Skip_String (Text (Curr .. Text'Last), '"', '"'); begin if I = 0 then Error ("String not closed: " & Text (Curr .. Text'Last)); end if; Curr := I + 1; return (Ada.Finalization.Controlled with Ptr => new Exp'Class' (Exp'Class (Literal' (Exp with Val => ASU.To_Unbounded_String (Util.Strings.Unquote (Text (Start + 1 .. I - 1), '"', '"')))))); end; else declare Found : Boolean; I : constant Natural := Util.Strings.Identifier (Text (Curr .. Text'Last)); begin if I = 0 then Error ("Identifier expected: " & Text (Curr .. Text'Last)); end if; Get (Text (Curr .. I), Expr, Found); if not Found then Error ("Unknown function """ & Text (Curr .. I) & '"'); end if; if Expr.Ptr.all in Predefined'Class then Error ("Unexpected operator: " & Text (Curr .. Text'Last)); end if; Curr := I + 1; end; end if; return Expr; end Parse_Factor; begin Last_Op := Op_None; Skip; declare Start : constant Natural := Curr; I : constant Natural := Util.Strings.Identifier (Text (Curr .. Text'Last)); begin if I = Curr + 2 and then Util.Strings.To_Lower (Text (Curr .. I)) = "not" then Curr := I + 1; return Create (Op_Not, Parse_Factor, Nil_Expression, Start); end if; end; return Parse_Factor; end Parse_Term; Expr : Expression; Start : Natural; Op : Operator; begin -- This is an operator precedence parser. Expr := Parse_Term; while Curr <= Text'Last loop if Last_Op = Op_None then Start := Curr; Op := Parse_Operator; if Op = Op_None then -- OK if text exhausted, or at a probable expression end. exit when Curr > Text'Last or else Text (Curr) = ')' or else Text (Curr) = ';'; Error ("Operator expected: " & Text (Start .. Text'Last)); end if; else Op := Last_Op; Start := Last_Pos; end if; if Precedence (Op) >= Max_Op then Last_Op := Op; Last_Pos := Start; return Expr; end if; Last_Op := Op_None; Expr := Create (Op, Expr, Parse_Expr (Max_Op => Precedence (Op)), Start); end loop; return Expr; end Parse_Expr; Expr : Expression; begin Expr := Parse_Expr; if Last_Op /= Op_None then Error ("Spurious operator at end of expression: " & Text (Last_Pos .. Text'Last)); end if; if Curr <= Text'Last then -- We allow a semicolon at the end. if Text (Curr) = ';' then Curr := Curr + 1; end if; Skip (May_Fail => True); -- If there's still something following, we have an error. if Curr <= Text'Last then Error ("Garbage following expression: " & Text (Curr .. Text'Last)); end if; end if; return Expr; end Parse; procedure Define_Macro (Name : in String; Expr : in Expression; Redefined : out Boolean) is begin if Hashing.Contains (Predef, Name) then Ada.Exceptions.Raise_Exception (Parse_Error'Identity, "Predefined functions and operators cannot be redefined!"); end if; Redefined := Hashing.Contains (Macros, Name); Hashing.Replace (Macros, Name, Expr); end Define_Macro; function Evaluate (Expr : in Expression; Argument : in Asis.Element) return Boolean is begin return Eval (Bool_Exp'Class (Expr.Ptr.all), Argument); end Evaluate; function Eval (E : in Terminal; Argument : in Asis.Element) return Boolean is begin return E.P /= null and then E.P (Argument); end Eval; function Eval (E : in Value; Argument : in Asis.Element) return Boolean is pragma Warnings (Off, Argument); -- silence -gnatwa begin return E.Val; end Eval; function Eval (E : in And_Exp; Argument : in Asis.Element) return Boolean is begin return Eval (Bool_Exp'Class (E.Left.Ptr.all), Argument) and then Eval (Bool_Exp'Class (E.Right.Ptr.all), Argument); end Eval; function Eval (E : in Or_Exp; Argument : in Asis.Element) return Boolean is begin return Eval (Bool_Exp'Class (E.Left.Ptr.all), Argument) or else Eval (Bool_Exp'Class (E.Right.Ptr.all), Argument); end Eval; function Eval (E : in Xor_Exp; Argument : in Asis.Element) return Boolean is begin return Eval (Bool_Exp'Class (E.Left.Ptr.all), Argument) xor Eval (Bool_Exp'Class (E.Right.Ptr.all), Argument); end Eval; function Eval (E : in Eq_Exp; Argument : in Asis.Element) return Boolean is begin if E.Left.Ptr.all in Bool_Exp'Class then return Eval (Bool_Exp'Class (E.Left.Ptr.all), Argument) = Eval (Bool_Exp'Class (E.Right.Ptr.all), Argument); else return Util.Strings.Equal (Eval (String_Exp'Class (E.Left.Ptr.all), Argument), Eval (String_Exp'Class (E.Right.Ptr.all), Argument)); end if; end Eval; function Eval (E : in Prefix_Exp; Argument : in Asis.Element) return Boolean is begin -- We know we have two string expressions! declare Left : constant String := Util.Strings.To_Lower (Eval (String_Exp'Class (E.Left.Ptr.all), Argument)); Right : constant String := Util.Strings.To_Lower (Eval (String_Exp'Class (E.Right.Ptr.all), Argument)); begin return Util.Strings.Is_Prefix (Left, Right); end; end Eval; function Eval (E : in Not_Exp; Argument : in Asis.Element) return Boolean is begin return not Eval (Bool_Exp'Class (E.Arg.Ptr.all), Argument); end Eval; ---------------------------------------------------------------------------- function Eval (E : in String_Terminal; Argument : in Asis.Element) return String is begin if E.P = null then return ""; end if; return ACH.To_String (E.P (Argument)); end Eval; function Eval (E : in Literal; Argument : in Asis.Element) return String is pragma Warnings (Off, Argument); -- silence -gnatwa begin return ASU.To_String (E.Val); end Eval; function Eval (E : in Concat_Exp; Argument : in Asis.Element) return String is begin return Eval (String_Exp'Class (E.Left.Ptr.all), Argument) & Eval (String_Exp'Class (E.Right.Ptr.all), Argument); end Eval; ---------------------------------------------------------------------------- procedure Adjust (E : in out Expression) is begin if E.Ptr /= null then E.Ptr.Ref_Count := E.Ptr.Ref_Count + 1; end if; end Adjust; procedure Finalize (E : in out Expression) is procedure Free is new Ada.Unchecked_Deallocation (Exp'Class, Expression_Ptr); begin if E.Ptr /= null then E.Ptr.Ref_Count := E.Ptr.Ref_Count - 1; if E.Ptr.Ref_Count = 0 then Free (E.Ptr); end if; end if; end Finalize; ---------------------------------------------------------------------------- begin Hashing.Set_Resize (Macros, 0.75); Hashing.Set_Resize (Predef, 0.75); declare Linear_Growth : GAL.Support.Hashing.Linear_Growth_Policy (20); begin Hashing.Set_Growth_Policy (Macros, Linear_Growth); Hashing.Set_Growth_Policy (Predef, Linear_Growth); end; Add_Predefined : declare procedure Add_Expression (Name : in String; Expr : in Exp'Class) is E : Expression := (Ada.Finalization.Controlled with Ptr => new Exp'Class'(Expr)); begin Hashing.Insert (Predef, Name, E); end Add_Expression; use AD.Predicates; begin Add_Expression ("private", Terminal'(Exp with P => Is_Private'Access)); Add_Expression ("separate", Terminal'(Exp with P => Is_Separate'Access)); Add_Expression ("unit", Terminal'(Exp with P => Is_Unit'Access)); Add_Expression ("package", Terminal'(Exp with P => Is_Package'Access)); Add_Expression ("child", Terminal'(Exp with P => Is_Child'Access)); Add_Expression ("constant", Terminal'(Exp with P => Is_Constant'Access)); Add_Expression ("pragma", Terminal'(Exp with P => Is_Pragma'Access)); Add_Expression ("representation", Terminal'(Exp with P => Is_Clause'Access)); Add_Expression ("variable", Terminal'(Exp with P => Is_Variable'Access)); Add_Expression ("type", Terminal'(Exp with P => Is_Type'Access)); Add_Expression ("subtype", Terminal'(Exp with P => Is_Subtype'Access)); Add_Expression ("procedure", Terminal'(Exp with P => Is_Procedure'Access)); Add_Expression ("function", Terminal'(Exp with P => Is_Function'Access)); Add_Expression ("subprogram", Terminal'(Exp with P => Is_Subprogram'Access)); Add_Expression ("entry", Terminal'(Exp with P => Is_Entry'Access)); Add_Expression ("elementary", Terminal'(Exp with P => Is_Elementary'Access)); Add_Expression ("scalar", Terminal'(Exp with P => Is_Scalar'Access)); Add_Expression ("discrete", Terminal'(Exp with P => Is_Discrete'Access)); Add_Expression ("enum", Terminal'(Exp with P => Is_Enumeration'Access)); Add_Expression ("integral", Terminal'(Exp with P => Is_Integral'Access)); Add_Expression ("signed", Terminal'(Exp with P => Is_Signed'Access)); Add_Expression ("modular", Terminal'(Exp with P => Is_Modular'Access)); Add_Expression ("real", Terminal'(Exp with P => Is_Real'Access)); Add_Expression ("float", Terminal'(Exp with P => Is_Float'Access)); Add_Expression ("fixed", Terminal'(Exp with P => Is_Fixed'Access)); Add_Expression ("ordinary_fixed", Terminal'(Exp with P => Is_Ordinary_Fixed'Access)); Add_Expression ("decimal_fixed", Terminal'(Exp with P => Is_Decimal_Fixed'Access)); Add_Expression ("numeric", Terminal'(Exp with P => Is_Numeric'Access)); Add_Expression ("access", Terminal'(Exp with P => Is_Access'Access)); Add_Expression ("access_object", Terminal'(Exp with P => Is_Access_To_Object'Access)); Add_Expression ("access_subprogram", Terminal'(Exp with P => Is_Access_To_Subprogram'Access)); Add_Expression ("composite", Terminal'(Exp with P => Is_Composite'Access)); Add_Expression ("array", Terminal'(Exp with P => Is_Array'Access)); Add_Expression ("record", Terminal'(Exp with P => Is_Record'Access)); Add_Expression ("tagged", Terminal'(Exp with P => Is_Tagged'Access)); Add_Expression ("task", Terminal'(Exp with P => Is_Task'Access)); Add_Expression ("protected", Terminal'(Exp with P => Is_Protected'Access)); Add_Expression ("limited", Terminal'(Exp with P => Is_Limited'Access)); Add_Expression ("class_wide", Terminal'(Exp with P => Is_Class_Wide'Access)); Add_Expression ("controlled", Terminal'(Exp with P => Is_Controlled'Access)); Add_Expression ("private_type", Terminal'(Exp with P => Is_Private_Type'Access)); Add_Expression ("incomplete", Terminal'(Exp with P => Is_Incomplete'Access)); Add_Expression ("aliased", Terminal'(Exp with P => Is_Aliased'Access)); Add_Expression ("exception", Terminal'(Exp with P => Is_Exception'Access)); Add_Expression ("renaming", Terminal'(Exp with P => Is_Renaming'Access)); Add_Expression ("generic", Terminal'(Exp with P => Is_Generic'Access)); Add_Expression ("formal", Terminal'(Exp with P => Is_Generic_Formal'Access)); Add_Expression ("instance", Terminal'(Exp with P => Is_Instance'Access)); Add_Expression ("abstract", Terminal'(Exp with P => Is_Abstract'Access)); Add_Expression ("full_name", String_Terminal'(Exp with P => Unique_Name'Access)); Add_Expression ("name", String_Terminal'(Exp with P => Simple_Name'Access)); Add_Expression ("true", Value'(Exp with Val => True)); Add_Expression ("false", Value'(Exp with Val => False)); -- Also insert the keywords (facilitates checking whether someone had -- the glorious idea to name a macro "not"). Add_Expression ("not", Predefined'(Exp with Op => Op_Not)); Add_Expression ("and", Predefined'(Exp with Op => Op_And)); Add_Expression ("or", Predefined'(Exp with Op => Op_Or)); Add_Expression ("xor", Predefined'(Exp with Op => Op_Xor)); end Add_Predefined; end AD.Expressions; adabrowse_4.0.3/config/0000755000175000017500000000000010234242071013123 5ustar kenkenadabrowse_4.0.3/config/adconf.adb0000644000175000017500000001743510234241457015046 0ustar kenken-- Configure AdaBrowse with or without project file support with Ada.Calendar; with Ada.Command_Line; with Ada.Strings.Unbounded; with Ada.Text_IO; with Util.Execution; with Util.Files; with Util.Pathes; with Util.Strings; with Util.Calendar.IO; procedure ADConf is package ASU renames Ada.Strings.Unbounded; Gcc : ASU.Unbounded_String; Asis_Dir : ASU.Unbounded_String; Gnat_Src : ASU.Unbounded_String; Gnat_Lib : ASU.Unbounded_String; function Handle_Command_Line return Boolean is use Ada.Command_Line; begin if Argument_Count /= 4 then return False; end if; Gcc := ASU.To_Unbounded_String (Argument (1)); Asis_Dir := ASU.To_Unbounded_String (Argument (2)); Gnat_Src := ASU.To_Unbounded_String (Argument (3)); Gnat_Lib := ASU.To_Unbounded_String (Argument (4)); return True; end Handle_Command_Line; function Configure return Boolean is procedure Open is new Util.Files.Open_G (Ada.Text_IO.File_Type, Ada.Text_IO.File_Mode, Ada.Text_IO.Open, Ada.Text_IO.Create); use Ada.Text_IO; procedure Generate_Header (File : in out File_Type) is Now : Ada.Calendar.Time := Ada.Calendar.Clock; begin Put_Line (File, "-- This file has been generated automatically by the"); Put_Line (File, "-- AdaBrowse configuration tool adconf."); Put_Line (File, "--"); Put_Line (File, "-- Generated on " & Util.Calendar.IO.Image (Now) & ' ' & Util.Calendar.IO.Image (Ada.Calendar.Seconds (Now))); Put_Line (File, "--"); Put_Line (File, "-- DO NOT MODIFY THIS FILE!"); New_Line (File); Put_Line (File, "pragma License (GPL);"); New_Line (File); end Generate_Header; procedure Generate_Stub (Component : in String) is File : File_Type; begin Open (File, Out_File, "ad-projects-impl_yes-get_parent.adb"); Generate_Header (File); Put_Line (File, "with Prj;"); Put_Line (File, "separate (AD.Projects.Impl_Yes)"); Put_Line (File, "function Get_Parent"); Put_Line (File, " (Project : in Prj.Project_Id)"); Put_Line (File, " return Prj.Project_Id"); Put_Line (File, "is"); Put_Line (File, "begin"); Put_Line (File, " return Prj.Projects.Table (Project)." & Component & ';'); Put_Line (File, "end Get_Parent;"); Close (File); end Generate_Stub; procedure Generate_Renaming (Package_Suffix : in String) is Package_Name : constant String := "AD.Projects.Impl_" & Package_Suffix; File : File_Type; begin Open (File, Out_File, "ad-projects-impl.ads"); Generate_Header (File); Put_Line (File, "with " & Package_Name & ';'); Put_Line (File, "private package AD.Projects.Impl"); Put_Line (File, " renames " & Package_Name & ';'); Close (File); end Generate_Renaming; function Try_To_Build return Boolean is File : File_Type; Three_Fifteen_Tried : Boolean; GnatMake : constant String := "gnatmake -q -gnatwIL -I. -I.." & " -I" & ASU.To_String (Asis_Dir) & " -I" & ASU.To_String (GNAT_Lib) & " -I" & ASU.To_String (Gnat_Src) & " adtest -largs -lasis"; begin -- Generate the renaming. Generate_Renaming ("Yes"); -- Generate the stub. Try to get it right the first time: if Util.Strings.First_Index (ASU.To_String (Gnat_Src), "3.15") /= 0 then Three_Fifteen_Tried := True; Generate_Stub ("Modifies"); else Three_Fifteen_Tried := False; Generate_Stub ("Extends"); end if; -- Try to compile the file: declare Result : Integer; begin Util.Execution.Execute (ASU.To_String (Gcc) & " -c ../util-nl.c"); Result := Util.Execution.Execute (GnatMake); if Result /= 0 then -- Maybe the stub was wrong? if Three_Fifteen_Tried then Generate_Stub ("Extends"); else Generate_Stub ("Modifies"); end if; Result := Util.Execution.Execute (GnatMake); end if; return Result = 0; end; end Try_To_Build; procedure Remove (Name : in String) is File : File_Type; begin Ada.Text_IO.Open (File, In_File, Name); Delete (File); exception when others => null; end Remove; File : File_Type; begin if Handle_Command_Line then Put_Line (Current_Error, "==============================="); Put_Line (Current_Error, "AdaBrowse configuration STARTS."); Put_Line (Current_Error, "Compiler => " & ASU.To_String (Gcc)); Put_Line (Current_Error, "ASIS installation => " & ASU.To_String (Asis_Dir)); Put_Line (Current_Error, "GNAT sources => " & ASU.To_String (Gnat_Src)); Put_Line (Current_Error, "GNAT library => " & ASU.To_String (Gnat_Lib)); -- Generate the test main program. We want to try linking, too! Open (File, Out_File, "adtest.adb"); Put_Line (File, "-- This file is just temporary, it will be deleted"); Put_Line (File, "-- once AdaBrowse is configured."); Put_Line (File, "with AD.Projects;"); Put_Line (File, "procedure ADTest is"); Put_Line (File, "begin"); Put_Line (File, " AD.Projects.Handle_Project_File (""blah"");"); Put_Line (File, "end ADTest;"); Close (File); declare Result : Boolean := Try_To_Build; begin -- Delete the test driver Remove ("adtest.adb"); Remove ("adtest.o"); Remove ("adtest.ali"); Remove ("adtest.exe"); if Result then return True; else Put_Line (Current_Error, "Cannot configure AdaBrowse with GNAT project manager " & "support."); end if; end; end if; -- Didn't work: generate a renaming that points to a null -- implementation. Generate_Renaming ("No"); return False; end Configure; begin if Configure then Ada.Text_IO.Put_Line (Ada.Text_IO.Current_Error, "=================================================="); Ada.Text_IO.Put_Line (Ada.Text_IO.Current_Error, "AdaBrowse configured WITH project manager support."); else Ada.Text_IO.Put_Line (Ada.Text_IO.Current_Error, "====================================================="); Ada.Text_IO.Put_Line (Ada.Text_IO.Current_Error, "AdaBrowse configured WITHOUT project manager support."); end if; Ada.Command_Line.Set_Exit_Status (Ada.Command_Line.Success); exception when others => Ada.Text_IO.Put_Line (Ada.Text_IO.Current_Error, "================================"); Ada.Text_IO.Put_Line (Ada.Text_IO.Current_Error, "AdaBrowse configuration FAILED!!"); Ada.Command_Line.Set_Exit_Status (Ada.Command_Line.Failure); raise; end ADConf; adabrowse_4.0.3/util-text-internal.ads0000644000175000017500000000437210234241447016134 0ustar kenken------------------------------------------------------------------------------- -- -- Copyright © 2001, 2002 by Thomas Wolf. --
-- This piece of software is free software; you can redistribute it and/or -- modify it under the terms of the GNU General Public License as published -- by the Free Software Foundation; either version 2, or (at your option) -- any later version. This software is distributed in the hope that it will -- be useful, but without any warranty; without even the implied -- warranty of merchantability or fitness for a particular purpose. -- See the GNU General Public License for more details. You should have -- received a copy of the GNU General Public License with this distribution, -- see file "GPL.txt". If not, write to the Free -- Software Foundation, 59 Temple Place - Suite 330, Boston, MA 02111-1307, -- USA. --
--
-- As a special exception from the GPL, if other files instantiate generics -- from this unit, or you link this unit with other files to produce an -- executable, this unit does not by itself cause the resulting executable -- to be covered by the GPL. This exception does not however invalidate any -- other reasons why the executable file might be covered by the GPL. --
-- -- -- Thomas Wolf (TW) -- -- -- -- Direct access to the internal string buffer. -- -- -- -- -- -- Dynamic storage allocation in the default pool. -- -- -- -- 07-JUN-2002 TW Initial version. -- ------------------------------------------------------------------------------- pragma License (Modified_GPL); package Util.Text.Internal is pragma Elaborate_Body; function Get_Ptr (Source : in Unbounded_String) return String_Access; -- Lower bound is 1. procedure Set_Ptr (Source : in out Unbounded_String; Ptr : in String_Access); -- This is highly unsafe. @Ptr.all@ must be dynamically allocated; its -- lower index must be 1. Neither is checked. private pragma Inline (Get_Ptr, Set_Ptr); end Util.Text.Internal; adabrowse_4.0.3/ad-crossrefs.ads0000644000175000017500000000715010234241442014746 0ustar kenken------------------------------------------------------------------------------- -- -- This file is part of AdaBrowse. -- -- Copyright (c) 2002 by Thomas Wolf. --
-- AdaBrowse is free software; you can redistribute it and/or modify it -- under the terms of the GNU General Public License as published by the -- Free Software Foundation; either version 2, or (at your option) any -- later version. AdaBrowse is distributed in the hope that it will be -- useful, but without any warranty; without even the implied -- warranty of merchantability or fitness for a particular purpose. -- See the GNU General Public License for more details. You should have -- received a copy of the GNU General Public License with this distribution, -- see file "GPL.txt". If not, write to the Free -- Software Foundation, 59 Temple Place - Suite 330, Boston, MA 02111-1307, -- USA. --
-- --
-- Author:
-- Thomas Wolf (TW) --
twolf@acm.org
-- --
-- Purpose:
-- Singled out crossreference setup from AD.Writers.
-- -- ------------------------------------------------------------------------------- pragma License (GPL); with Ada.Strings.Wide_Unbounded; with Asis; with AD.Messages; with Asis2.Spans; package AD.Crossrefs is pragma Elaborate_Body; type Cross_Reference is record Full_Unit_Name : Ada.Strings.Wide_Unbounded.Unbounded_Wide_String; Image : Ada.Strings.Wide_Unbounded.Unbounded_Wide_String; Position : Asis2.Spans.Position; Is_Local : Boolean; Is_Top_Unit : Boolean; Ignore : Boolean; end record; Null_Crossref : constant Cross_Reference; function Crossref_Name (Name : in Asis.Defining_Name; This_Unit : in Asis.Declaration; Reporter : access AD.Messages.Error_Reporter'Class) return Cross_Reference; function Crossref_Special (Element : in Asis.Element; This_Unit : in Asis.Declaration) return Cross_Reference; function Crossref_Exp (Name : in Asis.Expression; This_Unit : in Asis.Declaration; Reporter : access AD.Messages.Error_Reporter'Class) return Cross_Reference; procedure Set_Standard_Units (Do_Them : in Boolean); -- If @Do_Them@ is @True@, AdaBrowse will generate cross-refs to standard -- units, too. function Crossref_To_Unit (Unit : in Asis.Compilation_Unit) return Boolean; -- Returns @True@ if cross-refs to the @Unit@ shall be created. Returns -- @False@ for @Standard@ and any unit excluded by a NoXRef key. If -- Set_Standard_Units (True) has been called, returns @True@ -- for non-application units, otherwise, it'll always return @False@ for -- such units. private Null_Crossref : constant Cross_Reference := (Full_Unit_Name => Ada.Strings.Wide_Unbounded.Null_Unbounded_Wide_String, Image => Ada.Strings.Wide_Unbounded.Null_Unbounded_Wide_String, Position => Asis2.Spans.Nil_Position, Is_Local => False, Is_Top_Unit => False, Ignore => True); end AD.Crossrefs; adabrowse_4.0.3/gal-storage.ads0000644000175000017500000000434110234241446014563 0ustar kenken------------------------------------------------------------------------------- -- -- Copyright (c) 2001, 2002 by Thomas Wolf. --
-- This piece of software is free software; you can redistribute it and/or -- modify it under the terms of the GNU General Public License as published -- by the Free Software Foundation; either version 2, or (at your option) -- any later version. This unit is distributed in the hope that it will be -- useful, but without any warranty; without even the implied -- warranty of merchantability or fitness for a particular purpose. -- See the GNU General Public License for more details. You should have -- received a copy of the GNU General Public License with this distribution, -- see file "GPL.txt". If not, write to the Free -- Software Foundation, 59 Temple Place - Suite 330, Boston, MA 02111-1307, -- USA. --
--
-- As a special exception from the GPL, if other files instantiate generics -- from this unit, or you link this unit with other files to produce an -- executable, this unit does not by itself cause the resulting executable -- to be covered by the GPL. This exception does not however invalidate any -- other reasons why the executable file might be covered by the GPL. --
-- --
-- Author:
-- Thomas Wolf (TW) --
twolf@acm.org
-- --
-- Purpose:
-- Root package for the storage subsystem, which provides storage managers -- (storage pools), including a default one, as well as a signature package -- for simplifying using pools together with containers. --

-- To use the standard storage pool (at least on GNAT), use package -- GAL.Storage.Standard -- to instantiate the containers.
-- -- ------------------------------------------------------------------------------- pragma License (Modified_GPL); package GAL.Storage is pragma Pure; -- This package is empty. end GAL.Storage; adabrowse_4.0.3/util-environment.ads0000644000175000017500000000651110234241446015676 0ustar kenken------------------------------------------------------------------------------- -- -- Copyright © 2001, 2002 by Thomas Wolf. --
-- This piece of software is free software; you can redistribute it and/or -- modify it under the terms of the GNU General Public License as published -- by the Free Software Foundation; either version 2, or (at your option) -- any later version. This software is distributed in the hope that it will -- be useful, but without any warranty; without even the implied -- warranty of merchantability or fitness for a particular purpose. -- See the GNU General Public License for more details. You should have -- received a copy of the GNU General Public License with this distribution, -- see file "GPL.txt". If not, write to the Free -- Software Foundation, 59 Temple Place - Suite 330, Boston, MA 02111-1307, -- USA. --
--
-- As a special exception from the GPL, if other files instantiate generics -- from this unit, or you link this unit with other files to produce an -- executable, this unit does not by itself cause the resulting executable -- to be covered by the GPL. This exception does not however invalidate any -- other reasons why the executable file might be covered by the GPL. --
-- -- -- Thomas Wolf (TW) -- -- -- -- Operations on environment variables. -- -- -- -- Fully task- and abortion-safe. -- -- -- -- -- -- 03-OCT-2001 TW Initial version. -- 01-MAY-2002 TW Added 'Expand'. -- 03-MAY-2002 TW Added 'Safe_Get', and the 'Expander' types. -- ------------------------------------------------------------------------------- pragma License (Modified_GPL); package Util.Environment is pragma Elaborate_Body; Not_Defined : exception; function Get (Name : in String) return String; -- Raises @Not_Defined@ if the environment variable @Name@ is not defined. -- Returns an empty string if the environment variable is so defined. -- -- Note: it is entirely implementation-defined whether or not environment -- variable names are case sensitive. function Safe_Get (Name : in String) return String; -- As @Get@, but return an empty string if the variable is not defined. -- Never raises @Not_Defined@. ---------------------------------------------------------------------------- type Expander is abstract tagged limited private; function Get (Self : access Expander; Name : in String) return String; -- Default calls @Safe_Get@ above. type String_Expander is abstract new Expander with private; function Expand (Self : access String_Expander; Source : in String) return String is abstract; -- Replaces all references to environment variables in @Source@ by that -- variable's definition and returns the resulting string. It is undefined -- what happens with syntactically invalid references or references to -- variables that are not defined. private type Expander is abstract tagged limited null record; type String_Expander is abstract new Expander with null record; end Util.Environment; adabrowse_4.0.3/ad-descriptions.ads0000644000175000017500000000732710234241442015451 0ustar kenken------------------------------------------------------------------------------- -- -- This file is part of AdaBrowse. -- -- Copyright (c) 2002 by Thomas Wolf. --
-- AdaBrowse is free software; you can redistribute it and/or modify it -- under the terms of the GNU General Public License as published by the -- Free Software Foundation; either version 2, or (at your option) any -- later version. AdaBrowse is distributed in the hope that it will be -- useful, but without any warranty; without even the implied -- warranty of merchantability or fitness for a particular purpose. -- See the GNU General Public License for more details. You should have -- received a copy of the GNU General Public License with this distribution, -- see file "GPL.txt". If not, write to the Free -- Software Foundation, 59 Temple Place - Suite 330, Boston, MA 02111-1307, -- USA. --
-- --
-- Author:
-- Thomas Wolf (TW) --
twolf@acm.org
-- --
-- Purpose:
-- Storage of description definitions.
-- -- ------------------------------------------------------------------------------- pragma License (GPL); with Asis.Text; with Asis2.Spans; package AD.Descriptions is pragma Elaborate_Body; procedure Parse (Selector : in String; Value : in String); ---------------------------------------------------------------------------- type Item_Classes is (No_Item_Class, Item_Context_Clause, -- with, use, or use type clause Item_Clause, -- An interior use or use type clause Item_Constant, Item_Container, -- Task, Protected, Package Item_Exception, Item_Instantiation, Item_Library, -- Package, Renaming, Subprogram Item_Library_Instantiation, Item_Library_Package, Item_Library_Renaming, Item_Library_Subprogram, Item_Object, Item_Package, -- *Nested* packages, not library level! Item_Pragma, Item_Protected, -- Protected objects and types Item_Renaming, Item_Rep_Clause, Item_Subprogram, Item_Task, -- Single_Task_Decls and task types Item_Type); function Item_Class (Item : in Asis.Element) return Item_Classes; function Is_Container (Class : in Item_Classes) return Boolean; ---------------------------------------------------------------------------- type Comment_Finder is private; procedure Find (Self : in Comment_Finder; Item : in Asis.Element; Span : out Asis.Text.Span; Class : in Item_Classes := No_Item_Class); procedure Find (Self : in Comment_Finder; Item : in Asis.Element; From : in Asis2.Spans.Position; To : in Asis2.Spans.Position; Span : out Asis.Text.Span; Class : in Item_Classes := No_Item_Class); procedure Clear_Comments; type Finders is array (Positive range <>) of Comment_Finder; type Finders_Ptr is access all Finders; function Get_Finders (The_Class : in Item_Classes) return Finders_Ptr; private type Location is (None, Before, After, Inside); Unlimited : constant := -1; type Comment_Finder is record Where : Location; How_Far : Integer := Unlimited; end record; end AD.Descriptions; adabrowse_4.0.3/ad-printers-html.adb0000644000175000017500000010326610234241451015531 0ustar kenken------------------------------------------------------------------------------- -- -- This file is part of AdaBrowse. -- -- Copyright (c) 2002 by Thomas Wolf. --
-- AdaBrowse is free software; you can redistribute it and/or modify it -- under the terms of the GNU General Public License as published by the -- Free Software Foundation; either version 2, or (at your option) any -- later version. AdaBrowse is distributed in the hope that it will be -- useful, but without any warranty; without even the implied -- warranty of merchantability or fitness for a particular purpose. -- See the GNU General Public License for more details. You should have -- received a copy of the GNU General Public License with this distribution, -- see file "GPL.txt". If not, write to the Free -- Software Foundation, 59 Temple Place - Suite 330, Boston, MA 02111-1307, -- USA. --
-- --
-- Author:
-- Thomas Wolf (TW) --
twolf@acm.org
-- --
-- Purpose:
-- HTML output producer.
-- -- ------------------------------------------------------------------------------- pragma License (GPL); with Ada.Characters.Handling; with Ada.Exceptions; with Ada.Strings.Unbounded; with Ada.Strings.Wide_Unbounded; with Ada.Unchecked_Deallocation; with Asis.Text; with Asis2.Spans; with AD.Format; with AD.Messages; with AD.HTML.Pathes; with AD.Text_Utilities; with Util.Pathes; with Util.Strings; with Util.Text.Internal; package body AD.Printers.HTML is procedure Free is new Ada.Unchecked_Deallocation (Blocks, Block_Ptr); package ACH renames Ada.Characters.Handling; package ASM renames Ada.Strings.Maps; package ASU renames Ada.Strings.Unbounded; package WASU renames Ada.Strings.Wide_Unbounded; use AD.HTML; use Util.Strings; ---------------------------------------------------------------------------- HTML_Suffix : constant String := "html"; function Get_Suffix (Self : in Printer) return String is pragma Warnings (Off, Self); -- silence -gnatwa begin return HTML_Suffix; end Get_Suffix; Index_XRef_Stuff : ASU.Unbounded_String; procedure Set_Index_XRef (Value : in String) is begin Index_XRef_Stuff := ASU.To_Unbounded_String (Value); end Set_Index_XRef; ---------------------------------------------------------------------------- procedure Open_XRef (Self : access Printer; XRef : in AD.Crossrefs.Cross_Reference; Is_Index : in Boolean) is begin if XRef.Ignore or else (XRef.Is_Local and then XRef.Is_Top_Unit) then Self.No_XRef := True; return; end if; Self.No_XRef := False; Put (Self, "'); else Put (Self, """>"); end if; end Open_XRef; procedure Put_XRef (Self : access Printer; XRef : in AD.Crossrefs.Cross_Reference; Code : in Boolean := True; Is_Index : in Boolean := False) is begin if Code then Put (Self, ""); end if; Open_XRef (Self, XRef, Is_Index); Put (Self, HTMLize (ACH.To_String (WASU.To_Wide_String (XRef.Image)))); Close_XRef (Self); if Code then Put (Self, ""); end if; end Put_XRef; ---------------------------------------------------------------------------- procedure Open_Block (Self : access Printer) is P : constant Block_Ptr := new Blocks (1 .. Self.First_In_Block'Last + 1); begin P (1) := True; P (2 .. P'Last) := Self.First_In_Block.all; Free (Self.First_In_Block); Self.First_In_Block := P; end Open_Block; procedure Close_Block (Self : access Printer) is P : Block_Ptr := Self.First_In_Block; begin Self.First_In_Block := new Blocks (1 .. P'Last - 1); Self.First_In_Block.all := P (P'First + 1 .. P'Last); Free (P); end Close_Block; ---------------------------------------------------------------------------- function Get_Description (Kind : in Item_Kind; Is_Private : in Boolean) return String is function Get_Description (Kind : in Item_Kind) return String is begin case Kind is when A_Generic_Signature_Package => -- This is a special case because of the parentheses return "Generic (signature) package"; when others => declare S : String := To_Lower (Library_Item_Kind'Image (Kind)); begin for I in S'Range loop if S (I) = '_' then S (I) := ' '; end if; end loop; -- The first two characters are "a_", which we omit. S (S'First + 2) := To_Upper (S (S'First + 2)); return S (S'First + 2 .. S'Last); end; end case; end Get_Description; Text : constant String := Get_Description (Kind); begin if Is_Private then return "Private " & To_Lower (Text (Text'First)) & Text (Text'First + 1 .. Text'Last); else return Text; end if; end Get_Description; procedure Open_Unit (Self : access Printer; Unit_Kind : in Item_Kind; Unit_Name : in Wide_String; Is_Private : in Boolean; XRef : in AD.Crossrefs.Cross_Reference) is pragma Warnings (Off, XRef); -- silence -gnatwa begin begin Open_File (Self.all, AD.Options.Processing_Mode, AD.Text_Utilities.To_File_Name (ACH.To_String (Unit_Name), HTML_Suffix)); exception when E : others => AD.Messages.Warn (Ada.Exceptions.Exception_Message (E)); end; if Is_Open (Self.all) then if Unit_Kind in Library_Item_Kind then AD.HTML.Header (Self.F.all, Get_Description (Unit_Kind, Is_Private) & ": " & ACH.To_String (Unit_Name)); else AD.HTML.Header (Self.F.all, ACH.To_String (Unit_Name)); end if; if Self.First_In_Block /= null then Free (Self.First_In_Block); end if; Self.First_In_Block := new Blocks'(1 .. 1 => True); Self.Container_Level := -1; Self.Type_Has_Parent := False; Self.No_XRef := False; Self.In_Exception := False; Self.In_Type := False; Self.In_Dependencies := False; Self.In_Constants := False; Self.In_Top_Item := False; Self.Force_Multiline := False; Self.In_Task := False; Self.Is_Unit := True; end if; end Open_Unit; procedure Close_Unit (Self : access Printer) is begin AD.HTML.Footer (Self.F.all); Free (Self.First_In_Block); Self.Is_Unit := False; end Close_Unit; procedure Write_Comment (Self : access Printer; Lines : in Asis.Text.Line_List) is begin AD.Format.Format (Lines, Self); end Write_Comment; procedure Emit_Snippet (Self : access Printer) is I : Natural := Util.Text.First_Index (Self.Buffer, ASCII.LF); Last : constant Natural := Util.Text.Length (Self.Buffer); begin Self.Use_Buffer := False; -- Switch off buffer usage! if (I = 0 or else I = Last) and then not Self.Force_Multiline then -- Single-line snippet: -- TBD: comment-in the following! it is commented out only -- for correctness checking: V2.13 didn't replace white -- space by  , so we don't either. This allows pure -- text comparison to verify that the output is still the -- same! -- declare -- Lines : aliased AD.Filters.Filter_Lines; -- begin -- if I = Last then -- Remove that single (and last) LF, otherwise we'll -- get a "
" inserted! -- Util.Text.Delete (Self.Buffer, Last, Last); -- end if; -- AD.Filters.Transform (Lines'Access, Self.Buffer); -- end; declare Txt : constant Util.Text.String_Access := Util.Text.Internal.Get_Ptr (Self.Buffer); begin if Txt (Txt'Last) = ASCII.LF then Put_Line (Self, "" & Txt (Txt'First .. Txt'Last - 1) & ""); else Put_Line (Self, "" & Txt.all & ""); end if; end; else -- Multi-line snippet: Put (Self, "
");
         declare
            Txt   : constant Util.Text.String_Access :=
              Util.Text.Internal.Get_Ptr (Self.Buffer);
            First : Natural := 1;
         begin
            if I = 0 then
               Put (Self, Txt.all);
            else
               loop
                  Put_Line (Self, Txt (First .. I - 1));
                  exit when I = Txt'Last;
                  First := I + 1;
                  I := First_Index (Txt (First .. Txt'Last), ASCII.LF);
                  if I = 0 then
                     Put (Self, Txt (First .. Txt'Last));
                     exit;
                  end if;
               end loop;
            end if;
         end;
         Put_Line (Self, "
"); end if; Self.Buffer := Util.Text.Null_Unbounded_String; end Emit_Snippet; procedure Open_Section (Self : access Printer; Section : in Section_Type) is begin case Section is when Index_XRef_Section => Put_Line (Self, "
"); Self.First_Index := True; when Dependencies_Section => if Self.First_In_Block (1) then Self.First_In_Block (1) := False; else Put_Line (Self, "
"); end if; AD.HTML.Subtitle (Self.F.all, "Dependencies"); Self.In_Dependencies := True; -- Self.Force_Multiline := True; when Snippet_Section => if Self.Container_Level > 0 then Put (Self, ""); else Put_Line (Self, "CLASS=""odd"">"); end if; else if Self.In_Constants then Put (Self, "ALIGN=""LEFT"" "); end if; Put_Line (Self, "CLASS=""code"">"); end if; end if; -- We buffer the snippet. When we close it, we first count the -- newlines. If there is only one, we run the text though a -- Filter_Lines filter, which will replace all whitespace by -- " " as needed, wrap it in a "CODE" tag and emit the -- result. If there are several lines, we just wrap it all -- into a "PRE". Self.Use_Buffer := True; Self.Force_Multiline := not Self.In_Constants; when Description_Section => if Self.In_Exception then Put_Line (Self, ""); Self.In_Exception := False; end if; if Self.Container_Level > 0 then Put_Line (Self, ""); elsif Self.Container_Level = -1 and then not Self.In_Dependencies then -- Top-level comment coming! if Self.First_In_Block (1) then Self.First_In_Block (1) := False; else Put_Line (Self, "
"); end if; AD.HTML.Subtitle (Self.F.all, "Description"); end if; Put_Line (Self, "
"); when Header_Section | Footer_Section => Put (Self, ""); else Put_Line (Self, """odd"">"); end if; Self.Use_Buffer := True; Self.Force_Multiline := True; when Content_Section => -- Was WIDTH=10, but that sometimes fails to display correctly -- on IE 5.0. Put (Self, ""); else Put (Self, """odd"">"); end if; Put_Line (Self, "
"); Put_Line (Self, ""); Put_Line (Self, ""); Open_Block (Self); when Top_Item_Section => Self.In_Top_Item := True; Self.First_In_Block (1) := False; when Children_Section => Put_Line (Self, ""); when Type_Section => if Self.In_Type then Put_Line (Self, ""); end if; Self.In_Type := False; when Operations_Section => null; when Constants_Section | Variables_Section => Self.In_Constants := False; Put_Line (Self, "
"); if Self.First_In_Block (1) then Self.First_In_Block (1) := False; else Put_Line (Self, "
"); end if; AD.HTML.Subtitle (Self.F.all, "Known child units"); Put_Line (Self, ""); when Exceptions_Section => Put_Line (Self, ""); when Exception_Section => Close_Block (Self); if Self.In_Exception then Put_Line (Self, ""); end if; Self.In_Exception := False; when Exception_Rename_Section => Put (Self, ""); when Ultimate_Exception_Section => Put (Self, ")"); when Type_Summary_Section => Put_Line (Self, "
"); if Self.First_In_Block (1) then Self.First_In_Block (1) := False; else Put_Line (Self, "
"); end if; AD.HTML.Subtitle (Self.F.all, "Exceptions"); Put_Line (Self, ""); when Exception_Section => Put_Line (Self, ""); when Exceptions_Section => Put_Line (Self, "
"); Self.In_Exception := True; Open_Block (Self); when Exception_Rename_Section => Put (Self, ""); Dump (Self, " renames "); when Ultimate_Exception_Section => Put (Self, " (ultimately a rename of "); when Type_Summary_Section => Put_Line (Self, "
"); if Self.First_In_Block (1) then Self.First_In_Block (1) := False; else Put_Line (Self, "
"); end if; AD.HTML.Subtitle (Self.F.all, "Type Summary"); Put_Line (Self, ""); when Type_Section => Put_Line (Self, ""); Self.In_Type := False; end if; when Constants_Section | Variables_Section => Put_Line (Self, ""); when Top_Item_Section => Self.In_Top_Item := False; when Children_Section => Put_Line (Self, "
"); Self.In_Type := True; when Operations_Section => if Self.In_Type then Put_Line (Self, "
"); if Self.First_In_Block (1) then Self.First_In_Block (1) := False; else Put_Line (Self, "
"); end if; if Section = Constants_Section then AD.HTML.Subtitle (Self.F.all, "Constants and Named Numbers"); else AD.HTML.Subtitle (Self.F.all, "Variables"); end if; Put_Line (Self, ""); Self.In_Constants := True; when Others_Section => if not Self.In_Task then Put_Line (Self, ""); end if; Open_Block (Self); end case; end Open_Section; -- Section := {Section | Item }. procedure Close_Section (Self : access Printer; Section : in Section_Type) is begin case Section is when Index_XRef_Section => if not Self.First_Index then Put_Line (Self, "

"); Put_Line (Self, "
"); end if; -- Count the number of chars present; if > 1, write them. if Util.Strings.Cardinality (Self.Index_Chars) > 1 then Put_Line (Self, "

"); if ASM.Is_In ('"', Self.Index_Chars) then Put (Self, " [Operators]"); end if; for I in Character range 'A' .. 'Z' loop if ASM.Is_In (I, Self.Index_Chars) then Put (Self, " [" & I & "]"); end if; end loop; for I in Character range 'a' .. 'z' loop if ASM.Is_In (I, Self.Index_Chars) then Put (Self, " [" & I & "]"); end if; end loop; New_Line (Self); Put_Line (Self, "

"); Put_Line (Self, "
"); end if; Self.First_Index := True; when Dependencies_Section => Self.In_Dependencies := False; -- Self.Force_Multiline := False; when Snippet_Section => Emit_Snippet (Self); if Self.Container_Level > 0 then Put_Line (Self, ""); end if; Self.Force_Multiline := False; when Description_Section => Put_Line (Self, ""); if Self.Container_Level > 0 then Put_Line (Self, ""); end if; when Header_Section | Footer_Section => Emit_Snippet (Self); Put_Line (Self, ""); Self.Force_Multiline := False; when Content_Section => Close_Block (Self); Put_Line (Self, "
"); if Self.First_In_Block (1) then Self.First_In_Block (1) := False; else Put_Line (Self, "
"); end if; AD.HTML.Subtitle (Self.F.all, "Other Items:"); Put_Line (Self, "
"); Put_Line (Self, "
"); Put_Line (Self, "
"); Put_Line (Self, "
"); Put_Line (Self, "
"); Put_Line (Self, ""); when Others_Section => Close_Block (Self); end case; end Close_Section; procedure Open_Container (Self : access Printer; XRef : in AD.Crossrefs.Cross_Reference; Kind : in Item_Kind; Name : in Wide_String := "") is pragma Warnings (Off, Kind); -- silence -gnatwa pragma Warnings (Off, Name); -- silence -gnatwa pragma Warnings (Off, XRef); -- silence -gnatwa begin if Self.Container_Level < 0 then Self.Container_Level := 1; if Self.First_In_Block (1) then Self.First_In_Block (1) := False; else Put_Line (Self, "
"); end if; else Put_Line (Self, ""); Self.Container_Level := Self.Container_Level + 1; end if; Put_Line (Self, ""); if Self.Container_Level = 1 then Put_Line (Self, ""); end if; Open_Block (Self); Self.In_Task := Kind = A_Task or else Kind = A_Protected_Object or else Kind = A_Task_Type or else Kind = A_Protected_Type; end Open_Container; procedure Close_Container (Self : access Printer; Is_Last : in Boolean := False) is begin if Self.Container_Level > 0 then Put_Line (Self, "
"); AD.HTML.Subtitle (Self.F.all, "Header"); Put_Line (Self, "
"); Self.Container_Level := Self.Container_Level - 1; if Self.Container_Level > 0 then if not Is_Last then Put_Line (Self, "
"); end if; Put_Line (Self, ""); end if; end if; Close_Block (Self); Self.In_Task := False; end Close_Container; procedure Open_Item (Self : access Printer; XRef : in AD.Crossrefs.Cross_Reference; Kind : in Item_Kind := Not_An_Item; Name : in Wide_String := "") is pragma Warnings (Off, Kind); -- silence -gnatwa pragma Warnings (Off, Name); -- silence -gnatwa pragma Warnings (Off, XRef); -- silence -gnatwa begin if Self.Container_Level < 0 then if Self.First_In_Block (1) then Self.First_In_Block (1) := False; else Put_Line (Self, "
"); end if; Put_Line (Self, "

Header

"); -- Self.Force_Multiline := True; Self.Container_Level := 0; else if not Self.In_Constants then Put_Line (Self, ""); Put_Line (Self, ""); end if; end if; end Open_Item; procedure Close_Item (Self : access Printer; Is_Last : in Boolean := False) is begin if Self.Container_Level <= 0 then Self.Force_Multiline := False; else if not Self.In_Constants then Put_Line (Self, "
"); if not Is_Last then Put_Line (Self, "
"); end if; Put_Line (Self, ""); end if; end if; end Close_Item; procedure Other_Declaration (Self : access Printer; XRef : in AD.Crossrefs.Cross_Reference; Text : in String) is begin New_Line (Self); Put (Self, Get_Comment (Before) & "-- " & AD.HTML.HTMLize (Text) & ": "); Put_XRef (Self, XRef); Put (Self, Get_Comment (After)); end Other_Declaration; procedure Add_Child (Self : access Printer; Kind : in Item_Kind; Is_Private : in Boolean; XRef : in AD.Crossrefs.Cross_Reference) is begin Put (Self, ""); Put_XRef (Self, XRef); Put (Self, ""); Put_Line (Self, "(" & To_Lower (Get_Description (Kind, Is_Private)) & ")"); end Add_Child; procedure Add_Exception (Self : access Printer; XRef : in AD.Crossrefs.Cross_Reference) is begin if Self.First_In_Block (1) then Self.First_In_Block (1) := False; else Put (Self, ", "); end if; Put (Self, ""); Open_Anchor (Self, XRef); Put (Self, ACH.To_String (WASU.To_Wide_String (XRef.Image))); Close_Anchor (Self); Put (Self, ""); end Add_Exception; procedure Type_Name (Self : access Printer; XRef : in AD.Crossrefs.Cross_Reference) is begin Put_XRef (Self, XRef); Self.Type_Has_Parent := False; end Type_Name; procedure Type_Kind (Self : access Printer; Info : in String) is begin Put (Self, " (" & HTMLize (Info) & ')'); end Type_Kind; procedure Parent_Type (Self : access Printer; XRef : in AD.Crossrefs.Cross_Reference) is begin Put (Self, " derived from "); Put_XRef (Self, XRef); Self.Type_Has_Parent := True; end Parent_Type; procedure Open_Operation_List (Self : access Printer; Kind : in Operation_Kind) is begin Put (Self, ""); case Kind is when Overridden_Operation => Put (Self, "Overridden Operations"); when Own_Operation => if Self.Type_Has_Parent then Put (Self, "New Operations"); else Put (Self, "Primitive Operations"); end if; when Inherited_Operation => Put (Self, "Inherited Operations"); when Inherited_Original_Operation => Put (Self, "Original Operations"); end case; Put_Line (Self, ": "); Open_Block (Self); end Open_Operation_List; procedure Close_Operation_List (Self : access Printer) is begin New_Line (Self); Put_Line (Self, ""); Close_Block (Self); end Close_Operation_List; procedure Add_Type_Operation (Self : access Printer; XRef : in AD.Crossrefs.Cross_Reference) is begin if Self.First_In_Block (1) then Self.First_In_Block (1) := False; else Put_Line (Self, ","); end if; Put_XRef (Self, XRef); end Add_Type_Operation; procedure Add_Private (Self : access Printer; For_Package : in Boolean) is begin if not For_Package then if Self.Container_Level mod 2 = 0 then Put_Line (Self, ""); else Put_Line (Self, ""); end if; Put (Self, ""); Dump (Self, "private"); Put_Line (Self, ""); Put_Line (Self, "
"); Self.First_In_Block (1) := False; else if Self.First_In_Block (1) then Self.First_In_Block (1) := False; else Put_Line (Self, "
"); end if; Open_Section (Self, Snippet_Section); Dump (Self, "private"); New_Line (Self, 2); Dump (Self, " -- Implementation-defined ..."); New_Line (Self); Close_Section (Self, Snippet_Section); end if; end Add_Private; procedure Open_XRef (Self : access Printer; XRef : in AD.Crossrefs.Cross_Reference) is begin Open_XRef (Self, XRef, False); end Open_XRef; procedure Close_XRef (Self : access Printer) is begin if Self.No_XRef then Self.No_XRef := False; else Put (Self, ""); end if; end Close_XRef; procedure Open_Anchor (Self : access Printer; XRef : in AD.Crossrefs.Cross_Reference) is begin Put (Self, "" & Get_Definition (Before)); end Open_Anchor; procedure Close_Anchor (Self : access Printer) is begin Put (Self, Get_Definition (After) & ""); end Close_Anchor; procedure Inline_Error (Self : access Printer; Msg : in String) is begin Put (Self, ""); end Inline_Error; ---------------------------------------------------------------------------- -- Basic inline elements. procedure Write_Keyword (Self : access Printer; S : in String) is begin Put (Self, Get_Keyword (Before) & HTMLize (S) & Get_Keyword (After)); end Write_Keyword; procedure Write_Literal (Self : access Printer; S : in String) is begin Put (Self, Get_Literal (Before) & HTMLize (S) & Get_Literal (After)); end Write_Literal; procedure Write_Attribute (Self : access Printer; S : in String) is begin Put (Self, Get_Attribute (Before) & To_Mixed (S) & Get_Attribute (After)); end Write_Attribute; procedure Write_Comment (Self : access Printer; S : in String) is begin Put (Self, Get_Comment (Before) & AD.Format.Format (S) & Get_Comment (After)); end Write_Comment; procedure Write (Self : access Printer; S : in String) is begin Put (Self, HTMLize (S)); end Write; procedure Write_Plain (Self : access Printer; S : in String) is begin Put (Self, S); end Write_Plain; procedure Write_Code (Self : access Printer; S : in String) is begin Put (Self, "" & HTMLize (S) & ""); end Write_Code; ---------------------------------------------------------------------------- procedure Open_Index (Self : access Printer; File_Name : in String; Title : in String; Present : in Ada.Strings.Maps.Character_Set) is begin begin Open_File (Self.all, AD.Options.Multiple_Files, Util.Pathes.Replace_Extension (File_Name, HTML_Suffix), False); exception when E : others => AD.Messages.Error (Ada.Exceptions.Exception_Message (E)); end; if Is_Open (Self.all) then AD.HTML.Header (Self.F.all, Title); Self.Index_Chars := Present; end if; Self.Is_Unit := False; end Open_Index; procedure Close_Index (Self : access Printer) is begin if Is_Open (Self.all) then if Self.Char_Section_Open then Close_Char_Section (Self); end if; AD.HTML.Footer (Self.F.all); Close_File (Self.all); end if; end Close_Index; procedure XRef_Index (Self : access Printer; File_Name : in String; Title : in String) is begin if Self.First_Index then Put_Line (Self, "

"); -- else -- Put (Self, "
"); end if; Put_Line (Self, " " & AD.HTML.HTMLize (Title) & ""); Self.First_Index := False; end XRef_Index; procedure Open_Char_Section (Self : access Printer; Char : in Character) is begin if Char = '"' then Put_Line (Self, "

Operators

"); else Put_Line (Self, "

" & Char & "

"); end if; Self.Char_Section_Open := True; Self.First_Index := True; end Open_Char_Section; procedure Close_Char_Section (Self : access Printer) is begin if Self.Idx_Structures = 0 then if not Self.First_Index then Put_Line (Self, "

"); end if; else while Self.Idx_Structures > 0 loop Close_Index_Structure (Self); end loop; end if; Self.Char_Section_Open := False; end Close_Char_Section; procedure Open_Index_Structure (Self : access Printer) is begin Put_Line (Self, "
    "); Self.Idx_Structures := Self.Idx_Structures + 1; end Open_Index_Structure; procedure Close_Index_Structure (Self : access Printer) is begin if Self.Idx_Structures > 0 then Put_Line (Self, "
"); Self.Idx_Structures := Self.Idx_Structures - 1; end if; end Close_Index_Structure; procedure Open_Index_Item (Self : access Printer) is begin if Self.Idx_Structures > 0 then Put (Self, "
  • "); else if Self.First_Index then Put_Line (Self, "

    "); end if; end if; Self.First_Index := False; end Open_Index_Item; procedure Close_Index_Item (Self : access Printer) is begin if Self.Idx_Structures = 0 then Put_Line (Self, "
    "); else New_Line (Self); end if; end Close_Index_Item; ---------------------------------------------------------------------------- procedure Finalize (Self : in out Printer) is begin if Self.First_In_Block /= null then Free (Self.First_In_Block); end if; Finalize (Real_Printer (Self)); end Finalize; end AD.Printers.HTML; adabrowse_4.0.3/ad-indices.ads0000644000175000017500000001025310234241443014352 0ustar kenken------------------------------------------------------------------------------ -- -- This file is part of AdaBrowse. -- -- Copyright (c) 2002 by Thomas Wolf. --

    -- AdaBrowse is free software; you can redistribute it and/or modify it -- under the terms of the GNU General Public License as published by the -- Free Software Foundation; either version 2, or (at your option) any -- later version. AdaBrowse is distributed in the hope that it will be -- useful, but without any warranty; without even the implied -- warranty of merchantability or fitness for a particular purpose. -- See the GNU General Public License for more details. You should have -- received a copy of the GNU General Public License with this distribution, -- see file "GPL.txt". If not, write to the Free -- Software Foundation, 59 Temple Place - Suite 330, Boston, MA 02111-1307, -- USA. --
    -- --
    -- Author:
    -- Thomas Wolf (TW) --
    twolf@acm.org
    -- --
    -- Purpose:
    -- Managing indices.
    -- -- ------------------------------------------------------------------------------- pragma License (GPL); with Ada.Finalization; with Ada.Strings.Maps; with Ada.Strings.Unbounded; with AD.Crossrefs; with AD.Expressions; with AD.Printers; with GAL.Containers.Simple; with GAL.Storage.Standard; with Asis; pragma Elaborate_All (GAL.Containers.Simple); package AD.Indices is pragma Elaborate_Body; procedure Disable; procedure Verify; procedure Add (Element : in Asis.Element; XRef : in AD.Crossrefs.Cross_Reference; Is_Private : in Boolean := False); function Has_Indices return Boolean; procedure Write (Printer : access AD.Printers.Printer'Class); private type Index_Item; type Index_Item_Ptr is access all Index_Item; type Index_Item is record XRef : AD.Crossrefs.Cross_Reference; Is_Private : Boolean := False; end record; package Index_Items is new GAL.Containers.Simple (Index_Item, GAL.Storage.Standard); type Item_Type is (Units, Packages, Types, Procedures, Functions, Entrys, Exceptions, Constants, Variables, Pragmas, Clauses); type Contents is array (Item_Type) of Boolean; pragma Pack (Contents); type Index is new Ada.Finalization.Limited_Controlled with record Ref_Count : Natural := 1; File_Name : Ada.Strings.Unbounded.Unbounded_String; Title : Ada.Strings.Unbounded.Unbounded_String; Empty : Ada.Strings.Unbounded.Unbounded_String; Rule : AD.Expressions.Expression; Structured : Boolean := False; Items : Index_Items.Simple_Container; Contained : Contents := (others => False); Present : Ada.Strings.Maps.Character_Set := Ada.Strings.Maps.Null_Set; end record; type Index_Ptr is access all Index'Class; procedure Finalize (Idx : in out Index); procedure Set_Empty (Idx : access Index; Text : in String); procedure Set_Title (Idx : access Index; Title : in String); procedure Set_File_Name (Idx : access Index; Name : in String); procedure Set_Rule (Idx : access Index; Rule : in AD.Expressions.Expression); procedure Set_Structured (Idx : access Index; Flag : in Boolean); procedure Add (Idx : access Index; Element : in Asis.Element; XRef : in AD.Crossrefs.Cross_Reference; Is_Private : in Boolean := False); procedure Write (Idx : access Index; Printer : access AD.Printers.Printer'Class; Name : in String); function Get (Name : in String) return Index_Ptr; function Find (Name : in String) return Index_Ptr; end AD.Indices; adabrowse_4.0.3/ad-environment.adb0000644000175000017500000001040510234241450015254 0ustar kenken------------------------------------------------------------------------------- -- -- This file is part of AdaBrowse. -- -- Copyright (c) 2002 by Thomas Wolf. --
    -- AdaBrowse is free software; you can redistribute it and/or modify it -- under the terms of the GNU General Public License as published by the -- Free Software Foundation; either version 2, or (at your option) any -- later version. AdaBrowse is distributed in the hope that it will be -- useful, but without any warranty; without even the implied -- warranty of merchantability or fitness for a particular purpose. -- See the GNU General Public License for more details. You should have -- received a copy of the GNU General Public License with this distribution, -- see file "GPL.txt". If not, write to the Free -- Software Foundation, 59 Temple Place - Suite 330, Boston, MA 02111-1307, -- USA. --
    -- --
    -- Author:
    -- Thomas Wolf (TW) --
    twolf@acm.org
    -- --
    -- Purpose:
    -- Environment variable management.
    -- -- ------------------------------------------------------------------------------- pragma License (GPL); with AD.Messages; with AD.Projects; with GAL.ADT.Hash_Tables; with GAL.Storage.Standard; with GAL.Support.Hashing; with Util.Environment; with Util.Strings; pragma Elaborate_All (GAL.ADT.Hash_Tables); package body AD.Environment is package Env_Tables is new GAL.ADT.Hash_Tables (Key_Type => String, Item => String, Memory => GAL.Storage.Standard, Hash => GAL.Support.Hashing.Hash_Case_Insensitive, "=" => Util.Strings.Equal); My_Environment : Env_Tables.Hash_Table; function Get (Name : in String) return String is begin return Env_Tables.Retrieve (My_Environment, Name); exception when Env_Tables.Container_Empty | Env_Tables.Not_Found => -- Check the real environment. begin declare Value : constant String := Util.Environment.Get (Name); begin Set (Name, Value); return Value; end; exception when Util.Environment.Not_Defined => return ""; end; end Get; procedure Set (Name : in String; Value : in String) is begin AD.Messages.Debug ("Registering environment binding " & Name & "=" & Value); Env_Tables.Replace (My_Environment, Key => Name, Element => Value); AD.Projects.Define_Variable (Name, Value); end Set; function Is_Defined (Name : in String) return Boolean is begin if Env_Tables.Contains (My_Environment, Name) then return True; end if; begin Set (Name, Util.Environment.Get (Name)); return True; exception when Util.Environment.Not_Defined => return False; end; end Is_Defined; procedure Add (Assignment : in String) is -- We have a string name=value. Name must not contain embedded white -- space. Leading and trailing white space in name or value is trimmed. -- The whole assignment must already be unquoted, if it was enclosed -- in quotes. use Util.Strings; I : Natural; begin I := First_Index (Assignment, '='); if I <= Assignment'First then raise Invalid_Variable_Assignment; end if; declare Name : constant String := Trim (Assignment (Assignment'First .. I - 1)); Value : constant String := Trim (Assignment (I + 1 .. Assignment'Last)); begin if Name'Length = 0 or else Next_Blank (Name) /= 0 then raise Invalid_Variable_Assignment; end if; Set (Name, Value); end; end Add; begin Env_Tables.Set_Resize (My_Environment, 0.75); declare Linear_Growth : GAL.Support.Hashing.Linear_Growth_Policy (20); begin Env_Tables.Set_Growth_Policy (My_Environment, Linear_Growth); end; end AD.Environment; adabrowse_4.0.3/ad-parameters.adb0000644000175000017500000002403210234241451015055 0ustar kenken------------------------------------------------------------------------------- -- -- This file is part of AdaBrowse. -- -- Copyright (c) 2002 by Thomas Wolf. --
    -- AdaBrowse is free software; you can redistribute it and/or modify it -- under the terms of the GNU General Public License as published by the -- Free Software Foundation; either version 2, or (at your option) any -- later version. AdaBrowse is distributed in the hope that it will be -- useful, but without any warranty; without even the implied -- warranty of merchantability or fitness for a particular purpose. -- See the GNU General Public License for more details. You should have -- received a copy of the GNU General Public License with this distribution, -- see file "GPL.txt". If not, write to the Free -- Software Foundation, 59 Temple Place - Suite 330, Boston, MA 02111-1307, -- USA. --
    -- --
    -- Author:
    -- Thomas Wolf (TW) --
    twolf@acm.org
    -- --
    -- Purpose:
    -- Handling of the -f parameter value.
    -- -- ------------------------------------------------------------------------------- pragma License (GPL); with Ada.Exceptions; with Ada.Strings.Fixed; with Ada.Strings.Maps; with Ada.Strings.Unbounded; with Ada.Text_IO; with AD.Known_Units; with AD.Text_Utilities; with Util.Files.Text_IO; with Util.Pathes; with Util.Strings; pragma Elaborate_All (Util.Files.Text_IO); package body AD.Parameters is package ASF renames Ada.Strings.Fixed; package ASM renames Ada.Strings.Maps; package ASU renames Ada.Strings.Unbounded; use AD.Text_Utilities; To_Unit : constant ASM.Character_Mapping := ASM.To_Mapping ("-", "."); Name : ASU.Unbounded_String; Unit_Id : ASU.Unbounded_String; Path_Part : ASU.Unbounded_String; Is_StdIn : Boolean := False; Is_Temp : Boolean := False; F : Ada.Text_IO.File_Access := null; File : aliased Ada.Text_IO.File_Type; procedure Save_Input is use type Ada.Text_IO.File_Access; begin if not Is_StdIn or else F = null then return; end if; -- It's a hack, but so is "popen", which is the basis for my Util.Pipes -- package. The problem is that a command executed through "popen" -- inherits the calling program's standard I/O files: stdin, stdout, and -- stderr, where either stdin or stdout are replaced by a pipe, which -- can be accessed by the stream opened by Util.Pipes.Open. In other -- words, a called program shares stdin with AdaBrowse! -- -- Therefore, we need to squirrel away the contents of our stdin before -- making the first call to an external program, lest some nasty called -- program snatches it away by reading from its stdin, which is also -- *our* stdin. -- -- We use an unnamed temporary file to store the contents of stdin to. -- That's just plain simpler than some in-memory structure, and also -- avoids memory problems for large inputs. begin Ada.Text_IO.Create (File, Ada.Text_IO.Out_File); exception when others => return; end; -- Read all from stdin and save in temporary file. Is_Temp := True; declare Buffer : String (1 .. 500); Last : Natural; begin while not Ada.Text_IO.End_Of_File (F.all) loop Ada.Text_IO.Get_Line (F.all, Buffer, Last); if Last < Buffer'Last then Ada.Text_IO.Put_Line (File, Buffer (1 .. Last)); else Ada.Text_IO.Put (File, Buffer); end if; end loop; end; Ada.Text_IO.New_Line (File); Ada.Text_IO.Reset (File, Ada.Text_IO.In_File); Is_StdIn := False; F := File'Access; end Save_Input; procedure Set_Source_Name (File_Name : in String; Try_Known : in Boolean := False) is begin if Try_Known then AD.Known_Units.Find (File_Name, Name, Path_Part, Unit_Id); if ASU.Length (Name) > 0 then -- We've found it! return; end if; end if; Path_Part := ASU.To_Unbounded_String (Util.Pathes.Path (File_Name)); -- Not found. declare Ext : constant String := Util.Pathes.Extension (File_Name); begin if Ext'Length = 0 or else Util.Strings.Equal (Ext, "adt") then Name := ASU.To_Unbounded_String (Util.Pathes.Replace_Extension (File_Name, "ads")); else Name := ASU.To_Unbounded_String (Util.Pathes.Name (File_Name)); end if; end; Unit_Id := ASU.Null_Unbounded_String; end Set_Source_Name; function Get_Line is new Util.Files.Text_IO.Next_Line (Line_Continuation => "", Comment_Start => "#", Delimiters => Util.Strings.Null_Set); -- Raw line reading, but with comment handling. procedure Set_Input (File_Name : in String) is begin if File_Name (File_Name'First) = '@' or else File_Name = "-" then -- It's a list! if File_Name = "@-" or else File_Name = "-" then Is_StdIn := True; F := Ada.Text_IO.Current_Input; if not Advance_Input then Ada.Exceptions.Raise_Exception (Input_Error'Identity, "No units to process."); end if; else declare Name : constant String := File_Name (File_Name'First + 1 .. File_Name'Last); begin begin Ada.Text_IO.Open (File, Ada.Text_IO.In_File, Name); exception when others => Ada.Exceptions.Raise_Exception (Input_Error'Identity, "Cannot open file """ & Name & """."); end; F := Ada.Text_IO.File_Access'(File'Access); if not Advance_Input then Ada.Exceptions.Raise_Exception (Input_Error'Identity, "File """ & Name & """ is empty."); end if; end; end if; else F := null; Set_Source_Name (File_Name, True); end if; end Set_Input; procedure Set_Input (File : in Ada.Text_IO.File_Access) is begin F := File; Is_StdIn := False; if not Advance_Input then Ada.Exceptions.Raise_Exception (Input_Error'Identity, "No sources of unit specs found. Stopping"); end if; end Set_Input; function Advance_Input return Boolean is use type Ada.Text_IO.File_Access; begin if F = null or else not Ada.Text_IO.Is_Open (F.all) then return False; elsif Ada.Text_IO.End_Of_File (F.all) then Close; return False; end if; declare Line : constant String := Util.Strings.Trim (Get_Line (F.all)); begin if Line'Last < Line'First then Close; return False; end if; if Util.Strings.Is_Prefix (Line, "--") then -- Assume what follows is the unit name. The project manager -- uses this method to tell us the unit name up-front! if Ada.Text_IO.End_Of_File (F.all) then Close; return False; end if; declare Next_Line : constant String := Util.Strings.Trim (Get_Line (F.all)); begin if Next_Line'Last < Next_Line'First then Close; return False; end if; Set_Source_Name (Canonical (Next_Line)); Set_Unit_Name (Util.Strings.Trim (Line (Line'First + 2 .. Line'Last))); end; else Set_Source_Name (Canonical (Line), True); end if; return True; end; end Advance_Input; function Is_File return Boolean is use type Ada.Text_IO.File_Access; begin return F /= null; end Is_File; procedure Close is begin if Ada.Text_IO.Is_Open (File) then if Is_Temp then begin Ada.Text_IO.Delete (File); exception when others => Ada.Text_IO.Close (File); end; else Ada.Text_IO.Close (File); end if; end if; F := null; end Close; function Source_Name return String is begin return ASU.To_String (Name); end Source_Name; function Unit_Name return String is begin if ASU.Length (Unit_Id) > 0 then return ASU.To_String (Unit_Id); end if; -- Either we have no project file, or somehow the project manager -- was not able to produce a sensible name: revert to the default -- behavior. declare Unit_Name : constant String := Util.Strings.To_Mixed (ASF.Translate (Util.Pathes.Base_Name (Source_Name), To_Unit)); begin Set_Unit_Name (Unit_Name); return Unit_Name; end; end Unit_Name; procedure Set_Unit_Name (Name : in String) is begin Unit_Id := ASU.To_Unbounded_String (Name); end Set_Unit_Name; function Path return String is begin return ASU.To_String (Path_Part); end Path; end AD.Parameters; adabrowse_4.0.3/ad-indices-configuration.ads0000644000175000017500000000400310234241442017212 0ustar kenken------------------------------------------------------------------------------ -- -- This file is part of AdaBrowse. -- -- Copyright (c) 2002 by Thomas Wolf. --
    -- AdaBrowse is free software; you can redistribute it and/or modify it -- under the terms of the GNU General Public License as published by the -- Free Software Foundation; either version 2, or (at your option) any -- later version. AdaBrowse is distributed in the hope that it will be -- useful, but without any warranty; without even the implied -- warranty of merchantability or fitness for a particular purpose. -- See the GNU General Public License for more details. You should have -- received a copy of the GNU General Public License with this distribution, -- see file "GPL.txt". If not, write to the Free -- Software Foundation, 59 Temple Place - Suite 330, Boston, MA 02111-1307, -- USA. --
    -- --
    -- Author:
    -- Thomas Wolf (TW) --
    twolf@acm.org
    -- --
    -- Purpose:
    -- Index configuration.
    -- -- ------------------------------------------------------------------------------- pragma License (GPL); package AD.Indices.Configuration is pragma Elaborate_Body; procedure Parse (Key : in String; Value : in String); procedure Verify; type Index_Type is (Unit_Index, Subprogram_Index, Type_Index); -- This is a relic from the old indices. We still need it for backwards -- compatibility. procedure Enter_Index (Which : in Index_Type); procedure Set_File_Name (Which : in Index_Type; Name : in String); procedure Set_Title (Which : in Index_Type; Title : in String); procedure Set_Structured (Which : in Index_Type; Flag : in Boolean); end AD.Indices.Configuration; adabrowse_4.0.3/asis2-iterators.adb0000644000175000017500000003333410234241452015371 0ustar kenken------------------------------------------------------------------------------- -- -- This unit is part of the @Asis2@ ASIS secondary library. -- -- Copyright (c) 2003 by Thomas Wolf. --
    -- AdaBrowse is free software; you can redistribute it and/or modify it -- under the terms of the GNU General Public License as published by the -- Free Software Foundation; either version 2, or (at your option) any -- later version. AdaBrowse is distributed in the hope that it will be -- useful, but without any warranty; without even the implied -- warranty of merchantability or fitness for a particular purpose. -- See the GNU General Public License for more details. You should have -- received a copy of the GNU General Public License with this distribution, -- see file "GPL.txt". If not, write to the Free -- Software Foundation, 59 Temple Place - Suite 330, Boston, MA 02111-1307, -- USA. --
    --
    -- As a special exception from the GPL, if other files instantiate generics -- from this unit, or you link this unit with other files to produce an -- executable, this unit does not by itself cause the resulting executable -- to be covered by the GPL. This exception does not however invalidate any -- other reasons why the executable file might be covered by the GPL. --
    -- -- -- Thomas Wolf (TW) -- -- -- -- An analogue to @Asis.Iterator.Traverse_Element@ that ensures that -- @Post_Operation@s are called for "open" @Pre_Operation@s. -- -- -- -- 11-JUL-2003 TW Initial version. -- 14-JUL-2003 TW Ensured that at level zero, we do return -- @Skip_Siblings@ when appropriate. -- Added @Traverse_Levels@, @Traverse_List@, -- @Traverse_Unit@, and @Traverse_Unit_Elements@. -- ------------------------------------------------------------------------------- pragma License (Modified_GPL); with Ada.Exceptions; with Asis.Compilation_Units; with Asis.Elements; with Asis.Exceptions; with Asis.Iterator; package body Asis2.Iterators is use Asis; Package_Name : constant String := "Asis.Correct_Iterate"; -- generic -- type State_Information (<>) is limited private; -- -- with procedure Pre_Operation -- (Element : in Asis.Element; -- Depth : in Asis.ASIS_Positive; -- Control : in out Control_Traversal; -- State : in out State_Information) is <>; -- -- with procedure Post_Operation -- (Element : in Asis.Element; -- Depth : in Asis.ASIS_Positive; -- Control : in out Control_Traversal; -- State : in out State_Information) is <>; -- procedure Traverse_Levels (Element : in Asis.Element; Control : in out Control_Traversal; State : in out State_Information) is Level : Asis.ASIS_Natural := 0; -- We count the nesting level in order to not reset a Skip_Siblings -- or Terminate_Current_And_Siblings to Continue_Traversal on top level. -- On top-level, we want to pass out these two values, because they -- may be useful for deciding whether or not to continue traversing -- in a list of elements. -- -- Note that although this iterator is based on the standard one (which -- doesn't invoke Post when Abandon_Children of Abandon_Siblings is set -- in Pre), we can still count correctly because we know where we are. procedure Pre (Element : in Asis.Element; Asis_Control : in out Asis.Traverse_Control; Real_Control : in out Control_Traversal); procedure Post (Element : in Asis.Element; Asis_Control : in out Asis.Traverse_Control; Real_Control : in out Control_Traversal); procedure Traverse is new Asis.Iterator.Traverse_Element (State_Information => Control_Traversal, Pre_Operation => Pre, Post_Operation => Post); procedure Pre (Element : in Asis.Element; Asis_Control : in out Asis.Traverse_Control; Real_Control : in out Control_Traversal) is use type Asis.Traverse_Control; begin Level := Level + 1; -- Real_Control = Continue_Traversal and Asis_Control = Continue Pre_Operation (Element, Level, Real_Control, State); case Real_Control is when Continue_Traversal => -- Post will decrement the level. Asis_Control := Continue; when Terminate_Current => -- Do *not* call Post! Asis_Control := Abandon_Children; Level := Level - 1; Real_Control := Continue_Traversal; when Terminate_Current_And_Siblings => -- Do *not* call Post! Asis_Control := Abandon_Siblings; Level := Level - 1; if Level > 0 then Real_Control := Continue_Traversal; else Real_Control := Skip_Siblings; end if; when Skip_Children | Skip_Siblings | Unwind_Traversal | Stop_Traversal => -- Post will decrement the level. Post (Element, Asis_Control, Real_Control); -- If Post weakened the condition, make sure that we -- skip at least the children. if Asis_Control = Continue then Asis_Control := Abandon_Children; end if; when Terminate_Traversal => Asis_Control := Terminate_Immediately; -- We don't care about the level anymore. end case; -- Real_Control in -- (Continue_Traversal, Unwind_Traversal, Terminate_Traversal) -- or -- Level = 0 and Real_Control = Skip_Siblings end Pre; procedure Post (Element : in Asis.Element; Asis_Control : in out Asis.Traverse_Control; Real_Control : in out Control_Traversal) is begin -- Real_Control not in -- (Terminate_Current, Terminate_Current_And_Siblings, -- Terminate_Traversal) -- and -- Asis_Control = Continue Post_Operation (Element, Level, Real_Control, State); Level := Level - 1; case Real_Control is when Continue_Traversal => Asis_Control := Continue; when Skip_Children | Terminate_Current => Asis_Control := Abandon_Children; Real_Control := Continue_Traversal; when Skip_Siblings | Terminate_Current_And_Siblings => Asis_Control := Abandon_Siblings; if Level > 0 then Real_Control := Continue_Traversal; else Real_Control := Skip_Siblings; end if; when Unwind_Traversal => Asis_Control := Abandon_Siblings; when Stop_Traversal | Terminate_Traversal => Asis_Control := Terminate_Immediately; Real_Control := Terminate_Traversal; end case; -- Real_Control in -- (Continue_Traversal, Unwind_Traversal, Terminate_Traversal) -- or -- Level = 0 and Real_Control = Skip_Siblings end Post; Asis_Control : Asis.Traverse_Control := Continue; begin if Control /= Continue_Traversal or else Asis.Elements.Is_Nil (Element) then return; end if; -- Real_Control = Continue_Traversal and Asis_Control = Continue Traverse (Element, Asis_Control, Control); -- Real_Control in -- (Continue_Traversal, Skip_Siblings, Unwind_Traversal, -- Terminate_Traversal) end Traverse_Levels; -- generic -- type State_Information (<>) is limited private; -- -- with procedure Pre_Operation -- (Element : in Asis.Element; -- Control : in out Control_Traversal; -- State : in out State_Information) is <>; -- -- with procedure Post_Operation -- (Element : in Asis.Element; -- Control : in out Control_Traversal; -- State : in out State_Information) is <>; -- procedure Traverse_Element (Element : in Asis.Element; Control : in out Control_Traversal; State : in out State_Information) is procedure Pre (Element : in Asis.Element; Depth : in Asis.ASIS_Positive; Control : in out Control_Traversal; State : in out State_Information) is pragma Warnings (Off, Depth); -- silence -gnatwf begin Pre_Operation (Element, Control, State); end Pre; procedure Post (Element : in Asis.Element; Depth : in Asis.ASIS_Positive; Control : in out Control_Traversal; State : in out State_Information) is pragma Warnings (Off, Depth); -- silence -gnatwf begin Post_Operation (Element, Control, State); end Post; procedure Traverse is new Traverse_Levels (State_Information, Pre, Post); begin Traverse (Element, Control, State); end Traverse_Element; -- generic -- type State_Information (<>) is limited private; -- -- with procedure Process_Element -- (Element : in Asis.Element; -- Control : in out Control_Traversal; -- State : in out State_Information) is <>; -- procedure Traverse_List (Elements : in Asis.Element_List; Control : in out Control_Traversal; State : in out State_Information) is begin for I in Elements'Range loop Process_Element (Elements (I), Control, State); exit when Control /= Continue_Traversal; end loop; end Traverse_List; -- generic -- type State_Information (<>) is limited private; -- -- with procedure Process_Element -- (Element : in Asis.Element; -- Control : in out Control_Traversal; -- State : in out State_Information) is <>; -- procedure Traverse_Unit_Elements (Element : in Asis.Compilation_Unit; Control : in out Control_Traversal; State : in out State_Information; Include_Pragmas : in Boolean := False) is use Asis.Elements; use Asis.Compilation_Units; begin if Control /= Continue_Traversal or else Is_Nil (Element) then return; end if; declare Kind : constant Unit_Kinds := Unit_Kind (Element); begin if Kind not in A_Procedure .. A_Protected_Body_Subunit then Ada.Exceptions.Raise_Exception (Asis.Exceptions.ASIS_Inappropriate_Compilation_Unit'Identity, Package_Name & ".Traverse_Unit: Unexpected unit kind " & Unit_Kinds'Image (Kind)); end if; end; -- Control = Continue_Traversal Process_Unit : declare procedure Process_List is new Traverse_List (State_Information, Process_Element); begin if Include_Pragmas then Process_List (Configuration_Pragmas (Enclosing_Context (Element)), Control, State); if Control >= Unwind_Traversal then return; end if; -- Control in (Continue_Traversal, Skip_Siblings) Control := Continue_Traversal; Process_List (Compilation_Pragmas (Element), Control, State); if Control >= Unwind_Traversal then return; end if; -- Control in (Continue_Traversal, Skip_Siblings) Control := Continue_Traversal; end if; -- Include_Pragmas Process_List (Context_Clause_Elements (Compilation_Unit => Element, Include_Pragmas => True), Control, State); if Control >= Unwind_Traversal then return; end if; -- Control in (Continue_Traversal, Skip_Siblings) Control := Continue_Traversal; Process_Element (Unit_Declaration (Element), Control, State); end Process_Unit; -- Control in -- (Continue_Traversal, Skip_Siblings, Unwind_Traversal, -- Terminate_Traversal) end Traverse_Unit_Elements; -- generic -- type State_Information (<>) is limited private; -- -- with procedure Pre_Operation -- (Element : in Asis.Element; -- Control : in out Control_Traversal; -- State : in out State_Information) is <>; -- -- with procedure Post_Operation -- (Element : in Asis.Element; -- Control : in out Control_Traversal; -- State : in out State_Information) is <>; -- procedure Traverse_Unit (Element : in Asis.Compilation_Unit; Control : in out Control_Traversal; State : in out State_Information; Include_Pragmas : in Boolean := False) is procedure Process_Element is new Traverse_Element (State_Information); procedure Traverse is new Traverse_Unit_Elements (State_Information, Process_Element); begin Traverse (Element, Control, State, Include_Pragmas); end Traverse_Unit; end Asis2.Iterators; adabrowse_4.0.3/gal-containers-hash_tables.ads0000644000175000017500000003307110234241446017541 0ustar kenken------------------------------------------------------------------------------- -- -- Copyright (c) 2001, 2002 by Thomas Wolf. --
    -- This piece of software is free software; you can redistribute it and/or -- modify it under the terms of the GNU General Public License as published -- by the Free Software Foundation; either version 2, or (at your option) -- any later version. This unit is distributed in the hope that it will be -- useful, but without any warranty; without even the implied -- warranty of merchantability or fitness for a particular purpose. -- See the GNU General Public License for more details. You should have -- received a copy of the GNU General Public License with this distribution, -- see file "GPL.txt". If not, write to the Free -- Software Foundation, 59 Temple Place - Suite 330, Boston, MA 02111-1307, -- USA. --
    --
    -- As a special exception from the GPL, if other files instantiate generics -- from this unit, or you link this unit with other files to produce an -- executable, this unit does not by itself cause the resulting executable -- to be covered by the GPL. This exception does not however invalidate any -- other reasons why the executable file might be covered by the GPL. --
    -- --
    -- Author:
    -- Thomas Wolf (TW) --
    twolf@acm.org
    -- --
    -- Purpose:
    -- Provides dynamic hash tables. Internal collision resolution, automatic -- and explicit resizing. Collision chain index computation can be customized -- though Collision_Policies. Resizing can be controlled through -- load factors and Growth_Policies. --

    -- This hash table does not allow associating additional data with the -- items stored. However, only a portion of type @Item@ might be the actual -- key, while additional components might hold associated data. In this -- case, both @Hash@ and "=" must work only on the key part -- of @Item@. --

    -- Note that this hash table does not allow in-place modification of the -- items stored since this might result in violations of the internal -- consistency of the hash table. --

    -- A slightly more powerful (but also slightly more complex to instantiate) -- hash table package taking separate @Key@ and @Item@ types and allowing -- in-place modifications of the items (but not the keys) is available in -- package GAL.ADT.Hash_Tables. --
    -- --
    -- Tasking semantics:
    -- N/A. Not abortion-safe.
    -- --
    -- Storage semantics:
    -- Dynamic storage allocation in a user-supplied storage pool.
    -- -- ------------------------------------------------------------------------------- pragma License (Modified_GPL); with GAL.Storage.Memory; with GAL.ADT.Hash_Tables; with GAL.Support.Hashing; generic type Item (<>) is private; with package Memory is new GAL.Storage.Memory (<>); Initial_Size : in GAL.Support.Hashing.Size_Type := 23; with function Hash (Element : in Item) return GAL.Support.Hashing.Hash_Type is <>; with function "=" (Left, Right : in Item) return Boolean is <>; with function Choose_Size (Suggested : in GAL.Support.Hashing.Hash_Type) return GAL.Support.Hashing.Size_Type is GAL.Support.Hashing.Next_Prime; -- This function is called whenever the size of the hash table is to be -- defined. @Suggested@ is the suggested size of the new table; the -- function should then return a size that is >= @Suggested@. If it -- returns a smaller value anyway, the exception @Container_Error@ is -- raised. package GAL.Containers.Hash_Tables is pragma Elaborate_Body; ---------------------------------------------------------------------------- -- Exception renamings to facilitate usage of this package. Container_Empty : exception renames GAL.Containers.Container_Empty; Container_Full : exception renames GAL.Containers.Container_Full; Range_Error : exception renames GAL.Containers.Range_Error; Not_Found : exception renames GAL.Containers.Not_Found; Duplicate_Key : exception renames GAL.Containers.Duplicate_Key; Hash_Table_Empty : exception renames Container_Empty; Hash_Table_Full : exception renames Container_Full; Container_Error : exception renames GAL.Containers.Container_Error; ---------------------------------------------------------------------------- type Hash_Table is private; -- Hash tables are initially empty; no storage allocation occurs yet. -- Virgin hash tables do not resize themselves when full! -- -- Some routines specify explicit (minimum) sizes for a hash table. Note -- that an implementation is free to choose a larger size if it so -- desires. Null_Hash_Table : constant Hash_Table; ---------------------------------------------------------------------------- procedure Swap (Left, Right : in out Hash_Table); -- Swaps the two hash tables without making a temporary copy. ---------------------------------------------------------------------------- procedure Insert (Table : in out Hash_Table; Element : in Item); -- Raises Container_Full if the hash table is full and automatic resizing -- is off (the table's resize load factor is 0.0), and Duplicate_Key if -- if an item with an equal key already is in the table. procedure Insert (Table : in out Hash_Table; Element : access Item); ---------------------------------------------------------------------------- procedure Replace (Table : in out Hash_Table; Element : in Item); -- If the key already exists in the hash table, replaces the associated -- item. Otherwise inserts the element and its key. procedure Replace (Table : in out Hash_Table; Element : access Item); ---------------------------------------------------------------------------- procedure Delete (Table : in out Hash_Table; Element : in Item); -- Raises Container_Empty if the table is empty, and Not_Found is the key -- is not in the table. procedure Delete (Table : in out Hash_Table; Element : access Item); ---------------------------------------------------------------------------- function Contains (Table : in Hash_Table; Element : in Item) return Boolean; -- Returns False if the table is empty or the key is not in the table, -- True if it is. function Contains (Table : in Hash_Table; Element : access Item) return Boolean; ---------------------------------------------------------------------------- function Nof_Elements (Table : in Hash_Table) return GAL.Support.Hashing.Hash_Type; function Is_Empty (Table : in Hash_Table) return Boolean; function Load (Table : in Hash_Table) return GAL.Support.Hashing.Load_Factor; function Size (Table : in Hash_Table) return GAL.Support.Hashing.Hash_Type; ---------------------------------------------------------------------------- procedure Resize (Table : in out Hash_Table; New_Size : in GAL.Support.Hashing.Size_Type); -- Resizes the table to at least 'New_Size' slots. -- -- Raises Container_Error without modifying 'Table' if New_Size is so -- small that the table couldn't hold all the elements it currently -- contains. -- -- An alternative would be not to change the table at all, without raising -- an exception. However, I think an attempt to shrink a hash table through -- 'Resize' below the current number of elements in the table should be -- seen as an application error. -- -- Raises Range_Error if the new size of the table would be larger than -- the number of elements in Hash_Type. (Note that the new size of the -- table may be *larger* than 'New_Size'!) ---------------------------------------------------------------------------- procedure Reset (Table : in out Hash_Table); procedure Reset (Table : in out Hash_Table; New_Size : in GAL.Support.Hashing.Size_Type); procedure Reset (Table : in out Hash_Table; New_Size : in GAL.Support.Hashing.Size_Type; Resize_At : in GAL.Support.Hashing.Load_Factor); ---------------------------------------------------------------------------- procedure Merge (Result : in out Hash_Table; Source : in Hash_Table); -- Raises Duplicate_Key without modifying 'Result' if 'Source' contains -- a key already in 'Result'. procedure Merge (Result : in out Hash_Table; Source : in Hash_Table; Overwrite : in Boolean); -- Same as above, but different duplicate key handling: if Overwrite is -- true, items already in 'Result' are overwritten by the items from -- 'Source'; otherwise, the items in 'Result' remain unchanged. ---------------------------------------------------------------------------- -- Collision chain management. Every hash table has a collision policy; -- the default is to do exponential hashing, which seems to be least -- Susceptible to clustering (primary or secondary) and better than -- double hashing. -- -- (Note however that better is relative anyway. Depending on the -- circumstances, linear probing may in fact be the most appropriate -- choice, as it exhibits a good access locality and thus may be a win on -- modern processor architctures with multi-level caching.) procedure Set_Collision_Policy (Table : in out Hash_Table; Policy : in GAL.Support.Hashing.Collision_Policy'Class); -- If 'Table' is not empty, this causes re-hashing! procedure Remove_Collision_Policy (Table : in out Hash_Table); -- If 'Table' is not empty, and the current policy is not already the -- default one, this causes re-hashing! procedure Set_Default_Collision_Policy (Table : in out Hash_Table) renames Remove_Collision_Policy; function Get_Collision_Policy (Table : in Hash_Table) return GAL.Support.Hashing.Collision_Policy'Class; ---------------------------------------------------------------------------- -- Growth management. See GAL.Containers.Vectors for more comments. By -- default, a hash table has no growth policy and therefore doesn't -- grow automatically but raises Container_Full in case (2) below. -- -- The increase operation is called to get the new size: -- -- 1. In 'Insert', if the resize load factor > 0.0 and the table's load -- would be greater after inserting. -- -- 2. In 'Insert', if no empty slot can be found. ---------------------------------------------------------------------------- procedure Set_Resize (Table : in out Hash_Table; Resize_At : in GAL.Support.Hashing.Load_Factor); -- If Resize_At = 0.0, the table resizes only if it is full and a growth -- policy is set. procedure Set_Growth_Policy (Table : in out Hash_Table; Policy : in GAL.Support.Hashing.Growth_Policy'Class); procedure Remove_Growth_Policy (Table : in out Hash_Table); procedure Set_Default_Growth_Policy (Table : in out Hash_Table) renames Remove_Growth_Policy; function Has_Growth_Policy (Table : in Hash_Table) return Boolean; function Get_Growth_Policy (Table : in Hash_Table) return GAL.Support.Hashing.Growth_Policy'Class; ---------------------------------------------------------------------------- -- Traversals: type Visitor is abstract tagged private; procedure Execute (V : in out Visitor; Value : in Item; Quit : in out Boolean) is abstract; -- 'Quit' is False upon entry; traversal continues until either all items -- in the hash table have been processed or 'Quit' is set to True. procedure Traverse (Table : in Hash_Table; V : in out Visitor'Class); -- Calls 'Execute (V)' for all items currently in the hash table, until -- either all items have been processed or 'Execute' sets 'Quit' to True. generic with procedure Execute (Value : in Item; Quit : in out Boolean); procedure Traverse_G (Table : in Hash_Table); ---------------------------------------------------------------------------- -- Comparisons function "=" (Left, Right : in Hash_Table) return Boolean; -- Returns true if the two hash tables contain the same number of elements -- with the same keys, False otherwise. private package Impl is new GAL.ADT.Hash_Tables (Item, GAL.Support.Null_Type, Memory, Initial_Size, Hash, "=", Choose_Size); type Visitor is abstract new Impl.Visitor with null record; procedure Action (V : in out Visitor; Key : in Item; Value : in out GAL.Support.Null_Type; Quit : in out Boolean); -- Dispatching call-through to 'Execute'. type Hash_Table is record Rep : Impl.Hash_Table; end record; Null_Hash_Table : constant Hash_Table := (Rep => Impl.Null_Hash_Table); end GAL.Containers.Hash_Tables; adabrowse_4.0.3/util-pipes.ads0000644000175000017500000002066010234241447014454 0ustar kenken------------------------------------------------------------------------------- -- -- Copyright © 2001, 2002 by Thomas Wolf. --
    -- This piece of software is free software; you can redistribute it and/or -- modify it under the terms of the GNU General Public License as published -- by the Free Software Foundation; either version 2, or (at your option) -- any later version. This software is distributed in the hope that it will -- be useful, but without any warranty; without even the implied -- warranty of merchantability or fitness for a particular purpose. -- See the GNU General Public License for more details. You should have -- received a copy of the GNU General Public License with this distribution, -- see file "GPL.txt". If not, write to the Free -- Software Foundation, 59 Temple Place - Suite 330, Boston, MA 02111-1307, -- USA. --
    --
    -- As a special exception from the GPL, if other files instantiate generics -- from this unit, or you link this unit with other files to produce an -- executable, this unit does not by itself cause the resulting executable -- to be covered by the GPL. This exception does not however invalidate any -- other reasons why the executable file might be covered by the GPL. --
    -- -- -- Thomas Wolf (TW) -- -- -- -- This is a thick binding to the @popen@ and @pclose@ routines available -- on both Unix and Win32. It gives a convenient way to execute an external -- program and pass it some input, or read its output. -- -- -- -- Neither task- not abortion-safe. All operations here should be -- considered potentially blocking. -- -- -- -- -- -- 26-APR-2002 TW Initial version. -- 29-APR-2002 TW Added auto-close feature. -- ------------------------------------------------------------------------------- pragma License (Modified_GPL); with Ada.Finalization; with Ada.IO_Exceptions; with Ada.Streams; with Interfaces.C.Strings; package Util.Pipes is type Stream_Mode is (In_Stream, Out_Stream); -- Used in @Open@ to specify the type of the stream. type Pipe_Stream is new Ada.Streams.Root_Stream_Type with private; -- I have found no indication whatsoever about the type of the underlying -- C stream (binary or text mode?). Although you can write and -- read binary data to and from a @Pipe_Stream@, it's probably prudent to -- consider these streams as text-only, because they set up pipes -- to or from an external processes stdin or stdout handles, which are -- defined by the ISO C standard as text streams. Name_Error : exception renames Ada.IO_Exceptions.Name_Error; -- Raised by @Open@ if the command cannot be executed. Use_Error : exception renames Ada.IO_Exceptions.Use_Error; -- Raised by any stream operation if the stream is not open (and by @Open@, -- if it already is open). Mode_Error : exception renames Ada.IO_Exceptions.Mode_Error; -- Stream operations on the returned stream may raise @Mode_Error@ if -- writing on an @In_Stream@ or reading from an @Out_Stream@ is attempted. End_Error : exception renames Ada.IO_Exceptions.End_Error; -- Stream operations on an @In_Stream@ will raise @End_Error@ if EOF is -- encountered. Device_Error : exception renames Ada.IO_Exceptions.Device_Error; -- Raised by the @Put@ or @Get@ operations (and also by @Write@ and -- @Read@) if the underlying system operations indicate any reading or -- writing error. procedure Open (Stream : in out Pipe_Stream; Command : in String; Mode : in Stream_Mode; Close : in Boolean := True; Std_In : in String := ""); -- Executes @Command@, which may contain arguments, setting it up such that -- the executed command's stdin comes from the returned stream if @Mode@ -- is @Out_Stream@, or the command's stdout can be read from that stream -- if @Mode@ is @In_Stream@. Note that "in" and "out" are from the caller's -- perspective. -- -- If Close = True, the stream is closed automatically when -- the stream object disappears. Note that this may involve waiting until -- the external command terminates. @Out_Stream@s always are closed -- automatically. -- -- Raises @Name_Error@ if the @Command@ cannot be executed, or @Use_Error@ -- if the stream is already open. -- -- Note that an output filter is created using a stream of mode -- @Out_Stream@. The external process will share its stdout with the -- calling application, so you should carefully flush your stdout before -- opening such a pipe, otherwise, output may become garbled and mixed up. -- The same applies to an input filter: it shares its stdin with -- the calling application! Unfortunately, one cannot flush an input stream -- (that would be a meaningless operation anyway), so be careful! -- -- One way to avoid such problems is using the @Std_In@ parameter. If it -- is not the empty string, the command's stdin is redirected to come -- from the given filename (which had better be valid). In other words, -- the command actually executed is Command & " <" & Std_In. -- If this feature is used, the caller is responsible for removing the -- file, if that is desired. procedure Close (Stream : in out Pipe_Stream; Exit_Code : out Integer); -- Closes a stream obtained through @Open@. Raises @Use_Error@ if the -- stream has not been opened. -- -- An @Out_Stream@ must be closed, otherwise your program might -- not terminate. therefore, @Pipe_Stream@s are controlled, and any -- @Out_Stream@ is closed automatically when the stream object disappears. -- -- An @In_Stream@ is only closed automatically if it has been opened with -- Close = True, because closing such a stream may involve -- waiting until the external command has terminated. -- -- Note: this is a blocking call: it waits until the executed command -- has terminated, and then returns that commands exit code. function Is_Open (Stream : in Pipe_Stream) return Boolean; -- Returns @True@ if the @Stream@ is open, and @False@ otherwise. function End_Of_Stream (Stream : in Pipe_Stream) return Boolean; -- Raises @Mode_Error@ if the @Stream@ is an @Out_Stream@. Otherwise, -- returns @True@ if the @In_Stream@s end has been reached and @False@ -- otherwise. procedure Put (Stream : in Pipe_Stream; Text : in String); -- Same semantics as @Ada.Text_IO.Put@. procedure Put (Stream : in Pipe_Stream; Ch : in Character); -- Same semantics as @Put@ for a string. procedure Put_Line (Stream : in Pipe_Stream; Text : in String); -- Same semantics as @Ada.Text_IO.Put_Line@. procedure Get (Stream : in Pipe_Stream; Ch : out Character); -- Same semantics as @Ada.Text_IO.Get@. procedure Get (Stream : in Pipe_Stream; Buffer : out String); -- Same semantics as @Ada.Text_IO.Get@. procedure Get_Line (Stream : in Pipe_Stream; Buffer : out String; Last : out Natural); -- Same semantics as @Ada.Text_IO.Get_Line@. function Get_Line (Stream : in Pipe_Stream) return String; -- As @Ada.Text_IO.Get_Line@, but always returns a full line. private type C_File_Ptr is new Interfaces.C.Strings.chars_ptr; Null_Ptr : constant C_File_Ptr := C_File_Ptr (Interfaces.C.Strings.Null_Ptr); type Closer (Stream : access Pipe_Stream) is new Ada.Finalization.Limited_Controlled with null record; procedure Finalize (C : in out Closer); type Pipe_Stream is new Ada.Streams.Root_Stream_Type with record F : C_File_Ptr := Null_Ptr; Mode : Stream_Mode; Close_It : Boolean := True; Clean_Up : Closer (Pipe_Stream'Access); end record; procedure Read (Stream : in out Pipe_Stream; Item : out Ada.Streams.Stream_Element_Array; Last : out Ada.Streams.Stream_Element_Offset); procedure Write (Stream : in out Pipe_Stream; Item : in Ada.Streams.Stream_Element_Array); end Util.Pipes; adabrowse_4.0.3/ad-projects-impl_no.adb0000644000175000017500000000556510234241451016210 0ustar kenken------------------------------------------------------------------------------- -- -- This file is part of AdaBrowse. -- -- Copyright (c) 2002 by Thomas Wolf. --
    -- AdaBrowse is free software; you can redistribute it and/or modify it -- under the terms of the GNU General Public License as published by the -- Free Software Foundation; either version 2, or (at your option) any -- later version. AdaBrowse is distributed in the hope that it will be -- useful, but without any warranty; without even the implied -- warranty of merchantability or fitness for a particular purpose. -- See the GNU General Public License for more details. You should have -- received a copy of the GNU General Public License with this distribution, -- see file "GPL.txt". If not, write to the Free -- Software Foundation, 59 Temple Place - Suite 330, Boston, MA 02111-1307, -- USA. --
    -- --
    -- Author:
    -- Thomas Wolf (TW) --
    twolf@acm.org
    -- --
    -- Purpose:
    -- A dummy project manager implementation for a non-existing project -- manager.
    -- -- ------------------------------------------------------------------------------- pragma License (GPL); with Ada.Exceptions; package body AD.Projects.Impl_No is procedure Handle_Project_File (Name : in String) is pragma Warnings (Off, Name); -- silence -gnatwa begin Ada.Exceptions.Raise_Exception (Project_Error'Identity, "This AdaBrowse version doesn't support GNAT project files!"); end Handle_Project_File; procedure Get_Source_File_List (File : in out Ada.Text_IO.File_Type) is pragma Warnings (Off, File); -- silence -gnatwa begin null; end Get_Source_File_List; function Get_Tree_Directory return String is begin return ""; end Get_Tree_Directory; function Get_Output_Directory return String is begin return ""; end Get_Output_Directory; function Get_Project_File_Name return String is begin return ""; end Get_Project_File_Name; function Project_Version return String is begin return ""; end Project_Version; procedure Reset (On_Error : in Boolean) is pragma Warnings (Off, On_Error); -- silence -gnatwa begin null; end Reset; procedure Define_Variable (Name : in String; Value : in String) is pragma Warnings (Off, Name); -- silence -gnatwa pragma Warnings (Off, Value); -- silence -gnatwa begin null; end Define_Variable; procedure Initialize is begin null; end Initialize; end AD.Projects.Impl_No; adabrowse_4.0.3/asis2-predicates.adb0000644000175000017500000010621010234241452015472 0ustar kenken------------------------------------------------------------------------------- -- -- This unit is part of the @Asis2@ ASIS secondary library. -- -- Copyright (c) 2003 by Thomas Wolf. --
    -- AdaBrowse is free software; you can redistribute it and/or modify it -- under the terms of the GNU General Public License as published by the -- Free Software Foundation; either version 2, or (at your option) any -- later version. AdaBrowse is distributed in the hope that it will be -- useful, but without any warranty; without even the implied -- warranty of merchantability or fitness for a particular purpose. -- See the GNU General Public License for more details. You should have -- received a copy of the GNU General Public License with this distribution, -- see file "GPL.txt". If not, write to the Free -- Software Foundation, 59 Temple Place - Suite 330, Boston, MA 02111-1307, -- USA. --
    --
    -- As a special exception from the GPL, if other files instantiate generics -- from this unit, or you link this unit with other files to produce an -- executable, this unit does not by itself cause the resulting executable -- to be covered by the GPL. This exception does not however invalidate any -- other reasons why the executable file might be covered by the GPL. --
    -- -- -- Thomas Wolf (TW) -- -- -- -- Useful predicates on @Asis.Element@. All predicates return @False@ if -- called with inappropriate element kinds. -- -- Whereever the following descriptions specify "a declaration of", this -- also allows "a defining name in a declaration of". -- -- Wherever the following descriptions specify "a declaration of a type" or -- " a type declaration", this also allows "a type definition" of such a -- type. -- -- Mentions of "type" include generic formal types, "variable" includes -- generic formal "in out" objects, and so on. -- -- If @Element@ is an @Expression@, the predicates on types are also -- applicable, they refer to the type of the expression. If the @Expression@ -- is a name (identifier, operator, enumeration literal, or selected -- component), they refer to the referenced defining name. -- -- -- -- 05-JUN-2003 TW Initial version. -- 08-JUL-2003 TW Added 'Is_Package'; changed 'Unique_Name' to really -- return the fully qualified name. -- 18-JUL-2003 TW Removed the string operations, put into the @Asis2@ -- library, changed the license. -- ------------------------------------------------------------------------------- pragma License (Modified_GPL); with Asis.Compilation_Units; with Asis.Definitions; with Asis.Declarations; with Asis.Elements; with Asis.Expressions; with Asis2.Container_Elements; with Asis2.Declarations; with Asis2.Naming; with Asis2.Text; package body Asis2.Predicates is use Asis; use Asis.Definitions; use Asis.Declarations; use Asis.Elements; use Asis.Expressions; function Decl (Element : in Asis.Element) return Asis.Element is begin case Element_Kind (Element) is when An_Expression => case Expression_Kind (Element) is when An_Identifier | An_Enumeration_Literal | An_Operator_Symbol | A_Character_Literal | A_Selected_Component => return Asis2.Declarations.Name_Declaration (Element); when others => return Corresponding_Expression_Type (Element); end case; when A_Defining_Name | A_Definition => return Asis2.Declarations.Enclosing_Declaration (Element); when A_Declaration => return Element; when others => return Nil_Element; end case; end Decl; function Def (Decl : in Asis.Declaration) return Asis.Definition is D : constant Declaration_Kinds := Declaration_Kind (Decl); begin if D in A_Type_Declaration or else D = A_Subtype_Declaration then if D /= An_Incomplete_Type_Declaration then return Type_Declaration_View (Decl); else return Nil_Element; end if; elsif D in An_Object_Declaration then return Object_Declaration_View (Decl); end if; return Nil_Element; end Def; function Type_Of (D : in Asis.Declaration) return Asis.Declaration is begin case Declaration_Kind (D) is when A_Type_Declaration | A_Subtype_Declaration => return D; when A_Variable_Declaration | A_Constant_Declaration | A_Deferred_Constant_Declaration | An_Integer_Number_Declaration | A_Real_Number_Declaration => return Type_Of (Decl (Asis.Definitions.Subtype_Mark (Def (D)))); when A_Function_Declaration | A_Function_Renaming_Declaration | A_Formal_Function_Declaration | A_Generic_Function_Declaration => return Type_Of (Decl (Result_Profile (D))); when A_Function_Instantiation => return Type_Of (Corresponding_Declaration (D)); when A_Formal_Object_Declaration => return Type_Of (Decl (Declaration_Subtype_Mark (Def (D)))); when others => null; end case; return Nil_Element; end Type_Of; function Base (D : in Asis.Declaration) return Asis.Declaration is Type_Decl : constant Declaration := Type_Of (D); begin case Declaration_Kind (Type_Decl) is when A_Type_Declaration | A_Subtype_Declaration => return Corresponding_First_Subtype (Type_Decl); when others => null; end case; return Nil_Element; end Base; function Root (D : in Asis.Declaration) return Asis.Declaration is Type_Decl : constant Declaration := Type_Of (D); begin case Declaration_Kind (Type_Decl) is when A_Subtype_Declaration => return Root (Base (Type_Decl)); when others => declare Def : constant Asis.Definition := Asis2.Predicates.Def (Type_Decl); begin if Is_Nil (Def) then return Nil_Element; end if; case Definition_Kind (Def) is when A_Type_Definition => case Type_Kind (Def) is when A_Derived_Type_Definition | A_Derived_Record_Extension_Definition => return Corresponding_Root_Type (Def); when others => return Type_Decl; end case; when A_Formal_Type_Definition => if Formal_Type_Kind (Def) = A_Formal_Derived_Type_Definition then return Root (Decl (Asis.Definitions.Subtype_Mark (Def))); else return Type_Decl; end if; when others => return Type_Decl; end case; end; end case; end Root; ---------------------------------------------------------------------------- -- Units function Is_Private (Element : in Asis.Element) return Boolean is begin if Is_Nil (Element) then return False; end if; declare D : constant Asis.Declaration := Decl (Element); begin if Is_Nil (D) then return False; end if; if Is_Unit (D) then case Asis.Compilation_Units.Unit_Class (Enclosing_Compilation_Unit (D)) is when A_Private_Declaration | A_Private_Body => return True; when others => null; end case; else declare Items : constant Asis.Element_List := Asis2.Container_Elements.Private_Items (Asis2.Declarations.Enclosing_Declaration (D)); begin for I in Items'Range loop if Is_Equal (D, Items (I)) then return True; end if; end loop; end; end if; end; return False; end Is_Private; function Is_Separate (Element : in Asis.Element) return Boolean is begin if Is_Nil (Element) then return False; end if; declare D : constant Asis.Declaration := Decl (Element); begin if Is_Nil (D) then return False; end if; if Is_Unit (D) then if Asis.Compilation_Units.Unit_Class (Enclosing_Compilation_Unit (D)) = A_Separate_Body then return True; end if; else if Declaration_Kind (D) in A_Body_Stub then return True; end if; end if; end; return False; end Is_Separate; function Is_Unit (Element : in Asis.Element) return Boolean is begin if Is_Nil (Element) then return False; end if; return Is_Equal (Decl (Element), Unit_Declaration (Enclosing_Compilation_Unit (Element))); end Is_Unit; function Is_Child (Element : in Asis.Element) return Boolean is begin if Is_Unit (Element) then declare use Asis.Compilation_Units; Parent : constant Asis.Compilation_Unit := Corresponding_Parent_Declaration (Enclosing_Compilation_Unit (Element)); begin if Is_Nil (Parent) then -- Standard return False; end if; -- If the grandparent is nil, the parent is Standard, and we *do* -- have a root unit. return not Is_Nil (Corresponding_Parent_Declaration (Parent)); end; end if; return False; end Is_Child; ---------------------------------------------------------------------------- -- Items function Is_Constant (Element : in Asis.Element) return Boolean is begin if Is_Nil (Element) then return False; end if; declare D : constant Asis.Declaration := Decl (Element); begin case Declaration_Kind (D) is when A_Constant_Declaration | A_Deferred_Constant_Declaration | A_Real_Number_Declaration | An_Integer_Number_Declaration => return True; when A_Formal_Object_Declaration => return Mode_Kind (D) <= An_In_Mode; when others => null; end case; end; return False; end Is_Constant; function Is_Variable (Element : in Asis.Element) return Boolean is begin if Is_Nil (Element) then return False; end if; declare D : constant Asis.Declaration := Decl (Element); begin case Declaration_Kind (D) is when A_Variable_Declaration | A_Single_Task_Declaration | A_Single_Protected_Declaration => return True; when A_Formal_Object_Declaration => return Mode_Kind (D) >= An_Out_Mode; when others => null; end case; end; return False; end Is_Variable; function Is_Package (Element : in Asis.Element) return Boolean is begin if Is_Nil (Element) then return False; end if; declare D : constant Asis.Declaration := Decl (Element); begin case Declaration_Kind (D) is when A_Package_Declaration | A_Generic_Package_Declaration | A_Generic_Package_Renaming_Declaration | A_Package_Instantiation | A_Package_Renaming_Declaration | A_Formal_Package_Declaration | A_Formal_Package_Declaration_With_Box => return True; when others => return False; end case; end; end Is_Package; function Is_Type (Element : in Asis.Element) return Boolean is begin if Is_Nil (Element) then return False; end if; declare D : constant Asis.Declaration := Decl (Element); begin case Declaration_Kind (D) is when A_Formal_Type_Declaration => return True; when others => return Declaration_Kind (D) in A_Type_Declaration; end case; end; end Is_Type; function Is_Subtype (Element : in Asis.Element) return Boolean is begin return Declaration_Kind (Decl (Element)) = A_Subtype_Declaration; end Is_Subtype; -- Returns @True@ if @Element@ is a subtype declaration. function Is_Procedure (Element : in Asis.Element) return Boolean is begin case Declaration_Kind (Decl (Element)) is when A_Procedure_Declaration | A_Generic_Procedure_Declaration | A_Procedure_Renaming_Declaration | A_Generic_Procedure_Renaming_Declaration | A_Procedure_Body_Declaration | A_Procedure_Body_Stub | A_Procedure_Instantiation => return True; when A_Formal_Procedure_Declaration => return True; when others => return False; end case; end Is_Procedure; function Is_Function (Element : in Asis.Element) return Boolean is begin case Declaration_Kind (Decl (Element)) is when A_Function_Declaration | A_Generic_Function_Declaration | A_Function_Renaming_Declaration | A_Generic_Function_Renaming_Declaration | A_Function_Body_Declaration | A_Function_Body_Stub | A_Function_Instantiation => return True; when A_Formal_Function_Declaration => return True; when others => return False; end case; end Is_Function; function Is_Subprogram (Element : in Asis.Element) return Boolean is begin return Is_Procedure (Element) or else Is_Function (Element); end Is_Subprogram; function Is_Entry (Element : in Asis.Element) return Boolean is begin case Declaration_Kind (Decl (Element)) is when An_Entry_Declaration | An_Entry_Body_Declaration => return True; when others => return False; end case; end Is_Entry; ---------------------------------------------------------------------------- -- Types, Variables, and Constants. See RM 3.2 function Is_Elementary (Element : in Asis.Element) return Boolean is D : constant Definition := Def (Root (Decl (Element))); begin case Definition_Kind (D) is when Not_A_Definition => return False; when A_Task_Definition | A_Protected_Definition | A_Tagged_Private_Type_Definition | A_Private_Extension_Definition => return False; when A_Private_Type_Definition => return False; when A_Type_Definition => case Type_Kind (D) is when An_Unconstrained_Array_Definition | A_Constrained_Array_Definition | A_Record_Type_Definition => return False; when others => null; end case; when A_Formal_Type_Definition => case Formal_Type_Kind (D) is when A_Formal_Discrete_Type_Definition .. A_Formal_Decimal_Fixed_Point_Definition => return True; when others => return False; end case; when others => null; end case; return True; end Is_Elementary; function Is_Scalar (Element : in Asis.Element) return Boolean is subtype Scalar_Type is Type_Kinds range An_Enumeration_Type_Definition .. A_Decimal_Fixed_Point_Definition; D : constant Definition := Def (Root (Decl (Element))); begin case Definition_Kind (D) is when A_Formal_Type_Definition => case Formal_Type_Kind (D) is when A_Formal_Discrete_Type_Definition .. A_Formal_Decimal_Fixed_Point_Definition => return True; when others => return False; end case; when others => return Type_Kind (D) in Scalar_Type; end case; end Is_Scalar; function Is_Discrete (Element : in Asis.Element) return Boolean is D : constant Definition := Def (Root (Decl (Element))); begin case Definition_Kind (D) is when A_Formal_Type_Definition => case Formal_Type_Kind (D) is when A_Formal_Discrete_Type_Definition .. A_Formal_Modular_Type_Definition => return True; when others => return False; end case; when others => case Type_Kind (D) is when An_Enumeration_Type_Definition | A_Signed_Integer_Type_Definition | A_Modular_Type_Definition => return True; when A_Root_Type_Definition => case Root_Type_Kind (D) is when A_Root_Integer_Definition | A_Universal_Integer_Definition => return True; when others => null; end case; when others => null; end case; return False; end case; end Is_Discrete; function Is_Enumeration (Element : in Asis.Element) return Boolean is D : constant Definition := Def (Root (Decl (Element))); begin return Type_Kind (D) = An_Enumeration_Type_Definition; end Is_Enumeration; -- Returns @True@ if @Element@ is either the declaration of an enumeration -- type or a variable declaration whose type is an enumeration type. -- Includes subtypes and derived types, also includes character and boolean -- types. function Is_Integral (Element : in Asis.Element) return Boolean is D : constant Definition := Def (Root (Decl (Element))); begin case Definition_Kind (D) is when A_Formal_Type_Definition => case Formal_Type_Kind (D) is when A_Formal_Signed_Integer_Type_Definition | A_Formal_Modular_Type_Definition => return True; when others => null; end case; when others => case Type_Kind (D) is when A_Signed_Integer_Type_Definition | A_Modular_Type_Definition => return True; when A_Root_Type_Definition => case Root_Type_Kind (D) is when A_Root_Integer_Definition | A_Universal_Integer_Definition => return True; when others => null; end case; when others => null; end case; end case; return False; end Is_Integral; function Is_Signed (Element : in Asis.Element) return Boolean is D : constant Definition := Def (Root (Decl (Element))); begin case Definition_Kind (D) is when A_Formal_Type_Definition => return Formal_Type_Kind (D) = A_Formal_Signed_Integer_Type_Definition; when others => case Type_Kind (D) is when A_Signed_Integer_Type_Definition => return True; when A_Root_Type_Definition => case Root_Type_Kind (D) is when A_Root_Integer_Definition | A_Universal_Integer_Definition => return True; when others => null; end case; when others => null; end case; end case; return False; end Is_Signed; function Is_Modular (Element : in Asis.Element) return Boolean is D : constant Definition := Def (Root (Decl (Element))); begin return Type_Kind (D) = A_Modular_Type_Definition or else Formal_Type_Kind (D) = A_Formal_Modular_Type_Definition; end Is_Modular; function Is_Real (Element : in Asis.Element) return Boolean is subtype Formal_Reals is Formal_Type_Kinds range A_Formal_Floating_Point_Definition .. A_Formal_Decimal_Fixed_Point_Definition; D : constant Definition := Def (Root (Decl (Element))); begin case Definition_Kind (D) is when A_Formal_Type_Definition => return Formal_Type_Kind (D) in Formal_Reals; when others => case Type_Kind (D) is when A_Floating_Point_Definition | An_Ordinary_Fixed_Point_Definition | A_Decimal_Fixed_Point_Definition => return True; when A_Root_Type_Definition => case Root_Type_Kind (D) is when A_Root_Real_Definition | A_Universal_Real_Definition | A_Universal_Fixed_Definition => return True; when others => null; end case; when others => null; end case; end case; return False; end Is_Real; function Is_Float (Element : in Asis.Element) return Boolean is D : constant Definition := Def (Root (Decl (Element))); begin case Definition_Kind (D) is when A_Formal_Type_Definition => return Formal_Type_Kind (D) = A_Formal_Floating_Point_Definition; when others => case Type_Kind (D) is when A_Floating_Point_Definition => return True; when A_Root_Type_Definition => case Root_Type_Kind (D) is when A_Root_Real_Definition | A_Universal_Real_Definition => return True; when others => null; end case; when others => null; end case; end case; return False; end Is_Float; function Is_Fixed (Element : in Asis.Element) return Boolean is D : constant Definition := Def (Root (Decl (Element))); begin case Definition_Kind (D) is when A_Formal_Type_Definition => case Formal_Type_Kind (D) is when A_Formal_Ordinary_Fixed_Point_Definition .. A_Formal_Decimal_Fixed_Point_Definition => return True; when others => null; end case; when others => case Type_Kind (D) is when An_Ordinary_Fixed_Point_Definition | A_Decimal_Fixed_Point_Definition => return True; when A_Root_Type_Definition => return Root_Type_Kind (D) = A_Universal_Fixed_Definition; when others => null; end case; end case; return False; end Is_Fixed; function Is_Ordinary_Fixed (Element : in Asis.Element) return Boolean is D : constant Definition := Def (Root (Decl (Element))); begin return Type_Kind (D) = An_Ordinary_Fixed_Point_Definition or else Formal_Type_Kind (D) = A_Formal_Ordinary_Fixed_Point_Definition; end Is_Ordinary_Fixed; function Is_Decimal_Fixed (Element : in Asis.Element) return Boolean is D : constant Definition := Def (Root (Decl (Element))); begin return Type_Kind (D) = A_Decimal_Fixed_Point_Definition or else Formal_Type_Kind (D) = A_Formal_Decimal_Fixed_Point_Definition; end Is_Decimal_Fixed; function Is_Numeric (Element : in Asis.Element) return Boolean is begin return Is_Real (Element) or else Is_Integral (Element); end Is_Numeric; function Is_Access (Element : in Asis.Element) return Boolean is D : constant Definition := Def (Root (Decl (Element))); begin return Type_Kind (D) = An_Access_Type_Definition; end Is_Access; function Is_Access_To_Object (Element : in Asis.Element) return Boolean is D : constant Definition := Def (Root (Decl (Element))); begin return Access_Type_Kind (D) in Asis.Access_To_Object_Definition; end Is_Access_To_Object; function Is_Access_To_Subprogram (Element : in Asis.Element) return Boolean is D : constant Definition := Def (Root (Decl (Element))); begin return Access_Type_Kind (D) in Asis.Access_To_Subprogram_Definition; end Is_Access_To_Subprogram; function Is_Composite (Element : in Asis.Element) return Boolean is D : constant Definition := Def (Root (Decl (Element))); begin case Definition_Kind (D) is when Not_A_Definition => -- Because of this case, we cannot just return -- not Is_Elementary. return False; when A_Task_Definition | A_Protected_Definition | A_Tagged_Private_Type_Definition | A_Private_Extension_Definition => return True; when A_Private_Type_Definition => -- This is also a case where composite /= not -- elementary. return False; when A_Type_Definition => case Type_Kind (D) is when An_Unconstrained_Array_Definition | A_Constrained_Array_Definition | A_Record_Type_Definition => return True; when others => null; end case; when others => null; end case; return False; end Is_Composite; function Is_Array (Element : in Asis.Element) return Boolean is D : constant Definition := Def (Root (Decl (Element))); begin case Type_Kind (D) is when An_Unconstrained_Array_Definition | A_Constrained_Array_Definition => return True; when others => return False; end case; end Is_Array; function Is_Record (Element : in Asis.Element) return Boolean is D : constant Definition := Def (Root (Decl (Element))); begin case Definition_Kind (D) is when A_Tagged_Private_Type_Definition | A_Private_Extension_Definition => return True; when A_Type_Definition => case Type_Kind (D) is when A_Record_Type_Definition | A_Derived_Record_Extension_Definition | A_Tagged_Record_Type_Definition => return True; when others => null; end case; when others => null; end case; return False; end Is_Record; function Is_Tagged (Element : in Asis.Element) return Boolean is D : constant Definition := Def (Root (Decl (Element))); begin case Definition_Kind (D) is when A_Tagged_Private_Type_Definition | A_Private_Extension_Definition => return True; when A_Type_Definition => case Type_Kind (D) is when A_Derived_Record_Extension_Definition | A_Tagged_Record_Type_Definition => return True; when others => null; end case; when others => null; end case; return False; end Is_Tagged; function Is_Task (Element : in Asis.Element) return Boolean is begin declare D : constant Asis.Declaration := Root (Decl (Element)); begin case Declaration_Kind (D) is when A_Task_Type_Declaration | A_Single_Task_Declaration => return True; when others => return Definition_Kind (Def (D)) = A_Task_Definition; end case; end; end Is_Task; function Is_Protected (Element : in Asis.Element) return Boolean is Elem_Decl : Asis.Declaration := Decl (Element); begin if Is_Subprogram (Elem_Decl) or else Is_Entry (Elem_Decl) then -- It is protected if it is a protected subprogram, i.e. the -- enclosing declaration (if any) is a protected type or object. Elem_Decl := Asis2.Declarations.Enclosing_Declaration (Elem_Decl); end if; declare D : constant Asis.Declaration := Root (Elem_Decl); begin case Declaration_Kind (D) is when A_Protected_Type_Declaration | A_Single_Protected_Declaration => return True; when others => return Definition_Kind (Def (D)) = A_Protected_Definition; end case; end; end Is_Protected; function Is_Limited (Element : in Asis.Element) return Boolean is begin if Is_Task (Element) or else Is_Protected (Element) then return True; end if; declare D : constant Asis.Declaration := Root (Decl (Element)); begin case Trait_Kind (D) is when A_Limited_Trait | A_Limited_Private_Trait => return True; when others => null; end case; end; return False; end Is_Limited; function Is_Class_Wide (Element : in Asis.Element) return Boolean is function Class_Wide_Subtype (D : in Definition) return Boolean is Expr : Expression := Asis.Definitions.Subtype_Mark (D); begin while Expression_Kind (Expr) = An_Attribute_Reference loop if Attribute_Kind (Expr) = A_Class_Attribute then return True; else Expr := Prefix (Expr); end if; end loop; return Is_Class_Wide (Expr); end Class_Wide_Subtype; D : constant Asis.Declaration := Decl (Element); begin case Declaration_Kind (D) is when A_Subtype_Declaration => return Class_Wide_Subtype (Type_Declaration_View (D)); when A_Variable_Declaration | A_Constant_Declaration | A_Deferred_Constant_Declaration => declare Def : constant Definition := Object_Declaration_View (D); begin if Definition_Kind (Def) = A_Subtype_Indication then return Class_Wide_Subtype (Def); end if; end; when A_Formal_Object_Declaration => return Attribute_Kind (Declaration_Subtype_Mark (D)) = A_Class_Attribute; when others => null; end case; return False; end Is_Class_Wide; function Is_Controlled (Element : in Asis.Element) return Boolean is D : Asis.Declaration := Root (Decl (Element)); begin -- It's controlled if the enclosing package of the root type's -- declaration is Ada.Finalization, or if it is a private type -- who's full view is controlled. if Declaration_Kind (D) = A_Private_Type_Declaration then D := (Corresponding_Type_Declaration (D)); end if; declare Name : constant Wide_String := Asis2.Text.To_Lower (Asis2.Naming.Full_Unit_Name (Enclosing_Compilation_Unit (D))); begin return Name = "ada.finalization"; end; end Is_Controlled; function Is_Private_Type (Element : in Asis.Element) return Boolean is D : constant Definition := Base (Decl (Element)); begin case Declaration_Kind (D) is when A_Private_Type_Declaration | A_Private_Extension_Declaration => return True; when others => null; end case; return False; end Is_Private_Type; function Is_Incomplete (Element : in Asis.Element) return Boolean is D : constant Declaration := Decl (Element); begin case Declaration_Kind (D) is when An_Incomplete_Type_Declaration | A_Deferred_Constant_Declaration => return True; when others => return False; end case; end Is_Incomplete; function Is_Aliased (Element : in Asis.Element) return Boolean is begin return Trait_Kind (Decl (Element)) = An_Aliased_Trait; end Is_Aliased; ---------------------------------------------------------------------------- -- Generics, renamings, and other stuff. function Is_Exception (Element : in Asis.Element) return Boolean is D : constant Declaration := Decl (Element); begin case Declaration_Kind (D) is when An_Exception_Declaration | An_Exception_Renaming_Declaration => return True; when others => return False; end case; end Is_Exception; function Is_Renaming (Element : in Asis.Element) return Boolean is D : constant Declaration := Decl (Element); begin return Declaration_Kind (D) in Asis.A_Renaming_Declaration; end Is_Renaming; function Is_Generic (Element : in Asis.Element) return Boolean is D : constant Declaration := Decl (Element); begin return Declaration_Kind (D) in Asis.A_Generic_Declaration; end Is_Generic; function Is_Generic_Formal (Element : in Asis.Element) return Boolean is D : constant Declaration := Decl (Element); begin return Declaration_Kind (D) in Asis.A_Formal_Declaration; end Is_Generic_Formal; function Is_Instance (Element : in Asis.Element) return Boolean is D : constant Declaration := Decl (Element); begin return Declaration_Kind (D) in Asis.A_Generic_Instantiation; end Is_Instance; function Is_Abstract (Element : in Asis.Element) return Boolean is begin return Trait_Kind (Decl (Element)) >= An_Abstract_Trait; end Is_Abstract; function Is_Pragma (Element : in Asis.Element) return Boolean is begin return Element_Kind (Element) = A_Pragma; end Is_Pragma; function Is_Clause (Element : in Asis.Element) return Boolean is begin return Clause_Kind (Element) = A_Representation_Clause; end Is_Clause; end Asis2.Predicates; adabrowse_4.0.3/ad-printers-xml.adb0000644000175000017500000005232110234241451015360 0ustar kenken------------------------------------------------------------------------------- -- -- This file is part of AdaBrowse. -- -- Copyright (c) 2002 by Thomas Wolf. --
    -- AdaBrowse is free software; you can redistribute it and/or modify it -- under the terms of the GNU General Public License as published by the -- Free Software Foundation; either version 2, or (at your option) any -- later version. AdaBrowse is distributed in the hope that it will be -- useful, but without any warranty; without even the implied -- warranty of merchantability or fitness for a particular purpose. -- See the GNU General Public License for more details. You should have -- received a copy of the GNU General Public License with this distribution, -- see file "GPL.txt". If not, write to the Free -- Software Foundation, 59 Temple Place - Suite 330, Boston, MA 02111-1307, -- USA. --
    -- --
    -- Author:
    -- Thomas Wolf (TW) --
    twolf@acm.org
    -- --
    -- Purpose:
    -- Abstract root type for the various output producers (HTML, XML, DocBook, -- and so on).
    -- -- ------------------------------------------------------------------------------- pragma License (GPL); with Ada.Characters.Handling; with Ada.Exceptions; with Ada.Strings.Wide_Unbounded; with AD.HTML; with AD.Options; with AD.Messages; with AD.Version; with Util.Strings; with Util.Text.Internal; package body AD.Printers.XML is package ACH renames Ada.Characters.Handling; package WASU renames Ada.Strings.Wide_Unbounded; use Util.Strings; XML_Version : constant String := "1.0"; -- Version of XML itself. DTD_Version : constant String := "2.0"; -- Version of the AdaBrowse DTD we're using. function Dots_To_Dashes (S : in String) return String is Result : String := S; begin for I in Result'Range loop if Result (I) = '.' then Result (I) := '_'; end if; end loop; return Result; end Dots_To_Dashes; function Quot (S : in String) return String is begin -- It happens that HTMLize is also useable for XML output... return AD.HTML.HTMLize (S, Keep_Entities => False); end Quot; procedure Emit_XRef_Data (Self : access Printer; XRef : in AD.Crossrefs.Cross_Reference; Anchor : in Boolean := False) is begin -- Emit the name even for local XREFs and ANCHORs. Put (Self, " UNIT=""" & ACH.To_String (WASU.To_Wide_String (XRef.Full_Unit_Name)) & '"'); Put (Self, " POS=""" & To_String (XRef.Position, True) & '"'); if XRef.Is_Top_Unit then Put (Self, " IS_TOP=""TRUE"""); end if; if XRef.Is_Local and then not Anchor then Put (Self, " IS_LOCAL=""TRUE"""); end if; end Emit_XRef_Data; procedure Put_XRef (Self : access Printer; Tag : in String; XRef : in AD.Crossrefs.Cross_Reference; Anchor : in Boolean := False) is begin if not XRef.Ignore then Put (Self, '<' & Tag); Emit_XRef_Data (Self, XRef, Anchor); Put (Self, '>'); end if; Put (Self, Quot (ACH.To_String (WASU.To_Wide_String (XRef.Image)))); if not XRef.Ignore then Put (Self, "'); end if; end Put_XRef; procedure Indent (Self : access Printer) is S : constant String (1 .. 2 * Self.Indent) := (others => ' '); begin Put (Self, S); end Indent; ---------------------------------------------------------------------------- function Get_Suffix (Self : in Printer) return String is pragma Warnings (Off, Self); -- silence -gnatwa begin return "xml"; end Get_Suffix; procedure Finalize (Self : in out Printer) is begin if Is_Open (Self) then Put_Line (Self, ""); Put_Line (Self, ""); end if; Close_File (Self); Finalize (Real_Printer (Self)); end Finalize; ---------------------------------------------------------------------------- procedure Open_Unit (Self : access Printer; Unit_Kind : in Item_Kind; Unit_Name : in Wide_String; Is_Private : in Boolean; XRef : in AD.Crossrefs.Cross_Reference) is begin if Self.Initial then Self.Initial := False; begin Open_File (Self.all, AD.Options.Single_File, "adabrowse"); -- Write the header: declare Char_Set : constant String := AD.HTML.Character_Set; begin Put (Self, " 0 then Put (Self, " encoding=""" & Char_Set & '"'); end if; Put_Line (Self, "?>"); end; New_Line (Self); Put_Line (Self, ""); New_Line (Self); Put_Line (Self, ""); New_Line (Self); Put_Line (Self, ""); exception when E : others => AD.Messages.Error (Ada.Exceptions.Exception_Message (E) & "; XML generation disabled."); end; end if; Self.Use_Buffer := False; Self.Buffer := Util.Text.Null_Unbounded_String; if Is_Open (Self.all) then New_Line (Self); declare -- Only add the PRIVATE attribute if the unit really *is* a -- private unit. If it isn't, don't add it. function Get_Private (Is_Private : in Boolean) return String is begin if Is_Private then return """ PRIVATE=""" & Boolean'Image (Is_Private); else return ""; end if; end Get_Private; begin Put_Line (Self, ""); end; Self.Indent := 1; Self.No_XRef := False; end if; end Open_Unit; procedure Close_Unit (Self : access Printer) is begin Self.Indent := Self.Indent - 1; Indent (Self); Put_Line (Self, ""); New_Line (Self); end Close_Unit; procedure Write_Comment (Self : access Printer; Lines : in Asis.Text.Line_List) is begin if Lines'Last >= Lines'First then Indent (Self); Put_Line (Self, ""); Self.Indent := Self.Indent + 1; for I in Lines'Range loop Indent (Self); Put_Line (Self, "" & Quot (Trim (ACH.To_String (Asis.Text.Comment_Image (Lines (I))))) & ""); end loop; Self.Indent := Self.Indent - 1; Indent (Self); Put_Line (Self, ""); end if; end Write_Comment; procedure Open_Section (Self : access Printer; Section : in Section_Type) is S : constant String := To_Upper (Section_Type'Image (Section)); begin if Section = Index_XRef_Section then -- Nothing to do: XML doesn't have inter-index xrefs! return; end if; -- 'S' ends in "_SECTION". Indent (Self); Put (Self, '<' & S (S'First .. S'Last - 8) & '>'); case Section is when Exception_Rename_Section | Ultimate_Exception_Section => null; when others => New_Line (Self); Self.Indent := Self.Indent + 1; end case; case Section is when Snippet_Section | Header_Section | Footer_Section => Self.Use_Buffer := True; Self.Buffer := Util.Text.Null_Unbounded_String; when others => null; end case; end Open_Section; procedure Close_Section (Self : access Printer; Section : in Section_Type) is begin case Section is when Index_XRef_Section => -- Nothing to do: XML doesn't have inter-index cross-refs! return; when Snippet_Section | Header_Section | Footer_Section => -- Now emit the snippet as a sequence of 's. Self.Use_Buffer := False; -- Switch off buffer usage! declare Txt : constant Util.Text.String_Access := Util.Text.Internal.Get_Ptr (Self.Buffer); First : Natural := 1; I : Natural := First_Index (Txt.all, ASCII.LF); begin loop if I = 0 then Indent (Self); Put_Line (Self, "" & Txt (First .. Txt'Last) & ""); exit; else Indent (Self); Put_Line (Self, "" & Txt (First .. I - 1) & ""); exit when I = Txt'Last; end if; First := I + 1; I := First_Index (Txt (First .. Txt'Last), ASCII.LF); end loop; end; Self.Buffer := Util.Text.Null_Unbounded_String; when others => null; end case; case Section is when Exception_Rename_Section | Ultimate_Exception_Section => null; when others => Self.Indent := Self.Indent - 1; Indent (Self); end case; declare S : constant String := To_Upper (Section_Type'Image (Section)); begin -- 'S' ends in "_SECTION". Put_Line (Self, "'); end; end Close_Section; procedure Open_Item (Self : access Printer; XRef : in AD.Crossrefs.Cross_Reference; Kind : in Item_Kind := Not_An_Item; Name : in Wide_String := "") is begin Indent (Self); Put (Self, "= Name'First then Put (Self, " NAME=""" & Quot (ACH.To_String (Name)) & '"'); end if; if Kind /= Not_An_Item then Put (Self, " KIND=""" & To_Upper (Item_Kind'Image (Kind)) & '"'); end if; if not XRef.Ignore then declare X : AD.Crossrefs.Cross_Reference := XRef; begin X.Is_Top_Unit := False; -- We never want the IS_TOP here! Emit_XRef_Data (Self, X, True); end; end if; Put_Line (Self, ">"); Self.Indent := Self.Indent + 1; end Open_Item; procedure Close_Item (Self : access Printer; Is_Last : in Boolean := False) is pragma Warnings (Off, Is_Last); -- silence -gnatwa begin Self.Indent := Self.Indent - 1; Indent (Self); Put_Line (Self, ""); end Close_Item; procedure Other_Declaration (Self : access Printer; XRef : in AD.Crossrefs.Cross_Reference; Text : in String) is begin if XRef.Ignore then return; end if; New_Line (Self); Put (Self, "-- " & AD.HTML.HTMLize (Text) & ": "); Put_XRef (Self, "XREF", XRef); Put (Self, ""); end Other_Declaration; procedure Open_Container (Self : access Printer; XRef : in AD.Crossrefs.Cross_Reference; Kind : in Item_Kind; Name : in Wide_String := "") is begin Indent (Self); Put (Self, "= Name'First then Put (Self, " NAME=""" & Quot (ACH.To_String (Name)) & '"'); end if; if Kind /= Not_An_Item then Put (Self, " KIND=""" & To_Upper (Item_Kind'Image (Kind)) & '"'); end if; if not XRef.Ignore then declare X : AD.Crossrefs.Cross_Reference := XRef; begin X.Is_Top_Unit := False; -- We never want the IS_TOP here! Emit_XRef_Data (Self, X, True); end; end if; Put_Line (Self, ">"); Self.Indent := Self.Indent + 1; end Open_Container; procedure Close_Container (Self : access Printer; Is_Last : in Boolean := False) is pragma Warnings (Off, Is_Last); -- silence -gnatwa begin Self.Indent := Self.Indent - 1; Indent (Self); Put_Line (Self, ""); end Close_Container; procedure Add_Child (Self : access Printer; Kind : in Item_Kind; Is_Private : in Boolean; XRef : in AD.Crossrefs.Cross_Reference) is begin Indent (Self); Put (Self, "'); Put_XRef (Self, "XREF", XRef); Put_Line (Self, ""); end Add_Child; procedure Add_Exception (Self : access Printer; XRef : in AD.Crossrefs.Cross_Reference) is begin Indent (Self); Put (Self, ""); Put_XRef (Self, "ANCHOR", XRef, True); Put (Self, ""); New_Line (Self); end Add_Exception; procedure Type_Name (Self : access Printer; XRef : in AD.Crossrefs.Cross_Reference) is begin Indent (Self); Put (Self, ""); Put_XRef (Self, "XREF", XRef); Put (Self, ""); New_Line (Self); end Type_Name; procedure Type_Kind (Self : access Printer; Info : in String) is begin Indent (Self); Put_Line (Self, "" & Quot (Info) & ""); end Type_Kind; procedure Parent_Type (Self : access Printer; XRef : in AD.Crossrefs.Cross_Reference) is begin Indent (Self); Put (Self, ""); Put_XRef (Self, "XREF", XRef); Put (Self, ""); New_Line (Self); end Parent_Type; procedure Open_Operation_List (Self : access Printer; Kind : in Operation_Kind) is S : constant String := To_Upper (Operation_Kind'Image (Kind)); begin -- 'S' ends in "_Operation" Indent (Self); Put_Line (Self, ""); Self.Indent := Self.Indent + 1; end Open_Operation_List; procedure Close_Operation_List (Self : access Printer) is begin Self.Indent := Self.Indent - 1; Indent (Self); Put_Line (Self, ""); end Close_Operation_List; procedure Add_Type_Operation (Self : access Printer; XRef : in AD.Crossrefs.Cross_Reference) is begin Indent (Self); Put_XRef (Self, "XREF", XRef); New_Line (Self); end Add_Type_Operation; procedure Add_Private (Self : access Printer; For_Package : in Boolean) is pragma Warnings (Off, For_Package); -- silence -gnatwa begin Indent (Self); Put_Line (Self, ""); end Add_Private; procedure Open_Anchor (Self : access Printer; XRef : in AD.Crossrefs.Cross_Reference) is begin Put (Self, "'); end Open_Anchor; procedure Close_Anchor (Self : access Printer) is begin Put (Self, ""); end Close_Anchor; procedure Open_XRef (Self : access Printer; XRef : in AD.Crossrefs.Cross_Reference) is begin if not XRef.Ignore then Put (Self, "'); Self.No_XRef := False; else Self.No_XRef := True; end if; end Open_XRef; procedure Close_XRef (Self : access Printer) is begin if not Self.No_XRef then Put (Self, ""); end if; Self.No_XRef := False; end Close_XRef; procedure Put_XRef (Self : access Printer; XRef : in AD.Crossrefs.Cross_Reference; Code : in Boolean := True; Is_Index : in Boolean := False) is pragma Warnings (Off, Code); -- silence -gnatwa pragma Warnings (Off, Is_Index); -- silence -gnatwa begin Put_XRef (Self, "XREF", XRef); end Put_XRef; procedure Inline_Error (Self : access Printer; Msg : in String) is pragma Warnings (Off, Self); -- silence -gnatwa pragma Warnings (Off, Msg); -- silence -gnatwa begin -- Just swallow the error message. null; end Inline_Error; ---------------------------------------------------------------------------- -- Basic inline elements. procedure Write_Keyword (Self : access Printer; S : in String) is begin Put (Self, "" & Quot (S) & ""); end Write_Keyword; procedure Write_Literal (Self : access Printer; S : in String) is begin Put (Self, "" & Quot (S) & ""); end Write_Literal; procedure Write_Attribute (Self : access Printer; S : in String) is begin Put (Self, "" & Quot (S) & ""); end Write_Attribute; procedure Write_Comment (Self : access Printer; S : in String) is begin Put (Self, "" & Quot (S) & ""); end Write_Comment; procedure Write (Self : access Printer; S : in String) is begin Put (Self, Quot (S)); end Write; procedure Write_Plain (Self : access Printer; S : in String) is begin Put (Self, S); end Write_Plain; procedure Write_Code (Self : access Printer; S : in String) is begin Put (Self, "" & Quot (S) & ""); end Write_Code; ---------------------------------------------------------------------------- procedure Open_Index (Self : access Printer; File_Name : in String; Title : in String; Present : in Ada.Strings.Maps.Character_Set) is pragma Warnings (Off, Present); -- silence -gnatwa begin Indent (Self); Put_Line (Self, ""); Self.Indent := Self.Indent + 1; Self.Idx_Section_Open := False; end Open_Index; procedure Close_Index (Self : access Printer) is begin Close_Char_Section (Self); Self.Indent := Self.Indent - 1; Indent (Self); Put_Line (Self, ""); New_Line (Self); end Close_Index; procedure XRef_Index (Self : access Printer; File_Name : in String; Title : in String) is pragma Warnings (Off, Self); -- silence -gnatwa pragma Warnings (Off, File_Name); -- silence -gnatwa pragma Warnings (Off, Title); -- silence -gnatwa begin null; end XRef_Index; procedure Open_Char_Section (Self : access Printer; Char : in Character) is begin Indent (Self); Put_Line (Self, ""); Self.Indent := Self.Indent + 1; Self.Idx_Section_Open := True; end Open_Char_Section; procedure Close_Char_Section (Self : access Printer) is begin if Self.Idx_Section_Open then Self.Indent := Self.Indent - 1; Indent (Self); Put_Line (Self, ""); end if; Self.Idx_Section_Open := False; end Close_Char_Section; procedure Open_Index_Structure (Self : access Printer) is pragma Warnings (Off, Self); -- silence -gnatwa begin null; end Open_Index_Structure; procedure Close_Index_Structure (Self : access Printer) is pragma Warnings (Off, Self); -- silence -gnatwa begin null; end Close_Index_Structure; procedure Open_Index_Item (Self : access Printer) is begin Indent (Self); Put (Self, ""); end Open_Index_Item; procedure Close_Index_Item (Self : access Printer) is begin Put_Line (Self, ""); end Close_Index_Item; end AD.Printers.XML; adabrowse_4.0.3/util-files-text_io.ads0000644000175000017500000001541310234241447016107 0ustar kenken------------------------------------------------------------------------------- -- -- Copyright © 2001, 2002 by Thomas Wolf. --
    -- This piece of software is free software; you can redistribute it and/or -- modify it under the terms of the GNU General Public License as published -- by the Free Software Foundation; either version 2, or (at your option) -- any later version. This software is distributed in the hope that it will -- be useful, but without any warranty; without even the implied -- warranty of merchantability or fitness for a particular purpose. -- See the GNU General Public License for more details. You should have -- received a copy of the GNU General Public License with this distribution, -- see file "GPL.txt". If not, write to the Free -- Software Foundation, 59 Temple Place - Suite 330, Boston, MA 02111-1307, -- USA. --
    --
    -- As a special exception from the GPL, if other files instantiate generics -- from this unit, or you link this unit with other files to produce an -- executable, this unit does not by itself cause the resulting executable -- to be covered by the GPL. This exception does not however invalidate any -- other reasons why the executable file might be covered by the GPL. --
    -- -- -- Thomas Wolf (TW) -- -- -- -- General utilities on text files. -- -- -- -- -- -- -- -- 02-MAR-2002 TW Initial version. -- 24-JUN-2002 TW Changes to 'Next_Line': 'Delimiters' is now a character -- set, and you can pass a function to skip strings. -- ------------------------------------------------------------------------------- pragma License (Modified_GPL); with Ada.Text_IO; with Ada.Strings.Maps; with Util.Strings; package Util.Files.Text_IO is pragma Elaborate_Body; ---------------------------------------------------------------------------- End_Error : exception renames Ada.Text_IO.End_Error; ---------------------------------------------------------------------------- procedure Open_File (File : in out Ada.Text_IO.File_Type; Mode : in Ada.Text_IO.File_Mode; Name : in String; Form : in String := ""); -- First tries to open the file; if that fails, tries to create the file. ---------------------------------------------------------------------------- function Get_Line (File : in Ada.Text_IO.File_Type := Ada.Text_IO.Current_Input) return String; -- As @Ada.Text_IO.Get_Line@, but always returns a full line from the file. -- Raises @End_Error@ if an attempt to read beyond the end of the file is -- made. ---------------------------------------------------------------------------- function Default_Skip_String (S : in String; Delim : in Character) return Natural; -- Equivalent to Util.Strings.Skip_String (S, Delim, No_Escape). generic Suppress_Blank_Lines : in Boolean := True; White_Space : in Ada.Strings.Maps.Character_Set := Util.Strings.Blanks; Line_Continuation : in String := "\"; Comment_Start : in String := "#"; Delimiters : in Ada.Strings.Maps.Character_Set := Util.Strings.String_Quotes; with function Strings (S : in String; Delim : in Character) return Natural is Default_Skip_String; function Next_Line (File : in Ada.Text_IO.File_Type := Ada.Text_IO.Current_Input) return String; -- Returns the next line from the @File@, suppressing comments -- and blank lines and handling line continuations, if so desired. -- -- Generic Parameters: -- -- -- -- -- -- --
    -- Suppress_Blank_Lines -- If True, this function will never return blank lines or lines -- containing only a comment. If false, empty lines will be returned; -- lines containing only a comment will also be returned as empty -- lines. A blank is defined by @White_Space@. --
    -- White_Space -- Character set used to determine what is whitespace for use with -- @Suppress_Blank_Lines@ and line continuations. --
    -- Line_Continuation

    --

    A line continuation marker must be the last non-blank stuff on a -- line (except if a comment follows; in this case, blanks between -- the line continuation marker and the beginning of the comment are -- allowed (and ignored)). --

    -- If @Line_Continuation@ is the empty string, no line -- continuation handling is done, i.e. lines are never merged. --

    -- Comment_Start

    -- The text that marks the beginning of a comment. If empty, no comment -- handling is done. --

    -- A comment is always treated as a line comment, i.e. extending -- up to the end of the line. Bracketed comments like C's /* ... */ -- are not supported. --

    -- Delimiters -- Give the set of characters that shall be string delimiters. Line -- continuations and comments are valid only if not within a string. -- If @Delimiters@ is the empty set, no string parsing on the -- line occurs. --
    -- Strings

    -- Used only if @Delimiters@ is not the empty set. This function is -- called whenever an opening string delimiter is found with the rest of -- the line (including the opening delimiter) and the delimiter character. -- It shall return zero if no matching end delimiter is found, @S'First@ -- if despite everything this string delimiter is not to be considered the -- start of a string, and the index of the closing string delimiter -- otherwise. --

    --
    -- -- Line continuations must come before comments if on the same -- line; they're not allowed within comments. I.e., something like -- "xxx \ # comment" is read as "xxx " and a line continuation (hence -- the following physical line, if any, is appended automatically), -- while "xxx # comment \" is read as "xxx " only. -- -- Raises @End_Error@ if called at the end of @File@. -- If EOF is hit while skipping blank lines and comments, no -- exception is raised but an empty string is returned. A line -- continuation on the last line of the file is ignored. end Util.Files.Text_IO; adabrowse_4.0.3/ad-queries.ads0000644000175000017500000001210210234241444014405 0ustar kenken------------------------------------------------------------------------------- -- -- This file is part of AdaBrowse. -- -- Copyright (c) 2002 by Thomas Wolf. --
    -- AdaBrowse is free software; you can redistribute it and/or modify it -- under the terms of the GNU General Public License as published by the -- Free Software Foundation; either version 2, or (at your option) any -- later version. AdaBrowse is distributed in the hope that it will be -- useful, but without any warranty; without even the implied -- warranty of merchantability or fitness for a particular purpose. -- See the GNU General Public License for more details. You should have -- received a copy of the GNU General Public License with this distribution, -- see file "GPL.txt". If not, write to the Free -- Software Foundation, 59 Temple Place - Suite 330, Boston, MA 02111-1307, -- USA. --
    -- --
    -- Author:
    -- Thomas Wolf (TW) --
    twolf@acm.org
    -- --
    -- Purpose:
    -- Complex ASIS queries.
    -- -- ------------------------------------------------------------------------------- pragma License (GPL); with Asis; with AD.Messages; package AD.Queries is pragma Elaborate_Body; type Operation_Kind is (Overridden_Operation, New_Operation, Inherited_Operation, Inherited_Original_Operation); -- Semantics: -- -- Overridden_Operation: oerrides some primitive operation of the parent -- type. -- New_Operation: a new primitive operation that the parent type doesn't -- have. -- Inherited_Operation: there is no declaration for this primitive -- operation here, it is inherited from the parent. -- Inherited_Original_Operation: Ditto, and the operation has never been -- overridden in the derivation chain between it's original declaration -- and the current type. type Operation_Description is record Is_Controlling_Result : Boolean; Kind : Operation_Kind; Decl : Asis.Declaration; end record; type Operation_List is array (Positive range <>) of Operation_Description; function Primitive_Operations (The_Type : in Asis.Declaration) return Operation_List; -- 'The_Type' should be a public declaration. Returns all publicly -- visible operations of the type. The returned array starts at index 1. function Ancestor_Type (The_Type : in Asis.Declaration) return Asis.Declaration; -- Returns a Nil_Element if the type doesn't have an ancestor. function Is_Ancestor (Ancestor : in Asis.Declaration; Child : in Asis.Declaration) return Boolean; -- returns True if 'Child' is derived directly or indirectly from -- 'Ancestor'. function Is_Primitive (Decl : in Asis.Declaration; The_Type : in Asis.Declaration) return Boolean; function Get_Dependents (Unit : in Asis.Compilation_Unit) return Asis.Compilation_Unit_List; -- Returns the transitive colsure of all withs. The result contains only -- application units. function Get_Pragmas (Unit : in Asis.Compilation_Unit) return Asis.Pragma_Element_List; function Expand_Generic (Element : in Asis.Element; Reporter : access AD.Messages.Error_Reporter'Class) return Asis.Element; -- If the Element is in an implicit generic specification -- due to a generic instantiation, returns the corresponding element from -- the generic template. Otherwise, returns Element. end AD.Queries; adabrowse_4.0.3/util-files-config.ads0000644000175000017500000001360010234241447015675 0ustar kenken------------------------------------------------------------------------------- -- -- Copyright © 2001, 2002 by Thomas Wolf. --
    -- This piece of software is free software; you can redistribute it and/or -- modify it under the terms of the GNU General Public License as published -- by the Free Software Foundation; either version 2, or (at your option) -- any later version. This software is distributed in the hope that it will -- be useful, but without any warranty; without even the implied -- warranty of merchantability or fitness for a particular purpose. -- See the GNU General Public License for more details. You should have -- received a copy of the GNU General Public License with this distribution, -- see file "GPL.txt". If not, write to the Free -- Software Foundation, 59 Temple Place - Suite 330, Boston, MA 02111-1307, -- USA. --
    --
    -- As a special exception from the GPL, if other files instantiate generics -- from this unit, or you link this unit with other files to produce an -- executable, this unit does not by itself cause the resulting executable -- to be covered by the GPL. This exception does not however invalidate any -- other reasons why the executable file might be covered by the GPL. --
    -- -- -- Thomas Wolf (TW) -- -- -- -- Simple configuration reader/writer. A configuration file consists of -- lines of the format key [= value]. -- -- The file format allows for line comments (starting with '#' and -- extending up to the end of the line) and line continuations using -- the backslash notation. -- -- -- -- -- -- Dynamic storage allocation in the default pool. @Configuration@s are -- controlled types. -- -- -- -- 19-JUN-2002 TW Initial version. -- 08-JUN-2003 TW Added 'Full_Name' to 'Set_File_Name'. -- ------------------------------------------------------------------------------- pragma License (Modified_GPL); with Ada.Finalization; with Ada.Strings.Maps; package Util.Files.Config is type Reader is abstract new Ada.Finalization.Limited_Controlled with private; procedure Set_File_Name (Self : in out Reader; Name : in String; Full_Name : in String); -- Called when a file has been opened. Default does nothing. function Parse_Key (Self : in Reader; Line : in String) return Natural; -- Assuming that @Line@ starts with a valid key, parse a key and -- return the index of its last character. Return zero if no -- legal key is found. -- -- Default recognizes Identifier {"." Identifier} procedure Parse_Operator (Self : in Reader; Line : in String; From, To : out Natural); -- If an operator is found, return in @From@ and @To@ the starting -- and ending index, otherwise set @To@ to zero and -- if white space -- was skipped -- @From@ to the index one beyond the last skipped -- character. -- -- Default skips white space and then recognizes a '='. function Delimiters (Self : in Reader) return Ada.Strings.Maps.Character_Set; -- Return a set containing all legal string delimiter characters. -- Default returns @Util.Strings.String_Quotes@. function Skip_String (Self : in Reader; Line : in String; Delim : in Character) return Natural; -- Called by @Read_From_File@ if Line (Line'First) in Delimiters (Self). -- Shall return the index of the string closing character or -- @Line'First@ if strings are not to be recognized. -- -- The default uses -- Util.Strings.Skip_String (Line, Delim,Delim), i.e. handles -- enclosed delimiters as in Ada (must be doubled). procedure New_Key (Self : in out Reader; Key : in String; Operator : in String; Value : in String) is abstract; -- Called after a successful parse of a line. Note that @Operator@ and -- @Value@ may both be empty. If @New_Key@ wants to signal an error, it -- should not use @Invalid_Configuration@ but some other -- exception. (@Read@ passes on @Invalid_Configuration@ unchanged, but -- adds the file name and the offending line to the message of any -- other exception.) Invalid_Configuration : exception; procedure Read (File_Name : in String; R : in out Reader'Class); -- Read lines from the file (handling line continuations and comments) -- and parse the lines using the @Reader@. Raises @Invalid_Configuration@ -- with a descriptive message if a parse error occurs. -- -- The @Reader@ may rely on the particular sequence of parsing operations -- use by @Read@: for each line, it first calls @Parse_Key@, then -- @Parse_Operator@, and finally @New_Key@. The value of a key is the -- rest of the line beyond the operator, with leading and trailing white -- space trimmed. -- -- This routine is smart enough to handle recursive calls, where the -- @Reader@'s @New_Key@ operation calls @Read_From_File@ again. If -- a recursive inclusion of an already included file is detected, -- @Invalid_Configuration@ is raised. -- -- Warning: this recursion detection can be subverted if an original -- @Reader@'s @New_Key@ operation calls @Read_From_File@ passing another -- @Reader@! private type String_Ptr is access all String; type Files is array (Positive range <>) of String_Ptr; type Stack_Ptr is access all Files; type Reader is abstract new Ada.Finalization.Limited_Controlled with record Stack : Stack_Ptr; end record; procedure Finalize (Self : in out Reader); end Util.Files.Config; adabrowse_4.0.3/gal-storage-default.adb0000644000175000017500000000653510234241453016171 0ustar kenken------------------------------------------------------------------------------- -- -- Copyright (c) 2001, 2002 by Thomas Wolf. --
    -- This piece of software is free software; you can redistribute it and/or -- modify it under the terms of the GNU General Public License as published -- by the Free Software Foundation; either version 2, or (at your option) -- any later version. This unit is distributed in the hope that it will be -- useful, but without any warranty; without even the implied -- warranty of merchantability or fitness for a particular purpose. -- See the GNU General Public License for more details. You should have -- received a copy of the GNU General Public License with this distribution, -- see file "GPL.txt". If not, write to the Free -- Software Foundation, 59 Temple Place - Suite 330, Boston, MA 02111-1307, -- USA. --
    --
    -- As a special exception from the GPL, if other files instantiate generics -- from this unit, or you link this unit with other files to produce an -- executable, this unit does not by itself cause the resulting executable -- to be covered by the GPL. This exception does not however invalidate any -- other reasons why the executable file might be covered by the GPL. --
    -- --
    -- Author:
    -- Thomas Wolf (TW) --
    twolf@acm.org
    -- --
    -- Purpose:
    -- A default storage pool that uses the pool of an arbitrary -- access-to-integer type.
    -- --
    -- Tasking semantics:
    -- As all pools, fully task safe.
    -- --
    -- Storage semantics:
    -- It's a storage pool, so of course it does dynamic storage -- allocations and deallocations.
    -- -- ------------------------------------------------------------------------------- pragma License (Modified_GPL); package body GAL.Storage.Default is type Dummy_Pointer is access Integer; procedure Allocate (Pool : in out Manager; Storage_Address : out System.Address; Size : in System.Storage_Elements.Storage_Count; Alignment : in System.Storage_Elements.Storage_Count) is pragma Warnings (Off, Pool); -- silence -gnatwa begin System.Storage_Pools.Allocate (Dummy_Pointer'Storage_Pool, Storage_Address, Size, Alignment); end Allocate; procedure Deallocate (Pool : in out Manager; Storage_Address : in System.Address; Size : in System.Storage_Elements.Storage_Count; Alignment : in System.Storage_Elements.Storage_Count) is pragma Warnings (Off, Pool); -- silence -gnatwa begin System.Storage_Pools.Deallocate (Dummy_Pointer'Storage_Pool, Storage_Address, Size, Alignment); end Deallocate; function Storage_Size (Pool : in Manager) return System.Storage_Elements.Storage_Count is pragma Warnings (Off, Pool); -- silence -gnatwa begin return System.Storage_Pools.Storage_Size (Dummy_Pointer'Storage_Pool); end Storage_Size; end GAL.Storage.Default; adabrowse_4.0.3/sdefault.adb0000644000175000017500000000166110234241453014144 0ustar kenken-- The GNAT sources do not contain this file; it is generated -- automatically when GNAT is configured. -- -- I don't want user's of AdaBrowse to have to actually build -- GNAT to get project file support; it is sufficient that -- they have the GNAT sources. Therefore I provide this dummy -- implementation. It works fine, because AdaBrowse doesn't -- need these default locations. package body Sdefault is S1 : constant String := ""; function Include_Dir_Default_Name return String_Ptr is begin return new String'(S1); end Include_Dir_Default_Name; function Object_Dir_Default_Name return String_Ptr is begin return new String'(S1); end Object_Dir_Default_Name; function Target_Name return String_Ptr is begin return new String'(S1); end Target_Name; function Search_Dir_Prefix return String_Ptr is begin return new String'(S1); end Search_Dir_Prefix; end Sdefault; adabrowse_4.0.3/asis2-container_elements.ads0000644000175000017500000001044510234241445017254 0ustar kenken------------------------------------------------------------------------------- -- -- This unit is part of the @Asis2@ ASIS secondary library. -- -- Copyright (c) 2002, 2003 by Thomas Wolf. --
    -- AdaBrowse is free software; you can redistribute it and/or modify it -- under the terms of the GNU General Public License as published by the -- Free Software Foundation; either version 2, or (at your option) any -- later version. AdaBrowse is distributed in the hope that it will be -- useful, but without any warranty; without even the implied -- warranty of merchantability or fitness for a particular purpose. -- See the GNU General Public License for more details. You should have -- received a copy of the GNU General Public License with this distribution, -- see file "GPL.txt". If not, write to the Free -- Software Foundation, 59 Temple Place - Suite 330, Boston, MA 02111-1307, -- USA. --
    --
    -- As a special exception from the GPL, if other files instantiate generics -- from this unit, or you link this unit with other files to produce an -- executable, this unit does not by itself cause the resulting executable -- to be covered by the GPL. This exception does not however invalidate any -- other reasons why the executable file might be covered by the GPL. --
    -- -- -- Thomas Wolf (TW) -- -- -- -- Utility routines for container elements, i.e. packages and task or -- protected declarations or definitions. -- -- -- -- 04-JUN-2003 TW First release as part of @AdaBrowse@. -- 18-JUL-2003 TW Created from operations in @AD.Queries@. -- ------------------------------------------------------------------------------- pragma License (Modified_GPL); with Asis; package Asis2.Container_Elements is pragma Elaborate_Body; function Has_Private (Element : in Asis.Element) return Boolean; -- Returns @True@ if @Element@ has an explicit private part. This is a -- wrapper around @Asis.Declarations.Is_Private_Present@ and -- @Asis.Definitions.Is_Private_Present@. Returns @False@ if no explicit -- @private@ keyword is present, or the @Element@ isn't appropriate. -- -- Appropriate elements: -- -- Declaration_Kinds : -- A_Package_Declaration -- A_Generic_Package_Declaration -- A_Task_Type_Declaration -- A_Single_Task_Declaration -- A_Protected_Type_Declaration -- A_Single_Protected_Declaration -- -- Definition_Kinds : -- A_Task_Definition -- A_Protected_Definition function Visible_Items (Element : in Asis.Element; Include_Pragmas : in Boolean := False) return Asis.Declarative_Item_List; -- Returns the list of items declared in the visible part of a (generic) -- package, task (type), or protected type or object. This is a wrapper -- around @Asis.Declarations.Visible_Part_Declarative_Items@ and -- @Asis.Definitions.Visible_Part_Items@. -- -- Appropriate elements: -- -- Declaration_Kinds : -- A_Package_Declaration -- A_Generic_Package_Declaration -- A_Task_Type_Declaration -- A_Single_Task_Declaration -- A_Protected_Type_Declaration -- A_Single_Protected_Declaration -- -- Definition_Kinds : -- A_Task_Definition -- A_Protected_Definition function Private_Items (Element : in Asis.Element; Include_Pragmas : in Boolean := False) return Asis.Declarative_Item_List; -- Returns the list of items declared in the private part of a (generic) -- package, task (type), or protected type or object. This is a wrapper -- around @Asis.Declarations.Private_Part_Declarative_Items@ and -- @Asis.Definitions.Private_Part_Items@. -- -- Appropriate elements: -- -- Declaration_Kinds : -- A_Package_Declaration -- A_Generic_Package_Declaration -- A_Task_Type_Declaration -- A_Single_Task_Declaration -- A_Protected_Type_Declaration -- A_Single_Protected_Declaration -- -- Definition_Kinds : -- A_Task_Definition -- A_Protected_Definition end Asis2.Container_Elements; adabrowse_4.0.3/asis2-text.adb0000644000175000017500000000664210234241452014343 0ustar kenken------------------------------------------------------------------------------- -- -- This unit is part of the @Asis2@ ASIS secondary library. -- -- Copyright (c) 2002, 2003 by Thomas Wolf. --
    -- AdaBrowse is free software; you can redistribute it and/or modify it -- under the terms of the GNU General Public License as published by the -- Free Software Foundation; either version 2, or (at your option) any -- later version. AdaBrowse is distributed in the hope that it will be -- useful, but without any warranty; without even the implied -- warranty of merchantability or fitness for a particular purpose. -- See the GNU General Public License for more details. You should have -- received a copy of the GNU General Public License with this distribution, -- see file "GPL.txt". If not, write to the Free -- Software Foundation, 59 Temple Place - Suite 330, Boston, MA 02111-1307, -- USA. --
    --
    -- As a special exception from the GPL, if other files instantiate generics -- from this unit, or you link this unit with other files to produce an -- executable, this unit does not by itself cause the resulting executable -- to be covered by the GPL. This exception does not however invalidate any -- other reasons why the executable file might be covered by the GPL. --
    -- -- -- Thomas Wolf (TW) -- -- -- -- Commonly useful operations on @Wide_String@. -- -- -- -- 18-JUL-2003 TW Initial version. -- ------------------------------------------------------------------------------- pragma License (Modified_GPL); with Ada.Strings.Wide_Fixed; package body Asis2.Text is package ASF renames Ada.Strings.Wide_Fixed; package ASM renames Ada.Strings.Wide_Maps; package ASC renames Ada.Strings.Wide_Maps.Wide_Constants; ---------------------------------------------------------------------------- function To_Lower (Source : in Wide_String) return Wide_String is begin return ASF.Translate (Source, ASC.Lower_Case_Map); end To_Lower; function To_Upper (Source : in Wide_String) return Wide_String is begin return ASF.Translate (Source, ASC.Upper_Case_Map); end To_Upper; function To_Basic (Source : in Wide_String) return Wide_String is begin return ASF.Translate (Source, ASC.Basic_Map); end To_Basic; ---------------------------------------------------------------------------- function To_Mixed (Source : in Wide_String) return Wide_String is Result : Wide_String (1 .. Source'Length); Alpha_Num : Boolean := False; J : Natural := 1; use ASC, ASM; begin for I in Source'Range loop if not Alpha_Num then Result (J) := Value (Upper_Case_Map, Source (I)); else Result (J) := Value (Lower_Case_Map, Source (I)); end if; Alpha_Num := Is_In (Source (I), Alphanumeric_Set); J := J + 1; end loop; return Result; end To_Mixed; ---------------------------------------------------------------------------- function Trim (Source : in Wide_String) return Wide_String is begin return ASF.Trim (Source, White_Space, White_Space); end Trim; end Asis2.Text; adabrowse_4.0.3/gal.ads0000644000175000017500000000347710234241446013132 0ustar kenken------------------------------------------------------------------------------- -- -- Copyright (c) 2001, 2002 by Thomas Wolf. --
    -- AdaBrowse is free software; you can redistribute it and/or modify it -- under the terms of the GNU General Public License as published by the -- Free Software Foundation; either version 2, or (at your option) any -- later version. AdaBrowse is distributed in the hope that it will be -- useful, but without any warranty; without even the implied -- warranty of merchantability or fitness for a particular purpose. -- See the GNU General Public License for more details. You should have -- received a copy of the GNU General Public License with this distribution, -- see file "GPL.txt". If not, write to the Free -- Software Foundation, 59 Temple Place - Suite 330, Boston, MA 02111-1307, -- USA. --
    --
    -- As a special exception from the GPL, if other files instantiate generics -- from this unit, or you link this unit with other files to produce an -- executable, this unit does not by itself cause the resulting executable -- to be covered by the GPL. This exception does not however invalidate any -- other reasons why the executable file might be covered by the GPL. --
    -- --
    -- Author:
    -- Thomas Wolf (TW) --
    twolf@acm.org
    -- --
    -- Purpose:
    -- Root package of the Generic Ada Library (GAL).
    -- -- ------------------------------------------------------------------------------- pragma License (Modified_GPL); package GAL is pragma Pure; end GAL; adabrowse_4.0.3/util-calendar-io.adb0000644000175000017500000002100110234241453015454 0ustar kenken------------------------------------------------------------------------------- -- -- Copyright © 2001, 2002 by Thomas Wolf. --
    -- This piece of software is free software; you can redistribute it and/or -- modify it under the terms of the GNU General Public License as published -- by the Free Software Foundation; either version 2, or (at your option) -- any later version. This software is distributed in the hope that it will -- be useful, but without any warranty; without even the implied -- warranty of merchantability or fitness for a particular purpose. -- See the GNU General Public License for more details. You should have -- received a copy of the GNU General Public License with this distribution, -- see file "GPL.txt". If not, write to the Free -- Software Foundation, 59 Temple Place - Suite 330, Boston, MA 02111-1307, -- USA. --
    --
    -- As a special exception from the GPL, if other files instantiate generics -- from this unit, or you link this unit with other files to produce an -- executable, this unit does not by itself cause the resulting executable -- to be covered by the GPL. This exception does not however invalidate any -- other reasons why the executable file might be covered by the GPL. --
    -- -- -- Thomas Wolf (TW) -- -- -- -- Routines for converting @Ada.Calendar.Time@ values to strings. Identical -- in function to the operations in -- Util.Calendars.Western -- and Util.Times.IO. -- -- Provided nonetheless because one doesn't always want to drag in all the -- extended time and calendar support, especially for simple applications. -- -- -- -- Fully task-safe; not abortion-safe. -- -- -- -- -- -- 13-MAR-2002 TW Initial version. -- ------------------------------------------------------------------------------- pragma License (Modified_GPL); with Ada.Strings.Fixed; with Ada.Text_IO; package body Util.Calendar.IO is use Ada.Calendar; ---------------------------------------------------------------------------- -- Utility functions function Pad (Source : in String; Count : in Natural := 2; Pad : in Character := '0') return String renames Ada.Strings.Fixed.Tail; -- 'Tail' is such a misleading name: we don't want to get at source's -- tail, we want to right-align and pad it with leading zeroes! function Trim (Source : in String; Side : in Ada.Strings.Trim_End := Ada.Strings.Both) return String renames Ada.Strings.Fixed.Trim; -- Renaming to supply the 'Side' argument. ---------------------------------------------------------------------------- -- Images for type 'Day_Duration' function Image (Instant : in Ada.Calendar.Day_Duration; With_Seconds : in Boolean := True; AM_PM : in Boolean := False) return String is begin if not AM_PM then declare H : Hours_Type; M : Minutes_Type; S : Seconds_Type; F : Day_Duration; begin Split (Instant, H, M, S, F); if not With_Seconds then return Pad (Trim (Hours_Type'Image (H))) & ':' & Pad (Trim (Minutes_Type'Image (M))); else return Pad (Trim (Hours_Type'Image (H))) & ':' & Pad (Trim (Minutes_Type'Image (M))) & ':' & Pad (Trim (Seconds_Type'Image (S))); end if; end; else if Instant = 0.0 then return "Midnight"; elsif Instant = 43_200.0 then return "Noon"; end if; if Instant > 43_200.0 then if Instant >= 43_200.0 + 3_600.0 then return Image (Instant - 43_200.0, With_Seconds) & " pm"; else -- Hmmm... I believe times between noon and 13:00 are usually -- given as "12:xx pm"? return Image (Instant, With_Seconds) & " pm"; end if; else return Image (Instant, With_Seconds) & " am"; end if; end if; end Image; package DIO is new Ada.Text_IO.Fixed_IO (Day_Duration); function Image (Instant : in Ada.Calendar.Day_Duration; Precision : in Natural; AM_PM : in Boolean := False) return String is begin if not AM_PM then declare Frac : String (1 .. Day_Duration'Fore + 1 + Natural'Max (Day_Duration'Aft, Precision)); H : Hours_Type; M : Minutes_Type; S : Seconds_Type; F : Day_Duration; HH : Natural; begin Split (Instant, H, M, S, F); -- HH is *not* Hours_Type because it may overflow to 24! HH := Natural (H); -- We nicely delegate the whole rounding business to 'DIO'! DIO.Put (To => Frac, Item => F, Aft => Precision, Exp => 0); declare Fraction : constant String := Trim (Frac); begin -- Since F is always positive, Fraction now has the format -- "D.DDDDD". if Fraction (Fraction'First) = '1' or else (Precision = 0 and then F >= 0.5) then -- Propagate carry: if S = Seconds_Type'Last then if M = Minutes_Type'Last then HH := HH + 1; M := 0; else M := M + 1; end if; S := 0; else S := S + 1; end if; end if; if Precision > 0 then return Pad (Trim (Natural'Image (HH))) & ':' & Pad (Trim (Minutes_Type'Image (M))) & ':' & Pad (Trim (Seconds_Type'Image (S))) & Fraction (Fraction'First + 1 .. Fraction'Last); else return Pad (Trim (Natural'Image (HH))) & ':' & Pad (Trim (Minutes_Type'Image (M))) & ':' & Pad (Trim (Seconds_Type'Image (S))); end if; end; end; else -- AM/PM Format if Instant = 0.0 then return "Midnight"; elsif Instant = 43_200.0 then return "Noon"; end if; if Instant > 43_200.0 then -- What about times between 12:00 and 13:00 here? Rounding of -- times > 23:59:59.5 may give "12:00:00 pm", but so should -- rounding down of times between 12:00:00 and 12:00:00.5. For -- the latter case, we return "00:00:00 pm"; client code can -- check for that and change it into "12:00:00 pm" if desired. return Image (Instant - 43_200.0, Precision) & " pm"; else return Image (Instant, Precision) & " am"; end if; end if; end Image; function Image (Date : in Ada.Calendar.Time; Format : in Date_Format := YMD; Separator : in String := "-"; Padding : in Boolean := True) return String is function Canonical (Source : in String; Padding : in Boolean) return String is begin -- Canonical if Padding then return Pad (Trim (Source)); else return Trim (Source); end if; end Canonical; Y : Year_Number; M : Month_Number; D : Day_Number; S : Day_Duration; begin Split (Date, Y, M, D, S); declare YS : constant String := Trim (Year_Number'Image (Y)); MS : constant String := Canonical (Month_Number'Image (M), Padding); DS : constant String := Canonical (Day_Number'Image (D), Padding); begin case Format is when DMY => return DS & Separator & MS & Separator & YS; when MDY => return MS & Separator & DS & Separator & YS; when YMD => return YS & Separator & MS & Separator & DS; end case; end; end Image; end Util.Calendar.IO; adabrowse_4.0.3/ad-printers-html.ads0000644000175000017500000001714310234241444015552 0ustar kenken------------------------------------------------------------------------------- -- -- This file is part of AdaBrowse. -- -- Copyright (c) 2002 by Thomas Wolf. --
    -- AdaBrowse is free software; you can redistribute it and/or modify it -- under the terms of the GNU General Public License as published by the -- Free Software Foundation; either version 2, or (at your option) any -- later version. AdaBrowse is distributed in the hope that it will be -- useful, but without any warranty; without even the implied -- warranty of merchantability or fitness for a particular purpose. -- See the GNU General Public License for more details. You should have -- received a copy of the GNU General Public License with this distribution, -- see file "GPL.txt". If not, write to the Free -- Software Foundation, 59 Temple Place - Suite 330, Boston, MA 02111-1307, -- USA. --
    -- --
    -- Author:
    -- Thomas Wolf (TW) --
    twolf@acm.org
    -- --
    -- Purpose:
    -- Abstract root type for the various output producers (HTML, XML, DocBook, -- and so on).
    -- -- ------------------------------------------------------------------------------- pragma License (GPL); with Asis.Text; with AD.Crossrefs; package AD.Printers.HTML is pragma Elaborate_Body; type Printer is new AD.Printers.Printer with private; procedure Open_Unit (Self : access Printer; Unit_Kind : in Item_Kind; Unit_Name : in Wide_String; Is_Private : in Boolean; XRef : in AD.Crossrefs.Cross_Reference); procedure Close_Unit (Self : access Printer); procedure Write_Comment (Self : access Printer; Lines : in Asis.Text.Line_List); procedure Open_Section (Self : access Printer; Section : in Section_Type); procedure Close_Section (Self : access Printer; Section : in Section_Type); procedure Open_Item (Self : access Printer; XRef : in AD.Crossrefs.Cross_Reference; Kind : in Item_Kind := Not_An_Item; Name : in Wide_String := ""); procedure Close_Item (Self : access Printer; Is_Last : in Boolean := False); procedure Other_Declaration (Self : access Printer; XRef : in AD.Crossrefs.Cross_Reference; Text : in String); procedure Open_Container (Self : access Printer; XRef : in AD.Crossrefs.Cross_Reference; Kind : in Item_Kind; Name : in Wide_String := ""); procedure Close_Container (Self : access Printer; Is_Last : in Boolean := False); procedure Add_Child (Self : access Printer; Kind : in Item_Kind; Is_Private : in Boolean; XRef : in AD.Crossrefs.Cross_Reference); procedure Add_Exception (Self : access Printer; XRef : in AD.Crossrefs.Cross_Reference); procedure Type_Name (Self : access Printer; XRef : in AD.Crossrefs.Cross_Reference); procedure Type_Kind (Self : access Printer; Info : in String); procedure Parent_Type (Self : access Printer; XRef : in AD.Crossrefs.Cross_Reference); procedure Open_Operation_List (Self : access Printer; Kind : in Operation_Kind); procedure Close_Operation_List (Self : access Printer); procedure Add_Type_Operation (Self : access Printer; XRef : in AD.Crossrefs.Cross_Reference); procedure Add_Private (Self : access Printer; For_Package : in Boolean); procedure Open_Anchor (Self : access Printer; XRef : in AD.Crossrefs.Cross_Reference); procedure Close_Anchor (Self : access Printer); procedure Open_XRef (Self : access Printer; XRef : in AD.Crossrefs.Cross_Reference); procedure Close_XRef (Self : access Printer); procedure Put_XRef (Self : access Printer; XRef : in AD.Crossrefs.Cross_Reference; Code : in Boolean := True; Is_Index : in Boolean := False); -- Open_XRef, emit XRef.Image, Close_XRef. procedure Inline_Error (Self : access Printer; Msg : in String); ---------------------------------------------------------------------------- -- Basic inline elements. procedure Write_Keyword (Self : access Printer; S : in String); procedure Write_Literal (Self : access Printer; S : in String); procedure Write_Attribute (Self : access Printer; S : in String); procedure Write_Comment (Self : access Printer; S : in String); procedure Write (Self : access Printer; S : in String); procedure Write_Plain (Self : access Printer; S : in String); procedure Write_Code (Self : access Printer; S : in String); ---------------------------------------------------------------------------- procedure Open_Index (Self : access Printer; File_Name : in String; Title : in String; Present : in Ada.Strings.Maps.Character_Set); procedure Close_Index (Self : access Printer); procedure XRef_Index (Self : access Printer; File_Name : in String; Title : in String); procedure Open_Char_Section (Self : access Printer; Char : in Character); procedure Close_Char_Section (Self : access Printer); procedure Open_Index_Structure (Self : access Printer); procedure Close_Index_Structure (Self : access Printer); procedure Open_Index_Item (Self : access Printer); procedure Close_Index_Item (Self : access Printer); procedure Set_Index_XRef (Value : in String); private type Blocks is array (Natural range <>) of Boolean; type Block_Ptr is access Blocks; type Printer is new AD.Printers.Real_Printer with record Container_Level : Integer := -1; First_In_Block : Block_Ptr; Type_Has_Parent : Boolean := False; No_XRef : Boolean := False; In_Exception : Boolean := False; In_Type : Boolean := False; In_Dependencies : Boolean := False; In_Constants : Boolean := False; In_Top_Item : Boolean := False; In_Task : Boolean := False; Force_Multiline : Boolean := False; -- Index stuff : Is_Unit : Boolean := False; First_Index : Boolean := False; Index_Chars : Ada.Strings.Maps.Character_Set := Ada.Strings.Maps.Null_Set; Idx_Structures : Natural := 0; Char_Section_Open : Boolean := False; end record; function Get_Suffix (Self : in Printer) return String; procedure Finalize (Self : in out Printer); end AD.Printers.HTML; adabrowse_4.0.3/ad-driver-handled_units.adb0000644000175000017500000000505610234241447017036 0ustar kenken------------------------------------------------------------------------------- -- -- This file is part of AdaBrowse. -- -- Copyright (c) 2002 by Thomas Wolf. --
    -- AdaBrowse is free software; you can redistribute it and/or modify it -- under the terms of the GNU General Public License as published by the -- Free Software Foundation; either version 2, or (at your option) any -- later version. AdaBrowse is distributed in the hope that it will be -- useful, but without any warranty; without even the implied -- warranty of merchantability or fitness for a particular purpose. -- See the GNU General Public License for more details. You should have -- received a copy of the GNU General Public License with this distribution, -- see file "GPL.txt". If not, write to the Free -- Software Foundation, 59 Temple Place - Suite 330, Boston, MA 02111-1307, -- USA. --
    -- --
    -- Author:
    -- Thomas Wolf (TW) --
    twolf@acm.org
    -- --
    -- Purpose:
    -- Global repository of all units processed.
    -- -- ------------------------------------------------------------------------------- pragma License (GPL); with GAL.Containers.Hash_Tables; with GAL.Storage.Standard; with GAL.Support.Hashing; with Util.Strings; pragma Elaborate_All (GAL.Containers.Hash_Tables); separate (AD.Driver) package body Handled_Units is package Hashing is new GAL.Containers.Hash_Tables (Item => String, Memory => GAL.Storage.Standard, Initial_Size => 101, Hash => GAL.Support.Hashing.Hash, "=" => "="); Repository : Hashing.Hash_Table; procedure Add (Name : in String) is begin Hashing.Insert (Repository, Util.Strings.To_Lower (Name)); end Add; function Exists (Name : in String) return Boolean is begin return Hashing.Contains (Repository, Util.Strings.To_Lower (Name)); end Exists; begin Hashing.Set_Resize (Repository, 0.75); declare Linear_Growth : GAL.Support.Hashing.Linear_Growth_Policy (100); begin Hashing.Set_Growth_Policy (Repository, Linear_Growth); end; end Handled_Units; adabrowse_4.0.3/asis2-declarations.ads0000644000175000017500000000671410234241445016052 0ustar kenken------------------------------------------------------------------------------ -- -- This unit is part of the @Asis2@ ASIS secondary library. -- -- Copyright (c) 2002, 2003 by Thomas Wolf. --
    -- AdaBrowse is free software; you can redistribute it and/or modify it -- under the terms of the GNU General Public License as published by the -- Free Software Foundation; either version 2, or (at your option) any -- later version. AdaBrowse is distributed in the hope that it will be -- useful, but without any warranty; without even the implied -- warranty of merchantability or fitness for a particular purpose. -- See the GNU General Public License for more details. You should have -- received a copy of the GNU General Public License with this distribution, -- see file "GPL.txt". If not, write to the Free -- Software Foundation, 59 Temple Place - Suite 330, Boston, MA 02111-1307, -- USA. --
    --
    -- As a special exception from the GPL, if other files instantiate generics -- from this unit, or you link this unit with other files to produce an -- executable, this unit does not by itself cause the resulting executable -- to be covered by the GPL. This exception does not however invalidate any -- other reasons why the executable file might be covered by the GPL. --
    -- -- -- Thomas Wolf (TW) -- -- -- -- Utility routines operating on naming expressions and defining names. -- -- -- -- 05-JUN-2003 TW Last release as part of @AdaBrowse@. -- 18-JUL-2003 TW Created from operations in @AD.Queries@. -- ------------------------------------------------------------------------------- pragma License (Modified_GPL); with Asis; package Asis2.Declarations is function References (Expr : in Asis.Expression; Decl : in Asis.Declaration) return Boolean; -- Returns True if 'Expr' is @An_Identifier@ or @A_Selected_Component@, and -- that name refers to 'Decl'. function Name_Definition (Expr : in Asis.Expression) return Asis.Defining_Name; -- Appropriate expression kinds: -- -- All those for @Asis.Expressions.Corresponding_Name_Definition@ plus -- @A_Selected_Component@, for which it returns the name definition of -- the selector. -- -- Returns @Nil_Element@ if @Expr@ refers to more than one definition. function Name_Declaration (Expr : in Asis.Expression) return Asis.Declaration; -- Synonym to Enclosing_Declaration (Name_Definition (Expr));. function Enclosing_Declaration (Element : in Asis.Element) return Asis.Declaration; -- Returns the declaration that contains @Element@. function Real_Declaration (Decl : in Asis.Declaration) return Asis.Declaration; -- Appropriate declaration kinds: -- -- All those for @Asis.Declarations.Corresponding_Declaration@ plus -- @An_Enumeration_Literal_Specification@, for which, if the enumeration -- literal is implicitly inherited, it returns the explicit declaration -- from which the enumeration literal was inherited, if such an explicit -- declaration exists. If none exists, returns @Nil_Element@. -- -- For all other declaration kinds, identical to function -- @Asis.Declarations.Corresponding_Declaration@. end Asis2.Declarations; adabrowse_4.0.3/simple_test.cfg0000644000175000017500000000050610234241454014674 0ustar kenken# This is a configuration file for the simple tests. compile = gcc -c -gnatc -gnatt -gnatws # Tell AdaBrowse to use the style sheet distributed with AdaBrowse. style_sheet= test.css # And tell it where to find the documentation for GAL. path.gal =../../GAL/doc/rm/ #2345678901234567890123456 index_XRef = TARGET="main" adabrowse_4.0.3/gal-containers-simple.adb0000644000175000017500000001753710234241453016543 0ustar kenken------------------------------------------------------------------------------- -- -- Copyright (c) 2001-2003 by Thomas Wolf. --
    -- This piece of software is free software; you can redistribute it and/or -- modify it under the terms of the GNU General Public License as published -- by the Free Software Foundation; either version 2, or (at your option) -- any later version. This unit is distributed in the hope that it will be -- useful, but without any warranty; without even the implied -- warranty of merchantability or fitness for a particular purpose. -- See the GNU General Public License for more details. You should have -- received a copy of the GNU General Public License with this distribution, -- see file "GPL.txt". If not, write to the Free -- Software Foundation, 59 Temple Place - Suite 330, Boston, MA 02111-1307, -- USA. --
    --
    -- As a special exception from the GPL, if other files instantiate generics -- from this unit, or you link this unit with other files to produce an -- executable, this unit does not by itself cause the resulting executable -- to be covered by the GPL. This exception does not however invalidate any -- other reasons why the executable file might be covered by the GPL. --
    -- --
    -- Author:
    -- Thomas Wolf (TW) --
    twolf@acm.org
    -- --
    -- Purpose:
    -- Simple dynamic container, implemented as a very simple singly linked list. -- Only operations are adding items, sorting, and finally traversing. It's -- truly simple, but captures a very common case. --
    -- --
    -- Tasking semantics:
    -- N/A. Not abortion-safe.
    -- --
    -- Storage semantics:
    -- Dynamic storage allocation in a user-supplied storage pool.
    -- -- ------------------------------------------------------------------------------- pragma License (Modified_GPL); with Ada.Unchecked_Deallocation; with GAL.Support; with GAL.Support.List_Sort; -- generic -- type Item is private; -- -- with package Memory is new GAL.Storage.Memory (<>); -- -- with function "=" (Left, Right : in Item) return Boolean is <>; -- package body GAL.Containers.Simple is procedure Swap (Left, Right : in out Simple_Container) is procedure Exchange is new GAL.Support.Swap (Link); procedure Exchange is new GAL.Support.Swap (Natural); begin Exchange (Left.C.Anchor, Right.C.Anchor); Exchange (Left.C.Last, Right.C.Last); Exchange (Left.C.Count, Right.C.Count); end Swap; function Nof_Elements (Container : in Simple_Container) return Natural is begin return Container.C.Count; end Nof_Elements; function Is_Empty (Container : in Simple_Container) return Boolean is begin return Container.C.Last = null; end Is_Empty; procedure Add (What : in Item; To : in out True_Container) is New_Item : constant Link := new Node'(Data => What, Next => null); begin if To.Last = null then To.Anchor := New_Item; else To.Last.Next := New_Item; end if; To.Last := New_Item; To.Count := To.Count + 1; end Add; procedure Add (What : in Item; To : in out Simple_Container) is begin Add (What, To.C); end Add; procedure Reset (Container : in out True_Container) is P : Link := Container.Anchor; procedure Free is new Ada.Unchecked_Deallocation (Node, Link); begin while P /= null loop declare Q : constant Link := P.Next; begin Free (P); P := Q; end; end loop; Container.Anchor := null; Container.Last := null; Container.Count := 0; end Reset; procedure Reset (Container : in out Simple_Container) is begin Reset (Container.C); end Reset; procedure Traverse (Container : in Simple_Container; V : in out Visitor'Class) is P : Link := Container.C.Anchor; Quit : Boolean := False; begin while P /= null and then not Quit loop Execute (V, P.Data, Quit); P := P.Next; end loop; end Traverse; -- generic -- with procedure Execute -- (Value : in out Item; -- Quit : in out Boolean); procedure Traverse_G (Container : in Simple_Container) is P : Link := Container.C.Anchor; Quit : Boolean := False; begin while P /= null and then not Quit loop Execute (P.Data, Quit); P := P.Next; end loop; end Traverse_G; -- generic -- type Auxiliary (<>) is limited private; -- with procedure Execute -- (Value : in out Item; -- Data : in out Auxiliary; -- Quit : in out Boolean); procedure Traverse_Aux_G (Container : in Simple_Container; Data : in out Auxiliary) is P : Link := Container.C.Anchor; Quit : Boolean := False; begin while P /= null and then not Quit loop Execute (P.Data, Data, Quit); P := P.Next; end loop; end Traverse_Aux_G; -- generic -- with function "<" (Left, Right : in Item) return Boolean is <>; procedure Sort (Container : in out Simple_Container) is function Smaller (L, R : in Link) return Boolean; pragma Inline (Smaller); function Smaller (L, R : in Link) return Boolean is begin return L.Data < R.Data; end Smaller; function Next (L : in Link) return Link; pragma Inline (Next); function Next (L : in Link) return Link is begin return L.Next; end Next; procedure Set_Next (L, Next : in Link); pragma Inline (Set_Next); procedure Set_Next (L, Next : in Link) is begin L.Next := Next; end Set_Next; procedure Post_Process (First, Last : in out Link) is pragma Warnings (Off, First); -- silence -gnatwa pragma Warnings (Off, Last); -- silence -gnatwa begin null; end Post_Process; procedure Sort is new GAL.Support.List_Sort (Node, Link, Smaller, Next, Set_Next, Post_Process); begin Sort (Container.C.Anchor, Container.C.Last); end Sort; procedure Adjust (Container : in out True_Container) is P : Link := Container.Anchor; begin Container.Anchor := null; Container.Last := null; Container.Count := 0; while P /= null loop Add (P.Data, Container); P := P.Next; end loop; end Adjust; procedure Finalize (Container : in out True_Container) is begin Reset (Container); end Finalize; procedure Write (Stream : access Ada.Streams.Root_Stream_Type'Class; Container : in Simple_Container) is P : Link := Container.C.Anchor; begin Natural'Write (Stream, Container.C.Count); while P /= null loop Item'Write (Stream, P.Data); P := P.Next; end loop; end Write; procedure Read (Stream : access Ada.Streams.Root_Stream_Type'Class; Container : out Simple_Container) is begin Reset (Container); declare N : Natural; begin Natural'Read (Stream, N); while N > 0 loop declare Data : Item; begin Item'Read (Stream, Data); Add (Data, Container); end; N := N - 1; end loop; end; end Read; end GAL.Containers.Simple; adabrowse_4.0.3/asis2-predicates.ads0000644000175000017500000002733010234241445015522 0ustar kenken------------------------------------------------------------------------------- -- -- This unit is part of the @Asis2@ ASIS secondary library. -- -- Copyright (c) 2003 by Thomas Wolf. --
    -- AdaBrowse is free software; you can redistribute it and/or modify it -- under the terms of the GNU General Public License as published by the -- Free Software Foundation; either version 2, or (at your option) any -- later version. AdaBrowse is distributed in the hope that it will be -- useful, but without any warranty; without even the implied -- warranty of merchantability or fitness for a particular purpose. -- See the GNU General Public License for more details. You should have -- received a copy of the GNU General Public License with this distribution, -- see file "GPL.txt". If not, write to the Free -- Software Foundation, 59 Temple Place - Suite 330, Boston, MA 02111-1307, -- USA. --
    --
    -- As a special exception from the GPL, if other files instantiate generics -- from this unit, or you link this unit with other files to produce an -- executable, this unit does not by itself cause the resulting executable -- to be covered by the GPL. This exception does not however invalidate any -- other reasons why the executable file might be covered by the GPL. --
    -- -- -- Thomas Wolf (TW) -- -- -- -- Useful predicates on @Asis.Element@. All predicates return @False@ if -- called with inappropriate element kinds. -- -- Whereever the following descriptions specify "a declaration of", this -- also allows "a defining name in a declaration of". -- -- Wherever the following descriptions specify "a declaration of a type" or -- " a type declaration", this also allows "a type definition" of such a -- type. -- -- Mentions of "type" include generic formal types, "variable" includes -- generic formal "in out" objects, and so on. -- -- If @Element@ is an @Expression@, the predicates on types are also -- applicable, they refer to the type of the expression. If the @Expression@ -- is a name (identifier, operator, enumeration literal, or selected -- component), they refer to the referenced defining name. -- -- -- -- 05-JUN-2003 TW Initial version. -- 08-JUL-2003 TW Added 'Is_Package'; changed 'Unique_Name' to really -- return the fully qualified name. -- 18-JUL-2003 TW Removed the string operations, put into the @Asis2@ -- library, changed the license. -- ------------------------------------------------------------------------------- pragma License (Modified_GPL); with Asis; package Asis2.Predicates is pragma Elaborate_Body; ---------------------------------------------------------------------------- -- Units function Is_Private (Element : in Asis.Element) return Boolean; -- Returns @True@ if @Element@ is a declaration occurring in the private -- part of a (generic) package declaration, task or protected type -- declaration, or a single task or protected object declaration. Also -- returns @True@ if Is_Unit (Element) and it is a private -- library unit. function Is_Separate (Element : in Asis.Element) return Boolean; -- Returns @True@ for separate body declarations and stubs. function Is_Unit (Element : in Asis.Element) return Boolean; -- Returns @True@ if @Element@ is the declaration of a compilation unit -- (spec or body). function Is_Child (Element : in Asis.Element) return Boolean; -- Returns @True@ if Is_Unit (Element) and it is not a -- root library unit. ---------------------------------------------------------------------------- -- Items function Is_Package (Element : in Asis.Element) return Boolean; -- Returns @True@ for all kinds of package declarations. function Is_Constant (Element : in Asis.Element) return Boolean; -- Returns @True@ for constant and named number declarations. function Is_Variable (Element : in Asis.Element) return Boolean; -- Returns @True@ for variable declarations and single task or protected -- object declarations. function Is_Type (Element : in Asis.Element) return Boolean; -- Returns @True@ if @Element@ is a type declaration. function Is_Subtype (Element : in Asis.Element) return Boolean; -- Returns @True@ if @Element@ is a subtype declaration. function Is_Procedure (Element : in Asis.Element) return Boolean; function Is_Function (Element : in Asis.Element) return Boolean; function Is_Subprogram (Element : in Asis.Element) return Boolean; -- Is_Procedure (Element) or -- Is_Function (Element). function Is_Entry (Element : in Asis.Element) return Boolean; function Is_Pragma (Element : in Asis.Element) return Boolean; function Is_Clause (Element : in Asis.Element) return Boolean; ---------------------------------------------------------------------------- -- Types, Variables, and Constants. See RM 3.2 function Is_Elementary (Element : in Asis.Element) return Boolean; function Is_Scalar (Element : in Asis.Element) return Boolean; function Is_Discrete (Element : in Asis.Element) return Boolean; function Is_Enumeration (Element : in Asis.Element) return Boolean; -- Returns @True@ if @Element@ is either the declaration of an enumeration -- type or a variable declaration whose type is an enumeration type. -- Includes subtypes and derived types, also includes character and boolean -- types. function Is_Integral (Element : in Asis.Element) return Boolean; -- Returns @True@ if @Element@ is either the declaration of an integer -- type or a variable declaration whose type is an integer type. -- Includes subtypes and derived types. function Is_Signed (Element : in Asis.Element) return Boolean; function Is_Modular (Element : in Asis.Element) return Boolean; -- Returns @True@ if @Element@ is either the declaration of a modular -- type or a variable declaration whose type is a modular type. -- Includes subtypes and derived types. function Is_Real (Element : in Asis.Element) return Boolean; function Is_Float (Element : in Asis.Element) return Boolean; -- Returns @True@ if @Element@ is either the declaration of a modular -- type or a variable declaration whose type is a modular type. -- Includes subtypes and derived types. function Is_Fixed (Element : in Asis.Element) return Boolean; -- Returns @True@ if @Element@ is either the declaration of a modular -- type or a variable declaration whose type is a modular type. -- Includes subtypes and derived types. function Is_Ordinary_Fixed (Element : in Asis.Element) return Boolean; function Is_Decimal_Fixed (Element : in Asis.Element) return Boolean; function Is_Numeric (Element : in Asis.Element) return Boolean; function Is_Access (Element : in Asis.Element) return Boolean; -- Is_Access_To_Object or -- Is_Access_To_Subprogram. function Is_Access_To_Object (Element : in Asis.Element) return Boolean; -- Returns @True@ if @Element@ is either the declaration of an access -- type or a variable declaration whose type is an access type. Includes -- subtypes and derived types. function Is_Access_To_Subprogram (Element : in Asis.Element) return Boolean; -- Returns @True@ if @Element@ is either the declaration of an access -- type or a variable declaration whose type is an access type. Includes -- subtypes and derived types. function Is_Composite (Element : in Asis.Element) return Boolean; function Is_Array (Element : in Asis.Element) return Boolean; -- Returns @True@ if @Element@ is either the declaration of an array -- type or a variable declaration whose type is an array type. Includes -- subtypes and derived types. function Is_Record (Element : in Asis.Element) return Boolean; -- Returns @True@ if @Element@ is either the declaration of a record -- type or a variable declaration whose type is a record type. Includes -- subtypes and derived types. function Is_Tagged (Element : in Asis.Element) return Boolean; -- Returns @True@ if @Element@ is either the declaration of a tagged type -- or a variable declaration whose type is tagged. -- -- This includes types derived from tagged types, but not subtypes of -- tagged types! function Is_Task (Element : in Asis.Element) return Boolean; -- Returns @True@ if @Element@ is either a task type declaration, a single -- task declaration, or a defining name in a variable declaration whose -- type is a task type. Includes subtypes and derived types. function Is_Protected (Element : in Asis.Element) return Boolean; -- Returns @True@ if @Element@ is either a protected type declaration, a -- protected object declaration, or a defining name in a variable -- declaration whose type is a protected type. Includes subtypes and -- derived types. function Is_Limited (Element : in Asis.Element) return Boolean; -- Returns @True@ if @Element@ is either the declaration of a limited type -- or a variable declaration whose type is limited. Includes subtypes and -- derived types. function Is_Class_Wide (Element : in Asis.Element) return Boolean; -- Returns @True@ if @Element@ is either the declaration of a class-wide -- type or a variable declaration whose type is class-wide. Includes -- subtypes. function Is_Controlled (Element : in Asis.Element) return Boolean; -- Definition: a controlled type is a type derived from one of -- the two types declared in @Ada.Finalization@. -- -- Returns @True@ if @Element@ is either the declaration of a controlled -- type or a variable declaration whose type is controlled. Includes -- subtypes. function Is_Private_Type (Element : in Asis.Element) return Boolean; -- Returns @True@ if @Element@ is either the declaration of a private -- type or a variable declaration whose type is private. function Is_Incomplete (Element : in Asis.Element) return Boolean; -- Returns @True@ if @Element@ is the declaration of an incomplete type -- or a deferred constant. function Is_Aliased (Element : in Asis.Element) return Boolean; ---------------------------------------------------------------------------- -- Generics, renamings, and other stuff. function Is_Exception (Element : in Asis.Element) return Boolean; function Is_Renaming (Element : in Asis.Element) return Boolean; function Is_Generic (Element : in Asis.Element) return Boolean; -- Returns @True@ for generic subprogram and package declarations, their -- bodies, and generic formal types and objects. function Is_Generic_Formal (Element : in Asis.Element) return Boolean; -- Returns @True@ for all generic formals. function Is_Instance (Element : in Asis.Element) return Boolean; -- Returns @True@ for all instantiations of generic subprograms or -- packages. function Is_Abstract (Element : in Asis.Element) return Boolean; -- Returns @True@ for all abstract types and subprograms. end Asis2.Predicates; adabrowse_4.0.3/ad-printers.ads0000644000175000017500000004166110234241444014612 0ustar kenken------------------------------------------------------------------------------- -- -- This file is part of AdaBrowse. -- -- Copyright (c) 2002 by Thomas Wolf. --
    -- AdaBrowse is free software; you can redistribute it and/or modify it -- under the terms of the GNU General Public License as published by the -- Free Software Foundation; either version 2, or (at your option) any -- later version. AdaBrowse is distributed in the hope that it will be -- useful, but without any warranty; without even the implied -- warranty of merchantability or fitness for a particular purpose. -- See the GNU General Public License for more details. You should have -- received a copy of the GNU General Public License with this distribution, -- see file "GPL.txt". If not, write to the Free -- Software Foundation, 59 Temple Place - Suite 330, Boston, MA 02111-1307, -- USA. --
    -- --
    -- Author:
    -- Thomas Wolf (TW) --
    twolf@acm.org
    -- --
    -- Purpose:
    -- Abstract root type for the various output producers (HTML, XML, DocBook, -- and so on).
    -- -- ------------------------------------------------------------------------------- pragma License (GPL); with Ada.Finalization; with Ada.Strings.Maps; with Ada.Text_IO; with Ada.Unchecked_Deallocation; with Asis.Text; with Asis2.Spans; with AD.Crossrefs; with AD.Options; with Util.Text; package AD.Printers is pragma Elaborate_Body; type Item_Kind is (Not_An_Item, A_Use_Clause, A_Use_Type_Clause, A_Pragma, A_Procedure, A_Function, A_Generic_Procedure, A_Generic_Function, A_Package_Instantiation, A_Procedure_Instantiation, A_Function_Instantiation, A_Package_Renaming, A_Procedure_Renaming, A_Function_Renaming, A_Generic_Package_Renaming, A_Generic_Procedure_Renaming, A_Generic_Function_Renaming, A_Package, A_Generic_Package, A_Generic_Signature_Package, -- Generic package declarations with no visible items (except the formal -- part). A_Task_Type, A_Protected_Type, A_Task, A_Protected_Object, A_Type, A_Subtype, A_Variable, A_Constant, A_Deferred_Constant, An_Object_Renaming, An_Entry, A_Protected_Procedure, A_Protected_Function, An_Exception, An_Exception_Renaming); subtype Library_Item_Kind is Item_Kind range A_Procedure .. A_Generic_Signature_Package; subtype Container_Item_Kind is Item_Kind range A_Package .. A_Protected_Object; subtype Declaration_Item_Kind is Item_Kind range Item_Kind'Succ (A_Pragma) .. Item_Kind'Last; function Get_Item_Kind (Item : in Asis.Element) return Item_Kind; type Printer is abstract new Ada.Finalization.Limited_Controlled with null record; type Printer_Ref is access all Printer'Class; Open_Failed : exception; -- Raised by @Open_Output@ if the file could not be opened. Cannot_Overwrite : exception; -- Raised by @Open_Output@ if a file with the given already exists, but -- may not be overwritten. type Section_Type is (Dependencies_Section, Snippet_Section, Description_Section, Header_Section, Footer_Section, Content_Section, Top_Item_Section, Children_Section, Exceptions_Section, Exception_Section, Exception_Rename_Section, Ultimate_Exception_Section, Type_Summary_Section, Type_Section, Operations_Section, Constants_Section, Variables_Section, Others_Section, Index_XRef_Section); -- All sections opened and closed through simple calls. procedure Open_Unit (Self : access Printer; Unit_Kind : in Item_Kind; Unit_Name : in Wide_String; Is_Private : in Boolean; XRef : in AD.Crossrefs.Cross_Reference) is abstract; procedure Close_Unit (Self : access Printer) is abstract; procedure Write_Comment (Self : access Printer; Lines : in Asis.Text.Line_List) is abstract; procedure Open_Section (Self : access Printer; Section : in Section_Type) is abstract; procedure Close_Section (Self : access Printer; Section : in Section_Type) is abstract; procedure Open_Item (Self : access Printer; XRef : in AD.Crossrefs.Cross_Reference; Kind : in Item_Kind := Not_An_Item; Name : in Wide_String := "") is abstract; procedure Close_Item (Self : access Printer; Is_Last : in Boolean := False) is abstract; procedure Other_Declaration (Self : access Printer; XRef : in AD.Crossrefs.Cross_Reference; Text : in String) is abstract; procedure Open_Container (Self : access Printer; XRef : in AD.Crossrefs.Cross_Reference; Kind : in Item_Kind; Name : in Wide_String := "") is abstract; procedure Close_Container (Self : access Printer; Is_Last : in Boolean := False) is abstract; procedure Add_Child (Self : access Printer; Kind : in Item_Kind; Is_Private : in Boolean; XRef : in AD.Crossrefs.Cross_Reference) is abstract; procedure Add_Exception (Self : access Printer; XRef : in AD.Crossrefs.Cross_Reference) is abstract; procedure Type_Name (Self : access Printer; XRef : in AD.Crossrefs.Cross_Reference) is abstract; procedure Type_Kind (Self : access Printer; Info : in String) is abstract; procedure Parent_Type (Self : access Printer; XRef : in AD.Crossrefs.Cross_Reference) is abstract; type Operation_Kind is (Overridden_Operation, Own_Operation, Inherited_Operation, Inherited_Original_Operation); procedure Open_Operation_List (Self : access Printer; Kind : in Operation_Kind) is abstract; procedure Close_Operation_List (Self : access Printer) is abstract; procedure Add_Type_Operation (Self : access Printer; XRef : in AD.Crossrefs.Cross_Reference) is abstract; procedure Add_Private (Self : access Printer; For_Package : in Boolean) is abstract; procedure Open_Anchor (Self : access Printer; XRef : in AD.Crossrefs.Cross_Reference) is abstract; procedure Close_Anchor (Self : access Printer) is abstract; procedure Open_XRef (Self : access Printer; XRef : in AD.Crossrefs.Cross_Reference) is abstract; procedure Close_XRef (Self : access Printer) is abstract; procedure Put_XRef (Self : access Printer; XRef : in AD.Crossrefs.Cross_Reference; Code : in Boolean := True; Is_Index : in Boolean := False) is abstract; -- Open_XRef, emit XRef.Image, Close_XRef. procedure Inline_Error (Self : access Printer; Msg : in String) is abstract; ---------------------------------------------------------------------------- -- Basic inline elements. procedure Write_Keyword (Self : access Printer; S : in String) is abstract; procedure Write_Literal (Self : access Printer; S : in String) is abstract; procedure Write_Attribute (Self : access Printer; S : in String) is abstract; procedure Write_Comment (Self : access Printer; S : in String) is abstract; procedure Write (Self : access Printer; S : in String) is abstract; procedure Write_Plain (Self : access Printer; S : in String) is abstract; procedure Write_Code (Self : access Printer; S : in String) is abstract; procedure New_Line (Self : access Printer; N : in Positive := 1) is abstract; ---------------------------------------------------------------------------- -- Formatted output. procedure Dump (Self : access Printer'Class; Line : in String); ---------------------------------------------------------------------------- -- I/O management. function Is_Open (Self : in Printer) return Boolean is abstract; ---------------------------------------------------------------------------- -- Index management. procedure Open_Index (Self : access Printer; File_Name : in String; Title : in String; Present : in Ada.Strings.Maps.Character_Set) is abstract; procedure Close_Index (Self : access Printer) is abstract; procedure XRef_Index (Self : access Printer; File_Name : in String; Title : in String) is abstract; procedure Open_Char_Section (Self : access Printer; Char : in Character) is abstract; procedure Close_Char_Section (Self : access Printer) is abstract; procedure Open_Index_Structure (Self : access Printer) is abstract; procedure Close_Index_Structure (Self : access Printer) is abstract; procedure Open_Index_Item (Self : access Printer) is abstract; procedure Close_Index_Item (Self : access Printer) is abstract; ---------------------------------------------------------------------------- function "+" (Left, Right : in Printer_Ref) return Printer_Ref; -- Be careful here! You shouldn't try to use Left.all or Right.all -- directly after having called "@+@". It's only intended use is to -- facilitate composing printers in adabrowse.adb! ---------------------------------------------------------------------------- procedure Free is new Ada.Unchecked_Deallocation (Printer'Class, Printer_Ref); ---------------------------------------------------------------------------- procedure Set_Line_Only; -- Make cross-references use only the line number. private type Real_Printer is abstract new Printer with record File : aliased Ada.Text_IO.File_Type; F : Ada.Text_IO.File_Access; Buffer : Util.Text.Unbounded_String; Use_Buffer : Boolean := False; end record; function Get_Suffix (Self : in Real_Printer) return String is abstract; procedure Finalize (Self : in out Real_Printer); procedure Open_File (Self : in out Real_Printer; Mode : in AD.Options.File_Handling; File_Name : in String; Use_Default : in Boolean := True); function Is_Open (Self : in Real_Printer) return Boolean; procedure Close_File (Self : in out Real_Printer); ---------------------------------------------------------------------------- -- The following operations will write to Self.Buffer if Self.Use_Buffer -- is True; otherwise to the file Self.F.all. procedure Put (Self : access Real_Printer; S : in String); procedure Put (Self : access Real_Printer; Ch : in Character); procedure Put_Line (Self : access Real_Printer; S : in String); procedure New_Line (Self : access Real_Printer; N : in Positive := 1); procedure Put_Line (Self : in out Real_Printer; S : in String); ---------------------------------------------------------------------------- type Composer is new Printer with record Left, Right : Printer_Ref; Left_Open, Right_Open : Boolean := False; end record; procedure Finalize (Self : in out Composer); function Is_Open (Self : in Composer) return Boolean; procedure Write_Comment (Self : access Composer; Lines : in Asis.Text.Line_List); procedure Open_Unit (Self : access Composer; Unit_Kind : in Item_Kind; Unit_Name : in Wide_String; Is_Private : in Boolean; XRef : in AD.Crossrefs.Cross_Reference); procedure Close_Unit (Self : access Composer); procedure Open_Section (Self : access Composer; Section : in Section_Type); procedure Close_Section (Self : access Composer; Section : in Section_Type); procedure Open_Item (Self : access Composer; XRef : in AD.Crossrefs.Cross_Reference; Kind : in Item_Kind := Not_An_Item; Name : in Wide_String := ""); procedure Close_Item (Self : access Composer; Is_Last : in Boolean := False); procedure Other_Declaration (Self : access Composer; XRef : in AD.Crossrefs.Cross_Reference; Text : in String); procedure Open_Container (Self : access Composer; XRef : in AD.Crossrefs.Cross_Reference; Kind : in Item_Kind; Name : in Wide_String := ""); procedure Close_Container (Self : access Composer; Is_Last : in Boolean := False); procedure Add_Child (Self : access Composer; Kind : in Item_Kind; Is_Private : in Boolean; XRef : in AD.Crossrefs.Cross_Reference); procedure Add_Exception (Self : access Composer; XRef : in AD.Crossrefs.Cross_Reference); procedure Type_Name (Self : access Composer; XRef : in AD.Crossrefs.Cross_Reference); procedure Type_Kind (Self : access Composer; Info : in String); procedure Parent_Type (Self : access Composer; XRef : in AD.Crossrefs.Cross_Reference); procedure Open_Operation_List (Self : access Composer; Kind : in Operation_Kind); procedure Close_Operation_List (Self : access Composer); procedure Add_Type_Operation (Self : access Composer; XRef : in AD.Crossrefs.Cross_Reference); procedure Add_Private (Self : access Composer; For_Package : in Boolean); procedure Open_Anchor (Self : access Composer; XRef : in AD.Crossrefs.Cross_Reference); procedure Close_Anchor (Self : access Composer); procedure Open_XRef (Self : access Composer; XRef : in AD.Crossrefs.Cross_Reference); procedure Close_XRef (Self : access Composer); procedure Put_XRef (Self : access Composer; XRef : in AD.Crossrefs.Cross_Reference; Code : in Boolean := True; Is_Index : in Boolean := False); -- Open_XRef, emit XRef.Image, Close_XRef. procedure Inline_Error (Self : access Composer; Msg : in String); ---------------------------------------------------------------------------- -- Basic inline elements. procedure Write_Keyword (Self : access Composer; S : in String); procedure Write_Literal (Self : access Composer; S : in String); procedure Write_Attribute (Self : access Composer; S : in String); procedure Write_Comment (Self : access Composer; S : in String); procedure Write (Self : access Composer; S : in String); procedure Write_Plain (Self : access Composer; S : in String); procedure Write_Code (Self : access Composer; S : in String); procedure New_Line (Self : access Composer; N : in Positive := 1); ---------------------------------------------------------------------------- -- I/O management. procedure Open_Index (Self : access Composer; File_Name : in String; Title : in String; Present : in Ada.Strings.Maps.Character_Set); procedure Close_Index (Self : access Composer); procedure XRef_Index (Self : access Composer; File_Name : in String; Title : in String); procedure Open_Char_Section (Self : access Composer; Char : in Character); procedure Close_Char_Section (Self : access Composer); procedure Open_Index_Structure (Self : access Composer); procedure Close_Index_Structure (Self : access Composer); procedure Open_Index_Item (Self : access Composer); procedure Close_Index_Item (Self : access Composer); ---------------------------------------------------------------------------- Full_Crossrefs : Boolean := True; function To_String (Pos : in Asis2.Spans.Position; Full : in Boolean) return String; end AD.Printers; adabrowse_4.0.3/asis2-units.ads0000644000175000017500000000362510234241445014542 0ustar kenken------------------------------------------------------------------------------- -- -- This unit is part of the @Asis2@ ASIS secondary library. -- -- Copyright (c) 2002, 2003 by Thomas Wolf. --
    -- AdaBrowse is free software; you can redistribute it and/or modify it -- under the terms of the GNU General Public License as published by the -- Free Software Foundation; either version 2, or (at your option) any -- later version. AdaBrowse is distributed in the hope that it will be -- useful, but without any warranty; without even the implied -- warranty of merchantability or fitness for a particular purpose. -- See the GNU General Public License for more details. You should have -- received a copy of the GNU General Public License with this distribution, -- see file "GPL.txt". If not, write to the Free -- Software Foundation, 59 Temple Place - Suite 330, Boston, MA 02111-1307, -- USA. --
    --
    -- As a special exception from the GPL, if other files instantiate generics -- from this unit, or you link this unit with other files to produce an -- executable, this unit does not by itself cause the resulting executable -- to be covered by the GPL. This exception does not however invalidate any -- other reasons why the executable file might be covered by the GPL. --
    -- -- -- Thomas Wolf (TW) -- -- -- -- Utility routines operating on compilation units. -- -- -- -- 22-JUL-2003 TW Initial version. -- ------------------------------------------------------------------------------- pragma License (Modified_GPL); with Asis; package Asis2.Units is pragma Elaborate_Body; function Is_Standard (Unit : in Asis.Compilation_Unit) return Boolean; end Asis2.Units; adabrowse_4.0.3/ad-filters.ads0000644000175000017500000001670010234241442014406 0ustar kenken------------------------------------------------------------------------------- -- -- This file is part of AdaBrowse. -- -- Copyright (c) 2002 by Thomas Wolf. --
    -- AdaBrowse is free software; you can redistribute it and/or modify it -- under the terms of the GNU General Public License as published by the -- Free Software Foundation; either version 2, or (at your option) any -- later version. AdaBrowse is distributed in the hope that it will be -- useful, but without any warranty; without even the implied -- warranty of merchantability or fitness for a particular purpose. -- See the GNU General Public License for more details. You should have -- received a copy of the GNU General Public License with this distribution, -- see file "GPL.txt". If not, write to the Free -- Software Foundation, 59 Temple Place - Suite 330, Boston, MA 02111-1307, -- USA. --
    -- --
    -- Author:
    -- Thomas Wolf (TW) --
    twolf@acm.org
    -- --
    -- Purpose:
    -- Filters for formatted output of comments.
    -- -- ------------------------------------------------------------------------------- pragma License (GPL); with Ada.Unchecked_Deallocation; with Ada.Finalization; with Util.Text; package AD.Filters is pragma Elaborate_Body; ---------------------------------------------------------------------------- -- Root filter class type Filter is abstract tagged limited null record; type Filter_Ref is access all Filter'Class; procedure Transform (Self : access Filter; Text : in out Util.Text.Unbounded_String) is abstract; ---------------------------------------------------------------------------- Parse_Error : exception; -- May be raised by @Parse@ if the program is invalid. function Parse (Program : in String) return Filter_Ref; -- raises @Parse_Error@ if @Program@ has an illegal syntax. Otherwise -- returns a filter implementing the given program. ---------------------------------------------------------------------------- -- Simple filters that do not involve HTML parsing. type Filter_Pipe is new Filter with private; procedure Add_Operand (Self : access Filter_Pipe; Operand : in Filter_Ref); procedure Transform (Self : access Filter_Pipe; Text : in out Util.Text.Unbounded_String); type Filter_Entities is new Filter with null record; procedure Transform (Self : access Filter_Entities; Text : in out Util.Text.Unbounded_String); type Filter_Enclose is new Filter with private; procedure Init (Self : access Filter_Enclose; Before, After : in String); procedure Transform (Self : access Filter_Enclose; Text : in out Util.Text.Unbounded_String); type Filter_Pre is new Filter with null record; procedure Transform (Self : access Filter_Pre; Text : in out Util.Text.Unbounded_String); type Filter_Swallow is new Filter with null record; procedure Transform (Self : access Filter_Swallow; Text : in out Util.Text.Unbounded_String); type Filter_Linefeeds is (LF_Only, CR_And_LF, CR_Only, Default_LF); type Filter_Execute (Linefeed : Filter_Linefeeds) is new Filter with private; procedure Init (Self : access Filter_Execute; Cmd : in String); procedure Transform (Self : access Filter_Execute; Text : in out Util.Text.Unbounded_String); ---------------------------------------------------------------------------- -- Filters that need to parse the HTML. First tag-modifying filters: type Filter_Expand is new Filter with null record; Recursive_Expansion : exception; procedure Transform (Self : access Filter_Expand; Text : in out Util.Text.Unbounded_String); type Filter_Strip is new Filter with null record; procedure Transform (Self : access Filter_Strip; Text : in out Util.Text.Unbounded_String); type Filter_Unknown (Std_Only : Boolean) is new Filter with null record; procedure Transform (Self : access Filter_Unknown; Text : in out Util.Text.Unbounded_String); ---------------------------------------------------------------------------- -- And now content-modifying filters: type Filter_Plain is new Filter with null record; procedure Transform (Self : access Filter_Plain; Text : in out Util.Text.Unbounded_String); type Filter_Para is new Filter with null record; procedure Transform (Self : access Filter_Para; Text : in out Util.Text.Unbounded_String); type Filter_Lines is new Filter with null record; procedure Transform (Self : access Filter_Lines; Text : in out Util.Text.Unbounded_String); type Filter_Shortcut is new Filter with null record; procedure Transform (Self : access Filter_Shortcut; Text : in out Util.Text.Unbounded_String); type Filter_HR (Strip : Boolean) is new Filter with null record; procedure Transform (Self : access Filter_HR; Text : in out Util.Text.Unbounded_String); type Filter_Standard is new Filter with null record; procedure Transform (Self : access Filter_Standard; Text : in out Util.Text.Unbounded_String); -- Same as Expand | Strip | HR | Para | Shortcut | Plain procedure Free is new Ada.Unchecked_Deallocation (Filter'Class, Filter_Ref); private type Filter_Enclose is new Filter with record Before, After : Util.Text.Unbounded_String; end record; type Filter_Execute (Linefeed : Filter_Linefeeds) is new Filter with record Cmd : Util.Text.Unbounded_String; end record; type Filter_Killer (Parent : access Filter_Pipe'Class) is new Ada.Finalization.Limited_Controlled with null record; procedure Finalize (Self : in out Filter_Killer); type Operand_Table is array (Positive range <>) of Filter_Ref; type Operand_Ptr is access all Operand_Table; type Filter_Pipe is new Filter with record Killer : Filter_Killer (Filter_Pipe'Access); Operands : Operand_Ptr; end record; -- Note: I use a controlled component to avoid that all filters become -- controlled types. I fear that making type 'Filter' (limited) controlled -- may encur too large an overhead for the standard filter. end AD.Filters; adabrowse_4.0.3/util-files-text_io.adb0000644000175000017500000001602410234241453016062 0ustar kenken------------------------------------------------------------------------------- -- -- Copyright © 2001, 2002 by Thomas Wolf. --
    -- This piece of software is free software; you can redistribute it and/or -- modify it under the terms of the GNU General Public License as published -- by the Free Software Foundation; either version 2, or (at your option) -- any later version. This software is distributed in the hope that it will -- be useful, but without any warranty; without even the implied -- warranty of merchantability or fitness for a particular purpose. -- See the GNU General Public License for more details. You should have -- received a copy of the GNU General Public License with this distribution, -- see file "GPL.txt". If not, write to the Free -- Software Foundation, 59 Temple Place - Suite 330, Boston, MA 02111-1307, -- USA. --
    --
    -- As a special exception from the GPL, if other files instantiate generics -- from this unit, or you link this unit with other files to produce an -- executable, this unit does not by itself cause the resulting executable -- to be covered by the GPL. This exception does not however invalidate any -- other reasons why the executable file might be covered by the GPL. --
    -- -- -- Thomas Wolf (TW) -- -- -- -- General utilities on text files. -- -- -- -- -- -- -- -- 02-MAR-2002 TW Initial version. -- 24-APR-2002 TW Added an EOF test in 'Get_Line' to avoid problems if -- the last line of a text file is not terminated by a -- newline and has exactly i*100 characters. -- ------------------------------------------------------------------------------- pragma License (Modified_GPL); with Util.Strings; package body Util.Files.Text_IO is ---------------------------------------------------------------------------- procedure Open_File (File : in out Ada.Text_IO.File_Type; Mode : in Ada.Text_IO.File_Mode; Name : in String; Form : in String := "") is use Ada.Text_IO; procedure Open_It is new Open_G (File_Type, File_Mode, Open, Create); begin Open_It (File, Mode, Name, Form); end Open_File; ---------------------------------------------------------------------------- function Get_Line (File : in Ada.Text_IO.File_Type := Ada.Text_IO.Current_Input) return String is Buffer : String (1 .. 100); Last : Natural; begin Ada.Text_IO.Get_Line (File, Buffer, Last); if Last < Buffer'Last or else Ada.Text_IO.End_Of_File (File) then return Buffer (1 .. Last); end if; return Buffer & Get_Line (File); end Get_Line; ---------------------------------------------------------------------------- function Default_Skip_String (S : in String; Delim : in Character) return Natural is begin return Util.Strings.Skip_String (S, Delim); end Default_Skip_String; -- generic ... function Next_Line (File : in Ada.Text_IO.File_Type := Ada.Text_IO.Current_Input) return String is use Util.Strings; Comment_Start_Length : constant Natural := Comment_Start'Length; Line_Continuation_Length : constant Natural := Line_Continuation'Length; function Get_The_Line (File : in Ada.Text_IO.File_Type) return String is Line : constant String := Get_Line (File); I, J, Last : Natural; begin -- Get_The_Line if Line'Last < Line'First then return Line; end if; -- Strip off comments. Last := Line'Last; if Comment_Start_Length > 0 and then Comment_Start_Length <= Line'Length then I := Line'First; while I <= Line'Last - Comment_Start_Length + 1 loop if Is_In (Delimiters, Line (I)) then J := Strings (Line (I .. Line'Last), Line (I)); exit when J = 0; -- Unterminated string else J := I; end if; if J = I then -- Either not a string beginning, or not skipped. if Is_Prefix (Line (I .. Line'Last), Comment_Start) then Last := I - 1; exit; end if; end if; I := J + 1; end loop; if Last < Line'First then return ""; end if; end if; if Line_Continuation_Length > 0 then -- Check line continuations: I := Last; while I >= Line'First and then Is_In (White_Space, Line (I)) loop I := I - 1; end loop; -- Now I is on the last non-white-space character if I >= Line'First and then I - Line'First + 1 >= Line_Continuation_Length then if Line (I - Line_Continuation_Length + 1 .. I) = Line_Continuation then -- Now check whether we are inside a string here: J := I - Line_Continuation_Length + 1; I := Line'First; while I < J loop if Is_In (Delimiters, Line (I)) then I := Strings (Line (I .. J - 1), Line (I)); exit when I = 0; end if; I := I + 1; end loop; if I = J then -- We have a line continuation! if Ada.Text_IO.End_Of_File (File) then -- Next is EOF: stop here. return Line (Line'First .. J - 1); else return Line (Line'First .. J - 1) & Get_The_Line (File); end if; end if; end if; end if; end if; -- Sorry, this is not a line continuation! return Line (Line'First .. Last); end Get_The_Line; begin -- Next_Line if Suppress_Blank_Lines then if Ada.Text_IO.End_Of_File (File) then raise Ada.Text_IO.End_Error; end if; begin loop declare Line : constant String := Get_The_Line (File); begin if Trim (Line)'Length > 0 then return Line; end if; end; end loop; exception when Ada.Text_IO.End_Error => -- We were *not* at EOF initially, but had only blank (or -- comment) lines in the rest of the file. return ""; end; else return Get_The_Line (File); end if; end Next_Line; ---------------------------------------------------------------------------- end Util.Files.Text_IO; adabrowse_4.0.3/doc/0000755000175000017500000000000010234241455012430 5ustar kenkenadabrowse_4.0.3/doc/GPL.txt0000644000175000017500000004313110234241455013615 0ustar kenken GNU GENERAL PUBLIC LICENSE Version 2, June 1991 Copyright (C) 1989, 1991 Free Software Foundation, Inc. 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA Everyone is permitted to copy and distribute verbatim copies of this license document, but changing it is not allowed. Preamble The licenses for most software are designed to take away your freedom to share and change it. By contrast, the GNU General Public License is intended to guarantee your freedom to share and change free software--to make sure the software is free for all its users. This General Public License applies to most of the Free Software Foundation's software and to any other program whose authors commit to using it. (Some other Free Software Foundation software is covered by the GNU Library General Public License instead.) You can apply it to your programs, too. When we speak of free software, we are referring to freedom, not price. Our General Public Licenses are designed to make sure that you have the freedom to distribute copies of free software (and charge for this service if you wish), that you receive source code or can get it if you want it, that you can change the software or use pieces of it in new free programs; and that you know you can do these things. To protect your rights, we need to make restrictions that forbid anyone to deny you these rights or to ask you to surrender the rights. These restrictions translate to certain responsibilities for you if you distribute copies of the software, or if you modify it. For example, if you distribute copies of such a program, whether gratis or for a fee, you must give the recipients all the rights that you have. You must make sure that they, too, receive or can get the source code. And you must show them these terms so they know their rights. We protect your rights with two steps: (1) copyright the software, and (2) offer you this license which gives you legal permission to copy, distribute and/or modify the software. Also, for each author's protection and ours, we want to make certain that everyone understands that there is no warranty for this free software. If the software is modified by someone else and passed on, we want its recipients to know that what they have is not the original, so that any problems introduced by others will not reflect on the original authors' reputations. Finally, any free program is threatened constantly by software patents. We wish to avoid the danger that redistributors of a free program will individually obtain patent licenses, in effect making the program proprietary. To prevent this, we have made it clear that any patent must be licensed for everyone's free use or not licensed at all. The precise terms and conditions for copying, distribution and modification follow. GNU GENERAL PUBLIC LICENSE TERMS AND CONDITIONS FOR COPYING, DISTRIBUTION AND MODIFICATION 0. This License applies to any program or other work which contains a notice placed by the copyright holder saying it may be distributed under the terms of this General Public License. The "Program", below, refers to any such program or work, and a "work based on the Program" means either the Program or any derivative work under copyright law: that is to say, a work containing the Program or a portion of it, either verbatim or with modifications and/or translated into another language. (Hereinafter, translation is included without limitation in the term "modification".) Each licensee is addressed as "you". Activities other than copying, distribution and modification are not covered by this License; they are outside its scope. The act of running the Program is not restricted, and the output from the Program is covered only if its contents constitute a work based on the Program (independent of having been made by running the Program). Whether that is true depends on what the Program does. 1. You may copy and distribute verbatim copies of the Program's source code as you receive it, in any medium, provided that you conspicuously and appropriately publish on each copy an appropriate copyright notice and disclaimer of warranty; keep intact all the notices that refer to this License and to the absence of any warranty; and give any other recipients of the Program a copy of this License along with the Program. You may charge a fee for the physical act of transferring a copy, and you may at your option offer warranty protection in exchange for a fee. 2. You may modify your copy or copies of the Program or any portion of it, thus forming a work based on the Program, and copy and distribute such modifications or work under the terms of Section 1 above, provided that you also meet all of these conditions: a) You must cause the modified files to carry prominent notices stating that you changed the files and the date of any change. b) You must cause any work that you distribute or publish, that in whole or in part contains or is derived from the Program or any part thereof, to be licensed as a whole at no charge to all third parties under the terms of this License. c) If the modified program normally reads commands interactively when run, you must cause it, when started running for such interactive use in the most ordinary way, to print or display an announcement including an appropriate copyright notice and a notice that there is no warranty (or else, saying that you provide a warranty) and that users may redistribute the program under these conditions, and telling the user how to view a copy of this License. (Exception: if the Program itself is interactive but does not normally print such an announcement, your work based on the Program is not required to print an announcement.) These requirements apply to the modified work as a whole. If identifiable sections of that work are not derived from the Program, and can be reasonably considered independent and separate works in themselves, then this License, and its terms, do not apply to those sections when you distribute them as separate works. But when you distribute the same sections as part of a whole which is a work based on the Program, the distribution of the whole must be on the terms of this License, whose permissions for other licensees extend to the entire whole, and thus to each and every part regardless of who wrote it. Thus, it is not the intent of this section to claim rights or contest your rights to work written entirely by you; rather, the intent is to exercise the right to control the distribution of derivative or collective works based on the Program. In addition, mere aggregation of another work not based on the Program with the Program (or with a work based on the Program) on a volume of a storage or distribution medium does not bring the other work under the scope of this License. 3. You may copy and distribute the Program (or a work based on it, under Section 2) in object code or executable form under the terms of Sections 1 and 2 above provided that you also do one of the following: a) Accompany it with the complete corresponding machine-readable source code, which must be distributed under the terms of Sections 1 and 2 above on a medium customarily used for software interchange; or, b) Accompany it with a written offer, valid for at least three years, to give any third party, for a charge no more than your cost of physically performing source distribution, a complete machine-readable copy of the corresponding source code, to be distributed under the terms of Sections 1 and 2 above on a medium customarily used for software interchange; or, c) Accompany it with the information you received as to the offer to distribute corresponding source code. (This alternative is allowed only for noncommercial distribution and only if you received the program in object code or executable form with such an offer, in accord with Subsection b above.) The source code for a work means the preferred form of the work for making modifications to it. For an executable work, complete source code means all the source code for all modules it contains, plus any associated interface definition files, plus the scripts used to control compilation and installation of the executable. However, as a special exception, the source code distributed need not include anything that is normally distributed (in either source or binary form) with the major components (compiler, kernel, and so on) of the operating system on which the executable runs, unless that component itself accompanies the executable. If distribution of executable or object code is made by offering access to copy from a designated place, then offering equivalent access to copy the source code from the same place counts as distribution of the source code, even though third parties are not compelled to copy the source along with the object code. 4. You may not copy, modify, sublicense, or distribute the Program except as expressly provided under this License. Any attempt otherwise to copy, modify, sublicense or distribute the Program is void, and will automatically terminate your rights under this License. However, parties who have received copies, or rights, from you under this License will not have their licenses terminated so long as such parties remain in full compliance. 5. You are not required to accept this License, since you have not signed it. However, nothing else grants you permission to modify or distribute the Program or its derivative works. These actions are prohibited by law if you do not accept this License. Therefore, by modifying or distributing the Program (or any work based on the Program), you indicate your acceptance of this License to do so, and all its terms and conditions for copying, distributing or modifying the Program or works based on it. 6. Each time you redistribute the Program (or any work based on the Program), the recipient automatically receives a license from the original licensor to copy, distribute or modify the Program subject to these terms and conditions. You may not impose any further restrictions on the recipients' exercise of the rights granted herein. You are not responsible for enforcing compliance by third parties to this License. 7. If, as a consequence of a court judgment or allegation of patent infringement or for any other reason (not limited to patent issues), conditions are imposed on you (whether by court order, agreement or otherwise) that contradict the conditions of this License, they do not excuse you from the conditions of this License. If you cannot distribute so as to satisfy simultaneously your obligations under this License and any other pertinent obligations, then as a consequence you may not distribute the Program at all. For example, if a patent license would not permit royalty-free redistribution of the Program by all those who receive copies directly or indirectly through you, then the only way you could satisfy both it and this License would be to refrain entirely from distribution of the Program. If any portion of this section is held invalid or unenforceable under any particular circumstance, the balance of the section is intended to apply and the section as a whole is intended to apply in other circumstances. It is not the purpose of this section to induce you to infringe any patents or other property right claims or to contest validity of any such claims; this section has the sole purpose of protecting the integrity of the free software distribution system, which is implemented by public license practices. Many people have made generous contributions to the wide range of software distributed through that system in reliance on consistent application of that system; it is up to the author/donor to decide if he or she is willing to distribute software through any other system and a licensee cannot impose that choice. This section is intended to make thoroughly clear what is believed to be a consequence of the rest of this License. 8. If the distribution and/or use of the Program is restricted in certain countries either by patents or by copyrighted interfaces, the original copyright holder who places the Program under this License may add an explicit geographical distribution limitation excluding those countries, so that distribution is permitted only in or among countries not thus excluded. In such case, this License incorporates the limitation as if written in the body of this License. 9. The Free Software Foundation may publish revised and/or new versions of the General Public License from time to time. Such new versions will be similar in spirit to the present version, but may differ in detail to address new problems or concerns. Each version is given a distinguishing version number. If the Program specifies a version number of this License which applies to it and "any later version", you have the option of following the terms and conditions either of that version or of any later version published by the Free Software Foundation. If the Program does not specify a version number of this License, you may choose any version ever published by the Free Software Foundation. 10. If you wish to incorporate parts of the Program into other free programs whose distribution conditions are different, write to the author to ask for permission. For software which is copyrighted by the Free Software Foundation, write to the Free Software Foundation; we sometimes make exceptions for this. Our decision will be guided by the two goals of preserving the free status of all derivatives of our free software and of promoting the sharing and reuse of software generally. NO WARRANTY 11. BECAUSE THE PROGRAM IS LICENSED FREE OF CHARGE, THERE IS NO WARRANTY FOR THE PROGRAM, TO THE EXTENT PERMITTED BY APPLICABLE LAW. EXCEPT WHEN OTHERWISE STATED IN WRITING THE COPYRIGHT HOLDERS AND/OR OTHER PARTIES PROVIDE THE PROGRAM "AS IS" WITHOUT WARRANTY OF ANY KIND, EITHER EXPRESSED OR IMPLIED, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE. THE ENTIRE RISK AS TO THE QUALITY AND PERFORMANCE OF THE PROGRAM IS WITH YOU. SHOULD THE PROGRAM PROVE DEFECTIVE, YOU ASSUME THE COST OF ALL NECESSARY SERVICING, REPAIR OR CORRECTION. 12. IN NO EVENT UNLESS REQUIRED BY APPLICABLE LAW OR AGREED TO IN WRITING WILL ANY COPYRIGHT HOLDER, OR ANY OTHER PARTY WHO MAY MODIFY AND/OR REDISTRIBUTE THE PROGRAM AS PERMITTED ABOVE, BE LIABLE TO YOU FOR DAMAGES, INCLUDING ANY GENERAL, SPECIAL, INCIDENTAL OR CONSEQUENTIAL DAMAGES ARISING OUT OF THE USE OR INABILITY TO USE THE PROGRAM (INCLUDING BUT NOT LIMITED TO LOSS OF DATA OR DATA BEING RENDERED INACCURATE OR LOSSES SUSTAINED BY YOU OR THIRD PARTIES OR A FAILURE OF THE PROGRAM TO OPERATE WITH ANY OTHER PROGRAMS), EVEN IF SUCH HOLDER OR OTHER PARTY HAS BEEN ADVISED OF THE POSSIBILITY OF SUCH DAMAGES. END OF TERMS AND CONDITIONS How to Apply These Terms to Your New Programs If you develop a new program, and you want it to be of the greatest possible use to the public, the best way to achieve this is to make it free software which everyone can redistribute and change under these terms. To do so, attach the following notices to the program. It is safest to attach them to the start of each source file to most effectively convey the exclusion of warranty; and each file should have at least the "copyright" line and a pointer to where the full notice is found. Copyright (C) This program is free software; you can redistribute it and/or modify it under the terms of the GNU General Public License as published by the Free Software Foundation; either version 2 of the License, or (at your option) any later version. This program is distributed in the hope that it will be useful, but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License for more details. You should have received a copy of the GNU General Public License along with this program; if not, write to the Free Software Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA Also add information on how to contact you by electronic and paper mail. If the program is interactive, make it output a short notice like this when it starts in an interactive mode: Gnomovision version 69, Copyright (C) year name of author Gnomovision comes with ABSOLUTELY NO WARRANTY; for details type `show w'. This is free software, and you are welcome to redistribute it under certain conditions; type `show c' for details. The hypothetical commands `show w' and `show c' should show the appropriate parts of the General Public License. Of course, the commands you use may be called something other than `show w' and `show c'; they could even be mouse-clicks or menu items--whatever suits your program. You should also get your employer (if you work as a programmer) or your school, if any, to sign a "copyright disclaimer" for the program, if necessary. Here is a sample; alter the names: Yoyodyne, Inc., hereby disclaims all copyright interest in the program `Gnomovision' (which makes passes at compilers) written by James Hacker. , 1 April 1989 Ty Coon, President of Vice This General Public License does not permit incorporating your program into proprietary programs. If your program is a subroutine library, you may consider it more useful to permit linking proprietary applications with the library. If this is what you want to do, use the GNU Library General Public License instead of this License. adabrowse_4.0.3/doc/adabrowse_dtd_2_0.html0000644000175000017500000003350510234241455016566 0ustar kenken AdaBrowse DTD 2.0

    AdaBrowse DTD 2.0

    		 
    
<!--
This file is part of AdaBrowse.

Copyright © 2002-2005 by Thomas Wolf.

AdaBrowse is free software; you can redistribute it and/or modify it
under the terms of the  GNU General Public License as published by the
Free Software  Foundation; either version 2, or (at your option) any
later version. AdaBrowse is distributed in the hope that it will be
useful, but without any warranty; without even the implied warranty
of merchantability or fitness for a particular purpose. See the GNU
General Public License for  more details. You should have received a
copy of the GNU General Public License with this distribution, see file
"GPL.txt". If not, write to the

  Free Software Foundation
  59 Temple Place - Suite 330
  Boston, MA 02111-1307
  USA.

Author:
   Thomas Wolf

Purpose:
   XML 1.0 Document Type Definition for AdaBrowse XML files.

Version:
   AdaBrowse DTD 2.0 (generated by AdaBrowse V4.0).

   Earlier versions:
      AdaBrowse DTD 1.0 generated by AdaBrowse 3.0 up to 3.3.
      AdaBrowse DTD 1.1 generated by AdaBrowse 3.4 up to 3.4.2.

Revision History

   20-AUG-2002   TW  Initial version.
   28-AUG-2002   TW  Corrections in cross-references.
   30-MAY-2003   TW  Added private attributes to UNIT and CHILD elements.
   07-JUL-2003   TW  Added indices.
-->

<!ENTITY % pure   "#PCDATA|KEYWORD|ATTRIBUTE|XREF|LITERAL" >
<!ENTITY % inline "%pure;|ANCHOR|COMMENT|CODE" >

<!ENTITY % lib_no_container
   "A_PROCEDURE |
    A_FUNCTION |
    A_GENERIC_PROCEDURE |
    A_GENERIC_FUNCTION |
    A_PACKAGE_INSTANTIATION|
    A_PROCEDURE_INSTANTIATION |
    A_FUNCTION_INSTANTIATION |
    A_PACKAGE_RENAMING |
    A_PROCEDURE_RENAMING |
    A_FUNCTION_RENAMING |
    A_GENERIC_PACKAGE_RENAMING |
    A_GENERIC_PROCEDURE_RENAMING |
    A_GENERIC_FUNCTION_RENAMING" >

<!ENTITY % lib_container
   "A_PACKAGE |
    A_GENERIC_PACKAGE |
    A_GENERIC_SIGNATURE_PACKAGE" >

<!ENTITY % no_lib_no_container
   "A_PRAGMA |
    A_USE_CLAUSE |
    A_USE_TYPE_CLAUSE |
    A_TYPE |
    A_SUBTYPE |
    A_VARIABLE |
    A_CONSTANT |
    A_DEFERRED_CONSTANT |
    AN_OBJECT_RENAMING |
    AN_EXCEPTION_RENAMING |
    AN_ENTRY |
    A_PROTECTED_PROCEDURE |
    A_PROTECTED_FUNCTION |
    AN_EXCEPTION" >

<!ENTITY % no_lib_container
   "A_TASK_TYPE |
    A_PROTECTED_TYPE |
    A_TASK |
    A_PROTECTED_OBJECT" >

<!ENTITY % boolean
   "FALSE | TRUE" >

<!ENTITY % lib "%lib_no_container; | %lib_container;" >

<!ENTITY % container "%lib_container; | %no_lib_container;" >

<!ENTITY % no_container "%lib_no_container; | %no_lib_no_container; | A_TASK_TYPE | A_TASK" >
<!-- Tasks and task types can also appear as items. -->

<!-- Inline elements -->

<!ELEMENT KEYWORD (#PCDATA) >

<!ELEMENT ATTRIBUTE (#PCDATA) >

<!ELEMENT LITERAL (#PCDATA) >

<!ELEMENT CODE (%inline;)* >

<!ELEMENT XREF (#PCDATA|LITERAL|KEYWORD)* >
<!-- Actually, I'd like to specify that an XREF may contain either
     PCDATA, or a LITERAL, or a KEYWORD. It cannot contain PCDATA with
     interspersed LITERALs and KEYWORDs (which is what the above spec
     really says). However, there is *no* way in XML 1.0 to specify this!

     Literals and keywords are allowed within an XREF because of operators
     such as "&" or "or". -->

<!ATTLIST XREF
          UNIT     CDATA       #REQUIRED
          POS      CDATA       #REQUIRED
          IS_TOP   (%boolean;) "FALSE"
          IS_LOCAL (%boolean;) "FALSE">
<!-- XREFs always contain the Unit, even if the cross-reference is local.
     Local cross-references have IS_LOCAL="TRUE". Cross-references to
     other compilation UNITs have IS_TOP="TRUE". -->

<!ELEMENT ANCHOR (%pure;)* >
<!ATTLIST ANCHOR
          UNIT   CDATA       #REQUIRED
          POS    CDATA       #REQUIRED
          IS_TOP (%boolean;) "FALSE">
<!-- ANCHORs always are local, so Unit always will equal the Name of the
     enclosing compilation UNIT. It is still explicitly repeated in each
     anchor to facilitate processing: there's no need to go look up the
     enclosing UNIT's name. Is_Top is TRUE only for the anchor on that
     compilation unit's name. -->

<!-- Note: I briefly considered using attribute types ID and IDREF for
     ANCHORS and XREFs, respectively. However, that wouldn't have worked,
     for any IDREF must correspond to some ID in the XML; but our XML may
     contain references to units in other files. -->

<!ELEMENT COMMENT (%pure;|ANCHOR|CODE)* >
<!-- Comments cannot be nested -->

<!-- Block elements -->

<!ELEMENT UNIT (DEPENDENCIES?, DESCRIPTION?, (CONTAINER|ITEM)) >
<!ATTLIST UNIT
          NAME    CDATA       #REQUIRED
          KIND    (%lib;)     #REQUIRED
          PRIVATE (%boolean;) "FALSE"
          POS     CDATA       #IMPLIED>
<!-- Name and Kind of a UNIT can be used to generate indices. Pos can be
     used for cross-reference purposes; it is the position on the unit's
     CONTAINER's or ITEM's defining name. PRIVATE is "TRUE" if it's a
     private compilation unit. -->

<!ELEMENT ITEM (SNIPPET, DESCRIPTION?) >
<!ATTLIST ITEM
          NAME  CDATA            #IMPLIED
          KIND  (%no_container;) #IMPLIED
          UNIT  CDATA            #IMPLIED
          POS   CDATA            #IMPLIED>
<!-- Name and Kind of an Item can be used to generate indices.  Unit and
     Pos can be used for cross-reference purposes; it is the position on
     the item's defining name. -->

<!ELEMENT SNIPPET (LINE)+ >
<!-- Used for code snippets. Implies <CODE> -->

<!ELEMENT LINE    (%inline;)* >

<!ELEMENT DESCRIPTION (BLOCK)+ >
<!ELEMENT BLOCK       (LINE)+ >

<!ELEMENT DEPENDENCIES (SNIPPET, DESCRIPTION?) >

<!ELEMENT CONTAINER    (HEADER, CONTENT?, FOOTER) >
<!ATTLIST CONTAINER
          NAME  CDATA         #IMPLIED
          KIND  (%container;) #IMPLIED
          UNIT  CDATA         #IMPLIED
          POS   CDATA         #IMPLIED>
<!-- Name and Kind of a CONTAINER can be used to generate indices. Unit and
     Pos can be used for cross-reference purposes; it is the position on the
     container's defining name. -->

<!ELEMENT HEADER  (LINE)* >

<!ELEMENT FOOTER  (LINE)* >

<!ELEMENT CONTENT  (TOP_ITEM?, CHILDREN?, EXCEPTIONS?, TYPE_SUMMARY?,
                    CONSTANTS?, VARIABLES?, OTHERS?, PRIVATE?) >

<!ELEMENT TOP_ITEM (SNIPPET?, DESCRIPTION?) >

<!ELEMENT CHILDREN (CHILD)+ >

<!ELEMENT CHILD (#PCDATA|XREF)* >
<!-- Actually, I'd like to specify that a CHILD may contain either
     PCDATA, or an XREF. It cannot contain PCDATA with interspersed XREFs
     (which is what the above spec really says). However, there is *no* way
     in XML 1.0 to specify this! -->

<!ATTLIST CHILD
          NAME    CDATA       #IMPLIED
          KIND    (%lib;)     #IMPLIED
          PRIVATE (%boolean;) "FALSE">

<!ELEMENT PRIVATE EMPTY >

<!ELEMENT EXCEPTIONS (EXCEPTION)+ >

<!ELEMENT EXCEPTION ((EXCEPTION_NAME)+, EXCEPTION_RENAME?, ULTIMATE_EXCEPTION?, DESCRIPTION?) >

<!ELEMENT EXCEPTION_NAME (#PCDATA|ANCHOR)* >
<!-- Actually, I'd like to specify that an EXCEPTION_NAME may contain either
     PCDATA, or an ANCHOR. It cannot contain PCDATA with interspersed ANCHORDs
     (which is what the above spec really says). However, there is *no* way in
     XML 1.0 to specify this! -->

<!ELEMENT EXCEPTION_RENAME (%inline;)*>

<!ELEMENT ULTIMATE_EXCEPTION (%inline;)*>

<!ELEMENT OTHERS (CONTAINER|ITEM|PRIVATE)+ >

<!ELEMENT CONSTANTS (ITEM)+ >

<!ELEMENT VARIABLES (ITEM)+ >

<!ELEMENT TYPE_SUMMARY (TYPE)+ >

<!ELEMENT TYPE (TYPE_NAME, TYPE_KIND?, PARENT_TYPE?, OPERATIONS?) >

<!ELEMENT TYPE_NAME (#PCDATA|XREF)* >
<!-- Actually, I'd like to specify that a TYPE_NAME may contain either
     PCDATA, or an XREF. It cannot contain PCDATA with interspersed XREFs
     (which is what the above spec really says). However, there is *no* way
     in XML 1.0 to specify this! -->

<!ELEMENT TYPE_KIND (#PCDATA)>

<!ELEMENT PARENT_TYPE (#PCDATA|XREF)* >
<!-- Actually, I'd like to specify that a PARENT_TYPE may contain either
     PCDATA, or an XREF. It cannot contain PCDATA with interspersed XREFs
     (which is what the above spec really says). However, there is *no* way
     in XML 1.0 to specify this! -->

<!ELEMENT OPERATIONS (OPLIST)+ >

<!ELEMENT OPLIST (XREF)+ >
<!ATTLIST OPLIST
          KIND (OVERRIDDEN|OWN|INHERITED) #REQUIRED>

<!-- Indices. New in V2.0 -->

<!ELEMENT INDEX_ITEM (#PCDATA|XREF)* >
<!-- This time, the definition is actually correct. -->

<!ELEMENT INDEX_SECTION (INDEX_ITEM)+ >
<!ATTLIST INDEX_SECTION
          NAME  CDATA #REQUIRED>
<!-- The name is the single common starting character of all contained
     INDEX_ITEMs -->

<!ELEMENT INDEX ((INDEX_SECTION)+|(INDEX_ITEM)*) >
<!ATTLIST INDEX
          NAME  CDATA #REQUIRED
          TITLE CDATA #REQUIRED>

<!-- Document root -->

<!ELEMENT ADABROWSE ((UNIT)+, (INDEX)*) >
    Copyright © 2002-2005 by Thomas Wolf. All rights reserved.
    TW, Jul 07, 2003
    adabrowse_4.0.3/doc/adabrowse_ug.html0000644000175000017500000051306510234241455015772 0ustar kenken AdaBrowse User's Guide

    AdaBrowse User's Guide

    AdaBrowse is a HTML generator for Ada 95: it automatically generates HTML documentation from Ada 95 library unit specs, similar to what javadoc does for Java, except that AdaBrowse is much more versatile and powerful. It can even generate XML output in addition to HTML documentation.

    Copyright © 2002-2003 by Thomas Wolf <twolf@acm.org>.
    AdaBrowse is distributed under the GPL (the GNU General Public License, see "License" below).

    Contents

    1. What it does

    AdaBrowse produces a fully cross-referenced HTML rendering of Ada 95 specs (no bodies) similar to what javadoc does for Java sources. AdaBrowse is a command-line utility; it has no graphical user interface.

    AdaBrowse is highly configurable through command-line options, style sheets, and configuration files.

    AdaBrowse completely takes apart the source code and produces a HTML documentation containing:

    • All context clauses
    • Unit header
    • If the unit is a package:
      • All exceptions (including renames)
      • All constants
      • All variables
      • A type index containing all types and their primitive operations (the latter only for (tagged) record types, private types, and types derived from those). The primitive operations list is fully cross- referenced and ordered by newly defined, overridden, and inherited operations.
      • Any other items

    For each item, AdaBrowse also tries to extract comments from the source and uses them to produce a description of the item. Which comments are to be taken for which items can be configured in a configuration file.

    As of V3.0, AdaBrowse not only can generate HTML documentation, but also XML output. The XML output contains all the information contained in the HTML, including structure, indices, and cross-references.

    AdaBrowse is not a pretty-printer! Any source chunks in the generated HTML retain the formatting as in the source file (except for cross-referencing and syntax coloring). To get the best results, the source should not contain tabs. (I use an editor that de-tabs any source file when it saves it by replacing all tabs by the appropriate number of spaces.)

    AdaBrowse does a few things that could be considered some very weak form of pretty printing, though:

    1. It prints all keywords in lowercase. I chose lowercase because I felt that the combination of all uppercase and bold face in the HTML was simply too much. Lowercase letters look much better in boldface, they're not that heavy.

    2. It capitalizes all attribute defining identifiers such as "Storage_Size" in "for X'Storage_Size use ...", or "Write" in "My_Type'Write (...)".

    3. Whenever possible, it uses the defining name in place of the identifier that references it. I.e., the source

      TYPE My_Type IS NEW natural;

X : my_Type;
      is rendered in the generated HTML as

      type My_Type is new Natural;

X : My_Type;
      As a result, the generated HTML should have consistent casing of all identifiers.

    However, it does not re-indent things, and it preserves the original line breaks in source code chunks.

    BTW, AdaBrowse is called "AdaBrowse" and not "adadoc" because there was already an open-source project on SourceForge with the latter name.

    2. Version History

    The version history of AdaBrowse can be found here.

    3. How to use it

    AdaBrowse is an ASIS-based application. You need GNAT 3.15p if you intend to use the pre-built executable in the distribution! (If you have some other GNAT version >= 3.14p, you may rebuild simply from the sources as described below.)

    There are two ways to use AdaBrowse:

    1. Call AdaBrowse for your spec: adabrowse -f <filename> (and any other options as needed, in particular -I if the file is not in the current directory or depends on other units whose sources are not in the current directory!) If no tree file for the given unit exists, AdaBrowse will try to generate one.

    or

    1. Generate the tree files for the specs you want to process by calling gcc -c -gnatc -gnatt <filename> (with the appropriate -I options, if needed.)

    2. Call AdaBrowse for these specs: adabrowse -f <filename> (and any other options, as needed [look in particular at -T!]).

    AdaBrowse generates HTML files by default in the current directory.

    AdaBrowse doesn't care whether the tree files have been produced from specs or bodies: since the tree file of a body always also contains the information on the spec, it can work with either.

    4. Options

    The following options are available in AdaBrowse:

    -h, -?, -help, --help
    Writes a comprehensive help text.

    -a, -all, --all
    Optional: Generate HTML not only for the unit given in the -f option, but also for all application units on which it depends semantically (transitive closure of "with"es and parent units).

    Note that this option processes only the application units in the transitive closure even if the "-g" option is also given; it does not process any "with"ed standard library unit. This also means that if the unit given is a standard library unit, the "-all" option has no effect. This behavior is intentional: you'll normally generate HTML for the standard library once by processing all standard library units explicitly, and you don't want to re-generate HTML for these units each time one of your application unit "with"es a standard library unit.

    -c filename
    Optional: Defines a configuration file for the HTML generator. Multiple -c options may be given; the files are processed in the given order and may overwrite earlier config settings.

    -f filename
    Gives the filename (*.ads) of the spec to process. This filename may contain a path! See below for more comments. Only one -f option may be given.

    -g
    Optional: If set, AdaBrowse also generates cross-references to items from library units in the standard and run-time packages, except for items from the implict package "Standard". Note: This can also be set by a configuration file key "Refs_To_Standard". The later definition wins.

    -G output_formats
    Optional; new in V3.0: specify the output formats AdaBrowse shall generate. The "-G" option must be followed by one or more output format names, given as separate arguments. Recognized output format names are html and xml (case insensitive).

    If no "-G" option is given, AdaBrowse behaves as if "-G html" were given; i.e., by default, AdaBrowse generates only HTML output.

    -i [filename]
    Optional: If set, AdaBrowse will generate a package index if it runs in "file input mode" (see below) or the -all option is set and the output does not go to stdout.

    If a filename is given, the index is written to that file (or to stdout, if the filename is "-").

    -is [filename]
    Optional: same as -i, but generates an index using indentation for child units.

    -l
    Optional; new in V3.0: make AdaBrowse generate cross-references in HTML output using only the line number. This is what earlier versions of AdaBrowse (up to and including V2.13) always did. As of V3.0, cross-references are constructed taking into account both line and column number of an item. You should use this option only if you have HTML documentation generated by earlier AdaBrowse versions and somehow cannot re-generate that documentation. However, the recommended usage is never to use this option and to regenerate possibly already existing HTML documentation.

    Note that HTML generated with "-l" is not compatible with HTML generated without "-l"! Also, HTML generated by AdaBrowse 3.0 and beyond is compatible with HTML generated by AdaBrowse 2.13 and earlier only if the "-l" option is given.

    Usage of this option generates a warning message on stderr.

    -o filename
    Optional: Define the output file name. If not set, the output goes to a file with the name of the input and suffix ".html". If filename specifies a directory (i.e., ends in a "\" on Windows or a "/" on Unix), all generated HTML files will be put into that directory. If the filename is "-", output is written to stdout. Only one -o option may be given.

    A dash as the filename ("-") is allowed only if there is exactly one output format specified. If there are multiple output formats specified (e.g. both XML and HTML), output is not allowed to go to stdout.

    -p [filename]
    Optional: As -i, but generates a subprogram index over all units processed.

    -P filename
    Gives the filename (with or without the extension *.gpr) of the GNAT project file to process. See below for more comments. Only one -P option may be given.

    -private, --private
    Optional: if given, AdaBrowse will also process the private parts of packages and task or protected declarations. (By default, it doesn't do so but replaces the private parts by a comment saying "Implementation defined".)

    -q
    Optional: "Quiet" mode: do not issue warning or info messages. Synonym to -w0.

    -s URL
    Optional: Defines the URL to the style sheet the generated HTML file shall use. This URL should be relative to the final place where you will put the HTML files! Note that a -s option can be overwritten by a later -c option, if the configuration file defines the key "Style_Sheet".

    -t [filename]
    Optional: As -i, but generates a global type index over all units processed.

    -v, -version, --version
    Optional: Print version information of AdaBrowse to stderr.

    -wi
    Sets the warning level of AdaBrowse. i may be one of the following:
    0, or eprint only error messages.
    1, or wprint warnings and errors.
    2, or i, or aprint all messages.
    -x
    Optional: If set, AdaBrowse never overwrites existing HTML files. (May be useful in conjunction with the -a option.)

    -X name=[value]
    Optional: define an environment variable name with value value. The value supersedes any possibly already existing definition of name in the system's environment for this call to AdaBrowse. The new definition affects any configuration file processed subsequently and also the project file (if any). The name must not contain white space; if value contains white space, quote the whole definition as in -X"user=John Doe". There may or may not be white space between the "-X and the variable definition.

    -I directory
    Optional: Define source pathes for ASIS. Same semantics as for GNAT. Multiple -I options may be given.

    -T directory
    Optional: Define pathes for ASIS to search for tree files (*.adt). Multiple -T options may be given.

    There must be at least either a -f or a -P option on the command line.

    4.1. The -f option

    The -f option has three different formats:

    1. If the filename is "-" or "@-", AdaBrowse reads the unit specs of the units to process from stdin, one unit per line, until EOF is encountered. Empty lines are skipped. (If you try this interactively, you'll have to signal EOF yourself. Otherwise, this may be useful if the input comes from a pipe, like in "ls -1 *.ads | adabrowse -f- ...")

    2. If the filename starts with "@", AdaBrowse doesn't consider it a unit spec, but as the name of a text file from which to read the unit names, one unit per line. Empty lines in the file are ignored.

    3. If neither applies, AdaBrowse uses the given filename as the unit spec.

    The first two cases are called the "file input mode" of AdaBrowse. The file may contain empty lines and comments (starting with the first "#" on a line and extending up to the end of the line), which are ignored. Note that contrary to configuration files, string handling for finding comment starts is not done, and line continuations also are not allowed.

    In all three cases, a unit spec is a filename that may contain a path; a possible suffix is ignored. Note that a unit spec is a file name; in other words, you give test-gen, or test-gen.ads, and not Test.Gen. The reason is simply that for most shell scripting languages, it is easier to work with filenames than to massage them into unit names (e.g. by replacing dashes by dots). Also, if you have krunched file names, there is no simple connection between the file name and the unit name.

    If a unit spec contains a path, the HTML file for that unit is placed into that directory unless overridden by a -o option. Note that if the unit spec contains a path, you'll most probably also have to set a -T or -I option, unless you do happen to have the ASIS information available directly (i.e., a tree file for the unit in the current directory; but that's not exactly typical).

    In file input mode, the -o option (if given at all) may either be "-" (in which case all output goes to stdout) or specify a directory, but must not specify a file.

    AdaBrowse assumes a GNAT-like naming scheme for source and HTML files. It also assumes that there is one library unit per file. As of V1.4, AdaBrowse can handle krunched file names in the -f option, provided it can find a source file, and it has the extension ".ads". If so, AdaBrowse opens and parses the source file to extract the unit name, instead of deriving it directly from the file name. Note that generated files always have names based on the unit name, not the original file name: i.e., output file names will never be krunched.

    Generated HTML files always have the suffix ".html" (not ".htm").

    4.2. The Project Manager

    4.2.1 Introduction

    AdaBrowse compiled with and for GNAT with the GNAT sources available has built-in support for the GNAT project manager. The executables distributed at the original download location always come with project manager support. If you intend to build AdaBrowse from the sources, see below.

    What does "GNAT project manager support" mean? First, AdaBrowse has a "-P" command line option; its argument is a project file name. If given this option, AdaBrowse reads the project file and extracts information from it:

    • If the project file contains a variable called "ADABROWSE_TREE_DIR" and its value is a single string, AdaBrowse assumes this to be a directory specification relative to the project file's directory where to look for tree files and generate tree files in. (This variable is a work-around for the project manager not having a Tree_Dir attribute.) If there is no such variable, or if it happens to be equal to the object directory, AdaBrowse issues an error message. AdaBrowse will never use the object directory specified in the project file to avoid accidentally overwriting an existing *.ali file belonging to an object file. See below for more information.

    • If the project file contains a variable called "ADABROWSE_OUTPUT" and its value is a single string, AdaBrowse assumes this string to be a directory specification where to write the generated files to. The directory is assumed to be relative to the directory of the project file the variable is found in.

    • If the project file contains a variable called "ADABROWSE_CONFIGURATIONS", AdaBrowse assumes it to contain the file names of AdaBrowse configuration files. The value can be either a single string or a string list. Again, file names are taken to be relative to the directory the project file is in. AdaBrowse processes all the configuration files in the order given. When processing a configuration file, the current directory is set to the directory of the project file. Hence any relative file references from within a configuration file will be relative to that directory, too. If there is no such variable in the project file, the project file extended by this project (if any) is searched. (In a way, projects inherit this variable when extending.)

    • If there is no "-f" option on the command line, AdaBrowse assumes all the unit specifications of all the units in the project are to be processed.

    • When given a project file, AdaBrowse unconditionally changes the compile command used to create tree files (if needed) to "gnat compile -c -gnatc -gnatt", and passes it the project file (and any -X options), too. Thus the compiler has the environment it needs (e.g. configuration pragmas defined in a project file).

    There must be either a -f or a -P option on the command-line. You can also specify both, e.g. to process only a subset of the files in a project.

    AdaBrowse fully supports naming schemes as defined in project files.

    Hints on using GNAT, the Project Manager, and AdaBrowse

    AdaBrowse does not add a new package for itself to the project file syntax. I would have very much liked to do that; however, the other project-aware GNAT tools issue warnings for such a package. I also cannot define new attributes for the project. Hence the somewhat crude way of using special variable names. If the GNAT project manager ever changes such that it doesn't warn about unknown packages, I may change this. But until then, we'll have to live with this.

    When using the GNAT project manager for your build process and for AdaBrowse, you should be aware of the following:

    ASIS-for-GNAT has, at least up to version 3.16a, a problem if tree files have been generated with -gnatt, but without -gnatc on the command line. If it loads such tree files, or a set of such files, it may fail hard with the craziest exceptions. AdaBrowse tries to compensate for that and to give at least a descriptive error message.

    However, when using project files, this means that you cannot just add -gnatt to your Default_Switches ("ada") in the Compiler package in your project files and have everything work fine. The problem is that typically, you won't specify the -gnatc in a project file: after all, you want to build real applications! As a result, ASIS-for-GNAT and thus AdaBrowse cannot work with these tree files.

    You also don't want to recompile (for AdaBrowse) things already compiled, because you'd define the options as -gnatc -gnatt. If that happens, GNAT will overwrite possibly existing *.ali files in the project's object directory, which is probably not a good idea, given that such existing *.ali files "belong" to the object files.

    AdaBrowse therefore insists on the variable ADABROWSE_TREE_DIR being defined, and its value being different from the object directory specified in the project file. AdaBrowse then creates a temporary project file used to compile files (if necessary) with the ADABROWSE_TREE_DIR as the object directory. In this way, files created through AdaBrowse are kept separate from files created by your normal build scripts. As a side-effect, AdaBrowse will not remove *.adt files it generated (as it does normally, when not using a project file) because it considers this ADABROWSE_TREE_DIR "its own". By not deleting the tree files, they remain available for future re-use.

    4.3. Index generation

    Index generation is active when AdaBrowse is told to process several units, and the output does not go to stdout (when the -o- option has been given).

    There are several options controlling index generation:

    -i or -is
    Switches on generation of a unit index.
    -p
    Switches on generation of a subprogram index.
    -t
    Switches on generation of a type index.

    All these options take an optional filename as a parameter. If a filename follows, the index will be written to that file (or to stdout, if the filename happens to be "-"). If no filename is given, some default name is chosen.

    All these options are actually maintained only for backwards compatibility reasons. As of V4.0, indices are defined primarily through configuration file entries, not on the command line. In order not to break existing scripts using command line options of earlier AdaBrowse versions, these options are still available.

    AdaBrowse assumes it will process several units in the following cases:

    • In file input mode (-f @file_name or -f-.
    • When using a project file (-P project_file_name).
    • When the -all option is given.

    If no filename is given, or it doesn't contain a path, it depends upon the setting of other options where the index will be placed:

    • In file input mode, if a -o option is given, it must specify a directory. All HTML files, including the index, will be put into that directory.

    • If no -o option is given, but the first unit spec contains a path, the index is put into the directory designated by that path.

    • If not in file input mode, but the -all option has been given, the -o option may specify a file name. The index is put into the directory designated by the path part of that file name (the current directory, if the filename doesn't contain a path).

    • If using a project file, the indices are written into the ADABROWSE_OUTPUT directory.

    • Otherwise, this index is put in the current directory.

    If a filename containing a path is given, the index will be placed into that file in the given directory. If the filename contains only a path, AdaBrowse will use that path and create an index named "index.html" in the designated directory.

    If a -x option is given (inhibiting overwriting of existing HTML files) and a file exists already in the place where AdaBrowse wants to put the index, no index will be generated and AdaBrowse will issue a warning. It'll also warn if it cannot generate an index for any other reasons, but will otherwise continue processing.

    Note that if you give a filename to the -i option that starts with the letter "s", you must have a white space between the option and the filename, otherwise it will be recognized as a -is option. Also, if the filename starts with "-", there mustn't be any whitespace between the option and the filename, for if there is, AdaBrowse will assume the filename to be the next option and handle it as such (options all start with "-"), and not as a filename.

    The same caveat also applies to the -p option, if you want the subprogram index to go to a file named "rivate": there must be a blank, otherwise, the whole thing will be recognized as the -private option. (Admittedly this is a rather pathological case, but it's mentioned here for completeness.)

    For a full description of indices in AdaBrowse, see section 5.5, "Indexing".

    4.4. Directory and File Names

    Since V.1.1, there may or may not be white space between the -c, -f, -o, -s, -P, -I, and -T options and the filename or directory or URL.

    Unfortunately, the directories given in the -T options must not contain white space. This is due to a limitation of the ASIS-for-GNAT implementation which cannot handle that. AdaBrowse checks for that and issues an error message if the directory name does contain white space.

    In the -I option, AdaBrowse does allows white space, and it also correctly re-quotes such an argument when it passes it along to the compiler if it tries to compile a file when ASIS reports inconsistencies or cannot find a tree file. (Re-quoting means: "enclose the argument, which contains white space, by double quotes and insert a backslash before any double quote originally in the argument".)

    Hence, if the compiler can handle directory and file name arguments containing white space, everything will work ok. The only problem is that the gcc driver that comes with GNAT gets confused, so with GNAT, do not use file or directory names containing white space. (It appears that the gcc driver doesn't re-quote the arguments when it passes them along to the gnat1 executable.)

    This is not a problem with AdaBrowse, it is a problem with GNAT (and gcc). With other compilers, it might work.

    Note that -I options are only passed along to the compiler, never to ASIS.

    The filenames given in the -c and -o options may contain directory information, and they may contain blanks. These names are used only by AdaBrowse itself, and they are handled correctly.

    4.5. Option History

    The options -a, -all, --all, and -I have been introduced in V1.01.

    The options -q and -x have been introduced in V1.1.

    The file input mode, the -i and -is options, and also the possibility to give a directory to the -o option have been introduced in V1.3.

    The subprogram and type indices as well as the associated options -p and -t have been introduced in V1.5.

    The -g option, which enables cross-reference generation to items from the standard library, has been introduced in V2.11.

    The -l and -G options have been introduced in V3.0.

    The -private option has been added in V3.2.

    The -P option has been added in V4.0. The indexing options -i, -is, -p, and -t have become obsolete in V4.0; they are superseded by the new indexing mechanism (but they are still supported).

    4.6. Examples

    Some examples, all using the sample files in directory .\simple_test: (All examples assume a clean slate; if you try these one after another, be sure to remove all *.adt, *.ali, and *.html files in between! Also, all examples assume the current directory is the adabrowse directory. And finally, all these examples are for Windows NT/2k, but I think Unix-people will understand them.)

    1. Generate all tree files, then run AdaBrowse on them: 
      cd .\simple_test
for %i in (*.ads) do gcc -c -gnatc -gnatt -I.. %i
for %i in (*.adt) do ..\adabrowse -c..\simple_test.cfg -f %i
    2. Let AdaBrowse generate the tree files: 
      for %i in (.\simple_test\*.ads) do adabrowse -I.\simple_test -I. -c .\simple_test.cfg -f %i
    3. Use a directory listing: 
      dir /b .\simple_test\*.ads > simple_test.lst
adabrowse -I.\simple_test -I. -c simple_test.cfg -f @simple_test.lst
      (The dir command produces a list of filenames (without the ".\simple_test\"). The HTML files therefore end up in the directory adabrowse_1.32.)

    4. Ditto, but using the Cygwin "ls" command, and reading directly from stdin: 
      ls -1 ./simple_test/*.ads | sed -e "s@/@\\@g" | adabrowse -I.\simple_test -I. -c simple_test.cfg -f-
      (The Cygwin "ls" uses "/", not "\", and generates a listing of filenames that start with "./simple_test/". The Cygwin "sed" command then replaces all "/" by "\" in that output. The HTML files are put in directory .\simple_test.)

      Note that on Unix systems, you won't need the "sed" command: AdaBrowse uses '\' as directory separator on Windows systems, but '/' on Unix systems. (And I guess it'll use ':' on MacOS, for it just uses whatever GNAT.Os_Lib considers the directory separator.)

    5. As example 4, but we want the output in some other directory, and we want an index, too: 
      mkdir Testing
ls -1 ./simple_test/*.ads | sed -e "s@/@\\@g" | adabrowse -I.\simple_test -I. -c simple_test.cfg -f- -o .\Testing\ -i
      (The HTML files are placed in the new directory .\Testing.)

    6. As example 5, but we assume we already have all the tree files (we generate them first); the index shall be structured and be written to file "toc.html". The example assumes we still have the subdirectory .\Testing: 
      cd .\simple_test
for %i in (*.ads) do gcc -c -gnatc -gnatt -I.. %i
cd ..
ls -1 ./simple_test/*.ads | sed -e "s@/@\\@g" | adabrowse -T.\simple_test -c simple_test.cfg -f- -o .\Testing\ -is toc.html
      (The HTML files are placed in the directory .\Testing; the index is in .\Testing\toc.html. Also note that this way of using AdaBrowse is likely to be the fastest way, for all tree files already exist, and AdaBrowse can open one single ASIS context for them all. Context opening and closing is slow in ASIS-for-GNAT, and seems to incur memory leaks.)

    5. Configuration Files

    AdaBrowse is highly configurable. On the one hand, you can use style sheets to customize some presentation aspects. On the other hand, you can control directly how AdaBrowse generates HTML in the first place through configuration files. In these configuration files, you can also exclude certain units from the HTML generation process, specify URL prefixes for cross-references to certain units, and suppress cross-references to certain units.

    This section describes the syntax of configuration files and in further subsections some of the simpler entries that you can use to customize the behavior of AdaBrowse. The entries controlling the formatting of Ada comments and related issues are (because of their complexity) described in the following chapters on Descriptions, User-Defined HTML Mark-Up, Environment Variable Substitution, and Advanced Description Formatting.

    5.1. Syntax of Configuration Files

    A configuration file is a text file containing lines that are either empty (zero or more whitespace characters) or that contain a key definition of the form 

        key = value

    Key names are case insensitive, whitespace around the key and the value is ignored. If a key is not defined, AdaBrowse supplies a sensible default value. (In fact, you can run AdaBrowse without configuration files at all, and the output will be rendered reasonably by Netscape and MS IE.)

    You can use as many configuration files as you like; they are processed in the order of the corresponding -c options on the command line. In general, definitions in files processed later overwrite earlier definitions. The few exceptions from this rule are mentioned explicitly in the key descriptions below.

    Any text on a line following the first '#' that is not within a string (i.e., not within text enclosed by single (') or double quotes ("), or the backquote character (`)) up to the end of the line is taken as a comment and ignored. E.g. 

        Some_Key = hello 'world #', a nice day # and a comment

    will set Some_Key to the value "hello 'world #', a nice day". Note that the first '#' doesn't start the comment, as it is inside a string.

    If a line ends with a backslash (\), this indicates a line contuation: the next line is appended to the line containing the backslash, and the backslash itself is removed. If a line contains both a line continuation marker and a comment, the line continuation must come before the comment. E.g. 

        Compile = gcc # the compiler to use \
              -c -gnatc -gnatt

    will set the compile command to "gcc" and then issue an error message for the second line, but 

        Compile = gcc \ # The compiler to use
              -c -gnatc -gnatt

    works fine and sets the compile command to "gcc -c -gnatc -gnatt". Note that if you absolutely want to define a key whose value has to end in a backslash, you need to write a two backslashes and make sure an empty line follows, as in 

        Some_Key = something\\

    # Rest of the configuration file...

    Line continuations and trailing comments have been introduced in V 1.3.

    Important note: comments and line continuations only are effecitive outside strings. Strings in a config file are written using the Ada convention: delimiter characters embedded within the string value must be doubled. AdaBrowse allows three string delimiters: the single quote ('), the double quote ("), and the backquote (`). This is true even in places where normally other conventions apply, e.g. in commands to be run! Hence, a sed command to replace all double quotes has to be written as 

        sed -e"s/\""/\&quot;/g" ...

    in a configuration file, even though on the command line of your favorite shell, you'd just write 

        sed -e"s/\"/\&quot;/g" ...

    The above applies to configuration file parsing in general. Normally, strings will occur in a configuration file at the following places (if at all):

    • In Format keys.
    • In commands to be run (the values of User_Tag.XYZ.Execute or User_Tag.XYZ.Set keys, or in the value of a Compile key, or in an execute filter).
    • In an enclose filter.
    • In the value of Index_Title keys.
    • Anywhere you can meaningfully give some HTML tag: HTML tag attribute values may be quoted. Although in this case, the strings should not contain embedded delimiters anyway, as this would be invalid HTML.

    In the first four cases, AdaBrowse de-quotes strings by replacing any double occurrences of the delimiter character within the string by a single occurrence of that character. In the last case, it doesn't do that: you should write valid HTML tags in the first place! (If some tag attribute absolutely needs to contain a delimiting character, use a named character entity: write <SOME_TAG some_attribute="foo &quot;bar&quot;">; the HTML standard requires browsers to replace character entities in attribute values. For the single quote, the character entity is &#39;, the double quote is &quot;, and the backquote is &#96;.)

    5.2 File Inclusion

    Include_File
    New in V2.0.

    AdaBrowse includes the file given by the key's value into the current configuration file at the place the Include_File key appears. The included file also had better be a configuration file. AdaBrowse does environment variable substitution on the value first. If the value is empty, the key definition is ignored.

    Recursive inclusion is not allowed.

    5.3 Compilation

    Compile
    This key has been introduced in V1.01, and modified in V2.0.

    Defines a command to be executed if initially opening the unit through ASIS failed. If this command isn't the empty string, AdaBrowse excecutes it to try to generate the necessary info for ASIS, and then re-tries opening the given unit through ASIS.

    The default is "gcc -c -gnatc -gnatt". The command must accept GNAT-style -I options (including -I-), giving directories to search for source files. For this to work with files not in the current directory, you must also pass the appropriate -I options to AdaBrowse.

    If the command is the empty string, AdaBrowse does not try to produce ASIS-information, it just reports that it cannot handle the given unit.

    The default setting will call GNAT, and cause the creation of a tree file (*.adt) and a *.ali file in the current directory. Both files will bedeleted again by AdaBrowse once they're no longer needed.

    As of V2.0, AdaBrowse performs environment variable substitution on the value of this key.

    5.4 HTML-related

    The value of these keys is placed verbatim into the generated HTML output at predefined places.

    Char_Set
    Introduced in V1.2.

    If defined, AdaBrowse will generate a line

    <META HTTP-EQUIV="Content-Type" CONTENT="text/html; charset=value">

    in the <HEAD> section of the generated HTML file. By default, this is set to "ISO-8859-1", which is Latin-1.

    This key is also used for the index.

    Style_Sheet
    Introduced in V1.0, modified in V2.0.

    Defines a URL. If defined, AdaBrowse generates a line containing a link to the key's value in the <HEAD> section:

    <LINK REL="stylesheet" HREF="value" TYPE="text/css">

    It follows that the value should be a URL relative to the final location where you'll put the generated HTML file, which may be different from the location where you generate them!

    If the value is empty, no such link is generated.

    This key is also used for the index. AdaBrowse does environment variable substitution on the value first.

    Note that AdaBrowse put a default style sheet directly into the generated HTML files using a <STYLE> element in the <HEAD> section. Your own style sheet defined by this key or with the "-s" option on the command-line may override these default style definitions.

    Body
    Defines the <BODY> tag to use. Also used for the index.

    Title.Before, Title.After
    Define what AdaBrowse puts around the page title (not the <TITLE> entry in the <HEAD> section, but the first title in the body). Also used for the index.

    Sub_Title.Before, Sub_Title.After
    Define what AdaBrowse puts around subtitles (such as "Dependences", "Header", and so on).

    Keyword.Before, Keyword.After
    Define what AdaBrowse puts around keywords (such as "package", "type", and so on).

    Attribute.Before, Attribute.After
    Define what AdaBrowse puts around attributes (such as "'Class", "'Read", and so on).

    Definition.Before, Definition.After
    Define what AdaBrowse puts around definitions, i.e. names of an entity being declared (such as the identifier "My_Type" in "type My_Type is private;").

    Comment.Before, Comment.After
    Define what AdaBrowse puts around comments (before the opening "--" and at the end of the line) that end up in-line in the generated output.

    Literal.Before, Literal.After
    Define what AdaBrowse puts around character and string literals.

    5.5. Indexing

    As of version 4.0, AdaBrowse supports fully user-defineable indices. An index has a name (an identifier) and is defined by a file name, a title, and a rule telling adabrowse what kinds of items to include in the index.

    5.5.1. Index Definition

    Indices are defined through the Index.<Identifier> keys, where the identifier defines the index name.

    Index.<Identifier>.File_Name
    Defines the file name where the index shall be written to. A possible extension is ignored. HTML output automatically appends the extension "html", while XML output includes the index in the global file adabrowse.xml anyway. If the file name is a single dash, the index will be written to stdout. If no file name is defined, it defaults to the name of the index itself, i.e. to the Identifier.

    Index.<Identifier>.Title
    Gives the index an explicit title. AdaBrowse is smart enough to figure out meaningful titles for simple indices itself (e.g., if there are only compilation units in an index, it'll choose "Unit Index" as the default title). However, it is not smart enough to generate titles for complicated indices, say, an index of all variables and functions whose (return) type was a controlled type. If no title is given and none can be figured out, "Index" is used.

    Index.<Identifier>.Rule
    Gives a rule: a boolean expression on items that defines which items are to be included in the index. We'll discuss rules shortly.

    Index.<Identifier>.Structured
    The value of this key may be either True or False (the default). If True, which actually only makes sense if the index contains only compilation units, the index will use indentation to show parent-child relations between items.

    Index.<Identifier>.Empty
    Defines a text that AdaBrowse will write in place of a "real" index entry if the index does not contain any entries. Defaults to "Nothing.".

    AdaBrowse performs environment variable substitution on all these keys' values.

    5.5.2. Index Rules

    Rules are boolean expression built from built-in predicates, operators, and user-defined functions. AdaBrowse evaluates the rule of an index for any item it encounters and adds the item to an index only if the rule of the index evaluates to true.

    Expressions have the following syntax: 

       Expression := Expr [;].
   Expr       := OR_Term {(or|xor) OR_Term}.
   OR_Term    := AND_Term {and AND_Term}.
   AND_Term   := EQ_Term {(=|/=) EQ_Term}.
   EQ_Term    := STR_Term {@ STR_Term}.
   STR_Term   := Term {& Term}.
   Term       := [not] Factor.
   Factor     := ( Expr ) |
                 Identifier |
                 String_Literal.

    The syntax of identifiers and string literals is as in Ada. Parsing (as well as string comparisons and the @ prefix operator) is case insensitive.

    The identifier of a Factor shall resolve to either a user-defined function name (see the description of the Rule key below), or be one of the predefined predicate names.

    Note that this syntax is a bit different from the Ada one:

    • It allows mixing different logical operators. All binary operators (including the logical ones and, or, and xor) are left-associative.
    • Mixing logical operators is possible because and has higher precedence than or and xor, and because of left-associativity.

    Parentheses can be used to override the normal precedences. The equality operators = and /= can compare either two boolean expressions, or two string expressions. String comparisons are case insensitive. The & is the string concatenation operator. The @ binary operator takes two string arguments and returns a boolean value; it is True if the right argument is a prefix of the left one.

    An expression may or may not have a terminating semicolon.

    Example: 

          A and B or C = D and E = F & G = H

    is the same as 

          (A and B) or ((C = D) and ((E = (F & G)) = H))

    5.5.3. Predefined Predicates

    AdaBrowse comes with a large set of predefined predicates. They can be classified in general predicates useful for determining the broad class of an item, plus type predicates that return True for particular classes of types. Finally, there are two built-in function for getting the name of an item, and the boolean constants.

    General predicates:

    child
    Is True for all child units.
    constant
    Is True for all constants and named numbers.
    entry
    Is True for all entry declarations (of both tasks and protected types or objects).
    exception
    Is True for all exception declarations (including renamings).
    function
    Is True for all function declarations (including protected functions and renamings, instantiations, and generic declarations).
    generic
    Is True for all generic declarations.
    instance
    Is True for all instantiations of generics.
    package
    Is True for all packages, including generics, renamings, and instantiations).
    pragma
    Is True for all pragmas.
    private
    Is True for all items declared in the private part of the enclosing package, task, or protected type (or object).
    procedure
    Is True for all procedure declarations (including protected procedures and renamings, instantiations, and generic declarations).
    representation
    Is True for all representation clauses.
    separate
    Is True for all separate items. Note that AdaBrowse will never encounter a separate item because it only processes unit specs!
    subprogram
    Equivalent to the expression function or procedure.
    subtype
    Is True for all subtype declarations.
    type
    Is True for all type declarations (but not subtype declarations!).
    unit
    Is True for all compilation units.
    variable
    Is True for all object declarations (variables, but also single task and protected obejct declarations).

    Predicates on types: these apply to type (and subtype) declarations, object declarations (where they work on the type of the object), and to functions (applying to the return type). These predicates basically mirror the type classes of Ada as shown in the refernce manual; see RM 3.2(12). However, there are a few extra predicates, such as class_wide or controlled. (The order given here also follows RM 3.2(12), with the extra predicates at the end.)

    elementary
    Is True for all elementary types.
    scalar
    Is True for all scalar types.
    discrete
    Is True for all discrete types.
    enum
    Is True for all enumeration types.
    integral
    Is True for all integral types.
    signed
    Is True for all signed integer types.
    modular
    Is True for all modular types.
    real
    Is True for all real types.
    float
    Is True for all floating-point types.
    fixed
    Is True for all fixed-point types.
    ordinary_fixed
    Is True for all ordinary fixed-point types.
    decimal_fixed
    Is True for all decimal fixed-point types.
    numeric
    Is True for all numeric types. Equivalent to the expression integral or real.
    access
    Is True for all access types.
    access_object
    Is True for all access-to-object types.
    access_subprogram
    Is True for all access-to-subprogram types.

    composite
    Is True for all composite types.
    array
    Is True for all array types (both constrained and unconstrained).
    record
    Is True for all record types.
    tagged
    Is True for all tagged record types.
    limited
    Is True for all limited types, including task and protected types.
    controlled
    Is True for all controlled types, i.e. types derived from one of the two types declared in package Ada.Finalization.
    class_wide
    Is True for all class-wide types.
    private_type
    Is True for all private types, including private extension declarations.
    protected
    Is True for all protected objects and types, but also for all declarations within.
    task
    Is True for all single tasks and task types, but also for entry declarations in tasks.

    Miscellaneous predicates:

    abstract
    Is True for all abstract types and subprograms.
    aliased
    Is True for all aliased objects.
    formal
    Is True for all generic formal declarations.
    incomplete
    Is True for all incomplete types and for deferred constant declarations.

    Constants:

    false
    Is always False.
    true
    Is (guess what?) always True.

    Built-in functions returning strings:

    name
    Returns the simple name of the item as a string.
    full_name
    Returns the fully qualified name of the item as a string.

    Note that elementary /= not composite: there are types that are neither elementary nor composite, such as private types.

    5.5.4. User-Defined Functions

    Besides these built-in predicates, you can also define your own rule functions with the Rule key:

    Rule.<Identifier>
    Defines a named function. Wherever this name appears in a subsequent expression, it is replaced by the defining expression. (In this sense, the name "function" is actually wrong; it's more like a macro.)

    Example: Rule.entries_of_tasks = entry and not protected

    5.5.5. Index Keys and Index Options

    Versions of AdaBrowse prior to V4.0 only had the command line options (plus the few obsolete keys mentioned below) to define indices. These options still exist, they are now defined in terms of the new indexing keys:

    -i [file_name] or -is [file_name]
    Defines a unit index named "Units". Equivalent to the index keys 
      Index.Units.File_Name  = index (default) or file_name
  Index.Units.Title      = Unit Index
  Index.Units.Rule       = unit
    If the option -is is used, an additional key 
      Index.Units.Structured = True
    is also defined.

    -p [file_name]
    Defines a subprogram index named "Subprograms". Equivalent to the index keys 
      Index.Subprograms.File_Name = procidx (default) or file_name
  Index.Subprograms.Title     = Subprogram Index
  Index.Subprograms.Rule      = subprogram and not protected
    -t [file_name]
    Defines a type index named "Types". Equivalent to the index keys 
      Index.Types.File_Name = typeidx (default) or file_name
  Index.Types.Title     = Type Index
  Index.Types.Rule      = type or subtype

    The command line options can coexist with the new Index keys, and it is possible to redefine in a configuration file the indices defined by the command line options.

    5.5.6. An Example

    In this example, we'll define an index of exceptions, but only those declared in public parts and that are not renamings. 
      Index.My_Exceptions.File_Name = ex_idx
  Index.My_Exceptions.Title     = Public Exceptions
  Index.My_Exceptions.Rule      = exception and not (private or renaming);

    5.5.7. Other Indexing Keys

    The following key has been carried over from earlier AdaBrowse versions. It allows the user to define special cross-reference formats for indices in HTML.

    Index_XRef
    Defines a portion of a <A HREF=""> tag to be used when AdaBrowse generates an index. AdaBrowse generates <A HREF="somewhere.html" then inserts the value, and then emits a single ">".

    This is useful if the index is finally to be used within a web page containing frames. For instance, with the definition

    Index_XRef = TARGET="main"

    AdaBrowse will generate cross references in the index that look like

    <A HREF="somepackage.html" TARGET="main">SomePackage</A>

    The default value of this key is the empty string.

    This key is used for all indices, but only for HTML output.

    The following keys are obsolete; they are maintained only to ensure backwards compatibility with versions of AdaBrowse prior to V4.0.

    Index_Title
    Defines the title of an index. The general format of this key is Index_Title[.Index_Spec], where Index_Spec is one of Unit_Index, Type_Index, or Procedure_Index. If no Index_Spec is given, the key applies to the unit index to maintain compatibility with AdaBrowse versions earlier than 1.5.

    The default titles are "Unit Index" (not "Package Index", because subprograms also may be library units) for the unit index, "Type Index" for the type index, and "Subprogram Index" for the subprogram index.

    Examples:

    Index_Title = My Subsystem
    Sets the title for the unit index to "My Subsystem". Equivalent to Index.Units.Title = My Subsystem.

    Index_Title.Unit_Index = My Subsystem
    Ditto. Equivalent to Index.Units.Title = My Subsystem.

    Index_Title.Type_Index = My Types
    Sets the title for the type index to "My Types".
    Equivalent to Index.Types.Title = My Types.

    5.6. Cross-References

    (New in V1.1)

    By default, AdaBrowse will generate cross-references to other units based on the assumption that the other units' HTML files will be in the same directory as the final place for the current unit's HTML file. However, this may not always be adequate.

    Consider a shop that runs several projects, all using a set of common core components. The core components' descriptions are on a Web server in the intranet at URL "http://intranet.shop.com/core/doc/ref_manual/".

    You are working in project X (which uses the core components), and are to place your project's HTML docu at "http://intranet.shop.com/X/specs/".

    Therefore, the HTML files you generate must prefix all cross references to a core component with either "http://intranet.shop.com/core/doc/ref_manual/" or, in this particular case, "../../core/doc/ref_manual/".

    Or maybe, for some reason, you don't want any cross-references to certain components at all.

    AdaBrowse has some keys which allow you to define exactly this behavior:

    Path.<Full_Unit_Name_Prefix>
    Modified in V2.0.

    If defined, prepend the value to any cross-reference to a unit whose full unit name (starting with a root library unit name) has a prefix that matches <Full_Unit_Name_Prefix>. If several <Full_Unit_Name_Prefix>es match, the longest match wins. Matching is case-insensitive. Note that you specify a unit name prefix, not a file name prefix. I.e., you'd write "Core.Os", not "core-os".

    Several Path keys may be defined. If two <Full_Unit_Name_Prefix>es are identical (except for casing), the later definition wins.

    <Full_Unit_Name_Prefix> must not be empty, i.e. a definition like

    Path. = ...

    is illegal.

    AdaBrowse does environment variable substitution on the value. The value (after environment variable substitution) may be empty, in which case AdaBrowse does not prefix cross-references to matching units.

    Example: 

    Path.Cor  = http://intranet.shop.com/core_old/doc/rm/
Path.Core = ../../core/doc/ref_manual/
Path.BC   = http://intranet.shop.com/booch_components/rm/
    If AdaBrowse wants to generate a cross-reference to a unit CORE.OS now, it'll check the list of pathes given and in this case, it'll generate the cross-reference to "../../core/doc/ref_manual/core-os.html". Note that the first path also matches, but "Core" is a longer match than "Cor". However, for a cross-reference to COROLD.EXTERNAL, the first path will match (whereas the second one won't as "core" is not a matching prefix), and the cross-reference will be generated to the URL "http://intranet.shop.com/core_old/doc/rm/corold-external.html".

    No_XRef = Full_Unit_Name_Prefix {"," Full_Unit_Name_Prefix}
    If defined, tells AdaBrowse never to generate cross-references to Units whose full name has a prefix matching one of the given unit name prefixes, unless a unit that would be thus excluded from cross-reference generation is explicitly included by a XRef key (see below). Matching is case-insensitive. White space around unit name prefixes is ignored, and so are empty unit name prefixes.

    Multiple No_XRef keys may be defined. The set of prefixes considered is the union of all No_XRef keys' values. The value may be empty, in which case the key definition has no effect.

    Matching is case-insensitive.

    Example: 

    No_XRef = Core.Os ,,  , BC.Support
No_XRef = , Co ,
    The set of prefixes is "Co", "Core.Os", "BC.Support".

    XRef = Full_Unit_Name_Prefix {"," Full_Unit_Name_Prefix}
    (New in V2.12.) This is the exact opposite of No_XRef. Cross-references to units matching one of the prefixes defined by XRef keys are always generated, even if the unit name would otherwise be excluded from cross-reference generation by a No_XRef key. I.e., XRef keys define exceptions to the set of units defined by No_XRef keys.

    Exclude = Full_Unit_Name_Prefix {"," Full_Unit_Name_Prefix}
    Same syntax as No_XRef. Defines a set of units for which no HTML files shall ever be generated. This is useful in particular in conjuction with the -a option: if your package in project X uses something from Core, AdaBrowse would normally also generate a HTML file for the core packages. But that's probably not what you want.

    If the value is empty, all previous definitions of that key are reset, i.e., the set of units to exclude is (again) the empty set.

    Multiple Exclude keys may be defined, the set of excluded units is the union of all keys' values (except for the empty value, see above).

    Example:

    Exclude = Core, BC

    If the unit you give in the (mandatory) -f option is excluded, AdaBrowse issues an error message.

    Note: cross-references to a unit suppressed by an Exclude key will still be generated unless the unit is also suppressed by a No_XRef key.

    Also note that AdaBrowse excludes by default all units from the Ada 95 standard library. (It only handles what ASIS calls "An_Application_Unit".)

    Include = Full_Unit_Name_Prefix {"," Full_Unit_Name_Prefix}
    (New in V2.12) This is the exact opposite of Exclude. HTML files are always generated for units matching one of the prefixes defined by Include keys, even if the unit name would otherwise be excluded from cross-reference generation by an Exclude key. I.e., include keys define exceptions to the set of units defined by Exclude keys.

    Do not confuse this key with the Include_File key, which is for including another configuration file into the current one.

    Refs_To_Standard = (True | False)
    (New in V2.11.) If this key is set to True, AdaBrowse will generate cross-references to items from the Ada 95 standard library or the compiler's run-time library, unless such units are excluded from cross-reference generation explicitly using a No_XRef key. If it is set to False (the default), AdaBrowse won't generate such cross-references. In both cases, AdaBrowse will never generate cross-references to items from the implicit package Standard.

    AdaBrowse does longest prefix matching for the [No_]XRef and the Exclude or Include keys. This makes it possible to define precisely which units are to be included, and which ones are to be excluded. For instance, 

       Exclude = System., System.Address_To_Access_Conversions.
   Include = System.Address_To_Access_Conversions

    has the following effect:

    1. exclude all children and further descendents from package System. That's the "Exclude = System." part. Note the period: it doesn't exclude System itself!

    2. include the package System.Address_To_Access_Conversions and all its children and further descendents. That's the Include key.
    3. exclude again any descendents of System.Address_To_Access_Conversions again. That's the second prefix in the Exclude key's value.

    As a result, there will exactly two packages from the System subsystem be included: System itself, and System.Address_To_Access_Conversions. All other packages in this subsystem are excluded.

    Versions of AdaBrowse prior to V2.13 did shortest prefix matching on these unit prefixes. This made sense when there were no Include or XRef keys, but since their introduction in V2.12, shortest prefix matching isn't exactly useful anymore; longest prefix matching actually is much more useful.

    If the -a option is given to AdaBrowse, it will try to generate HTML files for all parent units of the given unit, as well as for the transitive closure of all "with"ed units and their parents. However, it will skip any unit in this set that is either excluded by an Exclude key, or for that no cross- references are generated anyway due to a No_XRef definition. AdaBrowse will issue a warning for each skipped unit to stderr. (If, in addition to -a, also -x was given, it'll also skip the unit if the corresponding HTML file already exists, and it'll also warn about that.)

    (Of course, if warnings are suppressed with the -q option, AdaBrowse will not issue these warnings.)

    5.7. General Usage Hints

    The file sample.cfg gives the default settings AdaBrowse uses anyway if no configuration is used. In this default setting AdaBrowse generates valid HTML 4.01. However, if you redefine some keys inconsistently in a configuration file, AdaBrowse may generate invalid HTML. An example would be to define 

        Keyword.Before = <EM>
    Keyword.After  = </STRONG>

    or 

        Comment.Before = <EM>
    Comment.After  =

    or (especially catastrophic) 

        Body = <!--

    Thus, be careful to define your values properly! Or use the default settings. AdaBrowse does not check whether or not the values defined make any sense.

    Note that the style sheet to use can be defined on the command line (with the -s option) or in a configuration file (with the Style_Sheet key). The later definition wins.

    5.8. A More Elaborate Example

    This example shows how to generate a useful HTML reference of the standard library of your compiler. The example assumes your compiler is GNAT, and its standard library is at a place designated by an environment variable called GNAT_LIB_SRCS. On my machine for instance, GNAT_LIB_SRCS would have the value x:\gnat\lib\gcc-lib\pentium-mingw32msv\2.8.1\adainclude.

    First, create a directory where you want the generated HTML to go: 

       mkdir ./std_lib_html

    Then create a configuration file ./std_lib_html/std.cfg with the following contents: 

       # Sample configuration file for creating a HTML docu for the standard lib.

   # Do not generate cross refs to any child of System. Note the period at the end: we
   # don't exclude System itself!
   No_XRef = System.

   # But do generate cross-refs to the standard children
   XRef    = System.Address_To_Access_Conversions, System.Machine_Code, System.RPC
   XRef    = System.Storage_Elements, System.Storage_Pools

   # The above combination of No_XRef and XRef excludes all GNAT-specific children
   # of package System.

   # Now the same with Exclude and Include keys:
   Exclude = System.
   Include = System.Address_To_Access_Conversions, System.Machine_Code, System.RPC
   Include = System.Storage_Elements, System.Storage_Pools

    Then, execute the following commands (assuming Win NT/2k, but on Unix, it would be very similar): 

       cd .\std_lib_html
   for %i in (%GNAT_LIB_SRCS%\*.ads) do gcc -c -gnatc -gnatg -gnatt -I%GNAT_LIB_SRCS% -I- %i
   ls -1 *.adt | sed -e"s@/@\\@g" | adabrowse -I%GNAT_LIB_SRCS% -c std.cfg -g -f- -is -t -p
   del *.adt *.ali

    Note the "-g" option! Also note that the above configuration file excludes only the GNAT specific children of System, but it doesn't exclude GNAT-specific additions to e.g. the Ada or Interfaces subsystem.

    On my machine, the above execution of AdaBrowse takes about one minute and generates 205 HTML files (using GNAT 3.15p).

    6. Descriptions

    This section describes how AdaBrowse associates Ada 95 comments with declarations to generate HTML descriptions. It also gives an introduction to how AdaBrowse formats the HTML descriptions.

    Advanced topics on user-defined HTML mark-up and on how to fine tune or even completely change the formatting process are described in their own sections following this basic introduction.

    6.1. Finding Descriptions

    Since V1.1, AdaBrowse can extract comments from the source and generate HTML descriptions for items from them automatically. You configure which comments are to be taken for which items through the Description keys explained below. For instance, you can tell AdaBrowse whether you generally put comments for a subprogram before or after the subprogram declaration.

    This section only describes how AdaBrowse associates Ada comments with certain Ada entities. For information on how to control the formatting of the HTML descriptions generated from these comments, see below.

    6.1.1. Description Definitions

    The keys that tell AdaBrowse where to find the comments to create the descriptions of an entity from all start with "Description." and all take a list written as comma-separated values as their argument. Legal list element values are:

    Before (Number)
    Take the comment above the entity to build the description from. There may be at most Number empty lines between the last comment line and the beginning of the entity. If no number is given, this means "any number of empty lines". If the Number is zero, there mustn't be any empty lines between the entity and the comment. The search for the comment starts at the beginning of the item and goes backward.

    Examples:

    Description.Subprogram = Before (3)
    Tells AdaBrowse that the description for a subprogram declaration can be found in a comment textually above the declaration, separated from the declaration by at most 3 empty lines.

    Declaration.Subprogram = Before
    The same, but the search for the comment is not limited to a particular number of empty lines.

    After (Number)
    Ditto, but AdaBrowse goes looking for a comment below the entity. The search starts at the end of the item and goes forward.

    Inside (Number)
    This value is allowed only for the "containers" (see below). It tells AdaBrowse that the descriptive comment is inside the entity, separated by at most 'Number' empty lines from the end of the header. The search goes forward. (An exception are library units, see the corresponding keys below.)

    It can be applied to (generic) package declarations, task (type) declarations, and protected object and type declarations.

    The header of each of these constructs is defined by AdaBrowse to end at the end of the "is":

    package XYZ is

    generic ... package XYZ is

    task (type) XYZ (Discriminants) is

    protected (type) XYZ (Discriminants) is

    None
    Tells AdaBrowse not to try to find any descriptive comment for the entity.

    In any case, search for a descriptive comment stops and comes up empty if either

    • a comment already taken as the description of some other entity is hit, or
    • a line containing any non-comment is hit.

    If a comment is found, all comment-only lines directly adjacent until one of the above two conditions (or the beginning or end of the file) is met belong to that descriptive comment.

    AdaBrowse recognizes the following description keys:

    Description.Context_Clause
    For the context clauses of a library unit. "Before" means "before the first context clause" and "After" means "after the last context clause". default setting is "After (1)".

    Description.Clause
    For interior "use" and "use type" clauses. Default setting is "After (1)".

    Description.Subprogram
    For subprogram, generic subprogram, entry, and entry family declarations.

    Description.Renaming
    For (generic) subprogram and package renamings. If not set explicitly, defaults to Description.Subprogram.

    Description.Instantiation
    For generic instantiations (subprograms or packages). If not set explicitly, defaults to Description.Subprogram.

    Description.Constant
    Applies to (deferred) constants and named numbers.

    Description.Exception
    For exception declarations including exception renamings.

    Description.Pragma
    For pragmas.

    Description.Rep_Clause
    For representation clauses.

    Description.Type
    For all types except task and protected types.

    Description.Object
    For all variable declarations and object renamings.

    Description.Container
    A global key for all "containers", i.e., (generic) package declarations that are not renamings, task (type) declarations, and declarations of protected objects and types.

    Description.Task
    For tasks and task types. If not set explicitly, defaults to Description.Container.

    Description.Protected
    For protected objects and types. Defaults to Description.Container.

    Description.Package
    For nested (generic) packages. Defaults to Description.Container.

    Description.Library
    For all library units. Here, "Before" means "before the context clauses", "Inside" means "between the context clauses and the beginning of the header" and "After" means "after the declaration" for library unit sub subprograms and renamings and "Inside, after the package header" for library unit (generic) packages.

    If "Inside" is specified, the search for the comment starts at the beginning of the header, and the search goes backwards. It is thus possible to have 

    Description.Context_Clause = After
Description.Library = Inside

with Ada.Text_IO;
-- This comment is taken for the context clauses

-- This comment is taken to build the package description
package XYZ is
   ...
    The empty line between these two comments is crucial! Without this empty line, both Ada comment lines would be considered part of the same descriptive comment and be taken for the package description. (See below.)

    Description.Library_Subprogram
    For (generic) library subprograms. Defaults to Description.Library.

    Description.Library_Package
    For (generic) library packages. Defaults to Description.Library.

    Description.Library_Renaming
    For library unit (generic) renamings. Defaults to Description.Library.

    Description.Library_Instantiation
    For library units that are instantiations of other generic units. Defaults to Description.Library.

    6.1.2. How AdaBrowse maps Ada Comments to Descriptions

    Determining which comment belongs to which entity works as follows:

    Generally, for finding a description, AdaBrowse considers all specified locations in the order they appear in the list of the key.

    AdaBrowse starts with the library unit and tries to find a descriptive comment for it. If it finds one, it associates that comment with the library unit.

    Next, it considers the context clauses and associates any description it finds with them (as a whole).

    Then, if the library unit is a package, it goes through all declarations and pragmas inside the visible part of the package in the order of their appearance and tries to find descriptions.

    If for some entities a list and not just a single value was given, AdaBrowse then makes another pass following exactly the same rules and tries to find additional descriptions (that have not yet been assigned to an entity), using the remaining location definitions in the entity's key definition.

    Nested containers, that is, (generic) package declarations, task (type) declarations, and protected object and type declarations are handled similarly whenever the container is encountered.

    The default values, which mirror my own style, are as follows:

    Description.Context_Clause= After (1)
    Description.Clause= After (1)
    Description.Subprogram= After (1)
    Description.Renaming= After (1)
    Description.Instantiation= After (1)
    Description.Constant= After (1)
    Description.Exception= After (1)
    Description.Pragma= After (1)
    Description.Rep_Clause= After (1)
    Description.Type= After (1), Before
    Description.Object= After (1)
    Description.Container= Before, Inside
    Description.Task= Before, Inside
    Description.Protected= Before, Inside
    Description.Package= Before, Inside
    Description.Library= Before, After
    Description.Library_Subprogram= Before, After
    Description.Library_Package= Before, After
    Description.Library_Renaming= Before, After
    Description.Library_Instantiation= Before, After

    6.2. Basic Description Formatting

    A description for some declaration is thus a sequence of Ada 95 comments. These comments appear in the order the locations were given in the Description key definitions, not in the order they appeared in the original Ada 95 source.

    If the first line of a comment of a description contains the comment prefix and then dashes only, it is removed and likewise for the last line. Next, the comment prefix is removed from all lines in the comments of the descriptions, and any trailing " --" (for box comments) is also removed. The comment prefix is normally "--" (of course), but more elaborate prefixes can be defined; see below. Then, any trailing white-space is removed. What remains is the content of the description.

    This description content is then processed in various ways (which you can define, see below) and then written to the generated HTML file. Logically, if the comments contain HTML tags, these will end up in the generated HTML file. Hence you can use HTML mark-up to format your Ada 95 comments.

    6.2.1. Default Formatting

    By default, HTML comments within Ada comments (started by "<!--" and extending up to the next "-->") are suppressed completely; they are not written into the generated HTML file at all. HTML special characters in Ada comments are automatically replaced by the corresponding named character entity, e.g. a "<" in an Ada comment will be written as "&lt;" into the HTML file. (Unless, of course, the "<" is the opening of an HTML tag.) Characters beyond the 7-bit ASCII range (like e.g. "ü") are replaced by numeric character entities, in this case by "&#252;".

    Empty Ada comment lines (i.e., starting with "--" and then followed by white-space only (and possibly a terminating " --")) cause new paragraphs to be started, so it is in general not necessary to put <P> tags in your comments.

    AdaBrowse uses a simplified parsing of Ada comments to determine what is an HTML tag. It considers anything starting with a "<" followed by a character or a "/" and a character up to the next ">" that is not within a """-delimited string a HTML tag. This works pretty well in practice, but may fail in some circumstances:

    • If you have an Ada comment like "-- This function returns True iff 10<a", AdaBrowse thinks the "<a" was the start of a HTML tag. To avoid this, write your comment as "-- This function returns True iff 10 < a", which looks nicer anyway. (Note that this particular case causes troubles even if AdaBrowse knew all the legal HTML tags exactly, and therefore I chose to use a simplified parsing only: nothing would be gained by an exact parsing, but it would make AdaBrowse slower.)

    • The same problem occurs in an Ada comment like "-- Author: <somebody@somewhere.org>": AdaBrowse will treat the whole e-mail address as a HTML tag. Either omit the "<" and ">" around the e-mail address, or write them as "&lt;" and "&gt;", or make sure there's a space following the "<" as in "-- Author: < somebody@somewhere.org >".

    6.2.2. A Shortcut for the <CODE>-Tag

    I also found that the most often used HTML tag in Ada 95 comments tends to be <CODE>. Since I personally find it rather cumbersome to have to type this so often and I also think it interferes with the readability of the Ada comments in the Ada source, AdaBrowse offers a more readable short-hand notation for most uses of the <CODE>-tag: Any pair of "@ without white-space in between is replaced by "<CODE>" and "</CODE>", respectively. Hence the Ada comment 

    This function returns @True@ iff 10 < @a@

    will be written as 

    This function returns <CODE>True</CODE> iff 10 < <CODE>a</CODE>

    into the HTML file, and will be rendered as

    This function returns True iff 10 < a

    The "@"-pair handling is intended to catch and simplify the most common uses of the <CODE>-tag, but it cannot replace all uses of <CODE>.

    The above is sufficient for most simple needs, and AdaBrowse provides sensible default settings such that well-written comments are rendered nicely when the generated HTML file is displayed. However, for more advanced needs, AdaBrowse provides two more ways to control the formatting process precisely to nearly any level desired:

    1. User-defined HTML mark-up can be used to define your own tags that are macro-expanded. There are even ways to define tags that include other files, or that call an external command and replace the tag by the command's output. This is described in detail in the section on user-defined HTML mark-up.

    2. Format instructions allow you to define exactly how AdaBrowse shall format a comment. You may define special prefixes and format instructions that apply to all Ada 95 comments that start with those prefixes (for instance, you could make any comments beginning with "--!" to be written in a <PRE> block). You may also redefine how AdaBrowse formats comments in general by defining your own format instructions for the standard prefix "--". AdaBrowse offers several powerful built-in format instructions, but also allows you to send the whole description content to some external command for formatting. All this is described in the section on advanced description formatting.

    However, for your first experiments, just use the default settings. As a next step, I suggest trying out the "@"-pair replacement. Once you've had some experience with AdaBrowse, you'll probably start using user-defined tags for newly written source code. Format instructions are mainly useful if you have special formatting needs, or if you need to generate HTML documentation for legacy code containing textually formatted comments.

    7. User-Defined Mark-Up

    As of V2.0, AdaBrowse supports user-defined HTML mark-up elements. By default, AdaBrowse replaces any user-defined HTML tag in a comment that is formatted according to the tag's definition.

    7.1. Basic Syntax

    A user-defined HTML element is defined by keys of the form User_Tag.<TAG_IDENTIFIER>. <TAG_IDENTIFIER> must be an identifier, which in AdaBrowse has the syntax 

        Identifier = Letter { Letter | Digit | '_' }.
    Letter     = 'A' .. 'Z' | 'a' ..'z'.
    Digit      = '0' .. '9'.

    This is the same syntax as for Ada 95 identifiers, except that it allows multiple underscores in a row as well as trailing underscores.

    To define a container element, the syntax is 

        User_Tag.<TAG_IDENTIFIER>.Before = Definition
    User_Tag.<TAG_IDENTIFIER>.After  = Definition

    Both the ".Before" and the ".After" must be present. If one or the other is missing, AdaBrowse will issue an error message. The ".Before" definition replaces any occurrence of the opening tag, and the ".After" definition replaces occurrences of the closing tag.

    To define a non-container element, use the syntax 

        User_Tag.<TAG_IDENTIFIER> = Definition

    i.e. without either ".Before" or ".After". In both cases, the key is case insensitive, both in the configuration file and also in the comments where the user-defined tags are used. Both container and non-container elements can be individually switched on or off: 

        User_Tag.<TAG_IDENTIFIER>.Enabled = (True | False)

    By default, all user-defined HTML elements are enabled. If an element is disabled, it is completely suppressed. If a container element is disabled, all its content also is suppressed.

    7.2. A Simple Example

    Consider the following configuration file: 

        User_Tag.COPYRIGHT.Before = <BLOCKQUOTE><STRONG>Copyright (c)
    User_Tag.COPYRIGHT.After  = </STRONG></BLOCKQUOTE>

    User_Tag.AUTHOR = Thomas Wolf

    An Ada comment like 

        --  <COPYRIGHT> 2002 by <AUTHOR></COPYRIGHT>

    will thus be written to the generated HTML file as: 

    <BLOCKQUOTE><STRONG>Copyright (c) 2002 by Thomas Wolf</STRONG></BLOCKQUOTE>

    and will be rendered as

    Copyright (c) 2002 by Thomas Wolf

    Note how the non-container element "AUTHOR" works like a variable!

    The same effect can also be achieved with the configuration file 

        User_Tag.COPYRIGHT.Before = <BLOCKQUOTE><STRONG>Copyright (c)
    User_Tag.COPYRIGHT.After  = by <Author></STRONG></BLOCKQUOTE>

    User_Tag.AUTHOR = Thomas Wolf

    and the Ada comment 

        --  <COPYRIGHT> 2002 </COPYRIGHT>

    This latter example also shows that user-defined tags can be defined in terms of other user-defined tags: AdaBrowse performs macro substitution of user-defined tags. Of course, recursion between user-defined tags is not allowed. If AdaBrowse detects a recursive definition of user-defined tags during tag expansion, such as 

        User_Tag.RECURSIVE   = <NOT_ALLOWED>
    User_Tag.NOT_ALLOWED = <RECURSIVE>

    it issues an error message and terminates.

    7.3. Advanced User-Defined Variables

    A user-defined non-container HTML element acts like a variable (or more precisely, a macro): it is simply replaced by its definition, and references inside that definition to yet other user-defined HTML elements also are replaced.

    AdaBrowse offers some more advanced ways to set such user-defined variables (all these definitions define non-container HTML elements):

    User_Tag.<TAG_IDENTIFIER>.Include = File_Name
    Replaces any occurrence of <TAG_IDENTIFIER> by the verbatim contents of the file File_Name. If the file cannot be found or read, AdaBrowse issues a warning and replaces the tag by the empty string. Within File_Name, AdaBrowse performs environment variable substitution!

    Note that AdaBrowse does not parse the file in any way, so inside the included file, AdaBrowse's user-defined HTML elements are not available; the file should contain standard HTML only. Also, it is good, prudent practice to make the file self-contained in the sense that it should close all container elements it has opened. Otherwise, the HTML file generated by AdaBrowse may become hopelessly garbled.

    If the file name is empty, no file inclusion occurs, and the tag is replaced by the empty string.

    User_Tag.<TAG_IDENTIFIER>.Execute = Command
    For each occurrence of <TAG_IDENTIFIER>, AdaBrowse runs the Command and replaces the tag by the entire output of the command. Note that the command had better not read from stdin, and it also had better return. If the command blocks (does not return), so will AdaBrowse! Within the Command, AdaBrowse performs environment variable substitution.

    The command's output is placed verbatim into the generated HTML file, so again, no user-defined HTML elements are available.

    If the command is empty, no command is run and the tag is replaced by the empty string.

    User_Tag.<TAG_IDENTIFIER>.Set = Command
    As the Execute selector, but the command is run only once upon the first occurrence of <TAG_IDENTIFIER>. The variable is set to the first line (limited to 1000 characters) of the command's output. Then, this and any subsequent occurrences of the tag are replaced by this value. Since these replacements are then normal tag replacements, AdaBrowse does parse the value and expand any contained references to other user-defined HTML elements! Within the Command, AdaBrowse performs environment variable substitution.

    If the command is empty, no command is run and the tag is replaced by the empty string.

    User_Tag.<TAG_IDENTIFIER>.Variable = ...
    As a normal non-container definition of the form User_Tag.<TAG_IDENTIFIER> (without selector), but AdaBrowse performs environment variable substitution on the value.

    7.4. Parameters of User-Defined Tags

    (Introduced in V2.1)

    User-defined HTML tags may also have parameters. AdaBrowse considers anything after the tag identifier in an opening tag up to the closing ">" the parameters of the tag. This is similar to standard HTML (where parameters are called "attributes"). Consider e.g. 

        <A HREF="http://www.somewhere.org/" TARGET="_top">

    In AdaBrowse's terms, this tag has two parameters: one has the name HREF and the value http://www.somewhere.org/, and the other one is named TARGET and has the value _top.

    Parameters of user-defined tags work in exactly the same way. Any valid parameter has a name, and is defined using an equal sign followed by the value. If the value is quoted (a double quote sign (") follows the equal sign immediately), the enclosing quotes are stripped off. Note that there mustn't be any white space between the equal sign and the parameter name or the value!

    Parameters make only sense if they can be referenced in some way and the referenced parameter inserted in some way in the user-defined key's expansion at macro substitution time. The syntax for parameter references is similar to the syntax used for environment variable references as explained below, except that the initial character introducing a reference is not the "$" sign but the "%" sign. Of course, indirect and recursive references for parameters don't make much sense and therefore are not allowed.

    At macro substitution time, any parameter reference in the definition of a user-defined HTML tag is replaced by the value of the corresponding parameter. The following examples show how this can be used:

    • Define an HTML tag that includes any file given: 
      
User_Tag.INCLUDE_ANY.Include = %File
      A tag <INCLUDE_ANY FILE="../somefile.html"> will then be replaced by the contents of file ../somefile.html. Another tag <INCLUDE_ANY FILE="other.html"> will be replaced by the contents of file other.html. And an INCLUDE_FILE tag that doesn't have a parameter named File will be silently ignored, since references to undefined parameters are replaced by the empty string.

    • Pass parameters to an external command: 
      
User_Tag.RUN_IT.Execute = some_program %Params
      A tag <RUN_IT PARAMS="-I.. -I../something -q -x"> will then run the command "some_program -I.. -I../something -q -x" and replace the tag with the output of this command.

    • Pass on some parameters to other tags (standard or user-defined): 
      
User_Tag.MY_TAG.Before = <SPAN %{Class:+Class="%Class"}>
User_Tag.MY_TAG.After  = </SPAN>
      A fragment like <MY_TAG CLASS="something">Text</MY_TAG> will then be replaced by <SPAN Class="something">Text</SPAN>. Note that the value of %Class is just something (without the quotes, see above)! Occurrences of MY_TAG without a Class parameter will expand into a SPAN tag without parameters. (That's the definition of the ":+" operator used in this example, see below for more information.)

    Because the form used in the last example ("%{Param:+Param="%Param"}") is so common, the syntax %{!Param} is used as an abbreviation for this. (In other words, the syntax of indirect references is redefined (or misused) to expand to the name of the parameter, followed by an equal sign and the value of the parameter within quotes if the parameter exists, and the empty string otherwise.)

    The special parameter name % is defined to denote all parameters of the user-defined HTML tag. I.e., a reference of the form "%%" or "%{%}" is replaced by whatever followed the tag identifier up to the closing ">" sign. Example: 

        User_Tag.MY_TAG.Before = <SPAN %%>
    User_Tag.MY_TAG.After  = </SPAN>

    effectively defines MY_TAG as an alias for SPAN.

    Note an important difference between the substitution of tag parameters and the substitution of environment variables: environment variables are replaced when the configuration file is read, whereas tag parameters (logically) are replaced when an occurrence of the user-defined tag is found in an Ada comment and is to be rendered as HTML.

    8. Environment Variable Substitution

    Environment variable substitution occurs when the declaration in the configuration file is read and can thus never interfere with the later macro substitution of user-defined HTML mark-up.

    8.1. Syntax and Semantics

    AdaBrowse uses for environment variable substitution a syntax very similar to that of the GNU bash shell. An environment variable has a name, which is an identifier as defined above. A simple reference to an environment variable has the form 

        $Identifier

    and is replaced as a whole (including the '$' sign) by the variable's value or by the empty string if no such environment variable is defined.

    More interesting are the complex variable references, which have the syntax 

        Value         = any string, maybe containing environment variable references.
    Operator      = :- | :+.
    Reference     = ${Variable_Name[Operator[Value]]}.
    Variable_Name = Value | !Identifier.

    In all forms, Variable_Name can have one of three formats:

    • An identifier: expands to the empty string if no such environment variable is defined, and to the variable's value otherwise.
    • A '!' and an identifier: expands the identifier as above, but then takes the result of this expansion as the name of another environment variable, which is then expanded. This is known as indirect expansion, and is limited to one level of indirection only.
    • Some arbitrary string that may contain embedded references to environment variables: environment variable substitution is performed on the whole thing, and the resulting value is taken to be the name of an environment variable, which is then expanded. This recursive expansion is unknown in bash, and it is done for as many levels as specified.

    The semantics of these forms is as follows:

    ${Variable_Name}
    Is identical to the simple form of references $Identifier except that it also allows indirect and recursive expansion.

    ${Variable_Name:-Value}
    Is replaced by the result of ${Variable_Name} unless that result is empty, in which case it is replaced by the expansion of Value.

    ${Variable_Name:+Value}
    Is replaced by the expansion of Value if the result of ${Variable_Name} is non-empty, or the empty string otherwise. (:+ is the inverse of :-.)

    Indirect expansion using the '!' character is supported only to keep the syntax as close to the one used by bash as possible. It is actually superfluous and can be replaced by the more powerful (and, so I think, simpler because more regular) recursive expansion: "${!Some_Name}" is identical to "${${Some_Name}}" or "${$Some_Name}".

    In the operators :- and :+, the ':' is actually optional. It appears that it is optional in bash (although the manual doesn't say so), and I have therefore chosen to make it optional in AdaBrowse, too.

    Within configuration files, AdaBrowse also supports two special "environment" variables named '@' and '$'.

    @
    Is always defined and evaluates to the path component of the complete filename AdaBrowse used to open the file. This path has a trailing directory separator ('\' on Windows or '/' on Unix), unless we're on Windows and the path is a relative path on some other drive (as in "C:some_file.cfg"). If the filename has no path, "$@" is substituted by ".\" or "./", respectively.

    $
    Also is always defined and evaluates to the raw filename (without path, if any) of the complete filename AdaBrowse used to open the file. I.e. "$$" or "${$}" is substituted by the filename of the configuration file.

    The @ variable is useful to refer to other files relative to the place the configuration file is at, rather than relative to the current directory from which AdaBrowse was invoked. Whether the $ variable is useful at all I do not know :-), but it seemed only consistent to provide that, too. Note that "$@$$" gives the complete filename of the configuration file, whereas "$@\$$" won't expand the "$$" because the backslash escapes the '$' sign introducing the variable reference.

    AdaBrowse performs environment variable substitution on the values of the following keys:

    • Compile,
    • Include_File,
    • Path....,
    • Style_Sheet, and
    • User_Tag.... with selectors ".Execute", ".Include", ".Set", ".Variable", and (new in V2.1) ".Enabled".

    To include a literal dollar sign '$' in any of these keys' values, escape it with a backslash and write "\$". If, for some reason, you want to have a backslash immediately before a variable reference, and do not want to escape the dollar sign, escape the backslash by writing two backslashes before the dollar. The sequence "\\" immediately followed by a variable reference is replaced by a single backslash and the substitution of the reference. I.e., "${SOME_PATH}\${SOME_FILE}" won't do what is expected, but "${SOME_PATH}\\${SOME_FILE}" will (and there will be one backslash between the two variable substitutions).

    8.2. Some Examples

    • Include a configuration file, but only if a variable giving a prefix of its path is set: 
      
Include_File = ${PATH_TO_FILE:+$PATH_TO_FILE\file.cfg}
    • To include the current date: 
      
User_Tag.Date.Set = date /t
      (or whatever the equivalent on Unix would be).

    • To supply a default path, if an environment variable that should be set isn't: 
      
User_Tag.GMGPL.Include = ${ADABROWSE_HOME:-.}\gmgpl.html
    • To specify a file relative to the location of the configuration file the key is in: 
      
User_Tag.XYZ.Include = $@some_file.html
    • To enable a user-defined tag depending on the setting of some environment variable: 
      
User_Tag.SOME_TAG.Enabled = ${SOME_VAR:-False}
      Note that in this example, the environment variable SOME_VAR, if defined, must have one of the values "True" or "False"; otherwise an error will occur because the ".Enabled" selector is defined to accept only these two definitions. If the environment variable is not defined (or defined as the empty string), the ":-" operator makes this be treated as False.

    9. Advanced Description Formatting

    This section describes in detail how AdaBrowse formats Ada comments to generate descriptions for items. You can configure how AdaBrowse performs this formatting to a great extent, in fact, it is even possible to replace the built-in formatting completely.

    9.1. Structure of a Description

    As mentioned above, a description is a sequence of comments AdaBrowse extracts from the source file. In this section, I will refine this basic definition a little bit by introducing blocks.

    9.1.1. Comment Blocks and Prefixes

    A comment block is any sequence of consecutive Ada 95 comment lines that start with the same prefix. When AdaBrowse formats a description, it goes through all comments of the description, and within each comment, through all blocks and formats the blocks according to the format instructions defined for the prefix of the lines in each block.

    The default prefix is "--", so by default any Ada 95 comment forms one block. Additional prefixes for splitting a comment into blocks are defined by the configuration key Format: 

        Format.<Prefix> = Format_Instruction

    <Prefix> is a string, which must start with "--". AdaBrowse issues an error if the string doesn't start with "--". Any consecutive comment lines (beginning with the "--" in the Ada source) that start with the same prefix belong to one comment block. If several prefixes match, the longest match wins.

    As with most configuration keys, later definitions of a format for the same prefix override earlier definition for that prefix. A definition of a "Format" key with an empty right-hand side (i.e., only white space in the value after the "=") removes the comment prefix and any format instructions previously defined for it, except in the case of the standard prefix "--" (which cannot be removed) where such an empty definition reverts to the default formatting.

    The prefix "--" is predefined as if a key "Format."--" = ..." was defined as the very first configuration key. This definition defines the default formatting AdaBrowse uses, and it can be redefined by an explicit definition of the configuration key Format."--". Such later redefinition can be removed by defining the configuration key with an empty value, which makes AdaBrowse use the built-in default formatting as already mentioned above.

    The Format Instruction for a given prefix defines how the content of a particular comment block is to be formatted. Note that if you use several prefixes, it would be a very good idea to make sure that all comment blocks are self-contained, i.e. that no HTML entities cross blocks. This is a direct consequence of AdaBrowse's formatting process, which formats block after block. Obviously, this can get misdirected if blocks are not self-contained.

    To show how different format instructions for different blocks can be used, consider the following example:

     

    Assume our Ada sources contain not only normal Ada comments starting with "--", but also comment lines starting with "--!" that shall somehow be formatted specially, for instance these lines might contain sample code.

    We can now define a comment prefix 

        Format."--!" = some format instructions

    to make AdaBrowse format any such comment lines e.g. by including them verbatim in a <PRE></PRE> block. (I'll soon explain how to write such a format instruction below.) As a result, a comment like 

        ------------------------------------------------------
    --  This is an example usage of procedure @Foo@:
    --
    --!   declare
    --!      X : Integer := 42;
    --!   begin
    --!      Foo (X);
    --!   end;
    --
    --  Note that @X@ must not be zero!
    ------------------------------------------------------

    will be split into three blocks: 

        --  This is an example usage of procedure @Foo@:
    --
        --!   declare
    --!      X : Integer := 42;
    --!   begin
    --!      Foo (X);
    --!   end;
        --
    --  Note that @X@ must not be zero!

    The first and the last block will be formatted according to the default rules (we didn't redefine Format."--"), whereas the middle block will be formatted according to our own rules.

    Note that to just have something enclosed in <PRE></PRE> tags, a special format is maybe overkill: in new sources, you could just as well directly enclose the example code in <PRE></PRE> tags yourself. However, if you have legacy code, you may not want to modify it to produce HTML documentation, or you may want to do more complex formatting. In these cases, the format instructions come in handy.

    9.2. User-Defined Formatting

    This section explains how to define format instructions for comment blocks.

    9.2.1. Format Instructions

    AdaBrowse recognizes the following format instructions, which define how it should format the content of a comment block:

    swallow
    Swallow the block, i.e. replace it by an empty string. The whole block will not appear at all in the generated HTML file.

    entities
    AdaBrowse puts the whole content of the block as-is into the generated HTML file. It doesn't parse the HTML, but blindly replaces all special characters (such as "<" or """, or characters beyond the 7-bit ASCII range) by named character entities. Note that if the block does contain HTML mark-up, this will effectively disable the mark-up (because all "<" characters will be replaced by &lt;, even if they started a HTML tag). This filter is intended primarily for legacy code where it is known that comments do not contain any HTML mark-up.

    Note that because the entities filter blindly replaces special characters, it should come before any filter that inserts or modifies tags. To replace special characters without affecting existing HTML mark-up, use the plain filter instead!

    plain
    AdaBrowse replaces special characters by character entities, e.g. all quotes not within a tag are replaced by &quot;; any "<" that doesn't belong to a tag is replaced by &lt;, and so on. The difference to the entities filter is that this filter does parse the HTML mark-up and preserves it.

    hr [strip | replace]
    Defines how AdaBrowse shall handle comment lines that contain only the prefix followed by dashes. Such lines may occur within a description (the global processing only strips the first and last line of a whole comment if they contain only dashes, but not interior comment lines). Possible values for hr are:

    strip
    Replace such separator lines by an empty line.
    replace
    Replace separator lines by <HR>.

    If only "hr" appears (i.e., without "strip" or "replace" following), the default behavior is strip.

    strip_comments
    Removes all HTML-comments.

    enclose (string, string)
    AdaBrowse encloses the whole block by prefixing it with the first string and appending the second string. Typically, the strings will contain HTML mark-up, and if enclose is followed (in a pipe) by expand, they may even contain user-defined HTML mark-up.

    AdaBrowse does not verify that the two strings correspond in any way, so if you define nonsense parameters such as enclose ("<!--", ""), you will get nonsense HTML output. Typically, the first string will contain some container-opening tags, and the second one the corresponding closing tags in the right order. Both strings must be present (even though they may be empty). Embedded double quotes in a string must be doubled as in Ada 95.

    pre
    AdaBrowse encloses the whole block in <PRE></PRE> tags, i.e. pre is short-hand for enclose ("<PRE>", "</PRE>").

    expand
    AdaBrowse performs macro replacement of user-defined HTML entities as described above.

    unknown_tags [all | standard]
    AdaBrowse converts all references to unknown HTML entities (i.e., unknown tags) to text by replacing all special characters, notably the opening < and the closing >, by character entities. In other words, "<UNKNOWN>" becomes "&lt;UNKNOWN&gt;".

    The optional parameter defines whether the filter considers only the standard HTML 4.01 tags as known (unknown_tags standard), or whether user-defined tags also shall be considered as known (unknown_tags all). Default is standard, i.e., any remaining user-defined tags will be replaced by their text equivalent.

    shortcut
    AdaBrowse replaces all occurrences of pairs of "@" without whitespace in between by <CODE> and </CODE>, respectively, as described above.

    para
    AdaBrowse assumes that an empty content line indicates a new paragraph and inserts <BR> or <P> tags as appropriate.

    This format instruction is smart: it won't change anything inside <PRE> blocks, and it also will never insert <BR> or <P> tags where they would be illegal (such as directly inside a <UL>).

    lines
    AdaBrowse tries to maintain the original line structure of the Ada comment by replacing all white space outside HTML tags by &nbsp; and adding a <BR> at each end-of-line outside HTML tags, unless the line already ended in a <BR>.

    This format instruction will only do this wherever such processing is allowed. E.g., it won't change anything in a <PRE> block (because there, it is unnecessary), and also won't do anything if the last tag was e.g. <UL> (because inside an unordered list, the only tag allowed is <LI>). Inside each <LI>, however, it will transform the text.

    standard
    This is a shortcut for the pipe "expand | strip_comments | unknown_tags standard | hr strip | para | shortcut | plain", which defines the standard formatting AdaBrowse uses by default.

    execute [end-of-line] (command)
    This is the most powerful format instruction. It tells AdaBrowse to run the command to format a comment block, passing the block on the command's stdin. AdaBrowse reads the command's output (stdout) and treats that as the result of the formatting.

    The optional end-of-line specification may be useful if the command assumes an end-of-line convention other than the one normally used on your operating system. (This happens for instance for me when I use the Cygwin utilities on Windows; Cygwin sed wants single LFs, whereas the normal end-of-line marker on Windows in CR-LF, which apparently confuses sed. I do not know whether this is "normal" or some installation problem on my machine, but anyway AdaBrowse has a way to get around such difficulties.)

    To properly handle such pathological cases, you can define precisely what end-of-line convention AdaBrowse shall use for the input to the command. Possible values of end-of-line are CR, CRLF, and LF. By default, AdaBrowse uses whatever is the standard convention on the operating system it runs on.

    The closing parenthesis of an execute filter is defined to be the next right parenthesis (")") not within a string (delimited by ", ', or the backquote `; embedded string delimiters are assumed to be escaped by a backslash) and on the same nesting level, where the nesting level is given by the nesting of parenthesized pieces of text enclosed by round parentheses ("(" and ")") or curly braces ("{" and "}").

    If the command is empty or contains only whitespace, AdaBrowse issues an error. It also issues an error and terminates if the command fails for any reason.

    The parsing of format instructions always is case insensitive, e.g. all of "STANDARD", "standard", "StAnDaRd", or any other combination of upper and lower case letters is recognized as the format instruction standard.

    All of these format instruction except entities and execute skip any HTML comments they encounter. Hence, expand will not expand user-defined tags inside HTML comments, para will not do anything inside an HTML comment, and so on. However, any command called by an execute instruction will have to deal with HTML comments as it sees fit.

    9.2.2. Pipes

    All these format instructions are filters that transform their input in some way to produce output. As a consequence, combining these is possible using the "|" pipe operator. It's an infix, left-associative operator. The syntax of a pipe is 

        Pipe = Format_Instruction | Pipe "|" Format_Instruction.

    And the semantics is that the output of the left operand is piped into the input of the right operand. The output of the pipe is the output of its right operand, and the input to a pipe becomes the input of its left operand. Note that grouping by parentheses is not allowed in a pipe, and would be superfluous anyway.

    Note that in the expand filter, most user-defined HTML tags are expanded recursively, i.e., if their expansion contains further user-defined tags, these are expanded in turn. However, this is not the case for user-defined tags defined using the ".Include" or the ".Execute" selectors. If you want to use user-defined tags in the results of such mark-up definitions, you should define a format instruction that has several expand filters in a row. E.g. the format instruction 

    Format."--" = expand | standard

    would in a first step expand all user-defined HTML tags, and then (because standard contains an expand filter) expand all remaining user-defined tags again. Note that any user-defined tags remaining after the first expand filter must have come from an expansion of an ".Include" or ".Execute" tag.

    If you use the execute filter, make sure that the command does terminate! If the called command blocks, AdaBrowse will block, too.

    Some combinations of format instructions within a pipe make no sense. For instance, after a pre filter, para, lines, or standard don't make much sense because both para and lines leave anything within a <PRE> block untouched. The combination of para followed by lines or pre within the same pipe also is pretty useless. You also should make sure that any "hr replace" filter appears before an eventual "para" filter, otherwise the result may not be what you expect. AdaBrowse does not check for such bizarre combinations, so make sure you understand what each filter does, and write sensible pipes! Otherwise, the final result may become hopelessly garbled.

    Also note that AdaBrowse does not try to correct already invalid HTML stemming from the Ada comments. So, if your HTML is incorrect to begin with, all bets are off as to what the final result will be, and whether and if so, how it will be rendered by a browser.

    9.2.3. The Default Formatting

    The standard formatting is defined by 

    Format."--" = expand | strip_comments | unknown_tags standard | hr strip | para | shortcut | plain

    which is the same as 

    Format."--" = standard

    You can redefine this standard formatting by overriding the key Format."--" explicitly in a configuration file.

    9.2.4. An Example

    As an example of an execute filter, consider how a simple look-alike of the lines filter could be implemented using sed: 

    Format."--!" = execute (sed -e"s/^\(.*\)<BR>$/\1/" \
                            -e"s/[[:blank:]]/\&nbsp;/g" \
                            -e"s/^\(.*\)$/\1<BR>/") | \
               plain

    The first sed expression removes any trailing <BR> to avoid inadvertantly doubling <BR>s. The second expression replaces all white space by &nbsp;, and the third finally appends a <BR> to each line. That's more or less what the predefined lines filter does, except that this definition assumes that there are no HTML tags in the input (the lines filter is smarter: it only replaces whitespace and only adds <BR> in text outside HTML tags).

    If the above execute filter does not work for you, you're probably on Windows and are using the Cygwin sed. In that case, you should instruct AdaBrowse explicitly not to use the host end-of-line indicator (which would be CR-LF), but the Unix format, which is a single LF. In that case, you should use the format instruction 

    Format."--!" = execute lf (sed -e"s/^\(.*\)<BR>$/\1/" \
                               -e"s/[[:blank:]]/\&nbsp;/g" \
                               -e"s/^\(.*\)$/\1<BR>/") | \
               plain

    Note that due to the way configuration files are read, we might also write this definition with embedded comments: 

    Format."--!" = execute (sed -e"s/^\(.*\)<BR>$/\1/" \      # Remove existing <BR>s
                            -e"s/[[:blank:]]/\&nbsp;/g" \ # Replace whitespace
                            -e"s/^\(.*\)$/\1<BR>/") | \   # Add <BR>s
               plain

    The comments are removed before any further processing, and the command to be run is in all three cases 

    sed -e"s/^\(.*\)<BR>$/\1/" -e"s/[[:blank:]]/\&nbsp;/g" -e"s/^\(.*\)$/\1<BR>/"

    Redefining the formatting for the standard comment prefix may be useful for processing legacy sources that don't use HTML markup for formatting in the comments. Some possibilities to get reasonably looking HTML output without modifying such sources are:

    • Format."--" = hr strip | entities | lines, or

    • Format."--" = entities | enclose ("<DIV CLASS=""LineStructure"">", "</DIV>") | hr strip, with a style definition in the style sheet like 
          DIV.LineStructure {
      white-space : pre
    }
    • Format."--" = entities | pre | hr strip, which also uses a monospaced (non-proportional) font.

    Note, however, that the CSS 2 standard allows conforming user-agents (browsers) to ignore the white-space property! Hence the second example may or may not produce the desired result.

    Also note that the entities filter must come before the enclose filter; otherwise, it would replace e.g. the "<PRE>" inserted by the enclose filter by "&lt;PRE&gt;", and thus the tag would not be interpreted by a browser but rather be displayed!

    10. XML Output

    As of version 3.0, AdaBrowse can also generate XML output in addition to HTML output. This opens the door for generating other document formats than HTML: just translate the XML into your favorite format, e.g. docbook or texinfo. This saves you the need to write your own Ada parser if you'd like to have e.g. a docbook documentation instead of HTML: you just need to write a docbook generator that takes the AdaBrowse XML as input, which should be relatively simple, given that there are numerous XML parsers available. And it saves me the trouble of having to provide built-in generators for any odd format.

    Some publicly available XML parser tool kits are e.g. XML/Ada (for Ada 95), or Xerces (Java, C++, Perl), and there are many others. It might even be possible to use XSLT stylesheets to transform the AdaBrowse-generated XML into other formats; for this, you'd need an XSLT processor such as Xalan (Java) or xsltproc (C). (I recommend the latter: it is small, fast, and works. You'll also need libxml2; a Windows port of xsltproc also exists: download libxml, libxslt, and iconv.) Another suggestion is the Saxon/Ælfred (Java). If you work on Windows, also be sure to get Markus Hoenicka's excellent guide to setting up an SGML/XML editing and publishing system on Windows NT.

    The generated XML complies to the XML 1.0 DTD included in the distribution. This DTD is also available at the URL http://home.tiscalinet.ch/t_wolf/tw/ada95/adabrowse/xml/adabrowse_2_0.dtd. It is thus possible to process the generated XML using any odd off-the-shelf XML 1.0 compliant XML parser. I do not claim that this DTD was a prime example of how a DTD should be written; it has been developed in a rather ad-hoc fashion. However, it captures all the necessary information and complies to XML 1.0, and thus (hopefully) fulfills its intended purpose, namely to serve as an intermediary representation for generating other document formats than HTML.

    You switch on XML generation using the "-G" option giving the output format name "xml". It is possible to generate only XML using "-G xml", or to generate both HTML and XML at the same time using "-G xml html".

    The XML output generates one single file containing the XML for all units processed. This file is has a default file name of "adabrowse.xml" in file input mode and of the name of the input unit with extension "xml" if only one file is being processed and is written to:

    • If the -o option specifies a file name: to that file, with extension "xml".
    • If the -o option specifies only a path: to a file named as specified above in the given directory.
    • If the -o option specifies stdout: to stdout.
    • If no -o option at all is given: to a file named as specified above in the current directory.

    This XML file contains all the information contained in the HTML file: it mirrors the exact structure of the HTML, and includes all cross-references. Descriptions are already grouped together with the item they belong to. The XML newly (since V4.0) also does contain the indices.

    Descriptions are not processed in any way (i.e.; all filter definitions are ignored) except for replacing all special characters by their character entities. Hence there is no replacement of user-defined tags or other automatic formatting: the XML contains the raw comments. If you use user-defined tags and so on, your XML-to-whatever translator will have to deal with them.

    There are no implicit formatting assumptions in the XML (as e.g. in the PRE in HTML). All lines are represented by an XML element LINE, both in source excerpts and descriptions.

    XML generation ignores the following options: -l (cross-references in XML always have both the line and the column number), and -s.

    XML generation honors the following configuration file keys: Compile, Char_Set, all the Description.* keys, all the Index and Rule keys, Exclude, Include, Include_File, No_XRef, XRef, and Refs_To_Standard. All other configuration file keys have no effect on the generation of XML (but they are still parsed, and if incorrect, may cause error messages to be generated).

    11. Rebuilding from sources for a GNAT version

    11.1 Why does AdaBrowse work only with a specific GNAT version?

    AdaBrowse uses ASIS to produce precise cross-references in the generated HTML and to extract semantic information. The ASIS-for-GNAT library is specific to a particular GNAT version, and therefore, all ASIS applications also are specific to the GNAT version the ASIS library used is for.

    AdaBrowse won't work with the FSF GNAT contained in gcc 3.x, because there is no ASIS implementation for that compiler. See also below.

    11.2 Rebuilding

    AdaBrowse works ok with versions of GNAT >= 3.14p. To rebuild AdaBrowse from the sources, follow these steps:

    1. Get ASIS-for-GNAT for your GNAT version.

    2. Apply the following corrections to the ASIS-for-GNAT you got:
      GNAT versionCorrection to make in ASIS-for-GNAT:
      3.14p

      Get the version string of your GNAT compiler by compiling something with the options gcc -c -gnatv. GNAT writes its version string (e.g. "3.14p  (20010503)").

      Open the ASIS source file ./gnat/gnatvsn.ads and make sure that the GNAT_Version_String there is exactly the same. (When I downloaded ASIS-for-GNAT 3.14p, there was a blank missing.) If the strings differ, change gnatvsn.ads to match what GNAT wrote.

      If you fail to make this correction, the ASIS libraray will not work at all (it'll always report an inconsistency between the compiler version and the ASIS library version.)

      3.15p No corrections needed.
      3.16a No corrections needed.
      3.16a1
      5.01a

      Remove line #295 from file ./asis/a4g-contt-pd.adb (the one reading "Result_Unit_Id_List := Nil_Unit_Id_List;").

      Without this correction, the "-all" option of AdaBrowse will not work; ASIS-for-GNAT will always raise a CONSTRAINT_ERROR!


    3. Install ASIS-for-GNAT.

    4. Make sure the path to your ASIS-for-GNAT installation is in ADA_INCLUDE_PATH and ADA_OBJECTS_PATH.

    5. Run the make file by typing make in the adabrowse directory.

    The above procedure will produce an AdaBrowse without support for the GNAT project manager. If you have GNAT 3.15p or later, you may rebuild an AdaBrowse with project manager support as follows:

    1. Get, correct and install ASIS-for-GNAT for your GNAT version.

    2. Make sure the path to your ASIS-for-GNAT installation is in ADA_INCLUDE_PATH and ADA_OBJECTS_PATH.

    3. Get the compiler sources for your GNAT version and put them into a directory, e.g. C:\gnat-3.15p-src\. Do not include this directory in the ADA_INCLUDE_PATH!

    4. Set the environment variable GNATSRC to the directory in which the compiler sources are. (Note that the sources are in a subdirectory src/ada, so you'd have to set it to C:\gnat-3.15p-src\src\ada in the above case.)

    5. Go to the directory where you had unpacked the AdaBrowse source distribution and type make.

    Steps 4 and 5 can also be combined by simply changing to the directory where you had unpacked the AdaBrowse source distribution and typing the command 

       make GNATSRC=C:/gnat-3.15p-src/src/ada

    (You can use forward slashes even on Windows.)

    Do not include the GNAT source directory in ADA_INCLUDE_PATH! Because the GNAT source distribution contains both the compiler and the library sources, this will screw up things completely unless you know exactly what you're doing. The typical outcome is that you will no longer be able to link because "system.ads has been modified".

    The make file is smart enough; so just leave any such issues to the makefile. It knows what it's doing, if you permit me the anthropomorphism. Just tell it where the GNAT sources are by setting GNATSRC (it's smart, but it can't read your mind :-), and then let it do its job.

    If this does not configure AdaBrowse to use the project manager, then either the environment variable GNATSRC was set wrongly, or your compiler doesn't have a project manager, or it is a compiler newer than GNAT 3.16a and has an incompatible project manager, or the make file incorrectly figured out the location of the installed ASIS library.

    If any of these things happen, the make file will produce an AdaBrowse without project manager support. You'll have to figure out yourself what went wrong.

    I have tested the make file using GNU make 3.79.1 on Windows 2k and with GNU make 3.77 on Windows NT; it may fail with other versions of GNU make or with other make utilities or on other operating systems (though I believe it should work fine on Linux, too). If the make file fails and doesn't build any executable named "adabrowse", the source distribution can, as a last resort, also be compiled using the commands 

       make adabrowse

    or 

       gcc -c -O2 util-nl.c
   gnatmake -O2 adabrowse -largs -lasis

    Both will build an AdaBrowse using "gcc" as the default compiler name and not having project manager support.

    If the make fails, and you're sure you did everything correctly, I'd like to know about it so that I can try to figure out what went wrong and correct the make file. See "Reporting Bugs" below. I'll need to know your operating system, make version, GNAT version, ASIS version, AdaBrowse version, the command you used to run the make file, and your complete environment (all environment variables and their values), and a valid e-mail address of yours.

    (Although, if you're using the ancient GNU make 3.77, I'd much rather you upgrade to GNU make 3.79.1. Version 3.77 has just too many bugs, and I don't know why it is in the GNAT 3.15p distribution. 3.79.1 has been out for quite some time... Windows users can get an executable of an up-to-date GNU make (3.79.1 or 3.80, although I have no idea how stable the 3.80 version is -- I don't have it, and I didn't test with it) from the MinGW site.)

    12. Rebuilding from sources for other compilers (not GNAT)

    The procedure is basically the same:

    1. Get and install an ASIS implementation for your compiler.

    2. Verify that the compiler can find and use the ASIS library.

    3. Watch out for implementation-defined ASIS features used in AdaBrowse:

      • GNAT-specific pragmas License on all units. These may cause compilation warnings when compiled with some compiler other than GNAT.

      • Implementation-defined options passed to Asis.Ada_Environments.Associate in file adabrowse.adb.

      • ASIS-for-GNAT-specific exception handling in adabrowse.adb.

      • AdaBrowse uses GNAT.Os_Lib in a few places. You'll need to replace that as appropriate in files util-pathes.adb and in ad-file_ops.ad[bs].

      • Make sure package AD.Projects.Impl is a renaming of AD.Projects.Impl_No. (Your compiler most probably doesn't come with the GNAT project manager, I suppose.)

    4. Build the adabrowse application.

    If it doesn't work, you're on your own. I cannot maintain or support versions of AdaBrowse except the one I distribute myself. (If it doesn't work due to some bug in your ASIS implementation, and you can find a simple work-around, and that work-around doesn't break the latest version of AdaBrowse for GNAT, I'm willing to incorporate your bug fix. But otherwise, I won't deal with such problems.)

    13. Testing

    I have tested AdaBrowse with ASIS-for-GNAT 3.15p and 3.16a, using the test files in subdirectory ./simple_test and a large (some 56 ada specs) subsystem containing a pretty complex data structure library of mine. (The Generic Ada Library GAL, of which some files are included in this distribution. I'll publish that when I have done some more testing.).

    For these tests, I have checked the generated HTML with Netscape 4.76, MS IE 5.0, and Mozilla 1.4, and it is rendered reasonably by all three.

    I have also run AdaBrowse over the following, large libraries:

    • adabindx 0.7.2,
    • the ASIS-for-GNAT 3.14p sources,
    • a subset (all the as[go]c*.ads) of Corey Minyard's ASL (asl-1.4),
    • Simon Wright's Booch Components (bc-20010819),
    • Matthew Heaney's charles (20020228),
    • RR Software's CLAW 1.3 Introductory Edition,
    • GtkAda 2.0.0,
    • Mats Weber's components (except those files GNAT 3.14p failed or crashed upon),
    • Ted Dennison's OpenToken 3.0b,
    • J. Carter's pragmarc (from 01-DEC-2001),
    • Stephen Leake's SAL 1.03,
    • TASH 8.3.2a,
    • Gautier de Montmollin's UnzipAda 0.9,
    • Stephen Leake's Windex 1.06,
    • The complete Ada 95 standard library and the run-time library of GNAT, and
    • XML/Ada 0.7.1.

    AdaBrowse handles all of these without problems, and I didn't see any obvious problems in a cursory inspection of some of the generated HTML files. All of the generated files have been checked to comply to the "HTML 4.01 Transitional" DTD.

    Version 3.0 of AdaBrowse is the result of a major rewrite of the complete output part of AdaBrowse. It has been regression tested by comparing it against the output of V2.13 for all the above test subsystems. The only differences found are either small layout improvements of V3.0 over V2.13, or are due to the improved cross-reference generation of V3.0 for implicitly inherited items and items from instantiations of nested generics, which actually came out wrong in V2.13.

    The new indices of V4.0 have been cross-checked against the old indices of V3.4.2; no significant differences were found.

    The new XML output of V3.4 (and also of V4.0) has been verified to comply to the DTD contained in the distribution using Xerces 2.0.0.

    14. Known Problems

    1. If AdaBrowse runs an external command, and that command does not terminate, AdaBrowse will be blocked, too.

    2. Both Netscape and MS IE sometimes produce an extra line at the end of a preformatted block. I.e. the HTML fragment

      <PRE>This is some code.</PRE>
      Followed by other text.

      is rendered as 

      This is some code.
      Followed by other text.

      As a result, most code chunks put into the generated HTML page have such a trailing empty space, which sometimes makes the layout a bit awkward.

      This is a problem with the browsers' rendering of HTML. There's nothing whatsoever in the HTML 4.0 spec that would justify this empty space. But there's also nothing I can do about it.

    3. If you use the -all option, comments after a library-level subprogram or generic instantiation or generic renaming are found only for the top unit but not for the other units. This is due to a problem in ASIS-for-GNAT, which somehow doesn't seem to give access to these source lines.

    4. ASIS-for-GNAT only finds the "known child units" if their tree files exist and can be found. Hence, if you let AdaBrowse generate the tree files on the fly, you'll generally not see any known child units. However, if you generate the tree files for all units and then run AdaBrowse, ASIS will find them, and AdaBrowse can generate a meaningful section for the known child units.

    5. In some rare cases, AdaBrowse may fail to generate completely accurate cross-references. This is caused by bugs in ASIS-for-GNAT, in particular in the area of formal packages. I do my best to work around these bugs and try hard to generate cross-references that point at least to the correct file, but in some cases, the source position returned by ASIS is bogus, and there's nothing I can do about that. However, these cases are so rare that you'll most probably not even notice them. If you notice wrong or missing cross-references, check the HTML source generated. If it contains a comment just before the suspicious place saying something about an ASIS failure, the cross-reference is wrong or missing because of a known ASIS problem, and it's no use reporting this as a bug.

    6. Not really a problem, but I've been asked whether I'd produce a version of AdaBrowse for Ada 83. No, I won't, for I have neither an Ada 83 compiler nor an Ada 83 ASIS implementation. However, GNAT has an option -gnat83 which makes it compile using the Ada 83 rules. If it still can generate tree files when this option is set, and if ASIS-for-GNAT can work with such tree files, then AdaBrowse also will work. (I didn't try it!) Hence I see no pressing need for a special Ada 83 version of AdaBrowse.

    7. AdaBrowse won't work (yet) with the FSF GNAT in gcc-3.1. The problem is that there is currently no ASIS implementation for that compiler. Since AdaBrowse uses ASIS, there needs to be an ASIS for the FSF GNAT to make AdaBrowse work with it. Once there'll be such an ASIS, it'll be a simple matter of recompiling AdaBrowse to get it to work with the FSF GNAT. (I do not know what ACT's plans in that respect are. I hope they'll put their ASIS-for-GNAT into the FSF CVS tree once gcc-3.1 has stabilized and is out. If they don't, I fear somebody will have to write an ASIS implementation for the FSF GNAT.)

    8. Not a problem: I've been asked whether I'd agree to have AdaBrowse put into the FSF CVS repository (and, supposedly, into the FSF GNAT distribution). I have no objections, but again, there needs to be an ASIS for the FSF GNAT first.

    15. License

    AdaBrowse is copyright © 2002-2003 by Thomas Wolf <twolf@acm.org>.

    AdaBrowse is free software; you may redistribute it and/or modify it under the terms of the GNU General Public License as published by the Free Software Foundation; either version 2, or (at your option) any later version.

    AdaBrowse is distributed in the hope that it will be useful, but without any warranty; without even the implied warranty of merchantability or fitness for a particular purpose. See the GNU General Public License for more details. You should have received a copy of the GNU General Public License with this distribution; see file GPL.txt. If not, write to the Free Software Foundation, 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA or try the URL http://www.gnu.org/licenses/gpl.html.

    Some of the sources (all the gal*.ad?) files are part of a not-yet-released library of mine; these are subject to the "GNAT modified GPL" (GMGPL), which is the GPL but explicitly allows using these units without causing such use to make the using executable automatically fall under the GPL.

    All the util*.ad? files are an extract of my Util subsystem available at the URL http://home.tiscalinet.ch/t_wolf/tw/ada95/util/. These, too, are covered by the GMGPL.

    16. Reporting Bugs and Enhancements

    Send bug reports and enhancement propsals to <twolf@acm.org>. Use a subject line containing the text "AdaBrowse".

    For bug reports, I need:

    • Your complete system setup: OS, GNAT version, ASIS-for-GNAT version, AdaBrowse version, settings of environment variables such as ADA_INCLUDE_PATH and ADA_OBJECTS_PATH.

    • The complete sources on which the problem is shown. Preferrably reduced to the minimum necessary and in gnatchop format! (Not the AdaBrowse sources [I have those :-)], but the ones you tried to run AdaBrowse on!)

      If the error occurs on sources from a publicly available, downloadable library, you may also just send me a link to the download location and tell me which file causes troubles.

      I can also handle .zip, .tar.gz, .gz, and .bz2 files. Any other funny compression or encoding will not be accepted.

    • Any configuration files and style sheets used.

    • The exact command and/or shell script you used for calling AdaBrowse.

    • All output produced by AdaBrowse: HTML files, error and warning messages on stderr, etc.

    • A clear, precise, and comprehensible description of the error (what you think is wrong) in English (or, if you prefer, in German or French).

    • A valid e-mail address of yours, so that I can contact you if necessary.

    I can only maintain the AdaBrowse version I distribute myself. See above for AdaBrowse adapted to work with other compilers.

    Copyright © 2002-2005 by Thomas Wolf. All rights reserved.
    TW, Nov 18, 2003
    adabrowse_4.0.3/doc/adabrowse_dtd_1_0.html0000644000175000017500000003157610234241455016573 0ustar kenken AdaBrowse DTD 1.0

    AdaBrowse DTD 1.0

    		 
    
<!--
This file is part of AdaBrowse.

Copyright © 2002-2005 by Thomas Wolf.

AdaBrowse is free software; you can redistribute it and/or modify it
under the terms of the  GNU General Public License as published by the
Free Software  Foundation; either version 2, or (at your option) any
later version. AdaBrowse is distributed in the hope that it will be
useful, but without any warranty; without even the implied warranty
of merchantability or fitness for a particular purpose. See the GNU
General Public License for  more details. You should have received a
copy of the GNU General Public License with this distribution, see file
"GPL.txt". If not, write to the

  Free Software Foundation
  59 Temple Place - Suite 330
  Boston, MA 02111-1307
  USA.

Author:
   Thomas Wolf

Purpose:
   XML 1.0 Document Type Definition for AdaBrowse XML files.

Version:
   AdaBrowse DTD 1.0 (generated by AdaBrowse 3.0 up to and including 3.3).

   Newer versions:
      AdaBrowse DTD 1.1 generated by AdaBrowse 3.4 up to 3.4.2.
        (The difference is minor; there's a new attribute PRIVATE for the UNIT and CHILD elements.)
      AdaBrowse DTD 2.0 generated by AdaBrowse 4.0.
        (Includes indices.)

Revision History

   20-AUG-2002   TW  Initial version.
   28-AUG-2002   TW  Corrections in cross-references.
-->

<!ENTITY % pure   "#PCDATA|KEYWORD|ATTRIBUTE|XREF|LITERAL" >
<!ENTITY % inline "%pure;|ANCHOR|COMMENT|CODE" >

<!ENTITY % lib_no_container
   "A_PROCEDURE |
    A_FUNCTION |
    A_GENERIC_PROCEDURE |
    A_GENERIC_FUNCTION |
    A_PACKAGE_INSTANTIATION|
    A_PROCEDURE_INSTANTIATION |
    A_FUNCTION_INSTANTIATION |
    A_PACKAGE_RENAMING |
    A_PROCEDURE_RENAMING |
    A_FUNCTION_RENAMING |
    A_GENERIC_PACKAGE_RENAMING |
    A_GENERIC_PROCEDURE_RENAMING |
    A_GENERIC_FUNCTION_RENAMING" >

<!ENTITY % lib_container
   "A_PACKAGE |
    A_GENERIC_PACKAGE |
    A_GENERIC_SIGNATURE_PACKAGE" >

<!ENTITY % no_lib_no_container
   "A_PRAGMA |
    A_USE_CLAUSE |
    A_USE_TYPE_CLAUSE |
    A_TYPE |
    A_SUBTYPE |
    A_VARIABLE |
    A_CONSTANT |
    A_DEFERRED_CONSTANT |
    AN_OBJECT_RENAMING |
    AN_EXCEPTION_RENAMING |
    AN_ENTRY |
    A_PROTECTED_PROCEDURE |
    A_PROTECTED_FUNCTION |
    AN_EXCEPTION" >

<!ENTITY % no_lib_container
   "A_TASK_TYPE |
    A_PROTECTED_TYPE |
    A_TASK |
    A_PROTECTED_OBJECT" >

<!ENTITY % boolean
   "FALSE | TRUE" >

<!ENTITY % lib "%lib_no_container; | %lib_container;" >

<!ENTITY % container "%lib_container; | %no_lib_container;" >

<!ENTITY % no_container "%lib_no_container; | %no_lib_no_container; | A_TASK_TYPE | A_TASK" >
<!-- Tasks and task types can also appear as items. -->

<!-- Inline elements -->

<!ELEMENT KEYWORD (#PCDATA) >

<!ELEMENT ATTRIBUTE (#PCDATA) >

<!ELEMENT LITERAL (#PCDATA) >

<!ELEMENT CODE (%inline;)* >

<!ELEMENT XREF (#PCDATA|LITERAL|KEYWORD)* >
<!-- Actually, I'd like to specify that an XREF may contain either
     PCDATA, or a LITERAL, or a KEYWORD. It cannot contain PCDATA with
     interspersed LITERALs and KEYWORDs (which is what the above spec
     really says). However, there is *no* way in XML 1.0 to specify this!

     Literals and keywords are allowed within an XREF because of operators
     such as "&" or "or". -->

<!ATTLIST XREF
          UNIT     CDATA       #REQUIRED
          POS      CDATA       #REQUIRED
          IS_TOP   (%boolean;) "FALSE"
          IS_LOCAL (%boolean;) "FALSE">
<!-- XREFs always contain the Unit, even if the cross-reference is local.
     Local cross-references have IS_LOCAL="TRUE". Cross-references to
     other compilation UNITs have IS_TOP="TRUE". -->

<!ELEMENT ANCHOR (%pure;)* >
<!ATTLIST ANCHOR
          UNIT   CDATA       #REQUIRED
          POS    CDATA       #REQUIRED
          IS_TOP (%boolean;) "FALSE">
<!-- ANCHORs always are local, so Unit always will equal the Name of the
     enclosing compilation UNIT. It is still explicitly repeated in each
     anchor to facilitate processing: there's no need to go look up the
     enclosing UNIT's name. Is_Top is TRUE only for the anchor on that
     compilation unit's name. -->

<!-- Note: I briefly considered using attribute types ID and IDREF for
     ANCHORS and XREFs, respectively. However, that wouldn't have worked,
     for any IDREF must correspond to some ID in the XML; but our XML may
     contain references to units in other files. -->

<!ELEMENT COMMENT (%pure;|ANCHOR|CODE)* >
<!-- Comments cannot be nested -->

<!-- Block elements -->

<!ELEMENT UNIT (DEPENDENCIES?, DESCRIPTION?, (CONTAINER|ITEM)) >
<!ATTLIST UNIT
          NAME  CDATA   #REQUIRED
          KIND  (%lib;) #REQUIRED
          POS   CDATA   #IMPLIED>
<!-- Name and Kind of a UNIT can be used to generate indices. Pos can be
     used for cross-reference purposes; it is the position on the unit's
     CONTAINER's or ITEM's defining name. -->

<!ELEMENT ITEM (SNIPPET, DESCRIPTION?) >
<!ATTLIST ITEM
          NAME  CDATA            #IMPLIED
          KIND  (%no_container;) #IMPLIED
          UNIT  CDATA            #IMPLIED
          POS   CDATA            #IMPLIED>
<!-- Name and Kind of an Item can be used to generate indices.  Unit and
     Pos can be used for cross-reference purposes; it is the position on
     the item's defining name. -->

<!ELEMENT SNIPPET (LINE)+ >
<!-- Used for code snippets. Implies <CODE> -->

<!ELEMENT LINE    (%inline;)* >

<!ELEMENT DESCRIPTION (BLOCK)+ >
<!ELEMENT BLOCK       (LINE)+ >

<!ELEMENT DEPENDENCIES (SNIPPET, DESCRIPTION?) >

<!ELEMENT CONTAINER    (HEADER, CONTENT?, FOOTER) >
<!ATTLIST CONTAINER
          NAME  CDATA         #IMPLIED
          KIND  (%container;) #IMPLIED
          UNIT  CDATA         #IMPLIED
          POS   CDATA         #IMPLIED>
<!-- Name and Kind of a CONTAINER can be used to generate indices. Unit and
     Pos can be used for cross-reference purposes; it is the position on the
     container's defining name. -->

<!ELEMENT HEADER  (LINE)* >

<!ELEMENT FOOTER  (LINE)* >

<!ELEMENT CONTENT  (TOP_ITEM?, CHILDREN?, EXCEPTIONS?, TYPE_SUMMARY?,
                    CONSTANTS?, VARIABLES?, OTHERS?, PRIVATE?) >

<!ELEMENT TOP_ITEM (SNIPPET?, DESCRIPTION?) >

<!ELEMENT CHILDREN (CHILD)+ >

<!ELEMENT CHILD (#PCDATA|XREF)* >
<!-- Actually, I'd like to specify that a CHILD may contain either
     PCDATA, or an XREF. It cannot contain PCDATA with interspersed XREFs
     (which is what the above spec really says). However, there is *no* way
     in XML 1.0 to specify this! -->

<!ATTLIST CHILD
          NAME  CDATA   #IMPLIED
          KIND  (%lib;) #IMPLIED>

<!ELEMENT PRIVATE EMPTY >

<!ELEMENT EXCEPTIONS (EXCEPTION)+ >

<!ELEMENT EXCEPTION ((EXCEPTION_NAME)+, EXCEPTION_RENAME?, ULTIMATE_EXCEPTION?, DESCRIPTION?) >

<!ELEMENT EXCEPTION_NAME (#PCDATA|ANCHOR)* >
<!-- Actually, I'd like to specify that an EXCEPTION_NAME may contain either
     PCDATA, or an ANCHOR. It cannot contain PCDATA with interspersed ANCHORDs
     (which is what the above spec really says). However, there is *no* way in
     XML 1.0 to specify this! -->

<!ELEMENT EXCEPTION_RENAME (%inline;)*>

<!ELEMENT ULTIMATE_EXCEPTION (%inline;)*>

<!ELEMENT OTHERS (CONTAINER|ITEM|PRIVATE)+ >

<!ELEMENT CONSTANTS (ITEM)+ >

<!ELEMENT VARIABLES (ITEM)+ >

<!ELEMENT TYPE_SUMMARY (TYPE)+ >

<!ELEMENT TYPE (TYPE_NAME, TYPE_KIND?, PARENT_TYPE?, OPERATIONS?) >

<!ELEMENT TYPE_NAME (#PCDATA|XREF)* >
<!-- Actually, I'd like to specify that a TYPE_NAME may contain either
     PCDATA, or an XREF. It cannot contain PCDATA with interspersed XREFs
     (which is what the above spec really says). However, there is *no* way
     in XML 1.0 to specify this! -->

<!ELEMENT TYPE_KIND (#PCDATA)>

<!ELEMENT PARENT_TYPE (#PCDATA|XREF)* >
<!-- Actually, I'd like to specify that a PARENT_TYPE may contain either
     PCDATA, or an XREF. It cannot contain PCDATA with interspersed XREFs
     (which is what the above spec really says). However, there is *no* way
     in XML 1.0 to specify this! -->

<!ELEMENT OPERATIONS (OPLIST)+ >

<!ELEMENT OPLIST (XREF)+ >
<!ATTLIST OPLIST
          KIND (OVERRIDDEN|OWN|INHERITED) #REQUIRED>

<!-- Document root -->

<!ELEMENT ADABROWSE (UNIT)+ >
    Copyright © 2002-2005 by Thomas Wolf. All rights reserved.
    TW, May 30, 2003
    adabrowse_4.0.3/doc/versions.html0000644000175000017500000005024010234241455015167 0ustar kenken AdaBrowse Version History

    AdaBrowse Version History
    VersionDateDescription
    4.0.3 22-Feb-2005 Three minor bug fixes:
    • Description.Library = Inside works now correctly.
    • Indices honor Index_XRef (again).
    • The Makefile should work now even if the current directory is not in the PATH. (Uses ./get_gcc now.)
    4.0.2 19-Nov-2003

    New -X option for definition of "environment" variables. (As in GNAT.)

    Code clean-up: added license pragmas (GNAT specific) to all units; separated some purely ASIS stuff into a new Asis2 subsystem, which is GMGPL'ed and intended for separate release.

    Correction in the Makefile to split $PATH correctly on Unix, where the path separator is ':', not ';'!

    4.0.1 22-Aug-2003

    Minor improvement in the generated HTML: width specification for indentation table cells is now relative ("2%") instead of absolute (10). Solves a minor display problem on IE 5.0.

    4.0 11-Jul-2003

    New major feature: AdaBrowse supports now the GNAT project manager, including naming schemes defined in project files! Requires GNAT 3.15p or later. If built from the sources, project file support will only be included if compiled with GNAT 3.15p or later and the compiler sources are available.

    Major overhaul of the index generation part of AdaBrowse. Newly, indices can be defined by the user using expressions of boolean predicates to define what goes into an index.

    3.4.2 26-Jun-2003

    Work-around for yet another bug in ASIS: the transitive closure of "with"es (used when the "-all was given on the command-line) returned by ASIS-for-GNAT 3.16a doesn't contain implicitly "with"ed parents of explicitly "with"ed child units. AdaBrowse now compensates for this bug.

    3.4.1 07-Jun-2003

    Work-around for yet another bug in ASIS: the text span returned by ASIS-for-GNAT for private type declarations with more than one discriminant ends at the first semicolon, i.e. after the first discriminant. AdaBrowse now compensates for this bug.

    Improved handling of casing in unit indices (including the "known children" section of parent units). If the source contained inconsistent casing, this could re-appear in these indices, although AdaBrowse tries hard to make casing consistent everywhere.

    By default, AdaBrowse no longer processes the private parts of task and protected declarations. Use the "-private" command-line option to make it process them. (AdaBrowse always processes private compilation units, though. This is on purpose: if you ask it to process such a unit, you most probably have a good reason to do so, and I don't like tools second-guessing the user's intentions.)

    General minor code clean-up.

    3.4 30-May-2003

    Correction in AdaBrowse and work-around for yet another bug in ASIS-for-GNAT so that the "private" keyword in private compilation unit declarations is no longer swallowed. Also added a new PRIVATE boolean attribute to the UNIT and CHILD elements in the generated XML; bumped the DTD version to 1.1. Made corresponding documentation changes.

    Version number changed to 3.4 instead of 3.3.1 because of the change in the DTD.

    3.3 28-Apr-2003

    Minor changes to work around a bug in GNAT 3.16a and another bug in ASIS-for-GNAT 3.16a.

    ASIS-for-GNAT 3.16a claims in its version string to be an ASIS for GNAT 5.00 (which is the (forthcoming) gcc 3.x-based GNAT). However, the ASIS library only checks the version of the tree file, it no longer requires the compiler version to match the ASIS library version exactly.

    The only reason for incrementing the version number to 3.3 instead of 3.2.1 is the fairly long time (five months) between these two versions.

    3.2 26-Nov-2002

    Change in the global type index; contains now also subtypes.

    New command line option "-private" for making AdaBrowse process the private parts of packages, too.

    AdaBrowse 3.2 is the first version for GNAT 3.15p.

    3.1 11-Nov-2002

    Minor correction in associating comments with "use" or "use type" clauses: the key Description.Clause newly applies only to interior clauses; a new key Description.Context_Clause governs finding descriptions for the context clauses as a whole.

    Also corrected the documentation: it had "Description.Clauses" instead of "Description.Clause" (singular).

    3.0 30-Aug-2002

    Complete refactoring of the output part of AdaBrowse. Previously, tree traversals and output generation were intermingled; now they're cleanly separated, which opens the way to the next major improvement:

    AdaBrowse now not only can generate HTML output, but also XML output! There's a DTD for this XML in the distribution. The generated XML can then be further processed by whatever tool you like, and it can be parsed by any XML 1.0 compliant off-the-shelf XML parser. The XML file contains all the structure and information found in the HTML output, including all cross-references. Hence, to generate documentation in e.g. docbook or texinfo format, use AdaBrowse to generate XML, and then generate your favorite format from that. Saves you the trouble of having to write an Ada 95 parser, and saves me the trouble of having to provide a potentially unbounded set of special-purpose formatters for any imaginable output format.

    Minor improvements in cross-reference generation for implicitly inherited subprograms and enumeration literals; the cross-reference newly goes to the explicit declaration (if there is one) the item is inherited from. Also improved cross-references to items in generic instantiations, which now can point to the corresponding item from the generic template even in the case of nested generics.

    Cross-references in HTML now by default use both the line and the column number, whereas previous versions only used the line number. Warning: this makes HTML files generated by AdaBrowse 3.0 incompatible with files generated by earlier versions! To get the old, line-number-only behavior, use the new command-line option -l.

    Bug correction in the handling of the Path and the [No_]XRef and Include/Exclude keys, which contrary to the documentation just ignored later definitions for the same unit prefix. Now they all honor the last definition for any particular prefix.

    2.13 09-July-2002 Minor code clean-up; as well as a minor change to the [No_]XRef and Include/Exclude keys, which now do longest prefix matching on the unit names.
    2.12 04-July-2002

    The generated HTML files now include a default style specification that can be overridden by style rules in an external style sheet specified by a "-s" command-line option or the Style_Sheet key in a configuration file.

    New configuration file keys XRef and Include to specify exceptions to the sets of units defined by the No_XRef and Exclude keys.

    2.11 03-July-2002

    Minor correction in the "Path" keys in configuration files (2.1 had a bug making this work only if the unit name prefix was all lowercase.)

    New command line option "-g" and config file key "Refs_To_Standard" to make AdaBrowse generate cross-refences to items from the standard library.

    Major speed-up: previous versions opened and closed ASIS contexts each and every time. Newly, this is only done if a recompilation was necessary. (ASIS-for-GNAT seems to have a huge memory leak when a context is closed.)

    2.1 01-July-2002

    Major re-haul of the formatting of descriptions:

    • Introduction of parameters for user-defined HTML mark-up, i.e. user-defind tags may now have attributes, which can be referenced in the replacement.
    • Addition of user-defineable formatting rules, which in the extreme make it possible to completely replace the default formatting (by running an external command).

    Also, generally cleaned up the formatting code and corrected a few problem cases in HTML generation (such as superfluous or even plain wrongly placed <P> tags, or character entities given in hexadecimal format, or a typo which made AdaBrowse emit a MTEA tag instead of a META tag, or a new <!DOCTYPE element, which uses "W3C" instead of "IETF" now and specifies "HTML 4.01 Transitional" instead of "HTML 4.0").

    Some re-factoring and speed optimizations (the latter both within AdaBrowse and also for typical loading of the generated HTML pages: previous versions enclosed descriptions in yet another table, V3.0 now uses a DIV element for the same purpose, which usually renders faster than a table).

    Restructured a large part of the User's Guide.

    2.01 03-May-2002 Code clean-up and minor improvement of environment variable substitution.
    2.0 02-May-2002

    AdaBrowse now supports user-defined HTML mark-up: you can define your own tags! See the user's guide for more information.

    AdaBrowse now does environment variable substitution on some entries in configuration files, and one configuration file may now include another one.

    1.61 26-Apr-2002 Another work-around for a bug in ASIS-for-GNAT, which sometimes crashes on generic parameter associations in an instantiation, if named notation is chosen and the formal parameter name is an operator symbol.
    1.6 24-Apr-2002

    Minor change in the algorithm for finding descriptions such that it properly handles trailing comments, too.

    Also, if AdaBrowse is running in file input mode and the -all option was given, previous versions processed units referenced by several units multiple times, causing warnings if -x was given and also causing these multiply processed units to appear multiple times in the indices. This has been corrected now; any unit in a run of AdaBrowse will be processed at most once.

    Finally, yet another work-around for yet another bug in ASIS-for-GNAT, which returns bogus information of "String" in "Some_Const : constant String := ...".

    1.51 08-Apr-2002

    Code clean-up such that gcc -gnatwa -gnaty3abefhiklmprt is silent. (The style checks are the same as plain -gnaty, but without -gnatyc and -gnatys because I don't like these.)

    Also, replaced the license on the gal*.* and util*.* units: these no longer use the Ada Community License (the one the Booch components use) but the GNAT modified GPL. See the user's guide for comments.

    1.5 03-Apr-2002

    New options "-p" and "-t" to generate subprogram and type indices (global, over all units processed).

    Also, a minor correction in the generation of structured indices to correctly handle cases where child units without their parents appear in the index.

    1.4 26-Mar-2002 AdaBrowse can now handle unit specifications given by krunched file names. See the user's guide for more information.
    1.36 25-Mar-2002

    Another work-around for a bug in ASIS-for-GNAT 3.14p: ASIS goes into an endless loop (or blocks otherwise) on the source "pragma Inline ("&");" if the operator references more than one function, and some of these functions are predefined operators. The work-around in AdaBrowse is never to try to generate a cross-reference for operators in pragmas.

    Also corrected a layout error in the generated HTML for task types without task definition as in "task type X (A : Integer);".

    1.35 21-Mar-2002 Bug-fix in finding the primitive operations: AdaBrowse failed sometimes with an exception.
    1.34 20-Mar-2002 Another work-around for a bug in ASIS-for-GNAT 3.14p: ASIS fails on record components having a type specified with an attribute, as in "record X : Integer'Base; end record;".
    1.33 19-Mar-2002 Bug fix: AdaBrowse crashed on object renaming declarations.
    1.32 18-Mar-2002

    AdaBrowse newly replaces pairs of "@" without white-space in between by the HTML tags <CODE> and </CODE>, respectively. Hence one can use "@Some_Var@" as a shortcut for "<CODE>Some_Var</CODE>" in an Ada comment. See the user's guide for more information.

    AdaBrowse now allows line comments starting with "#" in the input file in file input mode.

    Improved the User's Guide, especially section 5.3.

    Bug correction: if a comment contains a "&" that already is the start of a named character entity (e.g. "&lt;", or "&#34;"), then do not replace the "&" by "&amp;".

    1.31 15-Mar-2002 -i and -is now optionally take a filename argument specifying the filename of the index; "-" makes it write the index to stdout.
    1.3 14-Mar-2002 Uses some packages from my Util subsystem now. As a result, configuration file syntax has changed slightly (it allows now trailing comments on a line, and also supports line continuations.) Also extended the -f and -o options for the new "file input mode". Also added -i and -is options for index generation.
    1.21 05-Mar-2002 Some improvements in finding primitive operations, as well a work-around for yet another bug in ASIS-for-GNAT 3.14p.
    1.2 26-Feb-2002 AdaBrowse now takes apart the source completely. First "fully javadoc-like" version.
    1.1 06-Feb-2002 Internal version, never released. Major code clean-up. New options -q and -x, many new keys in configuration files for customizing cross-reference generation and finding descriptions.
    1.01 04-Feb-2002 Improved error message, added -a/-all/--all option, tries to create tree files (by calling GNAT) if initially opening the library unit failed. I.e. it is no longer necessary to create the tree files by hand! AdaBrowse can do it for you now.
    1.0 02-Feb-2002 Initial public release
    Copyright © 2002-2005 by Thomas Wolf. All rights reserved.
    TW, Feb 22, 2005
    adabrowse_4.0.3/doc/adabrowse_dtd_1_1.html0000644000175000017500000003217310234241455016566 0ustar kenken AdaBrowse DTD 1.1

    AdaBrowse DTD 1.1

    		 
    
<!--
This file is part of AdaBrowse.

Copyright © 2002-2005 by Thomas Wolf.

AdaBrowse is free software; you can redistribute it and/or modify it
under the terms of the  GNU General Public License as published by the
Free Software  Foundation; either version 2, or (at your option) any
later version. AdaBrowse is distributed in the hope that it will be
useful, but without any warranty; without even the implied warranty
of merchantability or fitness for a particular purpose. See the GNU
General Public License for  more details. You should have received a
copy of the GNU General Public License with this distribution, see file
"GPL.txt". If not, write to the

  Free Software Foundation
  59 Temple Place - Suite 330
  Boston, MA 02111-1307
  USA.

Author:
   Thomas Wolf

Purpose:
   XML 1.0 Document Type Definition for AdaBrowse XML files.

Version:
   AdaBrowse DTD 1.1 (generated by AdaBrowse 3.4).
    

   Earlier versions:
      AdaBrowse DTD 1.0 generated by AdaBrowse 3.0 up to 3.3.
        (Has no PRIVATE attribute for the UNIT and CHILD elements.)

   Newer versions:
      AdaBrowse DTD 2.0 generated by AdaBrowse 4.0.
        (Includes indices.)

Revision History

   20-AUG-2002   TW  Initial version.
   28-AUG-2002   TW  Corrections in cross-references.
   30-MAY-2003   TW  Added private attributes to UNIT and CHILD elements.
-->

<!ENTITY % pure   "#PCDATA|KEYWORD|ATTRIBUTE|XREF|LITERAL" >
<!ENTITY % inline "%pure;|ANCHOR|COMMENT|CODE" >

<!ENTITY % lib_no_container
   "A_PROCEDURE |
    A_FUNCTION |
    A_GENERIC_PROCEDURE |
    A_GENERIC_FUNCTION |
    A_PACKAGE_INSTANTIATION|
    A_PROCEDURE_INSTANTIATION |
    A_FUNCTION_INSTANTIATION |
    A_PACKAGE_RENAMING |
    A_PROCEDURE_RENAMING |
    A_FUNCTION_RENAMING |
    A_GENERIC_PACKAGE_RENAMING |
    A_GENERIC_PROCEDURE_RENAMING |
    A_GENERIC_FUNCTION_RENAMING" >

<!ENTITY % lib_container
   "A_PACKAGE |
    A_GENERIC_PACKAGE |
    A_GENERIC_SIGNATURE_PACKAGE" >

<!ENTITY % no_lib_no_container
   "A_PRAGMA |
    A_USE_CLAUSE |
    A_USE_TYPE_CLAUSE |
    A_TYPE |
    A_SUBTYPE |
    A_VARIABLE |
    A_CONSTANT |
    A_DEFERRED_CONSTANT |
    AN_OBJECT_RENAMING |
    AN_EXCEPTION_RENAMING |
    AN_ENTRY |
    A_PROTECTED_PROCEDURE |
    A_PROTECTED_FUNCTION |
    AN_EXCEPTION" >

<!ENTITY % no_lib_container
   "A_TASK_TYPE |
    A_PROTECTED_TYPE |
    A_TASK |
    A_PROTECTED_OBJECT" >

<!ENTITY % boolean
   "FALSE | TRUE" >

<!ENTITY % lib "%lib_no_container; | %lib_container;" >

<!ENTITY % container "%lib_container; | %no_lib_container;" >

<!ENTITY % no_container "%lib_no_container; | %no_lib_no_container; | A_TASK_TYPE | A_TASK" >
<!-- Tasks and task types can also appear as items. -->

<!-- Inline elements -->

<!ELEMENT KEYWORD (#PCDATA) >

<!ELEMENT ATTRIBUTE (#PCDATA) >

<!ELEMENT LITERAL (#PCDATA) >

<!ELEMENT CODE (%inline;)* >

<!ELEMENT XREF (#PCDATA|LITERAL|KEYWORD)* >
<!-- Actually, I'd like to specify that an XREF may contain either
     PCDATA, or a LITERAL, or a KEYWORD. It cannot contain PCDATA with
     interspersed LITERALs and KEYWORDs (which is what the above spec
     really says). However, there is *no* way in XML 1.0 to specify this!

     Literals and keywords are allowed within an XREF because of operators
     such as "&" or "or". -->

<!ATTLIST XREF
          UNIT     CDATA       #REQUIRED
          POS      CDATA       #REQUIRED
          IS_TOP   (%boolean;) "FALSE"
          IS_LOCAL (%boolean;) "FALSE">
<!-- XREFs always contain the Unit, even if the cross-reference is local.
     Local cross-references have IS_LOCAL="TRUE". Cross-references to
     other compilation UNITs have IS_TOP="TRUE". -->

<!ELEMENT ANCHOR (%pure;)* >
<!ATTLIST ANCHOR
          UNIT   CDATA       #REQUIRED
          POS    CDATA       #REQUIRED
          IS_TOP (%boolean;) "FALSE">
<!-- ANCHORs always are local, so Unit always will equal the Name of the
     enclosing compilation UNIT. It is still explicitly repeated in each
     anchor to facilitate processing: there's no need to go look up the
     enclosing UNIT's name. Is_Top is TRUE only for the anchor on that
     compilation unit's name. -->

<!-- Note: I briefly considered using attribute types ID and IDREF for
     ANCHORS and XREFs, respectively. However, that wouldn't have worked,
     for any IDREF must correspond to some ID in the XML; but our XML may
     contain references to units in other files. -->

<!ELEMENT COMMENT (%pure;|ANCHOR|CODE)* >
<!-- Comments cannot be nested -->

<!-- Block elements -->

<!ELEMENT UNIT (DEPENDENCIES?, DESCRIPTION?, (CONTAINER|ITEM)) >
<!ATTLIST UNIT
          NAME    CDATA       #REQUIRED
          KIND    (%lib;)     #REQUIRED
          PRIVATE (%boolean;) "FALSE"
          POS     CDATA       #IMPLIED>
<!-- Name and Kind of a UNIT can be used to generate indices. Pos can be
     used for cross-reference purposes; it is the position on the unit's
     CONTAINER's or ITEM's defining name. PRIVATE is "TRUE" if it's a
     private compilation unit. -->

<!ELEMENT ITEM (SNIPPET, DESCRIPTION?) >
<!ATTLIST ITEM
          NAME  CDATA            #IMPLIED
          KIND  (%no_container;) #IMPLIED
          UNIT  CDATA            #IMPLIED
          POS   CDATA            #IMPLIED>
<!-- Name and Kind of an Item can be used to generate indices.  Unit and
     Pos can be used for cross-reference purposes; it is the position on
     the item's defining name. -->

<!ELEMENT SNIPPET (LINE)+ >
<!-- Used for code snippets. Implies <CODE> -->

<!ELEMENT LINE    (%inline;)* >

<!ELEMENT DESCRIPTION (BLOCK)+ >
<!ELEMENT BLOCK       (LINE)+ >

<!ELEMENT DEPENDENCIES (SNIPPET, DESCRIPTION?) >

<!ELEMENT CONTAINER    (HEADER, CONTENT?, FOOTER) >
<!ATTLIST CONTAINER
          NAME  CDATA         #IMPLIED
          KIND  (%container;) #IMPLIED
          UNIT  CDATA         #IMPLIED
          POS   CDATA         #IMPLIED>
<!-- Name and Kind of a CONTAINER can be used to generate indices. Unit and
     Pos can be used for cross-reference purposes; it is the position on the
     container's defining name. -->

<!ELEMENT HEADER  (LINE)* >

<!ELEMENT FOOTER  (LINE)* >

<!ELEMENT CONTENT  (TOP_ITEM?, CHILDREN?, EXCEPTIONS?, TYPE_SUMMARY?,
                    CONSTANTS?, VARIABLES?, OTHERS?, PRIVATE?) >

<!ELEMENT TOP_ITEM (SNIPPET?, DESCRIPTION?) >

<!ELEMENT CHILDREN (CHILD)+ >

<!ELEMENT CHILD (#PCDATA|XREF)* >
<!-- Actually, I'd like to specify that a CHILD may contain either
     PCDATA, or an XREF. It cannot contain PCDATA with interspersed XREFs
     (which is what the above spec really says). However, there is *no* way
     in XML 1.0 to specify this! -->

<!ATTLIST CHILD
          NAME    CDATA       #IMPLIED
          KIND    (%lib;)     #IMPLIED
          PRIVATE (%boolean;) "FALSE">

<!ELEMENT PRIVATE EMPTY >

<!ELEMENT EXCEPTIONS (EXCEPTION)+ >

<!ELEMENT EXCEPTION ((EXCEPTION_NAME)+, EXCEPTION_RENAME?, ULTIMATE_EXCEPTION?, DESCRIPTION?) >

<!ELEMENT EXCEPTION_NAME (#PCDATA|ANCHOR)* >
<!-- Actually, I'd like to specify that an EXCEPTION_NAME may contain either
     PCDATA, or an ANCHOR. It cannot contain PCDATA with interspersed ANCHORDs
     (which is what the above spec really says). However, there is *no* way in
     XML 1.0 to specify this! -->

<!ELEMENT EXCEPTION_RENAME (%inline;)*>

<!ELEMENT ULTIMATE_EXCEPTION (%inline;)*>

<!ELEMENT OTHERS (CONTAINER|ITEM|PRIVATE)+ >

<!ELEMENT CONSTANTS (ITEM)+ >

<!ELEMENT VARIABLES (ITEM)+ >

<!ELEMENT TYPE_SUMMARY (TYPE)+ >

<!ELEMENT TYPE (TYPE_NAME, TYPE_KIND?, PARENT_TYPE?, OPERATIONS?) >

<!ELEMENT TYPE_NAME (#PCDATA|XREF)* >
<!-- Actually, I'd like to specify that a TYPE_NAME may contain either
     PCDATA, or an XREF. It cannot contain PCDATA with interspersed XREFs
     (which is what the above spec really says). However, there is *no* way
     in XML 1.0 to specify this! -->

<!ELEMENT TYPE_KIND (#PCDATA)>

<!ELEMENT PARENT_TYPE (#PCDATA|XREF)* >
<!-- Actually, I'd like to specify that a PARENT_TYPE may contain either
     PCDATA, or an XREF. It cannot contain PCDATA with interspersed XREFs
     (which is what the above spec really says). However, there is *no* way
     in XML 1.0 to specify this! -->

<!ELEMENT OPERATIONS (OPLIST)+ >

<!ELEMENT OPLIST (XREF)+ >
<!ATTLIST OPLIST
          KIND (OVERRIDDEN|OWN|INHERITED) #REQUIRED>

<!-- Document root -->

<!ELEMENT ADABROWSE (UNIT)+ >
    Copyright © 2002-2005 by Thomas Wolf. All rights reserved.
    TW, May 30, 2003
    adabrowse_4.0.3/doc/gal.css0000644000175000017500000000033410234241455013705 0ustar kenkenTABLE.title { background-color: #99CCFF; } TABLE.footer { background-color: #99CCFF; } .sample { background-color: #EEEEEE; } H2.toc { background-color: #99CCFF; } H3.toc { background-color: #99CCFF; } adabrowse_4.0.3/doc/adabrowse.css0000644000175000017500000000061710234241455015115 0ustar kenkenTABLE.title { background-color: #99CCFF } TABLE.footer { background-color: #99CCFF } TD.type { background-color: #CCEEFF } TD.odd { background-color: #99CCFF } TD.even { background-color: #CCEEFF } TD.code { background-color: #EEEEEE } SPAN.comment { color: red } SPAN.literal { color: green } SPAN.definition { color: purple } H3.subtitle { background-color: #CCEEFF } adabrowse_4.0.3/ad-html-pathes.ads0000644000175000017500000000366010234241442015165 0ustar kenken------------------------------------------------------------------------------- -- -- This file is part of AdaBrowse. -- -- Copyright (c) 2002 by Thomas Wolf. --
    -- AdaBrowse is free software; you can redistribute it and/or modify it -- under the terms of the GNU General Public License as published by the -- Free Software Foundation; either version 2, or (at your option) any -- later version. AdaBrowse is distributed in the hope that it will be -- useful, but without any warranty; without even the implied -- warranty of merchantability or fitness for a particular purpose. -- See the GNU General Public License for more details. You should have -- received a copy of the GNU General Public License with this distribution, -- see file "GPL.txt". If not, write to the Free -- Software Foundation, 59 Temple Place - Suite 330, Boston, MA 02111-1307, -- USA. --
    -- --
    -- Author:
    -- Thomas Wolf (TW) --
    twolf@acm.org
    -- --
    -- Purpose:
    -- Handling of "pathes": prefix URLs defined for cross-references.
    -- -- ------------------------------------------------------------------------------- pragma License (GPL); package AD.HTML.Pathes is pragma Elaborate_Body; procedure Add_Path (Key : in String; Value : in String); -- Key must be all lower-case. function Get_Path (Unit_Name : in String) return String; -- Returns the empty string if no key matches a prefix of Unit_Name. -- Otherwise, returns the value of the key matching the longest prefix -- of 'Unit_Name'. 'Unit_Name' must be all lower-case. end AD.HTML.Pathes; adabrowse_4.0.3/ad-messages.ads0000644000175000017500000000402610234241443014544 0ustar kenken------------------------------------------------------------------------------- -- -- This file is part of AdaBrowse. -- -- Copyright (c) 2002 by Thomas Wolf. --
    -- AdaBrowse is free software; you can redistribute it and/or modify it -- under the terms of the GNU General Public License as published by the -- Free Software Foundation; either version 2, or (at your option) any -- later version. AdaBrowse is distributed in the hope that it will be -- useful, but without any warranty; without even the implied -- warranty of merchantability or fitness for a particular purpose. -- See the GNU General Public License for more details. You should have -- received a copy of the GNU General Public License with this distribution, -- see file "GPL.txt". If not, write to the Free -- Software Foundation, 59 Temple Place - Suite 330, Boston, MA 02111-1307, -- USA. --
    -- --
    -- Author:
    -- Thomas Wolf (TW) --
    twolf@acm.org
    -- --
    -- Purpose:
    -- Output of warning and error messages.
    -- -- ------------------------------------------------------------------------------- pragma License (GPL); package AD.Messages is pragma Elaborate_Body; type Verbosity is (Only_Errors, Errors_And_Warnings, All_Messages, Including_Debug); procedure Set_Mode (To : in Verbosity); function Get_Mode return Verbosity; procedure Info (Msg : in String); procedure Warn (Msg : in String); procedure Error (Msg : in String); procedure Debug (Msg : in String); procedure Help_Text; type Error_Reporter is abstract tagged null record; procedure Report_Error (Self : in out Error_Reporter; Msg : in String) is abstract; end AD.Messages; adabrowse_4.0.3/ad-parse.adb0000644000175000017500000005274410234241451014037 0ustar kenken------------------------------------------------------------------------------- -- -- This file is part of AdaBrowse. -- -- Copyright (c) 2002 by Thomas Wolf. --
    -- AdaBrowse is free software; you can redistribute it and/or modify it -- under the terms of the GNU General Public License as published by the -- Free Software Foundation; either version 2, or (at your option) any -- later version. AdaBrowse is distributed in the hope that it will be -- useful, but without any warranty; without even the implied -- warranty of merchantability or fitness for a particular purpose. -- See the GNU General Public License for more details. You should have -- received a copy of the GNU General Public License with this distribution, -- see file "GPL.txt". If not, write to the Free -- Software Foundation, 59 Temple Place - Suite 330, Boston, MA 02111-1307, -- USA. --
    -- --
    -- Author:
    -- Thomas Wolf (TW) --
    twolf@acm.org
    -- --
    -- Purpose:
    -- Simplified Ada 95 parser. Parses the source until it finds the -- name of the library unit declaration. Note: this parser (and its -- scanner!) doesn't need to be hyper-fast, it'll only be used for -- krunched file names, and then parse the file only up to the -- unit name.
    -- -- ------------------------------------------------------------------------------- pragma License (GPL); with Ada.Strings.Maps; with Ada.Text_IO; with Util.Files.Text_IO; with Util.Strings; with Util.Text.Internal; pragma Elaborate_All (Util.Files.Text_IO); pragma Elaborate_All (Util.Text); package body AD.Parse is package UT renames Util.Text; ---------------------------------------------------------------------------- -- Scanning routines. This is a very simple, line-based scanner. Not -- particularly efficient, but does the job nicely. package Scanner is type Token is (Other_Token, Left_Paren_Token, Right_Paren_Token, Semicolon_Token, Period_Token, With_Token, Use_Token, Pragma_Token, Type_Token, Package_Token, Procedure_Token, Function_Token, Is_Token, New_Token, Return_Token, Private_Token, Generic_Token, Name_Token, String_Token); procedure Init (File_Name : in String); procedure Advance; function Current_Token return Token; function Image return UT.Unbounded_String; procedure Close; Scan_Error : exception; private pragma Inline (Current_Token); end Scanner; package body Scanner is use Util.Strings; F : Ada.Text_IO.File_Type; function Ada_Skip_String (S : in String; Delim : in Character) return Natural is begin return Skip_String (S, Delim, Delim); end Ada_Skip_String; function Get_Line is new Util.Files.Text_IO.Next_Line (Line_Continuation => "", Comment_Start => "--", Delimiters => Ada.Strings.Maps.To_Set ('"'), Strings => Ada_Skip_String); -- Note: we only need to handle the double quote as a string delimiter, -- for "--" can only occur in strings, but never in character literals. -- Hence it isn't necessary to handle the single quote at all here. Curr_Line : UT.Unbounded_String; Curr : UT.String_Access; Curr_Idx : Natural; Curr_Token : Token := Other_Token; Token_Image : UT.Unbounded_String; Token_Ptr : UT.String_Access; -- Set for 'Name_Token' and 'String_Token'; in the latter case, it -- also contains the delimiting double quotes. procedure Load_Line is begin UT.Set (Curr_Line, Get_Line (F)); Curr := UT.Internal.Get_Ptr (Curr_Line); Curr_Idx := 1; if Curr_Idx > Curr'Last then raise Scan_Error; end if; end Load_Line; function Find_Token return Token is begin case Token_Ptr (Token_Ptr'First) is when 'f' | 'F' => if To_Lower (Token_Ptr.all) = "function" then return Function_Token; end if; when 'g' | 'G' => if To_Lower (Token_Ptr.all) = "generic" then return Generic_Token; end if; when 'i' | 'I' => if To_Lower (Token_Ptr.all) = "is" then return Is_Token; end if; when 'n' | 'N' => if To_Lower (Token_Ptr.all) = "new" then return New_Token; end if; when 'p' | 'P' => declare S : constant String := To_Lower (Token_Ptr.all); begin if S = "package" then return Package_Token; elsif S = "pragma" then return Pragma_Token; elsif S = "private" then return Private_Token; elsif S = "procedure" then return Procedure_Token; end if; end; when 'r' | 'R' => if To_Lower (Token_Ptr.all) = "return" then return Return_Token; end if; when 't' | 'T' => if To_Lower (Token_Ptr.all) = "type" then return Type_Token; end if; when 'u' | 'U' => if To_Lower (Token_Ptr.all) = "use" then return Use_Token; end if; when 'w' | 'W' => if To_Lower (Token_Ptr.all) = "with" then return With_Token; end if; when others => null; end case; return Name_Token; end Find_Token; Numeral : constant Ada.Strings.Maps.Character_Set := Ada.Strings.Maps.To_Set ("0123456789_"); Based_Numeral : constant Ada.Strings.Maps.Character_Set := Ada.Strings.Maps.To_Set ("0123456789_ABCDEFabcdef"); procedure Advance is begin if Curr_Idx > Curr'Last then Load_Line; end if; declare Ch : Character := Curr (Curr_Idx); begin while Is_Blank (Ch) loop Curr_Idx := Curr_Idx + 1; if Curr_Idx > Curr'Last then Load_Line; Curr_Idx := 1; end if; Ch := Curr (Curr_Idx); end loop; case Ch is when '(' => Curr_Token := Left_Paren_Token; when ')' => Curr_Token := Right_Paren_Token; when ';' => Curr_Token := Semicolon_Token; when '.' => Curr_Token := Period_Token; when 'A' .. 'Z' | 'a' .. 'z' => -- Parse a name: any sequence of characters, digits, and -- underscores. declare Stop_Idx : constant Natural := Identifier (Curr (Curr_Idx .. Curr'Last)); begin UT.Set (Token_Image, Curr (Curr_Idx .. Stop_Idx)); Token_Ptr := UT.Internal.Get_Ptr (Token_Image); Curr_Idx := Stop_Idx; end; Curr_Token := Find_Token; when ''' => if Curr_Idx + 2 <= Curr'Last and then Curr (Curr_Idx + 2) = ''' then Curr_Idx := Curr_Idx + 2; end if; Curr_Token := Other_Token; when '"' => -- Skip a string. declare Stop_Idx : constant Natural := Ada_Skip_String (Curr (Curr_Idx .. Curr'Last), '"'); begin if Stop_Idx = 0 then raise Scan_Error; end if; UT.Set (Token_Image, Curr (Curr_Idx .. Stop_Idx)); Token_Ptr := UT.Internal.Get_Ptr (Token_Image); Curr_Idx := Stop_Idx; Curr_Token := String_Token; end; when '0' .. '9' => -- Skip a number. Note: use a simplified syntax! declare Stop_Idx : Natural := Curr_Idx; begin while Stop_Idx <= Curr'Last and then Is_In (Numeral, Curr (Stop_Idx)) loop Stop_Idx := Stop_Idx + 1; end loop; if Stop_Idx <= Curr'Last then if Curr (Stop_Idx) = '#' then Stop_Idx := Stop_Idx + 1; -- Actually, there must be at least one digit, and -- at most one period. while Stop_Idx <= Curr'Last and then Is_In (Based_Numeral, Curr (Stop_Idx)) loop Stop_Idx := Stop_Idx + 1; end loop; if Stop_Idx <= Curr'Last and then Curr (Stop_Idx) = '#' then Stop_Idx := Stop_Idx + 1; else raise Scan_Error; end if; elsif Curr (Stop_Idx) = '.' then Stop_Idx := Stop_Idx + 1; -- Actually, there must be at least one digit. while Stop_Idx <= Curr'Last and then Is_In (Numeral, Curr (Stop_Idx)) loop Stop_Idx := Stop_Idx + 1; end loop; end if; -- Fraction or Based end if; if Stop_Idx <= Curr'Last and then Curr (Stop_Idx) = 'E' then Stop_Idx := Stop_Idx + 1; if Stop_Idx > Curr'Last then raise Scan_Error; end if; case Curr (Stop_Idx) is when '0' .. '9' => null; when '+' | '-' => Stop_Idx := Stop_Idx + 1; if Stop_Idx > Curr'Last then raise Scan_Error; end if; when others => raise Scan_Error; end case; -- Actually, there must be at least one digit now. while Stop_Idx <= Curr'Last and then Is_In (Numeral, Curr (Stop_Idx)) loop Stop_Idx := Stop_Idx + 1; end loop; end if; -- Exponent Curr_Idx := Stop_Idx - 1; end; Curr_Token := Other_Token; when others => Curr_Token := Other_Token; end case; Curr_Idx := Curr_Idx + 1; end; end Advance; function Current_Token return Token is begin return Curr_Token; end Current_Token; function Image return UT.Unbounded_String is begin if Curr_Token = Name_Token or else Curr_Token = String_Token then return Token_Image; else return UT.Null_Unbounded_String; end if; end Image; procedure Init (File_Name : in String) is begin Ada.Text_IO.Open (F, Ada.Text_IO.In_File, File_Name); Load_Line; Advance; end Init; procedure Close is begin if Ada.Text_IO.Is_Open (F) then Ada.Text_IO.Close (F); end if; end Close; end Scanner; ---------------------------------------------------------------------------- -- Parsing routines. This is a very simple recursive descent parser, yet -- it recognizes syntactically correct Ada 95 library unit headers up -- to the library unit name. It doesn't do any error recovery, and it -- skips source chunks that are not interesting. The sole purpose of this -- is to get the name of the library unit, not any syntax or semantics -- checking. package Parser is function Library_Unit return String; Parse_Error : exception; end Parser; package body Parser is use Scanner; procedure Skip_Parentheses is Level : Natural := 0; begin loop case Current_Token is when Left_Paren_Token => Level := Level + 1; when Right_Paren_Token => Level := Level - 1; when others => null; end case; Advance; exit when Level = 0; end loop; end Skip_Parentheses; procedure Skip_To_Semicolon is begin while Current_Token /= Semicolon_Token loop Advance; end loop; end Skip_To_Semicolon; procedure Skip_To_Semicolon_Nested is begin while Current_Token /= Semicolon_Token loop if Current_Token = Left_Paren_Token then Skip_Parentheses; else Advance; end if; end loop; end Skip_To_Semicolon_Nested; procedure Context_Clauses is begin loop case Current_Token is when With_Token | Use_Token => Skip_To_Semicolon; when Pragma_Token => Skip_To_Semicolon_Nested; when others => exit; end case; -- Skip the semicolon. Advance; end loop; end Context_Clauses; procedure Generic_Formals is begin loop case Current_Token is when Pragma_Token => -- Just to be on the safe side: allow pragmas in the generic -- formal part. Skip_To_Semicolon_Nested; when Use_Token => Skip_To_Semicolon; when Type_Token => -- Generic formal type. Advance; if Current_Token /= Name_Token then raise Parse_Error; end if; Advance; if Current_Token = Left_Paren_Token then -- Discriminants. Skip_Parentheses; end if; if Current_Token /= Is_Token then raise Parse_Error; end if; Skip_To_Semicolon; when With_Token => -- Generic formal subprogram or formal package. Advance; case Current_Token is when Package_Token => Advance; if Current_Token /= Name_Token then raise Parse_Error; end if; Advance; if Current_Token /= Is_Token then raise Parse_Error; end if; Advance; if Current_Token /= New_Token then raise Parse_Error; end if; Advance; if Current_Token /= Name_Token then raise Parse_Error; end if; Advance; -- It may be an expanded name (Package.Name). while Current_Token = Period_Token loop Advance; if Current_Token /= Name_Token then raise Parse_Error; end if; Advance; end loop; if Current_Token = Left_Paren_Token then -- Generic actual part. Skip_Parentheses; end if; Skip_To_Semicolon; when Procedure_Token | Function_Token => declare Initial : constant Token := Current_Token; begin Advance; if Current_Token /= Name_Token and then (Initial /= Function_Token or else Current_Token /= String_Token) then raise Parse_Error; end if; Advance; if Current_Token = Left_Paren_Token then -- Parameter specifications. Skip_Parentheses; end if; if Initial = Function_Token then -- Return type if Current_Token /= Return_Token then raise Parse_Error; end if; Advance; if Current_Token /= Name_Token then raise Parse_Error; end if; Advance; end if; Skip_To_Semicolon; end; when others => raise Parse_Error; end case; when Name_Token => -- Generic formal object. Skip to first semicolon not within -- parentheses. Skip_To_Semicolon_Nested; when Package_Token | Procedure_Token | Function_Token => exit; when others => raise Parse_Error; end case; if Current_Token /= Semicolon_Token then raise Parse_Error; end if; -- Skip the semicolon. Advance; end loop; end Generic_Formals; function Library_Unit return String is begin Context_Clauses; if Current_Token = Private_Token then Advance; end if; if Current_Token = Generic_Token then Advance; Generic_Formals; end if; case Current_Token is when Package_Token | Procedure_Token | Function_Token => declare Initial : constant Token := Current_Token; Unit_Name : UT.Unbounded_String; begin -- Next one must be the unit name. Advance; if Current_Token = Name_Token or else (Initial = Function_Token and then Current_Token = String_Token) then Unit_Name := Image; declare Last_Token : Token := Current_Token; begin Advance; while Current_Token = Period_Token loop Advance; if Last_Token /= Name_Token then raise Parse_Error; end if; if Current_Token = Name_Token or else (Initial = Function_Token and then Current_Token = String_Token) then UT.Append (Unit_Name, '.'); UT.Append (Unit_Name, Image); Last_Token := Current_Token; Advance; else raise Parse_Error; end if; end loop; end; else raise Parse_Error; end if; return UT.To_String (Unit_Name); end; when others => null; end case; return ""; end Library_Unit; end Parser; ---------------------------------------------------------------------------- -- Exported routines. function Get_Unit_Name (File_Name : in String) return String is begin Scanner.Init (File_Name); declare Unit_Name : constant String := Parser.Library_Unit; begin Scanner.Close; return Unit_Name; end; exception when others => Scanner.Close; return ""; end Get_Unit_Name; end AD.Parse; adabrowse_4.0.3/gal-adt.ads0000644000175000017500000000776110234241446013700 0ustar kenken------------------------------------------------------------------------------- -- -- Copyright (c) 2001, 2002 by Thomas Wolf. --
    -- This piece of software is free software; you can redistribute it and/or -- modify it under the terms of the GNU General Public License as published -- by the Free Software Foundation; either version 2, or (at your option) -- any later version. This unit is distributed in the hope that it will be -- useful, but without any warranty; without even the implied -- warranty of merchantability or fitness for a particular purpose. -- See the GNU General Public License for more details. You should have -- received a copy of the GNU General Public License with this distribution, -- see file "GPL.txt". If not, write to the Free -- Software Foundation, 59 Temple Place - Suite 330, Boston, MA 02111-1307, -- USA. --
    --
    -- As a special exception from the GPL, if other files instantiate generics -- from this unit, or you link this unit with other files to produce an -- executable, this unit does not by itself cause the resulting executable -- to be covered by the GPL. This exception does not however invalidate any -- other reasons why the executable file might be covered by the GPL. --
    -- --
    -- Author:
    -- Thomas Wolf (TW) --
    twolf@acm.org
    -- --
    -- Purpose:
    -- Root package for GAL's "raw ADT" subsystem. The "raw ADTs" are used in the -- Containers subsystem to -- implement containers.
    -- -- ------------------------------------------------------------------------------- pragma License (Modified_GPL); package GAL.ADT is pragma Pure; Container_Empty : exception; -- May be raised by some ADTs when an illegal operation is attempted on -- an empty ADT object, e.g. trying to delete an item from an empty tree -- or list. Container_Full : exception; -- May be raised by bounded ADTs when an item should be added to an ADT -- that is already full. Range_Error : exception; -- Raised by operations that support ranges of some kind if the range is -- invalid, e.g. there are some list operations where ranges can be -- specified using two positions -- these operations raise Range_Error -- if the two positions are not on the same list, or one of them is null. Not_Found : exception; -- Raised if an item we looked for in an ADT was not found, and the ADT -- object is not empty. (If it is empty, Container_Empty should be raised -- instead.) Duplicate_Key : exception; -- Raised by asome ADTs that don't allow duplicates when a second item -- that is considered equal to an item already in the ADT is about to be -- added. Container_Error : exception; -- General consistency error. Raised e.g. when an iterator is used that -- has becomes invalid because the item it was referencing has vanished. Navigation_Error : exception; -- Raised when a semantically illegal operation through a position is -- attempted, such as inserting an element after a position that already -- is beyond the end of a list. Unordered_Error : exception; -- Raised by relational operators (<,>,<=,>=) if the two objects to be -- compared are unordered. This can e.g. happen for list positions, if -- the two positions are on different lists, or if one of them is null. -- In addition to these exceptions, any ADT may potentially raise -- -- Constraint_Error if an operation through a null-iterator is attempted. -- Storage_Error if a dynamic storage allocation has failed. end GAL.ADT; adabrowse_4.0.3/ad-syntax.ads0000644000175000017500000000321210234241444014260 0ustar kenken------------------------------------------------------------------------------- -- -- This file is part of AdaBrowse. -- -- Copyright (c) 2002 by Thomas Wolf. --
    -- AdaBrowse is free software; you can redistribute it and/or modify it -- under the terms of the GNU General Public License as published by the -- Free Software Foundation; either version 2, or (at your option) any -- later version. AdaBrowse is distributed in the hope that it will be -- useful, but without any warranty; without even the implied -- warranty of merchantability or fitness for a particular purpose. -- See the GNU General Public License for more details. You should have -- received a copy of the GNU General Public License with this distribution, -- see file "GPL.txt". If not, write to the Free -- Software Foundation, 59 Temple Place - Suite 330, Boston, MA 02111-1307, -- USA. --
    -- --
    -- Author:
    -- Thomas Wolf (TW) --
    twolf@acm.org
    -- --
    -- Purpose:
    -- Utility routines for syntax coloring.
    -- -- ------------------------------------------------------------------------------- pragma License (GPL); package AD.Syntax is Max_Keyword_Length : constant := 10; procedure Find_Keyword (S : in String; Before : in Character; Last : in Natural; Start : out Natural; Stop : out Natural); end AD.Syntax; adabrowse_4.0.3/ad-user_tags.ads0000644000175000017500000001153110234241444014731 0ustar kenken------------------------------------------------------------------------------- -- -- This file is part of AdaBrowse. -- -- Copyright (c) 2002 by Thomas Wolf. --
    -- AdaBrowse is free software; you can redistribute it and/or modify it -- under the terms of the GNU General Public License as published by the -- Free Software Foundation; either version 2, or (at your option) any -- later version. AdaBrowse is distributed in the hope that it will be -- useful, but without any warranty; without even the implied -- warranty of merchantability or fitness for a particular purpose. -- See the GNU General Public License for more details. You should have -- received a copy of the GNU General Public License with this distribution, -- see file "GPL.txt". If not, write to the Free -- Software Foundation, 59 Temple Place - Suite 330, Boston, MA 02111-1307, -- USA. --
    -- --
    -- Author:
    -- Thomas Wolf (TW) --
    twolf@acm.org
    -- --
    -- Purpose:
    -- Storage of user-defined HTML tags.
    -- -- ------------------------------------------------------------------------------- pragma License (GPL); with Util.Environment; with Util.Text; package AD.User_Tags is pragma Elaborate_Body; Invalid_Tag : exception; procedure Parse_Tag (Key : in String; Definition : in String; Expander : access Util.Environment.String_Expander'Class); -- @Key@ should be the part of the key after the initial "User_Tag." -- @Definition@ should be whatever the key's definition is. If an -- error occurs, @Invalid_Tag@ with a descriptive error message is -- raised. type Tag (N : Natural) is abstract tagged record Name : String (1 .. N); end record; type Tag_Ptr is access all Tag'Class; for Tag_Ptr'Storage_Size use 0; -- No storage allocation through this pointer type: hence do not try -- to deallocate! type HTML_Content is (Dont_Touch, Pure, Inline, Block, Flow); -- 'Pure' means "never do anything with empty lines". type HTML_Container is (Single, Begin_End, End_Optional); type Follow_Set is array (Natural range <>) of Tag_Ptr; type Standard_Tag (N, F : Natural) is new Tag (N) with record Syntax : HTML_Container; Class : HTML_Content; Contains : HTML_Content; Follow : Follow_Set (1 .. F); end record; -- If the top tag can have only inline content, the formatter emits -- "

    " if handling paragraphs (unless the last thing written -- already was a "
    ", in which case we emit only one "
    "). -- -- If the top tag's content is pure, nothing is done for empty lines: -- they're written as-is. -- -- If the top tag's content is flow, we emit a

    if we're on the first -- text line of the container or the last last line was empty. (Note that -- we rely on P's being implicitly closed!) -- -- Whenever a closing tag is hit, we pop the stack until the corresponding -- opening tag is hit (if it exists, if not, ignore!). -- -- The follow sets are set only for tags whose end tag is optional. They're -- used to determine when to close e.g. a paragraph. A follow set entry -- "null" means "any block tag closes this open block". type Standard_Ptr is access all Standard_Tag'Class; for Standard_Ptr'Storage_Size use 0; type Tag_Kind is (Container, Normal, Include, Execute, Initialize); type User_Defined_Tag is new Tag with record Kind : Tag_Kind := Normal; Enabled : Boolean := True; In_Expansion : Boolean := False; Start : Util.Text.Unbounded_String; Final : Util.Text.Unbounded_String; end record; -- @Start@ is the replacement in case on @Normal@ and @Container@, -- the file name in case of @Include@, and the command in case of -- @Execute@ or @Initialize@. -- -- @Final@ is set only for @Container@ tags. type User_Tag_Ptr is access all User_Defined_Tag'Class; for User_Tag_Ptr'Storage_Size use 0; function Find_Tag (Key : in String) return Tag_Ptr; -- Returns @null@ if no such tag is found. procedure Verify; -- Verifies all the tags. If an error is found, @Invalid_Tag@ with a -- descriptive message is raised. procedure Reset_Tags; -- Resets the @In_Expansion@ flag of all tags, and resets all @Initialize@ -- tags. end AD.User_Tags; adabrowse_4.0.3/ad-html-pathes.adb0000644000175000017500000000754710234241450015153 0ustar kenken------------------------------------------------------------------------------- -- -- This file is part of AdaBrowse. -- -- Copyright (c) 2002 by Thomas Wolf. --

    -- AdaBrowse is free software; you can redistribute it and/or modify it -- under the terms of the GNU General Public License as published by the -- Free Software Foundation; either version 2, or (at your option) any -- later version. AdaBrowse is distributed in the hope that it will be -- useful, but without any warranty; without even the implied -- warranty of merchantability or fitness for a particular purpose. -- See the GNU General Public License for more details. You should have -- received a copy of the GNU General Public License with this distribution, -- see file "GPL.txt". If not, write to the Free -- Software Foundation, 59 Temple Place - Suite 330, Boston, MA 02111-1307, -- USA. --
    -- --
    -- Author:
    -- Thomas Wolf (TW) --
    twolf@acm.org
    -- --
    -- Purpose:
    -- Handling of "pathes": prefix URLs defined for cross-references.
    -- -- ------------------------------------------------------------------------------- pragma License (GPL); with Ada.Strings.Unbounded; with Ada.Unchecked_Deallocation; with Util.Strings; package body AD.HTML.Pathes is package ASU renames Ada.Strings.Unbounded; use Util.Strings; -- We do longest-prefix matches in 'Get_Path' below. Probably the most -- efficient data structure for this would be a trie, but since I assume -- that there won't be too many different pathes with keys that them- -- selves are prefixes of one another, this would be overkill. type Path; type Path_Ptr is access Path; type Path is record Key : ASU.Unbounded_String; Value : ASU.Unbounded_String; Next : Path_Ptr; end record; procedure Free is new Ada.Unchecked_Deallocation (Path, Path_Ptr); Anchor : Path_Ptr; procedure Add_Path (Key : in String; Value : in String) is use type ASU.Unbounded_String; P, Q : Path_Ptr; K : ASU.Unbounded_String := ASU.To_Unbounded_String (To_Lower (Key)); begin P := Anchor; while P /= null loop exit when Key'Length > ASU.Length (P.Key); if K = P.Key then -- Hey, we already have that exact key! if Value'Last < Value'First then -- Value is the empty string: let's remove this path -- altogether. if Q = null then Anchor := P.Next; else Q.Next := P.Next; end if; Free (P); else -- Overwrite the existing entry! P.Value := ASU.To_Unbounded_String (Value); end if; return; end if; Q := P; P := P.Next; end loop; -- New entry. if Q = null then Anchor := new Path'(K, ASU.To_Unbounded_String (Value), P); else Q.Next := new Path'(K, ASU.To_Unbounded_String (Value), P); end if; -- The list is ordered by key length, earlier keys first. end Add_Path; function Get_Path (Unit_Name : in String) return String is P : Path_Ptr := Anchor; U : constant String := To_Lower (Unit_Name); begin while P /= null loop if Is_Prefix (U, ASU.To_String (P.Key)) then return ASU.To_String (P.Value); end if; P := P.Next; end loop; return ""; end Get_Path; end AD.HTML.Pathes; adabrowse_4.0.3/util-environment-bash.ads0000644000175000017500000002255310234241446016615 0ustar kenken------------------------------------------------------------------------------- -- -- Copyright © 2001, 2002 by Thomas Wolf. --
    -- This piece of software is free software; you can redistribute it and/or -- modify it under the terms of the GNU General Public License as published -- by the Free Software Foundation; either version 2, or (at your option) -- any later version. This software is distributed in the hope that it will -- be useful, but without any warranty; without even the implied -- warranty of merchantability or fitness for a particular purpose. -- See the GNU General Public License for more details. You should have -- received a copy of the GNU General Public License with this distribution, -- see file "GPL.txt". If not, write to the Free -- Software Foundation, 59 Temple Place - Suite 330, Boston, MA 02111-1307, -- USA. --
    --
    -- As a special exception from the GPL, if other files instantiate generics -- from this unit, or you link this unit with other files to produce an -- executable, this unit does not by itself cause the resulting executable -- to be covered by the GPL. This exception does not however invalidate any -- other reasons why the executable file might be covered by the GPL. --
    -- -- -- Thomas Wolf (TW) -- -- -- -- Bash-style variable substitution. -- -- -- -- -- -- No dynamic storage allocation. @Expand@ is recursive; the recursion -- depth (and hence the stack consumption) is limited by the number of -- variable references and escaped '@$@'-signs in the @Source@ string. -- -- -- -- 03-MAY-2002 TW Initial version. -- 14-MAY-2002 TW Added 'Set_Reference_Character'. -- ------------------------------------------------------------------------------- pragma License (Modified_GPL); package Util.Environment.Bash is pragma Elaborate_Body; type Bash_Expander is new String_Expander with private; function Expand (Self : access Bash_Expander; Source : in String) return String; -- Replaces all references to environment variables in @Source@ by that -- variable's definition (or the empty string, if an environment variable -- is not defined) and returns the resulting string. -- -- A @Bash_Expander@ uses a syntax very similar to that of the GNU -- @bash@ shell. An environment variable has a name, which is an -- identifier: -- -- 
       --      Ident = Alpha { Alpha | Digit | '_' }.
   --      Alpha = 'A' .. 'Z' | 'a' ..'z'.
   --      Digit = '0' .. '9'.
   --
    -- -- A simple reference to a variable has the form -- -- 
       --      $Identifier
   --
    -- -- and is replaced as a whole (including the '$' sign) by the variable's -- value or by the empty string if no such variable is defined. -- -- More interesting are the complex variable references, which have the -- syntax -- -- 
       --     Value     = any string, maybe containing environment
   --                 variable references.
   --     Operator  = :- | :+.
   --     Reference = ${Var_Name[Operator[Value]]}.
   --     Var_Name  = Value | !Identifier.
   --
    -- -- In all forms, Variable_Name can have one of three formats: -- --
      --
    • An identifier: expands to the empty string if no such variable -- is defined, and to the variable's value otherwise. --
    • A '!' and an identifier: expands the identifier as above, but -- then takes the result of this expansion as the name of another -- variable, which is then expanded. This is known as indirect -- expansion, and is limited to one level of indirection only. --
    • Some arbitrary string that may contain embedded references to -- variables: environment variable substitution is performed on the -- whole thing, and the resulting value is taken to be the name of -- a variable, which is then expanded. This recursive -- expansion is unknown in @bash@>, and it is done -- for as many levels as specified. --
    -- -- The semantics of these forms is as follows: -- --
    @${Variable_Name}@ --
    Is identical to the simple form of references @$Identifier@ -- except that it also allows indirect and recursive expansion.
    -- --
    @${Variable_Name:-Value}@ --
    Is replaced by the result of @${Variable_Name}@ unless that -- result is empty, in which case it is replaced by the expansion -- of @Value@.
    -- --
    @${Variable_Name:+Value}@ --
    Is replaced by the expansion of @Value@ if the result of -- @${Variable_Name}@ is non-empty, or the empty string otherwise. -- (@:+@ is the inverse of @:-@.)
    -- -- Indirect expansion using the '@!@' character is supported only to keep -- the syntax as close to the one used by @bash@ as possible. It is -- actually superfluous and can be replaced by the more powerful (and, so -- I think, simpler because more regular) recursive expansion: -- "@${!Some_Name}@" is identical to "@${${Some_Name}}@" or -- "@${$Some_Name}@". -- -- In all operators, the '@:@' is actually optional. It appears that it -- is optional in @bash@ (although the manual doesn't say so), -- and I have therefore chosen to make it optional here, too. -- -- To include a literal dollar sign '@$@' in the result of the expansion -- of @Source@, escape it with a backslash and write "@\$@". If, for some -- reason, you want to have a backslash immediately before a variable -- reference without escaping the dollar sign, escape the backslash by -- writing two backslashes before the dollar. The sequence -- "@\\@" immediately followed by a variable reference is replaced by -- a single backslash and the substitution of the reference. -- -- Variable references that are not terminated properly are not replaced. -- E.g. "${Var" is returned unchanged. -- -- A @Bash_Expander@ implements only the two operators '@-@' and '@+@'. -- Other operators may be added in derived types. -- -- Also, a @Bash_Expander@ has no special variables. To add those, -- override @Get@ and/or @Expand_Variable@ as needed. In general, special -- variables with names that are not identifiers will require overriding -- of @Expand_Variable@. Other special variables may be implemented by -- overriding @Get@ only. function Legal_Name (Self : access Bash_Expander; Source : in String) return Natural; function Indirection (Self : access Bash_Expander; Name : in String) return String; function Prefix (Self : access Bash_Expander; Source : in String; Last : access Natural) return String; function Recurse (Self : access Bash_Expander; Source : in String) return String; -- Default does anything required for plain bash-style variable expansion. -- In general, you'll only need to override this to add special handling -- of isolated cases, and then invoke this default operation. @Last@ shall -- be set to 0 in case of error (when no expansion shall occur), otherwise -- to the index of the first character in @Name@ not processed anymore -- (which may be <= @Name'Last@ only if @Prefix@ is @True@). -- -- @Prefix@ is @True@ if @Expand_Variable@ shall use only the longest -- possible legal prefix of @Name@ as the variable name. -- -- @Indirect@ is @True@ if indirect expansion shall be performed. function Is_Operator (Self : access Bash_Expander; Selector : in Character) return Boolean; -- Return @True@ if @Selector@ is a legal operator for your variation of -- bash-style variable substitution, and @False@ otherwise. The default -- returns @True@ only if @Selector@ is '@+@' or '@-@'. function Execute_Operator (Self : access Bash_Expander; Operator : in Character; Var_Name : in String; Indirect : in Boolean; Default_Part : in String) return String; -- Execute a variable substitition that uses an @Operator@. @Var_Name@ is -- the @Var_Name@ part of the above syntax, and -- @Default_Part@ is the @Value@ from that syntax. if @Indirect@ is @True@, -- @Var_Name@ is only the @Identifier@, it doesn't include the '@!@' sign. -- -- Returns the expansion (which may be empty). procedure Set_Reference_Character (Self : access Bash_Expander; Char : in Character); -- By default, a @Bash_Expander@ uses the "@$@" sign to signal the start -- of a variable reference. However, sometimes you might want to use some -- other character. With this operation, you can redefine the character -- used. private type Bash_Expander is new String_Expander with record Ref_Char : Character := '$'; end record; end Util.Environment.Bash; adabrowse_4.0.3/ad-scanner.ads0000644000175000017500000000314110234241444014364 0ustar kenken------------------------------------------------------------------------------- -- -- This file is part of AdaBrowse. -- -- Copyright (c) 2002 by Thomas Wolf. --
    -- AdaBrowse is free software; you can redistribute it and/or modify it -- under the terms of the GNU General Public License as published by the -- Free Software Foundation; either version 2, or (at your option) any -- later version. AdaBrowse is distributed in the hope that it will be -- useful, but without any warranty; without even the implied -- warranty of merchantability or fitness for a particular purpose. -- See the GNU General Public License for more details. You should have -- received a copy of the GNU General Public License with this distribution, -- see file "GPL.txt". If not, write to the Free -- Software Foundation, 59 Temple Place - Suite 330, Boston, MA 02111-1307, -- USA. --
    -- --
    -- Author:
    -- Thomas Wolf (TW) --
    twolf@acm.org
    -- --
    -- Purpose:
    -- Traversal of the ASIS tree and HTML generation.
    -- -- ------------------------------------------------------------------------------- pragma License (GPL); with Asis; with AD.Printers; package AD.Scanner is pragma Elaborate_Body; procedure Scan (The_Unit : in Asis.Compilation_Unit; The_Printer : in AD.Printers.Printer_Ref); end AD.Scanner; adabrowse_4.0.3/ad-html.adb0000644000175000017500000004316710234241460013670 0ustar kenken------------------------------------------------------------------------------- -- -- This file is part of AdaBrowse. -- -- Copyright (c) 2002 by Thomas Wolf. --
    -- AdaBrowse is free software; you can redistribute it and/or modify it -- under the terms of the GNU General Public License as published by the -- Free Software Foundation; either version 2, or (at your option) any -- later version. AdaBrowse is distributed in the hope that it will be -- useful, but without any warranty; without even the implied -- warranty of merchantability or fitness for a particular purpose. -- See the GNU General Public License for more details. You should have -- received a copy of the GNU General Public License with this distribution, -- see file "GPL.txt". If not, write to the Free -- Software Foundation, 59 Temple Place - Suite 330, Boston, MA 02111-1307, -- USA. --
    -- --
    -- Author:
    -- Thomas Wolf (TW) --
    twolf@acm.org
    -- --
    -- Purpose:
    -- HTML output helper routines.
    -- -- ------------------------------------------------------------------------------- pragma License (GPL); with Ada.Characters.Handling; with Ada.Calendar; with Ada.Strings.Fixed; with Ada.Strings.Maps; with Ada.Strings.Unbounded; with Ada.Text_IO; with AD.Config; with AD.Version; with Util.Calendar.IO; with Util.Strings; package body AD.HTML is package ASF renames Ada.Strings.Fixed; package ASM renames Ada.Strings.Maps; package ASU renames Ada.Strings.Unbounded; use Util.Strings; type HTML_Tag is array (HTML_Tag_Kind) of ASU.Unbounded_String; Style_Sheet : ASU.Unbounded_String; Body_Start : ASU.Unbounded_String; Char_Set : ASU.Unbounded_String; Title : HTML_Tag; Sub_Title : HTML_Tag; Keyword : HTML_Tag; Attribute : HTML_Tag; Definition : HTML_Tag; Comment : HTML_Tag; Literal : HTML_Tag; Ending : HTML_Tag; function Character_Set return String is begin return ASU.To_String (Char_Set); end Character_Set; generic with procedure Line (S : in String); procedure Dump_Header (Title : in String); procedure Dump_Header (Title : in String) is begin Line (""); Line (""); Line (""); Line (""); Line (""); Line ("" & HTMLize (Title) & ""); Line (""); if ASU.Length (Char_Set) /= 0 then Line (""); end if; Line (""); -- Now put the default styles here. They can be overwritten by a user- -- defined style sheet containing !important rules. Line (""); declare S : constant String := ASU.To_String (Style_Sheet); begin if S'Last >= S'First then Line (""); end if; end; Line (""); Line (""); Line (ASU.To_String (Body_Start)); Line (""); Line (ASU.To_String (AD.HTML.Title (Before)) & HTMLize (Title) & ASU.To_String (AD.HTML.Title (After))); Line (""); Line (""); end Dump_Header; procedure Header (File : in Ada.Text_IO.File_Type; Title : in String) is procedure Write_Line (S : in String) is begin Ada.Text_IO.Put_Line (File, S); end Write_Line; procedure Dump is new Dump_Header (Write_Line); begin Dump (Title); end Header; generic with procedure Write (S : in String); with procedure Line (S : in String); procedure Dump_Footer; procedure Dump_Footer is T : constant Ada.Calendar.Time := Ada.Calendar.Clock; Debug_Mode : constant Boolean := False; begin -- Make sure we're no longer in an HTML comment! Write ("" & ASU.To_String (Ending (Before)) & "" & "Generated"); if not Debug_Mode then Write (" on " & Util.Calendar.IO.Image (T) & " at " & Util.Calendar.IO.Image (Ada.Calendar.Seconds (T))); end if; Write (" by AdaBrowse " & AD.Version.Get_Version & ""); if not Debug_Mode then if AD.Config.Get_Nof_Config_Files = 1 then Write (" using configuration file " & HTMLize (AD.Config.Get_Config_Files)); elsif AD.Config.Get_Nof_Config_Files > 1 then Write (" using configuration files " & HTMLize (AD.Config.Get_Config_Files)); end if; end if; Line ('.' & ASU.To_String (Ending (After))); Line (""); Line (""); end Dump_Footer; procedure Footer (File : in Ada.Text_IO.File_Type) is procedure Write (S : in String) is begin Ada.Text_IO.Put (File, S); end Write; procedure Write_Line (S : in String) is begin Ada.Text_IO.Put_Line (File, S); end Write_Line; procedure Dump is new Dump_Footer (Write, Write_Line); begin Dump; end Footer; procedure Subtitle (File : in Ada.Text_IO.File_Type; Text : in String) is begin Ada.Text_IO.Put_Line (File, ASU.To_String (Sub_Title (Before)) & HTMLize (Text) & ASU.To_String (Sub_Title (After))); end Subtitle; ---------------------------------------------------------------------------- HTML_Special_Chars : constant ASM.Character_Set := ASM.To_Set ("&<>"""); Is_8_Bit : constant ASM.Character_Set := ASM.To_Set (ASM.Character_Range'(Low => Character'Val (160), High => Character'Last)); subtype Var_String_Length is Natural range 0 .. 6; type Variable_String (N : Var_String_Length := 0) is record S : String (1 .. N); end record; type Replacement_Table is array (Character) of Variable_String; Replacement : constant Replacement_Table := ('&' => (5, "&"), '"' => (6, """), '<' => (4, "<"), '>' => (4, ">"), others => (0, "")); function Get_Replacement (Ch : in Character) return String is begin if Replacement (Ch).N > 0 then return Replacement (Ch).S; else return "&#" & Trim (Natural'Image (Character'Pos (Ch))) & ';'; end if; end Get_Replacement; function Is_Named_Char (S : in String) return Boolean is begin if S'Last < S'First then return False; end if; if S (S'First) = '#' then declare Start : Natural; I : Natural := S'First + 1; begin if I <= S'Last and then (S (I) = 'x' or else S (I) = 'X') then -- Hex number I := I + 1; Start := I; while I <= S'Last and then Ada.Characters.Handling.Is_Hexadecimal_Digit (S (I)) loop I := I + 1; end loop; else -- Decimal number Start := I; while I <= S'Last and then Ada.Characters.Handling.Is_Decimal_Digit (S (I)) loop I := I + 1; end loop; end if; return I > Start and then I > S'Last; end; else declare I : Natural := S'First; begin while I <= S'Last and then Is_In (Letters, S (I)) loop I := I + 1; end loop; return I > S'Last; end; end if; end Is_Named_Char; function HTMLize (S : in String; Keep_Entities : in Boolean := True) return String is use ASM; I : constant Natural := ASF.Index (S, HTML_Special_Chars or Is_8_Bit); begin if I = 0 then return S; end if; declare R : constant String := Get_Replacement (S (I)); begin if S (I) = '&' and then Keep_Entities then -- Crap. What if we already have "<" or """ in the source? declare J : constant Natural := First_Index (S (I + 1 .. S'Last), ';'); begin if J > I + 1 and then -- Check that we have either: # followed by decimal digits, -- # followed by 'x' or 'X' and hex digits, or sequence of -- letters. Is_Named_Char (S (I + 1 .. J - 1)) then return S (S'First .. J) & HTMLize (S (J + 1 .. S'Last), Keep_Entities); end if; end; end if; if I = S'First then return R & HTMLize (S (I + 1 .. S'Last), Keep_Entities); else return S (S'First .. I - 1) & R & HTMLize (S (I + 1 .. S'Last), Keep_Entities); end if; end; end HTMLize; function Find_Tag_End (S : in String; Is_End : in Boolean := False) return Natural is I : Natural := S'First; begin if Is_End then -- Scan ahead to the next '>'. I := First_Index (S, '>'); else declare In_String : Boolean := False; Delim : Character := ' '; begin while I <= S'Last loop if In_String and then S (I) = Delim then In_String := False; elsif not In_String then Delim := S (I); if Delim = '"' or else Delim = ''' then In_String := True; else exit when Delim = '>'; end if; end if; I := I + 1; end loop; end; if I > S'Last then I := 0; end if; end if; return I; end Find_Tag_End; ---------------------------------------------------------------------------- function Attributes (Source : in String) return String is I : Natural := Next_Non_Blank (Source); begin if I = 0 then return ""; end if; declare Result : String (I .. Source'Last); J : Natural := Result'First - 1; begin -- Replace all LFs or TABs by a space. while I <= Source'Last loop J := J + 1; if Is_In (Blanks, Source (I)) then Result (J) := ' '; else Result (J) := Source (I); end if; I := I + 1; end loop; -- Strip trailing white space: while J >= Result'First and then Result (J) = ' ' loop J := J - 1; end loop; return Result (Result'First .. J); end; end Attributes; ---------------------------------------------------------------------------- function Get_Keyword (What : in HTML_Tag_Kind) return String is begin return ASU.To_String (Keyword (What)); end Get_Keyword; function Get_Attribute (What : in HTML_Tag_Kind) return String is begin return ASU.To_String (Attribute (What)); end Get_Attribute; function Get_Definition (What : in HTML_Tag_Kind) return String is begin return ASU.To_String (Definition (What)); end Get_Definition; function Get_Comment (What : in HTML_Tag_Kind) return String is begin return ASU.To_String (Comment (What)); end Get_Comment; function Get_Literal (What : in HTML_Tag_Kind) return String is begin return ASU.To_String (Literal (What)); end Get_Literal; ---------------------------------------------------------------------------- procedure Set_Char_Set (Id : in String) is begin Char_Set := ASU.To_Unbounded_String (Id); end Set_Char_Set; procedure Set_Style_Sheet (URL : in String) is begin Style_Sheet := ASU.To_Unbounded_String (URL); end Set_Style_Sheet; procedure Set_Body (S : in String) is begin Body_Start := ASU.To_Unbounded_String (S); end Set_Body; procedure Set_Title (What : in HTML_Tag_Kind; S : in String) is begin Title (What) := ASU.To_Unbounded_String (S); end Set_Title; procedure Set_Subtitle (What : in HTML_Tag_Kind; S : in String) is begin Sub_Title (What) := ASU.To_Unbounded_String (S); end Set_Subtitle; procedure Set_Keyword (What : in HTML_Tag_Kind; S : in String) is begin Keyword (What) := ASU.To_Unbounded_String (S); end Set_Keyword; procedure Set_Attribute (What : in HTML_Tag_Kind; S : in String) is begin Attribute (What) := ASU.To_Unbounded_String (S); end Set_Attribute; procedure Set_Definition (What : in HTML_Tag_Kind; S : in String) is begin Definition (What) := ASU.To_Unbounded_String (S); end Set_Definition; procedure Set_Comment (What : in HTML_Tag_Kind; S : in String) is begin Comment (What) := ASU.To_Unbounded_String (S); end Set_Comment; procedure Set_Literal (What : in HTML_Tag_Kind; S : in String) is begin Literal (What) := ASU.To_Unbounded_String (S); end Set_Literal; begin Set_Char_Set ("ISO-8859-1"); -- Latin 1 Set_Style_Sheet ("adabrowse.css"); Set_Body (""); Set_Title (Before, "

    "); Set_Title (After, "

    "); Set_Subtitle (Before, "

    "); Set_Subtitle (After, "

    "); Set_Keyword (Before, ""); Set_Keyword (After, ""); Set_Attribute (Before, ""); Set_Attribute (After, ""); Set_Definition (Before, ""); Set_Definition (After, ""); Set_Comment (Before, ""); Set_Comment (After, ""); Set_Literal (Before, ""); Set_Literal (After, ""); Ending (Before) := ASU.To_Unbounded_String ("
    "); Ending (After) := ASU.To_Unbounded_String ("
    "); end AD.HTML; adabrowse_4.0.3/gal-support-comparisons.ads0000644000175000017500000000475010234241446017172 0ustar kenken------------------------------------------------------------------------------- -- -- Copyright (c) 2001, 2002 by Thomas Wolf. --
    -- AdaBrowse is free software; you can redistribute it and/or modify it -- under the terms of the GNU General Public License as published by the -- Free Software Foundation; either version 2, or (at your option) any -- later version. AdaBrowse is distributed in the hope that it will be -- useful, but without any warranty; without even the implied -- warranty of merchantability or fitness for a particular purpose. -- See the GNU General Public License for more details. You should have -- received a copy of the GNU General Public License with this distribution, -- see file "GPL.txt". If not, write to the Free -- Software Foundation, 59 Temple Place - Suite 330, Boston, MA 02111-1307, -- USA. --
    --
    -- As a special exception from the GPL, if other files instantiate generics -- from this unit, or you link this unit with other files to produce an -- executable, this unit does not by itself cause the resulting executable -- to be covered by the GPL. This exception does not however invalidate any -- other reasons why the executable file might be covered by the GPL. --
    -- --
    -- Author:
    -- Thomas Wolf (TW) --
    twolf@acm.org
    -- --
    -- Purpose:
    -- Generic package that constructs the relational operators ">", "<=", and -- ">=" given only an existing "<". Works for any kind of type -- Item.
    -- --
    -- Tasking semantics:
    -- N/A. Not abortion-safe.
    -- --
    -- Storage semantics:
    -- No dynamic storage allocation.
    -- -- ------------------------------------------------------------------------------- pragma License (Modified_GPL); generic type Item (<>) is limited private; with function "<" (Left, Right : in Item) return Boolean; package GAL.Support.Comparisons is pragma Elaborate_Body; function ">" (Left, Right : in Item) return Boolean; function "<=" (Left, Right : in Item) return Boolean; function ">=" (Left, Right : in Item) return Boolean; private pragma Inline (">", "<=", ">="); end GAL.Support.Comparisons; adabrowse_4.0.3/util-files.adb0000644000175000017500000002160510234241454014413 0ustar kenken------------------------------------------------------------------------------- -- -- Copyright © 2001, 2002 by Thomas Wolf. --
    -- This piece of software is free software; you can redistribute it and/or -- modify it under the terms of the GNU General Public License as published -- by the Free Software Foundation; either version 2, or (at your option) -- any later version. This software is distributed in the hope that it will -- be useful, but without any warranty; without even the implied -- warranty of merchantability or fitness for a particular purpose. -- See the GNU General Public License for more details. You should have -- received a copy of the GNU General Public License with this distribution, -- see file "GPL.txt". If not, write to the Free -- Software Foundation, 59 Temple Place - Suite 330, Boston, MA 02111-1307, -- USA. --
    --
    -- As a special exception from the GPL, if other files instantiate generics -- from this unit, or you link this unit with other files to produce an -- executable, this unit does not by itself cause the resulting executable -- to be covered by the GPL. This exception does not however invalidate any -- other reasons why the executable file might be covered by the GPL. --
    -- -- -- Thomas Wolf (TW) -- -- -- -- Provides a generic function to unconditionally open (or create) a file. -- -- -- -- -- -- -- -- 02-MAR-2002 TW Initial version. -- ------------------------------------------------------------------------------- pragma License (Modified_GPL); with Ada.Exceptions; with Ada.Finalization; with Ada.IO_Exceptions; with Ada.Streams.Stream_IO; with Ada.Unchecked_Deallocation; with Util.Pathes; package body Util.Files is procedure Open_G (File : in out File_Type; Mode : in File_Mode; Name : in String; Form : in String := "") is begin Open (File, Mode, Name, Form); exception when Ada.IO_Exceptions.Name_Error => Create (File, Mode, Name, Form); end Open_G; procedure Copy_File (From : in String; To : in String := ""; Overwrite : in Boolean := False; Buffer : in Buffer_Size := Default_Buffer_Size) is use Util.Pathes; Source_Name : constant String := Name (From); begin if Source_Name'Length = 0 then raise Ada.IO_Exceptions.Use_Error; end if; if To'Length = 0 then Copy (From, Source_Name, Overwrite, Buffer); elsif Name (To)'Length = 0 then Copy (From, Concat (To, Source_Name), Overwrite, Buffer); else Copy (From, To, Overwrite, Buffer); end if; end Copy_File; type Copier (Src_Name : access String; Tgt_Name : access String; Buf_Size : Buffer_Size; Overwrite : Boolean; Error : access Ada.Exceptions.Exception_Occurrence) is new Ada.Finalization.Limited_Controlled with null record; type Buffer_Ptr is access Ada.Streams.Stream_Element_Array; procedure Free is new Ada.Unchecked_Deallocation (Ada.Streams.Stream_Element_Array, Buffer_Ptr); procedure Finalize (Copy : in out Copier) is use Ada.Streams; use Ada.Streams.Stream_IO; function Get_Buffer (File_Size : in Count; Requested : in Buffer_Size) return Buffer_Ptr is Min, Max : Stream_Element_Count; begin begin Min := Stream_Element_Count (Requested); exception when Constraint_Error => Min := Stream_Element_Count'Last; end; begin Max := Stream_Element_Count (File_Size); exception when Constraint_Error => Max := Stream_Element_Count'Last; end; Max := Stream_Element_Count'Min (Min, Max); -- Now get the largest possible buffer smaller than 'Max'... declare Min : constant Stream_Element_Count := 2 ** 10; -- ... but at least 1k! Result : Buffer_Ptr; begin while Result = null loop begin Result := new Stream_Element_Array (1 .. Max); exception when Storage_Error => -- Try a smaller buffer size, but make sure that we -- *do* try the minimum size. if Max > Min and then Max < 2 * Min then Max := Min; else Max := Max / 2; end if; if Max < Min then raise Storage_Error; end if; Result := null; end; end loop; return Result; end; end Get_Buffer; Source, Target : File_Type; Buffer : Buffer_Ptr; Length : Count; begin -- First try to open the source file. Open (Source, In_File, Copy.Src_Name.all); -- Now try to open the target file. First with mode 'In_File'! begin Open (Target, In_File, Copy.Tgt_Name.all); -- Ok, the file is there. Close (Target); if not Copy.Overwrite then raise File_Exists; end if; Open (Target, Out_File, Copy.Tgt_Name.all); exception when Name_Error => -- File doesn't exist. Try to create it. Create (Target, Out_File, Copy.Tgt_Name.all); end; -- Both files are open. Check for empty source. Length := Size (Source); if End_Of_File (Source) or else Length = 0 then Close (Source); Close (Target); return; end if; Buffer := Get_Buffer (Length, Copy.Buf_Size); -- Now start copying. Copy_Chunks : declare Last : Stream_Element_Offset; begin while not End_Of_File (Source) loop Read_Chunk : declare Current : constant Positive_Count := Index (Source); begin Read (Source, Buffer.all, Last); exception when End_Error => -- I don't think this should happen, but just in case it -- does... if Current <= Length then Set_Index (Source, Current); Read (Source, Buffer (Buffer'First .. Buffer'First + Stream_Element_Offset (Length - Current)), Last); else -- Nothing left to read or write. exit; end if; end Read_Chunk; Write (Target, Buffer (Buffer'First .. Last)); exit when Last < Buffer'Last; end loop; end Copy_Chunks; Close (Target); -- Target is safe now! begin Close (Source); Free (Buffer); exception when others => null; end; exception when E : others => -- Source begin if Is_Open (Source) then Close (Source); end if; exception when others => null; end; -- Target begin if Is_Open (Target) then if Mode (Target) = Out_File then begin Delete (Target); exception when others => Close (Target); end; else Close (Target); end if; end if; exception when others => null; end; -- Buffer begin Free (Buffer); exception when others => null; end; Ada.Exceptions.Save_Occurrence (Copy.Error.all, E); end Finalize; procedure Copy (From : in String; To : in String; Overwrite : in Boolean; Buffer : in Buffer_Size) is Error : aliased Ada.Exceptions.Exception_Occurrence; begin declare Src : aliased String := From; Tgt : aliased String := To; Do_Copy : Copier (Src'Access, Tgt'Access, Buffer, Overwrite, Error'Access); pragma Warnings (Off, Do_Copy); -- silence -gnatwa begin null; -- Finalization of 'Do_Copy' will copy the file. end; declare use Ada.Exceptions; begin if Exception_Identity (Error) = Null_Id then Reraise_Occurrence (Error); end if; end; end Copy; end Util.Files; adabrowse_4.0.3/gal-sorting.adb0000644000175000017500000007477510234241453014603 0ustar kenken------------------------------------------------------------------------------- -- -- Copyright (c) 1999 - 2002 by Thomas Wolf. --
    -- AdaBrowse is free software; you can redistribute it and/or modify it -- under the terms of the GNU General Public License as published by the -- Free Software Foundation; either version 2, or (at your option) any -- later version. AdaBrowse is distributed in the hope that it will be -- useful, but without any warranty; without even the implied -- warranty of merchantability or fitness for a particular purpose. -- See the GNU General Public License for more details. You should have -- received a copy of the GNU General Public License with this distribution, -- see file "GPL.txt". If not, write to the Free -- Software Foundation, 59 Temple Place - Suite 330, Boston, MA 02111-1307, -- USA. --
    --
    -- As a special exception from the GPL, if other files instantiate generics -- from this unit, or you link this unit with other files to produce an -- executable, this unit does not by itself cause the resulting executable -- to be covered by the GPL. This exception does not however invalidate any -- other reasons why the executable file might be covered by the GPL. --
    -- --
    -- Author:
    -- Thomas Wolf (TW) --
    twolf@acm.org
    -- --
    -- Purpose:
    -- Speed and space optimized quicksort. Actually, an introspective -- quicksort with a worst-case runtime complexity of -- O (N * log2 (N)).
    -- --
    -- Literature:
    -- Musser, D.R.: "Introspective Sorting and Selection Algorithms", -- Software -- Practice & Experience (8):983-993; 1997.
    -- --
    -- Tasking semantics:
    -- N/A. Not abortion-safe.
    -- --
    -- Storage semantics:
    -- No dynamic storage allocation. Stack space used is -- O (log2 (N)).
    -- -- <-- -- Revision History -- -- 21-JAN-1999 TW Initial version -- 26-JAN-1999 TW Some minor fine-tuning. -- --> ------------------------------------------------------------------------------- pragma License (Modified_GPL); with Ada.Numerics.Elementary_Functions; package body GAL.Sorting is Cut_Off : constant := 10; -- Empirically determined constant. For smaller arrays, it's actually -- faster to use a simple insertion sort. function Max_Depth (Nof_Elements : in Natural) return Natural is -- Compute the recursion depth bound at which we'll switch to using -- Heapsort instead of proceeding further down with Quicksort. use Ada.Numerics.Elementary_Functions; -- This seems to give us the fastest logarithm around... begin return 2 * Natural (Log (Float (Nof_Elements), 2.0)); -- This is Musser's suggestion, which seems to work well in practice. -- Note: it should not be too low, or we'll switch to using -- Heapsort prematurely. Since Heapsort is slower than Quicksort -- on the average (its constant factor in the O(N*log2(N)) is -- larger), we might lose. If it's too high, we'll start using -- Heapsort too late and hence we cannot ensure the O(N*log2(N)) -- upper bound. end Max_Depth; ---------------------------------------------------------------------------- -- A sort with a classic interface: -- generic -- type Index_Type is (<>); -- type Element_Type is private; -- type Array_Type is array (Index_Type range <>) of Element_Type; -- with function "<" -- (Left, Right : in Element_Type) return Boolean is <>; procedure Sort_G (To_Sort : in out Array_Type) is -- Recursion depth is bounded by log2 (To_Sort'Length). -- Worst-case runtime complexity is O(N*log2(N)), not O(N**2)! -- Note: for sensible performance measures, compile with a typical -- optimization level and all checks off (e.g. gcc -O3 -gnatp). For -- correctness testing, switch on checks! pragma Suppress (Overflow_Check); pragma Suppress (Index_Check); pragma Suppress (Range_Check); -- For correctness testing, you should also comment out these pragmas! Pivot, Temp : Element_Type; -- We need exactly two temporary locations, one for Quicksort's pivot -- element, and a second one for swapping elements and as a general -- temporary during Insertion_Sort or Heap_Sort. procedure Swap (Left, Right : in Index_Type); pragma Inline (Swap); -- inline this for increased performance. procedure Swap (Left, Right : in Index_Type) is begin Temp := To_Sort (Left); To_Sort (Left) := To_Sort (Right); To_Sort (Right) := Temp; end Swap; -- For array slices with less than 'Cut_Off' elements, we use a simple -- insertion sort: it's faster than quicksort. procedure Insertion_Sort (L, R : in Index_Type) is -- Precondition: L < R. J : Index_Type; begin -- Insertion_Sort for I in Index_Type range Index_Type'Succ (L) .. R loop Temp := To_Sort (I); J := I; while J > L and then Temp < To_Sort (Index_Type'Pred (J)) loop To_Sort (J) := To_Sort (Index_Type'Pred (J)); J := Index_Type'Pred (J); end loop; To_Sort (J) := Temp; end loop; end Insertion_Sort; -- If the (logical) recursion depth of quicksort gets too deep, we -- assume that the input is one of the pathological cases causing -- quadratic behavior of quicksort. At that moment, we switch to -- heapsort to sort the sub-array. (This pays off because heap sort -- has a worst-case runtime complexity of O(N*log2(N))). procedure Heap_Sort (Left, Right : in Index_Type) is -- Precondition: Left < Right Offset : Integer; -- Used for mapping the true index range to 1 .. N. procedure Sift (L, R : in Index_Type) is -- Normal heapsort algorithms always sort an array indexed by a -- range 1 .. N. We have to juggle a bit to map this back to a -- range L .. R, and to avoid overflow if R happens to be -- Index_Type'Base'Last. I : Index_Type := L; C : Index_Type := L; begin Temp := To_Sort (L); while (Index_Type'Pos (C) - Offset + 1) <= (Index_Type'Pos (R) - Offset + 1) / 2 loop C := Index_Type'Val ((Index_Type'Pos (I) - Offset + 1) * 2 - 1 + Offset); -- We must add 'Offset - 1'. Make sure to subtract one first, -- otherwise we might get an overflow if I = 'Last and -- Offset = 'Last-1. if C < R and then To_Sort (C) < To_Sort (Index_Type'Succ (C)) then C := Index_Type'Succ (C); end if; exit when not (Temp < To_Sort (C)); To_Sort (I) := To_Sort (C); I := C; end loop; To_Sort (I) := Temp; end Sift; J : Index_Type; begin -- Heap_Sort -- Precondition: Left < Right Offset := Index_Type'Pos (Left); -- Set J to the middle: J := Index_Type'Val ((Index_Type'Pos (Right) - Offset + 1) / 2 + Offset - 1); -- Build the heap: for I in reverse Index_Type range Left .. J loop Sift (I, Right); end loop; -- And now extract elements and re-build the heap. J := Right; loop -- Put the largest element (which is now in front) at the end and -- replace it with the last element. Swap (Left, J); J := Index_Type'Pred (J); exit when J = Left; -- Rebuild the remaining heap (one element less). Sift (Left, J); end loop; end Heap_Sort; procedure Intro_Sort (L, R : in Index_Type; D : in Natural) is -- This is a quicksort with median-of-three pivot selection and -- stack depth optimization: the tail recusion is resolved by -- always sorting the larger sub-array iteratively instead of -- recursing. This limits the physical recursion depth to log2(N) -- and thus avoids stack overflows even for pathological huge inputs. -- Actually, this is an introspective sort (see Musser's paper). -- It switches to heapsort if the logical recursion depth becomes -- too deep and thus avoids quicksort's usual worst-case quadratic -- behavior. Left : Index_Type := L; Right : Index_Type := R; -- L and R are in parameters, so copy. Depth : Natural := D; -- Ditto for D. I : Index_Type := Left; J : Index_Type := Right; Middle : Index_Type; begin -- Intro_Sort while Index_Type'Pos (Right) - Index_Type'Pos (Left) > Cut_Off loop -- Only proceed until we have a small unsorted array fragment -- left. This fragment will then be sorted with Insertion_Sort, -- which is faster than quicksort for small arrays. if Depth = 0 then Heap_Sort (Left, Right); return; end if; -- If the (logical) recursion depth gets too deep, we switch -- to heapsort, which has a worst-case run-time complexity of -- O(N*log(N)). This gives Intro_Sort an overall worst-case -- bound of O(N*log(N)), compared with the O(N**2) bound of -- plain quicksort (even with median-of-three). -- -- Don't use (Left + Right) / 2; it might overflow. Instead use -- Left + (Right - Left) / 2, which is equivalent. Middle := Index_Type'Val (Index_Type'Pos (Left) + (Index_Type'Pos (Right) - Index_Type'Pos (Left)) / 2); -- Median-of-three: if To_Sort (Middle) < To_Sort (Left) then Swap (Middle, Left); end if; if To_Sort (Right) < To_Sort (Left) then Swap (Right, Left); end if; if To_Sort (Right) < To_Sort (Middle) then Swap (Right, Middle); end if; Pivot := To_Sort (Middle); -- Here, I = Left and J = Right while I < J loop while To_Sort (I) < Pivot loop I := Index_Type'Succ (I); end loop; while Pivot < To_Sort (J) loop J := Index_Type'Pred (J); end loop; if I <= J then if I < J then Swap (I, J); end if; -- Now increment I and decrement J..., but beware of -- boundary conditions! if I < Index_Type'Last then I := Index_Type'Succ (I); end if; if J > Index_Type'First then J := Index_Type'Pred (J); end if; -- I and J saturate at the bounds of Index_Type... this -- doesn't hurt, we'll quit the loop in this case, and -- continue only (both recusively and iteratively) if -- this didn't happen. end if; end loop; -- Decrement the logical recursion depth. The next iteration will -- hence be (correctly) seen like a true recursive call. Depth := Depth - 1; -- Now handle the shorter part recusively, and do the longer part -- iteratively. This limits the (physical) recusion depth to -- log2(N). Note: Musser advocates omitting this and just doing -- one half recursively and the other one iteratively regardless -- of their sizes, as the 'Depth' counter already puts an -- O(log2(N)) bound on the maximum stack depth. The speed savings -- are marginal, though, and I prefer a bound of log2(N) over one -- of 2 * log2(N)... if Index_Type'Pos (J) - Index_Type'Pos (Left) > Index_Type'Pos (Right) - Index_Type'Pos (I) then -- Left part is longer. If I saturated, it is >= Right, and we -- won't do the recursive call. if I < Right then Intro_Sort (I, Right, Depth); end if; -- Iteratively process To_Sort (Left .. J). Set up the indices: I := Left; Right := J; else -- Right part is longer. If J saturated, it is <= Left, and we -- won't do the recursive call. if J > Left then Intro_Sort (Left, J, Depth); end if; -- Iteratively process To_Sort (I .. Right). Set up the -- indices: J := Right; Left := I; end if; -- If either I or J saturated, Left >= Right now, and we'll -- quit the outer loop. end loop; if Left < Right then Insertion_Sort (Left, Right); end if; -- Note: an alternative is to simply return and run a single -- insertion sort over the whole input at the very end. However, -- in my tests this made sorting slower. Nevertheless it should be -- pointed out that some people advocate this single post-sorting -- insertion sort, notably Musser in his paper. end Intro_Sort; begin -- Sort_G if To_Sort'Last > To_Sort'First then Intro_Sort (To_Sort'First, To_Sort'Last, Max_Depth (To_Sort'Length)); end if; end Sort_G; ---------------------------------------------------------------------------- -- The same with an access parameter and range bounds. -- generic -- type Index_Type is (<>); -- type Element_Type is private; -- type Array_Type is array (Index_Type range <>) of Element_Type; -- with function "<" -- (Left, Right : in Element_Type) return Boolean is <>; procedure Sort_Slice_G (To_Sort : access Array_Type; From, To : in Index_Type) is pragma Suppress (Overflow_Check); pragma Suppress (Index_Check); pragma Suppress (Range_Check); Pivot, Temp : Element_Type; procedure Swap (Table : access Array_Type; Left, Right : in Index_Type); pragma Inline (Swap); -- inline this for increased performance. procedure Swap (Table : access Array_Type; Left, Right : in Index_Type) is begin Temp := Table (Left); Table (Left) := Table (Right); Table (Right) := Temp; end Swap; procedure Insertion_Sort (To_Sort : access Array_Type; L, R : in Index_Type) is -- Precondition: L < R. J : Index_Type; begin -- Insertion_Sort for I in Index_Type range Index_Type'Succ (L) .. R loop Temp := To_Sort (I); J := I; while J > L and then Temp < To_Sort (Index_Type'Pred (J)) loop To_Sort (J) := To_Sort (Index_Type'Pred (J)); J := Index_Type'Pred (J); end loop; To_Sort (J) := Temp; end loop; end Insertion_Sort; procedure Heap_Sort (To_Sort : access Array_Type; Left, Right : in Index_Type) is -- Precondition: Left < Right Offset : Integer; procedure Sift (To_Sort : access Array_Type; L, R : in Index_Type) is I : Index_Type := L; C : Index_Type := L; begin Temp := To_Sort (L); while (Index_Type'Pos (C) - Offset + 1) <= (Index_Type'Pos (R) - Offset + 1) / 2 loop C := Index_Type'Val ((Index_Type'Pos (I) - Offset + 1) * 2 - 1 + Offset); if C < R and then To_Sort (C) < To_Sort (Index_Type'Succ (C)) then C := Index_Type'Succ (C); end if; exit when not (Temp < To_Sort (C)); To_Sort (I) := To_Sort (C); I := C; end loop; To_Sort (I) := Temp; end Sift; J : Index_Type; begin -- Heap_Sort -- Precondition: Left < Right Offset := Index_Type'Pos (Left); -- Set J to the middle: J := Index_Type'Val ((Index_Type'Pos (Right) - Offset + 1) / 2 + Offset - 1); -- Build the heap: for I in reverse Index_Type range Left .. J loop Sift (To_Sort, I, Right); end loop; -- And now extract elements and re-build the heap. J := Right; loop -- Put the largest element (which is now in front) at the end and -- replace it with the last element. Swap (To_Sort, Left, J); J := Index_Type'Pred (J); exit when J = Left; -- Rebuild the remaining heap (one element less). Sift (To_Sort, Left, J); end loop; end Heap_Sort; procedure Intro_Sort (To_Sort : access Array_Type; L, R : in Index_Type; D : in Natural) is Left : Index_Type := L; Right : Index_Type := R; -- L and R are in parameters, so copy. Depth : Natural := D; -- Ditto for D. I : Index_Type := Left; J : Index_Type := Right; Middle : Index_Type; begin -- Intro_Sort while Index_Type'Pos (Right) - Index_Type'Pos (Left) > Cut_Off loop if Depth = 0 then Heap_Sort (To_Sort, Left, Right); return; end if; Middle := Index_Type'Val (Index_Type'Pos (Left) + (Index_Type'Pos (Right) - Index_Type'Pos (Left)) / 2); -- Median-of-three: if To_Sort (Middle) < To_Sort (Left) then Swap (To_Sort, Middle, Left); end if; if To_Sort (Right) < To_Sort (Left) then Swap (To_Sort, Right, Left); end if; if To_Sort (Right) < To_Sort (Middle) then Swap (To_Sort, Right, Middle); end if; Pivot := To_Sort (Middle); -- Here, I = Left and J = Right while I < J loop while To_Sort (I) < Pivot loop I := Index_Type'Succ (I); end loop; while Pivot < To_Sort (J) loop J := Index_Type'Pred (J); end loop; if I <= J then if I < J then Swap (To_Sort, I, J); end if; -- Now increment I and decrement J..., but beware of -- boundary conditions! if I < Index_Type'Last then I := Index_Type'Succ (I); end if; if J > Index_Type'First then J := Index_Type'Pred (J); end if; end if; end loop; Depth := Depth - 1; if Index_Type'Pos (J) - Index_Type'Pos (Left) > Index_Type'Pos (Right) - Index_Type'Pos (I) then if I < Right then Intro_Sort (To_Sort, I, Right, Depth); end if; I := Left; Right := J; else if J > Left then Intro_Sort (To_Sort, Left, J, Depth); end if; J := Right; Left := I; end if; -- If either I or J saturated, Left >= Right now, and we'll -- quit the outer loop. end loop; if Left < Right then Insertion_Sort (To_Sort, Left, Right); end if; end Intro_Sort; begin -- Sort_Slice_G if To_Sort'Last > To_Sort'First and then From <= To then if From < To_Sort'First or else To > To_Sort'Last then -- If 'From' is > To_Sort'Last, then so is 'To'. And if 'To' is -- < To_Sort'First, then so is 'From'. Hence the above condition -- is sufficient to ensure that *both* indices are within range. raise Constraint_Error; end if; Intro_Sort (To_Sort, From, To, Max_Depth (Index_Type'Pos (To) - Index_Type'Pos (From) + 1)); end if; end Sort_Slice_G; ---------------------------------------------------------------------------- -- A very general sort that can be used to sort whatever you like. As -- long as you can provide random access in constant time, this will -- be a logarithmic sort. (It's an introspective quicksort, too.) -- generic -- with function Is_Smaller (Left, Right : in Integer) return Boolean; -- -- Shall return True if the element at index 'Left' is smaller than -- -- the element at index 'Right' and Fasle otherwise. -- with procedure Copy (To, From : in Integer); -- -- Shall copy the element at index 'From' to position 'To'. procedure Sort_Indexed_G (Left, Right : in Natural) is pragma Suppress (Overflow_Check); pragma Suppress (Index_Check); pragma Suppress (Range_Check); procedure Swap (L, R : in Natural); pragma Inline (Swap); -- inline this for increased performance. procedure Swap (L, R : in Natural) is begin Copy (-1, L); Copy (L, R); Copy (R, -1); end Swap; procedure Insertion_Sort (L, R : in Positive) is -- Precondition: L < R. J : Natural; begin -- Insertion_Sort for I in Natural range L + 1 .. R loop Copy (-1, I); J := I; while J > L and then Is_Smaller (-1, J - 1) loop Copy (J, J - 1); J := J - 1; end loop; Copy (J, -1); end loop; end Insertion_Sort; procedure Heap_Sort (Left, Right : in Positive) is -- Precondition: Left < Right Offset : constant Integer := Left; procedure Sift (L, R : in Natural) is I : Integer := L; C : Integer := L; begin Copy (-1, L); while (C - Offset + 1) <= (R - Offset + 1) / 2 loop C := (I - Offset + 1) * 2 - 1 + Offset; if C < R and then Is_Smaller (C, C + 1) then C := C + 1; end if; exit when not Is_Smaller (-1, C); Copy (I, C); I := C; end loop; Copy (I, -1); end Sift; J : Natural; begin -- Heap_Sort -- Precondition: Left < Right J := (Right - Offset + 1) / 2 + Offset - 1; -- Build the heap: for I in reverse Positive range Left .. J loop Sift (I, Right); end loop; -- And now extract elements and re-build the heap. J := Right; loop -- Put the largest element (which is now in front) at the end and -- replace it with the last element. Swap (Left, J); J := J - 1; exit when J = Left; -- Rebuild the remaining heap (one element less). Sift (Left, J); end loop; end Heap_Sort; procedure Intro_Sort (L, R : in Natural; D : in Natural) is Left : Natural := L; -- L and R are in parameters, so copy. Right : Natural := R; Depth : Natural := D; -- Ditto for D. I : Natural := Left; J : Natural := Right; Middle : Natural; begin -- Intro_Sort while Right - Left > Cut_Off loop if Depth = 0 then Heap_Sort (Left, Right); return; end if; Middle := Left + (Right - Left) / 2; -- Median-of-three: if Is_Smaller (Middle, Left) then Swap (Middle, Left); end if; if Is_Smaller (Right, Left) then Swap (Right, Left); end if; if Is_Smaller (Right, Middle) then Swap (Right, Middle); end if; Copy (-2, Middle); -- Here, I = Left and J = Right while I < J loop while Is_Smaller (I, -2) loop I := I + 1; end loop; while Is_Smaller (-2, J) loop J := J - 1; end loop; if I <= J then if I < J then Swap (I, J); end if; if I < Positive'Last then I := I + 1; end if; if J > 1 then J := J - 1; end if; end if; end loop; Depth := Depth - 1; if Integer (J) - Integer (Left) > Integer (Right) - Integer (I) then -- Left part is longer. if I < Right then Intro_Sort (I, Right, Depth); end if; I := Left; Right := J; else -- Right part is longer. if J > Left then Intro_Sort (Left, J, Depth); end if; J := Right; Left := I; end if; end loop; if Left < Right then Insertion_Sort (Left, Right); end if; end Intro_Sort; begin -- Sort_Indexed_G if Left < Right then Intro_Sort (Left, Right, Max_Depth (Right - Left + 1)); end if; end Sort_Indexed_G; ---------------------------------------------------------------------------- -- Same as above, but using access-to-subroutines. procedure Sort (Left, Right : in Natural; Is_Smaller : in Comparator; Copy : in Copier) is pragma Suppress (Overflow_Check); pragma Suppress (Index_Check); pragma Suppress (Range_Check); pragma Suppress (Access_Check); procedure Swap (L, R : in Natural); pragma Inline (Swap); -- inline this for increased performance. procedure Swap (L, R : in Natural) is begin Copy (-1, L); Copy (L, R); Copy (R, -1); end Swap; procedure Insertion_Sort (L, R : in Positive) is -- Precondition: L < R. J : Natural; begin -- Insertion_Sort for I in Natural range L + 1 .. R loop Copy (-1, I); J := I; while J > L and then Is_Smaller (-1, J - 1) loop Copy (J, J - 1); J := J - 1; end loop; Copy (J, -1); end loop; end Insertion_Sort; procedure Heap_Sort (Left, Right : in Natural) is -- Precondition: Left < Right Offset : constant Integer := Left; procedure Sift (L, R : in Natural) is I : Integer := L; C : Integer := L; begin Copy (-1, L); while (C - Offset + 1) <= (R - Offset + 1) / 2 loop C := (I - Offset + 1) * 2 - 1 + Offset; if C < R and then Is_Smaller (C, C + 1) then C := C + 1; end if; exit when not Is_Smaller (-1, C); Copy (I, C); I := C; end loop; Copy (I, -1); end Sift; J : Natural; begin -- Heap_Sort -- Precondition: Left < Right J := (Right - Offset + 1) / 2 + Offset - 1; -- Build the heap: for I in reverse Positive range Left .. J loop Sift (I, Right); end loop; -- And now extract elements and re-build the heap. J := Right; loop -- Put the largest element (which is now in front) at the end and -- replace it with the last element. Swap (Left, J); J := J - 1; exit when J = Left; -- Rebuild the remaining heap (one element less). Sift (Left, J); end loop; end Heap_Sort; procedure Intro_Sort (L, R : in Natural; D : in Natural) is Left : Natural := L; -- L and R are in parameters, so copy. Right : Natural := R; Depth : Natural := D; -- Ditto for D. I : Natural := Left; J : Natural := Right; Middle : Natural; begin -- Intro_Sort while Right - Left > Cut_Off loop if Depth = 0 then Heap_Sort (Left, Right); return; end if; Middle := Left + (Right - Left) / 2; -- Median-of-three: if Is_Smaller (Middle, Left) then Swap (Middle, Left); end if; if Is_Smaller (Right, Left) then Swap (Right, Left); end if; if Is_Smaller (Right, Middle) then Swap (Right, Middle); end if; Copy (-2, Middle); -- Here, I = Left and J = Right while I < J loop while Is_Smaller (I, -2) loop I := I + 1; end loop; while Is_Smaller (-2, J) loop J := J - 1; end loop; if I <= J then if I < J then Swap (I, J); end if; if I < Positive'Last then I := I + 1; end if; if J > 1 then J := J - 1; end if; end if; end loop; Depth := Depth - 1; if Integer (J) - Integer (Left) > Integer (Right) - Integer (I) then -- Left part is longer. if I < Right then Intro_Sort (I, Right, Depth); end if; I := Left; Right := J; else -- Right part is longer. if J > Left then Intro_Sort (Left, J, Depth); end if; J := Right; Left := I; end if; end loop; if Left < Right then Insertion_Sort (Left, Right); end if; end Intro_Sort; begin -- Sort if Left < Right then -- We have suppressed access checks. Do it once and for all times -- by hand. if Is_Smaller = null or else Copy = null then raise Constraint_Error; end if; Intro_Sort (Left, Right, Max_Depth (Right - Left + 1)); end if; end Sort; ---------------------------------------------------------------------------- end GAL.Sorting; adabrowse_4.0.3/gal-adt-hash_tables.adb0000644000175000017500000010462010234241452016117 0ustar kenken------------------------------------------------------------------------------- -- -- Copyright (c) 2001, 2002 by Thomas Wolf. --
    -- This piece of software is free software; you can redistribute it and/or -- modify it under the terms of the GNU General Public License as published -- by the Free Software Foundation; either version 2, or (at your option) -- any later version. This unit is distributed in the hope that it will be -- useful, but without any warranty; without even the implied -- warranty of merchantability or fitness for a particular purpose. -- See the GNU General Public License for more details. You should have -- received a copy of the GNU General Public License with this distribution, -- see file "GPL.txt". If not, write to the Free -- Software Foundation, 59 Temple Place - Suite 330, Boston, MA 02111-1307, -- USA. --
    --
    -- As a special exception from the GPL, if other files instantiate generics -- from this unit, or you link this unit with other files to produce an -- executable, this unit does not by itself cause the resulting executable -- to be covered by the GPL. This exception does not however invalidate any -- other reasons why the executable file might be covered by the GPL. --
    -- --
    -- Author:
    -- Thomas Wolf (TW) --
    twolf@acm.org
    -- --
    -- Purpose:
    -- Provides dynamic hash tables. Internal collision resolution, automatic -- and explicit resizing. Collision chain index computation can be customized -- though Collision_Policies --
    . -- --
    -- Tasking semantics:
    -- N/A. Not abortion-safe.
    -- --
    -- Storage semantics:
    -- Dynamic storage allocation in a user-supplied storage pool.
    -- -- ------------------------------------------------------------------------------- pragma License (Modified_GPL); with Ada.Unchecked_Deallocation; with GAL.Support.Hashing; -- generic -- type Key_Type (<>) is private; -- type Item (<>) is private; -- -- with package Memory is new GAL.Storage.Memory (<>); -- -- Initial_Size : in GAL.Support.Hashing.Size_Type := 23; -- -- with function Hash -- (Element : in Key_Type) -- return GAL.Support.Hashing.Hash_Type is <>; -- -- with function "=" (Left, Right : in Key_Type) return Boolean is <>; -- -- with function Choose_Size -- (Suggested : in GAL.Support.Hashing.Hash_Type) -- return GAL.Support.Hashing.Hash_Type -- is GAL.Support.Hashing.Next_Prime; -- -- This function is called whenever the size of the hash table is to be -- -- defined. 'Suggested' is the suggested size of the new table; the -- -- function should then return a size that is >= Suggested. If it -- -- returns a smaller value anyway, the exception 'Container_Error' is -- -- raised. package body GAL.ADT.Hash_Tables is use GAL.Support.Hashing; procedure Free is new Ada.Unchecked_Deallocation (Mem, Ptr); procedure Free is new Ada.Unchecked_Deallocation (Key_Type, Key_Ptr); procedure Free is new Ada.Unchecked_Deallocation (Item, Data_Ptr); procedure Free is new Ada.Unchecked_Deallocation (Collision_Policy'Class, Collision_Policy_Ptr); procedure Free is new Ada.Unchecked_Deallocation (Growth_Policy'Class, Growth_Policy_Ptr); ---------------------------------------------------------------------------- function Round_Up (Suggested : in Hash_Type) return Hash_Type is Min_Size : constant Hash_Type := Hash_Type'Max (Suggested, 3); Result : constant Hash_Type := Choose_Size (Min_Size); begin if Result < Min_Size then raise Container_Error; end if; return Result; end Round_Up; ---------------------------------------------------------------------------- function Copy (Old : access Mem) return Ptr is Result : constant Ptr := new Mem (Old'Range); begin for I in Old'Range loop Result (I).State := Old (I).State; if Old (I).State = Used then Result (I).Value := new Item'(Old (I).Value.all); Result (I).Key := new Key_Type'(Old (I).Key.all); end if; end loop; return Result; end Copy; ---------------------------------------------------------------------------- procedure Grow (Table : in out Hash_Table; Grown : out Boolean); -- Forward declaration; we have a mutual recursion here between 'Grow' and -- 'Add'. procedure Add (Table : in out Hash_Table; Key : in Key_Ptr; Element : in Data_Ptr) is H : constant Hash_Type := Hash (Key.all); Start : Hash_Type := H mod Table.Table'Length + 1; N : Natural := 0; Curr : Hash_Type := Start; Index : Hash_Type := 0; Grown : Boolean := False; begin loop case Table.Table (Curr).State is when Empty => -- Not found! if Index = 0 then Index := Curr; end if; exit; when Deleted => -- A hole in the chain? if Index = 0 then Index := Curr; exit when Grown; end if; -- Continue!! when Used => null; end case; N := N + 1; Curr := Next (Table.Collisions, Curr, H, Table.Table'Length, N); if Curr = 0 or else Curr = Start then exit when Index > 0; -- No useable slot found on the whole chain, and we may grow the -- table: grow it! Grow (Table, Grown); exit when not Grown; -- Then re-try, just to find a useable slot: Start := H mod Table.Table'Length + 1; Curr := Start; N := 0; Index := 0; end if; end loop; if Index = 0 then raise Container_Full; end if; Table.Table (Index).State := Used; Table.Table (Index).Key := Key; Table.Table (Index).Value := Element; Table.Count := Table.Count + 1; end Add; procedure Rehash (Table : in out Hash_Table; Size : in Size_Type) is New_Table : constant Ptr := new Mem (1 .. Size); Old_Table : Ptr := Table.Table; N : Hash_Type := Table.Count; begin Table.Table := New_Table; Table.Count := 0; if Old_Table /= null then if N > 0 then for I in Old_Table'Range loop if Old_Table (I).State = Used then Add (Table, Old_Table (I).Key, Old_Table (I).Value); N := N - 1; exit when N = 0; end if; end loop; end if; Free (Old_Table); end if; end Rehash; procedure Grow (Table : in out Hash_Table; Grown : out Boolean) is Curr_Size : Hash_Type; New_Size : Size_Type; begin Grown := False; if Table.Growth = null then return; end if; if Table.Table = null then Curr_Size := 0; else Curr_Size := Table.Table'Length; end if; New_Size := Round_Up (Increase (Table.Growth, Curr_Size)); if New_Size <= Curr_Size then return; end if; Rehash (Table, New_Size); Grown := True; end Grow; procedure Find (Table : in out Hash_Table; Key : in Key_Type; Index : out Hash_Type; Found : out Boolean; May_Grow : in Boolean) is H : constant Hash_Type := Hash (Key); Start : Hash_Type := H mod Table.Table'Length + 1; N : Natural := 0; Curr : Hash_Type := Start; Grown : Boolean := False; begin Index := 0; Found := False; loop case Table.Table (Curr).State is when Empty => -- Not found! if Index = 0 then Index := Curr; end if; exit; when Deleted => -- A hole in the chain? if Index = 0 then Index := Curr; exit when Grown; end if; -- Continue!! when Used => if not Grown and then Table.Table (Curr).Key.all = Key then Index := Curr; Found := True; exit; end if; -- If we've already grown the table, we need not check the -- keys again; we already know that the key is not in the -- table. We just want to find an index where we might -- store the item. end case; N := N + 1; Curr := Next (Table.Collisions, Curr, H, Table.Table'Length, N); if Curr = 0 or else Curr = Start then exit when Index > 0 or else not May_Grow; -- No useable slot found on the whole chain, and we may grow the -- table: grow it! Grow (Table, Grown); exit when not Grown; -- Then re-try, just to find a useable slot: Start := H mod Table.Table'Length + 1; Curr := Start; N := 0; Index := 0; end if; end loop; end Find; procedure Find (Table : in Hash_Table; Key : in Key_Type; Index : out Hash_Type; Found : out Boolean) is H : constant Hash_Type := Hash (Key); Start : constant Hash_Type := H mod Table.Table'Length + 1; N : Natural := 0; Curr : Hash_Type := Start; begin Index := 0; Found := False; loop case Table.Table (Curr).State is when Empty => -- Not found! if Index = 0 then Index := Curr; end if; exit; when Deleted => -- A hole in the chain? if Index = 0 then Index := Curr; end if; -- Continue!! when Used => if Table.Table (Curr).Key.all = Key then Index := Curr; Found := True; exit; end if; end case; N := N + 1; exit when Table.Collisions = null; -- Hey, if the collision policy is still null, we never ever had -- a collision, and hence we needn't continue! Curr := Next (Table.Collisions, Curr, H, Table.Table'Length, N); exit when Curr = 0 or else Curr = Start; end loop; end Find; procedure Add (Table : in out Hash_Table; Key : in Key_Type; Element : in Item; Overwrite : in Boolean := False) is Index : Hash_Type; Found : Boolean; begin if Table.Table = null then Table.Table := new Mem (1 .. Round_Up (Table.Initial_Size)); end if; if Table.Collisions = null then Table.Collisions := new Default_Collision_Policy; end if; declare Length : constant Hash_Type := Table.Table'Length; begin Find (Table, Key, Index, Found, True); if Found then if Overwrite then Free (Table.Table (Index).Key); Table.Table (Index).Key := new Key_Type'(Key); Free (Table.Table (Index).Value); Table.Table (Index).Value := new Item'(Element); return; else raise Duplicate_Key; end if; end if; if Index = 0 then raise Container_Full; end if; if Length = Table.Table'Length -- We didn't re-size and then Table.Resize_At /= 0.0 -- and we may resize and then Load_Factor (Float (Table.Count + 1) / Float (Length)) > Table.Resize_At -- and the table is pretty full then Resize : declare Grown : Boolean; begin Grow (Table, Grown); if Grown then Find (Table, Key, Index, Found, True); if Index = 0 then -- Shouldn't happen! raise Container_Error; end if; end if; end Resize; end if; end; -- Insert it at 'Index': Table.Table (Index).State := Used; Table.Table (Index).Key := new Key_Type'(Key); Table.Table (Index).Value := new Item'(Element); Table.Count := Table.Count + 1; end Add; procedure Add (Table : in out Hash_Table; Key : in Key_Type; Element : access Item; Overwrite : in Boolean := False) is Index : Hash_Type; Found : Boolean; begin if Table.Table = null then Table.Table := new Mem (1 .. Round_Up (Table.Initial_Size)); end if; if Table.Collisions = null then Table.Collisions := new Default_Collision_Policy; end if; declare Length : constant Hash_Type := Table.Table'Length; begin Find (Table, Key, Index, Found, True); if Found then if Overwrite then Free (Table.Table (Index).Key); Table.Table (Index).Key := new Key_Type'(Key); Free (Table.Table (Index).Value); Table.Table (Index).Value := new Item'(Element.all); return; else raise Duplicate_Key; end if; end if; if Index = 0 then raise Container_Full; end if; if Length = Table.Table'Length -- We didn't re-size and then Table.Resize_At /= 0.0 -- and we may resize and then Load_Factor (Float (Table.Count + 1) / Float (Length)) > Table.Resize_At -- and the table is pretty full then Resize : declare Grown : Boolean; begin Grow (Table, Grown); if Grown then Find (Table, Key, Index, Found, True); if Index = 0 then -- Shouldn't happen! raise Container_Error; end if; end if; end Resize; end if; end; -- Insert it at 'Index': Table.Table (Index).State := Used; Table.Table (Index).Key := new Key_Type'(Key); Table.Table (Index).Value := new Item'(Element.all); Table.Count := Table.Count + 1; end Add; procedure Insert (Table : in out Hash_Table; Key : in Key_Type; Element : in Item) is begin Add (Table, Key, Element, False); end Insert; procedure Insert (Table : in out Hash_Table; Key : in Key_Type; Element : access Item) is begin Add (Table, Key, Element, False); end Insert; ---------------------------------------------------------------------------- procedure Replace (Table : in out Hash_Table; Key : in Key_Type; Element : in Item) is begin Add (Table, Key, Element, True); end Replace; procedure Replace (Table : in out Hash_Table; Key : in Key_Type; Element : access Item) is begin Add (Table, Key, Element, True); end Replace; ---------------------------------------------------------------------------- procedure Delete (Table : in out Hash_Table; Key : in Key_Type) is Index : Hash_Type; Found : Boolean; begin if Table.Count = 0 then raise Container_Empty; end if; Find (Table, Key, Index, Found); if Found then Free (Table.Table (Index).Key); Free (Table.Table (Index).Value); Table.Table (Index).State := Deleted; Table.Count := Table.Count - 1; else raise Not_Found; end if; end Delete; procedure Delete (Table : in out Hash_Table; Key : in Key_Type; Element : out Item) is Index : Hash_Type; Found : Boolean; begin if Table.Count = 0 then raise Container_Empty; end if; Find (Table, Key, Index, Found); if Found then Element := Table.Table (Index).Value.all; -- Do this first, so that the table remains intact if it should raise -- an exception. Free (Table.Table (Index).Key); Free (Table.Table (Index).Value); Table.Table (Index).State := Deleted; Table.Count := Table.Count - 1; else raise Not_Found; end if; end Delete; ---------------------------------------------------------------------------- function Retrieve (Table : in Hash_Table; Key : in Key_Type) return Item is Index : Hash_Type; Found : Boolean; begin if Table.Count = 0 then raise Container_Empty; end if; Find (Table, Key, Index, Found); if not Found then raise Not_Found; end if; return Table.Table (Index).Value.all; end Retrieve; function Contains (Table : in Hash_Table; Key : in Key_Type) return Boolean is Index : Hash_Type; Found : Boolean; begin if Table.Count = 0 then return False; end if; Find (Table, Key, Index, Found); return Found; end Contains; ---------------------------------------------------------------------------- function Nof_Elements (Table : in Hash_Table) return Hash_Type is begin return Table.Count; end Nof_Elements; function Is_Empty (Table : in Hash_Table) return Boolean is begin return Table.Count = 0; end Is_Empty; function Load (Table : in Hash_Table) return Load_Factor is begin if Table.Table = null then return 0.0; end if; return Load_Factor (Float (Table.Count) / Float (Table.Table'Length)); end Load; function Size (Table : in Hash_Table) return Hash_Type is begin if Table.Table = null then return 0; end if; return Table.Table'Length; end Size; ---------------------------------------------------------------------------- procedure Swap (Left, Right : in out Hash_Table) is procedure Exchange is new GAL.Support.Swap (GAL.Support.Hashing.Hash_Type); procedure Exchange is new GAL.Support.Swap (Ptr); procedure Exchange is new GAL.Support.Swap (Collision_Policy_Ptr); procedure Exchange is new GAL.Support.Swap (Growth_Policy_Ptr); procedure Exchange is new GAL.Support.Swap (GAL.Support.Hashing.Load_Factor); begin Exchange (Left.Count, Right.Count); Exchange (Left.Table, Right.Table); Exchange (Left.Collisions, Right.Collisions); Exchange (Left.Growth, Right.Growth); Exchange (Left.Resize_At, Right.Resize_At); Exchange (Left.Initial_Size, Right.Initial_Size); end Swap; ---------------------------------------------------------------------------- procedure Resize (Table : in out Hash_Table; New_Size : in Size_Type) is -- The difference from 'Grow' above is that the table may shrink. Real_Size : constant Size_Type := Round_Up (New_Size); Curr_Size : Hash_Type; begin if Table.Table = null then Curr_Size := 0; else Curr_Size := Table.Table'Length; end if; if Real_Size < Table.Count then raise Container_Error; end if; if Real_Size = Curr_Size then return; end if; Rehash (Table, Real_Size); end Resize; ---------------------------------------------------------------------------- procedure Reset (Table : in out Hash_Table) is begin if Table.Table /= null and then Table.Count > 0 then declare N : Hash_Type := Table.Count; begin for I in Table.Table'Range loop if Table.Table (I).State = Used then Free (Table.Table (I).Key); Free (Table.Table (I).Value); N := N - 1; exit when N = 0; end if; end loop; end; end if; Table.Count := 0; if Table.Table /= null then Free (Table.Table); end if; Table.Table := null; end Reset; procedure Reset (Table : in out Hash_Table; New_Size : in Size_Type) is begin Reset (Table); Table.Initial_Size := New_Size; end Reset; procedure Reset (Table : in out Hash_Table; New_Size : in Size_Type; Resize_At : in Load_Factor) is begin Reset (Table, New_Size); Table.Resize_At := Resize_At; end Reset; ---------------------------------------------------------------------------- procedure Merge (Result : in out Hash_Table; Source : in Hash_Table) is begin if Source.Count = 0 then return; end if; if Result.Count = 0 then Reset (Result); Result.Count := Source.Count; Result.Table := Copy (Source.Table); return; else -- Both result and source have elements declare Copy : Hash_Table := Result; N : Hash_Type := Source.Count; begin for I in Source.Table'Range loop if Source.Table (I).State = Used then begin Insert (Copy, Source.Table (I).Key.all, Source.Table (I).Value); -- Raises Duplicate_Error if the key already exists. exception when Container_Full => Resize (Copy, 2 * Copy.Table'Length); Insert (Copy, Source.Table (I).Key.all, Source.Table (I).Value); end; N := N - 1; exit when N = 0; end if; end loop; Result := Copy; end; end if; end Merge; procedure Merge (Result : in out Hash_Table; Source : in Hash_Table; Overwrite : in Boolean) is begin if Source.Count = 0 then return; end if; if Result.Count = 0 then Merge (Result, Source); else declare N : Hash_Type := Source.Count; Index : Hash_Type; Found : Boolean; begin for I in Source.Table'Range loop if Source.Table (I).State = Used then Find (Result, Source.Table (I).Key.all, Index, Found, True); if Found then if Overwrite then Free (Result.Table (Index).Value); Result.Table (Index).Value := new Item'(Source.Table (I).Value.all); end if; else if Index = 0 then Resize (Result, 2 * Result.Table'Length); Find (Result, Source.Table (I).Key.all, Index, Found, True); if Index = 0 then raise Container_Error; end if; end if; Result.Table (Index).State := Used; Result.Table (Index).Key := new Key_Type'(Source.Table (I).Key.all); Result.Table (Index).Value := new Item'(Source.Table (I).Value.all); Result.Count := Result.Count + 1; end if; N := N - 1; exit when N = 0; end if; end loop; end; end if; end Merge; ---------------------------------------------------------------------------- -- Collision chain management. Every hash table has a collision policy; -- the default is to do exponential hashing, which seems to be least -- Susceptible to clustering (primary or secondary) and better than -- double hashing. -- -- (Note however that better is relative anyway. Depending on the -- circumstances, linear probing may in fact be the most appropriate -- choice, as it exhibits a good access locality and thus may be a win on -- modern processor architctures with multi-level caching.) procedure Set_Collision_Policy (Table : in out Hash_Table; Policy : in Collision_Policy'Class) is begin if Table.Collisions /= null then Free (Table.Collisions); end if; Table.Collisions := new Collision_Policy'Class'(Policy); if Table.Table /= null and then Table.Count > 0 then Rehash (Table, Table.Table'Length); end if; end Set_Collision_Policy; procedure Remove_Collision_Policy (Table : in out Hash_Table) is begin if Table.Collisions /= null and then Table.Collisions.all not in Default_Collision_Policy'Class then Free (Table.Collisions); Table.Collisions := new Default_Collision_Policy; if Table.Table /= null and then Table.Count > 0 then Rehash (Table, Table.Table'Length); end if; end if; end Remove_Collision_Policy; function Get_Collision_Policy (Table : in Hash_Table) return GAL.Support.Hashing.Collision_Policy'Class is begin return Table.Collisions.all; end Get_Collision_Policy; ---------------------------------------------------------------------------- procedure Set_Resize (Table : in out Hash_Table; Resize_At : in Load_Factor) is begin Table.Resize_At := Resize_At; end Set_Resize; procedure Set_Growth_Policy (Table : in out Hash_Table; Policy : in Growth_Policy'Class) is begin if Table.Growth /= null then Free (Table.Growth); end if; Table.Growth := new Growth_Policy'Class'(Policy); end Set_Growth_Policy; procedure Remove_Growth_Policy (Table : in out Hash_Table) is begin if Table.Growth /= null then Free (Table.Growth); end if; Table.Growth := null; end Remove_Growth_Policy; function Has_Growth_Policy (Table : in Hash_Table) return Boolean is begin return Table.Growth /= null; end Has_Growth_Policy; function Get_Growth_Policy (Table : in Hash_Table) return Growth_Policy'Class is begin return Table.Growth.all; end Get_Growth_Policy; ---------------------------------------------------------------------------- -- Traversals procedure Action (V : in out Visitor; Key : in Key_Type; Value : in out Item; Quit : in out Boolean) is pragma Warnings (Off, V); -- silence -gnatwa pragma Warnings (Off, Key); -- silence -gnatwa pragma Warnings (Off, Value); -- silence -gnatwa pragma Warnings (Off, Quit); -- silence -gnatwa begin null; end Action; procedure Action (V : in out Visitor; Key : in Key_Type; Value : access Item; Quit : in out Boolean) is pragma Warnings (Off, V); -- silence -gnatwa pragma Warnings (Off, Key); -- silence -gnatwa pragma Warnings (Off, Value); -- silence -gnatwa pragma Warnings (Off, Quit); -- silence -gnatwa begin null; end Action; -- generic -- with procedure Execute -- (Key : in Key_Type; -- Value : access Item; -- Quit : in out Boolean); procedure Traverse_By_Reference_G (Table : in Hash_Table) is begin if Table.Count = 0 then return; end if; declare Old_Table : constant Ptr := Table.Table; Old_Count : constant Hash_Type := Table.Count; N : Hash_Type := Old_Count; Quit : Boolean := False; begin for I in Table.Table'Range loop if Table.Table (I).State = Used then Execute (Table.Table (I).Key.all, Table.Table (I).Value, Quit); exit when Quit; if Table.Table /= Old_Table or else Table.Count /= Old_Count then -- ?? Table has been modified! raise Container_Error; end if; N := N - 1; exit when N = 0; end if; end loop; end; end Traverse_By_Reference_G; procedure Traverse (Table : in Hash_Table; V : in out Visitor'Class; Reference : in Boolean := False) is procedure Apply (Key : in Key_Type; Value : access Item; Quit : in out Boolean) is begin if Reference then Action (V, Key, Value, Quit); else Action (V, Key, Value.all, Quit); end if; end Apply; procedure Traverse is new Traverse_By_Reference_G (Apply); begin Traverse (Table); end Traverse; -- generic -- with procedure Execute -- (Key : in Key_Type; -- Value : in out Item; -- Quit : in out Boolean); procedure Traverse_G (Table : in Hash_Table) is procedure Apply (Key : in Key_Type; Value : access Item; Quit : in out Boolean) is begin Execute (Key, Value.all, Quit); end Apply; procedure Traverse is new Traverse_By_Reference_G (Apply); begin Traverse (Table); end Traverse_G; ---------------------------------------------------------------------------- package body Unsafe is function Retrieve (Table : in Hash_Table; Key : in Key_Type) return Item_Ptr is Index : Hash_Type; Found : Boolean; begin if Table.Count = 0 then return null; end if; Find (Table, Key, Index, Found); if not Found then return null; end if; return Item_Ptr (Table.Table (Index).Value); end Retrieve; end Unsafe; ---------------------------------------------------------------------------- -- Comparisons -- generic -- with function "=" (Left, Right : in Item) return Boolean is <>; function Equals (Left, Right : in Hash_Table) return Boolean is function Eq (L : access Mem; R : in Hash_Table; N : in Hash_Type) return Boolean is Not_Compared_Yet : Hash_Type := N; Index : Hash_Type; Found : Boolean; begin for I in L'Range loop if L (I).State = Used then Find (R, L (I).Key.all, Index, Found); if not Found or else L (I).Value.all /= R.Table (Index).Value.all then return False; end if; Not_Compared_Yet := Not_Compared_Yet - 1; exit when Not_Compared_Yet = 0; end if; end loop; return True; end Eq; begin -- Equals if Left.Count /= Right.Count then return False; end if; if Left.Table = Right.Table or else Left.Count = 0 then return True; end if; if Left.Table'Length > Right.Table'Length then return Eq (Right.Table, Left, Left.Count); else return Eq (Left.Table, Right, Left.Count); end if; end Equals; function "=" (Left, Right : in Hash_Table) return Boolean is function Dummy (L, R : in Item) return Boolean; pragma Inline (Dummy); function Dummy (L, R : in Item) return Boolean is pragma Warnings (Off, L); -- silence -gnatwa pragma Warnings (Off, R); -- silence -gnatwa begin return True; end Dummy; function Eq is new Equals (Dummy); begin -- "=" return Eq (Left, Right); end "="; ---------------------------------------------------------------------------- -- Controlled operations procedure Adjust (Table : in out Hash_Table) is begin if Table.Table /= null then Table.Table := Copy (Table.Table); end if; if Table.Collisions /= null then Table.Collisions := new Collision_Policy'Class'(Table.Collisions.all); end if; if Table.Growth /= null then Table.Growth := new Growth_Policy'Class'(Table.Growth.all); end if; end Adjust; procedure Finalize (Table : in out Hash_Table) is begin Reset (Table); if Table.Collisions /= null then Free (Table.Collisions); end if; Table.Collisions := null; if Table.Growth /= null then Free (Table.Growth); end if; Table.Growth := null; end Finalize; ---------------------------------------------------------------------------- -- Stream support. procedure Write (Stream : access Ada.Streams.Root_Stream_Type'Class; Table : in Hash_Table) is begin Hash_Type'Write (Stream, Table.Count); if Table.Count > 0 then declare N : Hash_Type := Table.Count; begin for I in Table.Table'Range loop if Table.Table (I).State = Used then Key_Type'Output (Stream, Table.Table (I).Key.all); Item'Output (Stream, Table.Table (I).Value.all); N := N - 1; exit when N = 0; end if; end loop; end; end if; end Write; procedure Read (Stream : access Ada.Streams.Root_Stream_Type'Class; Table : out Hash_Table) is N : Hash_Type; begin Hash_Type'Read (Stream, N); Reset (Table, N + 1); for I in 1 .. N loop declare Key : constant Key_Type := Key_Type'Input (Stream); Element : aliased Item := Item'Input (Stream); begin Insert (Table, Key, Element'Access); exception when Container_Full => -- Actually, that shouldn't happen if 'Choose_Size' and the -- collision resolution policy are well behaved. Resize (Table, 2 * Table.Table'Length); Insert (Table, Key, Element'Access); end; end loop; end Read; end GAL.ADT.Hash_Tables; adabrowse_4.0.3/ad-projects-impl_yes.ads0000644000175000017500000000400610234241444016404 0ustar kenken------------------------------------------------------------------------------- -- -- This file is part of AdaBrowse. -- -- Copyright (c) 2002 by Thomas Wolf. --
    -- AdaBrowse is free software; you can redistribute it and/or modify it -- under the terms of the GNU General Public License as published by the -- Free Software Foundation; either version 2, or (at your option) any -- later version. AdaBrowse is distributed in the hope that it will be -- useful, but without any warranty; without even the implied -- warranty of merchantability or fitness for a particular purpose. -- See the GNU General Public License for more details. You should have -- received a copy of the GNU General Public License with this distribution, -- see file "GPL.txt". If not, write to the Free -- Software Foundation, 59 Temple Place - Suite 330, Boston, MA 02111-1307, -- USA. --
    -- --
    -- Author:
    -- Thomas Wolf (TW) --
    twolf@acm.org
    -- --
    -- Purpose:
    -- Project manager implementation.
    -- -- ------------------------------------------------------------------------------- pragma License (GPL); with Ada.Text_IO; private package AD.Projects.Impl_Yes is procedure Handle_Project_File (Name : in String); procedure Get_Source_File_List (File : in out Ada.Text_IO.File_Type); function Get_Source_Directories return String; function Get_Tree_Directory return String; function Get_Output_Directory return String; function Get_Project_File_Name return String; function Project_Version return String; procedure Reset (On_Error : in Boolean); procedure Define_Variable (Name : in String; Value : in String); procedure Initialize; end AD.Projects.Impl_Yes; adabrowse_4.0.3/ad-exclusions.adb0000644000175000017500000001316410234241450015111 0ustar kenken------------------------------------------------------------------------------- -- -- This file is part of AdaBrowse. -- -- Copyright (c) 2002 by Thomas Wolf. --
    -- AdaBrowse is free software; you can redistribute it and/or modify it -- under the terms of the GNU General Public License as published by the -- Free Software Foundation; either version 2, or (at your option) any -- later version. AdaBrowse is distributed in the hope that it will be -- useful, but without any warranty; without even the implied -- warranty of merchantability or fitness for a particular purpose. -- See the GNU General Public License for more details. You should have -- received a copy of the GNU General Public License with this distribution, -- see file "GPL.txt". If not, write to the Free -- Software Foundation, 59 Temple Place - Suite 330, Boston, MA 02111-1307, -- USA. --
    -- --
    -- Author:
    -- Thomas Wolf (TW) --
    twolf@acm.org
    -- --
    -- Purpose:
    -- Handling of "pathes": prefix URLs defined for cross-references.
    -- -- ------------------------------------------------------------------------------- pragma License (GPL); with Ada.Strings.Unbounded; with Ada.Unchecked_Deallocation; with Util.Strings; package body AD.Exclusions is package ASU renames Ada.Strings.Unbounded; use Util.Strings; type Exclusion; type Exclusion_Ptr is access Exclusion; type Exclusion is record Key : ASU.Unbounded_String; Next : Exclusion_Ptr; Excluded : Boolean; end record; procedure Free is new Ada.Unchecked_Deallocation (Exclusion, Exclusion_Ptr); procedure Add (Anchor : in out Exclusion_Ptr; Key : in String; Excluded : in Boolean) is use type ASU.Unbounded_String; P, Q : Exclusion_Ptr; K : ASU.Unbounded_String := ASU.To_Unbounded_String (Key); begin P := Anchor; while P /= null loop exit when Key'Length > ASU.Length (P.Key); if K = P.Key then P.Excluded := Excluded; return; end if; Q := P; P := P.Next; end loop; if Q = null then Anchor := new Exclusion'(K, P, Excluded); else Q.Next := new Exclusion'(K, P, Excluded); end if; -- The list is ordered by key length, earlier keys first. end Add; function Is_Excluded (Unit : in String; Anchor : in Exclusion_Ptr) return Boolean is P : Exclusion_Ptr := Anchor; begin while P /= null loop if Is_Prefix (Unit, ASU.To_String (P.Key)) then return P.Excluded; end if; P := P.Next; end loop; return False; end Is_Excluded; ---------------------------------------------------------------------------- Excl_Anchor : Exclusion_Ptr; procedure Add_Exclusion (Key : in String) is begin Add (Excl_Anchor, To_Lower (Key), True); end Add_Exclusion; procedure Add_Exclusion_Exception (Key : in String) is begin Add (Excl_Anchor, To_Lower (Key), False); end Add_Exclusion_Exception; function Is_Excluded (Unit_Name : in String) return Boolean is begin return Is_Excluded (To_Lower (Unit_Name), Excl_Anchor); end Is_Excluded; function Skip (Unit_Name : in String) return Boolean is begin return Is_Excluded (Unit_Name) or else No_XRef (Unit_Name); end Skip; procedure Clear (Anchor : in out Exclusion_Ptr; Flag : in Boolean) is P, Q, R : Exclusion_Ptr; begin P := Anchor; Q := null; while P /= null loop R := P; if P.Excluded = Flag then if Q = null then Anchor := P.Next; else Q.Next := P.Next; end if; else Q := P; end if; P := P.Next; if R.Excluded = Flag then Free (R); end if; end loop; end Clear; procedure Clear_Exclusions is begin Clear (Excl_Anchor, True); end Clear_Exclusions; procedure Clear_Exclusion_Exceptions is begin Clear (Excl_Anchor, False); end Clear_Exclusion_Exceptions; ---------------------------------------------------------------------------- No_XRefs : Exclusion_Ptr; procedure Add_No_XRef (Key : in String) is begin Add (No_XRefs, To_Lower (Key), True); end Add_No_XRef; procedure Add_No_XRef_Exception (Key : in String) is begin Add (No_XRefs, To_Lower (Key), False); end Add_No_XRef_Exception; function No_XRef (Unit_Name : in String) return Boolean is begin return Is_Excluded (To_Lower (Unit_Name), No_XRefs); end No_XRef; end AD.Exclusions; adabrowse_4.0.3/Makefile0000644000175000017500000002413010234241454013322 0ustar kenken#------------------------------------------------------------------------------ # Makefile for GNAT for adabrowse # # This makefile assumes that the ASIS libraries are in # ADA_INCLUDE_PATH and ADA_OBJECTS_PATH. If this is not # the case, uncomment and edit the alternate definitions # of GCC_OPTIONS and LD_OPTIONS below, and comment the now # uncommented ones. # # 05-APR-2002 TW Initial version # 02-MAY-2002 TW Added 'nasty', changed the targets so they are macro refs. # 08-MAY-2002 TW Changed the makefile so that it uses 'get_gcc' to figure # out the name of the gcc used by GNAT. # 08-JUN-2003 TW Added the automatic configuration stuff (with or without # the project manager support). # 20-NOV-2003 TW Correction for splitting path lists: Unix has ':' as the # path separator, whereas Windows uses ';'! # 22-FEB-2005 TW Make sure to use ./get_gcc instead of plain get_gcc so that # the makefile also works if a user doesn't have the current # directory in the PATH. #------------------------------------------------------------------------------ # It is assumed that the pathes to your ASIS installation are in your # ADA_INCLUDE_PATH and ADA_OBJECTS_PATH! # This makefile has become pretty complicated, mainly because of things # which we figure out when the makefile is run: # # 1. We determine the compiler name used by gnatmake by default, and # generate a package spec AD.Setup containing this name. # # This is so because on some Linux installations, the compiler to # use for GNAT is not called "gcc" but "gnatgcc", and I want AdaBrowse # to default to this name. # # To get the compiler's name and to create AD.Setup, we build a small # utility program called get_gcc. # # 2. We figure out whether the GNAT sources are available. This is indicated # by variable GNATSRC being set to the directory where the GNAT sources # are. If this variable is set, and the directory actually contains the # GNAT sources, then we try to configure AdaBrowse such that it uses the # GNAT project manager. # # This is so because I don't want to distribute parts of the GNAT sources # with AdaBrowse. The reason is that the project manager and some files # it depends on differ between different GNAT versions, and furthermore # I think ACT wouldn't like my distributing extracts from the 3.15p and # 3.16a sources. Also, I'd have to add more and more extracts as new # compiler versions appeared. # # So the way chosen here is actually simpler: the GNAT sources, which # contain the project manager, are available from ACT, and users who # want project manager support in AdaBrowse can get them and then just # tell this makefile where they are. It isn't even necessary to try to # build GNAT. The only requiremnet is that the sources are consistent # with the GNAT and ASIS version used. # # To configure AdaBrowse, we build a utility program in subdirectory # ./config and run it. The program then tries to build (using gnatmake) # a dummy application using the project manager. If that succeeds, it # configures AdaBrowse by generating two files ad-projects-impl.ads # and ad-projects-impl-get_parent.adb. if building the dummy application # failes, these files are set up such that AdaBrowse doesn't use the # GNAT project manager. # # Only after these two configuration steps building of AdaBrowse proper # begins. # # And finally, this makefile is being complicated by the fact that the # it has to work with the ancient GNU make 3.77 (distributed with GNAT 3.15p). GCC_OPTIONS = -O2 LD_OPTIONS = -lasis host := $(shell gcc -dumpmachine) RM := rm -f CP := cp ADABROWSE := adabrowse NASTY := nasty GET_GCC := get_gcc EXE := CONFIGURE := adconf PATH_SEP := : ifeq "$(findstring mingw32, $(host))" "mingw32" # Assume we're on Windows RM := cmd.exe /c del CP := cmd.exe /c copy ADABROWSE := adabrowse.exe NASTY := nasty.exe GET_GCC := get_gcc.exe CONFIGURE := adconf.exe EXE := .exe PATH_SEP := ; endif # GNAT-specific gcc options: enable all warnings, and style checking. # The style checking flags are nearly as plain "-gnaty", but do not # check comment format, and do not require explicit specs for all # subprograms. I chose this setting because these two things do not # correspond at all to *my* style. GNAT_OPTIONS := -gnatwa -gnaty3abefhiklmprt GET_GCC_GEN = get_gcc.o get_gcc.ali GET_GCC_FULL = $(GET_GCC_GEN) get_gcc.txt get_gcc.use ifdef GNATSRC INTERNAL_GNAT_SRC := $(subst \,/,$(subst \\,/,$(GNATSRC))) INTERNAL_GNAT_SRC2 := $(INTERNAL_GNAT_SRC) # Check that this GNAT source directory is correct: ifeq "$(strip $(wildcard $(INTERNAL_GNAT_SRC)/prj-env.ads))" "" INTERNAL_GNAT_SRC := $(INTERNAL_GNAT_SRC2)/ada ifeq "$(strip $(wildcard $(INTERNAL_GNAT_SRC)/prj-env.ads))" "" INTERNAL_GNAT_SRC := $(INTERNAL_GNAT_SRC2)/src/ada ifeq "$(strip $(wildcard $(INTERNAL_GNAT_SRC)/prj-env.ads))" "" $(error GNAT sources not found) # # Unfortunately, the error function doesn't work with GNU make 3.77, # which is being distributed with GNAT 3.15p. (The GNAT 3.16a distribution # contains the current GNU make 3.79.1.) # # Hence we deliberately use a non-existing dependency to make make stop # with a halfway sensible message. adabrowse : Cannot_Find_GNAT_Sources endif endif endif endif # Figure out where the ASIS installation is. Include_Dirs := $(subst \,/, $(subst $(PATH_SEP), ,$(ADA_INCLUDE_PATH))) A4G_DIR := $(foreach dir,$(Include_Dirs),$(wildcard $(dir)/a4g.ali)) ifeq "$(strip $(A4G_DIR))" "" # ADA_INCLUDE_PATH had better contain the asis directory. $(error ADA_INCLUDE_PATH must contain the ASIS installation!) adabrowse : ASIS_Not_On_ADA_INCLUDE_PATH endif ASIS_DIR := $(strip $(dir $(word 1, $(A4G_DIR)))) ifeq "$(ASIS_DIR)" "" # Something went wrong. $(error Cannot figure out the ASIS installation directory!) adabrowse : ASIS_Not_Found endif ifdef ADABROWSE_GNATSRC # Set the pathes so that we can compile files from the GNAT source # distribution without problems. If we don't do that, we will not be # able to link, because the GNAT compiler sources also contain # the library sources. We must therefore make sure that the installed # library always comes first! # But don't do this only the variable comes from the command line, and if # ADABROWSE_GCC_LIB also is defined! ifneq "$(findstring command,$(origin ADABROWSE_GNATSRC))" "" ifdef ADABROWSE_GCC_LIB export ADA_INCLUDE_PATH:=$(ASIS_DIR)$(PATH_SEP)$(ADABROWSE_GCC_LIB)$(PATH_SEP)$(ADABROWSE_GNATSRC)$(PATH_SEP)$(ADA_INCLUDE_PATH) export ADA_OBJECTS_PATH:=$(ASIS_DIR)$(PATH_SEP)$(subst adainclude,adalib,$(ADABROWSE_GCC_LIB))$(PATH_SEP)$(ADA_OBJECTS_PATH) endif endif # The GNAT sources may of course use internal GNAT units, so we don't # want that warning. Also, we get spurious warnings on elaboration issues, # all in GNAT sources. Suppress this warning, too. GNAT_OPTIONS += -gnatwIL endif # MAIN TARGET: (first in this makefile) all: ./config/$(CONFIGURE) run-conf $(MAKE) $(ADABROWSE) \ ADABROWSE_GCC_LIB=$(dir $(subst \,/,$(shell $(shell ./get_gcc -gcc get_gcc.use) -print-libgcc-file-name)))adainclude \ ADABROWSE_GNATSRC=$(INTERNAL_GNAT_SRC) # Configuration stuff. We build an executable adconf, which then figures out # from its parameters and by trying to compile a certain file whether or not # we do have project manager support. ./config/$(CONFIGURE): get_gcc.use ./config/adconf.adb cd ./config; gnatmake -q -I.. adconf # If adconf is called with two argument only (i.e., GNATSRC is not set), it # configures AdaBrowse not to use the project manager. # # If adconf is called with four arguments, it configures AdaBrowse such that # it *does* use the project manager, and then tries to compile the file # ad-projects-impl_yes.adb. If that fails, it retries again after having # made one single change to account for a difference between GNAT 3.15p and # 3.16a. If compilation still fails, it reverts to the configuration not # using the project manager. run-conf: cd ./config; \ ./$(CONFIGURE) $(shell ./get_gcc -gcc get_gcc.use) \ $(ASIS_DIR) \ $(INTERNAL_GNAT_SRC) \ $(dir $(subst \,/,$(shell $(shell ./get_gcc -gcc get_gcc.use) -print-libgcc-file-name)))adainclude -cd ./config; $(CP) ad-projects-impl.ads .. -cd ./config; $(CP) ad-projects-impl_yes-get_parent.adb .. # All this 'get_gcc' stuff here is GNAT specific: we try to dynamically # figure out the name of the gcc used by GNAT. On some systems, it # appears that this name is "gnatgcc", not "gcc"! get_gcc.o : gnatmake -q -c -f get_gcc.adb get_gcc.ali: gnatmake -q -c -f get_gcc.adb $(GET_GCC): get_gcc.o get_gcc.ali get_gcc.adb gnatmake -q get_gcc # Note: the dependency below first ensures that all the files we're # going to delete in the rm command actually exist. This is a work- # around for Win 2k, where make stops because cmd.exe /c del returns # a failure exit code because some files may not exist. However, they # must not exist when we run gnatmake, or we won't have the desired # output in get_gcc.err. (The trick is that the first line in that # file will be the compile command gnatmake uses for get_gcc.adb, # which will start with the compiler name.) get_gcc.use: $(GET_GCC) $(RM) $(GET_GCC) $(GET_GCC_GEN) gnatmake get_gcc 2>get_gcc.use # Ok, finally we can build adabrowse! The first dependency handles the # C file in the distribution. All the others may be regenerated. ifneq "$(EXE)" "" # On Windows, add a target "adabrowse" adabrowse: $(ADABROWSE) -$(warning AdaBrowse built without reconfiguration) endif $(ADABROWSE): util-nl.o \ ad-setup.ads \ ad-projects-impl.ads ad-projects-impl_yes-get_parent.adb gnatmake $(GCC_OPTIONS) adabrowse -cargs $(GNAT_OPTIONS) \ -largs $(LD_OPTIONS) strip $(ADABROWSE) $(NASTY): nasty.adb gnatmake nasty -cargs $(GCC_OPTIONS) ad-setup.ads: get_gcc.use $(shell ./get_gcc -setup get_gcc.use) util-nl.o: get_gcc.use util-nl.c $(shell ./get_gcc -gcc get_gcc.use) -c $(GCC_OPTIONS) util-nl.c clean: $(RM) $(ADABROWSE) $(NASTY) $(GET_GCC) *.o *.ali adabrowse_4.0.3/ad-options.ads0000644000175000017500000000554010234241443014432 0ustar kenken------------------------------------------------------------------------------- -- -- This file is part of AdaBrowse. -- -- Copyright (c) 2002 by Thomas Wolf. --
    -- AdaBrowse is free software; you can redistribute it and/or modify it -- under the terms of the GNU General Public License as published by the -- Free Software Foundation; either version 2, or (at your option) any -- later version. AdaBrowse is distributed in the hope that it will be -- useful, but without any warranty; without even the implied -- warranty of merchantability or fitness for a particular purpose. -- See the GNU General Public License for more details. You should have -- received a copy of the GNU General Public License with this distribution, -- see file "GPL.txt". If not, write to the Free -- Software Foundation, 59 Temple Place - Suite 330, Boston, MA 02111-1307, -- USA. --
    -- --
    -- Author:
    -- Thomas Wolf (TW) --
    twolf@acm.org
    -- --
    -- Purpose:
    -- Global storage of file names.
    -- -- ------------------------------------------------------------------------------- pragma License (GPL); package AD.Options is pragma Elaborate_Body; procedure Set_Private_Too (Flag : in Boolean); function Private_Too return Boolean; procedure Set_Output_Name (Name : in String); procedure Set_Output_Directory (Name : in String); function Output_Name return String; -- Returns the full name given in the -o option function Output_Directory return String; -- Returns only the directory part of the name given in the -o option procedure Set_Overwrite (Allowed : in Boolean); function Allow_Overwrite return Boolean; type File_Handling is (Single_File, Multiple_Files); procedure Set_Processing_Mode (To : in File_Handling); function Processing_Mode return File_Handling; -- if Processing_Mode is -- -- Single_File: -- if Output_Name /= "" then -- use Output_Name -- else -- if Output_Directory /= "" then -- Create file in Output_Directory -- else -- if file-to-process had a path then -- Create file in that directory -- else -- Create file in current directory -- end if -- end if -- end if -- -- Multiple_Files: -- Printer that produces several files: -- Do not check Output_Name -- Printer that produces one file only: -- Same as for Single_File end AD.Options; adabrowse_4.0.3/util-text-internal.adb0000644000175000017500000000441310234241454016105 0ustar kenken------------------------------------------------------------------------------- -- -- Copyright © 2001, 2002 by Thomas Wolf. --
    -- This piece of software is free software; you can redistribute it and/or -- modify it under the terms of the GNU General Public License as published -- by the Free Software Foundation; either version 2, or (at your option) -- any later version. This software is distributed in the hope that it will -- be useful, but without any warranty; without even the implied -- warranty of merchantability or fitness for a particular purpose. -- See the GNU General Public License for more details. You should have -- received a copy of the GNU General Public License with this distribution, -- see file "GPL.txt". If not, write to the Free -- Software Foundation, 59 Temple Place - Suite 330, Boston, MA 02111-1307, -- USA. --
    --
    -- As a special exception from the GPL, if other files instantiate generics -- from this unit, or you link this unit with other files to produce an -- executable, this unit does not by itself cause the resulting executable -- to be covered by the GPL. This exception does not however invalidate any -- other reasons why the executable file might be covered by the GPL. --
    -- -- -- Thomas Wolf (TW) -- -- -- -- Direct access to the internal string buffer. -- -- -- -- -- -- Dynamic storage allocation in the default pool. -- -- -- -- 07-JUN-2002 TW Initial version. -- ------------------------------------------------------------------------------- pragma License (Modified_GPL); package body Util.Text.Internal is function Get_Ptr (Source : in Unbounded_String) return String_Access is begin return Source.Data; end Get_Ptr; procedure Set_Ptr (Source : in out Unbounded_String; Ptr : in String_Access) is begin Free (Source.Data); if Ptr /= null then Source.Data := Ptr; else Source.Data := Null_String'Access; end if; end Set_Ptr; end Util.Text.Internal; adabrowse_4.0.3/util-strings.ads0000644000175000017500000005046410234241447015032 0ustar kenken------------------------------------------------------------------------------- -- -- Copyright © 2001, 2002 by Thomas Wolf. --
    -- This piece of software is free software; you can redistribute it and/or -- modify it under the terms of the GNU General Public License as published -- by the Free Software Foundation; either version 2, or (at your option) -- any later version. This software is distributed in the hope that it will -- be useful, but without any warranty; without even the implied -- warranty of merchantability or fitness for a particular purpose. -- See the GNU General Public License for more details. You should have -- received a copy of the GNU General Public License with this distribution, -- see file "GPL.txt". If not, write to the Free -- Software Foundation, 59 Temple Place - Suite 330, Boston, MA 02111-1307, -- USA. --
    --
    -- As a special exception from the GPL, if other files instantiate generics -- from this unit, or you link this unit with other files to produce an -- executable, this unit does not by itself cause the resulting executable -- to be covered by the GPL. This exception does not however invalidate any -- other reasons why the executable file might be covered by the GPL. --
    -- -- -- Thomas Wolf (TW) -- -- -- -- Various string utilities not provided in the standard library. Some -- of these also are repeated here, so that one can get all one needs -- with a single "@with@". -- -- -- -- -- -- -- -- 01-MAR-2002 TW Initial version. -- 14-MAR-2002 TW Added 'Count'. -- 18-MAR-2002 TW Added 'Letters'. -- 02-MAY-2002 TW Added 'Identifier'. -- 24-JUN-2002 TW Added 'Skip_String', 'Shell_Quotes', 'String_Quotes', -- 'Quote', 'Unquote', 'Next_Non_Blank', and 'Is_Prefix' -- and made the exception 'Illegal_Pattern' a renaming. -- 28-JUN-2002 TW Added 'Unquote_All'. -- 02-AUG-2002 TW Added 'Replace'. -- 07-AUG-2002 TW Added 'First_Index', 'Last_Index', and 'Count' with -- a string pattern. -- 12-OCT-2002 TW Added 'Next_Blank'. -- 18-JUN-2003 TW Added 'Equal'. -- 07-JUL-2003 TW Added 'Cardinality'. -- ------------------------------------------------------------------------------- pragma License (Modified_GPL); with Ada.Characters.Handling; with Ada.Strings.Fixed; with Ada.Strings.Maps; package Util.Strings is pragma Elaborate_Body; function To_Lower (Ch : in Character) return Character renames Ada.Characters.Handling.To_Lower; function To_Upper (Ch : in Character) return Character renames Ada.Characters.Handling.To_Upper; function To_Lower (S : in String) return String renames Ada.Characters.Handling.To_Lower; function To_Upper (S : in String) return String renames Ada.Characters.Handling.To_Upper; function To_Mixed (S : in String) return String; -- Maps all character immediately following an underscore ('@_@') or a -- period ('@.@') or a white space as defined by @Blanks@ below -- to upper case, all others to lower case. Forward : constant Ada.Strings.Direction := Ada.Strings.Forward; Backward : constant Ada.Strings.Direction := Ada.Strings.Backward; function Cardinality (Set : in Ada.Strings.Maps.Character_Set) return Natural; -- Returns the number of characters in @Set@. function Equal (Left, Right : in String) return Boolean; -- Case insensitive string comparison. function Count (Src : in String; Ch : in Character) return Natural; -- Returns the number of occurrences of @Ch@ in the string @Src@. function Count (Source : in String; Pattern : in String) return Natural; -- As @Ada.Strings.Fixed.Count@, but without mapping and therefore way -- faster. function Index (Src : in String; Ch : in Character; Dir : in Ada.Strings.Direction := Forward) return Natural; -- Returns the index of the first (or last, if @Dir@ is @Backward@) -- occurrence of @Ch@ in the string @Src@, or zero if no occurrence -- of this character can be found. function First_Index (Src : in String; Ch : in Character) return Natural; -- As @Index@, but hard-wired to searching forward. function Last_Index (Src : in String; Ch : in Character) return Natural; -- As @Index@, but hard-wired to searching backward. function First_Index (Source : in String; Pattern : in String) return Natural; -- As @Index@, but hard-wired to searching forward. Way faster than -- @Ada.Strings.Fixed.Index@, also because no mapping is applied. function Last_Index (Source : in String; Pattern : in String) return Natural; -- As @Index@, but hard-wired to searching backward. Way faster than -- @Ada.Strings.Fixed.Index@, also because no mapping is applied. function Index (Source : in String; Pattern : in String; Dir : in Ada.Strings.Direction := Forward) return Natural; -- As @Ada.Strings.Fixed.Index@, but hard-wired to not using a mapping. function Is_Prefix (Source : in String; Prefix : in String) return Boolean; -- Returns @True@ if @Source@ starts with @Prefix@, @False@ otherwise. function Is_Suffix (Source : in String; Suffix : in String) return Boolean; -- Returns @True@ if @Source@ ends with @Suffix@, @False@ otherwise. Blanks : constant Ada.Strings.Maps.Character_Set; -- Anything that can be considered white space: not just a blank, but -- also tabs, non-breaking spaces, carriage returns, and so on. Letters : constant Ada.Strings.Maps.Character_Set; -- 7-bit ASCII letters, i.e. A-Z and a-z. Null_Set : constant Ada.Strings.Maps.Character_Set := Ada.Strings.Maps.Null_Set; function Is_Blank (Ch : in Character) return Boolean; -- Returns Ada.Strings.Maps.Is_In (Ch, Blanks). function Is_In (Set : in Ada.Strings.Maps.Character_Set; Ch : in Character) return Boolean; -- Returns Ada.Strings.Maps.Is_In (Ch, Set). Provided -- mainly because I very often mix up the order of the arguments. Left : constant Ada.Strings.Trim_End := Ada.Strings.Left; Right : constant Ada.Strings.Trim_End := Ada.Strings.Right; Both : constant Ada.Strings.Trim_End := Ada.Strings.Both; function Trim (S : in String; Side : in Ada.Strings.Trim_End := Both) return String; -- Removes all characters in @Blanks@ declared above from the -- specified string end. function Trim (S : in String; Left : in Ada.Strings.Maps.Character_Set; Right : in Ada.Strings.Maps.Character_Set := Null_Set) return String renames Ada.Strings.Fixed.Trim; -- Removes the specified character sets. The point of this renaming is -- the default parameter. No_Escape : constant Character := Character'Val (0); -- This constant is used to indicate to the string parsing operations -- @Get_String@ and @In_String@ that string delimiters cannot be escaped. Shell_Quotes : constant Ada.Strings.Maps.Character_Set; -- Quotes typically recognized by command shells: double, single, and -- back quote. String_Quotes : constant Ada.Strings.Maps.Character_Set; -- Typical string quotes: double and single quotes. procedure Get_String (S : in String; From, To : out Natural; Delim : in Character := '"'; Escape : in Character := No_Escape); -- Returns in @From@ and @To@ the indices of the beginning or end of the -- next string in @S@. -- -- A string is defined as a sequence of characters enclosed by @Delim@; -- any occurrences of @Delim@ after the first @Delim@ that are -- immediately preceeded by @Escape@ do not yet terminate the string -- but are part of the string's content. -- -- -- -- -- --
    @Escape@
    -- /= Delim -- -- Delimiters that are part of the string must follow an -- @Escape@ immediately. Two @Escape@s in a row -- are considered one literal @Escape@. For instance, with -- Delim = '"' and Escape = '\', the operation -- recognizes C strings. --
    -- = Delim -- -- Delimiters that are part of the string must be doubled, an in Ada -- strings. --
    -- = No_Escape -- -- Strings cannot contain instances of the delimiter. The second -- occurrence of a delimiter in @S@ is the string end. --
    -- -- If no string is found, both @From@ and @To@ are zero. -- -- If an unterminated string is found, @From@ is the index of -- the opening occurrence of @Delim@, and @To@ is zero. -- -- Otherwise, a string was found, and @From@ and @To@ are the indices of -- the opening and closing occurrences of @Delim@, respectively. function In_String (S : in String; Delim : in Character := '"'; Escape : in Character := No_Escape) return Boolean; -- Returns @True@ if the end of @S@ is within an unterminated "string" -- (as described above), and @False@ otherwise. (If @S@ ends with -- an unterminated string, returns @True@, otherwise @False@.) function Skip_String (S : in String; Delim : in Character := '"'; Escape : in Character := No_Escape) return Natural; -- Returns the index of the closing occurrence of @Delim@ of the string -- in @S@. S (S'First) should be the opening occurrence of -- @Delim@. The semantics of @Delim@ and @Escape@ are as for @Get_String@. -- -- Returns zero if co closing occurrence of @Delim@ can be found in @S@. function Quote (S : in String; Delim : in Character; Escape : in Character) return String; -- Quote a string. @S@ is supposed to contain the string's contents -- (without the delimiters). Any embedded delimiter is quoted as follows: -- --
      --
    • If Escape = No_Escape, @S@ is returned. --
    • If Escape = Delim, all occurrences of @Delim@ in -- @S@ are replaced by two @Delim@s. --
    • Otherwise, an @Escape@ is inserted before any occurrence of -- @Delim@ or @Escape@ in @S@. --
    function Unquote (S : in String; Delim : in Character; Escape : in Character) return String; -- Unquotes embedded delimiters in a string. @S@ is supposed to contain -- the string's contents without the bounding delimiters. -- --
      --
    • If Escape = No_Escape, @S@ is returned. --
    • If Escape = Delim, all non-overlapping occurrences -- of two consecutive @Delim@s in @S@ are replaced by a single -- @Delim@. --
    • Otherwise, any non-overlapping occurrence of two @Escape@s in -- @S@ is replaced by a single @Escape@, and any occurrence of an -- @Escape@ immediately followed by a @Delim@ is replaced by a -- single @Delim@. --
    -- -- In all cases, the following is true: -- 
       --    Unquote (Quote (S, Delim, Escape), Delim, Escape) = S
   --
    function Unquote_All (S : in String; Quotes : in Ada.Strings.Maps.Character_Set; Escape : in Character := No_Escape) return String; -- Unquotes all non-overlapping occurrences of strings within @S@ -- delimited by any character in @Quotes@. If @Escape@ = @No_Escape@, -- the Ada convention (embedded delimiters must be doubled) is assumed, -- otherwise, embedded delimiters must be escaped by @Escape@. ---------------------------------------------------------------------------- function Identifier (S : in String) return Natural; -- If @S@ starts with an identifier, returns the index of the identifier's -- last character. Otherwise, returns zero. For the purpose of this -- function, an identifier has the following syntax: -- -- 
       --     Identifier = Letter {Letter | Digit | '_'}.
   --     Letter     = 'A' .. 'Z' | 'a' ..'z'.
   --     Digit      = '0' .. '9'.
   --
    -- -- Note that this is the Ada 95 syntax, except that multiple underscores -- in a row are allowed. function Next_Non_Blank (S : in String) return Natural; -- Returns the index of the first character in @S@ such that -- Is_Blank (S (I)) = False, or zero if no such character -- exists in @S@. function Next_Blank (S : in String) return Natural; -- Returns the index of the first character in @S@ for which -- Is_Blank (S (I)) = True, or zero if there is no such -- character in @S@. function Replace (Source : in String; What : in String; By : in String) return String; -- Replaces all non-overlapping occurrences of @What@ in @Source@ by @By@. -- Occurrences of @What@ in @By@ are not replaced recursively, -- as this would lead to an infinite recursion anyway. ---------------------------------------------------------------------------- No_Set_Inverter : constant Character := Character'Val (0); Illegal_Pattern : exception renames Ada.Strings.Pattern_Error; -- Raised by @Wildcard_Match@ if a pattern is malformed. generic Any_One : in Character := '?'; Zero_Or_More : in Character := '*'; Set_Inverter : in Character := '!'; Has_Char_Set : in Boolean := True; Has_Escape : in Boolean := True; Zero_Or_One : in Boolean := False; function Wildcard_Match (Pattern : in String; Text : in String) return Boolean; -- Returns @True@ if the wildcard string @Pattern@ matches the text -- @Text@, and @False@ otherwise. Raises @Illegal_Pattern@ if the -- pattern is malformed. -- -- Wildcard patterns are a simple form of regular -- expressions. Their syntax is as follows: (This description assumes -- the default values for all generic parameters.) -- -- -- -- -- -- -- -- -- -- --
    @?@Matches any one character.
    @*@Matches any sequence of characters (zero or more).
    @[...]@The characters between the square brackets define a character -- set. Matches any one character of the given set.
    @[!...]@Defines an inverted set. Matches any one character not -- listed.
    -- -- Character sets are given either by specifying a range ("a-z"), single -- characters ("xyz") or any combination of the two ("a-zA-Z0123"). If the -- first character in the set is '!', the set is inverted, i.e. it contains -- all characters not listed. -- -- Any character that is not one of the meta characters '@?@', '@*@', -- '@[@', '@]@', and '@\@' matches literally. To do a literal match against -- any meta character, escape it with a backslash, or use a one-character -- character set. -- -- @\?@ or @[?]@ matches a ?
    -- @\*@ or @[*]@ matches a *
    -- @\[@ or @[[]@ matches a [
    -- @\]@ or @[]]@ matches a ]
    -- @\\@ or @[\]@ matches a \
    -- -- In a character set, characters must not and need not be escaped. To -- include the character '@!@' in a character set, make sure it is not the -- character immediately following the '@[@'. To include '@]@' in a -- character set, make sure it follows the opening '@[@' (or the opening -- "@[!@" in the case of an inverted set) immediately. To include '@-@' -- in a character set, make it either the first or last character of the -- set, or the lower or upper bound of a range, e.g. "@[-a-z]@", or -- "@[abc-]@", or "@[ab --9]@", or "@[!-./]@". -- -- (Note that in "@[ab --9]@", the set is '@a@' or '@b@' or (' ' to '@-@') -- or '@9@', not '@a@' or '@b@' or ' ' or ('@-@' to '@9@'), i.e. the -- earliest interpretation of a range is taken. Also note that the set -- "@[abc--9]@" is illegal because in the range "@c--@", '@c@' > '@-@'. -- Specify this set as "@[--9abc]@" instead.) -- -- The '@!@' used for set inversion matches literally when used outside a -- character set. It is a meta character only when immediately following -- the opening '@[@' of a character set. -- -- Note that by default '@?@' matches any one character, not zero -- or one! -- -- Matches always are case sensitive. To do a case -- insensitive match, map upper-case letter to lower-case -- letters in both the text and the pattern before calling this routine. -- -- Note: if character sets are not allowed, they match literally. E.g. -- the pattern "@[abc]@" would then match the text "@[abc]@", but not -- "@a@". -- -- Generic Parameters: -- -- -- -- -- -- --
    -- Any_One -- The character used to match any one arbitrary text character. If -- @Zero_Or_One@ (see below) is True, this character matches -- zero or one arbitrary characters. --
    -- Zero_Or_More -- The character used to match zero or more arbitrary characters. --
    -- Set_Inverter -- The character used for inverting a character set. If it is -- @No_Set_Inverter@, but @Has_Char_Set@ (see below) is @True@, -- character sets cannot be inverted. If @Has_Char_Set@ is @False@, -- @Set_Inverter@ is ignored. --
    -- Has_Char_Set -- If @True@, character sets are supported, otherwise, they're not -- allowed and the set meta characters '@[@' and '@]@' always match -- literally. (Note that the set inverter (by default '@!@') always -- matches literally if used outside a character set.) --
    -- Has_Escape -- If @True@, backslash-escaping of meta characters is supported. If -- @False@, it is not, and one-character character sets must be used -- for literal matches against meta characters. --
    -- Zero_Or_One -- If @True@, the @Any_One@ character matches zero or one text -- characters. If @False@, @Any_One@ must match a text -- character. --
    -- -- The three characters used for @Any_One@, @Zero_Or_More@ and -- @Set_Inverter@ should of course be distinct, and not coincide with -- any of the other meta characters either! -- -- Note that character sets always must match a character; a null match is -- never allowed. (If null matches were allowed, a pattern like "@[!a]*@" -- would also match texts starting with "@a@"!) function Match (Pattern : in String; Text : in String) return Boolean; -- A default instantiation of the above @Wildcard_Match@. private Blanks : constant Ada.Strings.Maps.Character_Set := Ada.Strings.Maps.To_Set (Ada.Strings.Maps.Character_Ranges' (1 => (Character'Val (0), ' '), 2 => (Character'Val (127), Character'Val (159)))); Letters : constant Ada.Strings.Maps.Character_Set := Ada.Strings.Maps.To_Set ("ABCDEFGHIJKLMNOPQRSTUVWXYZ" & "abcdefghijklmnopqrstuvwxyz"); Shell_Quotes : constant Ada.Strings.Maps.Character_Set := Ada.Strings.Maps.To_Set ("'""`"); String_Quotes : constant Ada.Strings.Maps.Character_Set := Ada.Strings.Maps.To_Set ("'"""); pragma Inline (Is_Blank, Is_In, Is_Prefix, Is_Suffix, First_Index, Last_Index); end Util.Strings; adabrowse_4.0.3/util-files.ads0000644000175000017500000001105610234241447014435 0ustar kenken------------------------------------------------------------------------------- -- -- Copyright © 2001, 2002 by Thomas Wolf. --
    -- This piece of software is free software; you can redistribute it and/or -- modify it under the terms of the GNU General Public License as published -- by the Free Software Foundation; either version 2, or (at your option) -- any later version. This software is distributed in the hope that it will -- be useful, but without any warranty; without even the implied -- warranty of merchantability or fitness for a particular purpose. -- See the GNU General Public License for more details. You should have -- received a copy of the GNU General Public License with this distribution, -- see file "GPL.txt". If not, write to the Free -- Software Foundation, 59 Temple Place - Suite 330, Boston, MA 02111-1307, -- USA. --
    --
    -- As a special exception from the GPL, if other files instantiate generics -- from this unit, or you link this unit with other files to produce an -- executable, this unit does not by itself cause the resulting executable -- to be covered by the GPL. This exception does not however invalidate any -- other reasons why the executable file might be covered by the GPL. --
    -- -- -- Thomas Wolf (TW) -- -- -- -- Provides a generic function to unconditionally open (or create) a file. -- -- -- -- -- -- @Copy_File@ dynamically allocates and deallocates a buffer. -- -- -- -- 02-MAR-2002 TW Initial version. -- 09-JUN-2003 TW Added 'Copy_File'. -- ------------------------------------------------------------------------------- pragma License (Modified_GPL); package Util.Files is pragma Elaborate_Body; generic type File_Type is limited private; type File_Mode is (<>); with procedure Open (File : in out File_Type; Mode : in File_Mode; Name : in String; Form : in String); with procedure Create (File : in out File_Type; Mode : in File_Mode; Name : in String; Form : in String); procedure Open_G (File : in out File_Type; Mode : in File_Mode; Name : in String; Form : in String := ""); -- First tries to open the file; if that fails, tries to create the file. type Buffer_Size is new Natural range 2 ** 10 .. 2 ** 20; -- Buffer size in bytes. Range is from 8k to 1M. Default_Buffer_Size : constant Buffer_Size := 2 ** 16; -- 64kB. File_Exists : exception; procedure Copy_File (From : in String; To : in String := ""; Overwrite : in Boolean := False; Buffer : in Buffer_Size := Default_Buffer_Size); -- Safe file copy operation, it is abort deferred, but not task-safe. -- -- Both @From@ and @To@ may contain pathes; if @From@ specifies a -- non-existing file, or @To@ contains the specification of a non-existing -- directory, the exception @Ada:IO_Exceptions.Name_Error@ will be raised. -- If @From@ specifies a directory, an unspecified exception may be raised, -- typically, this will be @Ada.IO_Exceptions.Use_Error@. -- -- If both @To@ and @From@ specify the same file, an unspecified exception -- may be raised, typically, this will be @Ada.IO_Exceptions.Status_Error@. -- -- If @To@ specifies an existing file and @Overwrite@ is @False@, the -- exception @File_Exists@ is raised. -- -- If @To@ is the empty string, the file specified by @From@ is copied -- into the current directory. -- -- The operation will copy the file in chunks of at most @Buffer@ bytes. -- The buffer for these chunks is allocated and deallocated dynamically. -- -- If @To@ specifies only a directory, the file name is taken from @From@. -- If the operation fails halfway through, @To@ will be removed if it had -- been opened and the exception reporting the failure is propagated. private procedure Copy (From : in String; To : in String; Overwrite : in Boolean; Buffer : in Buffer_Size); -- Same as the above @Copy_File@, but just assumes that both -- @From@ and @To@ are full file specifications. -- -- @Copy_File@ above calls this to actually copy the file. end Util.Files; adabrowse_4.0.3/ad-projects-impl_yes-update_path_hack.adb0000644000175000017500000000561610234241451021653 0ustar kenken------------------------------------------------------------------------------- -- -- This file is part of AdaBrowse. -- -- Copyright (c) 2002 by Thomas Wolf. --
    -- AdaBrowse is free software; you can redistribute it and/or modify it -- under the terms of the GNU General Public License as published by the -- Free Software Foundation; either version 2, or (at your option) any -- later version. AdaBrowse is distributed in the hope that it will be -- useful, but without any warranty; without even the implied -- warranty of merchantability or fitness for a particular purpose. -- See the GNU General Public License for more details. You should have -- received a copy of the GNU General Public License with this distribution, -- see file "GPL.txt". If not, write to the Free -- Software Foundation, 59 Temple Place - Suite 330, Boston, MA 02111-1307, -- USA. --
    -- --
    -- Author:
    -- Thomas Wolf (TW) --
    twolf@acm.org
    -- --
    -- Purpose:
    -- A hack to provide a dummy function GNAT 3.16a imports from a C file -- from the GCC sources, but which actually isn't needed in AdaBrowse.
    -- -- ------------------------------------------------------------------------------- pragma License (GPL); with Interfaces.C.Strings; separate (AD.Projects.Impl_Yes) package body Update_Path_Hack is function Update_Path (Path : in Interfaces.C.Strings.chars_ptr; Component : in Interfaces.C.Strings.chars_ptr) return Interfaces.C.Strings.chars_ptr; pragma Export (C, Update_Path, "update_path"); function Update_Path (Path : in Interfaces.C.Strings.chars_ptr; Component : in Interfaces.C.Strings.chars_ptr) return Interfaces.C.Strings.chars_ptr is pragma Warnings (Off, Path); -- silence -gnatwa pragma Warnings (Off, Component); -- silence -gnatwa begin return Interfaces.C.Strings.New_String (""); end Update_Path; -- More hacks (for GNAT 5.03a). This operation also comes from file -- "prefix.c" from the gcc sources. procedure Set_Std_Prefix (S : in Interfaces.C.Strings.chars_ptr; Len : in Interfaces.C.int); pragma Export (C, Set_Std_Prefix, "set_std_prefix"); procedure Set_Std_Prefix (S : in Interfaces.C.Strings.chars_ptr; Len : in Interfaces.C.int) is pragma Warnings (Off, S); -- silence -gnatwa pragma Warnings (Off, Len); -- silence -gnatwa begin null; end Set_Std_Prefix; Run_Path_Option_Ptr : Interfaces.C.Strings.chars_ptr := Interfaces.C.Strings.New_String (""); pragma Export (C, Run_Path_Option_Ptr, "__gnat_run_path_option"); end Update_Path_Hack; adabrowse_4.0.3/ad-messages-inline.ads0000644000175000017500000000333410234241443016021 0ustar kenken------------------------------------------------------------------------------- -- -- This file is part of AdaBrowse. -- -- Copyright (c) 2002 by Thomas Wolf. --
    -- AdaBrowse is free software; you can redistribute it and/or modify it -- under the terms of the GNU General Public License as published by the -- Free Software Foundation; either version 2, or (at your option) any -- later version. AdaBrowse is distributed in the hope that it will be -- useful, but without any warranty; without even the implied -- warranty of merchantability or fitness for a particular purpose. -- See the GNU General Public License for more details. You should have -- received a copy of the GNU General Public License with this distribution, -- see file "GPL.txt". If not, write to the Free -- Software Foundation, 59 Temple Place - Suite 330, Boston, MA 02111-1307, -- USA. --
    -- --
    -- Author:
    -- Thomas Wolf (TW) --
    twolf@acm.org
    -- --
    -- Purpose:
    -- Inline output of warning and error messages.
    -- -- ------------------------------------------------------------------------------- pragma License (GPL); with AD.Printers; package AD.Messages.Inline is pragma Elaborate_Body; type Error_Reporter is new AD.Messages.Error_Reporter with record The_Printer : AD.Printers.Printer_Ref; end record; procedure Report_Error (Self : in out Error_Reporter; Msg : in String); end AD.Messages.Inline; adabrowse_4.0.3/ad-file_ops.adb0000644000175000017500000002115610234241450014515 0ustar kenken------------------------------------------------------------------------------- -- -- This file is part of AdaBrowse. -- -- Copyright (c) 2002 by Thomas Wolf. --
    -- AdaBrowse is free software; you can redistribute it and/or modify it -- under the terms of the GNU General Public License as published by the -- Free Software Foundation; either version 2, or (at your option) any -- later version. AdaBrowse is distributed in the hope that it will be -- useful, but without any warranty; without even the implied -- warranty of merchantability or fitness for a particular purpose. -- See the GNU General Public License for more details. You should have -- received a copy of the GNU General Public License with this distribution, -- see file "GPL.txt". If not, write to the Free -- Software Foundation, 59 Temple Place - Suite 330, Boston, MA 02111-1307, -- USA. --
    -- --
    -- Author:
    -- Thomas Wolf (TW) --
    twolf@acm.org
    -- --
    -- Purpose:
    -- Provides routines operating on files. Used to insulate the rest of -- AdaBrowse from OS-specifics.
    -- -- ------------------------------------------------------------------------------- pragma License (GPL); with Ada.Calendar; with Ada.Streams.Stream_IO; with Ada.Strings.Fixed; with Util.Calendar.IO; with Util.Pathes; with Util.Strings; with GAL.Support.Comparisons; pragma Elaborate_All (GAL.Support.Comparisons); package body AD.File_Ops is package ASF renames Ada.Strings.Fixed; package ASU renames Ada.Strings.Unbounded; use Util.Strings; procedure Delete (Name : in String) is use Ada.Streams.Stream_IO; F : File_Type; begin Open (F, In_File, Name); Delete (F); exception when others => null; end Delete; function Exists (Name : in String) return Boolean is use Ada.Streams.Stream_IO; F : File_Type; begin Open (F, In_File, Name); Close (F); return True; exception when others => begin if Is_Open (F) then Close (F); end if; exception when others => null; end; return False; end Exists; function Find (Name : in String; Options : in Ada.Strings.Unbounded.Unbounded_String) return String is function Find_Argument (S : in String; After : access Natural) return String is I : Natural := Index (S, '-'); Arg_Start : Natural; begin -- Find_Argument After.all := S'Last + 1; if I = 0 then return ""; end if; Arg_Start := I; I := I + 1; if Arg_Start > S'First and then S (Arg_Start - 1) = '"' then -- It's quoted. while I <= S'Last loop exit when S (I) = '"' and then S (I - 1) /= '\'; I := I + 1; end loop; After.all := I + 1; -- Now we have the contents of a quoted argument from Arg_Start -- to I-1. Un-escape any quotes within: declare Result : String (1 .. I - Arg_Start); K : Natural := 1; begin for J in Arg_Start .. I - 1 loop if J > Arg_Start and then S (J) = '"' and then S (J - 1) = '\' then K := K - 1; end if; Result (K) := S (J); K := K + 1; end loop; return Result (1 .. K - 1); end; else -- It's not quoted: just continue until you hit a white space I := ASF.Index (S (I .. S'Last), Blanks); if I = 0 then I := S'Last + 1; end if; After.all := I; return S (Arg_Start .. I - 1); end if; end Find_Argument; begin -- Find; if Exists (Name) then return Name; end if; if Util.Pathes.Is_Absolute_Path (Name) then return ""; end if; if ASU.Length (Options) > 0 then declare Dirs : constant String := ASU.To_String (Options); I : aliased Natural := Dirs'First; N : constant String := Util.Pathes.Name (Name); begin while I <= Dirs'Last loop declare Arg : constant String := Find_Argument (Dirs (I .. Dirs'Last), I'Access); begin exit when Arg'Last < Arg'First; declare Full_Name : constant String := Util.Pathes.Concat (Arg (Arg'First + 2 .. Arg'Last), N); begin if Exists (Full_Name) then return Full_Name; end if; end; end; end loop; end; end if; return ""; end Find; procedure Create_Unique_File (File : out Ada.Text_IO.File_Type; Name : out Ada.Strings.Unbounded.Unbounded_String; Base_Name : in String; Extension : in String) is function Time_Image (Secs : in Ada.Calendar.Day_Duration) return String is S : String := Util.Calendar.IO.Image (Secs, 2); J : Natural := S'First; begin -- Strip out all non-digits. for I in S'Range loop if S (I) >= '0' and then S (I) <= '9' then S (J) := S (I); J := J + 1; end if; end loop; return S (S'First .. J - 1); end Time_Image; begin for I in 1 .. 10 loop declare Now : constant Ada.Calendar.Time := Ada.Calendar.Clock; begin Ada.Text_IO.Create (File, Ada.Text_IO.Out_File, Base_Name & '_' & Util.Calendar.IO.Image (Now, Separator => "") & '_' & Time_Image (Ada.Calendar.Seconds (Now)) & '.' & Extension); Name := ASU.To_Unbounded_String (Ada.Text_IO.Name (File)); return; exception when Ada.Text_IO.Name_Error => null; end; end loop; Name := ASU.Null_Unbounded_String; end Create_Unique_File; function "<" (Left, Right : in Time_Stamp) return Boolean is use GNAT.OS_Lib; Y0, Y1 : Year_Type; M0, M1 : Month_Type; D0, D1 : Day_Type; HH0, HH1 : Hour_Type; MM0, MM1 : Minute_Type; SS0, SS1 : Second_Type; S0, S1 : Duration; begin GM_Split (OS_Time (Left), Y0, M0, D0, HH0, MM0, SS0); GM_Split (OS_Time (Right), Y1, M1, D1, HH1, MM1, SS1); S0 := Duration (HH0) * 3600.0 + Duration (MM0) * 60.0 + Duration (SS0); S1 := Duration (HH1) * 3600.0 + Duration (MM1) * 60.0 + Duration (SS1); return Y0 < Y1 or else (Y0 = Y1 and then (M0 < M1 or else (M0 = M1 and then (D0 < D1 or else (D0 = D1 and then S0 < S1))))); end "<"; package Time_Ops is new GAL.Support.Comparisons (Time_Stamp, "<"); function "<=" (Left, Right : in Time_Stamp) return Boolean renames Time_Ops."<="; function ">" (Left, Right : in Time_Stamp) return Boolean renames Time_Ops.">"; function ">=" (Left, Right : in Time_Stamp) return Boolean renames Time_Ops.">="; function Is_Directory (Name : in String) return Boolean is begin return GNAT.OS_Lib.Is_Directory (Name); exception when others => return False; end Is_Directory; function Last_Modified (Name : in String) return Time_Stamp is begin if not (Is_Directory (Name) or else Exists (Name)) then raise Name_Error; end if; return Time_Stamp (GNAT.OS_Lib.File_Time_Stamp (Name)); end Last_Modified; end AD.File_Ops; adabrowse_4.0.3/gal-support-hashing.ads0000644000175000017500000001313010234241446016246 0ustar kenken------------------------------------------------------------------------------- -- -- Copyright (c) 2001, 2002 by Thomas Wolf. --
    -- This piece of software is free software; you can redistribute it and/or -- modify it under the terms of the GNU General Public License as published -- by the Free Software Foundation; either version 2, or (at your option) -- any later version. This unit is distributed in the hope that it will be -- useful, but without any warranty; without even the implied -- warranty of merchantability or fitness for a particular purpose. -- See the GNU General Public License for more details. You should have -- received a copy of the GNU General Public License with this distribution, -- see file "GPL.txt". If not, write to the Free -- Software Foundation, 59 Temple Place - Suite 330, Boston, MA 02111-1307, -- USA. --
    --
    -- As a special exception from the GPL, if other files instantiate generics -- from this unit, or you link this unit with other files to produce an -- executable, this unit does not by itself cause the resulting executable -- to be covered by the GPL. This exception does not however invalidate any -- other reasons why the executable file might be covered by the GPL. --
    -- --
    -- Author:
    -- Thomas Wolf (TW) --
    twolf@acm.org
    -- --
    -- Purpose:
    -- Utilities for hashing.
    -- --
    -- Tasking semantics:
    -- N/A. Not abortion-safe.
    -- --
    -- Storage semantics:
    -- No dynamic storage allocation.
    -- -- ------------------------------------------------------------------------------- pragma License (Modified_GPL); package GAL.Support.Hashing is pragma Elaborate_Body; type Hash_Type is mod 2 ** 32; -- The hash type used by GAL.ADT.Hash_Tables. If you want to use other -- hash types, use GAL.Containers.Hash_Tables. subtype Size_Type is Hash_Type range 1 .. Hash_Type'Last; function Next_Prime (After : in Hash_Type) return Hash_Type; -- Returns the next prime number >= 'After'. function Is_Prime (X : in Hash_Type) return Boolean; -- returns @True@ if @X@ is a prime number. function Hash (S : in String) return Hash_Type; -- This is the hash function from the dragon book: Aho, Sethi, Ullman: -- "Compilers -- Principles, Techniques, and Tools", Addison Wesley 1986; -- p. 436. function Hash_Case_Insensitive (S : in String) return Hash_Type; -- Same as @Hash@, but disregards case differences; i.e. "AAA" and "aaa" -- hash to the same value. type Load_Factor is delta 0.1 range 0.0 .. 100.0; ---------------------------------------------------------------------------- type Growth_Policy is abstract tagged private; function Increase (Policy : access Growth_Policy; Current_Size : in Size_Type) return Size_Type is abstract; -- If a hash table needs to grow, and a growth policy is set, @Increase@ -- of the table's growth policy is invoked to determine the new size of -- the hash table. -- -- The function should return a value strictly greater than -- @Current_Size@, otherwise, the hash table will not be resized! type Linear_Growth_Policy (Increment : Size_Type) is new Growth_Policy with private; function Increase (Policy : access Linear_Growth_Policy; Current_Size : in Size_Type) return Size_Type; -- Returns Current_Size + Policy.Increment. type Double_Growth_Policy (Maximum_Increment : Size_Type) is new Growth_Policy with private; function Increase (Policy : access Double_Growth_Policy; Current_Size : in Size_Type) return Size_Type; -- Current_Size + Min (Policy.Maximum_Increment, Current_Size) ---------------------------------------------------------------------------- type Collision_Policy is abstract tagged private; function Next (Policy : access Collision_Policy; Current : in Size_Type; Hash : in Hash_Type; Table_Size : in Size_Type; Count : in Positive) return Hash_Type is abstract; -- Supposed to return the @Count@th index in the collision chain (in the -- range 1 .. @Table_Size@) or zero if no next index can be determined. -- -- Hash table indexing starts at 1! type Default_Collision_Policy is new Collision_Policy with private; function Next (Policy : access Default_Collision_Policy; Current : in Size_Type; Hash : in Hash_Type; Table_Size : in Size_Type; Count : in Positive) return Hash_Type; -- The @Default_Collision_Policy@ does double hashing, using -- Hash mod (Table_Size - 2) as the step. private type Growth_Policy is abstract tagged null record; type Linear_Growth_Policy (Increment : Size_Type) is new Growth_Policy with null record; type Double_Growth_Policy (Maximum_Increment : Size_Type) is new Growth_Policy with null record; type Collision_Policy is abstract tagged null record; type Default_Collision_Policy is new Collision_Policy with record Step : Hash_Type := 1; end record; end GAL.Support.Hashing; adabrowse_4.0.3/ad-config.adb0000644000175000017500000004275310234241447014176 0ustar kenken------------------------------------------------------------------------------- -- -- This file is part of AdaBrowse. -- -- Copyright (c) 2002 by Thomas Wolf. --
    -- AdaBrowse is free software; you can redistribute it and/or modify it -- under the terms of the GNU General Public License as published by the -- Free Software Foundation; either version 2, or (at your option) any -- later version. AdaBrowse is distributed in the hope that it will be -- useful, but without any warranty; without even the implied -- warranty of merchantability or fitness for a particular purpose. -- See the GNU General Public License for more details. You should have -- received a copy of the GNU General Public License with this distribution, -- see file "GPL.txt". If not, write to the Free -- Software Foundation, 59 Temple Place - Suite 330, Boston, MA 02111-1307, -- USA. --
    -- --
    -- Author:
    -- Thomas Wolf (TW) --
    twolf@acm.org
    -- --
    -- Purpose:
    -- Configuration file management.
    -- -- ------------------------------------------------------------------------------- pragma License (GPL); with Ada.Exceptions; with Ada.Strings.Maps; with Ada.Strings.Unbounded; with Ada.Unchecked_Deallocation; with AD.Compiler; with AD.Crossrefs; with AD.Descriptions; with AD.Environment; with AD.Exclusions; with AD.Expressions; with AD.Filters; with AD.Format; with AD.Indices.Configuration; with AD.HTML.Pathes; with AD.Messages; with AD.Printers.HTML; with AD.User_Tags; with Util.Environment.Bash; with Util.Files.Config; with Util.Pathes; with Util.Strings; package body AD.Config is package ASU renames Ada.Strings.Unbounded; use AD.HTML; use Util.Strings; procedure Deallocate is new Ada.Unchecked_Deallocation (String, ASU.String_Access); Reorder : constant Boolean := True; Config_Files : ASU.Unbounded_String; Nof_Config_Files : Natural := 0; function Get_Nof_Config_Files return Natural is begin return Nof_Config_Files; end Get_Nof_Config_Files; function Get_Config_Files return String is begin return ASU.To_String (Config_Files); end Get_Config_Files; function Get_Reorder return Boolean is begin return Reorder; end Get_Reorder; ---------------------------------------------------------------------------- type Add_Procedure is access procedure (Key : in String); ---------------------------------------------------------------------------- type Environment_Expander is new Util.Environment.Bash.Bash_Expander with record File_Name : ASU.String_Access; end record; function Legal_Name (Self : access Environment_Expander; Source : in String) return Natural; function Get (Self : access Environment_Expander; Name : in String) return String; function Legal_Name (Self : access Environment_Expander; Source : in String) return Natural is begin if Source'Last >= Source'First and then (Source (Source'First) = '@' or else Source (Source'First) = '$') then return Source'First; end if; -- Super call: return Util.Environment.Bash.Legal_Name (Util.Environment.Bash.Bash_Expander (Self.all)'Access, Source); end Legal_Name; function Get (Self : access Environment_Expander; Name : in String) return String is begin if Name = "$" then return Util.Pathes.Name (Self.File_Name.all); elsif Name = "@" then return Util.Pathes.Normalize (Util.Pathes.Path (Self.File_Name.all)); end if; return AD.Environment.Get (Name); -- Super call: -- return Util.Environment.Bash.Get -- (Util.Environment.Bash.Bash_Expander (Self.all)'Access, -- Name); end Get; ---------------------------------------------------------------------------- type Reader (Expander : access Environment_Expander) is new Util.Files.Config.Reader with null record; procedure Set_File_Name (Self : in out Reader; Name : in String; Full_Name : in String); function Delimiters (Self : in Reader) return Ada.Strings.Maps.Character_Set; function Skip_String (Self : in Reader; Line : in String; Delim : in Character) return Natural; function Parse_Key (Self : in Reader; Line : in String) return Natural; procedure New_Key (Self : in out Reader; Key : in String; Operator : in String; Value : in String); procedure Set_File_Name (Self : in out Reader; Name : in String; Full_Name : in String) is pragma Warnings (Off, Self); -- silence -gnatwa begin if Nof_Config_Files = 0 then Config_Files := ASU.To_Unbounded_String (Name); else ASU.Append (Config_Files, ", " & Name); end if; Nof_Config_Files := Nof_Config_Files + 1; Self.Expander.File_Name := new String'(Full_Name); end Set_File_Name; function Delimiters (Self : in Reader) return Ada.Strings.Maps.Character_Set is pragma Warnings (Off, Self); -- silence -gnatwa begin return Util.Strings.Shell_Quotes; end Delimiters; function Skip_String (Self : in Reader; Line : in String; Delim : in Character) return Natural is pragma Warnings (Off, Self); -- silence -gnatwa begin -- Ada format: enclosed delimiters must be doubled. return Util.Strings.Skip_String (Line, Delim, Delim); end Skip_String; function Parse_Key (Self : in Reader; Line : in String) return Natural is I : Natural; begin I := Util.Files.Config.Parse_Key (Util.Files.Config.Reader (Self), Line); -- "Format." key may be followed by a string! if I > 0 and then I + 1 < Line'Last then if Line (I + 1) = '.' and then Is_In (String_Quotes, Line (I + 2)) and then To_Lower (Line (Line'First .. I + 1)) = "format." then -- Last component may be a string! I := Skip_String (Self, Line (I + 2 .. Line'Last), Line (I + 2)); if I = 0 then Ada.Exceptions.Raise_Exception (Invalid_Config'Identity, "unterminated string found"); end if; end if; end if; return I; end Parse_Key; procedure New_Key (Self : in out Reader; Key : in String; Operator : in String; Value : in String) is pragma Warnings (Off, Operator); -- silence -gnatwa procedure Parse_List (Add : in Add_Procedure; Value : in String) is I, J : Natural; begin I := Value'First; while I <= Value'Last loop J := Index (Value (I .. Value'Last), ','); if J = 0 then J := Value'Last + 1; end if; declare Prefix : constant String := Trim (Value (I .. J - 1)); begin if Prefix'Last >= Prefix'First then Add (To_Lower (Prefix)); end if; end; I := J + 1; end loop; end Parse_List; function Read_Bool (Str : in String) return Boolean is begin return Boolean'Value (To_Upper (Str)); exception when others => Ada.Exceptions.Raise_Exception (Invalid_Config'Identity, "value must be either 'True' or 'False'"); return False; end Read_Bool; K : constant String := To_Lower (Key); begin -- New_Key if K = "include_file" then -- Recursive include of a configuration file. declare use type ASU.String_Access; Old_File : constant ASU.String_Access := Self.Expander.File_Name; Name : constant String := Expand (Self.Expander, Value); begin -- Note: expansion still uses the old file name! if Name'Last >= Name'First then Util.Files.Config.Read (Name, Self); if Self.Expander.File_Name /= Old_File then Deallocate (Self.Expander.File_Name); Self.Expander.File_Name := Old_File; end if; end if; exception when others => if Self.Expander.File_Name /= Old_File then Deallocate (Self.Expander.File_Name); Self.Expander.File_Name := Old_File; end if; raise; end; elsif K = "refs_to_standard" then AD.Crossrefs.Set_Standard_Units (Read_Bool (Value)); elsif K = "compile" then AD.Compiler.Set_Compile_Command (Expand (Self.Expander, Unquote_All (Value, Shell_Quotes))); elsif K = "index_title" then AD.Indices.Configuration.Set_Title (AD.Indices.Configuration.Unit_Index, Value); elsif K = "index_xref" then AD.Printers.HTML.Set_Index_XRef (Value); elsif K = "char_set" then Set_Char_Set (Value); elsif K = "style_sheet" then Set_Style_Sheet (Expand (Self.Expander, Value)); elsif K = "body" then Set_Body (Value); elsif K = "title.before" then Set_Title (Before, Value); elsif K = "title.after" then Set_Title (After, Value); elsif K = "sub_title.before" then Set_Subtitle (Before, Value); elsif K = "sub_title.after" then Set_Subtitle (After, Value); elsif K = "keyword.before" then Set_Keyword (Before, Value); elsif K = "keyword.after" then Set_Keyword (After, Value); elsif K = "attribute.before" then Set_Attribute (Before, Value); elsif K = "attribute.after" then Set_Attribute (After, Value); elsif K = "definition.before" then Set_Definition (Before, Value); elsif K = "definition.after" then Set_Definition (After, Value); elsif K = "comment.before" then Set_Comment (Before, Value); elsif K = "comment.after" then Set_Comment (After, Value); elsif K = "literal.before" then Set_Literal (Before, Value); elsif K = "literal.after" then Set_Literal (After, Value); elsif K = "no_xref" then Parse_List (AD.Exclusions.Add_No_XRef'Access, Value); elsif K = "xref" then Parse_List (AD.Exclusions.Add_No_XRef_Exception'Access, Value); elsif K = "exclude" then if Value'Last < Value'First then AD.Exclusions.Clear_Exclusions; else Parse_List (AD.Exclusions.Add_Exclusion'Access, Value); end if; elsif K = "include" then if Value'Last < Value'First then AD.Exclusions.Clear_Exclusion_Exceptions; else Parse_List (AD.Exclusions.Add_Exclusion_Exception'Access, Value); end if; elsif Is_Prefix (K, "path.") then if K'Length > 5 then AD.HTML.Pathes.Add_Path (K (K'First + 5 .. K'Last), Expand (Self.Expander, Value)); else Ada.Exceptions.Raise_Exception (Invalid_Config'Identity, ''' & Key & "' is an invalid key."); end if; elsif Is_Prefix (K, "description.") then AD.Descriptions.Parse (K (K'First + 12 .. K'Last), Value); elsif Is_Prefix (K, "index_title.") then declare use AD.Indices.Configuration; Idx : Index_Type; begin begin Idx := Index_Type'Value (To_Upper (K (K'First + 12 .. K'Last))); exception when others => Ada.Exceptions.Raise_Exception (Invalid_Config'Identity, ''' & Key & "' is an invalid key."); end; AD.Indices.Configuration.Set_Title (Idx, Unquote_All (Value, Shell_Quotes)); end; elsif Is_Prefix (K, "user_tag.") then begin AD.User_Tags.Parse_Tag (K (K'First + 9 .. K'Last), Value, Self.Expander); exception when E : AD.User_Tags.Invalid_Tag => Ada.Exceptions.Raise_Exception (Invalid_Config'Identity, Ada.Exceptions.Exception_Message (E)); end; elsif Is_Prefix (K, "format.") then declare A, B : Natural := 0; begin -- Use 'Key' here, for the string must be case sensitive!! if Key'Length > 8 then if Is_In (String_Quotes, Key (Key'First + 7)) then A := Key'First + 7; B := Skip_String (Self, Key (Key'First + 7 .. Key'Last), Key (Key'First + 7)); end if; end if; if A = 0 then Ada.Exceptions.Raise_Exception (Invalid_Config'Identity, "'Format.' must be followed by a string"); elsif B = 0 then Ada.Exceptions.Raise_Exception (Invalid_Config'Identity, "Unterminated string after 'Format.'"); end if; if not Is_Prefix (Key (A + 1 .. B - 1), "--") then Ada.Exceptions.Raise_Exception (Invalid_Config'Identity, "Format comment prefix must start with ""--"""); end if; begin AD.Format.Enter (Unquote (Key (A + 1 .. B - 1), Key (A), Key (A)), AD.Filters.Parse (Expand (Self.Expander, Value))); exception when E : AD.Filters.Parse_Error => Ada.Exceptions.Raise_Exception (Invalid_Config'Identity, Ada.Exceptions.Exception_Message (E)); end; end; elsif Is_Prefix (K, "rule.") then -- Must be followed by an identifier. declare I : constant Natural := Identifier (K (K'First + 5 .. K'Last)); begin if I = 0 then Ada.Exceptions.Raise_Exception (Invalid_Config'Identity, "'Rule.' must be followed by an identifier"); elsif I /= K'Last then Ada.Exceptions.Raise_Exception (Invalid_Config'Identity, "Key must have the form 'Rule.'"); end if; end; declare Expr : AD.Expressions.Expression; Redefined : Boolean; begin Expr := AD.Expressions.Parse (Value); AD.Expressions.Define_Macro (Key (Key'First + 5 .. Key'Last), Expr, Redefined); if Redefined then AD.Messages.Info (Key & " redefined in " & Self.Expander.File_Name.all); end if; exception when E : AD.Expressions.Parse_Error => Ada.Exceptions.Raise_Exception (Invalid_Config'Identity, Ada.Exceptions.Exception_Message (E)); end; elsif Is_Prefix (K, "index.") then AD.Indices.Configuration.Parse (Key (Key'First + 6 .. Key'Last), Expand (Self.Expander, Value)); else Ada.Exceptions.Raise_Exception (Invalid_Config'Identity, "unknown key '" & Key & '''); end if; end New_Key; ---------------------------------------------------------------------------- procedure Configure (File_Name : in String) is Expander : aliased Environment_Expander; Parser : Reader (Expander'Access); begin Util.Files.Config.Read (File_Name, Parser); Deallocate (Expander.File_Name); exception when E : others => Deallocate (Expander.File_Name); Ada.Exceptions.Raise_Exception (Invalid_Config'Identity, Ada.Exceptions.Exception_Message (E)); end Configure; end AD.Config; adabrowse_4.0.3/asis2-naming.adb0000644000175000017500000002713610234241452014631 0ustar kenken------------------------------------------------------------------------------- -- -- This unit is part of the @Asis2@ ASIS secondary library. -- -- Copyright (c) 2002, 2003 by Thomas Wolf. --
    -- AdaBrowse is free software; you can redistribute it and/or modify it -- under the terms of the GNU General Public License as published by the -- Free Software Foundation; either version 2, or (at your option) any -- later version. AdaBrowse is distributed in the hope that it will be -- useful, but without any warranty; without even the implied -- warranty of merchantability or fitness for a particular purpose. -- See the GNU General Public License for more details. You should have -- received a copy of the GNU General Public License with this distribution, -- see file "GPL.txt". If not, write to the Free -- Software Foundation, 59 Temple Place - Suite 330, Boston, MA 02111-1307, -- USA. --
    --
    -- As a special exception from the GPL, if other files instantiate generics -- from this unit, or you link this unit with other files to produce an -- executable, this unit does not by itself cause the resulting executable -- to be covered by the GPL. This exception does not however invalidate any -- other reasons why the executable file might be covered by the GPL. --
    -- -- -- Thomas Wolf (TW) -- -- -- -- Utility routines operating on naming expressions and defining names. -- -- -- -- 08-JUL-2003 TW Last release as part of @AdaBrowse@. -- 18-JUL-2003 TW Created from operations in @AD.Queries@. -- ------------------------------------------------------------------------------- pragma License (Modified_GPL); with Ada.Exceptions; with Asis.Compilation_Units; with Asis.Declarations; with Asis.Elements; with Asis.Exceptions; with Asis.Expressions; with Asis2.Declarations; with Asis2.Text; package body Asis2.Naming is Package_Name : constant String := "Asis2.Naming"; use Asis; use Asis.Declarations; use Asis.Elements; use Asis.Expressions; ---------------------------------------------------------------------------- function Get_Name (Decl : in Asis.Declaration) return Asis.Defining_Name is Names : constant Name_List := Asis.Declarations.Names (Decl); begin return Names (Names'First); end Get_Name; ---------------------------------------------------------------------------- procedure Verify_Name_Definition (Def : in out Asis.Defining_Name; Name : in Asis.Expression) is begin if Is_Nil (Def) or else Is_Nil (Name) then Def := Nil_Element; return; end if; -- Asis sometimes returns the wrong name. if Defining_Name_Kind (Def) = A_Defining_Expanded_Name then Def := Defining_Selector (Def); end if; declare Original : constant Wide_String := Asis2.Text.To_Lower (Name_Image (Name)); Def_Name : constant Wide_String := Asis2.Text.To_Lower (Defining_Name_Image (Def)); begin if Original /= Def_Name then -- Other differences (besides casing). Def := Nil_Element; end if; end; end Verify_Name_Definition; ---------------------------------------------------------------------------- function Name_Expression_Image (Name : in Asis.Expression) return Wide_String is E : constant Asis.Expression_Kinds := Expression_Kind (Name); begin case E is when A_Selected_Component => return Name_Expression_Image (Prefix (Name)) & "." & Name_Expression_Image (Selector (Name)); when An_Identifier | An_Enumeration_Literal => declare Def : Asis.Defining_Name := Asis2.Declarations.Name_Definition (Name); begin Verify_Name_Definition (Def, Name); if not Is_Nil (Def) then return Defining_Name_Image (Def); else -- No definition (or multiple ones, or a wrong one) found: -- use the expression's image instead. return Name_Image (Name); end if; end; when A_Character_Literal | An_Operator_Symbol => return Name_Image (Name); when An_Attribute_Reference => return Name_Expression_Image (Prefix (Name)) & "'" & Asis2.Text.To_Mixed (Name_Image (Attribute_Designator_Identifier (Name))); when others => Ada.Exceptions.Raise_Exception (Asis.Exceptions.ASIS_Inappropriate_Element'Identity, "Unexpected expression kind " & Expression_Kinds'Image (E) & " in " & Package_Name & ".Name_Expression_Image."); return ""; end case; end Name_Expression_Image; ---------------------------------------------------------------------------- function Name_Definition_Image (Name : in Asis.Defining_Name) return Wide_String is begin if Defining_Name_Kind (Name) = A_Defining_Expanded_Name then return Name_Expression_Image (Defining_Prefix (Name)) & "." & Defining_Name_Image (Defining_Selector (Name)); else return Defining_Name_Image (Name); end if; end Name_Definition_Image; ---------------------------------------------------------------------------- function Get_Single_Name (Decl : in Asis.Declaration) return Wide_String is begin if Declaration_Kind (Decl) = Not_A_Declaration then return ""; end if; declare Names : constant Name_List := Asis.Declarations.Names (Decl); begin if Names'Last /= Names'First then return ""; end if; return Name_Definition_Image (Names (Names'First)); end; end Get_Single_Name; ---------------------------------------------------------------------------- function Full_Unit_Name (Unit : in Asis.Compilation_Unit) return Wide_String is -- ASIS-for-GNAT 3.14p has a problem with unit names for children -- that are generic instantiations: it returns only the last -- component. Try to correct that. -- -- Also, ASIS-for-GNAT uses the program text to construct that unit -- name, which is consistent with the encouragement given by the ASIS -- standard. We, however, want to have capitalization as in the parent -- units declarations! use Asis.Compilation_Units; Parent : constant Compilation_Unit := Corresponding_Parent_Declaration (Unit); -- Nil if Unit is Standard. A_Nonexistent_Declaration if parent unit is -- not in context. Standard if Unit is a root unit. Name : Asis.Defining_Name := Get_Name (Unit_Declaration (Unit)); begin if Is_Nil (Parent) or else Unit_Kind (Parent) = A_Nonexistent_Declaration then -- Standard, or something went wrong: fall back to the standard ASIS -- implementation. return Unit_Full_Name (Unit); end if; if Is_Nil (Corresponding_Parent_Declaration (Parent)) then -- Grandparent is nil, therefore Parent is Standard: a root unit. return Name_Definition_Image (Name); else -- A child unit if Defining_Name_Kind (Name) = A_Defining_Expanded_Name then Name := Defining_Selector (Name); end if; return Full_Unit_Name (Parent) & "." & Name_Definition_Image (Name); end if; end Full_Unit_Name; ---------------------------------------------------------------------------- function Container_Name (Element : in Asis.Element) return Wide_String is Unit : constant Asis.Declaration := Unit_Declaration (Enclosing_Compilation_Unit (Element)); Dot : constant Wide_String := "."; function Parent (Unit : in Asis.Declaration; Element : in Asis.Element) return Wide_String is D : Asis.Declaration := Asis2.Declarations.Enclosing_Declaration (Element); begin -- Parent -- Skip enclosing declarations until we hit a package declaration, -- a task or a PO, or a subprogram declaration. loop if Is_Nil (D) then return ""; end if; case Declaration_Kind (D) is when A_Single_Task_Declaration | A_Single_Protected_Declaration | A_Task_Type_Declaration | A_Protected_Type_Declaration | A_Task_Body_Declaration | A_Protected_Body_Declaration | An_Entry_Declaration | An_Entry_Body_Declaration => -- All the things that cannot be a compilation unit: return Parent (Unit, D) & Dot & Get_Single_Name (D); when A_Package_Declaration | A_Package_Body_Declaration | A_Package_Renaming_Declaration | A_Generic_Package_Declaration | A_Generic_Procedure_Declaration | A_Generic_Function_Declaration | A_Generic_Package_Renaming_Declaration | A_Generic_Procedure_Renaming_Declaration | A_Generic_Function_Renaming_Declaration | A_Procedure_Declaration | A_Procedure_Body_Declaration | A_Procedure_Renaming_Declaration | A_Function_Declaration | A_Function_Body_Declaration | A_Function_Renaming_Declaration | A_Package_Instantiation | A_Procedure_Instantiation | A_Function_Instantiation | A_Formal_Procedure_Declaration | A_Formal_Function_Declaration => -- All the things that *can* be a compilation unit: if Is_Equal (Unit, D) then return Full_Unit_Name (Enclosing_Compilation_Unit (D)); else return Parent (Unit, D) & Dot & Get_Single_Name (D); end if; when others => D := Asis2.Declarations.Enclosing_Declaration (D); end case; end loop; return ""; end Parent; begin -- Container_Name; if Is_Equal (Unit, Element) then return ""; end if; return Parent (Unit, Element); end Container_Name; ---------------------------------------------------------------------------- function Fully_Qualified_Name (Name : in Asis.Defining_Name) return Wide_String is Decl : constant Asis.Declaration := Asis2.Declarations.Enclosing_Declaration (Name); Unit : constant Asis.Compilation_Unit := Enclosing_Compilation_Unit (Decl); Unit_Decl : constant Asis.Declaration := Unit_Declaration (Unit); begin if Is_Equal (Unit_Decl, Decl) then return Full_Unit_Name (Unit); end if; -- It's not a unit itself... declare Container : constant Wide_String := Container_Name (Decl); begin if Container'Length = 0 then return Name_Definition_Image (Name); else return Container & "." & Name_Definition_Image (Name); end if; end; end Fully_Qualified_Name; end Asis2.Naming; adabrowse_4.0.3/ad-projects-impl.ads0000644000175000017500000000044510234241476015534 0ustar kenken-- This file has been generated automatically by the -- AdaBrowse configuration tool adconf. -- -- Generated on 2005-04-28 22:10:37 -- -- DO NOT MODIFY THIS FILE! pragma License (GPL); with AD.Projects.Impl_No; private package AD.Projects.Impl renames AD.Projects.Impl_No; adabrowse_4.0.3/ad-printers.adb0000644000175000017500000007067410234241451014575 0ustar kenken------------------------------------------------------------------------------- -- -- This file is part of AdaBrowse. -- -- Copyright (c) 2002 by Thomas Wolf. --
    -- AdaBrowse is free software; you can redistribute it and/or modify it -- under the terms of the GNU General Public License as published by the -- Free Software Foundation; either version 2, or (at your option) any -- later version. AdaBrowse is distributed in the hope that it will be -- useful, but without any warranty; without even the implied -- warranty of merchantability or fitness for a particular purpose. -- See the GNU General Public License for more details. You should have -- received a copy of the GNU General Public License with this distribution, -- see file "GPL.txt". If not, write to the Free -- Software Foundation, 59 Temple Place - Suite 330, Boston, MA 02111-1307, -- USA. --
    -- --
    -- Author:
    -- Thomas Wolf (TW) --
    twolf@acm.org
    -- --
    -- Purpose:
    -- Abstract root type for the various output producers (HTML, XML, DocBook, -- and so on).
    -- -- ------------------------------------------------------------------------------- pragma License (GPL); with Ada.Exceptions; with Ada.Text_IO; with Asis.Declarations; with Asis.Elements; with Asis.Text; with AD.File_Ops; with AD.Messages; with AD.Syntax; with Util.Files; with Util.Pathes; with Util.Strings; package body AD.Printers is use Asis.Declarations; use Asis.Elements; use Asis; use Util.Strings; ---------------------------------------------------------------------------- function To_String (Pos : in Asis2.Spans.Position; Full : in Boolean) return String is begin if Full then return Trim (Asis.Text.Line_Number'Image (Pos.Line)) & '_' & Trim (Asis.Text.Character_Position'Image (Pos.Column)); else return Trim (Asis.Text.Line_Number'Image (Pos.Line)); end if; end To_String; ---------------------------------------------------------------------------- procedure Set_Line_Only is begin Full_Crossrefs := False; AD.Messages.Warn ("-l option given: cross-references use only the line number."); end Set_Line_Only; ---------------------------------------------------------------------------- function Get_Item_Kind (Item : in Asis.Element) return Item_Kind is function In_PO (Decl : in Asis.Declaration) return Boolean is Encl : Asis.Element := Decl; begin -- Loop until we either hit a nil element or a declaration. loop Encl := Enclosing_Element (Encl); exit when Is_Nil (Encl); case Declaration_Kind (Encl) is when Not_A_Declaration => null; when A_Protected_Type_Declaration | A_Single_Protected_Declaration | A_Task_Type_Declaration | A_Single_Task_Declaration => return True; when others => exit; end case; end loop; return False; end In_PO; begin case Declaration_Kind (Item) is when Not_A_Declaration => -- It had better be a pragma! (What about rep clauses?) -- We also have use clauses here... case Element_Kind (Item) is when Asis.A_Pragma => return AD.Printers.A_Pragma; when Asis.A_Clause => case Clause_Kind (Item) is when A_Use_Package_Clause => return A_Use_Clause; when Asis.A_Use_Type_Clause => return AD.Printers.A_Use_Type_Clause; when others => return Not_An_Item; end case; when others => return Not_An_Item; end case; when A_Procedure_Declaration => if In_PO (Item) then return A_Protected_Procedure; else return A_Procedure; end if; when A_Function_Declaration => if In_PO (Item) then return A_Protected_Function; else return A_Function; end if; when An_Entry_Declaration => return An_Entry; when A_Package_Declaration => return A_Package; when A_Generic_Package_Declaration => declare Visible_Stuff : constant Declaration_List := Visible_Part_Declarative_Items (Item); begin if Visible_Stuff'Last < Visible_Stuff'First then return A_Generic_Signature_Package; else return A_Generic_Package; end if; end; when A_Generic_Procedure_Declaration => return A_Generic_Procedure; when A_Generic_Function_Declaration => return A_Generic_Function; when Asis.A_Package_Instantiation => return AD.Printers.A_Package_Instantiation; when Asis.A_Procedure_Instantiation => return AD.Printers.A_Procedure_Instantiation; when Asis.A_Function_Instantiation => return AD.Printers.A_Function_Instantiation; when A_Package_Renaming_Declaration => return A_Package_Renaming; when A_Procedure_Renaming_Declaration => return A_Procedure_Renaming; when A_Function_Renaming_Declaration => return A_Function_Renaming; when A_Generic_Package_Renaming_Declaration => return A_Generic_Package_Renaming; when A_Generic_Procedure_Renaming_Declaration => return A_Generic_Procedure_Renaming; when A_Generic_Function_Renaming_Declaration => return A_Generic_Function_Renaming; when A_Task_Type_Declaration => return A_Task_Type; when A_Single_Task_Declaration => return A_Task; when A_Protected_Type_Declaration => return A_Protected_Type; when A_Single_Protected_Declaration => return A_Protected_Object; when A_Subtype_Declaration => return A_Subtype; when An_Ordinary_Type_Declaration | An_Incomplete_Type_Declaration | A_Private_Type_Declaration | A_Private_Extension_Declaration => return A_Type; when A_Variable_Declaration => return A_Variable; when A_Constant_Declaration | An_Integer_Number_Declaration | A_Real_Number_Declaration => return A_Constant; when A_Deferred_Constant_Declaration => return A_Deferred_Constant; when An_Object_Renaming_Declaration => return An_Object_Renaming; when An_Exception_Renaming_Declaration => return An_Exception_Renaming; when An_Exception_Declaration => return An_Exception; when others => return Not_An_Item; end case; end Get_Item_Kind; procedure Dump (Self : access Printer'Class; Line : in String) is Tmp : String (Line'First .. Line'Last + AD.Syntax.Max_Keyword_Length + 1); Last_Char : Character; I : Positive; Start : Natural; Stop : Natural; begin -- 'Tmp' is a lower-case copy of 'Line' with extra padding characters at -- the end. It serves to simplify 'Find_Keyword': it doesn't have to -- worry about casing, and it can also ignore overflow problems. for I in Line'Range loop Tmp (I) := To_Lower (Line (I)); end loop; for I in Line'Last + 1 .. Tmp'Last loop Tmp (I) := ' '; end loop; Last_Char := ' '; I := Line'First; while I <= Line'Last loop AD.Syntax.Find_Keyword (Tmp (I .. Tmp'Last), Last_Char, Line'Last, Start, Stop); if Start = 0 then Write (Self, Line (I .. Line'Last)); return; end if; if Start > I then Write (Self, Line (I .. Start - 1)); end if; if Tmp (Start .. Stop) = "--" then -- We have a comment!! Write_Comment (Self, Line (Start .. Line'Last)); exit; elsif Tmp (Start) = '"' or Tmp (Start) = ''' then -- A string or character literal. Write_Literal (Self, Line (Start .. Stop)); else -- A real keyword. Write 'Tmp', not 'Line': this makes all -- keywords lowercase for free! Write_Keyword (Self, Tmp (Start .. Stop)); end if; Last_Char := Tmp (Stop); I := Stop + 1; end loop; end Dump; ---------------------------------------------------------------------------- procedure Open_File (Self : in out Real_Printer; Mode : in AD.Options.File_Handling; File_Name : in String; Use_Default : in Boolean := True) is use type Ada.Text_IO.File_Access; use type AD.Options.File_Handling; procedure Open (File : in out Ada.Text_IO.File_Type; Name : in String) is procedure Open is new Util.Files.Open_G (Ada.Text_IO.File_Type, Ada.Text_IO.File_Mode, Ada.Text_IO.Open, Ada.Text_IO.Create); begin if not AD.Options.Allow_Overwrite and then AD.File_Ops.Exists (Name) then Ada.Exceptions.Raise_Exception (Cannot_Overwrite'Identity, "Mustn't write to file """ & Name & """."); end if; begin Open (File, Ada.Text_IO.Out_File, Name); exception when others => Ada.Exceptions.Raise_Exception (Open_Failed'Identity, "Cannot write to file """ & Name & """."); end; end Open; begin if Self.F /= null then Close_File (Self); end if; if Use_Default then Try_Name : declare Name : constant String := AD.Options.Output_Name; begin if Name = "-" then -- Output on stdout: Self.F := Ada.Text_IO.Current_Output; return; end if; if Name'Last >= Name'First and then Mode = AD.Options.Single_File then -- Not stdout: first try 'Name', if that fails, try 'File_Name' begin Open (Self.File, Util.Pathes.Replace_Extension (Name, Get_Suffix (Real_Printer'Class (Self)))); exception when E : others => if File_Name'Last >= File_Name'First then AD.Messages.Warn (Ada.Exceptions.Exception_Message (E)); else raise; end if; end; end if; end Try_Name; end if; if not Ada.Text_IO.Is_Open (Self.File) then -- Ok, it's not stdout, and either we have no name or we failed to -- open file 'Name', or we're in multi-file mode: open a file -- 'File_Name' in the specified directory. if File_Name = "-" then Self.F := Ada.Text_IO.Current_Output; return; end if; if Util.Pathes.Path (File_Name) /= "" then -- The given File_Name *does* have a path itself: use that! Open (Self.File, Util.Pathes.Replace_Extension (File_Name, Get_Suffix (Real_Printer'Class (Self)))); else -- 'File_Name' is a simple file: prepend the default output -- directory. Open (Self.File, Util.Pathes.Concat (AD.Options.Output_Directory, Util.Pathes.Replace_Extension (File_Name, Get_Suffix (Real_Printer'Class (Self))))); end if; end if; -- Here, Self.File is open. Self.F := Ada.Text_IO.File_Access'(Self.File'Unchecked_Access); end Open_File; function Is_Open (Self : in Real_Printer) return Boolean is use type Ada.Text_IO.File_Access; begin return Self.F /= null; end Is_Open; procedure Close_File (Self : in out Real_Printer) is begin if Ada.Text_IO.Is_Open (Self.File) then Ada.Text_IO.Close (Self.File); end if; Self.F := null; end Close_File; procedure Put (Self : access Real_Printer; Ch : in Character) is begin if Self.Use_Buffer then Util.Text.Append (Self.Buffer, Ch); else Ada.Text_IO.Put (Self.F.all, Ch); end if; end Put; procedure Put (Self : access Real_Printer; S : in String) is begin if Self.Use_Buffer then Util.Text.Append (Self.Buffer, S); else Ada.Text_IO.Put (Self.F.all, S); end if; end Put; procedure Put_Line (Self : access Real_Printer; S : in String) is begin Put_Line (Self.all, S); end Put_Line; procedure Put_Line (Self : in out Real_Printer; S : in String) is begin if Self.Use_Buffer then Util.Text.Append (Self.Buffer, S & ASCII.LF); else Ada.Text_IO.Put_Line (Self.F.all, S); end if; end Put_Line; procedure New_Line (Self : access Real_Printer; N : in Positive := 1) is begin if Self.Use_Buffer then declare Line_Feeds : constant String (1 .. N) := (others => ASCII.LF); begin Util.Text.Append (Self.Buffer, Line_Feeds); end; else Ada.Text_IO.New_Line (Self.F.all, Ada.Text_IO.Positive_Count (N)); end if; end New_Line; procedure Finalize (Self : in out Real_Printer) is begin Close_File (Self); exception when others => null; end Finalize; ---------------------------------------------------------------------------- function "+" (Left, Right : in Printer_Ref) return Printer_Ref is begin if Left = null then return Right; elsif Right = null then return Left; else declare P : constant Printer_Ref := new Composer; begin Composer (P.all).Left := Left; Composer (P.all).Right := Right; return P; end; end if; end "+"; ---------------------------------------------------------------------------- function Is_Open (Self : in Composer) return Boolean is begin return Is_Open (Self.Left.all) or else Is_Open (Self.Right.all); end Is_Open; procedure Finalize (Self : in out Composer) is begin if Self.Left /= null then Free (Self.Left); end if; if Self.Right /= null then Free (Self.Right); end if; -- A composer has no open files, so no need to close the output! end Finalize; procedure Open_Unit (Self : access Composer; Unit_Kind : in Item_Kind; Unit_Name : in Wide_String; Is_Private : in Boolean; XRef : in AD.Crossrefs.Cross_Reference) is begin Open_Unit (Self.Left, Unit_Kind, Unit_Name, Is_Private, XRef); Self.Left_Open := Is_Open (Self.Left.all); Open_Unit (Self.Right, Unit_Kind, Unit_Name, Is_Private, XRef); Self.Right_Open := Is_Open (Self.Right.all); end Open_Unit; procedure Close_Unit (Self : access Composer) is begin if Self.Left_Open then Close_Unit (Self.Left); end if; if Self.Right_Open then Close_Unit (Self.Right); end if; end Close_Unit; procedure Write_Comment (Self : access Composer; Lines : in Asis.Text.Line_List) is begin if Self.Left_Open then Write_Comment (Self.Left, Lines); end if; if Self.Right_Open then Write_Comment (Self.Right, Lines); end if; end Write_Comment; procedure Open_Section (Self : access Composer; Section : in Section_Type) is begin if Self.Left_Open then Open_Section (Self.Left, Section); end if; if Self.Right_Open then Open_Section (Self.Right, Section); end if; end Open_Section; procedure Close_Section (Self : access Composer; Section : in Section_Type) is begin if Self.Left_Open then Close_Section (Self.Left, Section); end if; if Self.Right_Open then Close_Section (Self.Right, Section); end if; end Close_Section; procedure Open_Item (Self : access Composer; XRef : in AD.Crossrefs.Cross_Reference; Kind : in Item_Kind := Not_An_Item; Name : in Wide_String := "") is begin if Self.Left_Open then Open_Item (Self.Left, XRef, Kind, Name); end if; if Self.Right_Open then Open_Item (Self.Right, XRef, Kind, Name); end if; end Open_Item; procedure Close_Item (Self : access Composer; Is_Last : in Boolean := False) is begin if Self.Left_Open then Close_Item (Self.Left, Is_Last); end if; if Self.Right_Open then Close_Item (Self.Right, Is_Last); end if; end Close_Item; procedure Other_Declaration (Self : access Composer; XRef : in AD.Crossrefs.Cross_Reference; Text : in String) is begin if Self.Left_Open then Other_Declaration (Self.Left, XRef, Text); end if; if Self.Right_Open then Other_Declaration (Self.Right, XRef, Text); end if; end Other_Declaration; procedure Open_Container (Self : access Composer; XRef : in AD.Crossrefs.Cross_Reference; Kind : in Item_Kind; Name : in Wide_String := "") is begin if Self.Left_Open then Open_Container (Self.Left, XRef, Kind, Name); end if; if Self.Right_Open then Open_Container (Self.Right, XRef, Kind, Name); end if; end Open_Container; procedure Close_Container (Self : access Composer; Is_Last : in Boolean := False) is begin if Self.Left_Open then Close_Container (Self.Left, Is_Last); end if; if Self.Right_Open then Close_Container (Self.Right, Is_Last); end if; end Close_Container; procedure Add_Child (Self : access Composer; Kind : in Item_Kind; Is_Private : in Boolean; XRef : in AD.Crossrefs.Cross_Reference) is begin if Self.Left_Open then Add_Child (Self.Left, Kind, Is_Private, XRef); end if; if Self.Right_Open then Add_Child (Self.Right, Kind, Is_Private, XRef); end if; end Add_Child; procedure Add_Exception (Self : access Composer; XRef : in AD.Crossrefs.Cross_Reference) is begin if Self.Left_Open then Add_Exception (Self.Left, XRef); end if; if Self.Right_Open then Add_Exception (Self.Right, XRef); end if; end Add_Exception; procedure Type_Name (Self : access Composer; XRef : in AD.Crossrefs.Cross_Reference) is begin if Self.Left_Open then Type_Name (Self.Left, XRef); end if; if Self.Right_Open then Type_Name (Self.Right, XRef); end if; end Type_Name; procedure Type_Kind (Self : access Composer; Info : in String) is begin if Self.Left_Open then Type_Kind (Self.Left, Info); end if; if Self.Right_Open then Type_Kind (Self.Right, Info); end if; end Type_Kind; procedure Parent_Type (Self : access Composer; XRef : in AD.Crossrefs.Cross_Reference) is begin if Self.Left_Open then Parent_Type (Self.Left, XRef); end if; if Self.Right_Open then Parent_Type (Self.Right, XRef); end if; end Parent_Type; procedure Open_Operation_List (Self : access Composer; Kind : in Operation_Kind) is begin if Self.Left_Open then Open_Operation_List (Self.Left, Kind); end if; if Self.Right_Open then Open_Operation_List (Self.Right, Kind); end if; end Open_Operation_List; procedure Close_Operation_List (Self : access Composer) is begin if Self.Left_Open then Close_Operation_List (Self.Left); end if; if Self.Right_Open then Close_Operation_List (Self.Right); end if; end Close_Operation_List; procedure Add_Type_Operation (Self : access Composer; XRef : in AD.Crossrefs.Cross_Reference) is begin if Self.Left_Open then Add_Type_Operation (Self.Left, XRef); end if; if Self.Right_Open then Add_Type_Operation (Self.Right, XRef); end if; end Add_Type_Operation; procedure Add_Private (Self : access Composer; For_Package : in Boolean) is begin if Self.Left_Open then Add_Private (Self.Left, For_Package); end if; if Self.Right_Open then Add_Private (Self.Right, For_Package); end if; end Add_Private; procedure Open_Anchor (Self : access Composer; XRef : in AD.Crossrefs.Cross_Reference) is begin if Self.Left_Open then Open_Anchor (Self.Left, XRef); end if; if Self.Right_Open then Open_Anchor (Self.Right, XRef); end if; end Open_Anchor; procedure Close_Anchor (Self : access Composer) is begin if Self.Left_Open then Close_Anchor (Self.Left); end if; if Self.Right_Open then Close_Anchor (Self.Right); end if; end Close_Anchor; procedure Open_XRef (Self : access Composer; XRef : in AD.Crossrefs.Cross_Reference) is begin if Self.Left_Open then Open_XRef (Self.Left, XRef); end if; if Self.Right_Open then Open_XRef (Self.Right, XRef); end if; end Open_XRef; procedure Close_XRef (Self : access Composer) is begin if Self.Left_Open then Close_XRef (Self.Left); end if; if Self.Right_Open then Close_XRef (Self.Right); end if; end Close_XRef; procedure Put_XRef (Self : access Composer; XRef : in AD.Crossrefs.Cross_Reference; Code : in Boolean := True; Is_Index : in Boolean := False) is begin if Self.Left_Open then Put_XRef (Self.Left, XRef, Code, Is_Index); end if; if Self.Right_Open then Put_XRef (Self.Right, XRef, Code, Is_Index); end if; end Put_XRef; procedure Inline_Error (Self : access Composer; Msg : in String) is begin if Self.Left_Open then Inline_Error (Self.Left, Msg); end if; if Self.Right_Open then Inline_Error (Self.Right, Msg); end if; end Inline_Error; ---------------------------------------------------------------------------- -- Basic inline elements. procedure Write_Keyword (Self : access Composer; S : in String) is begin if Self.Left_Open then Write_Keyword (Self.Left, S); end if; if Self.Right_Open then Write_Keyword (Self.Right, S); end if; end Write_Keyword; procedure Write_Literal (Self : access Composer; S : in String) is begin if Self.Left_Open then Write_Literal (Self.Left, S); end if; if Self.Right_Open then Write_Literal (Self.Right, S); end if; end Write_Literal; procedure Write_Attribute (Self : access Composer; S : in String) is begin if Self.Left_Open then Write_Attribute (Self.Left, S); end if; if Self.Right_Open then Write_Attribute (Self.Right, S); end if; end Write_Attribute; procedure Write_Comment (Self : access Composer; S : in String) is begin if Self.Left_Open then Write_Comment (Self.Left, S); end if; if Self.Right_Open then Write_Comment (Self.Right, S); end if; end Write_Comment; procedure Write (Self : access Composer; S : in String) is begin if Self.Left_Open then Write (Self.Left, S); end if; if Self.Right_Open then Write (Self.Right, S); end if; end Write; procedure Write_Plain (Self : access Composer; S : in String) is begin if Self.Left_Open then Write_Plain (Self.Left, S); end if; if Self.Right_Open then Write_Plain (Self.Right, S); end if; end Write_Plain; procedure Write_Code (Self : access Composer; S : in String) is begin if Self.Left_Open then Write_Code (Self.Left, S); end if; if Self.Right_Open then Write_Code (Self.Right, S); end if; end Write_Code; procedure New_Line (Self : access Composer; N : in Positive := 1) is begin if Self.Left_Open then New_Line (Self.Left, N); end if; if Self.Right_Open then New_Line (Self.Right, N); end if; end New_Line; procedure Open_Index (Self : access Composer; File_Name : in String; Title : in String; Present : in Ada.Strings.Maps.Character_Set) is begin Open_Index (Self.Left, File_Name, Title, Present); Self.Left_Open := Is_Open (Self.Left.all); Open_Index (Self.Right, File_Name, Title, Present); Self.Right_Open := Is_Open (Self.Right.all); end Open_Index; procedure Close_Index (Self : access Composer) is begin Close_Index (Self.Left); Close_Index (Self.Right); end Close_Index; procedure XRef_Index (Self : access Composer; File_Name : in String; Title : in String) is begin if Self.Left_Open then XRef_Index (Self.Left, File_Name, Title); end if; if Self.Right_Open then XRef_Index (Self.Right, File_Name, Title); end if; end XRef_Index; procedure Open_Char_Section (Self : access Composer; Char : in Character) is begin if Self.Left_Open then Open_Char_Section (Self.Left, Char); end if; if Self.Right_Open then Open_Char_Section (Self.Right, Char); end if; end Open_Char_Section; procedure Close_Char_Section (Self : access Composer) is begin if Self.Left_Open then Close_Char_Section (Self.Left); end if; if Self.Right_Open then Close_Char_Section (Self.Right); end if; end Close_Char_Section; procedure Open_Index_Structure (Self : access Composer) is begin if Self.Left_Open then Open_Index_Structure (Self.Left); end if; if Self.Right_Open then Open_Index_Structure (Self.Right); end if; end Open_Index_Structure; procedure Close_Index_Structure (Self : access Composer) is begin if Self.Left_Open then Close_Index_Structure (Self.Left); end if; if Self.Right_Open then Close_Index_Structure (Self.Right); end if; end Close_Index_Structure; procedure Open_Index_Item (Self : access Composer) is begin if Self.Left_Open then Open_Index_Item (Self.Left); end if; if Self.Right_Open then Open_Index_Item (Self.Right); end if; end Open_Index_Item; procedure Close_Index_Item (Self : access Composer) is begin if Self.Left_Open then Close_Index_Item (Self.Left); end if; if Self.Right_Open then Close_Index_Item (Self.Right); end if; end Close_Index_Item; end AD.Printers; adabrowse_4.0.3/ad-user_tags.adb0000644000175000017500000004400510234241452014711 0ustar kenken------------------------------------------------------------------------------- -- -- This file is part of AdaBrowse. -- -- Copyright (c) 2002 by Thomas Wolf. --
    -- AdaBrowse is free software; you can redistribute it and/or modify it -- under the terms of the GNU General Public License as published by the -- Free Software Foundation; either version 2, or (at your option) any -- later version. AdaBrowse is distributed in the hope that it will be -- useful, but without any warranty; without even the implied -- warranty of merchantability or fitness for a particular purpose. -- See the GNU General Public License for more details. You should have -- received a copy of the GNU General Public License with this distribution, -- see file "GPL.txt". If not, write to the Free -- Software Foundation, 59 Temple Place - Suite 330, Boston, MA 02111-1307, -- USA. --
    -- --
    -- Author:
    -- Thomas Wolf (TW) --
    twolf@acm.org
    -- --
    -- Purpose:
    -- Storage of user-defined HTML tags.
    -- -- ------------------------------------------------------------------------------- pragma License (GPL); with Ada.Exceptions; with GAL.Storage.Standard; with GAL.Support.Hashing; with GAL.ADT.Hash_Tables; with Util.Environment; with Util.Strings; pragma Elaborate_All (GAL.ADT.Hash_Tables); package body AD.User_Tags is -- Idea: handle each tag separately. Maintain state as you go: for all -- containers, push content type: inline, block, flow or pre. Whenever -- text is to be written, no

    s are inserted for inline, pre, or -- special. If inline, empty lines generate

    . If in block or -- flow, then do

    handling. Whenever flow or pre is pushed, push -- also In_Para = False. Whenever you insert a

    , also push it! -- -- At end tag of container, pop to corresponding begin tag (if any, -- if none, ignore and emit a warning). If type is ?, the end tag is -- optional. Use the follow set: if block nesting is the same and we -- hit a tag from the follow set, pop. When popping: if In_Para = true, -- emit

    , then emit closing tag. -- -- These rules should in fact make sure that we only insert

    where -- they are legal. In fact, since

    may contain only inline, use

    -- instead! More precisely, use
    as a -- replacement and emit the following in the section: -- -- -- -- or whatever is appropriate. subtype Tag_Class is Tag'Class; -- Work-around for a bug in GNAT 3.14p and 3.15p, which have problems -- when the hash table below is instantiated directly with Tag'Class. -- (The problem is that the compiler rejects the 'Action' operations -- of the types 'Resetter' and 'Verifier' below if they are properly -- declared with "Value : access Tag'Class".) package Hashing is new GAL.ADT.Hash_Tables (Key_Type => String, Item => Tag_Class, Memory => GAL.Storage.Standard, Initial_Size => 101, Hash => GAL.Support.Hashing.Hash); Tags : Hashing.Hash_Table; package UT renames Util.Text; use Util.Strings; procedure Parse_Tag (Key : in String; Definition : in String; Expander : access Util.Environment.String_Expander'Class) is I : Natural := Last_Index (Key, '.'); begin if I > 0 then if I = Key'First or else I = Key'Last then Ada.Exceptions.Raise_Exception (Invalid_Tag'Identity, '"' & Key & """ is an invalid tag specification"); end if; I := I - 1; else I := Key'Last; end if; if Identifier (Key (Key'First .. I)) /= I then Ada.Exceptions.Raise_Exception (Invalid_Tag'Identity, '"' & Key (Key'First .. I) & """ is not an identifier"); end if; declare Tag_Key : constant String := To_Upper (Key (Key'First .. I)); Tag_Selector : constant String := To_Lower (Key (I + 2 .. Key'Last)); Ptr : Hashing.Item_Ptr; T : aliased User_Defined_Tag (N => Tag_Key'Length); P : User_Tag_Ptr; use type Hashing.Item_Ptr; begin Ptr := Hashing.Unsafe.Retrieve (Tags, Tag_Key); if Ptr = null then P := T'Unchecked_Access; T.Name := Tag_Key; else if Ptr.all in Standard_Tag'Class then Ada.Exceptions.Raise_Exception (Invalid_Tag'Identity, "cannot redefine a standard HTML 4.0 tag (" & Tag_Key & ")"); end if; P := User_Defined_Tag (Ptr.all)'Access; end if; if Tag_Selector'Last < Tag_Selector'First then P.Kind := Normal; UT.Set (P.Start, Definition); elsif Tag_Selector = "enabled" then declare Value : Boolean; begin begin Value := Boolean'Value (To_Upper (Util.Environment.Expand (Expander, Definition))); exception when others => Ada.Exceptions.Raise_Exception (Invalid_Tag'Identity, "Value must be one of True or False"); end; P.Enabled := Value; end; elsif Tag_Selector = "before" then P.Kind := Container; UT.Set (P.Start, Definition); elsif Tag_Selector = "after" then if P.Kind /= Container then P.Start := UT.Null_Unbounded_String; end if; P.Kind := Container; UT.Set (P.Final, Definition); elsif Tag_Selector = "include" then P.Kind := Include; UT.Set (P.Start, Util.Environment.Expand (Expander, Definition)); elsif Tag_Selector = "execute" then P.Kind := Execute; UT.Set (P.Start, Util.Environment.Expand (Expander, Unquote_All (Definition, Shell_Quotes))); elsif Tag_Selector = "variable" then P.Kind := Normal; UT.Set (P.Start, Util.Environment.Expand (Expander, Definition)); elsif Tag_Selector = "set" then P.Kind := Initialize; UT.Set (P.Start, Util.Environment.Expand (Expander, Unquote_All (Definition, Shell_Quotes))); else Ada.Exceptions.Raise_Exception (Invalid_Tag'Identity, '"' & Tag_Selector & """ is an invalid selector"); end if; if Ptr = null then Hashing.Insert (Tags, Tag_Key, T); elsif P.Kind = Normal then P.Final := UT.Null_Unbounded_String; end if; end; end Parse_Tag; ---------------------------------------------------------------------------- function Find_Tag (Key : in String) return Tag_Ptr is P : constant Hashing.Item_Ptr := Hashing.Unsafe.Retrieve (Tags, To_Upper (Key)); begin return Tag_Ptr (P); end Find_Tag; ---------------------------------------------------------------------------- type Verifier is new Hashing.Visitor with null record; -- There's a problem here with GNAT 3.14p and 3.15p; it refuses to accept -- the declaration with the (correct) "Value : access Tag'Class". Hence -- the ugly work-around using 'Tag_Class' below. -- Note: encapsulating the type in a package doesn't help either. procedure Action (V : in out Verifier; Key : in String; Value : access Tag_Class; -- Tag'Class Quit : in out Boolean) is Q : constant Tag_Ptr := Tag_Ptr (Value); P : User_Tag_Ptr; begin if Q.all not in User_Defined_Tag'Class then return; end if; P := User_Defined_Tag (Q.all)'Access; if P.Kind = Container and then P.Enabled then if UT.Length (P.Start) = 0 then Ada.Exceptions.Raise_Exception (Invalid_Tag'Identity, "user-defined tag """ & Key & """ has no "".Before"" definition"); Quit := True; -- Silence GNAT's "-gnatwa" option elsif UT.Length (P.Final) = 0 then Ada.Exceptions.Raise_Exception (Invalid_Tag'Identity, "user-defined tag """ & Key & """ has no "".After"" definition"); if V not in Verifier'Class then -- Silence GNAT's "-gnatwa" Quit := True; end if; end if; end if; end Action; procedure Verify is V : Verifier; begin Hashing.Traverse (Tags, V, True); end Verify; ---------------------------------------------------------------------------- type Resetter is new Hashing.Visitor with null record; -- See comments above about 'Tag_Class'! procedure Action (V : in out Resetter; Key : in String; Value : access Tag_Class; -- Tag'Class Quit : in out Boolean) is Q : constant Tag_Ptr := Tag_Ptr (Value); begin if Key'Last < Key'First or else V not in Resetter'Class then Quit := True; -- Silence GNAT's -gnatwa end if; if Q.all in User_Defined_Tag'Class then declare P : constant User_Tag_Ptr := User_Tag_Ptr (Q); begin P.In_Expansion := False; end; end if; end Action; procedure Reset_Tags is R : Resetter; begin Hashing.Traverse (Tags, R, True); end Reset_Tags; ---------------------------------------------------------------------------- begin Hashing.Set_Resize (Tags, 0.75); declare Linear_Growth : GAL.Support.Hashing.Linear_Growth_Policy (100); begin Hashing.Set_Growth_Policy (Tags, Linear_Growth); end; -- Now enter all standard HTML tags. Add_Predefined : declare No_Follow : constant Follow_Set (1 .. 0) := (others => null); procedure Enter (Name : in String; Class : in HTML_Content; Syntax : in HTML_Container; Content : in HTML_Content; Follow : in Follow_Set := No_Follow) is begin Hashing.Insert (Tags, Name, Standard_Tag'(N => Name'Length, Name => Name, F => Follow'Length, Syntax => Syntax, Class => Class, Contains => Content, Follow => Follow)); end Enter; procedure Inline_Tag (Name : in String) is begin Enter (Name, Inline, Begin_End, Inline); end Inline_Tag; procedure Block_Tag (Name : in String) is begin Enter (Name, Block, Begin_End, Inline); end Block_Tag; procedure Container (Name : in String) is begin Enter (Name, Block, Begin_End, Flow); end Container; procedure Singleton (Name : in String) is begin Enter (Name, Inline, Single, Inline); end Singleton; begin Inline_Tag ("A"); Inline_Tag ("ABBR"); Inline_Tag ("ACRONYM"); Block_Tag ("ADDRESS"); Enter ("APPLET", Inline, Begin_End, Flow); Singleton ("AREA"); Inline_Tag ("B"); Inline_Tag ("BASE"); Singleton ("BASEFONT"); Inline_Tag ("BDO"); Inline_Tag ("BIG"); -- Inline_Tag ("BLINK"); Container ("BLOCKQUOTE"); Container ("BODY"); -- Actually, we should never encounter a BODY tag. Singleton ("BR"); Enter ("BUTTON", Inline, Begin_End, Flow); Block_Tag ("CAPTION"); Container ("CENTER"); Inline_Tag ("CITE"); Inline_Tag ("CODE"); Singleton ("COL"); Enter ("COLGROUP", Block, End_Optional, Pure, (1 .. 4 => null)); Enter ("DD", Block, End_Optional, Flow, (1 .. 2 => null)); Container ("DEL"); Inline_Tag ("DFN"); Enter ("DIR", Block, Begin_End, Pure); -- Only LI allowed. Container ("DIV"); Enter ("DL", Block, Begin_End, Pure); -- Only DD or DT allowed. Enter ("DT", Block, End_Optional, Inline, (1 .. 2 => null)); Inline_Tag ("EM"); Container ("FIELDSET"); Inline_Tag ("FONT"); Container ("FORM"); Enter ("FRAME", Block, Single, Flow); Enter ("FRAME_SET", Block, Begin_End, Pure); -- May contain only FRAMEs and NOFRAMEs. Block_Tag ("H1"); Block_Tag ("H2"); Block_Tag ("H3"); Block_Tag ("H4"); Block_Tag ("H5"); Block_Tag ("H6"); Enter ("HEAD", Block, Begin_End, Pure); -- We shouldn't ever encounter this one. Enter ("HR", Block, Single, Inline); Enter ("HTML", Block, Begin_End, Flow); -- Should never occur! Inline_Tag ("I"); Container ("IFRAME"); Singleton ("IMG"); Singleton ("INPUT"); Container ("INS"); Enter ("ISINDEX", Block, Single, Inline); Inline_Tag ("KBD"); Block_Tag ("LEGEND"); Enter ("LI", Block, End_Optional, Flow, (1 .. 1 => null)); Singleton ("LINK"); Enter ("MAP", Block, Begin_End, Pure); Enter ("MENU", Block, Begin_End, Pure); -- Only LI allowed Singleton ("META"); Container ("NOFRAMES"); Container ("NOSCRIPT"); Enter ("OBJECT", Inline, Begin_End, Flow); Enter ("OL", Block, Begin_End, Pure); -- Only LI allowed Enter ("OPTGROUP", Block, Begin_End, Pure); -- Only OPTION allowed Enter ("OPTION", Block, End_Optional, Inline, (1 .. 2 => null)); Enter ("P", Block, End_Optional, Inline, (1 .. 1 => null)); Singleton ("PARAM"); Enter ("PRE", Block, Begin_End, Pure); -- Pure because we want to maintain line structure as is! Inline_Tag ("Q"); Inline_Tag ("S"); Inline_Tag ("SAMP"); Enter ("SCRIPT", Inline, Begin_End, Dont_Touch); -- Pure because it may only be a script. Enter ("SELECT", Inline, Begin_End, Pure); -- Pure because only OPTGROUP and OPTION are allowed. Inline_Tag ("SMALL"); Inline_Tag ("SPAN"); Inline_Tag ("STRIKE"); Inline_Tag ("STRONG"); Enter ("STYLE", Block, Begin_End, Dont_Touch); Inline_Tag ("SUB"); Inline_Tag ("SUP"); Enter ("TABLE", Block, Begin_End, Pure); Enter ("TBODY", Block, End_Optional, Pure, (1 .. 2 => null)); Enter ("TD", Block, End_Optional, Flow, (1 .. 3 => null)); Enter ("TEXTAREA", Inline, Begin_End, Pure); Enter ("TFOOT", Block, End_Optional, Pure, (1 .. 2 => null)); Enter ("TH", Block, End_Optional, Flow, (1 .. 3 => null)); Enter ("THEAD", Block, End_Optional, Pure, (1 .. 2 => null)); Enter ("TITLE", Block, Begin_End, Pure); Enter ("TR", Block, End_Optional, Pure, (1 .. 4 => null)); Inline_Tag ("TT"); Inline_Tag ("U"); Enter ("UL", Block, Begin_End, Pure); -- Only LI allowed. Inline_Tag ("VAR"); -- All right. Now retrieve some and set up the follow sets. Define_Follow_Sets : declare P : Standard_Ptr; begin P := Standard_Ptr (Find_Tag ("COLGROUP")); P.Follow (1) := Find_Tag ("THEAD"); P.Follow (2) := Find_Tag ("TFOOT"); P.Follow (3) := Find_Tag ("TBODY"); P.Follow (4) := Find_Tag ("TR"); P := Standard_Ptr (Find_Tag ("DD")); P.Follow (1) := Find_Tag ("DT"); P.Follow (2) := Tag_Ptr (P); P := Standard_Ptr (Find_Tag ("DT")); P.Follow (1) := Find_Tag ("DD"); P.Follow (2) := Tag_Ptr (P); P := Standard_Ptr (Find_Tag ("LI")); P.Follow (1) := Tag_Ptr (P); P := Standard_Ptr (Find_Tag ("OPTION")); P.Follow (1) := Find_Tag ("OPTGROUP"); P.Follow (2) := Tag_Ptr (P); P := Standard_Ptr (Find_Tag ("TBODY")); P.Follow (1) := Find_Tag ("TFOOT"); P.Follow (2) := Find_Tag ("THEAD"); P := Standard_Ptr (Find_Tag ("TD")); P.Follow (1) := Tag_Ptr (P); P.Follow (2) := Find_Tag ("TR"); P.Follow (3) := Find_Tag ("TH"); P := Standard_Ptr (Find_Tag ("TFOOT")); P.Follow (1) := Find_Tag ("TBODY"); P.Follow (2) := Find_Tag ("THEAD"); P := Standard_Ptr (Find_Tag ("TH")); P.Follow (1) := Tag_Ptr (P); P.Follow (2) := Find_Tag ("TR"); P.Follow (3) := Find_Tag ("TD"); P := Standard_Ptr (Find_Tag ("THEAD")); P.Follow (1) := Find_Tag ("TFOOT"); P.Follow (2) := Find_Tag ("TBODY"); P := Standard_Ptr (Find_Tag ("TR")); P.Follow (1) := Tag_Ptr (P); P.Follow (2) := Find_Tag ("TFOOT"); P.Follow (3) := Find_Tag ("TBODY"); P.Follow (4) := Find_Tag ("THEAD"); end Define_Follow_Sets; end Add_Predefined; end AD.User_Tags; adabrowse_4.0.3/asis2-declarations.adb0000644000175000017500000002423310234241452016023 0ustar kenken------------------------------------------------------------------------------ -- -- This unit is part of the @Asis2@ ASIS secondary library. -- -- Copyright (c) 2002, 2003 by Thomas Wolf. --
    -- AdaBrowse is free software; you can redistribute it and/or modify it -- under the terms of the GNU General Public License as published by the -- Free Software Foundation; either version 2, or (at your option) any -- later version. AdaBrowse is distributed in the hope that it will be -- useful, but without any warranty; without even the implied -- warranty of merchantability or fitness for a particular purpose. -- See the GNU General Public License for more details. You should have -- received a copy of the GNU General Public License with this distribution, -- see file "GPL.txt". If not, write to the Free -- Software Foundation, 59 Temple Place - Suite 330, Boston, MA 02111-1307, -- USA. --
    --
    -- As a special exception from the GPL, if other files instantiate generics -- from this unit, or you link this unit with other files to produce an -- executable, this unit does not by itself cause the resulting executable -- to be covered by the GPL. This exception does not however invalidate any -- other reasons why the executable file might be covered by the GPL. --
    -- -- -- Thomas Wolf (TW) -- -- -- -- Utility routines operating on naming expressions and defining names. -- -- -- -- 05-JUN-2003 TW Last release as part of @AdaBrowse@. -- 18-JUL-2003 TW Created from operations in @AD.Queries@. -- ------------------------------------------------------------------------------- pragma License (Modified_GPL); with Asis.Declarations; with Asis.Definitions; with Asis.Elements; with Asis.Exceptions; with Asis.Expressions; package body Asis2.Declarations is use Asis; use Asis.Declarations; use Asis.Definitions; use Asis.Elements; use Asis.Expressions; ---------------------------------------------------------------------------- function References (Expr : in Asis.Expression; Decl : in Asis.Declaration) return Boolean is begin case Expression_Kind (Expr) is when An_Identifier => return Is_Equal (Corresponding_Name_Declaration (Expr), Decl); when A_Selected_Component => return Is_Equal (Corresponding_Name_Declaration (Selector (Expr)), Decl); when others => return False; end case; end References; ---------------------------------------------------------------------------- function Name_Definition (Expr : in Asis.Expression) return Asis.Defining_Name is function Get_Def (Expr : in Asis.Expression) return Asis.Defining_Name is begin if Expression_Kind (Expr) = An_Operator_Symbol then declare Outer : Asis.Element := Enclosing_Element (Expr); begin while Expression_Kind (Outer) = A_Parenthesized_Expression loop Outer := Enclosing_Element (Outer); end loop; if Element_Kind (Outer) = An_Association and then Association_Kind (Outer) = A_Pragma_Argument_Association then -- ASIS-for-GNAT 3.14p has a severe bug in function -- 'Corresponding_Name_Definition': it doesn't return at -- all if a name refers to several definitions, and some of -- those are predefined entities. Hence this work-around: -- if we have an operator symbol in a pragma, we always -- return a Nil_Element, for it may reference predefined -- operators. -- -- 'Corresponding_Name_Definition_List' has the same bug. return Nil_Element; end if; end; end if; declare Result : constant Defining_Name := Corresponding_Name_Definition (Expr); begin -- ASIS 2.0.R for GNAT 3.14p sometimes returns a defining expanded -- name here. We don't want that: we clearly ask for the defining -- identifier of the selector, and that should obviously be the -- defining selector! if Defining_Name_Kind (Result) = A_Defining_Expanded_Name then return Defining_Selector (Result); else return Result; end if; end; -- Asis 2.0.R for GNAT 3.13p occasionally returns the wrong -- definition here. An example is Test.Gen.Err, where it -- returns the name definition from the declaration of the -- generic child package "Test.Gen" instead of from the -- declaration of package "Test" for the identifier "Test" at -- the beginning of the defining expanded name "Test.Gen.Err". -- -- I have no work-around for this! -- This error is *not* corrected in the 3.14p version. -- -- Note that we have to handle this failure explicitly at the -- call site! exception when Asis.Exceptions.ASIS_Inappropriate_Element | Asis.Exceptions.ASIS_Failed => -- Asis sometimes crashes here... observed for generic children -- of generic packages that have non-generic parent packages. -- An example is GAL.ADT.Lists.Iterators: in the package -- defining name, Asis 2.0.R for GNAT 3.13p crashes on "GAL" -- and "ADT" (internal error: no entity set), which are the -- non-generic parents of the generic package "Lists". -- -- This error seems to be corrected in the 3.14p version. -- -- Note that we may also legally get an exception here, e.g. if -- the expression denotes the subprogram name in a dispatching -- call. return Nil_Element; end Get_Def; begin if Expression_Kind (Expr) = A_Selected_Component then return Get_Def (Selector (Expr)); else return Get_Def (Expr); end if; end Name_Definition; ---------------------------------------------------------------------------- function Name_Declaration (Expr : in Asis.Expression) return Asis.Declaration is Result : Asis.Defining_Name := Name_Definition (Expr); begin if not Is_Nil (Result) then Result := Enclosing_Declaration (Result); end if; return Result; end Name_Declaration; ---------------------------------------------------------------------------- function Enclosing_Declaration (Element : in Asis.Element) return Asis.Declaration is Result : Asis.Element := Enclosing_Element (Element); begin while not Is_Nil (Result) and then Declaration_Kind (Result) = Not_A_Declaration loop Result := Enclosing_Element (Result); end loop; return Result; end Enclosing_Declaration; ---------------------------------------------------------------------------- function Real_Declaration (Decl : in Asis.Declaration) return Asis.Declaration is begin if Declaration_Kind (Decl) = An_Enumeration_Literal_Specification then if Declaration_Origin (Decl) /= An_Implicit_Inherited_Declaration then return Decl; end if; -- Ok, we have an implicitly inherited enumeration literal: go find -- its real declaration. declare True_Decl : Asis.Element := Decl; begin -- Use a loop to find the type declaration: I'm not sure whether -- the list (of enumeration literal specifications) is represented -- somewhere explicitly. With a loop, we'll just skip that if it -- is there somewhere. while not Is_Nil (True_Decl) loop case Declaration_Kind (True_Decl) is when An_Ordinary_Type_Declaration => exit when Type_Kind (Type_Declaration_View (True_Decl)) = A_Derived_Type_Definition; when others => null; end case; True_Decl := Enclosing_Element (True_Decl); end loop; if Is_Nil (True_Decl) then return Nil_Element; end if; -- Now 'True_Decl' is the (derived) type definition that inherits -- the enumeration literal. Go unwind type derivations now: True_Decl := Corresponding_Root_Type (Type_Declaration_View (True_Decl)); if not Is_Nil (True_Decl) and then Type_Kind (Type_Declaration_View (True_Decl)) = An_Enumeration_Type_Definition then -- Now 'True_Decl' is the enumeration type declaration from -- which the literal was inherited in the first place. Get -- the list of literals, and try to find the one that -- corresponds to 'Decl'. declare Literals : constant Asis.Declaration_List := Enumeration_Literal_Declarations (Type_Declaration_View (True_Decl)); Image : constant Wide_String := Defining_Name_Image (Names (Decl) (1)); begin for I in Literals'Range loop if Defining_Name_Image (Names (Literals (I)) (1)) = Image then return Literals (I); end if; end loop; end; end if; -- Nothing found. return Nil_Element; end; else -- Not an enumeration literal specification. return Corresponding_Declaration (Decl); end if; end Real_Declaration; end Asis2.Declarations; adabrowse_4.0.3/nasty.adb0000644000175000017500000000141310234241453013466 0ustar kenken----------------------------------------------------------------------------- -- This is just a quick hack to show what a command to be run by AdaBrowse -- should NOT do: it reads from stdin, and it doesn't return. ----------------------------------------------------------------------------- with Ada.Text_IO; procedure Nasty is use Ada.Text_IO; Std_In : File_Access := Standard_Input; begin Put_Line ("nasty starts..."); while not End_Of_File (Std_In.all) loop declare Buf : String (1 .. 500); Last : Natural; begin Get_Line (Std_In.all, Buf, Last); Put_Line (Current_Error, "nasty read: " & Buf (1 .. Last)); end; end loop; Put_Line ("nasty won't end."); loop null; end loop; end Nasty; adabrowse_4.0.3/util-text.adb0000644000175000017500000017104010234241454014274 0ustar kenken------------------------------------------------------------------------------- -- -- Copyright © 2001, 2002 by Thomas Wolf. --
    -- This piece of software is free software; you can redistribute it and/or -- modify it under the terms of the GNU General Public License as published -- by the Free Software Foundation; either version 2, or (at your option) -- any later version. This software is distributed in the hope that it will -- be useful, but without any warranty; without even the implied -- warranty of merchantability or fitness for a particular purpose. -- See the GNU General Public License for more details. You should have -- received a copy of the GNU General Public License with this distribution, -- see file "GPL.txt". If not, write to the Free -- Software Foundation, 59 Temple Place - Suite 330, Boston, MA 02111-1307, -- USA. --
    --
    -- As a special exception from the GPL, if other files instantiate generics -- from this unit, or you link this unit with other files to produce an -- executable, this unit does not by itself cause the resulting executable -- to be covered by the GPL. This exception does not however invalidate any -- other reasons why the executable file might be covered by the GPL. --
    -- -- -- Thomas Wolf (TW) -- -- -- -- A complete replacement for @Ada.Strings.Unbounded@, with conversion -- routines. The problem with the standard unbounded strings package is -- that it lacks certain operations (such as I/O operations, or a way to -- append a slice of an @Unbounded_String@ to another @Unbounded_String@ -- without having an intermediary conversion to @String@). -- -- This implementation is fully portable; it doesn't use any GNAT-specific -- pragmas like @Stream_Convert@. The price to pay is that this package -- cannot be preelaborated (since @Null_Unbounded_String@ is a constant of -- a controlled type). I wonder how the language designers did envision that -- this be done... -- -- @Unbounded_String@s are streamable; however, the format is not compatible -- with the one used by GNAT's implementation of @Ada.Strings.Unbounded@. -- -- -- -- -- -- Dynamic storage allocation in the default pool. -- -- -- -- 07-JUN-2002 TW Initial version. -- 27-JUN-2002 TW Added two 'Find_Token' variants: one with a single -- 'From' parameter, and one with 'Low' and 'High' -- parameters. -- ------------------------------------------------------------------------------- pragma License (Modified_GPL); with Ada.Strings.Fixed; with Ada.Unchecked_Deallocation; with Util.Strings; package body Util.Text is -- Implementation note: our string data is always indexed from 1. We -- therefore can use 'Last instead of 'Length, which is slightly faster -- because 'Length must be calculated as -- -- 'Length := 'Last - 'First + 1; -- if 'Length < 0 then 'Length := 0; end if; package ASF renames Ada.Strings.Fixed; package ASM renames Ada.Strings.Maps; package ASU renames Ada.Strings.Unbounded; use Util.Strings; pragma Suppress (Access_Check); -- No null-pointer checking: we *know* that the 'Data' field of an -- Unbounded_String can never be null. ---------------------------------------------------------------------------- Index_Error : exception renames Ada.Strings.Index_Error; Pattern_Error : exception renames Ada.Strings.Pattern_Error; ---------------------------------------------------------------------------- procedure Deallocate is new Ada.Unchecked_Deallocation (String, String_Access); procedure Free (Ptr : in out String_Access) is begin if Ptr /= Null_String'Access then Deallocate (Ptr); end if; Ptr := null; end Free; ---------------------------------------------------------------------------- -- Utility operations procedure Slice_Check (Low, High, Length : in Natural); pragma Inline (Slice_Check); procedure Slice_Check (Low, High, Length : in Natural) is begin if Low > Length + 1 or else High > Length then -- Checking 'High' is ok by AI95-00128. raise Index_Error; end if; end Slice_Check; procedure Trim (Source : in String; Side : in Ada.Strings.Trim_End; I, J : out Natural) is use type Ada.Strings.Trim_End; begin I := Source'First; J := Source'Last; if Side /= Ada.Strings.Right then while I <= J and then Source (I) = ' ' loop I := I + 1; end loop; end if; if Side /= Ada.Strings.Left then while J >= I and then Source (J) = ' ' loop J := J - 1; end loop; end if; end Trim; procedure Trim (Source : in String; Left : in ASM.Character_Set; Right : in ASM.Character_Set; I, J : out Natural) is use type ASM.Character_Set; begin I := Source'First; J := Source'Last; if Left /= ASM.Null_Set then while I <= J and then ASM.Is_In (Source (I), Left) loop I := I + 1; end loop; end if; if Right /= ASM.Null_Set then while J >= I and then ASM.Is_In (Source (J), Right) loop J := J - 1; end loop; end if; end Trim; function Slice (Source : in String_Access; Low : in Positive; High : in Natural) return String_Access is begin if Low > High then return Null_String'Access; end if; declare Result : constant String_Access := new String (1 .. High - Low + 1); begin Result.all := Source (Low .. High); return Result; end; end Slice; function Insert (Source : in String_Access; Before : in Positive; Item : in String) return String_Access is Length : constant Natural := Item'Length; Ptr : constant String_Access := new String (1 .. Source'Last + Length); begin Ptr (1 .. Before - 1) := Source (1 .. Before - 1); Ptr (Before .. Before + Length - 1) := Item; Ptr (Before + Length .. Ptr'Last) := Source (Before .. Source'Last); return Ptr; end Insert; function Replace_Slice (Source : in String_Access; Low : in Positive; High : in Natural; By : in String) return String_Access is begin if High >= Low then declare Suffix_Length : constant Integer := Integer'Max (0, Source'Last - High); By_Length : constant Natural := By'Length; New_Length : constant Integer := Low - 1 + By_Length + Suffix_Length; Ptr : constant String_Access := new String (1 .. New_Length); begin Ptr (1 .. Low - 1) := Source (1 .. Low - 1); Ptr (Low .. Low + By_Length - 1) := By; Ptr (Low + By_Length .. Ptr'Last) := Source (High + 1 .. Source'Last); return Ptr; end; else return Insert (Source, Low, By); end if; end Replace_Slice; ---------------------------------------------------------------------------- -- Public operations, in alphabetic order; operators first. function "&" (Left, Right : Unbounded_String) return Unbounded_String is Result : Unbounded_String := (Ada.Finalization.Controlled with Data => new String (1 .. Left.Data'Last + Right.Data'Last)); begin Result.Data (1 .. Left.Data'Last) := Left.Data.all; Result.Data (Left.Data'Last + 1 .. Result.Data'Last) := Right.Data.all; return Result; end "&"; function "&" (Left : in Unbounded_String; Right : in String) return Unbounded_String is Length : constant Natural := Right'Length; Result : Unbounded_String := (Ada.Finalization.Controlled with Data => new String (1 .. Left.Data'Last + Length)); begin Result.Data (1 .. Left.Data'Last) := Left.Data.all; Result.Data (Left.Data'Last + 1 .. Result.Data'Last) := Right; return Result; end "&"; function "&" (Left : in String; Right : in Unbounded_String) return Unbounded_String is Length : constant Natural := Left'Length; Result : Unbounded_String := (Ada.Finalization.Controlled with Data => new String (1 .. Length + Right.Data'Last)); begin Result.Data (1 .. Length) := Left; Result.Data (Length + 1 .. Result.Data'Last) := Right.Data.all; return Result; end "&"; function "&" (Left : in Unbounded_String; Right : in Character) return Unbounded_String is Result : Unbounded_String := (Ada.Finalization.Controlled with Data => new String (1 .. Left.Data'Last + 1)); begin Result.Data (1 .. Left.Data'Last) := Left.Data.all; Result.Data (Left.Data'Last + 1) := Right; return Result; end "&"; function "&" (Left : in Character; Right : in Unbounded_String) return Unbounded_String is Result : Unbounded_String := (Ada.Finalization.Controlled with Data => new String (1 .. Right.Data'Last + 1)); begin Result.Data (1) := Left; Result.Data (2 .. Result.Data'Last) := Right.Data.all; return Result; end "&"; function "=" (Left, Right : in Unbounded_String) return Boolean is begin return Left.Data.all = Right.Data.all; end "="; function "=" (Left : in Unbounded_String; Right : in String) return Boolean is begin return Left.Data.all = Right; end "="; function "=" (Left : in String; Right : in Unbounded_String) return Boolean is begin return Left = Right.Data.all; end "="; function "<" (Left, Right : in Unbounded_String) return Boolean is begin return Left.Data.all < Right.Data.all; end "<"; function "<" (Left : in Unbounded_String; Right : in String) return Boolean is begin return Left.Data.all < Right; end "<"; function "<" (Left : in String; Right : in Unbounded_String) return Boolean is begin return Left < Right.Data.all; end "<"; function "<=" (Left, Right : in Unbounded_String) return Boolean is begin return Left.Data.all <= Right.Data.all; end "<="; function "<=" (Left : in Unbounded_String; Right : in String) return Boolean is begin return Left.Data.all <= Right; end "<="; function "<=" (Left : in String; Right : in Unbounded_String) return Boolean is begin return Left <= Right.Data.all; end "<="; function ">" (Left, Right : in Unbounded_String) return Boolean is begin return Left.Data.all > Right.Data.all; end ">"; function ">" (Left : in Unbounded_String; Right : in String) return Boolean is begin return Left.Data.all > Right; end ">"; function ">" (Left : in String; Right : in Unbounded_String) return Boolean is begin return Left > Right.Data.all; end ">"; function ">=" (Left, Right : in Unbounded_String) return Boolean is begin return Left.Data.all >= Right.Data.all; end ">="; function ">=" (Left : in Unbounded_String; Right : in String) return Boolean is begin return Left.Data.all >= Right; end ">="; function ">=" (Left : in String; Right : in Unbounded_String) return Boolean is begin return Left >= Right.Data.all; end ">="; function "*" (Left : in Natural; Right : in Character) return Unbounded_String is New_String : Unbounded_String := (Ada.Finalization.Controlled with Data => new String (1 .. Left)); begin for I in New_String.Data'Range loop New_String.Data (I) := Right; end loop; return New_String; end "*"; function "*" (Left : in Natural; Right : in String) return Unbounded_String is begin if Left = 0 or else Right'Last < Right'First then return Null_Unbounded_String; end if; declare Length : constant Natural := Right'Last - Right'First + 1; New_String : Unbounded_String := (Ada.Finalization.Controlled with Data => new String (1 .. Left * Length)); begin for I in 1 .. Left loop New_String.Data (I * Length - Length + 1 .. I * Length) := Right; end loop; return New_String; end; end "*"; function "*" (Left : in Natural; Right : in Unbounded_String) return Unbounded_String is begin return Left * Right.Data.all; end "*"; ---------------------------------------------------------------------------- -- Append. -- Standard procedure Append (Source : in out Unbounded_String; New_Item : in Unbounded_String) is begin Append (Source, New_Item.Data.all); end Append; -- Standard procedure Append (Source : in out Unbounded_String; New_Item : in String) is begin if New_Item'Last < New_Item'First then return; end if; declare Ptr : constant String_Access := new String (1 .. Source.Data'Last + New_Item'Length); begin Ptr (1 .. Source.Data'Last) := Source.Data.all; Ptr (Source.Data'Last + 1 .. Ptr'Last) := New_Item; Free (Source.Data); Source.Data := Ptr; end; end Append; -- Standard procedure Append (Source : in out Unbounded_String; New_Item : in Character) is Ptr : constant String_Access := new String (1 .. Source.Data'Last + 1); begin Ptr (1 .. Source.Data'Last) := Source.Data.all; Ptr (Source.Data'Last + 1) := New_Item; Free (Source.Data); Source.Data := Ptr; end Append; -- Slice function Append (Source : in Unbounded_String; From : in Unbounded_String; Low : in Positive; High : in Natural) return Unbounded_String is begin Slice_Check (Low, High, From.Data'Last); if Low <= High then return Source & From.Data (Low .. High); else return Source; end if; end Append; -- Slice procedure Append (Source : in out Unbounded_String; From : in Unbounded_String; Low : in Positive; High : in Natural) is begin Slice_Check (Low, High, From.Data'Last); if Low <= High then Append (Source, From.Data (Low .. High)); end if; end Append; ---------------------------------------------------------------------------- -- Count. -- Standard function Count (Source : in Unbounded_String; Pattern : in String; Mapping : in Ada.Strings.Maps.Character_Mapping := Ada.Strings.Maps.Identity) return Natural is use type ASM.Character_Mapping; begin if Mapping = Ada.Strings.Maps.Identity then return Count (Source.Data.all, Pattern); elsif Pattern'Last < Pattern'First then raise Pattern_Error; elsif Pattern'Last - Pattern'First + 1 > Source.Data'Last then return 0; end if; declare Temporary : Unbounded_String := (Ada.Finalization.Controlled with Data => new String (Source.Data'Range)); begin for I in Temporary.Data'Range loop Temporary.Data (I) := ASM.Value (Mapping, Source.Data (I)); end loop; return Count (Temporary.Data.all, Pattern); end; end Count; -- Standard function Count (Source : in Unbounded_String; Pattern : in String; Mapping : in Ada.Strings.Maps.Character_Mapping_Function) return Natural is use type ASM.Character_Mapping_Function; begin if Pattern'Last < Pattern'First then raise Pattern_Error; elsif Pattern'Last - Pattern'First + 1 > Source.Data'Last then return 0; elsif Mapping = null then raise Constraint_Error; end if; declare Temporary : Unbounded_String := (Ada.Finalization.Controlled with Data => new String (Source.Data'Range)); begin for I in Temporary.Data'Range loop Temporary.Data (I) := Mapping (Source.Data (I)); end loop; return Count (Temporary.Data.all, Pattern); end; end Count; -- Standard function Count (Source : in Unbounded_String; Set : in Ada.Strings.Maps.Character_Set) return Natural is begin return ASF.Count (Source.Data.all, Set); end Count; -- Unbounded function Count (Source : in Unbounded_String; Pattern : in Unbounded_String; Mapping : in Ada.Strings.Maps.Character_Mapping := Ada.Strings.Maps.Identity) return Natural is begin return Count (Source, Pattern.Data.all, Mapping); end Count; -- Unbounded function Count (Source : in Unbounded_String; Pattern : in Unbounded_String; Mapping : in Ada.Strings.Maps.Character_Mapping_Function) return Natural is begin return Count (Source, Pattern.Data.all, Mapping); end Count; ---------------------------------------------------------------------------- -- Delete. -- Standard function Delete (Source : in Unbounded_String; From : in Positive; Through : in Natural) return Unbounded_String is begin Slice_Check (From, Through, Source.Data'Last); if From > Through then return Source; end if; declare New_String : Unbounded_String := (Ada.Finalization.Controlled with Data => new String (1 .. Source.Data'Last - (Through - From + 1))); begin New_String.Data (1 .. From - 1) := Source.Data (1 .. From - 1); New_String.Data (From .. New_String.Data'Last) := Source.Data (Through + 1 .. Source.Data'Last); return New_String; end; end Delete; -- Standard procedure Delete (Source : in out Unbounded_String; From : in Positive; Through : in Natural) is begin Slice_Check (From, Through, Source.Data'Last); if From > Through then return; end if; declare New_String : constant String_Access := new String (1 .. Source.Data'Last - (Through - From + 1)); begin New_String (1 .. From - 1) := Source.Data (1 .. From - 1); New_String (From .. New_String'Last) := Source.Data (Through + 1 .. Source.Data'Last); Free (Source.Data); Source.Data := New_String; end; end Delete; ---------------------------------------------------------------------------- -- Find. -- Standard function Element (Source : in Unbounded_String; Index : in Positive) return Character is begin return Source.Data (Index); end Element; ---------------------------------------------------------------------------- -- Find. -- New function Find (Source : in Unbounded_String; Pattern : in Character; Going : in Ada.Strings.Direction := Ada.Strings.Forward) return Natural is use type Ada.Strings.Direction; begin if Going = Forward then return First_Index (Source.Data.all, Pattern); else return Last_Index (Source.Data.all, Pattern); end if; end Find; -- New function Find (Source : in Unbounded_String; Pattern : in String; Going : in Ada.Strings.Direction := Ada.Strings.Forward) return Natural is use type Ada.Strings.Direction; begin if Going = Forward then return First_Index (Source.Data.all, Pattern); else return Last_Index (Source.Data.all, Pattern); end if; end Find; -- New function Find (Source : in Unbounded_String; Pattern : in Unbounded_String; Going : in Ada.Strings.Direction := Ada.Strings.Forward) return Natural is use type Ada.Strings.Direction; begin if Going = Forward then return First_Index (Source.Data.all, Pattern.Data.all); else return Last_Index (Source.Data.all, Pattern.Data.all); end if; end Find; -- New, From function Find (Source : in Unbounded_String; Pattern : in Character; From : in Positive; Going : in Ada.Strings.Direction := Ada.Strings.Forward) return Natural is use type Ada.Strings.Direction; begin if From > Source.Data'Last then raise Index_Error; end if; if Going = Forward then return First_Index (Source.Data (From .. Source.Data'Last), Pattern); else return Last_Index (Source.Data (1 .. From), Pattern); end if; end Find; -- New, From function Find (Source : in Unbounded_String; Pattern : in String; From : in Positive; Going : in Ada.Strings.Direction := Ada.Strings.Forward) return Natural is use type Ada.Strings.Direction; begin if From > Source.Data'Last then raise Index_Error; end if; if Going = Forward then return First_Index (Source.Data (From .. Source.Data'Last), Pattern); else return Last_Index (Source.Data (1 .. From), Pattern); end if; end Find; -- New, From function Find (Source : in Unbounded_String; Pattern : in Unbounded_String; From : in Positive; Going : in Ada.Strings.Direction := Ada.Strings.Forward) return Natural is begin return Find (Source, Pattern.Data.all, From, Going); end Find; ---------------------------------------------------------------------------- -- Find_Token. -- Standard procedure Find_Token (Source : in Unbounded_String; Set : in Ada.Strings.Maps.Character_Set; Test : in Ada.Strings.Membership; First : out Positive; Last : out Natural) is begin ASF.Find_Token (Source.Data.all, Set, Test, First, Last); end Find_Token; -- From procedure Find_Token (Source : in Unbounded_String; From : in Positive; Set : in Ada.Strings.Maps.Character_Set; Test : in Ada.Strings.Membership; First : out Positive; Last : out Natural) is begin if From > Source.Data'Last then raise Index_Error; end if; ASF.Find_Token (Source.Data (From .. Source.Data'Last), Set, Test, First, Last); end Find_Token; -- Slice procedure Find_Token (Source : in Unbounded_String; Low : in Positive; High : in Natural; Set : in Ada.Strings.Maps.Character_Set; Test : in Ada.Strings.Membership; First : out Positive; Last : out Natural) is begin Slice_Check (Low, High, Source.Data'Last); ASF.Find_Token (Source.Data (Low .. High), Set, Test, First, Last); end Find_Token; ---------------------------------------------------------------------------- -- First_Index. -- New function First_Index (Source : in Unbounded_String; Ch : in Character) return Natural is begin return First_Index (Source.Data.all, Ch); end First_Index; -- New function First_Index (Source : in Unbounded_String; Pattern : in String) return Natural is begin return First_Index (Source.Data.all, Pattern); end First_Index; -- New function First_Index (Source : in Unbounded_String; Pattern : in Unbounded_String) return Natural is begin return First_Index (Source.Data.all, Pattern.Data.all); end First_Index; -- New, From function First_Index (Source : in Unbounded_String; Ch : in Character; From : in Positive) return Natural is begin if From > Source.Data'Last then raise Index_Error; end if; return First_Index (Source.Data (From .. Source.Data'Last), Ch); end First_Index; -- New, From function First_Index (Source : in Unbounded_String; Pattern : in String; From : in Positive) return Natural is begin if From > Source.Data'Last then raise Index_Error; end if; return First_Index (Source.Data (From .. Source.Data'Last), Pattern); end First_Index; -- New, From function First_Index (Source : in Unbounded_String; Pattern : in Unbounded_String; From : in Positive) return Natural is begin if From > Source.Data'Last then raise Index_Error; end if; return First_Index (Source.Data (From .. Source.Data'Last), Pattern.Data.all); end First_Index; ---------------------------------------------------------------------------- -- From_Standard. -- New function From_Standard (S : in Ada.Strings.Unbounded.Unbounded_String) return Unbounded_String is begin return Unbounded_String' (Ada.Finalization.Controlled with Data => new String'(ASU.To_String (S))); end From_Standard; -- New procedure From_Standard (Source : in Ada.Strings.Unbounded.Unbounded_String; Target : out Unbounded_String) is begin Free (Target.Data); Target.Data := new String'(ASU.To_String (Source)); end From_Standard; ---------------------------------------------------------------------------- -- From_String. -- New function From_String (S : in String) return Unbounded_String is Result : Unbounded_String; begin Result.Data := new String (1 .. S'Length); Result.Data.all := S; return Result; end From_String; ---------------------------------------------------------------------------- -- Head. -- Standard function Head (Source : in Unbounded_String; Count : in Natural; Pad : in Character := Ada.Strings.Space) return Unbounded_String is begin if Count <= Source.Data'Last then return Slice (Source, 1, Count); else declare New_String : Unbounded_String := (Ada.Finalization.Controlled with Data => new String (1 .. Count)); begin New_String.Data (1 .. Source.Data'Last) := Source.Data.all; for I in Source.Data'Last + 1 .. New_String.Data'Last loop New_String.Data (I) := Pad; end loop; return New_String; end; end if; end Head; -- Standard procedure Head (Source : in out Unbounded_String; Count : in Natural; Pad : in Character := Ada.Strings.Space) is begin if Count <= Source.Data'Last then declare New_String : constant String_Access := Slice (Source.Data, 1, Count); begin Free (Source.Data); Source.Data := New_String; end; else declare New_String : constant String_Access := new String (1 .. Count); begin New_String (1 .. Source.Data'Last) := Source.Data.all; for I in Source.Data'Last + 1 .. New_String'Last loop New_String (I) := Pad; end loop; Free (Source.Data); Source.Data := New_String; end; end if; end Head; ---------------------------------------------------------------------------- -- Index. -- Standard function Index (Source : in Unbounded_String; Pattern : in String; Going : in Ada.Strings.Direction := Ada.Strings.Forward; Mapping : in Ada.Strings.Maps.Character_Mapping := Ada.Strings.Maps.Identity) return Natural is use type Ada.Strings.Direction; pragma Suppress (Range_Check); -- No range check needed on the 'From' parameter. begin if Source.Data'Last = 0 then if Pattern'Last < Pattern'First then raise Pattern_Error; else return 0; end if; end if; if Going = Ada.Strings.Forward then return Index (Source, Pattern, 1, Going, Mapping); else return Index (Source, Pattern, Source.Data'Last, Going, Mapping); end if; end Index; -- Standard function Index (Source : in Unbounded_String; Pattern : in String; Going : in Ada.Strings.Direction := Ada.Strings.Forward; Mapping : in Ada.Strings.Maps.Character_Mapping_Function) return Natural is use type Ada.Strings.Direction; pragma Suppress (Range_Check); -- No range check needed on the 'From' parameter. begin if Source.Data'Last = 0 then if Pattern'Last < Pattern'First then raise Pattern_Error; else return 0; end if; end if; if Going = Ada.Strings.Forward then return Index (Source, Pattern, 1, Going, Mapping); else return Index (Source, Pattern, Source.Data'Last, Going, Mapping); end if; end Index; -- Standard function Index (Source : in Unbounded_String; Set : in Ada.Strings.Maps.Character_Set; Test : in Ada.Strings.Membership := Ada.Strings.Inside; Going : in Ada.Strings.Direction := Ada.Strings.Forward) return Natural is begin return ASF.Index (Source.Data.all, Set, Test, Going); end Index; -- From function Index (Source : in Unbounded_String; Pattern : in String; From : in Positive; Going : in Ada.Strings.Direction := Ada.Strings.Forward; Mapping : in Ada.Strings.Maps.Character_Mapping := Ada.Strings.Maps.Identity) return Natural is use type ASM.Character_Mapping; use type Ada.Strings.Direction; begin if Mapping = ASM.Identity then return Find (Source, Pattern, From, Going); elsif Pattern'Last < Pattern'First then raise Pattern_Error; elsif From > Source.Data'Last then raise Index_Error; end if; if (Going = Forward and then Pattern'Last - Pattern'First + 1 > Source.Data'Last - From + 1) or else (Going = Backward and then Pattern'Last - Pattern'First + 1 > From) then -- Pattern is longer than the source: cannot possibly match. return 0; end if; -- Only map the portion to be searched. Map on the heap: unbounded -- strings may be long! declare Temporary : Unbounded_String; begin if Going = Forward then Temporary.Data := new String (From .. Source.Data'Last); -- Yes, this time indexing *doesn't* start at 1... but this is -- used only internally, so this doesn't hurt. for I in Temporary.Data'Range loop Temporary.Data (I) := ASM.Value (Mapping, Source.Data (I)); end loop; return First_Index (Temporary.Data.all, Pattern); else Temporary.Data := new String (1 .. From); for I in Temporary.Data'Range loop Temporary.Data (I) := ASM.Value (Mapping, Source.Data (I)); end loop; return Last_Index (Temporary.Data.all, Pattern); end if; end; end Index; -- From function Index (Source : in Unbounded_String; Pattern : in String; From : in Positive; Going : in Ada.Strings.Direction := Ada.Strings.Forward; Mapping : in Ada.Strings.Maps.Character_Mapping_Function) return Natural is use type ASM.Character_Mapping_Function; use type Ada.Strings.Direction; begin if From > Source.Data'Last then raise Index_Error; elsif Pattern'Last < Pattern'First then raise Pattern_Error; elsif Mapping = null then raise Constraint_Error; end if; if (Going = Forward and then Pattern'Last - Pattern'First + 1 > Source.Data'Last - From + 1) or else (Going = Backward and then Pattern'Last - Pattern'First + 1 > From) then -- Pattern is longer than the source: cannot possibly match. return 0; end if; -- Only map the portion to be searched. Map on the heap: unbounded -- strings may be long! declare Temporary : Unbounded_String; begin if Going = Forward then Temporary.Data := new String (From .. Source.Data'Last); -- Yes, this time indexing *doesn't* start at 1... but this is -- used only internally, so this doesn't hurt. for I in Temporary.Data'Range loop Temporary.Data (I) := Mapping (Source.Data (I)); end loop; return First_Index (Temporary.Data.all, Pattern); else Temporary.Data := new String (1 .. From); for I in Temporary.Data'Range loop Temporary.Data (I) := Mapping (Source.Data (I)); end loop; return Last_Index (Temporary.Data.all, Pattern); end if; end; end Index; -- From function Index (Source : in Unbounded_String; From : in Positive; Set : in Ada.Strings.Maps.Character_Set; Test : in Ada.Strings.Membership := Ada.Strings.Inside; Going : in Ada.Strings.Direction := Ada.Strings.Forward) return Natural is begin if From > Source.Data'Last then raise Index_Error; end if; return ASF.Index (Source.Data (From .. Source.Data'Last), Set, Test, Going); end Index; -- Unbounded function Index (Source : in Unbounded_String; Pattern : in Unbounded_String; Going : in Ada.Strings.Direction := Ada.Strings.Forward; Mapping : in Ada.Strings.Maps.Character_Mapping := Ada.Strings.Maps.Identity) return Natural is begin return Index (Source, Pattern.Data.all, Going, Mapping); end Index; -- Unbounded function Index (Source : in Unbounded_String; Pattern : in Unbounded_String; Going : in Ada.Strings.Direction := Ada.Strings.Forward; Mapping : in Ada.Strings.Maps.Character_Mapping_Function) return Natural is begin return Index (Source, Pattern.Data.all, Going, Mapping); end Index; -- Unbounded, From function Index (Source : in Unbounded_String; Pattern : in Unbounded_String; From : in Positive; Going : in Ada.Strings.Direction := Ada.Strings.Forward; Mapping : in Ada.Strings.Maps.Character_Mapping := Ada.Strings.Maps.Identity) return Natural is begin return Index (Source, Pattern.Data.all, From, Going, Mapping); end Index; -- Unbounded, From function Index (Source : in Unbounded_String; Pattern : in Unbounded_String; From : in Positive; Going : in Ada.Strings.Direction := Ada.Strings.Forward; Mapping : in Ada.Strings.Maps.Character_Mapping_Function) return Natural is begin return Index (Source, Pattern.Data.all, From, Going, Mapping); end Index; ---------------------------------------------------------------------------- -- Index_Non_Blank. -- Standard function Index_Non_Blank (Source : in Unbounded_String; Going : in Ada.Strings.Direction := Ada.Strings.Forward) return Natural is begin return ASF.Index_Non_Blank (Source.Data.all, Going); end Index_Non_Blank; -- From function Index_Non_Blank (Source : in Unbounded_String; From : in Positive; Going : in Ada.Strings.Direction := Ada.Strings.Forward) return Natural is begin if From > Source.Data'Last + 1 then raise Index_Error; end if; return ASF.Index_Non_Blank (Source.Data (From .. Source.Data'Last), Going); end Index_Non_Blank; ---------------------------------------------------------------------------- -- Insert. -- Standard function Insert (Source : in Unbounded_String; Before : in Positive; New_Item : in String) return Unbounded_String is begin if Before > Source.Data'Last + 1 then raise Index_Error; end if; return Unbounded_String' (Ada.Finalization.Controlled with Data => Insert (Source.Data, Before, New_Item)); end Insert; -- Standard procedure Insert (Source : in out Unbounded_String; Before : in Positive; New_Item : in String) is begin if Before > Source.Data'Last + 1 then raise Index_Error; end if; declare New_String : constant String_Access := Insert (Source.Data, Before, New_Item); begin Free (Source.Data); Source.Data := New_String; end; end Insert; -- Unbounded function Insert (Source : in Unbounded_String; Before : in Positive; New_Item : in Unbounded_String) return Unbounded_String is begin return Insert (Source, Before, New_Item.Data.all); end Insert; -- Unbounded procedure Insert (Source : in out Unbounded_String; Before : in Positive; New_Item : in Unbounded_String) is begin Insert (Source, Before, New_Item.Data.all); end Insert; -- Slice function Insert (Source : in Unbounded_String; Before : in Positive; New_Item : in Unbounded_String; Low : in Positive; High : in Natural) return Unbounded_String is begin Slice_Check (Low, High, New_Item.Data'Last); return Insert (Source, Before, New_Item.Data (Low .. High)); end Insert; -- Slice procedure Insert (Source : in out Unbounded_String; Before : in Positive; New_Item : in Unbounded_String; Low : in Positive; High : in Natural) is begin Slice_Check (Low, High, New_Item.Data'Last); Insert (Source, Before, New_Item.Data (Low .. High)); end Insert; ---------------------------------------------------------------------------- -- Is_Prefix. -- New function Is_Prefix (Source : in Unbounded_String; Prefix : in String) return Boolean is begin return Is_Prefix (Source.Data.all, Prefix); end Is_Prefix; -- New function Is_Prefix (Source : in Unbounded_String; Prefix : in Unbounded_String) return Boolean is begin return Is_Prefix (Source.Data.all, Prefix.Data.all); end Is_Prefix; ---------------------------------------------------------------------------- -- Is_Suffix. -- New function Is_Suffix (Source : in Unbounded_String; Suffix : in String) return Boolean is begin return Is_Suffix (Source.Data.all, Suffix); end Is_Suffix; -- New function Is_Suffix (Source : in Unbounded_String; Suffix : in Unbounded_String) return Boolean is begin return Is_Suffix (Source.Data.all, Suffix.Data.all); end Is_Suffix; ---------------------------------------------------------------------------- -- Last_Index. -- New function Last_Index (Source : in Unbounded_String; Ch : in Character) return Natural is begin return Last_Index (Source.Data.all, Ch); end Last_Index; -- New function Last_Index (Source : in Unbounded_String; Pattern : in String) return Natural is begin return Last_Index (Source.Data.all, Pattern); end Last_Index; -- New function Last_Index (Source : in Unbounded_String; Pattern : in Unbounded_String) return Natural is begin return Last_Index (Source.Data.all, Pattern.Data.all); end Last_Index; -- New, From function Last_Index (Source : in Unbounded_String; Ch : in Character; Limit : in Positive) return Natural is begin if Limit > Source.Data'Last then raise Index_Error; end if; return Last_Index (Source.Data (1 .. Limit), Ch); end Last_Index; -- New, From function Last_Index (Source : in Unbounded_String; Pattern : in String; Limit : in Positive) return Natural is begin if Limit > Source.Data'Last then raise Index_Error; end if; return Last_Index (Source.Data (1 .. Limit), Pattern); end Last_Index; -- New, From function Last_Index (Source : in Unbounded_String; Pattern : in Unbounded_String; Limit : in Positive) return Natural is begin if Limit > Source.Data'Last then raise Index_Error; end if; return Last_Index (Source.Data (1 .. Limit), Pattern.Data.all); end Last_Index; ---------------------------------------------------------------------------- -- Length. -- Standard function Length (Source : in Unbounded_String) return Natural is begin return Source.Data'Length; end Length; ---------------------------------------------------------------------------- -- Overwrite. -- New function Occurrences (Source : in Unbounded_String; Pattern : in String) return Natural is begin return Count (Source.Data.all, Pattern); end Occurrences; -- New function Occurrences (Source : in Unbounded_String; Pattern : in Unbounded_String) return Natural is begin return Count (Source.Data.all, Pattern.Data.all); end Occurrences; ---------------------------------------------------------------------------- -- Overwrite. -- Standard function Overwrite (Source : in Unbounded_String; Position : in Positive; New_Item : in String) return Unbounded_String is begin if Position > Source.Data'Last + 1 then raise Index_Error; end if; declare Length : constant Natural := New_Item'Length; New_String : Unbounded_String := (Ada.Finalization.Controlled with Data => new String (1 .. Integer'Max (Source.Data'Last, Position - 1 + Length))); begin New_String.Data (1 .. Position - 1) := Source.Data (1 .. Position - 1); New_String.Data (Position .. Position + Length - 1) := New_Item; New_String.Data (Position + Length .. New_String.Data'Last) := Source.Data (Position + Length .. Source.Data'Last); return New_String; end; end Overwrite; -- Standard procedure Overwrite (Source : in out Unbounded_String; Position : in Positive; New_Item : in String) is Length : constant Natural := New_Item'Length; begin if Position <= Source.Data'Last - Length + 1 then Source.Data (Position .. Position + Length - 1) := New_Item; elsif Position > Source.Data'Last + 1 then raise Index_Error; else declare New_String : constant String_Access := new String (1 .. Position - 1 + Length); begin New_String (1 .. Position - 1) := Source.Data (1 .. Position - 1); New_String (Position .. New_String'Last) := New_Item; Free (Source.Data); Source.Data := New_String; end; end if; end Overwrite; -- Unbounded function Overwrite (Source : in Unbounded_String; Position : in Positive; New_Item : in Unbounded_String) return Unbounded_String is begin return Overwrite (Source, Position, New_Item.Data.all); end Overwrite; -- Unbounded procedure Overwrite (Source : in out Unbounded_String; Position : in Positive; New_Item : in Unbounded_String) is begin Overwrite (Source, Position, New_Item.Data.all); end Overwrite; -- Slice function Overwrite (Source : in Unbounded_String; Position : in Positive; New_Item : in Unbounded_String; Low : in Positive; High : in Natural) return Unbounded_String is begin Slice_Check (Low, High, New_Item.Data'Last); return Overwrite (Source, Position, New_Item.Data (Low .. High)); end Overwrite; -- Slice procedure Overwrite (Source : in out Unbounded_String; Position : in Positive; New_Item : in Unbounded_String; Low : in Positive; High : in Natural) is begin Slice_Check (Low, High, New_Item.Data'Last); Overwrite (Source, Position, New_Item.Data (Low .. High)); end Overwrite; ---------------------------------------------------------------------------- -- Replace. -- New procedure Replace (Source : in out Unbounded_String; What : in String; By : in String) is N : constant Natural := Count (Source.Data.all, What); begin if N = 0 then return; end if; declare By_Length : constant Natural := By'Length; What_Length : constant Natural := What'Length; Result : constant String_Access := new String (1 .. Source.Data'Last - N * (What_Length - By_Length)); I, J, K : Natural; begin J := 1; I := Source.Data'First; while I <= Source.Data'Last loop K := First_Index (Source.Data (I .. Source.Data'Last), What); if K = 0 then Result (J .. Result'Last) := Source.Data (I .. Source.Data'Last); I := Source.Data'Last + 1; else Result (J .. J + (K - I) - 1) := Source.Data (I .. K - 1); J := J + (K - I); Result (J .. J + By_Length - 1) := By; J := J + By_Length; I := K + What_Length; end if; end loop; Free (Source.Data); Source.Data := Result; end; end Replace; -- New, Unbounded procedure Replace (Source : in out Unbounded_String; What : in Unbounded_String; By : in Unbounded_String) is begin Replace (Source, What.Data.all, By.Data.all); end Replace; ---------------------------------------------------------------------------- -- Replace_Element. -- Standard procedure Replace_Element (Source : in out Unbounded_String; Index : in Positive; By : in Character) is begin Source.Data (Index) := By; end Replace_Element; ---------------------------------------------------------------------------- -- Replace_Slice. -- Standard function Replace_Slice (Source : in Unbounded_String; Low : in Positive; High : in Natural; By : in String) return Unbounded_String is begin Slice_Check (Low, High, Source.Data'Last); return Unbounded_String' (Ada.Finalization.Controlled with Data => Replace_Slice (Source.Data, Low, High, By)); end Replace_Slice; -- Standard procedure Replace_Slice (Source : in out Unbounded_String; Low : in Positive; High : in Natural; By : in String) is begin Slice_Check (Low, High, Source.Data'Last); declare New_String : constant String_Access := Replace_Slice (Source.Data, Low, High, By); begin Free (Source.Data); Source.Data := New_String; end; end Replace_Slice; -- Unbounded function Replace_Slice (Source : in Unbounded_String; Low : in Positive; High : in Natural; By : in Unbounded_String) return Unbounded_String is begin return Replace_Slice (Source, Low, High, By.Data.all); end Replace_Slice; -- Unbounded procedure Replace_Slice (Source : in out Unbounded_String; Low : in Positive; High : in Natural; By : in Unbounded_String) is begin Replace_Slice (Source, Low, High, By.Data.all); end Replace_Slice; -- Slice function Replace_Slice (Source : in Unbounded_String; Low : in Positive; High : in Natural; By : in Unbounded_String; From : in Positive; To : in Natural) return Unbounded_String is begin Slice_Check (From, To, By.Data'Last); return Replace_Slice (Source, Low, High, By.Data (From .. To)); end Replace_Slice; -- Slice procedure Replace_Slice (Source : in out Unbounded_String; Low : in Positive; High : in Natural; By : in Unbounded_String; From : in Positive; To : in Natural) is begin Slice_Check (From, To, By.Data'Last); Replace_Slice (Source, Low, High, By.Data (From .. To)); end Replace_Slice; ---------------------------------------------------------------------------- -- Set. -- New procedure Set (Target : in out Unbounded_String; Str : in String) is begin Free (Target.Data); if Str'Last >= Str'First then Target.Data := new String (1 .. Str'Length); Target.Data.all := Str; else Target.Data := Null_String'Access; end if; end Set; ---------------------------------------------------------------------------- -- Slice. -- Standard function Slice (Source : in Unbounded_String; Low : in Positive; High : in Natural) return String is begin Slice_Check (Low, High, Source.Data'Last); return Source.Data (Low .. High); end Slice; -- Unbounded function Slice (Source : in Unbounded_String; Low : in Positive; High : in Natural) return Unbounded_String is begin Slice_Check (Low, High, Source.Data'Last); return Unbounded_String' (Ada.Finalization.Controlled with Data => Slice (Source.Data, Low, High)); end Slice; -- Slice procedure Slice (Target : in out Unbounded_String; Source : in Unbounded_String; Low : in Positive; High : in Natural) is begin Slice_Check (Low, High, Source.Data'Last); declare New_String : constant String_Access := Slice (Source.Data, Low, High); begin Free (Target.Data); Target.Data := New_String; end; end Slice; ---------------------------------------------------------------------------- -- Tail. -- Standard function Tail (Source : in Unbounded_String; Count : in Natural; Pad : in Character := Ada.Strings.Space) return Unbounded_String is begin if Count <= Source.Data'Last then return Slice (Source, Source.Data'Last - Count + 1, Source.Data'Last); else declare New_String : Unbounded_String := (Ada.Finalization.Controlled with Data => new String (1 .. Count)); begin New_String.Data (New_String.Data'Last - Source.Data'Last + 1 .. New_String.Data'Last) := Source.Data.all; for I in 1 .. New_String.Data'Last - Source.Data'Last loop New_String.Data (I) := Pad; end loop; return New_String; end; end if; end Tail; -- Standard. procedure Tail (Source : in out Unbounded_String; Count : in Natural; Pad : in Character := Ada.Strings.Space) is begin if Count <= Source.Data'Last then declare New_String : constant String_Access := Slice (Source.Data, Source.Data'Last - Count + 1, Source.Data'Last); begin Free (Source.Data); Source.Data := New_String; end; else declare New_String : constant String_Access := new String (1 .. Count); begin New_String (New_String'Last - Source.Data'Last + 1 .. New_String'Last) := Source.Data.all; for I in 1 .. New_String'Last - Source.Data'Last loop New_String (I) := Pad; end loop; Free (Source.Data); Source.Data := New_String; end; end if; end Tail; ---------------------------------------------------------------------------- -- To_Standard. -- New function To_Standard (S : in Unbounded_String) return Ada.Strings.Unbounded.Unbounded_String is begin return ASU.To_Unbounded_String (S.Data.all); end To_Standard; -- New procedure To_Standard (Source : in Unbounded_String; Target : out Ada.Strings.Unbounded.Unbounded_String) is begin Target := ASU.To_Unbounded_String (Source.Data.all); end To_Standard; ---------------------------------------------------------------------------- -- To_String -- Standard function To_String (S : in Unbounded_String) return String is begin return S.Data.all; end To_String; ---------------------------------------------------------------------------- -- To_Unbounded_String. -- Standard function To_Unbounded_String (Length : in Natural) return Unbounded_String is begin return Unbounded_String' (Ada.Finalization.Controlled with Data => new String (1 .. Length)); end To_Unbounded_String; ---------------------------------------------------------------------------- -- Translate. -- Standard function Translate (Source : in Unbounded_String; Mapping : in Ada.Strings.Maps.Character_Mapping) return Unbounded_String is Result : Unbounded_String := (Ada.Finalization.Controlled with Data => new String (Source.Data'Range)); begin for I in Result.Data'Range loop Result.Data (I) := ASM.Value (Mapping, Source.Data (I)); end loop; return Result; end Translate; -- Standard procedure Translate (Source : in out Unbounded_String; Mapping : in Ada.Strings.Maps.Character_Mapping) is begin ASF.Translate (Source.Data.all, Mapping); end Translate; -- Slice function Translate (Source : in Unbounded_String; From : in Positive; Through : in Natural; Mapping : in Ada.Strings.Maps.Character_Mapping) return Unbounded_String is begin Slice_Check (From, Through, Source.Data'Last); if From > Through then return Null_Unbounded_String; end if; declare Result : Unbounded_String := (Ada.Finalization.Controlled with Data => new String (1 .. Through - From + 1)); begin for I in Result.Data'Range loop Result.Data (I) := ASM.Value (Mapping, Source.Data (From + I)); end loop; return Result; end; end Translate; -- Slice procedure Translate (Source : in out Unbounded_String; From : in Positive; Through : in Natural; Mapping : in Ada.Strings.Maps.Character_Mapping) is begin Slice_Check (From, Through, Source.Data'Last); ASF.Translate (Source.Data (From .. Through), Mapping); end Translate; -- Standard function Translate (Source : in Unbounded_String; Mapping : in Ada.Strings.Maps.Character_Mapping_Function) return Unbounded_String is use type ASM.Character_Mapping_Function; begin if Mapping = null then raise Constraint_Error; end if; declare Result : Unbounded_String := (Ada.Finalization.Controlled with Data => new String (Source.Data'Range)); begin for I in Result.Data'Range loop Result.Data (I) := Mapping (Source.Data (I)); end loop; return Result; end; end Translate; -- Standard procedure Translate (Source : in out Unbounded_String; Mapping : in Ada.Strings.Maps.Character_Mapping_Function) is begin ASF.Translate (Source.Data.all, Mapping); end Translate; -- Slice function Translate (Source : in Unbounded_String; From : in Positive; Through : in Natural; Mapping : in Ada.Strings.Maps.Character_Mapping_Function) return Unbounded_String is use type ASM.Character_Mapping_Function; begin Slice_Check (From, Through, Source.Data'Last); if From > Through then return Null_Unbounded_String; elsif Mapping = null then raise Constraint_Error; end if; declare Result : Unbounded_String := (Ada.Finalization.Controlled with Data => new String (1 .. Through - From + 1)); begin for I in Result.Data'Range loop Result.Data (I) := Mapping (Source.Data (From + I)); end loop; return Result; end; end Translate; -- Slice procedure Translate (Source : in out Unbounded_String; From : in Positive; Through : in Natural; Mapping : in Ada.Strings.Maps.Character_Mapping_Function) is begin Slice_Check (From, Through, Source.Data'Last); ASF.Translate (Source.Data (From .. Through), Mapping); end Translate; ---------------------------------------------------------------------------- -- Trim. -- Standard function Trim (Source : in Unbounded_String; Side : in Ada.Strings.Trim_End) return Unbounded_String is I, J : Natural; begin Trim (Source.Data.all, Side, I, J); return Unbounded_String' (Ada.Finalization.Controlled with Data => Slice (Source.Data, I, J)); end Trim; -- Standard procedure Trim (Source : in out Unbounded_String; Side : in Ada.Strings.Trim_End) is I, J : Natural; begin Trim (Source.Data.all, Side, I, J); -- What remains is Source.Data (I .. J). declare New_String : constant String_Access := Slice (Source.Data, I, J); begin Free (Source.Data); Source.Data := New_String; end; end Trim; -- Standard function Trim (Source : in Unbounded_String; Left : in Ada.Strings.Maps.Character_Set; Right : in Ada.Strings.Maps.Character_Set) return Unbounded_String is I, J : Natural; begin Trim (Source.Data.all, Left, Right, I, J); return Unbounded_String' (Ada.Finalization.Controlled with Data => Slice (Source.Data, I, J)); end Trim; -- Standard procedure Trim (Source : in out Unbounded_String; Left : in Ada.Strings.Maps.Character_Set; Right : in Ada.Strings.Maps.Character_Set) is I, J : Natural; begin Trim (Source.Data.all, Left, Right, I, J); declare New_String : constant String_Access := Slice (Source.Data, I, J); begin Free (Source.Data); Source.Data := New_String; end; end Trim; ---------------------------------------------------------------------------- -- Controlled operations procedure Initialize (S : in out Unbounded_String) is begin S.Data := Null_String'Access; end Initialize; procedure Adjust (S : in out Unbounded_String) is begin if S.Data /= Null_String'Access then S.Data := new String'(S.Data.all); end if; end Adjust; procedure Finalize (S : in out Unbounded_String) is begin Free (S.Data); end Finalize; ---------------------------------------------------------------------------- -- Stream operations procedure Write (Stream : access Ada.Streams.Root_Stream_Type'Class; S : in Unbounded_String) is begin Natural'Write (Stream, S.Data'Last); if S.Data'Last > 0 then String'Write (Stream, S.Data.all); end if; end Write; procedure Read (Stream : access Ada.Streams.Root_Stream_Type'Class; S : out Unbounded_String) is N : Natural; begin Free (S.Data); Natural'Read (Stream, N); if N = 0 then S.Data := Null_String'Access; else S.Data := new String (1 .. N); String'Read (Stream, S.Data.all); end if; end Read; end Util.Text; adabrowse_4.0.3/ad-filters.adb0000644000175000017500000026057410234241450014376 0ustar kenken------------------------------------------------------------------------------- -- -- This file is part of AdaBrowse. -- -- Copyright (c) 2002 by Thomas Wolf. --
    -- AdaBrowse is free software; you can redistribute it and/or modify it -- under the terms of the GNU General Public License as published by the -- Free Software Foundation; either version 2, or (at your option) any -- later version. AdaBrowse is distributed in the hope that it will be -- useful, but without any warranty; without even the implied -- warranty of merchantability or fitness for a particular purpose. -- See the GNU General Public License for more details. You should have -- received a copy of the GNU General Public License with this distribution, -- see file "GPL.txt". If not, write to the Free -- Software Foundation, 59 Temple Place - Suite 330, Boston, MA 02111-1307, -- USA. --
    -- --
    -- Author:
    -- Thomas Wolf (TW) --
    twolf@acm.org
    -- --
    -- Purpose:
    -- Filters for formatted output of comments.
    -- -- ------------------------------------------------------------------------------- pragma License (GPL); with Ada.Calendar; with Ada.Exceptions; with Ada.Streams.Stream_IO; with Ada.Text_IO; with Ada.Unchecked_Deallocation; with AD.File_Ops; with AD.HTML; with AD.Messages; with AD.Parameters; with AD.User_Tags; with GAL.Support; with Util.Calendar.IO; with Util.Environment.Bash; with Util.Pipes; with Util.Strings; with Util.Text.Internal; package body AD.Filters is package UT renames Util.Text; use AD.Messages; use AD.User_Tags; use Util.Strings; ---------------------------------------------------------------------------- -- Parsing a filter specification from a string. function Parse (Program : in String) return Filter_Ref is Pipe_Character : constant Character := '|'; procedure Get_Param (Src : in String; From, To : out Natural; Before : in Character) is begin From := Next_Non_Blank (Src); if From = 0 or else Src (From) /= Before then -- Missing parameter. Ada.Exceptions.Raise_Exception (Parse_Error'Identity, "missing parameter"); end if; From := Next_Non_Blank (Src (From + 1 .. Src'Last)); if From = 0 or else not Is_In (String_Quotes, Src (From)) then -- Missing parameter. Ada.Exceptions.Raise_Exception (Parse_Error'Identity, "string parameter expected"); end if; Get_String (Src (From .. Src'Last), From, To, Src (From), Src (From)); -- Ada format of strings, i.e. delimiter must be doubled. if To = 0 then -- Unterminated string. Ada.Exceptions.Raise_Exception (Parse_Error'Identity, "unterminated string: " & Src (From .. Src'Last)); end if; end Get_Param; procedure Get_Command (Src : in String; From, To : out Natural; Last : out Natural) is function Read_Command (Src : in String; Delim : in Character) return Natural is I : Natural := Src'First + 1; begin while I <= Src'Last and then Src (I) /= Delim loop if Src (I) = '(' then I := Read_Command (Src (I .. Src'Last), ')'); elsif Src (I) = '{' then I := Read_Command (Src (I .. Src'Last), '}'); elsif Is_In (Shell_Quotes, Src (I)) then declare J : constant Natural := Skip_String (Src (I .. Src'Last), Src (I), Src (I)); begin if J = 0 then Ada.Exceptions.Raise_Exception (Parse_Error'Identity, "unterminated string: " & Src (I .. Src'Last)); end if; I := J; end; end if; I := I + 1; end loop; if I > Src'Last then -- Unterminated parentheses. Ada.Exceptions.Raise_Exception (Parse_Error'Identity, "missing closing '" & Delim & "': " & Src); end if; return I; end Read_Command; begin -- Get_Command From := Src'First + 1; To := 0; Last := Read_Command (Src, ')'); while From <= Last and then Is_Blank (Src (From)) loop From := From + 1; end loop; To := Last - 1; while To >= From and then Is_Blank (Src (To)) loop To := To - 1; end loop; end Get_Command; Pipe, Expr : Filter_Ref := null; I, J : Natural; begin I := Next_Non_Blank (Program); if I = 0 then I := Program'Last + 1; end if; while I <= Program'Last loop J := Identifier (Program (I .. Program'Last)); if J = 0 then -- No identifier found: error Ada.Exceptions.Raise_Exception (Parse_Error'Identity, "identifier expected after " & Program (Program'First .. I)); end if; -- Handle the identifier. Parse_Filter : declare Filter_Name : constant String := To_Lower (Program (I .. J)); Start : constant Natural := I; begin if Filter_Name = "entities" then Expr := new Filter_Entities; elsif Filter_Name = "enclose" then declare A, B, C, D : Natural; begin Get_Param (Program (J + 1 .. Program'Last), A, B, '('); Get_Param (Program (B + 1 .. Program'Last), C, D, ','); J := Next_Non_Blank (Program (D + 1 .. Program'Last)); if J = 0 or else Program (J) /= ')' then -- Missing closing parentheses. Ada.Exceptions.Raise_Exception (Parse_Error'Identity, "missing ')': " & Program (Start .. Program'Last)); end if; Expr := new Filter_Enclose; Init (Filter_Enclose (Expr.all)'Access, Unquote (Program (A + 1 .. B - 1), Program (A), Program (A)), Unquote (Program (C + 1 .. D - 1), Program (C), Program (C))); end; elsif Filter_Name = "pre" then Expr := new Filter_Pre; elsif Filter_Name = "swallow" then Expr := new Filter_Swallow; elsif Filter_Name = "execute" then I := Next_Non_Blank (Program (J + 1 .. Program'Last)); if I = 0 then Ada.Exceptions.Raise_Exception (Parse_Error'Identity, "incomplete execute filter: " & Program (Start .. Program'Last)); end if; declare LF : Filter_Linefeeds := Default_LF; begin if Program (I) /= '(' then J := Identifier (Program (I .. Program'Last)); if J = 0 then Ada.Exceptions.Raise_Exception (Parse_Error'Identity, "linefeed specification expected: " & Program (Start .. I)); end if; declare Mode : constant String := To_Lower (Program (I .. J)); begin if Mode = "lf" then LF := LF_Only; elsif Mode = "cr" then LF := CR_Only; elsif Mode = "crlf" then LF := CR_And_LF; else Ada.Exceptions.Raise_Exception (Parse_Error'Identity, "unknown linefeed specification: " & Program (I .. J)); end if; end; I := Next_Non_Blank (Program (J + 1 .. Program'Last)); if Program (I) /= '(' then Ada.Exceptions.Raise_Exception (Parse_Error'Identity, "'(' expected after 'execute': " & Program (Start .. Program'Last)); end if; end if; -- Program (I) = '('. declare A, B : Natural; begin Get_Command (Program (I .. Program'Last), A, B, J); if A > B then -- Empty command Ada.Exceptions.Raise_Exception (Parse_Error'Identity, "empty command: " & Program (Start .. J)); end if; Expr := new Filter_Execute (LF); Init (Filter_Execute (Expr.all)'Access, Unquote_All (Program (A .. B), Shell_Quotes)); end; -- Program (J) = ')' end; elsif Filter_Name = "expand" then Expr := new Filter_Expand; elsif Filter_Name = "strip_comments" then Expr := new Filter_Strip; elsif Filter_Name = "plain" then Expr := new Filter_Plain; elsif Filter_Name = "para" then Expr := new Filter_Para; elsif Filter_Name = "lines" then Expr := new Filter_Lines; elsif Filter_Name = "shortcut" then Expr := new Filter_Shortcut; elsif Filter_Name = "standard" then Expr := new Filter_Standard; elsif Filter_Name = "hr" then I := Next_Non_Blank (Program (J + 1 .. Program'Last)); if I = 0 or else Program (I) = Pipe_Character then -- Default is strip Expr := new Filter_HR (True); if I = 0 then J := Program'Last; else J := I - 1; end if; else J := Identifier (Program (I .. Program'Last)); if J = 0 then Ada.Exceptions.Raise_Exception (Parse_Error'Identity, "'strip' or 'replace' expected: " & Program (Start .. Program'Last)); end if; declare Mode : constant String := To_Lower (Program (I .. J)); begin if Mode = "strip" then Expr := new Filter_HR (True); elsif Mode = "replace" then Expr := new Filter_HR (False); else Ada.Exceptions.Raise_Exception (Parse_Error'Identity, "'strip' or 'replace' expected: " & Program (Start .. J)); end if; end; end if; elsif Filter_Name = "unknown_tags" then I := Next_Non_Blank (Program (J + 1 .. Program'Last)); if I = 0 or else Program (I) = Pipe_Character then -- Default is standard tags only: Expr := new Filter_Unknown (True); if I = 0 then J := Program'Last; else J := I - 1; end if; else J := Identifier (Program (I .. Program'Last)); if J = 0 then Ada.Exceptions.Raise_Exception (Parse_Error'Identity, "'all' or 'standard' expected: " & Program (Start .. Program'Last)); end if; declare Mode : constant String := To_Lower (Program (I .. J)); begin if Mode = "standard" then Expr := new Filter_Unknown (True); elsif Mode = "all" then Expr := new Filter_Unknown (False); else Ada.Exceptions.Raise_Exception (Parse_Error'Identity, "'all' or 'standard' expected: " & Program (Start .. J)); end if; end; end if; else -- Unknown filter Ada.Exceptions.Raise_Exception (Parse_Error'Identity, "unknown filter '" & Program (I .. J) & '''); end if; end Parse_Filter; -- J is on the last character processed; Expr is the filter. I := Next_Non_Blank (Program (J + 1 .. Program'Last)); if I = 0 then if Pipe /= null then -- Expr is the rightmost operand of a pipe: add it. Add_Operand (Filter_Pipe (Pipe.all)'Access, Expr); end if; exit; end if; if Program (I) /= Pipe_Character then Ada.Exceptions.Raise_Exception (Parse_Error'Identity, "unknown operator '" & Program (I) & "', expected a pipe '|'"); end if; -- We're on a pipe operator: 'Expr' is an operand in a pipe (the -- right-most operand parsed so far). Hence create the pipe if it -- doesn'tz exist already, and then add the operand. if Pipe = null then Pipe := new Filter_Pipe; end if; Add_Operand (Filter_Pipe (Pipe.all)'Access, Expr); I := Next_Non_Blank (Program (I + 1 .. Program'Last)); if I = 0 then Ada.Exceptions.Raise_Exception (Parse_Error'Identity, "last pipe '|' has no right-hand side"); end if; end loop; if Pipe /= null then -- Yes, we have a pipe, and Expr is already contained in it. return Pipe; else -- We may return null here, which (much later on) will be used to -- signify "remove this filter completely". return Expr; end if; end Parse; ---------------------------------------------------------------------------- procedure Free is new Ada.Unchecked_Deallocation (Operand_Table, Operand_Ptr); procedure Finalize (Self : in out Filter_Killer) is begin if Self.Parent.Operands /= null then for I in Self.Parent.Operands'Range loop Free (Self.Parent.Operands (I)); end loop; Free (Self.Parent.Operands); end if; end Finalize; procedure Add_Operand (Self : access Filter_Pipe; Operand : in Filter_Ref) is begin if Operand /= null then if Self.Operands = null then Self.Operands := new Operand_Table'(1 => Operand); else declare New_Ops : constant Operand_Ptr := new Operand_Table (1 .. Self.Operands'Last + 1); begin New_Ops (1 .. Self.Operands'Last) := Self.Operands.all; New_Ops (New_Ops'Last) := Operand; Free (Self.Operands); Self.Operands := New_Ops; end; end if; end if; end Add_Operand; procedure Transform (Self : access Filter_Pipe; Text : in out Util.Text.Unbounded_String) is begin if Self.Operands /= null then for I in Self.Operands'Range loop Transform (Self.Operands (I), Text); end loop; end if; end Transform; ---------------------------------------------------------------------------- procedure Transform (Self : access Filter_Entities; Text : in out Util.Text.Unbounded_String) is pragma Warnings (Off, Self); -- silence -gnatwa Source : constant UT.String_Access := UT.Internal.Get_Ptr (Text); Result : UT.Unbounded_String; Start, I : Natural; begin Start := Source'First; while Start <= Source'Last loop -- Handle the text line by line: it's an attempt to avoid having -- huge strings on the secondary stack. (HTMLize is recursive...) I := First_Index (Source (Start .. Source'Last), ASCII.LF); if I = 0 then I := Source'Last; end if; UT.Append (Result, AD.HTML.HTMLize (Source (Start .. I))); Start := I + 1; end loop; Text := Result; end Transform; ---------------------------------------------------------------------------- procedure Init (Self : access Filter_Enclose; Before, After : in String) is begin UT.Set (Self.Before, Before); UT.Set (Self.After, After); end Init; procedure Transform (Self : access Filter_Enclose; Text : in out Util.Text.Unbounded_String) is -- Minimize the number of reallocations: Old_Str : constant UT.String_Access := UT.Internal.Get_Ptr (Text); Before : constant UT.String_Access := UT.Internal.Get_Ptr (Self.Before); After : constant UT.String_Access := UT.Internal.Get_Ptr (Self.After); Old_Length : constant Natural := Old_Str'Last; Before_Length : constant Natural := Before'Last; After_Length : constant Natural := After'Last; New_Str : constant UT.String_Access := new String (1 .. Old_Length + Before_Length + After_Length); begin New_Str (1 .. Before_Length) := Before.all; New_Str (Before_Length + 1 .. Before_Length + Old_Length) := Old_Str.all; New_Str (Before_Length + Old_Length + 1 .. New_Str'Last) := After.all; UT.Internal.Set_Ptr (Text, New_Str); end Transform; ---------------------------------------------------------------------------- procedure Transform (Self : access Filter_Pre; Text : in out Util.Text.Unbounded_String) is pragma Warnings (Off, Self); -- silence -gnatwa -- Minimize the number of reallocations: Old_Str : constant UT.String_Access := UT.Internal.Get_Ptr (Text); Length : constant Natural := Old_Str'Last; New_Str : constant UT.String_Access := new String (1 .. Length + 5 + 6); begin New_Str (1 .. 5) := "
    ";
      New_Str (6 .. 5 + Length)            := Old_Str.all;
      New_Str (6 + Length .. New_Str'Last) := "
    "; UT.Internal.Set_Ptr (Text, New_Str); end Transform; ---------------------------------------------------------------------------- procedure Transform (Self : access Filter_Swallow; Text : in out Util.Text.Unbounded_String) is pragma Warnings (Off, Self); -- silence -gnatwa begin Text := UT.Null_Unbounded_String; end Transform; ---------------------------------------------------------------------------- procedure Init (Self : access Filter_Execute; Cmd : in String) is begin UT.Set (Self.Cmd, Cmd); end Init; procedure Transform (Self : access Filter_Execute; Text : in out Util.Text.Unbounded_String) is Max_Open_Tries : constant := 10; -- Number of times we try to open a temp file, each time with a -- different name. function Unique_Name (Base : in String; Suffix : in String) return String is Now : constant Ada.Calendar.Time := Ada.Calendar.Clock; TS : String := Util.Calendar.IO.Image (Instant => Ada.Calendar.Seconds (Now), Precision => 3); begin -- TS has the format HH:MM:SS.FFF. Now strip out ':' and '.': TS (TS'First + 2 .. TS'First + 3) := TS (TS'First + 3 .. TS'First + 4); -- HHMM_:SS.FFF TS (TS'First + 4 .. TS'First + 5) := TS (TS'First + 6 .. TS'First + 7); -- HHMMSS__.FFF TS (TS'First + 6 .. TS'First + 8) := TS (TS'First + 9 .. TS'First + 11); -- HHMMSSFFF___ return Base & '_' & Util.Calendar.IO.Image (Date => Now, Separator => "") & '_' & TS (TS'First .. TS'First + 8) & '.' & Suffix; end Unique_Name; function Write_Text (Text : in String) return String is use Ada.Text_IO; File : File_Type; Name : String := Unique_Name ("ab", "ppp"); begin -- Create temp file for I in 1 .. Max_Open_Tries loop begin Create (File, Out_File, Name); exit; exception when others => if I < Max_Open_Tries then -- Create next name. Name := Unique_Name ("ab", "ppp"); end if; end; end loop; if not Is_Open (File) then return ""; end if; declare Start, I : Natural; begin Start := Text'First; while Start <= Text'Last loop I := First_Index (Text (Start .. Text'Last), ASCII.LF); if I = 0 then I := Text'Last + 1; end if; Put_Line (File, Text (Start .. I - 1)); Start := I + 1; end loop; end; Close (File); return Name; exception when others => if Is_Open (File) then Close (File); end if; return ""; end Write_Text; subtype Linefeed_Policy is Filter_Linefeeds range LF_Only .. CR_Only; function Write_Stream (Policy : in Linefeed_Policy; Text : in String) return String is use Ada.Streams.Stream_IO; File : File_Type; Name : String := Unique_Name ("ab", "ppp"); begin -- Create temp file for I in 1 .. Max_Open_Tries loop begin Create (File, Out_File, Name); exit; exception when others => if I < Max_Open_Tries then -- Create next name. Name := Unique_Name ("ab", "ppp"); end if; end; end loop; if not Is_Open (File) then return ""; end if; declare Start, I : Natural; S : constant Stream_Access := Stream (File); begin Start := Text'First; while Start <= Text'Last loop I := First_Index (Text (Start .. Text'Last), ASCII.LF); if I = 0 then I := Text'Last + 1; end if; String'Write (S, Text (Start .. I - 1)); case Policy is when LF_Only => Character'Write (S, ASCII.LF); when CR_And_LF => Character'Write (S, ASCII.CR); Character'Write (S, ASCII.LF); when CR_Only => Character'Write (S, ASCII.CR); end case; Start := I + 1; end loop; end; Close (File); return Name; exception when others => if Is_Open (File) then Close (File); end if; return ""; end Write_Stream; function Write_File (Self : access Filter_Execute; Text : in String) return String is begin if Self.Linefeed = Default_LF then return Write_Text (Text); else return Write_Stream (Self.Linefeed, Text); end if; end Write_File; Tmp_Name : constant String := Write_File (Self, UT.Internal.Get_Ptr (Text).all); begin if Tmp_Name'Last < Tmp_Name'First then Warn ("cannot run command: " & UT.Internal.Get_Ptr (Self.Cmd).all); return; end if; Text := UT.Null_Unbounded_String; -- Open in-pipe for 'Cmd' with stdin redirected to come from temp file declare use Util.Pipes; P : Pipe_Stream; Exit_Code : Integer; begin Open (P, UT.Internal.Get_Ptr (Self.Cmd).all, In_Stream, True, Tmp_Name); while not End_Of_Stream (P) loop begin declare Line : constant String := Get_Line (P); begin UT.Append (Text, Line & ASCII.LF); end; exception when End_Error => Warn ("Got exception:" & UT.Internal.Get_Ptr (Text).all); exit; end; end loop; Close (P, Exit_Code); if Exit_Code /= 0 then Warn ("command '" & UT.Internal.Get_Ptr (Self.Cmd).all & "' returned with exit code" & Integer'Image (Exit_Code)); end if; exception when E : others => Warn ("command '" & UT.Internal.Get_Ptr (Self.Cmd).all & "' failed!"); Warn (Ada.Exceptions.Exception_Information (E)); end; -- If an exception occurs, and the pipe is still open, the pipe -- is closed automatically. AD.File_Ops.Delete (Tmp_Name); end Transform; ---------------------------------------------------------------------------- -- Internal utility routines for scanning HTML. function Find_Comment_End (Source : in String) return Natural is Start : Natural := Source'First; I : Natural; begin -- According to the HTML 4.01 spec, there may be white space between -- the "--" and the ">"!! That definition seems broken to me, but if -- they define it that way, we'd better scan it that way, too... while Start + 2 <= Source'Last loop if Source (Start) = '-' and then Source (Start + 1) = '-' then I := Start + 2; -- Skip whitespace loop if Is_Blank (Source (I)) then I := I + 1; if I > Source'Last then return 0; end if; else exit; end if; end loop; if Source (I) = '>' then return I; else -- Non-white space, but not '>': the "--" was not the -- beginning of the comment end. (Is this correct?) Start := I; end if; else Start := Start + 1; end if; end loop; return 0; end Find_Comment_End; ---------------------------------------------------------------------------- -- Internal utility routines for parsing HTML. type Tag_Type_Kind is (Start_Tag, End_Tag, Comment); generic type Tag_Handling_State (<>) is limited private; with procedure Handle_Tag (Source : access String; Result : in out UT.Unbounded_String; Tag_Start, Tag_End : in Natural; Tag_Type : in Tag_Type_Kind; State : in out Tag_Handling_State); procedure Process_Tags (Text : in UT.Unbounded_String; Result : in out UT.Unbounded_String; State : in out Tag_Handling_State); -- 'Process_Tags' calls 'Handle_Tag' for any HTML mark-up tag it finds -- and replaces the tags by whatever 'Handle_Tag' puts into 'Result'. -- Note that HTML comments also are mark-up elements! -- -- Anything between tags reminas unchanged. -- -- 'Tag_Start' and 'Tag_End' are indices into 'Source'. If 'Tag_End' is -- greater than Length (Source), an unclosed tag was found. 'State' is just -- passed through to 'Handle_Tags'. generic type Tag_Handling_State (<>) is limited private; with procedure Handle_Tag (Source : access String; Result : in out UT.Unbounded_String; Tag_Start, Tag_End : in Natural; Tag_Type : in Tag_Type_Kind; State : in out Tag_Handling_State); with procedure Handle_Content (Source : in String; Result : in out UT.Unbounded_String; State : in out Tag_Handling_State); procedure Process_Content (Text : in UT.Unbounded_String; Result : in out UT.Unbounded_String; State : in out Tag_Handling_State); -- As 'Process_Tags', but additionally calls 'Handle_Content' for any -- content stretch 'Source (From .. To)'. procedure Process_Content (Text : in UT.Unbounded_String; Result : in out UT.Unbounded_String; State : in out Tag_Handling_State) is S : constant UT.String_Access := UT.Internal.Get_Ptr (Text); Tag_Type : Tag_Type_Kind; Start, I : Natural; begin Start := S'First; while Start <= S'Last loop I := Start; -- Scan ahead to the next '<' that is the start of either a -- tag or an HTML comment: while I <= S'Last loop if I < S'Last and then S (I) = '<' then if Is_In (Letters, S (I + 1)) then Tag_Type := Start_Tag; exit; elsif S (I + 1) = '/' and then I + 1 < S'Last and then Is_In (Letters, S (I + 2)) then Tag_Type := End_Tag; exit; elsif I + 3 <= S'Last and then S (I + 1 .. I + 3) = "!--" then Tag_Type := Comment; exit; end if; -- Not a tag start after all. end if; I := I + 1; end loop; Handle_Content (S (Start .. I - 1), Result, State); exit when I > S'Last; Start := I; case Tag_Type is when Comment => -- Scan ahead to the comment end. I := Find_Comment_End (S (I + 4 .. S'Last)); when Start_Tag => -- Scan ahead to the next '>' not within a string I := AD.HTML.Find_Tag_End (S (Start .. S'Last)); when End_Tag => -- Scan ahead to the next '>': I := First_Index (S (Start .. S'Last), '>'); end case; -- 'Start' is now on the opening '<', and 'I' is on the closing '>', -- or, if no closing '>' exists, 'I' is zero. if I = 0 then I := S'Last; end if; Handle_Tag (S, Result, Start, I, Tag_Type, State); Start := I + 1; end loop; end Process_Content; procedure Process_Tags (Text : in UT.Unbounded_String; Result : in out UT.Unbounded_String; State : in out Tag_Handling_State) is procedure Content (Source : in String; Result : in out UT.Unbounded_String; State : in out Tag_Handling_State) is pragma Warnings (Off, State); -- Silence -gnatwa begin -- Pass on content unchanged. if Source'Last >= Source'First then UT.Append (Result, Source); end if; end Content; procedure Process is new Process_Content (Tag_Handling_State, Handle_Tag, Content); begin -- Process_Tags Process (Text, Result, State); end Process_Tags; function Get_Tag_Key (Source : in String; Tag_Type : in Tag_Type_Kind) return String is I : Natural := Source'First + 1; J : Natural; begin if Tag_Type = End_Tag then I := I + 1; end if; J := Util.Strings.Identifier (Source (I .. Source'Last)); return Source (I .. J); end Get_Tag_Key; ---------------------------------------------------------------------------- -- Tag-modifying filters type Param_Expander (Values : access String) is new Util.Environment.Bash.Bash_Expander with null record; function Legal_Name (Self : access Param_Expander; Source : in String) return Natural; function Get (Self : access Param_Expander; Name : in String) return String; function Recurse (Self : access Param_Expander; Name : in String) return String; function Indirection (Self : access Param_Expander; Name : in String) return String; function Legal_Name (Self : access Param_Expander; Source : in String) return Natural is begin if Source'Last >= Source'First and then Source (Source'First) = '%' then return Source'First; end if; -- Super call: return Util.Environment.Bash.Legal_Name (Util.Environment.Bash.Bash_Expander (Self.all)'Access, Source); end Legal_Name; function Get (Self : access Param_Expander; Name : in String) return String is -- Of course, parsing the parameter string each and every time is not -- exactly hyper-efficient, but I guess that this whole parameter -- expansion feature will be used mostly for one or two parameters -- only, and thus the cost of building e.g. a hash table with names -- and values would not be amortized. Hence I consider this simple -- approach adequate. function Find (Source : in String; Pattern : in String) return Natural is In_String : Boolean := False; Start, J : Natural; Delim : Character := ' '; Length : constant Natural := Pattern'Length; begin if Length > Source'Length then return 0; end if; for I in 1 .. Source'Length - Length + 1 loop -- Skip strings, too; otherwise we might get confused on a -- parameter value like "Param="Other=" Other=512". Start := Source'First + I - 1; if In_String then In_String := Source (Start) /= Delim; else if Source (Start) = '"' or else Source (Start) = ''' then In_String := True; Delim := Source (Start); else J := Start; for K in Pattern'Range loop exit when To_Lower (Source (J)) /= To_Lower (Pattern (K)); J := J + 1; end loop; if J = Start + Length then return Start; end if; end if; end if; end loop; return 0; end Find; I, J : Natural; Length : constant Natural := Name'Length; begin if Length = 1 and then Name (Name'First) = '%' then return Self.Values.all; end if; J := Self.Values'First; loop I := Find (Self.Values (J .. Self.Values'Last), Name); if I = 0 then return ""; end if; if I + Length > Self.Values'Last or else Self.Values (I + Length) = '=' or else Self.Values (I + Length) = ' ' then exit; end if; -- It was a prefix only... J := I + Length; end loop; if I + Length <= Self.Values'Last and then Self.Values (I + Length) = '=' then I := I + Length + 1; if I <= Self.Values'Last and then (Self.Values (I) = '"' or else Self.Values (I) = ''') then J := First_Index (Self.Values (I + 1 .. Self.Values'Last), Self.Values (I)); I := I + 1; else J := First_Index (Self.Values (I .. Self.Values'Last), ' '); end if; if J = 0 then -- Hmmm... no second quote (or no white space) found. return Self.Values (I .. Self.Values'Last); end if; return Self.Values (I .. J - 1); else -- A boolean attribute... what shall be it's value? We somehow -- need to distinguish the case from ! -- Since Self.Values cannot contain linefeeds, we use this and -- return a string of length 1 conatining a linefeed: return (1 => ASCII.LF); end if; end Get; function Recurse (Self : access Param_Expander; Name : in String) return String is pragma Warnings (Off, Self); -- silence -gnatwa pragma Warnings (Off, Name); -- silence -gnatwa begin -- We do not allow recursion. return ""; end Recurse; function Indirection (Self : access Param_Expander; Name : in String) return String is -- Yes, I'm being sloppy and do not redispatch here. It isn't necessary -- because I *know* that there is no further derivation of this type. begin if Name'Last < Name'First or else Name = "%" or else Legal_Name (Self, Name) /= Name'Last then return ""; end if; -- Redefine ${!Name} as Name="Value" if set. declare Val : constant String := Get (Self, Name); I : Natural; Length : constant Natural := Val'Length; begin if Length = 0 then return ""; end if; if Length = 1 and then Val (Val'First) = ASCII.LF then -- Oops: a boolean attribute in minimized form. We'd better -- just return the name! (Some browsers only recognize the -- minimized form , but not the full form -- . Hence we'd better make sure that if an -- attribute is in minimized form, this expansion also returns -- the minimized form. return Name; else I := First_Index (Val, '"'); if I > 0 then return Name & "='" & Val & '''; else return Name & "=""" & Val & '"'; end if; end if; end; end Indirection; procedure Transform (Self : access Filter_Expand; Text : in out Util.Text.Unbounded_String) is pragma Warnings (Off, Self); -- silence -gnatwa -- We maintain a stack of all open container tags so that we can -- properly restore the enabled state. type Stack_Entry; type Stack_Ptr is access Stack_Entry; type Stack_Entry is record Next : Stack_Ptr; Tag : User_Tag_Ptr; Enabled : Boolean; end record; procedure Free is new Ada.Unchecked_Deallocation (Stack_Entry, Stack_Ptr); type Expansion_Stack is record TOS : Stack_Ptr; Enabled : Boolean := True; end record; procedure Push (S : in out Expansion_Stack; Tag : in User_Tag_Ptr) is begin -- The first disabled container tag disables everything from then on. S.Enabled := S.Enabled and then Tag.Enabled; S.TOS := new Stack_Entry'(S.TOS, Tag, S.Enabled); end Push; procedure Pop (S : in out Expansion_Stack; Tag : in User_Tag_Ptr) is P : Stack_Ptr := S.TOS; begin while P /= null and then P.Tag /= Tag loop P := P.Next; end loop; if P = null then -- What now? we have an end tag of a container that has never been -- opened! Probably the safest is not to pop... return; end if; while S.TOS /= P loop declare Q : Stack_Ptr := S.TOS; begin -- Expand the intermediary open containers' missing closing -- tags? That might again change the stack! For simplicity, -- we just ignore them! S.TOS := Q.Next; Free (Q); end; end loop; -- S.TOS = P: now pop that one, too. S.TOS := P.Next; Free (P); S.Enabled := S.TOS = null or else S.TOS.Enabled; -- If we popped to (or even beyond) the first disabled tag, we'll -- re-enable ourselves here. end Pop; procedure Clear (S : in out Expansion_Stack) is begin while S.TOS /= null loop declare P : Stack_Ptr := S.TOS; begin S.TOS := P.Next; Free (P); end; end loop; end Clear; procedure Expand_Tag (Source : access String; Result : in out UT.Unbounded_String; Tag_Start, Tag_End : in Natural; Tag_Type : in Tag_Type_Kind; State : in out Expansion_Stack); procedure Copy_Content (Source : in String; Result : in out UT.Unbounded_String; State : in out Expansion_Stack) is begin if State.Enabled then UT.Append (Result, Source); end if; end Copy_Content; procedure Expand_Tags is new Process_Content (Expansion_Stack, Expand_Tag, Copy_Content); procedure Expand_Tag (Source : access String; Result : in out UT.Unbounded_String; Tag_Start, Tag_End : in Natural; Tag_Type : in Tag_Type_Kind; State : in out Expansion_Stack) is procedure Replace_User_Tag (State : in out Expansion_Stack; The_Tag : in User_Tag_Ptr; Params : access String; From, To : in Natural; Result : in out UT.Unbounded_String) is procedure Include_Tag (File_Name : in String; Result : in out UT.Unbounded_String) is -- Called only when we're enabled. F : Ada.Text_IO.File_Type; Buf : String (1 .. 300); Last : Natural; begin -- Include_Tag if File_Name'Last < File_Name'First then return; end if; Ada.Text_IO.Open (F, Ada.Text_IO.In_File, File_Name); while not Ada.Text_IO.End_Of_File (F) loop Ada.Text_IO.Get_Line (F, Buf, Last); if Last < Buf'Last or else Ada.Text_IO.End_Of_File (F) then UT.Append (Result, Buf (1 .. Last) & ASCII.LF); else UT.Append (Result, Buf); end if; end loop; Ada.Text_IO.Close (F); exception when Ada.Text_IO.Name_Error => Warn ("Cannot open file """ & File_Name & '"'); when others => if Ada.Text_IO.Is_Open (F) then Ada.Text_IO.Close (F); end if; Warn ("Error reading file """ & File_Name & '"'); end Include_Tag; procedure Execute_Tag (The_Tag : in User_Tag_Ptr; Command : in String; One_Line : in Boolean; Result : in out UT.Unbounded_String) is -- Called only when we're enabled. begin -- Execute_Tag if Command'Last < Command'First then return; end if; AD.Parameters.Save_Input; declare S : Util.Pipes.Pipe_Stream; Buf : String (1 .. 1000); Last : Natural; Exit_Code : Integer; begin Util.Pipes.Open (S, Command, Util.Pipes.In_Stream); if One_Line then begin Util.Pipes.Get_Line (S, Buf, Last); exception when Util.Pipes.End_Error => Last := 0; end; The_Tag.Kind := Normal; UT.Set (The_Tag.Start, Buf (1 .. Last)); else while not Util.Pipes.End_Of_Stream (S) loop Util.Pipes.Get_Line (S, Buf, Last); if Last < Buf'Last or else Util.Pipes.End_Of_Stream (S) then UT.Append (Result, Buf (1 .. Last) & ASCII.LF); else UT.Append (Result, Buf); end if; end loop; end if; Util.Pipes.Close (S, Exit_Code); if Exit_Code /= 0 then Warn ("Called program """ & Command & """ returned exit code" & Integer'Image (Exit_Code)); end if; exception when Util.Pipes.Name_Error => Warn ("Cannot execute """ & Command & '"'); if One_Line then The_Tag.Kind := Normal; The_Tag.Start := UT.Null_Unbounded_String; end if; when others => Warn ("Error running """ & Command & '"'); if One_Line then The_Tag.Kind := Normal; The_Tag.Start := UT.Null_Unbounded_String; end if; end; end Execute_Tag; procedure Expand_Parameters (Source : in String; Params : in String; Result : out UT.Unbounded_String) is Attributes : aliased String := AD.HTML.Attributes (Params); Expander : aliased Param_Expander (Attributes'Access); begin -- Expand_Parameters Set_Reference_Character (Expander'Access, '%'); UT.Set (Result, Expand (Expander'Access, Source)); end Expand_Parameters; begin -- Replace_User_Tag if The_Tag.Enabled and then State.Enabled then -- Otherwise we're either already disabled, or this tag -- itself is disabled and hence we needn't do anything. declare Definition : UT.Unbounded_String; Substitute : UT.String_Access := UT.Internal.Get_Ptr (The_Tag.Start); use type UT.String_Access; begin if From <= To and then Next_Non_Blank (Params (From .. To)) >= From then -- Only do something if there are parameters! Expand_Parameters (Substitute.all, Params (From .. To), Definition); Substitute := UT.Internal.Get_Ptr (Definition); end if; case The_Tag.Kind is when Execute => Execute_Tag (The_Tag, Substitute.all, False, Result); when Include => Include_Tag (Substitute.all, Result); when others => if The_Tag.Kind = Initialize then Execute_Tag (The_Tag, Substitute.all, True, Result); Substitute := UT.Internal.Get_Ptr (The_Tag.Start); end if; if The_Tag.Kind = Container then Push (State, The_Tag); end if; if Substitute'Last >= Substitute'First then if Substitute = UT.Internal.Get_Ptr (The_Tag.Start) then Expand_Tags (The_Tag.Start, Result, State); else Expand_Tags (Definition, Result, State); end if; end if; end case; end; else -- Disabled... if The_Tag.Kind = Container then -- No need to do anything for disabled non-container tags. Push (State, The_Tag); -- If we weren't already disabled, we're now. end if; end if; end Replace_User_Tag; procedure Close_User_Tag (State : in out Expansion_Stack; The_Tag : in User_Tag_Ptr; Result : in out UT.Unbounded_String) is -- Called only for closing tags of containers. Old_TOS : constant Stack_Ptr := State.TOS; begin -- Close_User_Tag Pop (State, The_Tag); -- We may be re-enabled now. We still need to also check the tag's -- own enabled flag, for even if the state is now enabled again, -- we mustn't expand the closing tag if the tag itself is not -- enabled (and it therefore was the tag that caused overall -- disabling in the first place). -- Also note that we don't expand (and hence swallow the tag) -- if we didn't pop: if TOS is still the same, we had a stray end -- tag without corresponding opening tag. We ignore those. if State.TOS /= Old_TOS and then The_Tag.Enabled and then State.Enabled and then UT.Length (The_Tag.Final) > 0 then Expand_Tags (The_Tag.Final, Result, State); end if; end Close_User_Tag; begin -- Expand_Tag if Tag_Type = Comment then if State.Enabled then UT.Append (Result, Source (Tag_Start .. Tag_End)); end if; return; end if; -- 'Tag_Start' is on the '<', and 'Tag_End' on the closing '>' -- We ignore the case where 'Tag_End' > Length (Source); we just -- handle unclosed tags as if they were closed... -- First extract the tag name. declare Tag_Key : constant String := Get_Tag_Key (Source (Tag_Start .. Tag_End), Tag_Type); The_Tag : constant Tag_Ptr := Find_Tag (Tag_Key); begin if The_Tag = null then -- Unknown tag. if State.Enabled then UT.Append (Result, Source (Tag_Start .. Tag_End)); end if; return; end if; if The_Tag.all in Standard_Tag'Class then -- Standard tag: no expansion needed. if State.Enabled then UT.Append (Result, Source (Tag_Start .. Tag_End)); end if; return; end if; declare P : constant User_Tag_Ptr := User_Tag_Ptr (The_Tag); begin if P.In_Expansion then -- Error!! Ada.Exceptions.Raise_Exception (Recursive_Expansion'Identity, "recursive replacement of user-defined tag '" & The_Tag.Name & '''); end if; P.In_Expansion := True; if Tag_Type = Start_Tag then Replace_User_Tag (State, P, Source, Tag_Start + Tag_Key'Length + 1, Tag_End - 1, Result); else -- Ignore end tags for non-containers. if P.Kind /= Container then return; end if; Close_User_Tag (State, P, Result); end if; P.In_Expansion := False; end; end; end Expand_Tag; State : Expansion_Stack; Result : UT.Unbounded_String; begin -- Transform (Filter_Expand) Expand_Tags (Text, Result, State); Text := Result; Clear (State); end Transform; ---------------------------------------------------------------------------- procedure Transform (Self : access Filter_Unknown; Text : in out Util.Text.Unbounded_String) is procedure Handle_Unknown_Tag (Source : access String; Result : in out UT.Unbounded_String; Tag_Start, Tag_End : in Natural; Tag_Type : in Tag_Type_Kind; Standard_Tags_Only : in out Boolean) is begin if Tag_Type = Comment then UT.Append (Result, Source (Tag_Start .. Tag_End)); else declare Tag_Key : constant String := Get_Tag_Key (Source (Tag_Start .. Tag_End), Tag_Type); The_Tag : constant Tag_Ptr := Find_Tag (Tag_Key); begin if Source (Tag_End) /= '>' or else The_Tag = null or else (Standard_Tags_Only and then The_Tag.all not in Standard_Tag'Class) then -- An unknown or unclosed tag. UT.Append (Result, AD.HTML.HTMLize (Source (Tag_Start .. Tag_End))); else UT.Append (Result, Source (Tag_Start .. Tag_End)); end if; end; end if; end Handle_Unknown_Tag; procedure Replace_Unknown_Tags is new Process_Tags (Boolean, Handle_Unknown_Tag); Result : UT.Unbounded_String; Dummy : Boolean := Self.Std_Only; begin Replace_Unknown_Tags (Text, Result, Dummy); Text := Result; end Transform; ---------------------------------------------------------------------------- procedure Transform (Self : access Filter_Strip; Text : in out Util.Text.Unbounded_String) is pragma Warnings (Off, Self); -- silence -gnatwa Dummy : GAL.Support.Null_Type; procedure Suppress_Comment (Source : access String; Result : in out UT.Unbounded_String; Tag_Start, Tag_End : in Natural; Tag_Type : in Tag_Type_Kind; State : in out GAL.Support.Null_Type) is -- Shall we do the full HTML parse and *not* remove HTML comments -- within