Mercurial > hg > CbC > CbC_gcc
comparison gcc/ada/libgnat/s-strops.adb @ 111:04ced10e8804
gcc 7
author | kono |
---|---|
date | Fri, 27 Oct 2017 22:46:09 +0900 |
parents | |
children | 84e7813d76e9 |
comparison
equal
deleted
inserted
replaced
68:561a7518be6b | 111:04ced10e8804 |
---|---|
1 ------------------------------------------------------------------------------ | |
2 -- -- | |
3 -- GNAT RUN-TIME LIBRARY (GNARL) COMPONENTS -- | |
4 -- -- | |
5 -- S Y S T E M . S T R I N G _ O P S -- | |
6 -- -- | |
7 -- B o d y -- | |
8 -- -- | |
9 -- Copyright (C) 1992-2017, 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. -- | |
17 -- -- | |
18 -- As a special exception under Section 7 of GPL version 3, you are granted -- | |
19 -- additional permissions described in the GCC Runtime Library Exception, -- | |
20 -- version 3.1, as published by the Free Software Foundation. -- | |
21 -- -- | |
22 -- You should have received a copy of the GNU General Public License and -- | |
23 -- a copy of the GCC Runtime Library Exception along with this program; -- | |
24 -- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- | |
25 -- <http://www.gnu.org/licenses/>. -- | |
26 -- -- | |
27 -- GNAT was originally developed by the GNAT team at New York University. -- | |
28 -- Extensive contributions were provided by Ada Core Technologies Inc. -- | |
29 -- -- | |
30 ------------------------------------------------------------------------------ | |
31 | |
32 -- NOTE: This package is obsolescent. It is no longer used by the compiler | |
33 -- which now generates concatenation inline. It is retained only because | |
34 -- it may be used during bootstrapping using old versions of the compiler. | |
35 | |
36 pragma Compiler_Unit_Warning; | |
37 | |
38 package body System.String_Ops is | |
39 | |
40 ---------------- | |
41 -- Str_Concat -- | |
42 ---------------- | |
43 | |
44 function Str_Concat (X, Y : String) return String is | |
45 begin | |
46 if X'Length = 0 then | |
47 return Y; | |
48 | |
49 else | |
50 declare | |
51 L : constant Natural := X'Length + Y'Length; | |
52 R : String (X'First .. X'First + L - 1); | |
53 | |
54 begin | |
55 R (X'Range) := X; | |
56 R (X'First + X'Length .. R'Last) := Y; | |
57 return R; | |
58 end; | |
59 end if; | |
60 end Str_Concat; | |
61 | |
62 ------------------- | |
63 -- Str_Concat_CC -- | |
64 ------------------- | |
65 | |
66 function Str_Concat_CC (X, Y : Character) return String is | |
67 R : String (1 .. 2); | |
68 | |
69 begin | |
70 R (1) := X; | |
71 R (2) := Y; | |
72 return R; | |
73 end Str_Concat_CC; | |
74 | |
75 ------------------- | |
76 -- Str_Concat_CS -- | |
77 ------------------- | |
78 | |
79 function Str_Concat_CS (X : Character; Y : String) return String is | |
80 R : String (1 .. Y'Length + 1); | |
81 | |
82 begin | |
83 R (1) := X; | |
84 R (2 .. R'Last) := Y; | |
85 return R; | |
86 end Str_Concat_CS; | |
87 | |
88 ------------------- | |
89 -- Str_Concat_SC -- | |
90 ------------------- | |
91 | |
92 function Str_Concat_SC (X : String; Y : Character) return String is | |
93 begin | |
94 if X'Length = 0 then | |
95 return (1 => Y); | |
96 | |
97 else | |
98 declare | |
99 R : String (X'First .. X'Last + 1); | |
100 | |
101 begin | |
102 R (X'Range) := X; | |
103 R (R'Last) := Y; | |
104 return R; | |
105 end; | |
106 end if; | |
107 end Str_Concat_SC; | |
108 | |
109 end System.String_Ops; |