File : gnatkr.adb
1 ------------------------------------------------------------------------------
2 -- --
3 -- GNAT COMPILER COMPONENTS --
4 -- --
5 -- G N A T K R --
6 -- --
7 -- B o d y --
8 -- --
9 -- Copyright (C) 1992-2013, Free Software Foundation, Inc. --
10 -- --
11 -- GNAT is free software; you can redistribute it and/or modify it under --
12 -- terms of the GNU General Public License as published by the Free Soft- --
13 -- ware Foundation; either version 3, or (at your option) any later ver- --
14 -- sion. GNAT is distributed in the hope that it will be useful, but WITH- --
15 -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY --
16 -- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License --
17 -- for more details. You should have received a copy of the GNU General --
18 -- Public License distributed with GNAT; see file COPYING3. If not, go to --
19 -- http://www.gnu.org/licenses for a complete copy of the license. --
20 -- --
21 -- GNAT was originally developed by the GNAT team at New York University. --
22 -- Extensive contributions were provided by Ada Core Technologies Inc. --
23 -- --
24 ------------------------------------------------------------------------------
25
26 with Gnatvsn;
27 with Krunch;
28 with Switch; use Switch;
29
30 with Ada.Characters.Handling; use Ada.Characters.Handling;
31 with Ada.Command_Line; use Ada.Command_Line;
32
33 with System.IO; use System.IO;
34
35 procedure Gnatkr is
36 pragma Ident (Gnatvsn.Gnat_Static_Version_String);
37
38 Count : Natural;
39 Maxlen : Integer;
40 Exit_Program : exception;
41
42 function Get_Maximum_File_Name_Length return Integer;
43 pragma Import (C, Get_Maximum_File_Name_Length,
44 "__gnat_get_maximum_file_name_length");
45
46 procedure Usage;
47 -- Output usage information
48
49 -----------
50 -- Usage --
51 -----------
52
53 procedure Usage is
54 begin
55 Put_Line ("Usage: gnatkr filename[.extension] [krunch-count]");
56 end Usage;
57
58 procedure Check_Version_And_Help is new Check_Version_And_Help_G (Usage);
59
60 begin
61 Check_Version_And_Help ("GNATKR", "1992");
62 Count := Argument_Count;
63
64 if Count < 1 or else Count > 2 then
65 Usage;
66 raise Exit_Program;
67
68 else
69 -- If the length (krunch-count) argument is omitted use the system
70 -- default if there is one, otherwise use 8.
71
72 if Count = 1 then
73 Maxlen := Get_Maximum_File_Name_Length;
74
75 if Maxlen = -1 then
76 Maxlen := 8;
77 end if;
78
79 else
80 Maxlen := 0;
81
82 for J in Argument (2)'Range loop
83 if Argument (2) (J) /= ' ' then
84 if Argument (2) (J) not in '0' .. '9' then
85 Put_Line ("Illegal argument for krunch-count");
86 raise Exit_Program;
87 else
88 Maxlen := Maxlen * 10 +
89 Character'Pos (Argument (2) (J)) - Character'Pos ('0');
90 end if;
91 end if;
92 end loop;
93
94 -- Zero means crunch only system files
95
96 if Maxlen = 0 then
97 Maxlen := Natural'Last;
98 end if;
99
100 end if;
101
102 declare
103 Fname : String := Argument (1);
104 Klen : Natural := Fname'Length;
105
106 Extp : Boolean := False;
107 -- True if extension is present
108
109 Ext : Natural := 0;
110 -- If extension is present, points to it (init to prevent warning)
111
112 begin
113 -- Remove extension if present (an extension is defined as the
114 -- section of the file name after the last dot in the name. If
115 -- there is no dot in the name, then
116 -- name is all lower case and contains no other instances of dots)
117
118 for J in reverse 1 .. Klen loop
119 if Fname (J) = '.' then
120 Extp := True;
121 Ext := J;
122 Klen := J - 1;
123 exit;
124 end if;
125 end loop;
126
127 -- Fold to lower case and replace dots by dashes
128
129 for J in 1 .. Klen loop
130 Fname (J) := To_Lower (Fname (J));
131
132 if Fname (J) = '.' then
133 Fname (J) := '-';
134 end if;
135 end loop;
136
137 Krunch (Fname, Klen, Maxlen, False);
138
139 Put (Fname (1 .. Klen));
140
141 if Extp then
142 Put (Fname (Ext .. Fname'Length));
143 end if;
144
145 New_Line;
146 end;
147 end if;
148
149 Set_Exit_Status (Success);
150
151 exception
152 when Exit_Program =>
153 Set_Exit_Status (Failure);
154
155 end Gnatkr;