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;