Please find a program that compiles ans links with GNAT but crashes when run
the qsort routine gave me loyal service for the last 10 years on various applications
I am sure i am making an obvious mistake, but when it is your own code you just can't see it
Many thanks
With Ada.Strings.Unbounded;
With Ada.Text_Io;
with qsort;
Use Type Ada.Strings.Unbounded.Unbounded_String;
Procedure tsort is
Type Line_Array_Type Is Array (integer Range <>)
Of Ada.Strings.Unbounded.Unbounded_String;
Line_Array : Line_Array_Type(1 .. 20)
:= (Others => Ada.Strings.Unbounded.Null_Unbounded_String);
procedure Sort is new Qsort
(Elem => Ada.Strings.Unbounded.Unbounded_String,
Elem_Vector => Codegraphlib.Line_Array_type);
begin
line_Array(1) :=Ada.Strings.Unbounded.To_Unbounded_String(" Package Iio Is New Ada.Text_Io.Integer_Io(Integer);");
line_Array(2) :=Ada.Strings.Unbounded.To_Unbounded_String(" package body Parse_Tools is");
line_Array(3) :=Ada.Strings.Unbounded.To_Unbounded_String(" package Parse_Tools is");
line_Array(4) :=Ada.Strings.Unbounded.To_Unbounded_String(" procedure Erase_Part_Of_Screeen (Tab : in Integer := 0) is");
line_Array(5) :=Ada.Strings.Unbounded.To_Unbounded_String(" proc := 1;");
line_Array(6) :=Ada.Strings.Unbounded.To_Unbounded_String(" procedure Erase_Part_Of_Screeen (Tab : in Integer := 0);");
line_Array(7) :=Ada.Strings.Unbounded.To_Unbounded_String(" procedure Put_Screen_Background is");
line_Array(8) :=Ada.Strings.Unbounded.To_Unbounded_String(" procedure Get_Main_Command;");
line_Array(9) :=Ada.Strings.Unbounded.To_Unbounded_String(" procedure Get_Main_Command is new abcd (Command : in out CodeGraphLib.Command_Record_Type );");
line_Array(10):=Ada.Strings.Unbounded.To_Unbounded_String(" function Erase_Part_Of_Screeen (Tab : in Integer := 0) return sss is");
line_Array(11):=Ada.Strings.Unbounded.To_Unbounded_String(" function Erase_Part_Of_Screeen (Tab : in Integer := 0);");
line_Array(12):=Ada.Strings.Unbounded.To_Unbounded_String(" funk := 1;");
line_Array(13):=Ada.Strings.Unbounded.To_Unbounded_String(" function Put_Screen_Background return aaa is");
line_Array(14):=Ada.Strings.Unbounded.To_Unbounded_String(" function Get_Main_Command return zzz;");
line_Array(15):=Ada.Strings.Unbounded.To_Unbounded_String(" function Get_Main_Command is new abcd (Command : in out CodeGraphLib.Command_Record_Type );");
sort (line_array,15);
End tsort;
------------------------------------------------------------------------------
------------------------------------------------------------------------------
--
-- D.GAUDRY AUGUST 1988
--
--
-- Q S O R T . L I B
--
------------------------------------------------------------------------------
--VERY FAST SORTING ROUTINE ADAPTED FROM THE
--TQSORT.PKG PROVIDED WITH THE COMPILER
---------------------------------------------------------------
-- GENERIC SORTING ROUTINE FOR ANY TYPE OF VARIABLE
---------------------------------------------------------------
-- EXAMPLES OF INSTANTIATION:
-- -=-==-=-=-=-=-=-=-=-=-=-=-
--
-- INSTANTIATION OF FOR LONG_FLOAT SORT
--
--PROCEDURE FSORT IS NEW QSORT ( ELEM=>LONG_FLOAT ,
-- ELEM_VECTOR=>FLOAT_ARRAY_TYPE ) ;
--
-- INSTANTIATION FOR integer SORT
-- with integer index
--
--PROCEDURE ISORT IS NEW QSORT(ELEM=>INTEGER,
-- ELEM_VECTOR=>INTEGER_ARRAY_TYPE);
--
generic
type ELEM is private;
type ELEM_VECTOR is array (INTEGER range <>) of ELEM;
with function ">"
(X : ELEM;
Y : ELEM)
return BOOLEAN is <>;
with function "<"
(
X : ELEM;
Y : ELEM)
return BOOLEAN is <>;
------------------------------------------------------------------------------
procedure QSORT
(X : in out ELEM_VECTOR;
N_DATA : in INTEGER);
-------------------------------------------------------------------------------
-- UNIT_NAME | QSORT.PKG
-- CSCI_NAME
-- UNIT_DESCRIPTION
--
-- UNIT_SPS_REFERENCE
-- UNIT_CALLING_SEQUENCE
-- EXTERNAL_UNITS_CALLED
-- INPUTS
-- OUTPUTS
-- CREATED | 30 OCTOBER 1989
-- AUTHOR | DANIEL
--
-- DATE ------------ AUTHOR -------- REVISION # -- PR # -----TITLE ------------
-------------------------------------------------------------------------------
---------------------------------------------------------------
-- GENERIC SORTING ROUTINE FOR ANY TYPE OF VARIABLE
---------------------------------------------------------------
-- EXAMPLES OF INSTANTIATION:
-- -=-==-=-=-=-=-=-=-=-=-=-=-
--
-- INSTANTIATION OF FOR LONG_FLOAT SORT
--
--PROCEDURE FSORT IS NEW QSORT ( ELEM=>LONG_FLOAT ,
-- ELEM_VECTOR=>FLOAT_ARRAY_TYPE ) ;
--
-- INSTANTIATION FOR integer SORT
-- with integer index
--
--PROCEDURE ISORT IS NEW QSORT(ELEM=>INTEGER,
-- ELEM_VECTOR=>INTEGEr_ARRAY_TYPE);
--
procedure Qsort
(X : in out Elem_Vector;
N_Data : in Integer) is
Too_Big : exception;
Zero : constant := 0;
Numrecs : constant := 1000;
type Drecord is array (Zero .. Numrecs) of Elem;
Datrec : Drecord;
Total : Integer; -- total number of records
---------------------------
---------------------------
---------------------------
procedure Getrecs
(Filrec : in out Drecord;
Sum : in out Integer;
X : in Elem_Vector) is
begin
for I in 1 .. N_Data loop
Filrec(I) := X(I);
end loop;
Sum := N_Data;
end Getrecs;
---------------------------
---------------------------
---------------------------
procedure Fileout(
Outfil : in Drecord;
Send : in Integer;
X : out Elem_Vector) is
Tot : Integer;
begin
Tot := Zero;
while Tot /= Send loop
Tot := Tot + 1;
X(Tot) := Outfil(Tot);
end loop;
end Fileout; -- fileout
---------------------------
---------------------------
---------------------------
procedure Quicksort
(List : in out Drecord;
Numb : in Integer) is
Maxsub : constant := 21;
-- smallest subfile allowed in qsort
Stackdep : constant := 1000; -- stack size
type Indices is
record -- records of partions for stack
Beginning,
Ending : Integer;
end record;
Stk : Integer;
I : Integer;
J : Integer;
Left : Integer;
Righ : Integer;
T1rec : Elem; -- temp records
T2rec : Elem; -- temp records
subtype Stackptr is Integer range 1 .. Stackdep;
type Temparr is array (Stackptr) of Indices;
Stack : Temparr;
---------------------------
---------------------------
---------------------------
function Median
(Listnam : in Drecord;
Lef : in Integer;
Rit : in Integer)
return Integer is
Med : Integer;
begin
Med := (Lef + Rit) / 2;
if (Listnam(Rit) > Listnam(Med)) then
if Listnam(Med) > Listnam(Lef) then
return (Med);
elsif (Listnam(Rit) > Listnam(Lef)) then
return (Lef);
else
return (Rit);
end if;
elsif Listnam(Med) < Listnam(Lef) then
return (Med);
elsif Listnam(Rit) < Listnam(Lef) then
return (Lef);
else
return (Rit);
end if;
end Median;
---------------------------
---------------------------
---------------------------
procedure Stinsertsort
(Newrec : in out Drecord;
M : Integer;
N : Integer) is
-- 'm' has starting position,'n' has ending position
-- straight insertion for number of records < 21 is
-- more efficent
Lft : Integer; -- left sorting stop
Savrec, Xrec : Elem; -- temporary records
begin
Savrec := Newrec(M - 1); -- save the record before the sorting area
for Rgt in (M + 1) .. N loop -- Right sorting stop
Xrec := Newrec(Rgt);
Newrec(M - 1) := Xrec;
Lft := Rgt - 1;
while Xrec < Newrec(Lft) loop -- switch records
Newrec(Lft + 1) := Newrec(Lft);
Lft := Lft - 1;
end loop;
Newrec(Lft + 1) := Xrec;
end loop;
Newrec(M - 1) := Savrec; -- restore that saved record
end Stinsertsort;
---------------------------
---------------------------
---------------------------
begin
if Numb < Maxsub then
Stinsertsort(List, 1, Numb);
else -- file is larger than minimum subfile size
Stk := 1;
Stack(1).Beginning := 1;
Stack(1).Ending := Numb;
loop -- take top request from stack
Left := Stack(Stk).Beginning;
Righ := Stack(Stk).Ending;
Stk := Stk - 1; -- sort subfiles less than maxsub
-- by straight insertion sort
if (Righ - Left) < Maxsub then
Stinsertsort(List, Left, Righ);
else
loop -- split intervals
I := Left;
J := Righ;
T1rec := List(Median(List, Left, Righ));
loop
while List(I) < T1rec loop
I := I + 1;
end loop;
while T1rec < List(J) loop
J := J - 1;
end loop;
if I <= J then
T2rec := List(I);
List(I) := List(J);
List(J) := T2rec;
I := I + 1;
J := J - 1;
end if;
exit when I > J;
end loop; -- Repeat Loop
if (J - Left) < (Righ - I) then
if I < Righ then -- stack right partion req.
Stk := Stk + 1;
Stack(Stk).Beginning := I;
Stack(Stk).Ending := Righ;
end if;
Righ := J; -- continue sorting left partion
else
if Left < J then -- stack left partion req.
Stk := Stk + 1;
Stack(Stk).Beginning := Left;
Stack(Stk).Ending := J;
end if;
Left := I; -- continue sorting right partion
end if;
exit when Left >= Righ;
end loop;
end if;
exit when Stk = Zero;
end loop; -- Repeat Loop
end if;
end Quicksort;
-------------------------------------------------------------------------
-------------------------------------------------------------------------
-- MAIN
-------------------------------------------------------------------------
-------------------------------------------------------------------------
-------------------------------------------------------------------------
begin
if N_Data > Numrecs then
raise Too_Big;
end if;
Getrecs(Datrec, Total, X);
Quicksort(Datrec, Total);
Fileout(Datrec, Total, X);
end Qsort;
Daniel.Gaudry
9 Av CALMELS
92270 Bois Colombes
France
+33147862234
[log in to unmask]
|
