|
111
|
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;
|
