------- Comment #1 from baldrick at gcc dot gnu dot org 2007-02-21 15:17
-------
I've tried and failed to attach the source code (bugzilla problem), so here it
is inline (you can extract it using gnatchop):
with Join_Equal;
with JS;
procedure J is new Join_Equal (
Source_Type => JS.S,
Equal => JS.E,
Target_Type => JS.T,
Move => JS.M
);
package JS is
type S is range 0 .. 100;
type T is range 10 .. 20;
function E (L, R : S) return Boolean;
procedure M (
First, Last : S;
Destination : T
);
end JS;
generic
type Source_Type is (<>);
with function Equal (Left, Right : Source_Type) return Boolean;
type Target_Type is (<>);
with procedure Move (
First, Last : Source_Type;
Destination : Target_Type
);
procedure Join_Equal (
Source_First : in Source_Type;
Source_Last : in out Source_Type; -- returns last read
Target_First : in Target_Type;
Target_Last : out Target_Type -- returns last written
);
pragma Pure (Join_Equal);
procedure Join_Equal (
Source_First : in Source_Type;
Source_Last : in out Source_Type;
Target_First : in Target_Type;
Target_Last : out Target_Type
) is
Source : Source_Type := Source_First;
Target : Target_Type := Target_First;
begin
if Source_Last < Source_First then
if Target_First = Target_Type'First then
raise Constraint_Error;
end if;
Target_Last := Target_Type'Pred (Target_First);
return;
end if;
loop
declare
Start : constant Source_Type := Source;
Prev : Source_Type := Source;
begin
loop
if Source = Source_Last then
Move (Start, Source, Target);
Target_Last := Target;
return;
end if;
Source := Source_Type'Succ (Source);
exit when not Equal (Prev, Source);
Prev := Source;
end loop;
Move (Start, Prev, Target);
if Target = Target_Type'Last then
Source_Last := Prev;
Target_Last := Target;
return;
end if;
Target := Target_Type'Succ (Target);
end;
end loop;
end Join_Equal;
--
http://gcc.gnu.org/bugzilla/show_bug.cgi?id=30911
