* Re: Unchecked_Deallocation with tagged class type.
2023-11-15 20:26 7% ` Blady
@ 2023-11-15 21:17 0% ` Dmitry A. Kazakov
0 siblings, 0 replies; 200+ results
From: Dmitry A. Kazakov @ 2023-11-15 21:17 UTC (permalink / raw)
On 2023-11-15 21:26, Blady wrote:
> Le 14/11/2023 à 23:42, Dmitry A. Kazakov a écrit :
>>> But what does "Finalize (OB);"?
>>
>> Crashes your program. It is a bug. You should instantiate
>> Unchecked_Deallocation with class-wide type if you pass a class-wide
>> pointer.
>
> Thanks, I haven't considered this possibility.
> Note: the previous program built with GNAT FSF 13.2.0 ran without
> exception.
>
> I've changed:
> with Ada.Unchecked_Deallocation;
> procedure test_20231113_free_class is
>
> type TTA is tagged record
> AA : Integer;
> end record;
> type ATTA is access all TTA;
> type CATTA is access all TTA'Class;
> procedure Finalize (O : in out CATTA) is
> procedure Free is new Ada.Unchecked_Deallocation (TTA'Class, CATTA);
> begin
> Free (O);
> end Finalize;
>
> type TTB is new TTA with record
> BB : Integer;
> end record;
> type ATTB is access all TTB;
> type CATTB is access all TTB'Class;
> procedure Finalize (O : in out CATTB) is
> begin
> Finalize (CATTA (O));
> end Finalize;
>
> OA : CATTA := new TTA;
> OB : CATTB := new TTB;
>
> begin
> Finalize (OA);
> Finalize (OB);
> end test_20231113_free_class;
>
> It runs without exception.
> One question remains about "Finalize (OB);":
> Which memory size is deallocated TTA'Size or TTB'Size?
It is a wrong question. The implementation of the pool may ignore size
using the block size instead. Furthermore T'Size is not necessarily the
size actually allocated.
Regarding Unchecked_Deallocation instantiated with a pointer to a
class-wide object, consider it dispatching on the target object tag.
Thus you can deallocate any object using any instance of
Unchecked_Deallocation for any class-wide parent of, interfaces included.
So Finalize (OB) is OK.
--
Regards,
Dmitry A. Kazakov
http://www.dmitry-kazakov.de
^ permalink raw reply [relevance 0%]
* Re: Unchecked_Deallocation with tagged class type.
2023-11-14 22:42 0% ` Dmitry A. Kazakov
@ 2023-11-15 20:26 7% ` Blady
2023-11-15 21:17 0% ` Dmitry A. Kazakov
0 siblings, 1 reply; 200+ results
From: Blady @ 2023-11-15 20:26 UTC (permalink / raw)
Le 14/11/2023 à 23:42, Dmitry A. Kazakov a écrit :
>> But what does "Finalize (OB);"?
>
> Crashes your program. It is a bug. You should instantiate
> Unchecked_Deallocation with class-wide type if you pass a class-wide
> pointer.
Thanks, I haven't considered this possibility.
Note: the previous program built with GNAT FSF 13.2.0 ran without exception.
I've changed:
with Ada.Unchecked_Deallocation;
procedure test_20231113_free_class is
type TTA is tagged record
AA : Integer;
end record;
type ATTA is access all TTA;
type CATTA is access all TTA'Class;
procedure Finalize (O : in out CATTA) is
procedure Free is new Ada.Unchecked_Deallocation (TTA'Class, CATTA);
begin
Free (O);
end Finalize;
type TTB is new TTA with record
BB : Integer;
end record;
type ATTB is access all TTB;
type CATTB is access all TTB'Class;
procedure Finalize (O : in out CATTB) is
begin
Finalize (CATTA (O));
end Finalize;
OA : CATTA := new TTA;
OB : CATTB := new TTB;
begin
Finalize (OA);
Finalize (OB);
end test_20231113_free_class;
It runs without exception.
One question remains about "Finalize (OB);":
Which memory size is deallocated TTA'Size or TTB'Size?
Thanks, Pascal.
^ permalink raw reply [relevance 7%]
* Re: Unchecked_Deallocation with tagged class type.
2023-11-14 21:11 8% Unchecked_Deallocation with tagged class type Blady
@ 2023-11-14 22:42 0% ` Dmitry A. Kazakov
2023-11-15 20:26 7% ` Blady
0 siblings, 1 reply; 200+ results
From: Dmitry A. Kazakov @ 2023-11-14 22:42 UTC (permalink / raw)
On 2023-11-14 22:11, Blady wrote:
> The following code present a Finalize procedure with a parameter of
> access tagged class type in order to deallocate the memory of the given
> parameter from the root tagged type TTA and his children.
> The same for TTB which is inherited from TTA. But this Finalize call
> Finalize of TTA.
> It may be not the best idea.
> But let's see:
>
> with Ada.Unchecked_Deallocation;
> procedure test_20231113_free_tag is
>
> type TTA is tagged record
> AA : Integer;
> end record;
> type ATTA is access all TTA;
> type CATTA is access all TTA'Class;
> procedure Finalize (O : in out CATTA) is
> procedure Free is new Ada.Unchecked_Deallocation (TTA, ATTA);
> begin
> Free (ATTA (O));
> end Finalize;
>
> type TTB is new TTA with record
> BB : Integer;
> end record;
> type ATTB is access all TTB;
> type CATTB is access all TTB'Class;
> procedure Finalize (O : in out CATTB) is
> begin
> Finalize (CATTA (O));
> end Finalize;
>
> OA : CATTA := new TTA;
> OB : CATTB := new TTB;
>
> begin
> Finalize (OA);
> Finalize (OB);
> end test_20231113_free_tag;
>
> The procedure Free is the instanciation of Unchecked_Deallocation with
> the tagged type TTA.
> Thus the call "Finalize (OA);" deallocate the memory of object OA of
> type access class TTA.
>
> But what does "Finalize (OB);"?
Crashes your program. It is a bug. You should instantiate
Unchecked_Deallocation with class-wide type if you pass a class-wide
pointer.
--
Regards,
Dmitry A. Kazakov
http://www.dmitry-kazakov.de
^ permalink raw reply [relevance 0%]
* Unchecked_Deallocation with tagged class type.
@ 2023-11-14 21:11 8% Blady
2023-11-14 22:42 0% ` Dmitry A. Kazakov
0 siblings, 1 reply; 200+ results
From: Blady @ 2023-11-14 21:11 UTC (permalink / raw)
Hello,
The following code present a Finalize procedure with a parameter of
access tagged class type in order to deallocate the memory of the given
parameter from the root tagged type TTA and his children.
The same for TTB which is inherited from TTA. But this Finalize call
Finalize of TTA.
It may be not the best idea.
But let's see:
with Ada.Unchecked_Deallocation;
procedure test_20231113_free_tag is
type TTA is tagged record
AA : Integer;
end record;
type ATTA is access all TTA;
type CATTA is access all TTA'Class;
procedure Finalize (O : in out CATTA) is
procedure Free is new Ada.Unchecked_Deallocation (TTA, ATTA);
begin
Free (ATTA (O));
end Finalize;
type TTB is new TTA with record
BB : Integer;
end record;
type ATTB is access all TTB;
type CATTB is access all TTB'Class;
procedure Finalize (O : in out CATTB) is
begin
Finalize (CATTA (O));
end Finalize;
OA : CATTA := new TTA;
OB : CATTB := new TTB;
begin
Finalize (OA);
Finalize (OB);
end test_20231113_free_tag;
The procedure Free is the instanciation of Unchecked_Deallocation with
the tagged type TTA.
Thus the call "Finalize (OA);" deallocate the memory of object OA of
type access class TTA.
But what does "Finalize (OB);"?
What is the memory deallocate of object OB of type TTB?
Thanks, Pascal.
^ permalink raw reply [relevance 8%]
* Re: Real_Arrays on heap with overloaded operators and clean syntax
2023-01-23 1:14 8% ` Leo Brewin
@ 2023-01-23 6:01 0% ` Jim Paloander
0 siblings, 0 replies; 200+ results
From: Jim Paloander @ 2023-01-23 6:01 UTC (permalink / raw)
On Monday, January 23, 2023 at 2:14:58 AM UTC+1, Leo Brewin wrote:
> Here is a slight variation on the solution suggested by Gautier. It uses
> Aad's "rename" syntax so that you can avoid all the .all stuff. I use
> this construction extensively in my large scale scientific computations.
>
> with Ada.Numerics.Generic_Real_Arrays;
> with Ada.Unchecked_Deallocation;
> procedure Test_Large is
>
> type Float_15 is digits 15;
>
> package F15_R_A is new Ada.Numerics.Generic_Real_Arrays (Float_15);
>
> use F15_R_A;
>
> procedure Solve_it
> (x : in Real_Vector;
> y : out Real_Vector;
> A : in Real_Matrix) is
> begin
> null; -- Here, the big number-crunching
> end;
>
> n : constant := 10_000;
>
> type Vector_Access is access Real_Vector;
> type Matrix_Access is access Real_Matrix;
> x_ptr, y_ptr : Vector_Access := new Real_Vector (1 .. n);
> A_ptr : Matrix_Access := new Real_Matrix (1 .. n, 1 .. n);
>
> x : Real_Vector renames x_ptr.all;
> y : Real_Vector renames y_ptr.all;
> A : Real_Matrix renames A_ptr.all;
>
> procedure FreeVector is new
> Ada.Unchecked_Deallocation (Real_Vector,Vector_Access);
> procedure FreeMatrix is new
> Ada.Unchecked_Deallocation (Real_Matrix,Matrix_Access);
>
> begin
> Solve_it (x, y, A);
> -- Deallocation here
> FreeVector (x_ptr);
> FreeVector (y_ptr);
> FreeMatrix (A_ptr);
> end;
Thank you very much, would a for Real_Vector_Access'Storage_Pool use localPool; save you from the need to free the vectors and matrix yourself?
On the other hand, is there any way of avoiding temporaries? Possibly a modern version of the Real_Array using expression generic syntax or something similar? Since you are using scientific computationas extensively, you must be aware of Fortran. Have you compared Fortran's complex numbers with ADA's for inner products or similar computations to see who is faster? You see, I like a lot of things about ADA, but the syntax is really difficult to follow. Sometimes it gives me the impression that it is more difficult than really needed to be. For example there should be a way for Real_Arrays to allocate memory internally and not on the stack directly like containers. And for containers to provide an indexer Vector(i) and overloaded operators similarly to Real_Vectors. But the fact that they do not give me the impression that this Language although being designed by the army for mission critical applications never realized that modern mission critical need to simplify mathematical calculations providing an easy syntax. I am surprised that after so many years and so many updates to the Standard the designers of the Language did not realized that such mathematical syntax should be simplified to attract more people from scientific computing, who are tired with Fortran 10000 ways of declaring something a variable.
^ permalink raw reply [relevance 0%]
* Re: Real_Arrays on heap with overloaded operators and clean syntax
@ 2023-01-23 1:14 8% ` Leo Brewin
2023-01-23 6:01 0% ` Jim Paloander
0 siblings, 1 reply; 200+ results
From: Leo Brewin @ 2023-01-23 1:14 UTC (permalink / raw)
Here is a slight variation on the solution suggested by Gautier. It uses
Aad's "rename" syntax so that you can avoid all the .all stuff. I use
this construction extensively in my large scale scientific computations.
with Ada.Numerics.Generic_Real_Arrays;
with Ada.Unchecked_Deallocation;
procedure Test_Large is
type Float_15 is digits 15;
package F15_R_A is new Ada.Numerics.Generic_Real_Arrays (Float_15);
use F15_R_A;
procedure Solve_it
(x : in Real_Vector;
y : out Real_Vector;
A : in Real_Matrix) is
begin
null; -- Here, the big number-crunching
end;
n : constant := 10_000;
type Vector_Access is access Real_Vector;
type Matrix_Access is access Real_Matrix;
x_ptr, y_ptr : Vector_Access := new Real_Vector (1 .. n);
A_ptr : Matrix_Access := new Real_Matrix (1 .. n, 1 .. n);
x : Real_Vector renames x_ptr.all;
y : Real_Vector renames y_ptr.all;
A : Real_Matrix renames A_ptr.all;
procedure FreeVector is new
Ada.Unchecked_Deallocation (Real_Vector,Vector_Access);
procedure FreeMatrix is new
Ada.Unchecked_Deallocation (Real_Matrix,Matrix_Access);
begin
Solve_it (x, y, A);
-- Deallocation here
FreeVector (x_ptr);
FreeVector (y_ptr);
FreeMatrix (A_ptr);
end;
^ permalink raw reply [relevance 8%]
* 2-dimensional view on 1 dimensional array
@ 2022-10-23 12:31 6% Marek
0 siblings, 0 replies; 200+ results
From: Marek @ 2022-10-23 12:31 UTC (permalink / raw)
Hi.
Assume we have:
generic
type T is private;
type T_Array is array (Natural range <>) of aliased T;
type T_Array_Access is access all T_Array;
package Buffers is
type Row_Array is array (Natural range <>) of aliased
T_Array_Access;
type Row_Array_Access is access all Row_Array;
type Buffer is tagged
record
Raw_Buffer : T_Array_Access := null;
Rows_Table : Row_Array_Access := null;
Rows : Natural := 0;
Columns : Natural := 0;
Step : Integer := 0;
Max_Rows : Natural := 0;
end record;
procedure Init
(This : in out Buffer;
Buffer : T_Array_Access;
Rows : Natural;
Columns : Natural;
Step : Integer);
procedure Set_Value
(This : in out Buffer;
Value : T);
end Buffers;
..and:
with Ada.Unchecked_Deallocation;
package body Buffers is
type T_Access is access all T;
------------
-- Init --
------------
procedure Init
(This : in out Buffer;
Buffer : T_Array_Access;
Rows : Natural;
Columns : Natural;
Step : Integer)
is
procedure Free is
new Ada.Unchecked_Deallocation (Row_Array, Row_Array_Access);
Row_Index : Integer := 0;
begin
This.Raw_Buffer := Buffer;
This.Rows := Rows;
This.Columns := Columns;
This.Step := Step;
if Rows > This.Max_Rows then
if This.Rows_Table /= null then
Free (This.Rows_Table);
end if;
declare
New_Rows : constant Row_Array_Access :=
new Row_Array (0 .. Rows - 1);
begin
This.Rows_Table := New_Rows;
This.Max_Rows := Rows;
end;
end if;
for H in 0 .. Rows - 1 loop
declare
Row_Start : constant T_Access :=
This.Raw_Buffer (Row_Index * Step)'Access;
begin
This.Rows_Table (H) := ... -- What code here?
Row_Index := Row_Index + 1;
end;
end loop;
end Init;
-----------------
-- Set_Value --
-----------------
procedure Set_Value
(This : in out Buffer;
Value : T)
is
begin
if This.Rows > 0 then
for Y in 0 .. This.Rows - 1 loop
declare
Row : constant T_Array_Access := This.Rows_Table (Y);
begin
if This.Step > 0 then
for X in 0 .. This.Step - 1 loop
Row (X) := Value;
end loop;
end if;
end;
end loop;
end if;
end Set_Value;
end Buffers;
and finally:
with Buffers;
procedure Test is
type Float_Array is array (Natural range <>) of aliased Float;
type Float_Array_Access is access all Float_Array;
package Buffer_Package is
new Buffers (Float, Float_Array, Float_Array_Access);
use Buffer_Package;
A : aliased Float_Array := (0 .. 99 => 0.0);
B : Buffer_Package.Buffer;
begin
B.Init (A'Access, 10, 10, 10);
B.Set_Value (10.0);
end Test;
Is there any possibilities to get this working?
Idea is to have another (2 dimensional) view on 1 dimensional array.
Unchecked_Conversion is not working (different sizes of objects).
Address_To_Access conversion also (unconstrained array);
Marek
^ permalink raw reply [relevance 6%]
* Re: Unchecked_Deallocation with tagged types
2022-04-16 3:44 6% ` Thomas
@ 2022-04-16 8:09 0% ` Dmitry A. Kazakov
0 siblings, 0 replies; 200+ results
From: Dmitry A. Kazakov @ 2022-04-16 8:09 UTC (permalink / raw)
On 2022-04-16 05:44, Thomas wrote:
> In article <s5h0o5$1piu$1@gioia.aioe.org>,
> "Dmitry A. Kazakov" <mailbox@dmitry-kazakov.de> wrote:
>
>> On 2021-04-18 11:09, Jeffrey R. Carter wrote:
>>> On 4/18/21 10:46 AM, Gautier write-only address wrote:
>>>> Side note: did anyone already suggest a new keyword: unchecked_free
>>>> and a special statement:
>>>>
>>>> unchecked_free Some_Pointer;
>>>
>>> For every access variable P, there could exist the attribute procedure
>>>
>>> P'Free;
>>
>> I like the idea of attaching it to a variable rather than to type.
>
> why?
Because operations apply to objects not to
the types of.
> if it had to be made, i would say it could not be less than sth like:
> T'Unchecked_Free (P)
This does as little sense as T'Image did.
>> I remember the claim that originally making it a generic procedure with
>> an indigestible name was meant as barrier for lazy programmers.
>
> not only that:
> i agree J-P. Rosen (he didn't said exactly that),
> it's fine to be able to search for the "Unchecked" keyword, to look at
> parts of code with some known risk (afaik):
> Ada.Unchecked_Deallocation, Ada.Unchecked_Conversion, Unchecked_Access.
You can search for "Free" as easily.
Furthermore, the way unchecked stuff breaks the program is such that the
actual problem is almost never located at the place where you call
something unchecked. The error is usually triggered in a different place.
>> Plus
>> some considerations regarding garbage collection lurked in the subconscious.
>
> could you explain, please ? :-)
You allocate objects at will and the language per magic wand frees them
for you someway someday. This anything that works in a non-magical way
(read: deterministic, predictable, explicit) is so outrageous that must
be highlighted as "unchecked." (:-))
--
Regards,
Dmitry A. Kazakov
http://www.dmitry-kazakov.de
^ permalink raw reply [relevance 0%]
* Re: Unchecked_Deallocation with tagged types
2021-04-18 16:08 9% ` Gautier write-only address
@ 2022-04-16 5:00 0% ` Thomas
0 siblings, 0 replies; 200+ results
From: Thomas @ 2022-04-16 5:00 UTC (permalink / raw)
In article <b37bc687-b72f-4bc4-858c-77dc9b878cffn@googlegroups.com>,
Gautier write-only address <gautier_niouzes@hotmail.com> wrote:
> > Well, P'Free can also be in another package... Of course, we are talking
> > here only about the direct, actual deallocation.
> >
> > If you want to precisely know where deallocation is used, use AdaControl
> > (for any solution). If you want to be confident that there is no direct
> > deallocation in a module, the generic wins.
>
> It loses because you can have direct, immediate deallocation without the
> "with Ada.Unchecked_Deallocation" somewhere in the context clause.
>
> pack.ads:
>
> with Ada.Unchecked_Deallocation;
> package Pack is
> type IA is access Integer;
> procedure Release is new Ada.Unchecked_Deallocation (Integer, IA);
> end;
>
> ----
> proc.adb:
>
> with Pack;
> procedure Proc is
> use Pack;
> P : IA;
> begin
> P := new Integer;
> Release (P);
> end;
what J-P. Rosen meant was that P'Free could be in the body of
Pack.Release, and then it would not be in Proc either.
perso i like the design with the "generic".
(I'm used to it anyway, although of course it's worse than not needing
explicit Deallocation.)
but the question is: why in the specification ???
actually i need to know more about your case:
- do you find it ok to put the access types in the package
specification, and then not have control over what they become?
- or don't you want that, but you regularly become in situations where
you have no choice (for example because you need components of which you
are not the author)?
what's your opinion about String_Access and Free in
Ada.Strings.Unbounded?
I don't understand what they are doing here, since this package is made
to avoid needing them...
--
RAPID maintainer
http://savannah.nongnu.org/projects/rapid/
^ permalink raw reply [relevance 0%]
* Re: Unchecked_Deallocation with tagged types
@ 2022-04-16 3:44 6% ` Thomas
2022-04-16 8:09 0% ` Dmitry A. Kazakov
0 siblings, 1 reply; 200+ results
From: Thomas @ 2022-04-16 3:44 UTC (permalink / raw)
In article <s5h0o5$1piu$1@gioia.aioe.org>,
"Dmitry A. Kazakov" <mailbox@dmitry-kazakov.de> wrote:
> On 2021-04-18 11:09, Jeffrey R. Carter wrote:
> > On 4/18/21 10:46 AM, Gautier write-only address wrote:
> >> Side note: did anyone already suggest a new keyword: unchecked_free
> >> and a special statement:
> >>
> >> unchecked_free Some_Pointer;
> >
> > For every access variable P, there could exist the attribute procedure
> >
> > P'Free;
>
> I like the idea of attaching it to a variable rather than to type.
why?
if it had to be made, i would say it could not be less than sth like:
T'Unchecked_Free (P)
>
> -------------
> I remember the claim that originally making it a generic procedure with
> an indigestible name was meant as barrier for lazy programmers.
not only that:
i agree J-P. Rosen (he didn't said exactly that),
it's fine to be able to search for the "Unchecked" keyword, to look at
parts of code with some known risk (afaik):
Ada.Unchecked_Deallocation, Ada.Unchecked_Conversion, Unchecked_Access.
> Plus
> some considerations regarding garbage collection lurked in the subconscious.
could you explain, please ? :-)
--
RAPID maintainer
http://savannah.nongnu.org/projects/rapid/
^ permalink raw reply [relevance 6%]
* On absurdity of collections 7.6.1 (11.1/3)
@ 2021-09-29 9:09 6% Dmitry A. Kazakov
0 siblings, 0 replies; 200+ results
From: Dmitry A. Kazakov @ 2021-09-29 9:09 UTC (permalink / raw)
For Ada programmers who wonder what it is, here is a practical example.
Given the package specification:
package P is
type Item (Length : Positive) is
new Ada.Finalization.Limited_Controlled with
record
Text : String (1..Length);
end record;
overriding procedure Finalize (X : in out Item);
type Item_Ptr is access all Item;
function New_Item
( Pool : in out Root_Storage_Pool'Class;
Text : String
) return Item_Ptr;
procedure Free is new Ada.Unchecked_Deallocation (Item, Item_Ptr);
end P;
and the program using it like this:
Ptr : Item_Ptr := New_Item (Some_Pool, "A");
...
Free (Ptr);
Write the package body.
--
Regards,
Dmitry A. Kazakov
http://www.dmitry-kazakov.de
^ permalink raw reply [relevance 6%]
* Re: Custom Storage Pool questions
@ 2021-09-15 16:43 4% ` Simon Wright
0 siblings, 0 replies; 200+ results
From: Simon Wright @ 2021-09-15 16:43 UTC (permalink / raw)
Jere <jhb.chat@gmail.com> writes:
> But after reading the following AdaCore article, my assumption is now
> called into question:
> https://blog.adacore.com/header-storage-pools
>
> In particular, the blog there advocates for separately counting for
> things like unconstrained array First/Last indices or the Prev/Next
> pointers used for Controlled objects. Normally I would have assumed
> that the Size_In_Storage_Elements parameter in Allocate would account
> for that, but the blog clearly shows that it doesn't
Well, I may well have missed the point somewhere, and maybe things have
changed since 2015, but as far as I can see, with FSF GCC 11.1.0, the
technique described in the blog is completely unnecessary.
To save having to recompile the runtime with debug symbols, I wrote a
tiny pool which delegates to GNAT's
System.Pool_Global.Global_Pool_Object (the default pool), e.g.
overriding procedure Allocate
(Pool : in out My_Pool.Pool;
Storage_Address : out Address;
Size_In_Storage_Elements : in Storage_Elements.Storage_Count;
Alignment : in Storage_Elements.Storage_Count)
is
pragma Unreferenced (Pool);
begin
Global_Pool_Object.Allocate
(Address => Storage_Address,
Storage_Size => Size_In_Storage_Elements,
Alignment => Alignment);
end Allocate;
and I find with
Pool : My_Pool.Pool;
type C is new Ada.Finalization.Controlled with null record;
type Cs is array (Natural range <>) of C;
type Csp is access Cs with Storage_Pool => Pool;
procedure Free is new Ada.Unchecked_Deallocation (Cs, Csp);
Pcs : Csp;
begin
Pcs := new Cs (0 .. 5);
Free (Pcs);
that
* the alignment requested is 8 (was 4 for an array of Boolean);
* the size requested is 72, which is 24 bytes more than required for the
6 minimal POs;
* the value returned by Allocate is 24 bytes more than the address of
the array object Pcs (which is the same as that of Pcs(0));
* the value passed to Deallocate is the same as that returned by
Allocate.
I think it's more than likely (!) that the extra allocation of 24 bytes
is made up of 2 pointers at 8 bytes each, used to implement the
finalization chain, and two integers at 4 bytes each, holding the array
bounds.
So I'd say that to create a pool with extra header information, you'd
need to allocate space for your header + padding to ensure that the
compiler's object is properly aligned + the compiler-requested size,
aligned to the max of your header's alignment and the compiler-requested
alignment.
Mind, I don't quite see how to actually access the header info for a
particular allocation ...
^ permalink raw reply [relevance 4%]
* Re: Unchecked_Deallocation with tagged types
@ 2021-04-18 16:08 9% ` Gautier write-only address
2022-04-16 5:00 0% ` Thomas
0 siblings, 1 reply; 200+ results
From: Gautier write-only address @ 2021-04-18 16:08 UTC (permalink / raw)
> Well, P'Free can also be in another package... Of course, we are talking
> here only about the direct, actual deallocation.
>
> If you want to precisely know where deallocation is used, use AdaControl
> (for any solution). If you want to be confident that there is no direct
> deallocation in a module, the generic wins.
It loses because you can have direct, immediate deallocation without the "with Ada.Unchecked_Deallocation" somewhere in the context clause.
pack.ads:
with Ada.Unchecked_Deallocation;
package Pack is
type IA is access Integer;
procedure Release is new Ada.Unchecked_Deallocation (Integer, IA);
end;
----
proc.adb:
with Pack;
procedure Proc is
use Pack;
P : IA;
begin
P := new Integer;
Release (P);
end;
^ permalink raw reply [relevance 9%]
* Re: Unchecked_Deallocation with tagged types
2021-04-18 8:21 8% ` Dmitry A. Kazakov
@ 2021-04-18 9:13 0% ` DrPi
1 sibling, 0 replies; 200+ results
From: DrPi @ 2021-04-18 9:13 UTC (permalink / raw)
Le 18/04/2021 à 10:21, Dmitry A. Kazakov a écrit :
> On 2021-04-17 23:45, DrPi wrote:
>
>> I have the following types :
>>
>> type t_Element_Record is tagged null record;
>> type t_Element is access all t_Element_Record'Class;
>>
>> type t_Str_Record (Str_Length : Natural) is new t_Element_Record
>> with record
>> Str : String (1 .. Str_Length);
>> end record;
>> type t_Str is access all t_Str_Record'Class;
>>
>> Do I have to create a Unchecked_Deallocation procedure for each tagged
>> type or only one for the root tagged type (and the compiler manages
>> the effective tagged type) ?
>
> You have Unchecked_Deallocation for the type you deallocate. In your
> case the answer is neither. You instantiate Unchecked_Deallocation for
> the class.
>
> procedure Free is
> new Ada.Unchecked_Deallocation
> ( t_Element_Record'Class,
> t_Element
> );
>
Thanks
> P.S. Hungarian notation is evil. Using suffixes on top of Hungarian
> notation is evil squared.
>
I know Ada convention is to use Camel_Case_Syntax. Maybe there's also a
convention for naming ?
What's the convention you use for naming ?
^ permalink raw reply [relevance 0%]
* Re: Unchecked_Deallocation with tagged types
2021-04-17 22:36 6% ` Rod Kay
2021-04-18 9:06 0% ` DrPi
@ 2021-04-18 9:07 6% ` Jeffrey R. Carter
1 sibling, 0 replies; 200+ results
From: Jeffrey R. Carter @ 2021-04-18 9:07 UTC (permalink / raw)
On 4/18/21 12:36 AM, Rod Kay wrote:
> On 18/4/21 8:29 am, Rod Kay wrote:
>> I believe it is ...
>>
>> procedure free is new Ada.unchecked_Deallocation (t_Element,
>> t_Element_Record'Class);
>
> Ugh ... I mean ...
>
> procedure free is new Ada.unchecked_Deallocation (t_Element_Record'Class,
> t_Element);
No, you mean
... new Ada.Unchecked_Deallocation
(Object => Name_Repeating_2_Things_From_The_Code'Class,
Name => Name_Repeating_1_Thing_From_The_Code);
which ensures that you don't make a mistake when you write it, and understand
what is what when you read it (although Pointer would be better than Name).
--
Jeff Carter
"Run away! Run away!"
Monty Python and the Holy Grail
58
^ permalink raw reply [relevance 6%]
* Re: Unchecked_Deallocation with tagged types
2021-04-17 22:36 6% ` Rod Kay
@ 2021-04-18 9:06 0% ` DrPi
2021-04-18 9:07 6% ` Jeffrey R. Carter
1 sibling, 0 replies; 200+ results
From: DrPi @ 2021-04-18 9:06 UTC (permalink / raw)
Le 18/04/2021 à 00:36, Rod Kay a écrit :
> On 18/4/21 8:29 am, Rod Kay wrote:
>> I believe it is ...
>>
>> procedure free is new Ada.unchecked_Deallocation (t_Element,
>> t_Element_Record'Class);
>>
>>
>> Regards.
>
>
> Ugh ... I mean ...
>
> procedure free is new Ada.unchecked_Deallocation
> (t_Element_Record'Class, t_Element);
>
>
> Sorry, early morning brain fog :).
This wouldn't happen to me ;)
Thanks
^ permalink raw reply [relevance 0%]
* Re: Unchecked_Deallocation with tagged types
2021-04-17 22:29 6% ` Rod Kay
@ 2021-04-18 8:21 8% ` Dmitry A. Kazakov
2021-04-18 9:13 0% ` DrPi
1 sibling, 2 replies; 200+ results
From: Dmitry A. Kazakov @ 2021-04-18 8:21 UTC (permalink / raw)
On 2021-04-17 23:45, DrPi wrote:
> I have the following types :
>
> type t_Element_Record is tagged null record;
> type t_Element is access all t_Element_Record'Class;
>
> type t_Str_Record (Str_Length : Natural) is new t_Element_Record with
> record
> Str : String (1 .. Str_Length);
> end record;
> type t_Str is access all t_Str_Record'Class;
>
> Do I have to create a Unchecked_Deallocation procedure for each tagged
> type or only one for the root tagged type (and the compiler manages the
> effective tagged type) ?
You have Unchecked_Deallocation for the type you deallocate. In your
case the answer is neither. You instantiate Unchecked_Deallocation for
the class.
procedure Free is
new Ada.Unchecked_Deallocation
( t_Element_Record'Class,
t_Element
);
P.S. Hungarian notation is evil. Using suffixes on top of Hungarian
notation is evil squared.
--
Regards,
Dmitry A. Kazakov
http://www.dmitry-kazakov.de
^ permalink raw reply [relevance 8%]
* Re: Unchecked_Deallocation with tagged types
2021-04-17 22:29 6% ` Rod Kay
@ 2021-04-17 22:36 6% ` Rod Kay
2021-04-18 9:06 0% ` DrPi
2021-04-18 9:07 6% ` Jeffrey R. Carter
0 siblings, 2 replies; 200+ results
From: Rod Kay @ 2021-04-17 22:36 UTC (permalink / raw)
On 18/4/21 8:29 am, Rod Kay wrote:
> I believe it is ...
>
> procedure free is new Ada.unchecked_Deallocation (t_Element,
> t_Element_Record'Class);
>
>
> Regards.
Ugh ... I mean ...
procedure free is new Ada.unchecked_Deallocation
(t_Element_Record'Class, t_Element);
Sorry, early morning brain fog :).
^ permalink raw reply [relevance 6%]
* Re: Unchecked_Deallocation with tagged types
@ 2021-04-17 22:29 6% ` Rod Kay
2021-04-17 22:36 6% ` Rod Kay
2021-04-18 8:21 8% ` Dmitry A. Kazakov
1 sibling, 1 reply; 200+ results
From: Rod Kay @ 2021-04-17 22:29 UTC (permalink / raw)
I believe it is ...
procedure free is new Ada.unchecked_Deallocation (t_Element,
t_Element_Record'Class);
Regards.
^ permalink raw reply [relevance 6%]
* GNAT vs Matlab - operation on multidimensional complex matrices
@ 2020-03-23 23:16 6% darek
0 siblings, 0 replies; 200+ results
From: darek @ 2020-03-23 23:16 UTC (permalink / raw)
Hi Everyone,
I am working on radar signal processing algorithms that use multidimensional complex arrays.
To my surprise, the performance of some Matlab functions is much better than compiled Ada code.
Let's start with a simple problem of computing sum of all elements in a 3D real and complex array.
The Ada code is as follows:
with Ada.Text_IO;
with Ada.Real_Time; use Ada.Real_Time;
with Ada.Unchecked_Deallocation;
with Ada.Numerics.Long_Complex_Types; use Ada.Numerics.Long_Complex_Types;
with Ada.Text_IO.Complex_IO;
procedure TestSpeed is
package TIO renames Ada.Text_IO;
package CTIO is new Ada.Text_IO.Complex_IO(Ada.Numerics.Long_Complex_Types);
subtype mReal is Long_Float;
NumIteration : constant := 1_000;
NumChannels : constant := 64;
NumRanges : constant := 400;
NumAngles : constant := 30;
type tCubeReal is array (1..NumChannels, 1..NumAngles, 1..NumRanges) of mReal;
type tCubeRealAcc is access all tCubeReal;
--for tCubeReal'Alignment use 8;
type tCubeComplex is array (1..NumChannels, 1..NumAngles, 1..NumRanges) of Complex;
type tCubeComplexAcc is access all tCubeComplex;
--for tCubeComplex'Alignment use 16;
RealCubeAcc : tCubeRealAcc;
SReal : mReal;
ComplexCubeAcc : tCubeComplexAcc;
SComplex : Complex;
procedure Free is new Ada.Unchecked_Deallocation(tCubeReal, tCubeRealAcc);
procedure Free is new Ada.Unchecked_Deallocation(tCubeComplex, tCubeComplexAcc);
--| -------------------------------------------------------------------------
procedure SpeedSumRealCube (NumIteration : Integer; Mtx : in tCubeReal; S: out mReal) is
Ts : Time;
TEx : Time_Span;
t : mReal;
begin
Ts := Clock;
S := 0.0;
for k in 1..NumIteration loop
for m in Mtx'Range(1) loop
for n in Mtx'Range(2) loop
for p in Mtx'Range(3) loop
S := S + Mtx(m, n, p);
end loop;
end loop;
end loop;
end loop;
TEx := Clock - Ts;
TIO.New_Line;
TIO.Put_Line("Computation time:" & Duration'Image(To_Duration(TEx)));
t := mReal(To_Duration(TEx))/mReal(NumIteration);
TIO.Put_Line("Computation time per iteration:" & t'Image);
end SpeedSumRealCube;
--| -------------------------------------------------------------------------
procedure SpeedSumComplexCube (NumIteration : Integer; Mtx : in tCubeComplex; S: out Complex) is
Ts : Time;
TEx : Time_Span;
t : mReal;
begin
Ts := Clock;
S := 0.0 + i* 0.0;
for k in 1..NumIteration loop
for m in Mtx'Range(1) loop
for n in Mtx'Range(2) loop
for p in Mtx'Range(3) loop
S := S + Mtx(m, n, p);
end loop;
end loop;
end loop;
end loop;
TEx := Clock - Ts;
TIO.New_Line;
TIO.Put_Line("Computation time:" & Duration'Image(To_Duration(TEx)));
t := mReal(To_Duration(TEx))/mReal(NumIteration);
TIO.Put_Line("Computation time per iteration:" & t'Image);
end SpeedSumComplexCube;
--| -------------------------------------------------------------------------
begin
TIO.Put_Line("Real cube");
TIO.Put_Line("Real type size is:" & Integer(mReal'Size)'Image);
RealCubeAcc := new tCubeReal;
RealCubeAcc.all := (others =>(others =>( others => 1.0)));
SpeedSumRealCube(NumIteration => NumIteration,
Mtx => RealCubeAcc.all,
S => SReal);
TIO.Put_Line("Sum is:" & SReal'Image);
TIO.Put_Line("Complex cube");
TIO.Put_Line("Complex type size is:" & Integer(Complex'Size)'Image);
ComplexCubeAcc := new tCubeComplex;
ComplexCubeAcc.all := (others =>(others =>( others => 1.0 + i * 1.0)));
SpeedSumComplexCube(NumIteration => NumIteration,
Mtx => ComplexCubeAcc.all,
S => SComplex);
TIO.Put("Sum is:"); CTIO.Put(SComplex);
Free(ComplexCubeAcc);
Free(RealCubeAcc);
end TestSpeed;
1. Compiled with: gcc version 9.2.0 (tdm64-1) ( and gnat community edition 2019), with the -O2 optimisation level.
2. CPU: AMD64 Family 23 Model 24 Stepping 1 CPU0 2300 AMD Ryzen 7 3750H with Radeon Vega Mobile Gfx
3. Win10 64bit
The results of the program execution:
Computation time: 0.616710300
Computation time per iteration: 6.16710300000000E-04
Sum is: 7.68000000000000E+08
Complex cube
Complex type size is: 128
Computation time: 3.707091000
Computation time per iteration: 3.70709100000000E-03
Sum is:( 7.68000000000000E+08, 7.68000000000000E+08)
The executable produced by the gcc provide with the gnat community edition gave very similar results.
More interesting part - the Matlab code.
Matlab version : Matlab 2019b, 64bit
function [] = TestSpeed
NumIterations = 1000;
NumChannels = 64;
NumRanges = 400;
NumAngles = 30;
%--| real matrix
ReMtx = ones(NumChannels, NumAngles, NumRanges);
tic
SReal = ComputeSum(NumIterations, ReMtx);
TExR = toc;%cputime-ts;
fprintf('TExe:%f, sum real=%f\n', TExR, SReal);
%--| complex matrix
CplxMtx = complex(ReMtx, ReMtx);
%ts = cputime;
tic
SCplx = ComputeSum(NumIterations, CplxMtx);
TExC = toc; %cputime - ts;
fprintf('TExe:%f, sum complex= <%f,%f> \n', TExC, real(SCplx), imag(SCplx));
fprintf('Complex operations are %f times slower\n', TExC/TExR);
end % function
function [S] = ComputeSum(NumIterations, Mtx)
S = 0;
for i = 1:NumIterations
S = S + sum(sum(sum(Mtx)));
end % for
end % function
The results of the program execution:
TExe:0.260718, sum real=768000000.000000
TExe:0.789778, sum complex= <768000000.000000,768000000.000000>
Complex operations are 3.029242 times slower
What is wrong with my code ? Is it the Ada compiler doing bad job here?
If you look at Matlab code, on average the computation that use complex addition are ~3 times slower than for the real numbers.
In the case of Ada code, the complex operations are ~ 6 times slower that for the real numbers.
Did I miss something somewhere ? Any ideas how I can improve the performance of the Ada program (different array layout, magic pragmas, or magic compiler switches) ?
It seems that Matlab is performing really well here ...
Any suggestions are very welcome.
Regards,
Darek
^ permalink raw reply [relevance 6%]
* Having problems instantiating a child class with an extension aggregate
@ 2020-01-27 0:22 7% b.mcguinness747
0 siblings, 0 replies; 200+ results
From: b.mcguinness747 @ 2020-01-27 0:22 UTC (permalink / raw)
I have three packages:
--------------------------------------------------------------------------------
-- Basic data types used by other packages
--------------------------------------------------------------------------------
package APL_Types is
...
type Int64 is range -9223372036854775808..9223372036854775807;
subtype Int32 is Int64 range -2147483648..2147483647;
subtype Int16 is Int64 range -32768..32767;
subtype APL_Integer is Int64;
...
type Array_Index is range 0..APL_Integer'Last;
type Index_List is array(Array_Index range <>) of Array_Index;
type Index_List_Pointer is access Index_List;
procedure Free_Index_List is new Ada.Unchecked_Deallocation (Index_List, Index_List_Pointer);
subtype Dimensions is Index_List;
type Dimensions_Pointer is access Dimensions;
procedure Free_Dimensions is new Ada.Unchecked_Deallocation (Dimensions, Dimensions_Pointer);
...
end APL_Types;
--------------------------------------------------------------------------------
-- This holds the dimensions of the array, which can change over time
--
-- The array elements are handled by child classes since they might either be
-- stored in the array or calculated when required.
--------------------------------------------------------------------------------
with Ada.Finalization;
with APL_Types;
package APL_Arrays is
use APL_Types;
type APL_Array is new Ada.Finalization.Controlled with private;
type APL_Array_Pointer is access APL_Array;
function Effective_Rank (array_rank, function_rank : Array_Index) return Array_Index;
procedure Finalize (this : in out APL_Array);
function Length (this : in APL_Array; axis : Array_Index) return Array_Index;
function Rank (this : in APL_Array) return Array_Index;
function Raveled_Length (this : in APL_Array) return Array_Index;
function Raveled_Shape (
shape : Dimensions;
function_rank : Array_Index;
to_table : in Boolean := false
) return Dimensions_Pointer;
function Same_Shape (this, other : in APL_Array) return Boolean;
private
type APL_Array is new Ada.Finalization.Controlled with record
g_shape : Dimensions_Pointer;
end record;
end APL_Arrays;
--------------------------------------------------------------------------------
-- Arrays that store each array element
--------------------------------------------------------------------------------
with Ada.Unchecked_Deallocation;
with APL_Arrays, APL_Types;
generic
type Element is private;
package APL_Data_Arrays is
use APL_Types;
type APL_Data_Array is new APL_Arrays.APL_Array with private;
type APL_Data_Array_Pointer is access APL_Data_Array;
type Scalar_Monadic_Function is access function (right : Element) return Element;
type Scalar_Dyadic_Function is access function (left, right : Element) return Element;
function Apply_Scalar_Dyadic (
left, right : in APL_Data_Array; -- The arrays to be operated on
lrank, rrank : Array_Index; -- The left and right function rank
fn : Scalar_Dyadic_Function -- Function to apply to the arrays
) return APL_Data_Array_Pointer;
function Apply_Scalar_Monadic (
right : in APL_Data_Array; -- The array to be operated on
fn : Scalar_Monadic_Function -- The function to apply to the array
) return APL_Data_Array_Pointer;
procedure Finalize (this : in out APL_Data_Array);
overriding function Raveled_Length (this : in APL_Data_Array) return Array_Index;
private
use APL_Types;
type Elements is array(Array_Index range <>) of Element;
type Elements_Pointer is access Elements;
procedure Free_Elements is new Ada.Unchecked_Deallocation (Elements, Elements_Pointer);
type APL_Data_Array is new APL_Arrays.APL_Array with record
g_data : Elements_Pointer;
end record;
end APL_Data_Arrays;
I am trying to create instances of APL_Data_Array in apl_data_arrays.adb. I have procedures that perform operations on one or two arrays and generate a third array with the same dimensions as one of the original arrays, so I want to create a result array, copying the dimensions from an existing array and allocating space for the array elements to be calculated. I tried:
result : APL_Data_Array_Pointer := new APL_Data_Array'(
g_shape => new Dimensions'(right.g_shape.all),
g_data => new Elements(right.g_data.all'Range)
);
This gives me an error message:
apl_data_arrays.adb:180:36: type of aggregate has private ancestor "Controlled"
apl_data_arrays.adb:180:36: must use extension aggregate
But when I try:
result : APL_Data_Array_Pointer := new APL_Data_Array'(
APL_Array'(new Dimensions'(right.g_shape.all)) with
g_data => new Elements(right.g_data.all'Range)
);
I get another error message:
apl_data_arrays.adb:180:48: no selector "g_shape" for type "APL_Data_Array" defined at apl_data_arrays.ads:46
This puzzles me since g_shape is a member of the parent class and should be visible to the child class. I don't see how to fix the problem.
I would appreciate help.
--- Brian McGuinness
^ permalink raw reply [relevance 7%]
* Tracing a race condition
@ 2019-02-02 20:01 4% Jere
0 siblings, 0 replies; 200+ results
From: Jere @ 2019-02-02 20:01 UTC (permalink / raw)
I was running a rather large code base which on rare occasion
throws a PROGRAM_ERROR "finalize/adjust raised exception". After
working on it some time, I narrowed it down to a call to Release
in the Object package of Dmitry's simple components. This narrows
the problem down to at least a couple of options (maybe more):
1. An object that a task has an access to goes out of scope early
2. A potential race condition in the Release procedure
I am still trying to trace through the code (not mine, so learning
how it works) to verify the status of #1. I did take a look at #2 as
well though. Here is the Entity type and the Release procedure:
***************************
type Entity is new Ada.Finalization.Limited_Controlled with record
Use_Count : Natural := 0; -- Reference count
end record;
type Entity_Ptr is access all Entity'Class;
***************************
***************************
procedure Release (Ptr : in out Entity_Ptr) is
procedure Free is new
Ada.Unchecked_Deallocation (Entity'Class, Entity_Ptr);
begin
if Ptr /= null then
declare
Object : Entity'Class renames Ptr.all;
begin
Decrement_Count (Object);
if Object.Use_Count > 0 then
return;
end if;
end;
Free (Ptr);
end if;
end Release;
***************************
Source: http://www.dmitry-kazakov.de/ada/components_4_38.tgz
Decrement_Count simply calls a protected procedure to update
the Use_Count field of the Object.
I think what is happening is Task A calls a series of code
that eventually causes a call to Release on an object and
so does Task B. When that happens, there is a small chance
of the following situation:
Task A: Decrement_Count(Object); -- Use_Count goes down to 1
Task A gives up its time slot
Task B resumes
Task B: Decrement_Count(Object); -- Use_Count goes down to 0
Task B: if Object.Use_Count > 0 then -- skips this since 0
...
Task B: Free(Ptr); -- This free is logically wrong (early)
...
Task B gives up its time slot
Task A resumes
Task A: if Object.Use_Count > 0 then -- skips this since 0
...
Task A: Free(Ptr); -- This free causes the exception (I think)
That doesn't mean that the #1 scenario isn't also a problem, but
I am still looking at it to verify. In the mean time, is this
a potential race condition in the Release procedure?
^ permalink raw reply [relevance 4%]
* Re: ? Is ok return a type derived from ada.finalization.controlled from a "Pure_Function" ? thanks.
2019-01-24 23:56 6% ? Is ok return a type derived from ada.finalization.controlled from a "Pure_Function" ? thanks danielcheagle
2019-01-25 21:20 0% ` Randy Brukardt
@ 2019-01-26 17:02 0% ` Daniel Norte Moraes
1 sibling, 0 replies; 200+ results
From: Daniel Norte Moraes @ 2019-01-26 17:02 UTC (permalink / raw)
Em quinta-feira, 24 de janeiro de 2019 21:56:12 UTC-2, Daniel Norte Moraes escreveu:
> Hi!
>
> Is ok return a type derived from ada.finalization.controlled
> from a function declared "Pure_Function" ?
>
> Or yet, is ok declare a fuction returning a
> controlled type as "pure_function" ?
>
> Thanks in Advance!!!
>
> []'s Dani. :-)
>
> note1 : the type has a access value.
> note2 : initialize, adjust and finalize overrided and working :-)
>
> fragment example code:
>
> ---------------------------------
> pragma Ada_2012;
> pragma Detect_Blocking;
>
> with Ada.Finalization;
>
> package Arbitrary
> with preelaborate
> is
>
> type Arbitrary_Type (size : Positive) is
> new Ada.Finalization.Controlled with private;
>
> function To_Arbitrary (value : Integer; precision : Integer)
> return Arbitrary_Type
> with inline; -- Can I add "pure_function" ?
>
> private
>
> type Mantissa_Type is array (Positive range <>) of Integer;
> type Mantissa_Pointer is access Mantissa_Type;
>
> type Arbitrary_Type (size : Positive) is
> new Ada.Finalization.Controlled with record
> mantissa : Mantissa_Pointer;
> exponent : Integer;
> sign : Integer range -1 .. 1;
> precision : Positive := size;
> end record;
>
> end arbitrary;
>
> -----------------------------------------------
>
>
> pragma Ada_2012;
> pragma Detect_Blocking;
>
> with Ada.Unchecked_Deallocation;
>
> package body Arbitrary is
>
> procedure Delete is new Ada.Unchecked_Deallocation (Mantissa_Type,
> Mantissa_Pointer);
>
> -----------------------------------------------------------------------
> -- Initialize an Arbitrary_Type
> -----------------------------------------------------------------------
> procedure Initialize (Object : in out Arbitrary_Type) is
> begin
> Object.mantissa := new Mantissa_Type (1 .. Object.precision);
> Object.exponent := 0;
> Object.sign := 1;
> -- "here" for diminish race condition from OS' s
> Object.mantissa.all := (others => 0);
> end Initialize;
>
> -----------------------------------------------------------------------
> -- Fix an Arbitrary_Type after being assigned a value
> -----------------------------------------------------------------------
> procedure Adjust (Object : in out Arbitrary_Type) is
> begin
> Object.mantissa := new Mantissa_Type'(Object.mantissa.all);
> end Adjust;
>
> -----------------------------------------------------------------------
> -- Release an Arbitrary_Type;
> -----------------------------------------------------------------------
> procedure Finalize (Object : in out Arbitrary_Type) is
> begin
> if Object.mantissa /= null then
> Delete (Object.mantissa);
> end if;
> Object.mantissa := null;
> end Finalize;
>
> -----------------------------------------------------------------------
> -- Convert an Integer type to an Arbitrary_Type
> -----------------------------------------------------------------------
> function To_Arbitrary (value : Integer; precision : Integer)
> return Arbitrary_Type is
> result : Arbitrary_Type (precision);
> begin
> result.mantissa (result.exponent + 1) := value;
> Normalize (result);
> return result;
> end To_Arbitrary;
>
> end arbitrary;
> -------------------------------------------------------------------
>
> Really Thanks! :-)
> []'s Dani. :-)
Thanks Randy,Shark8 and Simon! :-)
Continuing the work, I tested including pure_function and the craziest mistakes popped up.
gdb showed that pure_function interfered with "adjust" and "initialize" horribly. (I.e.
Thanks for the advice! at least in "to_arbitrary" add "Pure_Function" is a bad idea.
^ permalink raw reply [relevance 0%]
* Re: ? Is ok return a type derived from ada.finalization.controlled from a "Pure_Function" ? thanks.
2019-01-24 23:56 6% ? Is ok return a type derived from ada.finalization.controlled from a "Pure_Function" ? thanks danielcheagle
@ 2019-01-25 21:20 0% ` Randy Brukardt
2019-01-26 17:02 0% ` Daniel Norte Moraes
1 sibling, 0 replies; 200+ results
From: Randy Brukardt @ 2019-01-25 21:20 UTC (permalink / raw)
Of course it's OK, "Pure_Function" is some GNAT-specific nonsense. :-)
My recollection is that GNAT does not check if Pure_Function makes sense, so
the only question is whether you can live with the possible implications.
(And I don't know why you would want to use Pure_Function anyway.)
Note that in Ada 2020, you would use the Global aspect to declare the usage
of globals by your subprogram, and those are checked, so either the aspect
is legal or your program won't compile. But GNAT hasn't implemented that
yet, so far as I know.
Randy.
<danielcheagle@gmail.com> wrote in message
news:db66050e-9606-4c79-bd21-6c0164913181@googlegroups.com...
> Hi!
>
> Is ok return a type derived from ada.finalization.controlled
> from a function declared "Pure_Function" ?
>
> Or yet, is ok declare a fuction returning a
> controlled type as "pure_function" ?
>
> Thanks in Advance!!!
>
> []'s Dani. :-)
>
> note1 : the type has a access value.
> note2 : initialize, adjust and finalize overrided and working :-)
>
> fragment example code:
>
> ---------------------------------
> pragma Ada_2012;
> pragma Detect_Blocking;
>
> with Ada.Finalization;
>
> package Arbitrary
> with preelaborate
> is
>
> type Arbitrary_Type (size : Positive) is
> new Ada.Finalization.Controlled with private;
>
> function To_Arbitrary (value : Integer; precision : Integer)
> return Arbitrary_Type
> with inline; -- Can I add "pure_function" ?
>
> private
>
> type Mantissa_Type is array (Positive range <>) of Integer;
> type Mantissa_Pointer is access Mantissa_Type;
>
> type Arbitrary_Type (size : Positive) is
> new Ada.Finalization.Controlled with record
> mantissa : Mantissa_Pointer;
> exponent : Integer;
> sign : Integer range -1 .. 1;
> precision : Positive := size;
> end record;
>
> end arbitrary;
>
> -----------------------------------------------
>
>
> pragma Ada_2012;
> pragma Detect_Blocking;
>
> with Ada.Unchecked_Deallocation;
>
> package body Arbitrary is
>
> procedure Delete is new Ada.Unchecked_Deallocation (Mantissa_Type,
> Mantissa_Pointer);
>
> -----------------------------------------------------------------------
> -- Initialize an Arbitrary_Type
> -----------------------------------------------------------------------
> procedure Initialize (Object : in out Arbitrary_Type) is
> begin
> Object.mantissa := new Mantissa_Type (1 .. Object.precision);
> Object.exponent := 0;
> Object.sign := 1;
> -- "here" for diminish race condition from OS' s
> Object.mantissa.all := (others => 0);
> end Initialize;
>
> -----------------------------------------------------------------------
> -- Fix an Arbitrary_Type after being assigned a value
> -----------------------------------------------------------------------
> procedure Adjust (Object : in out Arbitrary_Type) is
> begin
> Object.mantissa := new Mantissa_Type'(Object.mantissa.all);
> end Adjust;
>
> -----------------------------------------------------------------------
> -- Release an Arbitrary_Type;
> -----------------------------------------------------------------------
> procedure Finalize (Object : in out Arbitrary_Type) is
> begin
> if Object.mantissa /= null then
> Delete (Object.mantissa);
> end if;
> Object.mantissa := null;
> end Finalize;
>
> -----------------------------------------------------------------------
> -- Convert an Integer type to an Arbitrary_Type
> -----------------------------------------------------------------------
> function To_Arbitrary (value : Integer; precision : Integer)
> return Arbitrary_Type is
> result : Arbitrary_Type (precision);
> begin
> result.mantissa (result.exponent + 1) := value;
> Normalize (result);
> return result;
> end To_Arbitrary;
>
> end arbitrary;
> -------------------------------------------------------------------
>
> Really Thanks! :-)
> []'s Dani. :-)
>
>
>
^ permalink raw reply [relevance 0%]
* ? Is ok return a type derived from ada.finalization.controlled from a "Pure_Function" ? thanks.
@ 2019-01-24 23:56 6% danielcheagle
2019-01-25 21:20 0% ` Randy Brukardt
2019-01-26 17:02 0% ` Daniel Norte Moraes
0 siblings, 2 replies; 200+ results
From: danielcheagle @ 2019-01-24 23:56 UTC (permalink / raw)
Hi!
Is ok return a type derived from ada.finalization.controlled
from a function declared "Pure_Function" ?
Or yet, is ok declare a fuction returning a
controlled type as "pure_function" ?
Thanks in Advance!!!
[]'s Dani. :-)
note1 : the type has a access value.
note2 : initialize, adjust and finalize overrided and working :-)
fragment example code:
---------------------------------
pragma Ada_2012;
pragma Detect_Blocking;
with Ada.Finalization;
package Arbitrary
with preelaborate
is
type Arbitrary_Type (size : Positive) is
new Ada.Finalization.Controlled with private;
function To_Arbitrary (value : Integer; precision : Integer)
return Arbitrary_Type
with inline; -- Can I add "pure_function" ?
private
type Mantissa_Type is array (Positive range <>) of Integer;
type Mantissa_Pointer is access Mantissa_Type;
type Arbitrary_Type (size : Positive) is
new Ada.Finalization.Controlled with record
mantissa : Mantissa_Pointer;
exponent : Integer;
sign : Integer range -1 .. 1;
precision : Positive := size;
end record;
end arbitrary;
-----------------------------------------------
pragma Ada_2012;
pragma Detect_Blocking;
with Ada.Unchecked_Deallocation;
package body Arbitrary is
procedure Delete is new Ada.Unchecked_Deallocation (Mantissa_Type,
Mantissa_Pointer);
-----------------------------------------------------------------------
-- Initialize an Arbitrary_Type
-----------------------------------------------------------------------
procedure Initialize (Object : in out Arbitrary_Type) is
begin
Object.mantissa := new Mantissa_Type (1 .. Object.precision);
Object.exponent := 0;
Object.sign := 1;
-- "here" for diminish race condition from OS' s
Object.mantissa.all := (others => 0);
end Initialize;
-----------------------------------------------------------------------
-- Fix an Arbitrary_Type after being assigned a value
-----------------------------------------------------------------------
procedure Adjust (Object : in out Arbitrary_Type) is
begin
Object.mantissa := new Mantissa_Type'(Object.mantissa.all);
end Adjust;
-----------------------------------------------------------------------
-- Release an Arbitrary_Type;
-----------------------------------------------------------------------
procedure Finalize (Object : in out Arbitrary_Type) is
begin
if Object.mantissa /= null then
Delete (Object.mantissa);
end if;
Object.mantissa := null;
end Finalize;
-----------------------------------------------------------------------
-- Convert an Integer type to an Arbitrary_Type
-----------------------------------------------------------------------
function To_Arbitrary (value : Integer; precision : Integer)
return Arbitrary_Type is
result : Arbitrary_Type (precision);
begin
result.mantissa (result.exponent + 1) := value;
Normalize (result);
return result;
end To_Arbitrary;
end arbitrary;
-------------------------------------------------------------------
Really Thanks! :-)
[]'s Dani. :-)
^ permalink raw reply [relevance 6%]
* Re: Memory pools
2018-05-31 19:28 5% ` gorgelo
@ 2018-05-31 19:33 4% ` gorgelo
1 sibling, 0 replies; 200+ results
From: gorgelo @ 2018-05-31 19:33 UTC (permalink / raw)
And to follow up on the naive benchmarks:
https://github.com/frol/completely-unscientific-benchmarks
Using the memory pool in the previous post it can be used to implement the Treap algorithm (after some minor modifications):
pragma Suppress (Tampering_Check);
-- Tampering checks are only for multi-task applications.
-- Since this application is single task we can safely
-- suppress tampering checks of the standard containers.
-- If performance is an issue, the Ada-Traits Containers may be used instead.
with System.Storage_Elements;
with System.Storage_Pools;
with Ada.Text_IO;
with Ada.Integer_Text_IO;
with Ada.Containers.Vectors;
with Ada.Unchecked_Deallocation;
with Ada.Numerics.Discrete_Random;
procedure Main is
subtype Storage_Offset is System.Storage_Elements.Storage_Offset;
subtype Storage_Count is System.Storage_Elements.Storage_Count;
subtype Storage_Array is System.Storage_Elements.Storage_Array;
subtype Root_Storage_Pool is System.Storage_Pools.Root_Storage_Pool;
subtype Integer_Address is System.Storage_Elements.Integer_Address;
subtype Count_Type is Ada.Containers.Count_Type;
use type Count_Type;
use type Storage_Offset;
use type Integer_Address;
procedure Put (Text : String) renames Ada.Text_IO.Put;
procedure Put_Line (Text : String) renames Ada.Text_IO.Put_Line;
procedure Put_Line (I : Integer) is
begin
Ada.Integer_Text_IO.Put (I, 0);
Ada.Text_IO.New_Line;
end Put_Line;
procedure Put (I : Integer) is
begin
Ada.Integer_Text_IO.Put (I, 0);
end Put;
procedure Put (I : Storage_Offset) is
begin
Ada.Integer_Text_IO.Put (Integer (I), 0);
end Put;
function To_Integer (Value : System.Address) return Integer_Address
renames System.Storage_Elements.To_Integer;
generic
Slot_Size : Positive;
-- Specifies the size of each slot in Storage Elements (bytes)
-- Must be big enough to store any object one wishes to allocate
-- inside the memory pool.
MAX : Positive;
-- Specifies the number of slots that will be allocated in an array
-- from the heap every time more memory needs to be pre-allocated.
package Arena_Pools is
type Arena (<>) is new Root_Storage_Pool with private;
function Make return Arena;
overriding
procedure Allocate
( Pool : in out Arena;
Address : out System.Address;
Size : Storage_Count;
Alignment : Storage_Count
);
overriding
procedure Deallocate
( Pool : in out Arena;
Address : System.Address;
Size : Storage_Count;
Alignment : Storage_Count
);
overriding
function Storage_Size (Pool : Arena) return Storage_Count;
-- Approximation of how many Storage Elements (bytes)
-- have been heap-allocated.
private
type Slot is record
Elements : Storage_Array (1..Storage_Offset (Slot_Size));
end record;
subtype Slot_Index is Storage_Offset range 1.. Storage_Offset (MAX);
type Slots_Array is array (Slot_Index) of Slot;
subtype Free_Index is Integer range 1..MAX;
-- This Integer type (32-bits) is created in order to not use the type
-- Storage_Offset (64-bits) in the free indices vector.
package Indices_Vector is new Ada.Containers.Vectors
(Index_Type => Positive,
Element_Type => Free_Index,
"=" => "=");
type Slots_Envelope is record
Items : Slots_Array;
Free_Indices : Indices_Vector.Vector;
end record;
type Slots_Envelope_Ptr is access all Slots_Envelope;
package Envelope_Vectors is new Ada.Containers.Vectors
(Index_Type => Positive,
Element_Type => Slots_Envelope_Ptr,
"=" => "=");
type Arena is new Root_Storage_Pool with record
Index : Positive := 1;
-- Indicates which array of slots to first search for a free index
Envelopes : Envelope_Vectors.Vector;
end record;
overriding
procedure Finalize (This : in out Arena);
-- Deallocates all allocated memory from the heap
end Arena_Pools;
package body Arena_Pools is
function Make return Slots_Envelope_Ptr is
Envelope : Slots_Envelope_Ptr := new Slots_Envelope;
begin
Envelope.Free_Indices.Reserve_Capacity (Ada.Containers.Count_Type (MAX));
for I in Slot_Index'Range loop
Envelope.Free_Indices.Append (Free_Index (I));
end loop;
return Envelope;
end Make;
function Make return Arena is
Envelope : Slots_Envelope_Ptr := Make;
begin
return This : Arena do
This.Envelopes.Append (Envelope);
end return;
end Make;
function Determine_Index (Pool : Arena;
Address : System.Address) return Positive is
Searched_For : Natural := 0;
First_Address : System.Address;
Last_Address : System.Address;
begin
for I in Pool.Envelopes.First_Index..Pool.Envelopes.Last_Index loop
First_Address := Pool.Envelopes (I).Items (1)'Address;
Last_Address := Pool.Envelopes (I).Items (Storage_Offset (MAX))'Address;
if
To_Integer (First_Address) <= To_Integer (Address) and
To_Integer (Address) <= To_Integer (Last_Address)
then
Searched_For := I;
exit;
end if;
end loop;
if Searched_For = 0 then
raise Storage_Error;
end if;
return Searched_For;
end Determine_Index;
procedure Allocate
(Pool : in out Arena;
Address : out System.Address;
Size : Storage_Count;
Alignment : Storage_Count)
is
Id : Slot_Index;
begin
if Pool.Envelopes (Pool.Index).Free_Indices.Length > 0 then
Id := Slot_Index (Pool.Envelopes (Pool.Index).Free_Indices.Last_Element);
Pool.Envelopes (Pool.Index).Free_Indices.Delete_Last;
else
declare
Has_Found : Boolean := False;
begin
for I in Pool.Envelopes.First_Index .. Pool.Envelopes.Last_Index loop
if Pool.Envelopes (I).Free_Indices.Length > 0 then
Pool.Index := I;
Id := Slot_Index (Pool.Envelopes (Pool.Index).Free_Indices.Last_Element);
Pool.Envelopes (Pool.Index).Free_Indices.Delete_Last;
Has_Found := True;
exit;
end if;
end loop;
if not Has_Found then
declare
E : Slots_Envelope_Ptr := Make;
begin
Pool.Envelopes.Append (E);
Pool.Index := Pool.Envelopes.Last_Index;
Id := Slot_Index (Pool.Envelopes (Pool.Index).Free_Indices.Last_Element);
Pool.Envelopes (Pool.Index).Free_Indices.Delete_Last;
end;
end if;
end;
end if;
Address := Pool.Envelopes (Pool.Index).Items (Id).Elements'Address;
end Allocate;
procedure Deallocate (Pool : in out Arena;
Address : System.Address;
Size : Storage_Count;
Alignment : Storage_Count)
is
I : constant Positive := Determine_Index (Pool, Address);
First_Address : System.Address;
Last_Address : System.Address;
Slot_Id : Slot_Index;
D : Integer_Address;
begin
First_Address := Pool.Envelopes (I).Items (1)'Address;
Last_Address := Pool.Envelopes (I).Items (Storage_Offset (MAX))'Address;
D := (To_Integer (Last_Address) - To_Integer (First_Address) + Integer_Address (Slot_Size)) / Integer_Address (MAX);
Slot_Id := Slot_Index ((To_Integer (Address) + Integer_Address (Slot_Size) - To_Integer (First_Address))/ D);
Pool.Envelopes (I).Free_Indices.Append (Free_Index (Slot_Id));
end Deallocate;
function Storage_Size (Pool : Arena) return Storage_Count is
Result : Storage_Count := 0;
begin
for Envelope of Pool.Envelopes loop
Result := Storage_Count (Slot_Size*MAX) + Storage_Count (Envelope.Free_Indices.Capacity * 4);
end loop;
return Result;
end Storage_Size;
procedure Free is new Ada.Unchecked_Deallocation (Object => Slots_Envelope,
Name => Slots_Envelope_Ptr);
procedure Finalize (This : in out Arena) is
begin
for Envelope of This.Envelopes loop
Free (Envelope);
end loop;
This.Envelopes.Clear;
end Finalize;
end Arena_Pools;
package Pools is new Arena_Pools (24, 200_000);
Pool : Pools.Arena := Pools.Make;
-- Here ends the definition of the Storage pool and here begins
-- implementation of the algorithm.
package Integer_Random is new Ada.Numerics.Discrete_Random (Integer);
G : Integer_Random.Generator;
type Node;
type Node_Ptr is access all Node with
Storage_Pool => Pool;
type Node is record
Left : Node_Ptr;
Right : Node_Ptr;
X : Integer := 0;
Y : Integer := Integer_Random.Random (G);
end record with
Size => 24*8;
package Tree_Def is
type Tree is tagged private;
function Has_Value (T : in out Tree;
X : in Integer) return Boolean;
procedure Insert (T : in out Tree;
X : in Integer);
procedure Erase (T : in out Tree;
X : in Integer);
private
function Merge (Lower : Node_Ptr;
Greater : Node_Ptr) return Node_Ptr;
function Merge (Lower : Node_Ptr;
Equal : Node_Ptr;
Greater : Node_Ptr) return Node_Ptr;
procedure Split (Orig : in Node_Ptr;
Lower : in out Node_Ptr;
Greater_Or_Equal : in out Node_Ptr;
Value : in Integer);
procedure Split (Orig : in Node_Ptr;
Lower : in out Node_Ptr;
Equal : in out Node_Ptr;
Greater : in out Node_Ptr;
Value : in Integer);
procedure Make_Node (Node : out Node_Ptr;
X : in Integer);
type Tree is tagged record
Root: Node_Ptr := null;
end record;
end Tree_Def;
package body Tree_Def is
procedure Free is new Ada.Unchecked_Deallocation(Object => Node,
Name => Node_Ptr);
procedure Make_Node (Node : out Node_Ptr;
X : in Integer) is
begin
Node := new Main.Node;
Node.X := X;
Node.Y := Integer_Random.Random (G);
end Make_Node;
procedure Delete_Node (Node : in out Node_Ptr) is
begin
if Node /= null then
if Node.Left /= null then
Delete_Node(Node.Left);
end if;
if Node.Right /= null then
Delete_Node (Node.Right);
end if;
Free (Node);
end if;
end Delete_Node;
function Merge (Lower : Node_Ptr;
Greater : Node_Ptr) return Node_Ptr is
begin
if Lower = null then
return Greater;
end if;
if Greater = null then
return lower;
end if;
if Lower.Y < Greater.Y then
Lower.Right := Merge (Lower.Right, Greater);
return Lower;
else
Greater.Left := Merge (Lower, Greater.Left);
return Greater;
end if;
end Merge;
function Merge (Lower : Node_Ptr;
Equal : Node_Ptr;
Greater : Node_Ptr) return Node_Ptr is
begin
return Merge (Merge (Lower, Equal), Greater);
end merge;
procedure Split (Orig : in Node_Ptr;
Lower : in out Node_Ptr;
Greater_Or_Equal : in out Node_Ptr;
Value : in Integer) is
begin
if Orig = null then
Lower := null;
Greater_Or_Equal := null;
return;
end if;
if Orig.X < Value then
Lower := Orig;
Split (Lower.Right, Lower.Right, Greater_Or_Equal, Value);
else
Greater_Or_Equal := Orig;
Split (Greater_Or_Equal.Left, Lower, Greater_Or_Equal.Left, Value);
end if;
end Split;
procedure Split (Orig : in Node_Ptr;
Lower : in out Node_Ptr;
Equal : in out Node_Ptr;
Greater : in out Node_Ptr;
Value : in Integer)
is
Equal_Or_Greater: Node_Ptr;
begin
Split (Orig, Lower, Equal_Or_Greater, Value);
Split (Equal_Or_Greater, Equal, Greater, Value + 1);
end Split;
function Has_Value (T : in out Tree;
X : in Integer) return Boolean
is
Lower : Node_Ptr;
Equal : Node_Ptr;
Greater : Node_Ptr;
Result : Boolean;
begin
Split (T.Root, Lower, Equal, Greater, X);
Result := Equal /= null;
T.Root := Merge (Lower, Equal, Greater);
return Result;
end Has_Value;
procedure Insert (T : in out Tree;
X : in Integer)
is
Lower : Node_Ptr;
Equal : Node_Ptr;
Greater : Node_Ptr;
begin
Split (T.Root, Lower, Equal, Greater, X);
if Equal = null then
Make_Node (Equal, X);
end if;
T.Root := Merge (Lower, Equal, Greater);
end Insert;
procedure Erase (T : in out Tree;
X : in Integer) is
Lower : Node_Ptr;
Equal : Node_Ptr;
Greater : Node_Ptr;
begin
Split (T.Root, Lower, Equal, Greater, X);
T.Root := Merge (Lower, Greater);
-- commenting out the following line
-- doesn't seem to affect running time by much, if at all
Delete_Node (Equal);
end Erase;
end Tree_Def;
Tree : Tree_Def.Tree;
Current : Integer := 5;
Result : Integer := 0;
Mode : Integer;
begin
Integer_Random.Reset (G);
for I in 1..1_000_000 loop
Mode := I mod 3;
Current := (Current * 57 + 43) mod 10007;
if Mode = 0 then
Tree.Insert (Current);
elsif Mode = 1 then
Tree.Erase (Current);
else
Result := Result + (if Tree.Has_Value (Current) then 1 else 0);
end if;
end loop;
Put_Line (Result);
end Main;
^ permalink raw reply [relevance 4%]
* Re: Memory pools
@ 2018-05-31 19:28 5% ` gorgelo
2018-05-31 19:33 4% ` gorgelo
1 sibling, 0 replies; 200+ results
From: gorgelo @ 2018-05-31 19:28 UTC (permalink / raw)
Here is an example of an unbounded storage pool that handles deallocations and is used for allocating 3 Integers inside it and then deallocating them:
with System.Storage_Elements;
with System.Storage_Pools;
with Ada.Text_IO;
with Ada.Integer_Text_IO;
with Ada.Containers.Vectors;
with Ada.Unchecked_Deallocation;
procedure Main is
subtype Storage_Offset is System.Storage_Elements.Storage_Offset;
subtype Storage_Count is System.Storage_Elements.Storage_Count;
subtype Storage_Array is System.Storage_Elements.Storage_Array;
subtype Root_Storage_Pool is System.Storage_Pools.Root_Storage_Pool;
subtype Integer_Address is System.Storage_Elements.Integer_Address;
use type Ada.Containers.Count_Type;
use type Storage_Offset;
use type Integer_Address;
procedure Put (Text : String) renames Ada.Text_IO.Put;
procedure Put_Line (Text : String) renames Ada.Text_IO.Put_Line;
procedure Put_Line (I : Integer) is
begin
Ada.Integer_Text_IO.Put (I);
Ada.Text_IO.New_Line;
end Put_Line;
procedure Put (I : Integer) is
begin
Ada.Integer_Text_IO.Put (I, 0);
end Put;
procedure Put (I : Storage_Offset) is
begin
Ada.Integer_Text_IO.Put (Integer (I), 0);
end Put;
function To_Integer (Value : System.Address) return Integer_Address
renames System.Storage_Elements.To_Integer;
package Arena_Pools is
type Arena (<>) is new Root_Storage_Pool with private;
function Make return Arena;
overriding
procedure Allocate
( Pool : in out Arena;
Address : out System.Address;
Size : Storage_Count;
Alignment : Storage_Count
);
overriding
procedure Deallocate
( Pool : in out Arena;
Address : System.Address;
Size : Storage_Count;
Alignment : Storage_Count
);
overriding
function Storage_Size (Pool : Arena) return Storage_Count;
-- Approximation of how many Storage Elements (bytes)
-- have been heap-allocated.
private
Slot_Size : constant := 20;
-- Specifies the size of each slot in Storage Elements (bytes)
-- Must be big enough to store any object one wishes to allocate
-- inside the memory pool.
type Slot is record
Elements : Storage_Array (1..Slot_Size);
end record;
MAX : constant := 200_000;
-- Specifies the number of slots that will be allocated in an array
-- from the heap every time more memory needs to be pre-allocated.
subtype Slot_Index is Storage_Offset range 1..MAX;
type Slots_Array is array (Slot_Index) of Slot;
subtype Free_Index is Integer range 1..MAX;
-- This Integer type (32-bits) is created in order to not use the type
-- Storage_Offset (64-bits) in the free indices vector.
package Indices_Vector is new Ada.Containers.Vectors
(Index_Type => Positive,
Element_Type => Free_Index,
"=" => "=");
type Slots_Envelope is record
Items : Slots_Array;
Free_Indices : Indices_Vector.Vector;
end record;
type Slots_Envelope_Ptr is access all Slots_Envelope;
package Envelope_Vectors is new Ada.Containers.Vectors
(Index_Type => Positive,
Element_Type => Slots_Envelope_Ptr,
"=" => "=");
type Arena is new Root_Storage_Pool with record
Index : Positive := 1;
-- Indicates which array of slots to first search for a free index
Envelopes : Envelope_Vectors.Vector;
end record;
overriding
procedure Finalize (This : in out Arena);
-- Deallocates all allocated memory from the heap
end Arena_Pools;
package body Arena_Pools is
function Make return Slots_Envelope_Ptr is
Envelope : Slots_Envelope_Ptr := new Slots_Envelope;
begin
Envelope.Free_Indices.Reserve_Capacity (MAX);
for I in Slot_Index'Range loop
Envelope.Free_Indices.Append (Free_Index (I));
end loop;
return Envelope;
end Make;
function Make return Arena is
Envelope : Slots_Envelope_Ptr := Make;
begin
return This : Arena do
This.Envelopes.Append (Envelope);
end return;
end Make;
function Determine_Index (Pool : Arena;
Address : System.Address) return Positive is
Searched_For : Natural := 0;
First_Address : System.Address;
Last_Address : System.Address;
begin
for I in Pool.Envelopes.First_Index..Pool.Envelopes.Last_Index loop
First_Address := Pool.Envelopes (I).Items (1)'Address;
Last_Address := Pool.Envelopes (I).Items (MAX)'Address;
if
To_Integer (First_Address) <= To_Integer (Address) and
To_Integer (Address) <= To_Integer (Last_Address)
then
Searched_For := I;
exit;
end if;
end loop;
if Searched_For = 0 then
raise Storage_Error;
end if;
return Searched_For;
end Determine_Index;
procedure Allocate
(Pool : in out Arena;
Address : out System.Address;
Size : Storage_Count;
Alignment : Storage_Count)
is
Id : Slot_Index;
begin
if Pool.Envelopes (Pool.Index).Free_Indices.Length > 0 then
Id := Slot_Index (Pool.Envelopes (Pool.Index).Free_Indices.Last_Element);
Pool.Envelopes (Pool.Index).Free_Indices.Delete_Last;
else
declare
Has_Found : Boolean := False;
begin
for I in Pool.Envelopes.First_Index .. Pool.Envelopes.Last_Index loop
if Pool.Envelopes (I).Free_Indices.Length > 0 then
Pool.Index := I;
Id := Slot_Index (Pool.Envelopes (Pool.Index).Free_Indices.Last_Element);
Pool.Envelopes (Pool.Index).Free_Indices.Delete_Last;
Has_Found := True;
exit;
end if;
end loop;
if not Has_Found then
declare
E : Slots_Envelope_Ptr := Make;
begin
Pool.Envelopes.Append (E);
Pool.Index := Pool.Envelopes.Last_Index;
Id := Slot_Index (Pool.Envelopes (Pool.Index).Free_Indices.Last_Element);
Pool.Envelopes (Pool.Index).Free_Indices.Delete_Last;
end;
end if;
end;
end if;
Put ("Will allocate (array, slot) := (");
Put (Pool.Index);
Put (",");
Put (Id);
Put_Line (")");
Address := Pool.Envelopes (Pool.Index).Items (Id).Elements'Address;
end Allocate;
procedure Deallocate (Pool : in out Arena;
Address : System.Address;
Size : Storage_Count;
Alignment : Storage_Count)
is
I : constant Positive := Determine_Index (Pool, Address);
First_Address : System.Address;
Last_Address : System.Address;
Slot_Id : Slot_Index;
D : Integer_Address;
begin
First_Address := Pool.Envelopes (I).Items (1)'Address;
Last_Address := Pool.Envelopes (I).Items (MAX)'Address;
D := (To_Integer (Last_Address) - To_Integer (First_Address) + Slot_Size) / MAX;
Slot_Id := Slot_Index ((To_Integer (Address) + Slot_Size - To_Integer (First_Address))/ D);
Pool.Envelopes (I).Free_Indices.Append (Free_Index (Slot_Id));
Put ("Deallocate (array, slot) := (");
Put (I);
Put (",");
Put (Slot_Id);
Put_Line (")");
end Deallocate;
function Storage_Size (Pool : Arena) return Storage_Count is
Result : Storage_Count := 0;
begin
for Envelope of Pool.Envelopes loop
Result := Slot_Size*MAX + Storage_Count (Envelope.Free_Indices.Capacity * 4);
end loop;
return Result;
end Storage_Size;
procedure Free is new Ada.Unchecked_Deallocation (Object => Slots_Envelope,
Name => Slots_Envelope_Ptr);
procedure Finalize (This : in out Arena) is
begin
for Envelope of This.Envelopes loop
Free (Envelope);
end loop;
This.Envelopes.Clear;
Put_Line ("Deallocated all heap-allocated memory");
end Finalize;
end Arena_Pools;
Pool : Arena_Pools.Arena := Arena_Pools.Make;
type Integer_Ptr is access Integer with
Storage_Pool => Pool;
procedure Free is new Ada.Unchecked_Deallocation (Object => Integer,
Name => Integer_Ptr);
X : Integer_Ptr := new Integer'(1);
Y : Integer_Ptr := new Integer'(2);
Z : Integer_Ptr := new Integer'(3);
begin
Free (X);
Free (Y);
Free (Z);
Put_Line ("Has allocated" & Pool.Storage_Size'Image & " bytes.");
end Main;
It has the following output:
Will allocate (array, slot) := (1,200000)
Will allocate (array, slot) := (1,199999)
Will allocate (array, slot) := (1,199998)
Deallocate (array, slot) := (1,200000)
Deallocate (array, slot) := (1,199999)
Deallocate (array, slot) := (1,199998)
Has allocated 4800000 bytes.
Deallocated all heap-allocated memory
The implementation is inspired from Rosetta stone Arena pools:
http://rosettacode.org/wiki/Arena_storage_pool#Ada
^ permalink raw reply [relevance 5%]
* Re: How to get Ada to ?cross the chasm??
@ 2018-05-11 7:21 8% ` Niklas Holsti
0 siblings, 0 replies; 200+ results
From: Niklas Holsti @ 2018-05-11 7:21 UTC (permalink / raw)
On 18-05-11 01:52 , Paul Rubin wrote:
> "Randy Brukardt" <randy@rrsoftware.com> writes:
>> No wonder you don't understand: Ada 95 had none of the container stuff or
>> other features that reduces the memory management burden without using GC.
>> At a minimum, you need to consider Ada 2005, but the most recent Ada is
>> best.
>
> Ah, ok, I was also going by
>
> http://cowlark.com/2014-04-27-ada/index.html
>
> which claims Ada has no standardized way to release allocated memory (so
> each implementation had its own way).
That summary of Ada has many inaccuracies, but mostly minor ones. Pity
that they have not been corrected (some of the examples are
syntactically wrong, too).
For releasing allocated heap memory, Ada.Unchecked_Deallocation is just
as standard as "free" in C. People are just scared by the name, and by
the asymmetry between the simple, primitive "new" keyword and the long
library-level name Unchecked_Deallocation.
Logically, perhaps Ada should not have included a "new" keyword to
allocate heap memory, but should have had something like a generic
library function Ada.Unchecked_Allocation, which is "unchecked" in the
sense that there is no guarantee that the allocated memory will be
released when no longer needed. I can imagine the confusion that would
have caused...
> If you can suggest a good place
> to read about the current standard method I'd appreciate it.
The idea is just to use the standard containers, including the ones that
can handle indefinite types like String, instead of doing "new" and
Unchecked_Deallocation yourself. And to use cursors pointing to elements
of a container, instead of using visible access types. The containers
then manage the heap allocations and releases.
However, I don't think this method will free you from worrying about
dangling references -- I believe a cursor can be left dangling, just as
an access value can be. (I haven't yet had occasion to do such
container-centric Ada programming, although I have used the Ada
containers in less central roles.)
--
Niklas Holsti
Tidorum Ltd
niklas holsti tidorum fi
. @ .
^ permalink raw reply [relevance 8%]
* Augmented active object pattern
@ 2018-04-18 8:01 4% Dmitry A. Kazakov
0 siblings, 0 replies; 200+ results
From: Dmitry A. Kazakov @ 2018-04-18 8:01 UTC (permalink / raw)
The following is a way to have an encapsulated task (active object etc)
which hopefully works around most of the language issues.
type Object_Type;
task type Worker_Task (Owner : not null access Object_Type'Class) is
entry Quit;
... -- other entries
end Worker_Task;
type Worker_Ptr is access all Worker_Type;
type Object_Type is new Ada.Finalization.Limited_Controlled with
Worker : Worker_Ptr;
...
end record;
overriding procedure Finalize (Object : in out Object_Type);
This was the usual part.
----------------------------------------------------
task body Worker_Task is
begin
while Is_Callable (Environment_Task) loop
select
accept Quit;
exit;
or ... -- other entries
else -- or delay
null;
end select;
.. -- Doing a chunk of main job
end loop;
end Worker_Task;
procedure Finalize (Object : in out Object_Type) is
procedure Free is
new Ada.Unchecked_Deallocation (Worker_Task, Worker_Ptr);
begin
if Object.Worker /= null then
if Environment_Task /= Current_Task
Object.Worker.Quit; -- Request exiting
end if;
while not Object.Worker'Terminated loop
delay 0.001;
end loop;
Free (Object.Worker);
end if;
...
end Finalize;
-----------------------------------------------------
New here is handling the library level finalization deadlock. The task
terminates itself when the environment task is not "callable" emulating
forbidden terminate alternative for this special case. Below the library
level this does not work, so the Quit entry is needed to handle these as
before. In its part Quit does not work (deadlocks) at the master's level.
Within Finalize, we check if things happen on the library level. If not
we request task termination the usual way via entry call to Quit. At the
library level that would deadlock (thanks to RM 7.6.1(4)), so Quit is
not called and task terminates itself recognizing the special case
hidden in Annotated RM C.7.1(10) as a notice.
Note that when the pointer is declared below the library level the
deadlock reemerges and there is no solution to that whatsoever, because
the "callable trick" works exclusively for the environment task.
--
Regards,
Dmitry A. Kazakov
http://www.dmitry-kazakov.de
^ permalink raw reply [relevance 4%]
* Re: Full view of a private partial view cannot be a subtype
2017-12-19 1:01 4% ` Jere
2017-12-19 9:08 0% ` Dmitry A. Kazakov
@ 2017-12-19 19:10 0% ` Stephen Leake
1 sibling, 0 replies; 200+ results
From: Stephen Leake @ 2017-12-19 19:10 UTC (permalink / raw)
On Monday, December 18, 2017 at 7:01:49 PM UTC-6, Jere wrote:
> On Sunday, December 17, 2017 at 10:39:17 AM UTC-5, Dmitry A. Kazakov wrote:
> > On 2017-12-17 16:26, Jere wrote:
> >
> > > my assertion is that:
> > >
> > > subtype Thing is Core_Pkg.Thing;
> > >
> > > procedure Do_Something(The_Thing : in out Thing)
> > > renames Core_Pkg.Do_Something;
> > >
> > >
> > > is easier to both maintain and read than:
> > >
> > > type Thing is new Core_Pkg.Thing with null record;
> > >
> > > procedure Do_Something(The_Thing : in out Thing);
> >
> > But these are two semantically different concepts. Ada's subtype
> > declares an equivalent type [it inherits everything from and exports
> > everything to the base]. Ada's new tagged type declares a new instance
> > of a class. It only inherits.
> >
> > I don't understand how can you exchange one for another.
> >
> > --
> > Regards,
> > Dmitry A. Kazakov
> > http://www.dmitry-kazakov.de
>
> I don't want to exchange one for the other. I have a package that I want
> to provide default arguments to privately but maintain the same exact
> type/operation specification. Subtyping seems more correct than
> inheritance in this case. I'm not trying to define a new type or an
> extension of a type. I just want provide a simpler interface to a
> much more complex generic while hiding part of that so the user doesn't
> accidentally do something they shouldn't.
>
> Something like:
>
> generic
> type Item_Type(<>);
> type Item_Access is access Item_type;
> with procedure Deallocation(Ref : in out Item_Access);
> package Sledgehammer is
> <types>
> <operations>
> private
> <implementation>
> end Sledgehammer;
>
> This would be used in maybe 5% or less of the code base and only
> when absolutely necessary. I want to convert it to:
>
> generic
> type Item_Type(<>) is limited private;
> package Nicer_Package is
> type Item_Access is access Item_Type;
> <same types>
> <same operations>
> private
> procedure Deallocate is new Ada.Unchecked_Deallocation
> (Item_Type,Item_Access);
>
> package Implementation is new Sledgehammer
> (Item_Type => Item_Type,
> Item_Access => Item_Access,
> Deallocation => Deallocate);
>
> <implementation>
> end Nicer_Package;
I had a pattern like that in my original SAL library. I provided "Aux" generics to do the helper instantiations in the simple cases, so the typical use case was:
package My_List_Aux is new Sledgehammer_Aux (Item_Type);
package My_Lists is new Sledgehammer (Item_Type, My_List_Aux.Item_Access, My_List_Aux.Deallocate);
I found that to be a good compromise.
^ permalink raw reply [relevance 0%]
* Re: Full view of a private partial view cannot be a subtype
2017-12-19 9:08 0% ` Dmitry A. Kazakov
@ 2017-12-19 13:08 0% ` Jere
0 siblings, 0 replies; 200+ results
From: Jere @ 2017-12-19 13:08 UTC (permalink / raw)
On Tuesday, December 19, 2017 at 4:08:46 AM UTC-5, Dmitry A. Kazakov wrote:
> On 2017-12-19 02:01, Jere wrote:
> > On Sunday, December 17, 2017 at 10:39:17 AM UTC-5, Dmitry A. Kazakov wrote:
> >> On 2017-12-17 16:26, Jere wrote:
> >>
> > Something like:
> >
> > generic
> > type Item_Type(<>);
> > type Item_Access is access Item_type;
> > with procedure Deallocation(Ref : in out Item_Access);
> > package Sledgehammer is
> > <types>
> > <operations>
> > private
> > <implementation>
> > end Sledgehammer;
> >
> > This would be used in maybe 5% or less of the code base and only
> > when absolutely necessary. I want to convert it to:
> >
> > generic
> > type Item_Type(<>) is limited private;
> > package Nicer_Package is
> > type Item_Access is access Item_Type;
> > <same types>
> > <same operations>
> > private
> > procedure Deallocate is new Ada.Unchecked_Deallocation
> > (Item_Type,Item_Access);
> >
> > package Implementation is new Sledgehammer
> > (Item_Type => Item_Type,
> > Item_Access => Item_Access,
> > Deallocation => Deallocate);
> >
> > <implementation>
> > end Nicer_Package;
> >
> > Since all I am doing is automating the access type and
> > the deallocation operation, I don't think a new type
> > is really the right design. Additionally, I don't want
> > to expose the deallocation operation as it should never
> > be called directly.
>
> How do you create objects?
Explicit. The client does. It's mostly due to the need
for of the incomplete type. I can't make or manage objects
of type Item_Type, so the client has to allocate.
>
> There are two approaches:
>
> 1. Explicit new, implicit deallocate. This works only with containers,
> which should know the access type and the deallocator.
>
> 2. Factory (a Create call), implicit deallocate. This requires reference
> counting or custom GC pool.
>
> P.S., declaring an access type in the public part of a generic is
> suspicious for bad design.
>
Again, it is only for basically to keep the client from having to
specify in 90-95% of the situations where they don't really need it.
The type is never used to create variables. In the more complex
generic, I make the client specify instead, but the simpler one is
just for quick utility and hopefully lack of exposure to the deallocation
routine.
^ permalink raw reply [relevance 0%]
* Re: Full view of a private partial view cannot be a subtype
2017-12-19 1:01 4% ` Jere
@ 2017-12-19 9:08 0% ` Dmitry A. Kazakov
2017-12-19 13:08 0% ` Jere
2017-12-19 19:10 0% ` Stephen Leake
1 sibling, 1 reply; 200+ results
From: Dmitry A. Kazakov @ 2017-12-19 9:08 UTC (permalink / raw)
On 2017-12-19 02:01, Jere wrote:
> On Sunday, December 17, 2017 at 10:39:17 AM UTC-5, Dmitry A. Kazakov wrote:
>> On 2017-12-17 16:26, Jere wrote:
>>
> Something like:
>
> generic
> type Item_Type(<>);
> type Item_Access is access Item_type;
> with procedure Deallocation(Ref : in out Item_Access);
> package Sledgehammer is
> <types>
> <operations>
> private
> <implementation>
> end Sledgehammer;
>
> This would be used in maybe 5% or less of the code base and only
> when absolutely necessary. I want to convert it to:
>
> generic
> type Item_Type(<>) is limited private;
> package Nicer_Package is
> type Item_Access is access Item_Type;
> <same types>
> <same operations>
> private
> procedure Deallocate is new Ada.Unchecked_Deallocation
> (Item_Type,Item_Access);
>
> package Implementation is new Sledgehammer
> (Item_Type => Item_Type,
> Item_Access => Item_Access,
> Deallocation => Deallocate);
>
> <implementation>
> end Nicer_Package;
>
> Since all I am doing is automating the access type and
> the deallocation operation, I don't think a new type
> is really the right design. Additionally, I don't want
> to expose the deallocation operation as it should never
> be called directly.
How do you create objects?
There are two approaches:
1. Explicit new, implicit deallocate. This works only with containers,
which should know the access type and the deallocator.
2. Factory (a Create call), implicit deallocate. This requires reference
counting or custom GC pool.
P.S., declaring an access type in the public part of a generic is
suspicious for bad design.
--
Regards,
Dmitry A. Kazakov
http://www.dmitry-kazakov.de
^ permalink raw reply [relevance 0%]
* Re: Full view of a private partial view cannot be a subtype
@ 2017-12-19 1:01 4% ` Jere
2017-12-19 9:08 0% ` Dmitry A. Kazakov
2017-12-19 19:10 0% ` Stephen Leake
0 siblings, 2 replies; 200+ results
From: Jere @ 2017-12-19 1:01 UTC (permalink / raw)
On Sunday, December 17, 2017 at 10:39:17 AM UTC-5, Dmitry A. Kazakov wrote:
> On 2017-12-17 16:26, Jere wrote:
>
> > my assertion is that:
> >
> > subtype Thing is Core_Pkg.Thing;
> >
> > procedure Do_Something(The_Thing : in out Thing)
> > renames Core_Pkg.Do_Something;
> >
> >
> > is easier to both maintain and read than:
> >
> > type Thing is new Core_Pkg.Thing with null record;
> >
> > procedure Do_Something(The_Thing : in out Thing);
>
> But these are two semantically different concepts. Ada's subtype
> declares an equivalent type [it inherits everything from and exports
> everything to the base]. Ada's new tagged type declares a new instance
> of a class. It only inherits.
>
> I don't understand how can you exchange one for another.
>
> --
> Regards,
> Dmitry A. Kazakov
> http://www.dmitry-kazakov.de
I don't want to exchange one for the other. I have a package that I want
to provide default arguments to privately but maintain the same exact
type/operation specification. Subtyping seems more correct than
inheritance in this case. I'm not trying to define a new type or an
extension of a type. I just want provide a simpler interface to a
much more complex generic while hiding part of that so the user doesn't
accidentally do something they shouldn't.
Something like:
generic
type Item_Type(<>);
type Item_Access is access Item_type;
with procedure Deallocation(Ref : in out Item_Access);
package Sledgehammer is
<types>
<operations>
private
<implementation>
end Sledgehammer;
This would be used in maybe 5% or less of the code base and only
when absolutely necessary. I want to convert it to:
generic
type Item_Type(<>) is limited private;
package Nicer_Package is
type Item_Access is access Item_Type;
<same types>
<same operations>
private
procedure Deallocate is new Ada.Unchecked_Deallocation
(Item_Type,Item_Access);
package Implementation is new Sledgehammer
(Item_Type => Item_Type,
Item_Access => Item_Access,
Deallocation => Deallocate);
<implementation>
end Nicer_Package;
Since all I am doing is automating the access type and
the deallocation operation, I don't think a new type
is really the right design. Additionally, I don't want
to expose the deallocation operation as it should never
be called directly.
Based on earlier conversion from Jeff, it looks like
composition is my best bet since I cannot do it via
subtyping and renames. I was just hoping there was a
way I could do it without adding so much extra stuff
to read and maintain. I don't like decreasing
readability like that. If I am willing to expose the
deallocation operation, then I can just use subtype
and renames (which make more sense to me in this
case) but that's the tradeoff.
^ permalink raw reply [relevance 4%]
* Re: use Ada.Text_IO in main() or Package?
@ 2017-09-14 9:49 5% ` gautier_niouzes
0 siblings, 0 replies; 200+ results
From: gautier_niouzes @ 2017-09-14 9:49 UTC (permalink / raw)
Le jeudi 14 septembre 2017 11:37:41 UTC+2, Mace Ayres a écrit :
> Tks. It does make sense. I haven't been programming much in last decades, never really go into OOP much, but I can see this is going to avoid a lot of issues, and enforces some rigor.
Actually it is just a question of what is depending on what.
Instead of Structures, you can take Ada.Text_IO itself as an example.
In the guts of package Ada.Text_IO, the GNAT run-time library has a package body file: a-textio.adb) with the following lines:
with Ada.Streams; use Ada.Streams;
with Interfaces.C_Streams; use Interfaces.C_Streams;
with System.File_IO;
with System.CRTL;
with System.WCh_Cnv; use System.WCh_Cnv;
with System.WCh_Con; use System.WCh_Con;
with Ada.Unchecked_Conversion;
with Ada.Unchecked_Deallocation;
It makes sense they are there and not expected to be in any Main() or any other referencing Ada.Text_IO.
I've never used System.File_IO for instance and would not: it is GNAT only and unknown in other Ada systems. And there is no need for that.
G.
^ permalink raw reply [relevance 5%]
* Re: Portable memory barrier?
2017-05-18 17:44 4% ` Dmitry A. Kazakov
@ 2017-05-18 21:01 0% ` Randy Brukardt
0 siblings, 0 replies; 200+ results
From: Randy Brukardt @ 2017-05-18 21:01 UTC (permalink / raw)
As I always repeat, the ARG is looking more for problems than for solutions
(we're plenty inventive in that regard). The most useful thing is a problem
statement on the lines of "I can't write a portable <something> algorithm
because Ada doesn't provide any portable <blah> operations". Along with an
explanation of the <something> algorithm.
It's fairly obvious to me that since Atomic only protects a read or a write,
but not both that classic operations like test-and-set can't be (directly)
written using it. Some algorithms can be constructed without test-and-set,
but plenty of others can't be.
I'd think that the feature in question needs to be a low-level as possible
so that it can be implemented as efficiently as possible (if a protected
object is needed to implement it, there is no value to the low-level feature
as anyone can -- and should -- use a PO if that is possible).
I'd have no idea how to implement your generic without resorting to a PO,
which would defeat the purpose. (We recently had this discussion wrt
Suspension_Objects -- they can always be implemented with a PO, but the
entire point was that they ought to be simpler than that. Thus we didn't
make any additional requirements on them and in fact clarified that only one
task is supposed to be calling Suspend_Until_True. The same sort of dynamic
seems to be in effect here.)
Anyway, as I said, I know just enough to be dangerous here. You clearly know
more, so send some comments to Ada-Comment to get a discussion started. Else
it will never make the agenda...and then its pretty certain that no changes
will happen!
Randy.
"Dmitry A. Kazakov" <mailbox@dmitry-kazakov.de> wrote in message
news:ofkmin$1iog$1@gioia.aioe.org...
> On 16/05/2017 00:53, Randy Brukardt wrote:
>> "Dmitry A. Kazakov" <mailbox@dmitry-kazakov.de> wrote in message
>> news:of174q$13o7$1@gioia.aioe.org...
>>> On 11/05/2017 02:35, Randy Brukardt wrote:
>>>
>>>> Still, it would be nice to try something in this area. One could
>>>> imagine
>>>> creating an Annex C test that implemented a lock-free algorithm and
>>>> just
>>>> tried to see if it worked properly.
>>>
>>> The real application used socked communication. The problem I suspect is
>>> that artificial tests would not show problems full-size application
>>> have.
>>> Maybe, a better strategy could be specific low-level tests for atomic
>>> objects used in lock-free algorithms.
>>
>> That's what I was thinking. But I'm not really the person to propose such
>> tests, I know just enough to be dangerous. ;-) I'd be much better served
>> being just an editor on such tests, as I wouldn't have too much trouble
>> seeing things that need to be more portable (I have a lot of experience
>> doing that).
>>
>>> And we really should extend the Annex C with some basic atomic
>>> operations
>>> like atomic increment, test-then-increment, test-then-exchange etc, all
>>> falling back to protected objects if the machine lacks corresponding
>>> instructions.
>>
>> I think you are right about that. Supposedly, implementations are
>> supposed
>> to provide access to such things via machine code insertions, but that is
>> never going to be portable (even to other implementations for the same
>> target). So that's not really helpful.
>>
>> Perhaps you could to send a problem statement and brief proposal to
>> Ada-Comment? There's still time to make suggestions for Ada 2020, and
>> tasking issues of all kinds are right in the wheelhouse of what we're
>> hoping
>> to accomplish. (As always, the ARG can find ways to solve problems, the
>> real
>> issue is knowing what the problems are. I believe that you are saying
>> that
>> creating portable lock-free algorithms are harder than necessary because
>> of
>> limitations in what can be atomic and what can be safely done with atomic
>> objects. That seems like an important problem for the ARG to spend some
>> time
>> on.)
>
> I was thinking about something slightly higher level than tedious CAS.
> E.g. predefined generic package:
>
> generic
> type Value_Type is (<>);
> Initial_Value : Value_Type'Base;
> package Atomic_Object is
> --
> -- Holder_Type -- Type of the atomic object to keep Value_Type'Base
> --
> type Holder_Type is private;
> pragma Atomic (Holder_Type); -- It is a private type,
> -- so it must be safe to assign
> --
> -- Get actual value
> --
> function Load (Item : Holder_Type) return Value_Type'Base;
> --
> -- Set new value
> --
> procedure Store (Item : in out Holder_Type;
> New_Value : Value_Type'Base);
> procedure Store (Item : in out Holder;
> New_Value : Value_Type'Base;
> Old_Value : out Value_Type'Base);
> --
> -- Compare old value to the barrier and if successful
> -- store new value
> --
> procedure Store_If_Greater (Item : in out Holder_Type;
> Barrier : Value_Type'Base;
> New_Value : Value_Type'Base);
> procedure Store_If_Greater (Item : in out Holder_Type;
> Barrier : Value_Type'Base;
> New_Value : Value_Type'Base;
> Old_Value : out Value_Type'Base);
> procedure Store_If_Equal ...
> procedure Store_If_Inequal ...
> procedure Store_If_Less ...
> procedure Store_If_Greater ...
> --
> -- Increment value
> --
> procedure Increment (Item : in out Holder;
> Increment : Value_Type'Base);
> procedure Increment (Item : in out Holder;
> Increment : Value_Type'Base;
> Old_Value : out Value_Type'Base);
> --
> -- Compare old value to the barrier and if successful increment
> --
> procedure Increment_If_Greater (Item : in out Holder_Type;
> Barrier : Value_Type'Base;
> Increment : Value_Type'Base);
> procedure Increment_If_Greater (Item : in out Holder_Type;
> Barrier : Value_Type'Base;
> Increment : Value_Type'Base;
> Old_Value : out Value_Type'Base);
> procedure Increment_If_Equal ...
> procedure Increment_If_Inequal ...
> procedure Increment_If_Less ...
> procedure Increment_If_Greater ...
>
> end Atomic_Object;
>
> The implementation should be free to use machine instructions, a
> spin-lock, or a protected object.
>
> Example: reference counted object:
>
> type Count_Type is mod 2**32;
> package Atomic_Counters is new Atomic_Object (Count_Type, 0);
>
> type Reference_Counted is record
> Use_Count : Atomic_Counters.Holder_Type;
> ...
> end record;
>
> type Reference_Counted_Ptr is access all Reference_Counted;
> procedure Free is new Ada.Unchecked_Deallocation (Reference_Counted,
> Reference_Counted_Ptr);
> type Handle is new Ada.Finalization.Controlled with record
> Target : Reference_Counted_Ptr;
> end record;
>
> procedure Adjust (Pointer : in out Handle) is
> begin -- Could check overflows using Increment_If_Less
> Atomic_Counters.Increment (Pointer.Target.Use_Count, 1);
> end Adjust;
>
> procedure Finalize (Pointer : in out Handle) is
> Old_Value : Count_Type;
> begin
> if Pointer.Target /= null then
> Atomic_Counters.Increment_If_Greater
> ( Item => Pointer.Target.Use_Count,
> Barrier => 0,
> Increment => 0 - 1, -- Decrement by 1
> Old_Value => Old_Value
> );
> case Old_Value is
> when 0 => -- Use count is unexpectedly 0
> raise Program_Error;
> when 1 => -- Going to destroy the target
> Free (Pointer.Target);
> when others =>
> null;
> end case;
> end if;
> end Finalize;
>
> --
> Regards,
> Dmitry A. Kazakov
> http://www.dmitry-kazakov.de
^ permalink raw reply [relevance 0%]
* Re: Portable memory barrier?
@ 2017-05-18 17:44 4% ` Dmitry A. Kazakov
2017-05-18 21:01 0% ` Randy Brukardt
0 siblings, 1 reply; 200+ results
From: Dmitry A. Kazakov @ 2017-05-18 17:44 UTC (permalink / raw)
On 16/05/2017 00:53, Randy Brukardt wrote:
> "Dmitry A. Kazakov" <mailbox@dmitry-kazakov.de> wrote in message
> news:of174q$13o7$1@gioia.aioe.org...
>> On 11/05/2017 02:35, Randy Brukardt wrote:
>>
>>> Still, it would be nice to try something in this area. One could imagine
>>> creating an Annex C test that implemented a lock-free algorithm and just
>>> tried to see if it worked properly.
>>
>> The real application used socked communication. The problem I suspect is
>> that artificial tests would not show problems full-size application have.
>> Maybe, a better strategy could be specific low-level tests for atomic
>> objects used in lock-free algorithms.
>
> That's what I was thinking. But I'm not really the person to propose such
> tests, I know just enough to be dangerous. ;-) I'd be much better served
> being just an editor on such tests, as I wouldn't have too much trouble
> seeing things that need to be more portable (I have a lot of experience
> doing that).
>
>> And we really should extend the Annex C with some basic atomic operations
>> like atomic increment, test-then-increment, test-then-exchange etc, all
>> falling back to protected objects if the machine lacks corresponding
>> instructions.
>
> I think you are right about that. Supposedly, implementations are supposed
> to provide access to such things via machine code insertions, but that is
> never going to be portable (even to other implementations for the same
> target). So that's not really helpful.
>
> Perhaps you could to send a problem statement and brief proposal to
> Ada-Comment? There's still time to make suggestions for Ada 2020, and
> tasking issues of all kinds are right in the wheelhouse of what we're hoping
> to accomplish. (As always, the ARG can find ways to solve problems, the real
> issue is knowing what the problems are. I believe that you are saying that
> creating portable lock-free algorithms are harder than necessary because of
> limitations in what can be atomic and what can be safely done with atomic
> objects. That seems like an important problem for the ARG to spend some time
> on.)
I was thinking about something slightly higher level than tedious CAS.
E.g. predefined generic package:
generic
type Value_Type is (<>);
Initial_Value : Value_Type'Base;
package Atomic_Object is
--
-- Holder_Type -- Type of the atomic object to keep Value_Type'Base
--
type Holder_Type is private;
pragma Atomic (Holder_Type); -- It is a private type,
-- so it must be safe to assign
--
-- Get actual value
--
function Load (Item : Holder_Type) return Value_Type'Base;
--
-- Set new value
--
procedure Store (Item : in out Holder_Type;
New_Value : Value_Type'Base);
procedure Store (Item : in out Holder;
New_Value : Value_Type'Base;
Old_Value : out Value_Type'Base);
--
-- Compare old value to the barrier and if successful
-- store new value
--
procedure Store_If_Greater (Item : in out Holder_Type;
Barrier : Value_Type'Base;
New_Value : Value_Type'Base);
procedure Store_If_Greater (Item : in out Holder_Type;
Barrier : Value_Type'Base;
New_Value : Value_Type'Base;
Old_Value : out Value_Type'Base);
procedure Store_If_Equal ...
procedure Store_If_Inequal ...
procedure Store_If_Less ...
procedure Store_If_Greater ...
--
-- Increment value
--
procedure Increment (Item : in out Holder;
Increment : Value_Type'Base);
procedure Increment (Item : in out Holder;
Increment : Value_Type'Base;
Old_Value : out Value_Type'Base);
--
-- Compare old value to the barrier and if successful increment
--
procedure Increment_If_Greater (Item : in out Holder_Type;
Barrier : Value_Type'Base;
Increment : Value_Type'Base);
procedure Increment_If_Greater (Item : in out Holder_Type;
Barrier : Value_Type'Base;
Increment : Value_Type'Base;
Old_Value : out Value_Type'Base);
procedure Increment_If_Equal ...
procedure Increment_If_Inequal ...
procedure Increment_If_Less ...
procedure Increment_If_Greater ...
end Atomic_Object;
The implementation should be free to use machine instructions, a
spin-lock, or a protected object.
Example: reference counted object:
type Count_Type is mod 2**32;
package Atomic_Counters is new Atomic_Object (Count_Type, 0);
type Reference_Counted is record
Use_Count : Atomic_Counters.Holder_Type;
...
end record;
type Reference_Counted_Ptr is access all Reference_Counted;
procedure Free is new Ada.Unchecked_Deallocation (Reference_Counted,
Reference_Counted_Ptr);
type Handle is new Ada.Finalization.Controlled with record
Target : Reference_Counted_Ptr;
end record;
procedure Adjust (Pointer : in out Handle) is
begin -- Could check overflows using Increment_If_Less
Atomic_Counters.Increment (Pointer.Target.Use_Count, 1);
end Adjust;
procedure Finalize (Pointer : in out Handle) is
Old_Value : Count_Type;
begin
if Pointer.Target /= null then
Atomic_Counters.Increment_If_Greater
( Item => Pointer.Target.Use_Count,
Barrier => 0,
Increment => 0 - 1, -- Decrement by 1
Old_Value => Old_Value
);
case Old_Value is
when 0 => -- Use count is unexpectedly 0
raise Program_Error;
when 1 => -- Going to destroy the target
Free (Pointer.Target);
when others =>
null;
end case;
end if;
end Finalize;
--
Regards,
Dmitry A. Kazakov
http://www.dmitry-kazakov.de
^ permalink raw reply [relevance 4%]
* Re: zLibAda vs ZipAda (which should I use, if any)?
@ 2016-08-27 19:15 5% ` gautier_niouzes
0 siblings, 0 replies; 200+ results
From: gautier_niouzes @ 2016-08-27 19:15 UTC (permalink / raw)
Le samedi 27 août 2016 18:31:30 UTC+2, Aurele a écrit :
> Hi Gautier, I think your GID packages will provide the services I need. Very well done by the way.
>
> Maybe you can save me some time and guide me on its use for my needs. I've inserted some code below that show how I'll load the images from the zip file using Zip-Ada, I arrange the data (not shown), and then I need to call GID procedure to load as Handle.
>
> Any comments or ideas?
>
> declare
>
> package ASU renames Ada.Strings.Unbounded;
>
> type Entry_ID is new Integer range -1..Integer'Last;
>
> type iEntry is record
> Texture_ID : ZipFile.Entry_ID;
> FullName : Ada.Strings.Unbounded.Unbounded_String;
> Directory : Ada.Strings.Unbounded.Unbounded_String;
> EntryName : Ada.Strings.Unbounded.Unbounded_String;
> Extension : Ada.Strings.Unbounded.Unbounded_String;
> end record;
> type iEntryEntry_Ptr is access all ZipFile.iEntry;
>
> subtype iEntry_Array_Size is Entry_ID;
>
> type iEntry_Array is array ( iEntry_Array_Size range <> ) of aliased ZipFile.iEntry;
> type iEntry_Array_Ptr is access all ZipFile.iEntry_Array;
>
> type Information is record
> File_Location : Ada.Strings.Unbounded.Unbounded_String;
> File_Name : Ada.Strings.Unbounded.Unbounded_String;
> Total_Entries : Natural;
> Texture_Entries : Natural;
> Data_Ptr : ZipFile.iEntry_Array_Ptr;
> end record;
> type Information_Ptr is access all ZipFile.Information;
>
> Zip_File_Name : constant String := "Textures.zip";
> Zip_File_Entries : iEntry_Array_Size;
>
> lpTexture_Array : aliased iEntry_Array_Ptr;
> lpTexture_Info : aliased Information_Ptr
>
> Local_Index : Entry_ID;
>
> ZipFileInfo : Zip.Zip_Info;
> FileType : UnZip.Streams.Zipped_File_Type;
>
> -----------------------------------------------------------------
> begin
>
> Zip.Load( ZipFileInfo, Zip_File_Name );
>
> Zip_File_Entries := iEntry_Array_Size( Zip.Entries( ZipFileInfo ) );
>
> lpTexture_Array := new ZipFile.iEntry_Array( 1..Zip_File_Entries );
> lpTexture_Info := new ZipFile.Information;
>
> -- Scan procedure not shown here but is straight forward...
> Scan( ZipFileInfo, FileName, Info_Ptr ); -- FILL INFO_PTR
>
> -- Simple test.... try to retrieve an image at index = 10
>
> Local_Index := 10; -- TEST: image at index = 10
>
> UnZip.Streams.Open
> ( File => FileType,
> Archive_Info => ZipFileInfo,
> Name => ASU.To_String( Info_Ptr.Data_Ptr( Local_Index ).FullName )
> );
>
> -- ???????????????????????????????????????????????????????
> -- LoadImage is below, no idea yet what has to be done
>
> LoadImage( FileNeme => Info_Ptr.Data_Ptr( Local_Index ).EntryName,
> FileExt => Info_Ptr.Data_Ptr( Local_Index ).Extension,
> FullName => Ada.Streams.Stream_IO.Stream_Access( UnZip.Streams.Stream( FileType ) ) );
>
> UnZip.Streams.Close( FileType );
>
> end;
>
>
> -----------------------------------------------------------------
> - TBD: Call "GID" procedure to load image (DIB or BMP (bitmap))
>
> type Hande is access all System.Address;
> hBitmap : Hande := NULL;
>
> procedure LoadImage ( FileName : Ada.Strings.Unbounded.Unbounded_String;
> FileExt : Ada.Strings.Unbounded.Unbounded_String;
> FullName : Ada.Strings.Unbounded.Unbounded_String ) is
> begin
> -- --------------------------
> hBitmap := ?; -- Call GID directly here ??? Steps ????
> -----------------------------
> end LoadImage;
>
> -----------------------------------------------------------------
>
> Cheers and thanks
> Aurele
I'm just copy-pasting useful things from the To_BMP example, which will be ok for a Windows bitmap. I skip the image rotation stuff to simplify...
type Byte_Array is array(Integer range <>) of Unsigned_8;
type p_Byte_Array is access Byte_Array;
procedure Dispose is new Ada.Unchecked_Deallocation(Byte_Array, p_Byte_Array);
img_buf: p_Byte_Array:= null;
procedure Load_raw_image(
image : in out GID.Image_descriptor;
buffer: in out p_Byte_Array
)
is
subtype Primary_color_range is Unsigned_8;
subtype U16 is Unsigned_16;
image_width: constant Positive:= GID.Pixel_width(image);
image_height: constant Positive:= GID.Pixel_height(image);
padded_line_size_x: constant Positive:=
4 * Integer(Float'Ceiling(Float(image_width) * 3.0 / 4.0));
padded_line_size_y: constant Positive:=
4 * Integer(Float'Ceiling(Float(image_height) * 3.0 / 4.0));
-- (in bytes)
idx: Integer;
--
procedure Set_X_Y (x, y: Natural) is
pragma Inline(Set_X_Y);
begin
idx:= 3 * x + padded_line_size_x * y;
end Set_X_Y;
--
procedure Put_Pixel_without_bkg (
red, green, blue : Primary_color_range;
alpha : Primary_color_range
)
is
pragma Inline(Put_Pixel_without_bkg);
pragma Warnings(off, alpha); -- alpha is just ignored
begin
buffer(idx..idx+2):= (blue, green, red);
-- GID requires us to look to next pixel for next time:
idx:= idx + 3;
end Put_Pixel_without_bkg;
--
procedure BMP24_Load_without_bkg is
new GID.Load_image_contents(
Primary_color_range,
Set_X_Y,
Put_Pixel_without_bkg,
Feedback,
GID.fast
);
next_frame: Ada.Calendar.Day_Duration;
begin
Dispose(buffer);
buffer:= new Byte_Array(0..padded_line_size_x * GID.Pixel_height(image) - 1);
BMP24_Load_without_bkg(image, next_frame);
end Load_raw_image;
...
i: GID.Image_descriptor;
begin
GID.Load_image_header(i, Your_nice_stream_Access.all, True);
Load_raw_image(i, img_buf);
end;
Now you surely know better how to let the image buffer (img_buf) meet the hBitmap handle (some Windows-ish bureaucracy ;-) )
_________________________
Gautier's Ada programming
http://gautiersblog.blogspot.com/search/label/Ada
NB: follow the above link for a valid e-mail address
^ permalink raw reply [relevance 5%]
* Re: Finalization and class-wide views
@ 2016-06-16 11:10 6% ` Alejandro R. Mosteo
0 siblings, 0 replies; 200+ results
From: Alejandro R. Mosteo @ 2016-06-16 11:10 UTC (permalink / raw)
As a follow-up I've modified the example with actual memory
allocation/deallocation, and valgrind seems to confirm the brokenness of
the third assignment in the original example.
valgrind --leak-check=full output:
==21058== HEAP SUMMARY:
==21058== in use at exit: 2,664 bytes in 666 blocks
==21058== total heap usage: 2,670 allocs, 2,004 frees, 10,680 bytes
allocated
==21058==
==21058== 2,664 bytes in 666 blocks are definitely lost in loss record 1
of 1
==21058== at 0x4C2DB8F: malloc (in
/usr/lib/valgrind/vgpreload_memcheck-amd64-linux.so)
==21058== by 0x41623C: __gnat_malloc (in
/home/jano/local/rxada/obj/finalize_leak)
==21058== by 0x402B0A: finalize_leak__pp__adjust.3673
(finalize_leak.adb:30)
==21058== by 0x402B4D: finalize_leak__pp__twoDA.3946
(finalize_leak.adb:32)
==21058== by 0x404D96: _ada_finalize_leak (finalize_leak.adb:67)
==21058== by 0x405887: main (b__finalize_leak.adb:241)
==21058==
==21058== LEAK SUMMARY:
==21058== definitely lost: 2,664 bytes in 666 blocks
==21058== indirectly lost: 0 bytes in 0 blocks
==21058== possibly lost: 0 bytes in 0 blocks
==21058== still reachable: 0 bytes in 0 blocks
==21058== suppressed: 0 bytes in 0 blocks
==21058==
==21058== For counts of detected and suppressed errors, rerun with: -v
==21058== ERROR SUMMARY: 1 errors from 1 contexts (suppressed: 0 from 0)
With this I feel confident enough to file a bug report. Here is the
modified program. The type Managed now holds a heap-allocated integer.
with Ada.Finalization; use Ada.Finalization;
with Ada.Text_Io; use Ada.Text_Io;
with Ada.Unchecked_Deallocation;
procedure Finalize_Leak is
generic
package P is
type One is interface;
type Int_Access is access Integer;
type Managed is new Controlled with record
X : Int_Access;
end record;
overriding procedure Adjust (M : in out Managed);
overriding procedure Finalize (M : in out Managed);
function Build (I : Integer) return Managed;
type Two is new One with record
M : Managed := Build (1);
end record;
end P;
package body P is
overriding procedure Adjust (M : in out Managed) is
begin
if M.X /= null then
M.X := new Integer'(M.X.all);
end if;
end Adjust;
overriding procedure Finalize (M : in out Managed) is
procedure Free is
new Ada.Unchecked_Deallocation (Integer, Int_Access);
begin
if M.X /= null then
Free (M.X);
Put_Line ("finalize M with free");
else
Put_Line ("finalize M");
end if;
end Finalize;
function Build (I : Integer) return Managed
is (Managed'(Controlled with X => new Integer'(I)));
end P;
package PP is new P; use PP;
function Pass (X : Two'Class) return One'Class is (X);
function "not" (X : Two'Class) return One'Class is (X);
A : Two;
begin
A.M := Build (1);
for I in 1 .. 666 loop
Put_Line ("----------------------------");
declare
B : One'Class := Pass (A); -- This is properly finalized
begin
Put_Line ("......");
end;
Put_Line ("......");
declare
B : One'Class := not A; -- This is not
begin
Put_Line ("---8<---");
end;
Put_Line ("--->8---");
end loop;
New_Line; Put_Line ("Now A is going to finalize");
end Finalize_Leak;
^ permalink raw reply [relevance 6%]
* Ada 2005,Doubly_Linked_List with Controlled parameter
@ 2016-04-05 2:03 5% George J
0 siblings, 0 replies; 200+ results
From: George J @ 2016-04-05 2:03 UTC (permalink / raw)
Hi all! I'm using Doubly_Linked_List with Controlled param, example here:
----------------------------------------------------------------------
type Info_Record is new Controlled with
record
Name:String_Access;
end record;
type Info is access all Info_Record'Class;
overriding procedure Finalize(Self:in out Info_Record);
package Test_Containers is new Ada.Containers.Doubly_Linked_Lists(Info_Record);
use Test_Containers;
Test_List:Test_Containers.List;
----------------------------------------------------------------------
procedure Free_String is new Ada.Unchecked_Deallocation
(Object => String,
Name => String_Access);
overriding procedure Finalize(Self:in out Info_Record) is
begin
if Self.Name/=null then
Free_String(Self.Name);
end if;
end Finalize;
----------------------------------------------------------------------
procedure Test is
begin
Test_List.Append(Info_Record'(Controlled with
Name => new String'("Test_Name"));
end Test;
----------------------------------------------------------------------
Problem is that after calling "Append"->at once starts Finalization proc, so appended pure line. I just use an access parameter after this "Doubly_Linked_List(Info)", and it's ok now,but i think that i'm wrong,cause Finalization doesn't start with Test_List.Clear and when exiting program. So question is "How I can finalize Doubly_Connected_List Controlled parameter correctly?Or I must not use Controlled parameter in this list?".
Thanks!
^ permalink raw reply [relevance 5%]
* Re: Abortable Timed Action
2016-01-08 20:24 4% ` T.G.
@ 2016-01-09 8:45 0% ` Simon Wright
0 siblings, 0 replies; 200+ results
From: Simon Wright @ 2016-01-09 8:45 UTC (permalink / raw)
"T.G." <anon@anon.org> writes:
> The reason why I had an explicit Finish instead of using terminate was
> that I was thinking of creating the timer dynamically and then freeing
> it with Ada.Unchecked_Deallocation. So I wanted to Finish the task
> before freeing it. I'm not sure if calling Free on an access actually
> terminates the task Normally.
GNAT certainly used to have issues in this area. Indeed, you could abort
the task and then deallocate it, and end with a memory leak (the task
control block wasn't actually freed); the cure was to wait until
'Terminated.
I believe that this is no longer a problem.
> delay until is an interesting idea. I'm assuming that time drift would
> be an issue in periodic actions that repeat at a certain interval, but
> in that case delay until could also have issues if it loses some
> accuracy on each iteration.
The common solution is something like
with Ada.Calendar;
with Ada.Text_IO; use Ada.Text_IO;
procedure Delay_Until is
task T is
entry Exec_After (T : Duration);
end T;
task body T is
Start : Ada.Calendar.Time;
Next : Ada.Calendar.Time;
Interval : Duration;
use type Ada.Calendar.Time;
begin
accept Exec_After (T : Duration) do
Start := Ada.Calendar.Clock;
Next := Start + T;
Interval := T;
end Exec_After;
loop
delay until Next;
Next := Next + Interval; -- *not* Ada.Calendar.Clock + Interval
Put_Line (Duration'Image (Ada.Calendar.Clock - Start));
end loop;
end T;
begin
T.Exec_After (0.5);
end Delay_Until;
^ permalink raw reply [relevance 0%]
* Re: Abortable Timed Action
@ 2016-01-08 20:24 4% ` T.G.
2016-01-09 8:45 0% ` Simon Wright
0 siblings, 1 reply; 200+ results
From: T.G. @ 2016-01-08 20:24 UTC (permalink / raw)
On 2016-01-06, Anh Vo <anhvofrcaus@gmail.com> wrote:
> After looking at your original post again, I believe your code
> should work after replacing delay statement by delay until
> statement. The delay until statement does not have time drifting
> issue. In addition, then Entry Finish can be replaced by the
> terminate alternative. The modified version is shown below.
> select
> accept Cancel;
> or
> delay until (Ada.Calendar.Clock + Timeout);
> Put_Line ("Do Something");
> end select;
The reason why I had an explicit Finish instead of using terminate was
that I was thinking of creating the timer dynamically and then freeing
it with Ada.Unchecked_Deallocation. So I wanted to Finish the task
before freeing it. I'm not sure if calling Free on an access actually
terminates the task Normally.
delay until is an interesting idea. I'm assuming that time drift would
be an issue in periodic actions that repeat at a certain interval, but
in that case delay until could also have issues if it loses some
accuracy on each iteration. For example, modifying the code to run
periodically, with:
Start_Time : Ada.Calendar.Time;
begin
...
accept Exec_After (T : Duration) do
Start_Time := Ada.Calendar.Clock;
Timeout := T;
end Exec_After;
Inner : loop
select
accept Cancel;
exit Inner;
or
delay until (Ada.Calendar.Clock + Timeout);
Put_Line (Duration'Image (Ada.Calendar.Clock - Start_Time));
end select;
end loop Inner;
it will drift, however, we can still use delay until but with a
counter, for example:
task body Timed_Action_Task is
Timeout : Duration;
Start_Time : Ada.Calendar.Time;
Counter : Positive := 1;
begin
loop
select
accept Exec_After (T : Duration) do
Start_Time := Ada.Calendar.Clock;
Timeout := T;
Counter := 1;
end Exec_After;
Inner : loop
select
exit Inner;
accept Cancel;
or
delay until (Start_Time + (Timeout * Counter));
Counter := Counter + 1;
Put_Line (Duration'Image (Ada.Calendar.Clock - Start_Time));
end select;
end loop Inner;
or
terminate;
end select;
end loop;
end Timed_Action_Task;
This avoids the drift from the previous example.
In my actual code, I used Ada.Real_Time.Timing_Events. It ended up
being somewhat complicated, but only because I wanted to pass both
Action and User_Data to the Timer and make a more flexible/reusable
timer. Now after testing the code above, I think I want to recheck my
code for a possible time drift with periodic timed events.
--- news://freenews.netfront.net/ - complaints: news@netfront.net ---
^ permalink raw reply [relevance 4%]
* Re: Running a preprocessor from GPS?
2015-07-28 22:11 6% ` EGarrulo
@ 2015-07-29 20:32 6% ` Randy Brukardt
0 siblings, 0 replies; 200+ results
From: Randy Brukardt @ 2015-07-29 20:32 UTC (permalink / raw)
"EGarrulo" <egarrulo@gmail.com> wrote in message
news:014427b1-ff7a-4a69-82e6-0330af77ed96@googlegroups.com...
> On Tuesday, July 28, 2015 at 11:12:54 PM UTC+2, Randy Brukardt wrote:
>> "EGarrulo" wrote in message
>> >boilerplate code, and this is one such case. Let's add the lack of a
>> >facility like "printf",
>>
>> Not strongly typed.
>
> What do you mean? Common Lisp has FORMAT and it is as strongly typed as
> they can be.
In Ada terms, typing is something done at compile-time. Ada does not have
runtime typing (one could imagine tag checks to be runtime typing, but
that's a check in Ada, not related to typing).
>> >along with a generic type system that can't perform basic type
>> >inference,
>>
>> Would have to weaken the type system.
>
> Do you mean that the compiler is not able to infer the type referenced by
> the access type in
> Ada.Unchecked_Deallocation` because that would weaken the type system?
That's not type inference by my understanding of the term. That's just a
lack of default parameters for generic types (something that I proposed back
in the Ada 2005, but died mainly because of a lack of appropriate syntax).
Nothing would be inferred, any more than the number of lines output by
New_Line is inferred.
Anyway, I can't recall any time in my entire history of Ada (goes back to
1979) where anyone voiced the opinion that the redundancy in
Unchecked_Deallocation is a real problem. You're at least 35 years too late
with that opinion, as Ada.Unchecked_Deallocation goes back to Ada 80 and
probably before that. There's no chance in heck that it would be changed
now.
And on the list of annoyances in Ada, this is *waaayyyy* down the list. #1
for most people is the visibility of operators. Another thing that it is way
too late to fix (and lots of effort has been expended in trying to find a
compatible fix).
>> > and I am beginning to understand why engineers opposed the adoption of
>> > Ada
>> > by the US Department of Defense.
>>
>> Ada is not for people that want to write quick sloppy code (and then
>> debug
>> it for months).
>
> Wanting to write sloppy code and wanting to write only what is necessary
> are
> two different attitudes, don't you agree?
What *you* think is unnecessary might be very valuable in someone else's
context. And they'd view it as "sloppy".
>> Besides, the C++ generics that you are implicitly referring
>> to didn't exist until long after Ada was designed. And they do things
>> which
>> would destroy the Ada contract model of generics (in C++, generics are
>> glorified macros).
>
> Ada generics are fine -- I see no difference in expressiveness versus C++,
> really -- but
> the standard library doesn't seem to make the most of them.
>
> Generics *are* glorified macros anyway, in a sense.
This is an especial sore point with me!
Formally in the Ada RM they are, which causes all manner of nonsense effects
which then get erased by special rules. Stupid.
For Janus/Ada at least, there is nothing macro-like about them: the code
(including the elaboration code for the specification) is fully shared, and
it's the processed declarations that are duplicated for an instantiation,
the source code is not involved in any way.
The language should have been defined describing the entities as being
duplicated, not the source, since that's what happens anyway (binding
happens when the generic is compiled, so in no sense are you duplicating
identifiers).
C++, OTOH, is almost purely a syntax duplication; binding occurs in the
instance, not in the original generic declaration. So the effect is very
different, especially in terms of debuggability (one can reason about Ada
generics because the properties of everything other than the generic formals
are the same for all instances, and the properties of the formals are quite
constrained; that really doesn't work in C++).
Randy.
^ permalink raw reply [relevance 6%]
* Re: Running a preprocessor from GPS?
@ 2015-07-28 22:11 6% ` EGarrulo
2015-07-29 20:32 6% ` Randy Brukardt
0 siblings, 1 reply; 200+ results
From: EGarrulo @ 2015-07-28 22:11 UTC (permalink / raw)
On Tuesday, July 28, 2015 at 11:12:54 PM UTC+2, Randy Brukardt wrote:
> "EGarrulo" wrote in message
> >boilerplate code, and this is one such case. Let's add the lack of a
> >facility like "printf",
>
> Not strongly typed.
What do you mean? Common Lisp has FORMAT and it is as strongly typed as they can be.
> >along with a generic type system that can't perform basic type inference,
>
> Would have to weaken the type system.
Do you mean that the compiler is not able to infer the type referenced by the access type in `Ada.Unchecked_Deallocation` because that would weaken the type system?
> > and I am beginning to understand why engineers opposed the adoption of Ada
> > by the US Department of Defense.
>
> Ada is not for people that want to write quick sloppy code (and then debug
> it for months).
Wanting to write sloppy code and wanting to write only what is necessary are two different attitudes, don't you agree?
> Besides, the C++ generics that you are implicitly referring
> to didn't exist until long after Ada was designed. And they do things which
> would destroy the Ada contract model of generics (in C++, generics are
> glorified macros).
Ada generics are fine -- I see no difference in expressiveness versus C++, really -- but the standard library doesn't seem to make the most of them.
Generics *are* glorified macros anyway, in a sense.
^ permalink raw reply [relevance 6%]
* Re: Why does `Unchecked_Deallocation` need the access type?
2015-07-26 8:54 0% ` Dmitry A. Kazakov
@ 2015-07-26 11:16 8% ` Niklas Holsti
0 siblings, 0 replies; 200+ results
From: Niklas Holsti @ 2015-07-26 11:16 UTC (permalink / raw)
On 15-07-26 11:54 , Dmitry A. Kazakov wrote:
> On Sun, 26 Jul 2015 00:11:22 -0700 (PDT), EGarrulo wrote:
>
>> The `Free` procedure to deallocate an object is declared like this:
>>
>> procedure Free is
>> new Ada.Unchecked_Deallocation(Object_Type, Object_Access_Type);
>>
>> Yet the access parameter seems redundant. Why is it necessary to specify it?
>
> Because the instance of the generic procedure Free has the argument of the
> access type:
>
> procedure Free (Pointer : in out Object_Access_Type);
[snip]
> What is indeed redundant here is the Object_Type. It is necessary because
> Ada does not have access type introspection. That is, you cannot get the
> object type from an access type, though the compiler knows it anyway.
> Surely there should have been an attribute to get that type, e.g.
>
> Pointer_Type'Target
>
> But there is none.
Another reason, perhaps a trivial one, for including Object_Type is that
the only syntax to define a formal access type in a generic declaration
uses an access_type_definition, which requires a name for the object
type. The declaration of Unchecked_Deallocation (RM 12.5.4) has this form:
generic
type Object(<>) is limited private;
type Name is access Object;
procedure Ada.Unchecked_Deallocation(X : in out Name)
...
Ada could perhaps have allowed a formal_access_type_definition with an
unnamed target type, perhaps of the form
type Name is access; -- Not Ada!
or
type Name is access <>; -- Not Ada!
and then the Object formal type could have been omitted from
Unchecked_Deallocation. However, it seems to me that such formal access
types would not be very useful without the 'Target attribute that Dmitry
suggested.
--
Niklas Holsti
Tidorum Ltd
niklas holsti tidorum fi
. @ .
^ permalink raw reply [relevance 8%]
* Re: Why does `Unchecked_Deallocation` need the access type?
2015-07-26 7:11 6% Why does `Unchecked_Deallocation` need the access type? EGarrulo
@ 2015-07-26 8:54 0% ` Dmitry A. Kazakov
2015-07-26 11:16 8% ` Niklas Holsti
0 siblings, 1 reply; 200+ results
From: Dmitry A. Kazakov @ 2015-07-26 8:54 UTC (permalink / raw)
On Sun, 26 Jul 2015 00:11:22 -0700 (PDT), EGarrulo wrote:
> The `Free` procedure to deallocate an object is declared like this:
>
> procedure Free is
> new Ada.Unchecked_Deallocation(Object_Type, Object_Access_Type);
>
> Yet the access parameter seems redundant. Why is it necessary to specify it?
Because the instance of the generic procedure Free has the argument of the
access type:
procedure Free (Pointer : in out Object_Access_Type);
BTW, in Ada you can have as many access types as you wish. With operations
(like Free) of their own. It is sometimes very useful:
type Aphabetic_Ptr is access all String;
function "=" (Left, Right : Aphabetic_Ptr) return Boolean;
function "<" (Left, Right : Aphabetic_Ptr) return Boolean;
type Lexicographical_Ptr is access all String;
function "=" (Left, Right : Lexicographical_Ptr) return Boolean;
function "<" (Left, Right : Lexicographical_Ptr) return Boolean;
Then you create two indices of the same set of strings using different sort
ordering.
What is indeed redundant here is the Object_Type. It is necessary because
Ada does not have access type introspection. That is, you cannot get the
object type from an access type, though the compiler knows it anyway.
Surely there should have been an attribute to get that type, e.g.
Pointer_Type'Target
But there is none.
--
Regards,
Dmitry A. Kazakov
http://www.dmitry-kazakov.de
^ permalink raw reply [relevance 0%]
* Why does `Unchecked_Deallocation` need the access type?
@ 2015-07-26 7:11 6% EGarrulo
2015-07-26 8:54 0% ` Dmitry A. Kazakov
0 siblings, 1 reply; 200+ results
From: EGarrulo @ 2015-07-26 7:11 UTC (permalink / raw)
The `Free` procedure to deallocate an object is declared like this:
procedure Free is
new Ada.Unchecked_Deallocation(Object_Type, Object_Access_Type);
Yet the access parameter seems redundant. Why is it necessary to specify it?
^ permalink raw reply [relevance 6%]
* Re: silly ravenscar question
@ 2015-02-24 15:30 6% ` Brad Moore
0 siblings, 0 replies; 200+ results
From: Brad Moore @ 2015-02-24 15:30 UTC (permalink / raw)
On 15-02-24 04:23 AM, jan.de.kruyf@gmail.com wrote:
>
>>
>>> object_access := new object;
>>>
>>> but I can not free this object.
>>
>> Look for "Unchecked_Deallocation" in the LRM.
>
> but there is no "NO_Unchecked_Deallocation" in the Ravenscar profile (D.13.1)
No_Unchecked_Deallocation is not associated with the Ravenscar profile.
It is also obsolescent. If you want that restriction, you should use
No_Dependence(Ada.Unchecked_Deallocation) in new code.
You might be thinking of the restriction, No_Implicit_Heap_Allocations
which is part of the Ravenscar Profile. That restricts the runtime from
making allocations from the heap, but it does not restrict application
code from using the heap to allocate objecs.
Brad
^ permalink raw reply [relevance 6%]
* Re: silly ravenscar question
2015-02-24 11:24 6% ` J-P. Rosen
@ 2015-02-24 12:10 6% ` jan.de.kruyf
0 siblings, 0 replies; 200+ results
From: jan.de.kruyf @ 2015-02-24 12:10 UTC (permalink / raw)
> 1) Ravenscar is purely about multi-tasking, and says nothing about the
> sequential aspects of the language. Allocators (aka "new") are allowed
> (but may be disallowed in safety critical contexts by other rules).
>
> 2) Did you look into Ada.Unchecked_Deallocation? It is a generic that
> you instantiate to get the equivalent of "free".
>
well . . . , what brought me to this question is that in Gnat for Arm
this works:
Job_Entry : Job_Entry_P_Type := new Job_Entry_Type;
but this combination does not:
procedure Free is
new Ada.Unchecked_Deallocation(Job_Entry_Type, Job_Entry_P_Type);
.
.
Free (Job_Entry);
it complains about some '__gnat' routine thats missing.
-----------------
By the way Mr. Rosen, do you still have the pdf for the original HOOD book available, I meant to ask you for some time already. At the moment my diagram drawing is very understandable to me, but otherwise it is peanut butter on hot toast.
I would think that with a little bit of persuasion Umlet could make HOOD diagrams quite beautifully.
Thanks,
j.
^ permalink raw reply [relevance 6%]
* Re: silly ravenscar question
@ 2015-02-24 11:24 6% ` J-P. Rosen
2015-02-24 12:10 6% ` jan.de.kruyf
1 sibling, 1 reply; 200+ results
From: J-P. Rosen @ 2015-02-24 11:24 UTC (permalink / raw)
Le 24/02/2015 10:07, jan.de.kruyf@gmail.com a écrit :
> Doing a variable length linked list on Gnat for Arm I found I can do
>
> object_access := new object;
>
> but I can not free this object. I follow that dynamic memory
> allocation is something bad (tm), under certain circumstances.
1) Ravenscar is purely about multi-tasking, and says nothing about the
sequential aspects of the language. Allocators (aka "new") are allowed
(but may be disallowed in safety critical contexts by other rules).
2) Did you look into Ada.Unchecked_Deallocation? It is a generic that
you instantiate to get the equivalent of "free".
--
J-P. Rosen
Adalog
2 rue du Docteur Lombard, 92441 Issy-les-Moulineaux CEDEX
Tel: +33 1 45 29 21 52, Fax: +33 1 45 29 25 00
http://www.adalog.fr
^ permalink raw reply [relevance 6%]
* Did I find mamory leak in Generic Image Decoder (GID) ?
@ 2015-02-02 5:50 7% reinkor
0 siblings, 0 replies; 200+ results
From: reinkor @ 2015-02-02 5:50 UTC (permalink / raw)
Dear All,
I tried out GID (Generic Image Decoder) from
http://sourceforge.net/projects/gen-img-dec/
The point was to read jpeg-images from my Ada program
"wrapped" in a function:
function read_jpg(cfile_jpg : String) return image1.imgc_t;
The source code is below. However, this function seems to eat memory
during (say 200) repeated calls to it (large images, 2000x1800 pixels each).
I did something very very stupid ?
reinert
----------------------------------------------------------------------
Here is the actual code:
with Ada.Streams.Stream_IO;
use Ada.Streams.Stream_IO;
with Ada.Characters.Latin_1;
with Interfaces.C;
with Interfaces.C.Strings;
with system;
with Ada.Unchecked_Conversion;
with Interfaces;
with GID;
with Ada.Calendar;
with Ada.Characters.Handling; use Ada.Characters.Handling;
with Ada.Text_IO; use Ada.Text_IO;
with Ada.Unchecked_Deallocation;
with Text_IO; use Text_IO;
package body file_handling3 is
package Int_Io is new Text_IO.Integer_Io (Integer);
use Int_Io;
use Interfaces;
type Byte_Array is array(Integer range <>) of Unsigned_8;
type p_Byte_Array is access Byte_Array;
procedure Dispose is new Ada.Unchecked_Deallocation(Byte_Array, p_Byte_Array);
img_buf: p_Byte_Array := null;
procedure Free_buf is new Ada.Unchecked_Deallocation(Object => Byte_Array, Name => p_Byte_Array);
procedure Load_raw_image(
image : in out GID.Image_descriptor;
buffer: in out p_Byte_Array;
next_frame: out Ada.Calendar.Day_Duration
)
is
subtype Primary_color_range is Unsigned_8;
image_width : constant Positive:= GID.Pixel_Width(image);
image_height: constant Positive:= GID.Pixel_height(image);
idx: Natural;
--
procedure Set_X_Y (x, y: Natural) is
begin
idx:= 3 * (x + image_width * (image_height - 1 - y));
end Set_X_Y;
--
procedure Put_Pixel (
red, green, blue : Primary_color_range;
alpha : Primary_color_range
)
is
pragma Warnings(off, alpha); -- alpha is just ignored
begin
buffer(idx..idx+2):= (red, green, blue);
idx:= idx + 3;
-- ^ GID requires us to look to next pixel on the right for next time.
end Put_Pixel;
stars: Natural:= 0;
procedure Feedback(percents: Natural) is
so_far: constant Natural:= percents / 5;
begin
for i in stars+1..so_far loop
Put( Standard_Error, '*');
end loop;
stars:= so_far;
end Feedback;
procedure Load_image is
new GID.Load_image_contents(
Primary_color_range, Set_X_Y,
Put_Pixel, Feedback, GID.fast
);
begin
Dispose(buffer);
buffer:= new Byte_Array(0..3 * image_width * image_height - 1);
Load_image(image, next_frame);
end Load_raw_image;
function read_jpg(cfile_jpg : String) return image1.imgc_t is
f: Ada.Streams.Stream_IO.File_Type;
i: GID.Image_descriptor;
name : String := cfile_jpg;
up_name: constant String:= To_Upper(name);
next_frame, current_frame: Ada.Calendar.Day_Duration:= 0.0;
isx,isy : Integer;
begin
Open(f, In_File, name);
GID.Load_image_header(
i,
Stream(f).all,
try_tga =>
name'Length >= 4 and then
up_name(up_name'Last-3..up_name'Last) = ".TGA"
);
Load_raw_image(i, img_buf, next_frame);
Close(f);
isx := GID.Pixel_Width(i);
isy := GID.Pixel_Height(i);
New_line;
Put(" isx,isy: ");Put(Integer'Image(isx));Put(Integer'Image(isy));
New_line;
declare
img1 : image1.imgc_t(1..isx,1..isy) := (others => (others => image1.Black));
Index : Positive;
begin
Index := img_buf'First;
for j in img1'Range (2) loop
for i in img1'Range (1) loop
img1(i,isy - j + 1).red := image1.Short_I(img_buf (Index + 0));
img1(i,isy - j + 1).green := image1.Short_I(img_buf (Index + 1));
img1(i,isy - j + 1).blue := image1.Short_I(img_buf (Index + 2));
Index := Index + 3;
end loop;
end loop;
Free_buf(img_buf);
return img1;
end;
end read_jpg;
end file_handling3;
^ permalink raw reply [relevance 7%]
* Re: Question regarding example code in AI12-0140
2014-10-31 19:40 0% ` AdaMagica
2014-11-01 15:31 0% ` Brad Moore
@ 2014-11-08 3:58 0% ` Randy Brukardt
1 sibling, 0 replies; 200+ results
From: Randy Brukardt @ 2014-11-08 3:58 UTC (permalink / raw)
"AdaMagica" <christ-usch.grein@t-online.de> wrote in message
news:bc4efa4f-7b39-4ca8-8c3b-503eef0039ea@googlegroups.com...
> Am Donnerstag, 30. Oktober 2014 16:59:31 UTC+1 schrieb Mark Lorenzen:
>> In AI-0140 the following example code is given:
>>
>> with Ada.Unchecked_Deallocation;
>>
>> package UNC is
>>
>> type My_String (<>) is limited private;
>> type My_String_Access is access My_String;
>> private
>> type My_String is new String;
>> procedure Free is new
>> Ada.Unchecked_Deallocation (My_String, My_String_Access);
>>
>> end UNC;
>>
>> The AI discusses if this is legal Ada or not.
>
> Hu - I've got severe problems to understand the AI. It says:
> "The full view of My_String is constrained, while My_String_Access
> designates the partial view of My_String, which is unconstrained."
>
> But since when is type String constrained? So why is the full view of
> My_String constrained?
>
> Am I blind?
I ran out of time to re-check the logic of this one before making it into an
AI. So I copied the original discussion directly into the AI, but I agree it
makes no sense as written. I'm sure I meant that the *partial view* is
constrained. Brad points out that 3.7(26) says that it is unconstrained and
indefinite, but this is not intended to be normative wording and only the
"indefinite" part is backed up by other wording in the Standard (at least
that I can find in a 30 second search of the RM).
In any case, the truly operative part is that we're statically matching a
type with unknown discriminants to a type with no discriminants (and
unconstrained bounds), and nothing in the Standard says that's allowed.
("Nothing" certainly being different than "unknown"). I agree that the
wording *should* allow this (the language would not make much sense if two
views of the same subtype didn't match), but it doesn't. Thus the AI. (Why
Janus/Ada implements this litererally, I don't know, but it's probably
related to trying to get some ACATS test with picky rules checks to pass.)
Randy.
^ permalink raw reply [relevance 0%]
* Re: Question regarding example code in AI12-0140
2014-10-31 19:40 0% ` AdaMagica
@ 2014-11-01 15:31 0% ` Brad Moore
2014-11-08 3:58 0% ` Randy Brukardt
1 sibling, 0 replies; 200+ results
From: Brad Moore @ 2014-11-01 15:31 UTC (permalink / raw)
On 14-10-31 01:40 PM, AdaMagica wrote:
> Am Donnerstag, 30. Oktober 2014 16:59:31 UTC+1 schrieb Mark Lorenzen:
>> In AI-0140 the following example code is given:
>>
>> with Ada.Unchecked_Deallocation;
>>
>> package UNC is
>>
>> type My_String (<>) is limited private;
>> type My_String_Access is access My_String;
>> private
>> type My_String is new String;
>> procedure Free is new
>> Ada.Unchecked_Deallocation (My_String, My_String_Access);
>>
>> end UNC;
>>
>> The AI discusses if this is legal Ada or not.
>
> Hu - I've got severe problems to understand the AI. It says:
> "The full view of My_String is constrained, while My_String_Access designates the partial view of My_String, which is unconstrained."
>
> But since when is type String constrained? So why is the full view of My_String constrained?
>
> Am I blind?
>
The AI needs some cleanup, and the sentence in the question that says;
"The full view of My_String is constrained, while My_String_Access
designates the partial view of My_String, which is unconstrained. "
is misleading and incorrect, since as you you point out type My_String
is an unconstrained subtype as defined in RM 3.2(9).
The original issue was not really about the My_String type. It was about
the My_String_Access type. It's declaration in the public part of the
package is that of an access type that designates a type that has
unknown discriminants. Any subtype of a type with unknown discriminants
is an unconstrained and indefinite subtype. see RM 3.7 (26)
However in the private part of the package where the instantiation
occurs and the full view of My_String can be seen, we find out that
My_String has no discriminants, which is not the same as having unknown
discriminants.
In the instantiation of Unchecked_Deallocation, the My_String generic
formal has no discriminants. The other generic formal, Name has has to
designate a type that statically matches the Object formal, yet at first
glance these do not appear to match.
RM 4.9.1 (1.2/2) A constraint statically matches another constraint if:
both are static and have equal corresponding bounds or discriminant values;
In the Appendix of the AI however, Tucker explains that for statically
matching, it is the properties of the designated type that matter, not
the properties of the access type that designates them. "The properties
of the designated type change as you learn more about the designated
type." He further points out that the access types in question are
exactly the *same* type, so they should match each other statically.
That is, both the access type declared in the public part of the package
and the view of the access type in the private part designate the
My_String type.
So the effect of this AI would likely just be a clarification in the
wording of the RM, but most compilers otherwise would not need any
changes. In Randy's case he would need to make a change to his compiler,
because he has a compiler bug.
Brad
^ permalink raw reply [relevance 0%]
* Re: Question regarding example code in AI12-0140
2014-10-30 15:59 7% Question regarding example code in AI12-0140 Mark Lorenzen
2014-10-30 16:21 0% ` Adam Beneschan
@ 2014-10-31 19:40 0% ` AdaMagica
2014-11-01 15:31 0% ` Brad Moore
2014-11-08 3:58 0% ` Randy Brukardt
1 sibling, 2 replies; 200+ results
From: AdaMagica @ 2014-10-31 19:40 UTC (permalink / raw)
Am Donnerstag, 30. Oktober 2014 16:59:31 UTC+1 schrieb Mark Lorenzen:
> In AI-0140 the following example code is given:
>
> with Ada.Unchecked_Deallocation;
>
> package UNC is
>
> type My_String (<>) is limited private;
> type My_String_Access is access My_String;
> private
> type My_String is new String;
> procedure Free is new
> Ada.Unchecked_Deallocation (My_String, My_String_Access);
>
> end UNC;
>
> The AI discusses if this is legal Ada or not.
Hu - I've got severe problems to understand the AI. It says:
"The full view of My_String is constrained, while My_String_Access designates the partial view of My_String, which is unconstrained."
But since when is type String constrained? So why is the full view of My_String constrained?
Am I blind?
^ permalink raw reply [relevance 0%]
* Re: Question regarding example code in AI12-0140
2014-10-30 15:59 7% Question regarding example code in AI12-0140 Mark Lorenzen
@ 2014-10-30 16:21 0% ` Adam Beneschan
2014-10-31 19:40 0% ` AdaMagica
1 sibling, 0 replies; 200+ results
From: Adam Beneschan @ 2014-10-30 16:21 UTC (permalink / raw)
On Thursday, October 30, 2014 8:59:31 AM UTC-7, Mark Lorenzen wrote:
> Hello
>
> In AI-0140 the following example code is given:
>
> with Ada.Unchecked_Deallocation;
>
> package UNC is
>
> type My_String (<>) is limited private;
> type My_String_Access is access My_String;
> private
> type My_String is new String;
> procedure Free is new
> Ada.Unchecked_Deallocation (My_String, My_String_Access);
>
> end UNC;
>
> The AI discusses if this is legal Ada or not.
>
> I have never used nor seen a formal generic type used in this way, where the full view of the type seems to strengthen the partial view. Can anyone enlighten me to what the intention of the author could be?
There are no formal generic types in this example, because you're not defining a generic. Perhaps you're confused because (<>) has been used since Ada 83 in formal generic types to mean "formal generic discrete type"? But the (<>) syntax was given a new job in Ada 95.
What it means is that as far as other packages are concerned, the type may be an indefinite type. Therefore, other packages are not allowed to define *variables* like
X : UNC.My_String;
(for approximately the same reasons they can't define variables like this:)
X : String;
The full view doesn't really "strengthen" the partial view here. Since String is an indefinite type, My_String will also be an indefinite type, and the body of UNC, if there were one, would also not be able to say
Y : My_String;
It would be legal to make the full view a definite type, however, such as
type My_String is new String(1..100);
The contract between UNC and its clients would still be that, as far as the clients are concerned, My_String is an indefinite type, and UNC would be reserving the right to change the implementation to an indefinite type in the future.
-- Adam
^ permalink raw reply [relevance 0%]
* Question regarding example code in AI12-0140
@ 2014-10-30 15:59 7% Mark Lorenzen
2014-10-30 16:21 0% ` Adam Beneschan
2014-10-31 19:40 0% ` AdaMagica
0 siblings, 2 replies; 200+ results
From: Mark Lorenzen @ 2014-10-30 15:59 UTC (permalink / raw)
Hello
In AI-0140 the following example code is given:
with Ada.Unchecked_Deallocation;
package UNC is
type My_String (<>) is limited private;
type My_String_Access is access My_String;
private
type My_String is new String;
procedure Free is new
Ada.Unchecked_Deallocation (My_String, My_String_Access);
end UNC;
The AI discusses if this is legal Ada or not.
I have never used nor seen a formal generic type used in this way, where the full view of the type seems to strengthen the partial view. Can anyone enlighten me to what the intention of the author could be?
Regards,
Mark L
^ permalink raw reply [relevance 7%]
* Trying to understand Ada.Finalization.Controlled assignment mechanics.
@ 2014-09-23 0:43 6% Jeremiah
0 siblings, 0 replies; 200+ results
From: Jeremiah @ 2014-09-23 0:43 UTC (permalink / raw)
My understanding of assignment of a child of Ada.Finalization.Controlled is that if you do the following:
A := B; -- A and B are derived from Ada.Finalization.Controlled
That the following occurs:
Finalize(A);
Copy B into A;
Adjust(B);
Is this correct?
I've been learning/relearning Ada lately, so I have been mainly making programs to get a better understanding of the mechanics of Ada. In order to understand assignment, I made a quick tester class. It isn't very useful nor is it meant to be, but it highlights something that I don't understand.
test_class2.ads
----------------------------------
with Ada.Finalization;
package test_class2 is
type access_type is access Integer;
type test is new Ada.Finalization.Controlled with record
ref : access_type := null;
end record;
function Make(a : access_type) return test;
overriding procedure Adjust(self : in out test);
overriding procedure Finalize(self : in out test);
end test_class2;
test_class2.adb
--------------------------
with Ada.Text_IO; use Ada.Text_IO;
with Ada.Unchecked_Deallocation;
package body test_class2 is
function Make(a : access_type) return test is
begin
return (Ada.Finalization.Controlled with ref => a);
end Make;
overriding procedure Adjust(self : in out test) is
begin
Put_Line("Adjusting");
self.ref := null;
end Adjust;
overriding procedure Finalize(self : in out test) is
procedure Free is new Ada.Unchecked_Deallocation(Integer, access_type);
begin
Put("Finalizing");
if(self.ref /= null) then
Put(" (FREED)");
Free(self.ref);
end if;
New_Line;
end Finalize;
end test_class2;
Main.adb
--------------------------
with Ada.Text_IO; use Ada.Text_IO;
with test_class2;
procedure Main is
tester : test_class2.test := test_class2.Make(new Integer'(45));
begin
Put_Line("Hello World");
end Main;
The output I am seeing doesn't make sense to me:
Adjusting
Finalizing (FREED)
Adjusting
Finalizing
Hello World
Finalizing
I wouldn't expect the Freeing of memory to happen until after Hello World when tester goes out of scope. I also thought that Finalize happens before Adjust, but Adjust looks like is happening first. I am compiling and running this on GNAT GPL for windows if that makes a difference. I don't have a different hardware platform to test on.
Can anyone explain to me why the "freeing" of memory happens prior to Hello World and whey Adjusting happens before Finalization? I figure I have something fundamental that I am missing.
Thanks!
^ permalink raw reply [relevance 6%]
* Re: newbie: can't read fast enough... :-) memory leaks...
2014-09-03 10:17 6% ` Pascal Obry
@ 2014-09-04 4:57 0% ` Brad Moore
0 siblings, 0 replies; 200+ results
From: Brad Moore @ 2014-09-04 4:57 UTC (permalink / raw)
On 2014-09-03 4:17 AM, Pascal Obry wrote:
> Le mercredi 03 septembre 2014 à 02:38 -0700, gdotone@gmail.com a
> écrit :
>> i know i'll get there, currently in chapter 3, of Ada 95 PSPD, anyway, can Ada code have/produce memory leaks? well, maybe not "can" it but, does Ada, natively prevent memory leaks?
>>
>> like, C seems to leak all over the place, if not managed correctly by the programmer.
>
> This depends on the implementation. Ada make it possible to use a
> garbage collector but as far as I know no implementation is using one.
> So yes, every Ada compiler around will leak memory if not properly
> freed.
>
> To free an allocated object one need to instantiate
> Ada.Unchecked_Deallocation.
>
> Note that well designed object can deallocate themselves when possible
> by using Ada.Finalization API. As an example, Unbounded_String are using
> dynamic allocation but you need need to worry about that as a user.
>
A couple of points on heap allocation that I think newcomers to Ada
often miss, or fail to appreciate.
Compared to languages like C and C++, I would say Ada reduces the need
for heap allocation.
For example, In C, for a function that can return a string of variable
length, a common approach is to allocate memory for the result from the
heap, and then return the address of the allocated result to the caller,
since in C, functions essentially return numeric values.
A numeric value might be a char, int, float, or an address of some type.
eg.
char * get_string()
{
const char *s1 = "The return result";
char * ptr = malloc(strlen(S1) + 1);
strcpy(ptr, s1);
return ptr;
}
or alternatively, pass the address of the buffer as a parameter into the
function as in...
void get_string(char *buf, int buflen)
{
const char *s1 = "The return result";
if (strlen(s1) + 1 > buflen) {
FATAL_ERR("Buffer too small");
}
strcpy(buf, s1);
}
But this relies on the caller knowing the maximum length of the result
before making the call.
In Ada, unconstrained types such as string types and arrays can be
easily returned on the stack as a result without allocating from the heap.
eg.
function Get_String return String is
begin
return "The return result";
end Get_String;
The second point is that another alternative to calling
Unchecked_Deallocation is to let the finalization of an access type free
all heap allocations for that type, using a nested scope.
eg.
declare
type String_Access is access String;
A, B : String_Access;
begin
A := new String'("String 1");
B := new String'("String 2");
... -- Operate on the data.
end;
-- A and B are automatically freed here because the String_Access
-- is finalized since the scope of the declaration of the access
-- type is being exited, and finalizing an access type also
-- finalizes its collection (allocated objects designated by that
-- type).
This is a nice way to free up a bunch of objects that are no longer
needed, if it can be guaranteed that the objects are only needed in a
nested scope. I like this better than garbage collection, because the
deallocation occurs more consistently, when and where it is needed.
I view this as being less error prone, if one is able to take advantage
of this approach.
There are other techniques and libraries that are helpful in this area,
but I think these two points are a good starting point.
Brad
^ permalink raw reply [relevance 0%]
* Re: newbie: can't read fast enough... :-) memory leaks...
@ 2014-09-03 10:17 6% ` Pascal Obry
2014-09-04 4:57 0% ` Brad Moore
0 siblings, 1 reply; 200+ results
From: Pascal Obry @ 2014-09-03 10:17 UTC (permalink / raw)
Le mercredi 03 septembre 2014 à 02:38 -0700, gdotone@gmail.com a
écrit :
> i know i'll get there, currently in chapter 3, of Ada 95 PSPD, anyway, can Ada code have/produce memory leaks? well, maybe not "can" it but, does Ada, natively prevent memory leaks?
>
> like, C seems to leak all over the place, if not managed correctly by the programmer.
This depends on the implementation. Ada make it possible to use a
garbage collector but as far as I know no implementation is using one.
So yes, every Ada compiler around will leak memory if not properly
freed.
To free an allocated object one need to instantiate
Ada.Unchecked_Deallocation.
Note that well designed object can deallocate themselves when possible
by using Ada.Finalization API. As an example, Unbounded_String are using
dynamic allocation but you need need to worry about that as a user.
--
Pascal Obry / Magny Les Hameaux (78)
The best way to travel is by means of imagination
http://v2p.fr.eu.org
http://www.obry.net
gpg --keyserver keys.gnupg.net --recv-key F949BD3B
^ permalink raw reply [relevance 6%]
* Re: A simple question about the "new" allocator
2014-08-12 6:54 6% A simple question about the "new" allocator NiGHTS
2014-08-12 7:35 0% ` Dmitry A. Kazakov
2014-08-12 15:10 0% ` Adam Beneschan
@ 2014-08-12 16:07 0% ` Jeffrey Carter
2 siblings, 0 replies; 200+ results
From: Jeffrey Carter @ 2014-08-12 16:07 UTC (permalink / raw)
On 08/11/2014 11:54 PM, NiGHTS wrote:
> With all default configurations using a typical Ada compiler, will the
> following code run indefinitely without fail or will it eventually crash?
With a typical Ada compiler, your program will crash. Ada's definition allows
garbage collection but doesn't require it. I'm not aware of any compiler that
implements it.
> If this does crash, what would be another way to write this program so that
> it does not crash? I would prefer not to use Ada.Unchecked_Deallocation.
If it didn't crash, your program would run forever without any visible effect;
it's quite easy to write such a program. Presuming that's not what you're
asking, you can repeatedly allocate memory using a safe pointer without running
out of memory:
with PragmARC.Safe_Pointers;
procedure Does_Not_Crash is
package Positive_Pointers is new PragmARC.Safe_Pointers (Object => Positive);
Test : Positive_Pointers.Safe_Pointer;
begin -- Does_Not_Crash
loop
Test := Positive_Pointers.Allocate;
end loop;
end Does_Not_Crash;
--
Jeff Carter
"There's no messiah here. There's a mess all right, but no messiah."
Monty Python's Life of Brian
84
^ permalink raw reply [relevance 0%]
* Re: A simple question about the "new" allocator
2014-08-12 6:54 6% A simple question about the "new" allocator NiGHTS
2014-08-12 7:35 0% ` Dmitry A. Kazakov
@ 2014-08-12 15:10 0% ` Adam Beneschan
2014-08-12 16:07 0% ` Jeffrey Carter
2 siblings, 0 replies; 200+ results
From: Adam Beneschan @ 2014-08-12 15:10 UTC (permalink / raw)
On Monday, August 11, 2014 11:54:50 PM UTC-7, NiGHTS wrote:
> With all default configurations using a typical Ada compiler, will the following code run indefinitely without fail or will it eventually crash?
>
>
>
> procedure main is
> Test : access Positive;
> begin
> loop
> Test := new Positive;
> end loop;
> end main;
> If this does crash, what would be another way to write this program so that it does not crash? I would prefer not to use Ada.Unchecked_Deallocation.
I vote for
procedure main is
begin
loop
null;
end loop;
end main;
which would have the same effect as your orignal code but without crashing. Really, the question "what would be another way to write this program so that it does not crash" makes no sense at all; before answering it, we would need specifics about just *what* you want to do without crashing.
For example, if you want "test := new Positive" to automatically deallocate the previously allocated Positive, since it isn't referenced any more, there are various "smart pointer" packages out there that keep a reference count.
But the question as posted isn't answerable.
-- Adam
^ permalink raw reply [relevance 0%]
* Re: A simple question about the "new" allocator
2014-08-12 7:35 0% ` Dmitry A. Kazakov
@ 2014-08-12 13:38 0% ` G.B.
0 siblings, 0 replies; 200+ results
From: G.B. @ 2014-08-12 13:38 UTC (permalink / raw)
On 12.08.14 09:35, Dmitry A. Kazakov wrote:
> On Mon, 11 Aug 2014 23:54:50 -0700 (PDT), NiGHTS wrote:
>
>> With all default configurations using a typical Ada compiler, will the following code run indefinitely without fail or will it eventually crash?
>>
>> procedure main is
>>
>> Test : access Positive;
>>
>> begin
>>
>> loop
>> Test := new Positive;
>> end loop;
>>
>> end main;
>>
>> If this does crash, what would be another way to write this program so
>> that it does not crash?
>>
>> I would prefer not to use Ada.Unchecked_Deallocation.
>
> Write a custom memory pool that does not allocate anything. Make Test a
> pointer to that pool.
>
> P.S. It might sound silly, but such pools are actually useful. When the
> object is already allocated and you want to initialize it and get a pointer
> to, one way to do that is using a fake allocator.
One such storage pool, tailored to the problem, and therefore likely
not applicable to every problem:
with System.Storage_Pools;
with System.Storage_Elements;
generic
type T is private;
package My_Switching_Pool is
pragma Preelaborate (My_Switching_Pool);
use System;
type Alternating_Pool
is new Storage_Pools.Root_Storage_Pool with private;
-- Provides storage for exactly two items of formal type `T`.
overriding
procedure Allocate
(Pool : in out Alternating_Pool;
Storage_Address : out Address;
Size_In_Storage_Elements : in Storage_Elements.Storage_Count;
Alignment : in Storage_Elements.Storage_Count);
-- makes the other of the two items available for storage
overriding
procedure Deallocate
(Pool : in out Alternating_Pool;
Storage_Address : in Address;
Size_In_Storage_Elements : in Storage_Elements.Storage_Count;
Alignment : in Storage_Elements.Storage_Count);
overriding
function Storage_Size
(Pool : Alternating_Pool) return Storage_Elements.Storage_Count;
private
type Names is (Fst, Snd);
type Pair is array (Names) of T;
type Alternating_Pool
is new Storage_Pools.Root_Storage_Pool with
record
In_Use : Names := Snd;
end record;
The_Data : Pair;
end My_Switching_Pool;
package body My_Switching_Pool is
overriding
procedure Allocate
(Pool : in out Alternating_Pool;
Storage_Address : out Address;
Size_In_Storage_Elements : in Storage_Elements.Storage_Count;
Alignment : in Storage_Elements.Storage_Count)
is
begin
-- switch components of `The_Data`
Pool.In_Use := (if Pool.In_Use = Fst
then Snd
else Fst);
Storage_Address := The_Data (Pool.In_Use)'Address;
end Allocate;
overriding
procedure Deallocate
(Pool : in out Alternating_Pool;
Storage_Address : in Address;
Size_In_Storage_Elements : in Storage_Elements.Storage_Count;
Alignment : in Storage_Elements.Storage_Count)
is
begin
null;
end Deallocate;
overriding
function Storage_Size
(Pool : Alternating_Pool)
return Storage_Elements.Storage_Count
is
use type Storage_Elements.Storage_Count;
begin
return Pair'Size / Storage_Elements.Storage_Element'Size;
end Storage_Size;
end My_Switching_Pool;
with My_Switching_Pool;
procedure Main is
package Two_Numbers is new My_Switching_Pool (T => Positive);
The_Pool : Two_Numbers.Alternating_Pool;
type Positive_Ptr is access Positive
with Storage_Pool => The_Pool;
Test : Positive_Ptr;
begin
loop
Test := new Positive;
end loop;
end Main;
^ permalink raw reply [relevance 0%]
* Re: A simple question about the "new" allocator
2014-08-12 6:54 6% A simple question about the "new" allocator NiGHTS
@ 2014-08-12 7:35 0% ` Dmitry A. Kazakov
2014-08-12 13:38 0% ` G.B.
2014-08-12 15:10 0% ` Adam Beneschan
2014-08-12 16:07 0% ` Jeffrey Carter
2 siblings, 1 reply; 200+ results
From: Dmitry A. Kazakov @ 2014-08-12 7:35 UTC (permalink / raw)
On Mon, 11 Aug 2014 23:54:50 -0700 (PDT), NiGHTS wrote:
> With all default configurations using a typical Ada compiler, will the following code run indefinitely without fail or will it eventually crash?
>
> procedure main is
>
> Test : access Positive;
>
> begin
>
> loop
> Test := new Positive;
> end loop;
>
> end main;
>
> If this does crash, what would be another way to write this program so
> that it does not crash?
>
> I would prefer not to use Ada.Unchecked_Deallocation.
Write a custom memory pool that does not allocate anything. Make Test a
pointer to that pool.
P.S. It might sound silly, but such pools are actually useful. When the
object is already allocated and you want to initialize it and get a pointer
to, one way to do that is using a fake allocator.
--
Regards,
Dmitry A. Kazakov
http://www.dmitry-kazakov.de
^ permalink raw reply [relevance 0%]
* A simple question about the "new" allocator
@ 2014-08-12 6:54 6% NiGHTS
2014-08-12 7:35 0% ` Dmitry A. Kazakov
` (2 more replies)
0 siblings, 3 replies; 200+ results
From: NiGHTS @ 2014-08-12 6:54 UTC (permalink / raw)
With all default configurations using a typical Ada compiler, will the following code run indefinitely without fail or will it eventually crash?
procedure main is
Test : access Positive;
begin
loop
Test := new Positive;
end loop;
end main;
If this does crash, what would be another way to write this program so that it does not crash? I would prefer not to use Ada.Unchecked_Deallocation.
^ permalink raw reply [relevance 6%]
* Re: Mission-Critical Design: Ada.Unchecked_Deallocation vs Garbage Collection
2014-07-24 1:00 6% ` Dennis Lee Bieber
@ 2014-07-24 6:52 8% ` Simon Wright
0 siblings, 0 replies; 200+ results
From: Simon Wright @ 2014-07-24 6:52 UTC (permalink / raw)
Dennis Lee Bieber <wlfraed@ix.netcom.com> writes:
> heavy time&money investment to certify that the binaries [...] have
> not changed
I was approached by an ex-colleague to help him understand why builds of
the same source code with the same compiler (GNAT 3.16a1, Windows x
VxWorks) didn't always produce the same executable. I couldn't (not at a
distance, anyway).
That's the sort of circumstance in which one really regrets not keeping
the support contract up!
^ permalink raw reply [relevance 8%]
* Re: Mission-Critical Design: Ada.Unchecked_Deallocation vs Garbage Collection
2014-07-23 22:07 7% ` Robert A Duff
@ 2014-07-24 1:00 6% ` Dennis Lee Bieber
2014-07-24 6:52 8% ` Simon Wright
0 siblings, 1 reply; 200+ results
From: Dennis Lee Bieber @ 2014-07-24 1:00 UTC (permalink / raw)
On Wed, 23 Jul 2014 18:07:10 -0400, Robert A Duff
<bobduff@shell01.TheWorld.com> declaimed the following:
>That particular example can be done without using the secondary stack in
>the latest version of GNAT. All the temps are allocated on the primary
Ah... But now we are in that unknown category: has the latest version
of GNAT passed the certification tests needed to be approved for use on our
application... (I was just CC'd on an email at work in which it was
discovered that the VMS cross-compiler had been patched in 1992 [obviously
an Ada-83 compliant system], used for 14 years, yet the official document
for the compiler version to be cited in all documentation was prior to
that... Yes, we are using a 14-year-old cross compiler on an even older OS
-- because that is a certified development system... Just changing from
WinXP to Win7 [on another development system] requires heavy time&money
investment to certify that the binaries [to run on neither of those OSs]
have not changed!)
--
Wulfraed Dennis Lee Bieber AF6VN
wlfraed@ix.netcom.com HTTP://wlfraed.home.netcom.com/
^ permalink raw reply [relevance 6%]
* Re: Mission-Critical Design: Ada.Unchecked_Deallocation vs Garbage Collection
2014-07-18 12:41 7% ` Dennis Lee Bieber
@ 2014-07-23 22:07 7% ` Robert A Duff
2014-07-24 1:00 6% ` Dennis Lee Bieber
0 siblings, 1 reply; 200+ results
From: Robert A Duff @ 2014-07-23 22:07 UTC (permalink / raw)
Dennis Lee Bieber <wlfraed@ix.netcom.com> writes:
> On Thu, 17 Jul 2014 23:17:48 -0700 (PDT), NiGHTS <nights@unku.us> declaimed
> the following:
>
>>In mission-critical design applications, do they favor garbage collectors or the unchecked deallocation?
>>
> Based upon the examples I've seen at work (flight management systems):
> NEITHER...
>
> Any dynamic memory gets allocated during the initialization step (based
> on some configuration "file" to identify how much of each component to
> create), and once that completes the only "dynamic" memory is the stack
> (and not even the secondary stack used in some operations -- like run-time
> string concatenation; no: put("string " & integer'image(val) & " more"); )
That particular example can be done without using the secondary stack in
the latest version of GNAT. All the temps are allocated on the primary
stack, with compile-time-known size. The length of X&Y is equal to the
sum of the lengths of X and Y. The maximum length of the 'Image result is 11.
Take a look at the output of -gnatD if you want to see how that works.
- Bob
^ permalink raw reply [relevance 7%]
* Re: Mission-Critical Design: Ada.Unchecked_Deallocation vs Garbage Collection
2014-07-18 7:51 8% ` J-P. Rosen
@ 2014-07-19 9:07 7% ` Pascal Obry
0 siblings, 0 replies; 200+ results
From: Pascal Obry @ 2014-07-19 9:07 UTC (permalink / raw)
Le vendredi 18 juillet 2014 à 09:51 +0200, J-P. Rosen a écrit :
> ... especially in Ada, where MUCH can be accomplished without resorting
> to pointers, unlike many other languages.
Right, I've heard that some projects still allow allocation of a buffer
during elaboration in a pool and then use only this space as heap. All
memory allocation is prohibited after.
--
Pascal Obry / Magny Les Hameaux (78)
The best way to travel is by means of imagination
http://v2p.fr.eu.org
http://www.obry.net
gpg --keyserver keys.gnupg.net --recv-key F949BD3B
^ permalink raw reply [relevance 7%]
* Re: Mission-Critical Design: Ada.Unchecked_Deallocation vs Garbage Collection
2014-07-18 6:17 7% Mission-Critical Design: Ada.Unchecked_Deallocation vs Garbage Collection NiGHTS
2014-07-18 6:25 8% ` Jeffrey Carter
@ 2014-07-18 12:41 7% ` Dennis Lee Bieber
2014-07-23 22:07 7% ` Robert A Duff
1 sibling, 1 reply; 200+ results
From: Dennis Lee Bieber @ 2014-07-18 12:41 UTC (permalink / raw)
On Thu, 17 Jul 2014 23:17:48 -0700 (PDT), NiGHTS <nights@unku.us> declaimed
the following:
>In mission-critical design applications, do they favor garbage collectors or the unchecked deallocation?
>
Based upon the examples I've seen at work (flight management systems):
NEITHER...
Any dynamic memory gets allocated during the initialization step (based
on some configuration "file" to identify how much of each component to
create), and once that completes the only "dynamic" memory is the stack
(and not even the secondary stack used in some operations -- like run-time
string concatenation; no: put("string " & integer'image(val) & " more"); )
--
Wulfraed Dennis Lee Bieber AF6VN
wlfraed@ix.netcom.com HTTP://wlfraed.home.netcom.com/
^ permalink raw reply [relevance 7%]
* Re: Mission-Critical Design: Ada.Unchecked_Deallocation vs Garbage Collection
2014-07-18 6:25 8% ` Jeffrey Carter
@ 2014-07-18 7:51 8% ` J-P. Rosen
2014-07-19 9:07 7% ` Pascal Obry
0 siblings, 1 reply; 200+ results
From: J-P. Rosen @ 2014-07-18 7:51 UTC (permalink / raw)
Le 18/07/2014 08:25, Jeffrey Carter a écrit :
> On 07/17/2014 11:17 PM, NiGHTS wrote:
>> What are your thoughts on this? When is it better to use garbage
>> collection and when is it better to use classic new & delete memory
>> management when a life may be on the line?
>
> Typically, safety-critical systems don't allow dynamic allocation
> and deallocation.
>
... especially in Ada, where MUCH can be accomplished without resorting
to pointers, unlike many other languages.
--
J-P. Rosen
Adalog
2 rue du Docteur Lombard, 92441 Issy-les-Moulineaux CEDEX
Tel: +33 1 45 29 21 52, Fax: +33 1 45 29 25 00
http://www.adalog.fr
^ permalink raw reply [relevance 8%]
* Re: Mission-Critical Design: Ada.Unchecked_Deallocation vs Garbage Collection
2014-07-18 6:17 7% Mission-Critical Design: Ada.Unchecked_Deallocation vs Garbage Collection NiGHTS
@ 2014-07-18 6:25 8% ` Jeffrey Carter
2014-07-18 7:51 8% ` J-P. Rosen
2014-07-18 12:41 7% ` Dennis Lee Bieber
1 sibling, 1 reply; 200+ results
From: Jeffrey Carter @ 2014-07-18 6:25 UTC (permalink / raw)
On 07/17/2014 11:17 PM, NiGHTS wrote:
> In mission-critical design applications, do they favor garbage collectors or
> the unchecked deallocation?
>
> What are your thoughts on this? When is it better to use garbage collection
> and when is it better to use classic new & delete memory management when a
> life may be on the line?
Typically, safety-critical systems don't allow dynamic allocation and deallocation.
--
Jeff Carter
"You a big nose have it."
Never Give a Sucker an Even Break
107
^ permalink raw reply [relevance 8%]
* Mission-Critical Design: Ada.Unchecked_Deallocation vs Garbage Collection
@ 2014-07-18 6:17 7% NiGHTS
2014-07-18 6:25 8% ` Jeffrey Carter
2014-07-18 12:41 7% ` Dennis Lee Bieber
0 siblings, 2 replies; 200+ results
From: NiGHTS @ 2014-07-18 6:17 UTC (permalink / raw)
In mission-critical design applications, do they favor garbage collectors or the unchecked deallocation?
The dangling pointer thing is definitely a problem I've had to deal with in complex C programs that I have debugged. But I can also see how having an unpredictable pool of memory hanging over the program could be a problem as well. I suppose this question is highly dependant on the application and target.
What are your thoughts on this? When is it better to use garbage collection and when is it better to use classic new & delete memory management when a life may be on the line?
^ permalink raw reply [relevance 7%]
* Type_Invariant and instance creation (was: Type_Invariant and Finalize)
@ 2014-07-17 21:30 6% ` Simon Wright
0 siblings, 0 replies; 200+ results
From: Simon Wright @ 2014-07-17 21:30 UTC (permalink / raw)
I wrote this to play with some of the concepts Natasha discussed, since
I haven't used the contract aspects before. It's a bit more complicated
than I'd have hoped because of the need for Adjust.
As it stands, it executes as expected with GNAT GPL 2014 (that is, the
finalizations occur OK and don't trigger assertion failures, but the
creation of an empty object does).
With FSF GCC 4.9.0, however, the assertion fails in Create at
return (Ada.Finalization.Controlled with V => new Integer'(Value));
I tried inserting Put_Lines in the test program to get an idea of the
flow:
declare
Tmp : Releasing_Not_Null.R := Releasing_Not_Null.Create (42);
begin
Put_Line ("in first declare block");
end;
Put_Line ("first declare block done");
and now blow me down if GNAT GPL 2014 doesn't fail just like FSF GCC!
What am I doing wrong? Which compiler (if either) is right?
-- gnatchop from here --
with Ada.Finalization;
package Releasing_Not_Null is
type R is new Ada.Finalization.Controlled with private;
function Create (Value : Integer) return R;
private
type P is access Integer;
type R is new Ada.Finalization.Controlled with record
V : P;
end record
with Type_Invariant => R.V /= null;
overriding
procedure Adjust (This : in out R);
overriding
procedure Finalize (This : in out R);
end Releasing_Not_Null;
with Ada.Unchecked_Deallocation;
package body Releasing_Not_Null is
function Create (Value : Integer) return R is
begin
return (Ada.Finalization.Controlled with V => new Integer'(Value));
end Create;
procedure Adjust (This : in out R) is
begin
This.V := new Integer'(This.V.all);
end Adjust;
procedure Finalize (This : in out R) is
procedure Free is new Ada.Unchecked_Deallocation (Integer, P);
begin
if This.V /= null then
Free (This.V);
end if;
end Finalize;
end Releasing_Not_Null;
with Releasing_Not_Null;
procedure Test_Releasing_Not_Null is
begin
declare -- this block is OK
Tmp : Releasing_Not_Null.R := Releasing_Not_Null.Create (42);
begin
null;
end;
declare
Tmp : Releasing_Not_Null.R; -- Failed invariant here
begin
null;
end;
end Test_Releasing_Not_Null;
^ permalink raw reply [relevance 6%]
* Re: Position of "use"
@ 2014-07-10 17:47 0% ` Tero Koskinen
0 siblings, 0 replies; 200+ results
From: Tero Koskinen @ 2014-07-10 17:47 UTC (permalink / raw)
10.7.2014 18:57, Adam Beneschan wrote:
> GNAT lets things slip through that should be errors.
To GNAT's defence, this kind of bugs are pretty hard to find,
especially afterwards if enough care has not been taken
during the initial implementation.
Many times you only notice "accepts invalid code" bug
if another compiler rejects the code.[1]
Some of my recent examples:
1)
GNAT compiles Strings Edit 2.9 cleanly, while ICCAda rejects
the code:
>
> "strings_edit-integers-subscript.ads", line 31: Error: Undefined >
identifier:
>
> Number. [RM 4.1(11), 8.3, 8.6(28)]
>
(See http://build.ada-language.com/job/Strings_Edit_ICCAda/3/console for
full log.)
2)
ICCAda and GNAT both compile Debug package from Adalog
( http://www.adalog.fr/compo2.htm#Debug ) while Janus/Ada rejects
the code:
> In File C:\work\adalog-debug\DEBUG.ADS at line 206
> --------------
> 205: type Debug_String is new String;
> 206: procedure Free is new Ada.Unchecked_Deallocation
> (Debug_String, Debug_String_Access);
>-------------------------------------------------------------------------^
> *ERROR* Formal and actual must both be constrained or unconstrained
> (6.4.10) [RM 12.5.4(3)]
Of course, in these cases, one could probably argue which compilers
are correct and which are not; luckily I a user, who does not need
to worry about the compiler implementation. :)
Yours,
Tero
[1] Yes, there is ACATS, but as you can see, it does not cover everything.
^ permalink raw reply [relevance 0%]
* Re: Termination of periodic tasks
@ 2014-06-17 19:32 3% ` Natasha Kerensikova
0 siblings, 0 replies; 200+ results
From: Natasha Kerensikova @ 2014-06-17 19:32 UTC (permalink / raw)
On 2014-06-17, Jacob Sparre Andersen <jacob@jacob-sparre.dk> wrote:
> Natasha Kerensikova wrote:
>
>> So let's consider instead real code that actually (more or less)
>> works:
>> https://github.com/faelys/natools/blob/trunk/src/natools-cron.ads
>> https://github.com/faelys/natools/blob/trunk/src/natools-cron.adb (I
>> whipped it together yesterday after thinking about Dmitry's
>> suggestion, but it's still only a rough draft, there are issues to
>> iron out before using it for real, like handling map key
>> collisions. However all comments are still welcome.)
>
> I've posted a pull request which eliminates all explicit memory
> management from the package. :-)
I was hesitating between posting my comments here or on the pull
request. I decided to post them here so that others can offer their
views and their explanations on the points I raise. If that's not the
best choice, please tell me so and I won't do it again.
> ... But not solved your actual problem. :-(
Basically that's my main concern: you turned a partial solution (that
works fine as long as global objects are explicitly reset) into a
complete non-solution (that never terminates). I'm afraid I'll have to
reject the pull request for this reasons.
But still, your version intrigues me. What go to such great lengths
only to eliminate memory management?
Maybe I'm too scarred by having forged myself into a C programmer that
can code for years without committing any resource leak, but I have
trouble to see what is so wrong with memory management to want so much
to eliminate it.
I understand that the less resource management the better is a good rule
of thumb, just like the less code the better. But isn't it a relatively
mild benefit to balance against all costs?
The core idea around which the package has been built, is to have a
worker task that terminate whenever the job map is empty, hoping it
would happen at program termination. And since it can also happen
temporarily during the program execution, there needs a way to
"unterminate" it when the job map is no longer empty. Since as far as I
know there is no way to restart a terminated task, reusing the task
object. So the only solution is to deallocate the terminate task object
and allocate a new one, ready to start.
My understanding of "explicit memory allocation" is stuff that involves
"new" keyword and Ada.Unchecked_Deallocation instances, and the
task-restart trick is the only explicit memory allocation I see in the
original Natools.Cron.
Getting rid of it means either an interminable static task like your
proposal, or hiding the allocation/deallocation behind a container or
some other wrapper, that seem of little value in that situation.
However, your proposal also eliminates the uses of Ada.Finalization and
of Natools.References. Even though I don't consider them as explicit
memory management, it seems you do. To me, Natools.Reference is as much
of an abstraction as Indefinite_Ordered_Maps, so I don't see any
explictness being remove through the use of the latter instead of the
former. And Ada.Finalization is about any resource management, and I
would say less for memory than for other resources. Anyway, it feels
like an extremely mild mechanism, I can't see why one would want to
avoid it.
Moreover, by removing Natools.References, you no longer have reference
semantics, so you cannot move references from one part of the code to
another, for example from the map inside the protected object to the
task.
I would guess that's why you moved the callback execution from the task
body to a procedure in the protected object. However, this has serious
drawbacks:
* First, it becomes a bounded error to perform any potentially
blocking operation, for example Text_IO.Put_Line which I used in my
little example to test the package while developing it.
* Second, it locks the database while running the callback, so the
callback cannot change its own period or unregister itself from the
service.
Also, not having references means copying the object around, which you
also do (but could have avoided using Update_Element), so you can no
longer store any mutable internal state in the callback object. My
little test example had a counter in it, and that is no longer possible.
Lastly, you conflated the callback interface with the job
identification, but probably realized that there can still be several
copies of the same objects, so you had to rely on a new Event_ID type.
However the Event_ID are ever-increasing values of Positive, without any
overflow management. One could probably hope that no sane
implementation-defined limit would be reached in this package, but even
though it's a fair assumption I would rather not assume it if that has
no cost.
Or is it only to solve the key collision issue? In that case I had
something else in mind (I will probably commit it tomorrow, no that I
have committed a test case for the issue).
So in summary, you did indeed eliminate explicit and
not-so-explicit-to-me memory management, but at the cost of:
- breaking the partial solution to the problem considered,
- forbidding potentially blocking operations in the callbacks,
- forbidding callback management from within callbacks,
- making it harder to write callbacks that inherit from
Ada.Finalization.* (e.g. because they hold resources like files)
or anything else,
- introducing software aging with an implementation-defined threshold.
Is it really worth it? Is there a lesson here I'm failing to grasp?
Thanks for your comments,
Natasha
^ permalink raw reply [relevance 3%]
* Re: Termination of periodic tasks
@ 2014-06-17 8:45 7% ` Dmitry A. Kazakov
0 siblings, 0 replies; 200+ results
From: Dmitry A. Kazakov @ 2014-06-17 8:45 UTC (permalink / raw)
On Tue, 17 Jun 2014 07:47:49 +0000 (UTC), Natasha Kerensikova wrote:
> Hello,
>
> On 2014-06-17, Dmitry A. Kazakov <mailbox@dmitry-kazakov.de> wrote:
>> On Tue, 17 Jun 2014 06:57:38 +0000 (UTC), Natasha Kerensikova wrote:
>>
>> [...]
>>> Is there a way to work around such a situation?
>>
>> The solution is always same: wrap a task pointer in a controlled object.
>> Manage the task from the object's Initialize and Finalize.
>>
> But if I change Global_Worker from an access-to-task to a controlled
> object, its master will still be the environment task, so Finalize
> wouldn't be called before termination of the worker task.
>
> Or am I missing something?
You should put it in a separate package to ensure different scopes of the
controlled object and the access-to-task type.
> Is there a special construct that yield an
> earlier call to Finalize than Cron_Entry? Would you happen to have a
> working example?
with Ada.Finalization;
package Workers is
type Manager is new Ada.Finalization.Limited_Controlled with private;
private
task type Worker is
entry Live;
entry Die;
end Worker;
type Worker_Ptr is access Worker;
type Manager is new Ada.Finalization.Limited_Controlled with record
Staff : Worker_Ptr;
end record;
overriding procedure Initialize (Handler : in out Manager);
overriding procedure Finalize (Handler : in out Manager);
end Workers;
--------------------------------------------------------------
with Ada.Unchecked_Deallocation;
with Ada.Text_IO; use Ada.Text_IO;
package body Workers is
task body Worker is
begin
accept Live;
Put_Line ("I am born!");
loop
select
accept Die;
exit;
else delay 1.0;
Put_Line ("I am alive!");
end select;
end loop;
Put_Line ("You killed me!");
end Worker;
procedure Initialize (Handler : in out Manager) is
begin
Handler.Staff := new Worker;
Handler.Staff.Live;
end Initialize;
procedure Finalize (Handler : in out Manager) is
procedure Free is
new Ada.Unchecked_Deallocation (Worker, Worker_Ptr);
begin
if Handler.Staff /= null then
Handler.Staff.Die;
while not Handler.Staff'Terminated loop
delay 0.01;
end loop;
Free (Handler.Staff);
end if;
end Finalize;
end Workers;
-------------------------------------------------------
with Ada.Text_IO; use Ada.Text_IO;
with Workers; use Workers;
procedure Test is
X : Manager;
begin
delay 5.0;
Put_Line ("Good bye!");
end Test;
-----------------------------------------------------
X is finalized before Workers (and Worker_Ptr), so it does not wait for all
instances to terminate.
--
Regards,
Dmitry A. Kazakov
http://www.dmitry-kazakov.de
^ permalink raw reply [relevance 7%]
* Help with type definition
@ 2014-05-16 7:37 6% hanslad
0 siblings, 0 replies; 200+ results
From: hanslad @ 2014-05-16 7:37 UTC (permalink / raw)
Hello,
I need an advise on how to define a type in my project.
I want to implement a network protocol with the following definition on the type "string":
"All String values are encoded as a sequence of UTF8 characters without a null terminator and preceded by the length in bytes.
The length in bytes is encoded as Int32. A value of -1 is used to indicate a 'null' string."
The string is used in different datastructures send on network eg. like the one implemented in "Node" type below.
Am I on the right track here?
Here is my code:
Ads:
with Interfaces;
with Ada.Finalization; use Ada.Finalization;
package Types is
type String_Type is new Ada.Finalization.Controlled with private;
type IdentifierType is
(
IdentifierType_Numeric,
IdentifierType_String
);
for IdentifierType use
(IdentifierType_Numeric => 1,
IdentifierType_String => 2);
for IdentifierType'Size use 8;
type Node (IdType : IdentifierType := IdentifierType_Numeric )is record
NamespaceIndex : Interfaces.Unsigned_16 := 0;
case IdType is
when IdentifierType_Numeric =>
Numeric : Interfaces.Unsigned_32 ;
when IdentifierType_String =>
String : String_Type;
end case;
end record;
private
overriding procedure Initialize (This: in out String_Type);
overriding procedure Adjust (This: in out String_Type);
overriding procedure Finalize (This : in out String_Type);
type String_Type_Implementation(Count : Natural) is record
Data : String(1 .. Count) := "";
end record;
type String_Type_Implementation_Ptr is access String_Type_Implementation;
type String_Type is new Ada.Finalization.Controlled with record
Length : Integer;
Implementation : String_Type_Implementation_Ptr;
end record;
end Types;
Adb:
with Ada.Unchecked_Deallocation;
package body Types is
procedure Free is
new Ada.Unchecked_Deallocation (String_Type_Implementation, String_Type_Implementation_Ptr);
procedure Finalize (This : in out String_Type) is
begin
if(This.Implementation /= null) then
Free (This.Implementation);
end if;
end Finalize;
overriding procedure Adjust (This : in out String_Type) is
begin
This.Implementation :=
new String_Type_Implementation'(This.Implementation.all);
end Adjust;
overriding procedure Initialize (This: in out String_Type) is
begin
This.Length := -1;
This.Implementation := new String_Type_Implementation(0);
end Initialize;
end Types;
Thanks,
Hans
^ permalink raw reply [relevance 6%]
* Re: Increasing GNAT's heap
@ 2013-11-12 19:30 6% ` Georg Bauhaus
0 siblings, 0 replies; 200+ results
From: Georg Bauhaus @ 2013-11-12 19:30 UTC (permalink / raw)
On 12.11.13 15:00, Dmitry A. Kazakov wrote:
> On Tue, 12 Nov 2013 14:26:42 +0100, Georg Bauhaus wrote:
>
>> On 12.11.13 12:09, Dmitry A. Kazakov wrote:
>>> Does anybody know a way to increase the heap size available for GNAT? It
>>> crashes with famous GNAT BUG DETECTED, Storage_Error heap exhausted.
>>
>> Do ulimit values have any effect?
>
> $ ulimit
> unlimited
FWIW, I am finding it difficult to trigger something beyond
"Storage_Error heap exhausted" (no bug, i.e.); SE seems kind
of expected for some amounts of memory requested. The program below
tries to make the memory manager commit, by forcing random inits
of the memory at random positions. The program runs quite
a while before either me interrupting it at 2**34 storage elements
(Mac OS X 10.7.5), or some Linux VMs duly reporting STORAGE_ERROR
while processing the memory for 2**32.
Both systems are 64 bit, though, so I can't tell what 32 bit gives as
results. I'm curious. Does this trigger a bug box in your system?
(size_t and others are there for hysteric raisins of comparison.)
with System.Storage_Elements; use System.Storage_Elements;
with Ada.Unchecked_Deallocation;
with Ada.Numerics.Discrete_Random, Ada.Numerics.Elementary_Functions;
with Ada.Text_IO;
procedure Alloc_Ada
is
-- powers of 2, for growing allocated sizes:
Small : constant := 16;
Large : constant := 40;
type Void_Ptr is access Storage_Array;
subtype size_t is Storage_Offset;
package Size_T_IO is new Ada.Text_IO.Integer_IO (size_t);
use Size_T_IO, Ada.Text_IO;
procedure Init (Object : Void_Ptr; Acc : out Storage_Element);
-- Initialize some of Object with random data. Place something
-- almost anywhere in the allocated area, assuming that doing so
-- will require commits.
procedure Free is
new Ada.Unchecked_Deallocation (Storage_Array, Void_Ptr);
procedure Init (Object : Void_Ptr; Acc : out Storage_Element) is
subtype Places is Storage_Offset range 0 .. Object'Length - 1;
package Arb is new Ada.Numerics.Discrete_Random (Storage_Element);
package Pos is new Ada.Numerics.Discrete_Random (Places);
package Math renames Ada.Numerics.Elementary_Functions;
G : Arb.Generator;
P : Pos.Generator;
Offset, Previous_Offset : Storage_Offset := 0;
No_Of_Inits : constant Natural :=
2**(Natural (Math.Log (Float (Object'Length), 2.0))
-
(Small - 4));
begin
Arb.Reset (G); Pos.Reset (P);
Acc := 0;
for Run in 1 .. No_Of_Inits loop
Previous_Offset := Offset;
Offset := Pos.Random (P);
Object (Offset) := Arb.Random (G);
Acc := Acc / 2
+ (Object (Previous_Offset) + Object (Offset)) / 4;
end loop;
end Init;
Buffer : Void_Ptr;
Kept : Storage_Element;
begin
for Power in size_t range Small .. Large loop
Put ("At "); Put (Power);
Put (" ("); Put (2**Natural (Power)); Put (")");
Buffer := new Storage_Array (0 .. 2**Natural (Power));
Init (Buffer, Acc => Kept);
Put_Line (Storage_Element'Image (Kept));
Free (Buffer);
end loop;
end Alloc_Ada;
^ permalink raw reply [relevance 6%]
* Re: Reference counting and idempotent finalize
@ 2013-09-11 12:21 5% ` Jeffrey R. Carter
0 siblings, 0 replies; 200+ results
From: Jeffrey R. Carter @ 2013-09-11 12:21 UTC (permalink / raw)
On 09/11/2013 03:45 AM, Natasha Kerensikova wrote:
> Access_Value.all.Counter := Access_Value.all.Counter - 1;
What happens if Counter is already zero? Can Counter become negative, and if so, what does it mean for Counter to be
negative?
> I neglected the possibility of exceptional flow interruption because I
> felt that an exception in Finalize triggers the end of the world (the
> same way I've felt for a long time the idempotency requirement). Now
> having done the research, 7.6.1(13) doesn't really mention the world
> ending, that looks quite close to it, doesn't it?
ARM 7.6.1 says, "It is a bounded error for a call on Finalize or Adjust that occurs as part of object finalization or
assignment to propagate an exception." My practice has, therefore, been to always ensure that Finalize cannot propagate
an exception.
FWIW, Finalize from PragmARC.Safe_Pointers looks like
procedure Finalize (Item : in out Safe_Pointer) is
procedure Free is new Ada.Unchecked_Deallocation (Object => Safe_Group, Name => Name);
begin -- Finalize
if Item.Ptr /= null then
if Item.Ptr.Count > 0 then
Item.Ptr.Count := Item.Ptr.Count - 1;
end if;
if Item.Ptr.Count = 0 then
Free (Item.Ptr);
end if;
Item.Ptr := null;
end if;
end Finalize;
I have convinced myself that this cannot propagate an exception (except Storage_Error, of course, since anything can
result in Storage_Error). It might be easier (and safer) to always have "exception when others => null;" on every Finalize.
The PragmAda Reusable Components, including the full implementation of PragmARC.Safe_Pointers, are at
pragmada.x10hosting.com
--
Jeff Carter
"Now go away or I shall taunt you a second time."
Monty Python and the Holy Grail
--- news://freenews.netfront.net/ - complaints: news@netfront.net ---
^ permalink raw reply [relevance 5%]
* Re: Anonymous access types are evil, why?
@ 2013-08-30 16:16 4% ` Gerhard Rummel
0 siblings, 0 replies; 200+ results
From: Gerhard Rummel @ 2013-08-30 16:16 UTC (permalink / raw)
Am Mittwoch, 28. August 2013 05:49:56 UTC-6 schrieb ake.ragna...@gmail.com:
> Consider the following application that uses anonymous access types and allocates Controlled objects on the heap using two different ways. One way takes 60 times longer than the other:
>
> ....
>
>
>
> What are the conclusions we can draw?
>
> 1. Perhaps one conclusion would be that when using anonymous access types then indirect assignment should be preferred over direct assignment. (see Models.B.Direct_Assignment and Models.B.Indirect_Assignment).
>
> 2. Avoid anonymous access types. Prefer named access types and 'Unchecked_Access.
>
>
>
> Is there anybody who can explain why direct assignment takes approximately 60 times longer than indirect assignment?
>
>
>
> Best regards,
>
> Åke Ragnar Dahlgren
I think there is a problem with the implementation of Controlled Types in
gnat2012, and NOT with anonymous access types: if you change the declaration of A_Type to a not controlled record there is nearly no difference in runtime: To show that I have declared three versions of your A_Type (in Models.A): as a record, a tagged record and as derived from Ada.Finalization.Controlled. Then I declared six versions of your B_Type, with anonymous and named access variables of each of the three types. Additionally, I cleaned up the heap before the direct or indirect assignments.
The output of the Main program is now:
Output:
Heap clean up before assignment: TRUE
MODELS.B.TYPE_WITH_RECORD_ACCESS_TYPE, Duration (direct assignment): 0.005783000
MODELS.B.TYPE_WITH_RECORD_ACCESS_TYPE, Duration (indirect assignment): 0.002435000
MODELS.B.TYPE_WITH_ANONYMOUS_RECORD_ACCESS_TYPE, Duration (direct assignment): 0.002283000
MODELS.B.TYPE_WITH_ANONYMOUS_RECORD_ACCESS_TYPE, Duration (indirect assignment): 0.002263000
MODELS.B.TYPE_WITH_TAGGED_RECORD_ACCESS_TYPE, Duration (direct assignment): 0.002298000
MODELS.B.TYPE_WITH_TAGGED_RECORD_ACCESS_TYPE, Duration (indirect assignment): 0.002263000
MODELS.B.TYPE_WITH_ANONYMOUS_TAGGED_RECORD_ACCESS_TYPE, Duration (direct assignment): 0.002304000
MODELS.B.TYPE_WITH_ANONYMOUS_TAGGED_RECORD_ACCESS_TYPE, Duration (indirect assignment): 0.002553000
MODELS.B.TYPE_WITH_CONTROLLED_ACCESS_TYPE, Duration (direct assignment): 0.005504000
MODELS.B.TYPE_WITH_CONTROLLED_ACCESS_TYPE, Duration (indirect assignment): 0.005505000
MODELS.B.TYPE_WITH_ANONYMOUS_CONTROLLED_ACCESS_TYPE, Duration (direct assignment): 0.010914000
MODELS.B.TYPE_WITH_ANONYMOUS_CONTROLLED_ACCESS_TYPE, Duration (indirect assignment): 0.005706000
As you can see, the quotient of the runtimes of the two methods of assignments is now a factor less than two, if your A_Type is Controlled and more than two, if your A_Type is a simple record instead of a Controlled type.
Things are much worse for Controlled types when you don't clean up the heap before the assignments:
Output:
Heap clean up before assignment: FALSE
MODELS.B.TYPE_WITH_RECORD_ACCESS_TYPE, Duration (direct assignment): 0.066929000
MODELS.B.TYPE_WITH_RECORD_ACCESS_TYPE, Duration (indirect assignment): 0.063081000
MODELS.B.TYPE_WITH_ANONYMOUS_RECORD_ACCESS_TYPE, Duration (direct assignment): 0.063031000
MODELS.B.TYPE_WITH_ANONYMOUS_RECORD_ACCESS_TYPE, Duration (indirect assignment): 0.062613000
MODELS.B.TYPE_WITH_TAGGED_RECORD_ACCESS_TYPE, Duration (direct assignment): 0.062416000
MODELS.B.TYPE_WITH_TAGGED_RECORD_ACCESS_TYPE, Duration (indirect assignment): 0.062329000
MODELS.B.TYPE_WITH_ANONYMOUS_TAGGED_RECORD_ACCESS_TYPE, Duration (direct assignment): 0.061632000
MODELS.B.TYPE_WITH_ANONYMOUS_TAGGED_RECORD_ACCESS_TYPE, Duration (indirect assignment): 0.062526000
MODELS.B.TYPE_WITH_CONTROLLED_ACCESS_TYPE, Duration (direct assignment): 0.064492000
MODELS.B.TYPE_WITH_CONTROLLED_ACCESS_TYPE, Duration (indirect assignment): 0.064068000
MODELS.B.TYPE_WITH_ANONYMOUS_CONTROLLED_ACCESS_TYPE, Duration (direct assignment): 11.441936000
MODELS.B.TYPE_WITH_ANONYMOUS_CONTROLLED_ACCESS_TYPE, Duration (indirect assignment): 0.063594000
In the last four lines you can see that the runtimes for the two methods of assignments are nearly equal for a B_Type with a named access type variable of a Controlled type and very different for anonymous access type variables.
I think there is no important performance difference between anonymous and named access variables if you clean up the heap before assigning new values to them. But there is a problem with the finalization of Controlled type variables on the heap, perhaps due to their implementation in gnat 2012.
The code of the program:
with Ada.Text_IO;
with Models.B;
procedure Main is
Number_Of_Times : constant Positive := 40000;
begin
for B in reverse Boolean range False .. True loop
declare
RT : Models.B.Type_With_Record_Access_Type;
ART : Models.B.Type_With_Anonymous_Record_Access_Type;
TRT : Models.B.Type_With_Tagged_Record_Access_Type;
ATRT : Models.B.Type_With_Anonymous_Tagged_Record_Access_Type;
CT : Models.B.Type_With_Controlled_Access_Type;
ACT : Models.B.Type_With_Anonymous_Controlled_Access_Type;
begin
Models.B.With_Heap_Cleaning := B;
Ada.Text_IO.Put_Line
(Item => "Heap clean up before assignment: "
& Boolean'Image (Models.B.With_Heap_Cleaning)
);
RT.Measure_Time (Number_Of_Times => Number_Of_Times);
ART.Measure_Time (Number_Of_Times => Number_Of_Times);
TRT.Measure_Time (Number_Of_Times => Number_Of_Times);
ATRT.Measure_Time (Number_Of_Times => Number_Of_Times);
CT.Measure_Time (Number_Of_Times => Number_Of_Times);
ACT.Measure_Time (Number_Of_Times => Number_Of_Times);
Ada.Text_IO.New_Line;
end;
end loop;
end Main;
package Models is
end Models;
with Ada.Finalization;
with Ada.Unchecked_Deallocation;
package Models.A is
type Record_Type is record
Asdf : Integer;
qwer : String (1 .. 8000);
end record;
type Record_Access_Type is access all Record_Type;
procedure Delete is new Ada.Unchecked_Deallocation
(Object => Record_Type, Name => Record_Access_Type);
type Tagged_Record_Type is tagged record
Asdf : Integer;
qwer : String (1 .. 8000);
end record;
type Tagged_Record_Access_Type is access all Tagged_Record_Type;
procedure Delete is new Ada.Unchecked_Deallocation
(Object => Tagged_Record_Type, Name => Tagged_Record_Access_Type);
type Controlled_Type is new Ada.Finalization.Controlled with
record
Asdf : Integer;
qwer : String (1 .. 8000);
end record;
type Controlled_Access_Type is access all Controlled_Type;
procedure Delete is new Ada.Unchecked_Deallocation
(Object => Controlled_Type, Name => Controlled_Access_Type);
end Models.A;
with Ada.Finalization,
Models.A;
package Models.B is
With_Heap_Cleaning : Boolean := False;
type Type_With_Access_Type is abstract new Ada.Finalization.Controlled
with private;
overriding
procedure Finalize (Item : in out Type_With_Access_Type) with Inline;
function Type_Name (Item : Type_With_Access_Type'Class) return String
with Inline;
procedure Cleanup (Item : in out Type_With_Access_Type) is abstract;
procedure Direct_Assignment (Item : in out Type_With_Access_Type)
is abstract;
procedure Indirect_Assignment (Item : in out Type_With_Access_Type)
is abstract;
procedure Measure_Time
(Item : in out Type_With_Access_Type'Class;
Number_Of_Times : Natural
);
----------------------------------------------------------------------------
type Type_With_Record_Access_Type is new Type_With_Access_Type with private;
overriding
procedure Adjust (Item : in out Type_With_Record_Access_Type) with Inline;
overriding
procedure Cleanup (Item : in out Type_With_Record_Access_Type);
overriding
procedure Direct_Assignment (Item : in out Type_With_Record_Access_Type)
with Inline;
overriding
procedure Indirect_Assignment (Item : in out Type_With_Record_Access_Type)
with Inline;
----------------------------------------------------------------------------
type Type_With_Anonymous_Record_Access_Type is new Type_With_Access_Type
with private;
overriding
procedure Adjust (Item : in out Type_With_Anonymous_Record_Access_Type)
with Inline;
overriding
procedure Cleanup (Item : in out Type_With_Anonymous_Record_Access_Type);
overriding
procedure Direct_Assignment
(Item : in out Type_With_Anonymous_Record_Access_Type) with Inline;
overriding
procedure Indirect_Assignment
(Item : in out Type_With_Anonymous_Record_Access_Type) with Inline;
----------------------------------------------------------------------------
type Type_With_Tagged_Record_Access_Type is new Type_With_Access_Type
with private;
overriding
procedure Adjust (Item : in out Type_With_Tagged_Record_Access_Type)
with Inline;
overriding
procedure Cleanup (Item : in out Type_With_Tagged_Record_Access_Type);
overriding
procedure Direct_Assignment
(Item : in out Type_With_Tagged_Record_Access_Type) with Inline;
overriding
procedure Indirect_Assignment
(Item : in out Type_With_Tagged_Record_Access_Type) with Inline;
----------------------------------------------------------------------------
type Type_With_Anonymous_Tagged_Record_Access_Type is
new Type_With_Access_Type with private;
overriding
procedure Adjust
(Item : in out Type_With_Anonymous_Tagged_Record_Access_Type) with Inline;
overriding
procedure Cleanup
(Item : in out Type_With_Anonymous_Tagged_Record_Access_Type);
overriding
procedure Direct_Assignment
(Item : in out Type_With_Anonymous_Tagged_Record_Access_Type) with Inline;
overriding
procedure Indirect_Assignment
(Item : in out Type_With_Anonymous_Tagged_Record_Access_Type) with Inline;
----------------------------------------------------------------------------
type Type_With_Controlled_Access_Type is new Type_With_Access_Type
with private;
overriding
procedure Adjust (Item : in out Type_With_Controlled_Access_Type)
with Inline;
overriding
procedure Cleanup (Item : in out Type_With_Controlled_Access_Type);
overriding
procedure Direct_Assignment
(Item : in out Type_With_Controlled_Access_Type) with Inline;
overriding
procedure Indirect_Assignment
(Item : in out Type_With_Controlled_Access_Type) with Inline;
----------------------------------------------------------------------------
type Type_With_Anonymous_Controlled_Access_Type is new Type_With_Access_Type
with private;
overriding
procedure Adjust (Item : in out Type_With_Anonymous_Controlled_Access_Type)
with Inline;
overriding
procedure Cleanup
(Item : in out Type_With_Anonymous_Controlled_Access_Type);
overriding
procedure Direct_Assignment
(Item : in out Type_With_Anonymous_Controlled_Access_Type) with Inline;
overriding
procedure Indirect_Assignment
(Item : in out Type_With_Anonymous_Controlled_Access_Type) with Inline;
private
type Type_With_Access_Type is abstract new Ada.Finalization.Controlled
with null record;
type Type_With_Record_Access_Type is new Type_With_Access_Type with record
A : Models.A.Record_Access_Type;
end record;
type Type_With_Anonymous_Record_Access_Type is new Type_With_Access_Type
with record
A : access Models.A.Record_Type;
end record;
type Type_With_Tagged_Record_Access_Type is new Type_With_Access_Type
with record
A : Models.A.Tagged_Record_Access_Type;
end record;
type Type_With_Anonymous_Tagged_Record_Access_Type is
new Type_With_Access_Type with record
A : access Models.A.Tagged_Record_Type;
end record;
type Type_With_Controlled_Access_Type is new Type_With_Access_Type
with record
A : Models.A.Controlled_Access_Type;
end record;
type Type_With_Anonymous_Controlled_Access_Type is new Type_With_Access_Type
with record
A : access Models.A.Controlled_Type;
end record;
end Models.B;
with Ada.Real_Time;
with Ada.Tags;
with Ada.Text_IO;
package body Models.B is
overriding
procedure Finalize (Item : in out Type_With_Access_Type)
is
begin
Type_With_Access_Type'Class (Item).Cleanup;
end Finalize;
function Type_Name (Item : Type_With_Access_Type'Class) return String
is
begin
return Ada.Tags.External_Tag (T => Item'Tag);
end Type_Name;
procedure Measure_Time
(Item : in out Type_With_Access_Type'Class;
Number_Of_Times : Natural
)
is
Start_Time_Stamp : Ada.Real_Time.Time;
End_Time_Stamp : Ada.Real_Time.Time;
begin
Start_Time_Stamp := Ada.Real_Time.Clock;
for I in 1 .. Number_Of_Times loop
Item.Direct_Assignment;
end loop;
End_Time_Stamp := Ada.Real_Time.Clock;
declare
use type Ada.Real_Time.Time;
Total_Time : constant Duration
:= Ada.Real_Time.To_Duration (End_Time_Stamp - Start_Time_Stamp);
begin
Ada.Text_IO.Put_Line
(Item.Type_Name
& ", Duration (direct assignment): " & Total_Time'Img
);
end;
Start_Time_Stamp := Ada.Real_Time.Clock;
for I in 1 .. Number_Of_Times loop
Item.Indirect_Assignment;
end loop;
End_Time_Stamp := Ada.Real_Time.Clock;
declare
use type Ada.Real_Time.Time;
Total_Time : constant Duration
:= Ada.Real_Time.To_Duration (End_Time_Stamp - Start_Time_Stamp);
begin
Ada.Text_IO.Put_Line
(Item.Type_Name
& ", Duration (indirect assignment): " & Total_Time'Img
);
end;
end Measure_Time;
----------------------------------------------------------------------------
overriding
procedure Adjust (Item : in out Type_With_Record_Access_Type)
is
use Models.A;
begin
if Item.A /= null then
Item.A := new Models.A.Record_Type'(Item.A.all);
end if;
end Adjust;
overriding
procedure Cleanup (Item : in out Type_With_Record_Access_Type)
is
use Models.A;
X : Models.A.Record_Access_Type := Item.A;
begin
Item.A := null;
if X /= null then
Delete (X);
end if;
end Cleanup;
overriding
procedure Direct_Assignment (Item : in out Type_With_Record_Access_Type) is
use Models.A;
begin
if With_Heap_Cleaning then
Item.Cleanup;
end if;
Item.A := new Models.A.Record_Type;
end Direct_Assignment;
overriding
procedure Indirect_Assignment (Item : in out Type_With_Record_Access_Type)
is
use Models.A;
begin
if With_Heap_Cleaning then
Item.Cleanup;
end if;
declare
A : constant Models.A.Record_Access_Type := new Models.A.Record_Type;
begin
Item.A := A;
end;
end Indirect_Assignment;
---------------------------------------------------------------------------
overriding
procedure Adjust (Item : in out Type_With_Anonymous_Record_Access_Type)
is
use Models.A;
begin
if Item.A /= null then
Item.A := new Models.A.Record_Type'(Item.A.all);
end if;
end Adjust;
overriding
procedure Cleanup (Item : in out Type_With_Anonymous_Record_Access_Type)
is
use Models.A;
X : Models.A.Record_Access_Type := Item.A;
begin
Item.A := null;
if X /= null then
Delete (X);
end if;
end Cleanup;
overriding
procedure Direct_Assignment
(Item : in out Type_With_Anonymous_Record_Access_Type)
is
use Models.A;
begin
if With_Heap_Cleaning then
Item.Cleanup;
end if;
Item.A := new Models.A.Record_Type;
end Direct_Assignment;
overriding
procedure Indirect_Assignment
(Item : in out Type_With_Anonymous_Record_Access_Type)
is
use Models.A;
begin
if With_Heap_Cleaning then
Item.Cleanup;
end if;
declare
A : constant Models.A.Record_Access_Type := new Models.A.Record_Type;
begin
Item.A := A;
end;
end Indirect_Assignment;
---------------------------------------------------------------------------
overriding
procedure Adjust (Item : in out Type_With_Tagged_Record_Access_Type)
is
use Models.A;
begin
if Item.A /= null then
Item.A := new Models.A.Tagged_Record_Type'(Item.A.all);
end if;
end Adjust;
overriding
procedure Cleanup (Item : in out Type_With_Tagged_Record_Access_Type)
is
use Models.A;
X : Models.A.Tagged_Record_Access_Type := Item.A;
begin
Item.A := null;
if X /= null then
Delete (X);
end if;
end Cleanup;
overriding
procedure Direct_Assignment
(Item : in out Type_With_Tagged_Record_Access_Type)
is
use Models.A;
begin
if With_Heap_Cleaning then
Item.Cleanup;
end if;
Item.A := new Models.A.Tagged_Record_Type;
end Direct_Assignment;
overriding
procedure Indirect_Assignment
(Item : in out Type_With_Tagged_Record_Access_Type)
is
use Models.A;
begin
if With_Heap_Cleaning then
Item.Cleanup;
end if;
declare
A : constant Models.A.Tagged_Record_Access_Type
:= new Models.A.Tagged_Record_Type;
begin
Item.A := A;
end;
end Indirect_Assignment;
---------------------------------------------------------------------------
overriding
procedure Adjust
(Item : in out Type_With_Anonymous_Tagged_Record_Access_Type)
is
use Models.A;
begin
if Item.A /= null then
Item.A := new Models.A.Tagged_Record_Type'(Item.A.all);
end if;
end Adjust;
overriding
procedure Cleanup
(Item : in out Type_With_Anonymous_Tagged_Record_Access_Type)
is
use Models.A;
X : Models.A.Tagged_Record_Access_Type := Item.A;
begin
Item.A := null;
if X /= null then
Delete (X);
end if;
end Cleanup;
overriding
procedure Direct_Assignment
(Item : in out Type_With_Anonymous_Tagged_Record_Access_Type)
is
use Models.A;
begin
if With_Heap_Cleaning then
Item.Cleanup;
end if;
Item.A := new Models.A.Tagged_Record_Type;
end Direct_Assignment;
overriding
procedure Indirect_Assignment
(Item : in out Type_With_Anonymous_Tagged_Record_Access_Type)
is
use Models.A;
begin
if With_Heap_Cleaning then
Item.Cleanup;
end if;
declare
A : constant Models.A.Tagged_Record_Access_Type
:= new Models.A.Tagged_Record_Type;
begin
Item.A := A;
end;
end Indirect_Assignment;
---------------------------------------------------------------------------
overriding
procedure Adjust (Item : in out Type_With_Controlled_Access_Type)
is
use Models.A;
begin
if Item.A /= null then
Item.A := new Models.A.Controlled_Type'(Item.A.all);
end if;
end Adjust;
overriding
procedure Cleanup (Item : in out Type_With_Controlled_Access_Type)
is
use Models.A;
X : Models.A.Controlled_Access_Type := Item.A;
begin
Item.A := null;
if X /= null then
Delete (X);
end if;
end Cleanup;
overriding
procedure Direct_Assignment (Item : in out Type_With_Controlled_Access_Type)
is
use Models.A;
begin
if With_Heap_Cleaning then
Item.Cleanup;
end if;
Item.A := new Models.A.Controlled_Type;
end Direct_Assignment;
overriding
procedure Indirect_Assignment
(Item : in out Type_With_Controlled_Access_Type)
is
use Models.A;
begin
if With_Heap_Cleaning then
Item.Cleanup;
end if;
declare
A : constant Models.A.Controlled_Access_Type
:= new Models.A.Controlled_Type;
begin
Item.A := A;
end;
end Indirect_Assignment;
---------------------------------------------------------------------------
overriding
procedure Adjust (Item : in out Type_With_Anonymous_Controlled_Access_Type)
is
use Models.A;
begin
if Item.A /= null then
Item.A := new Models.A.Controlled_Type'(Item.A.all);
end if;
end Adjust;
overriding
procedure Cleanup
(Item : in out Type_With_Anonymous_Controlled_Access_Type)
is
use Models.A;
X : Models.A.Controlled_Access_Type := Item.A;
begin
Item.A := null;
if X /= null then
Delete (X);
end if;
end Cleanup;
overriding
procedure Direct_Assignment
(Item : in out Type_With_Anonymous_Controlled_Access_Type)
is
use Models.A;
begin
if With_Heap_Cleaning then
Item.Cleanup;
end if;
Item.A := new Models.A.Controlled_Type;
end Direct_Assignment;
overriding
procedure Indirect_Assignment
(Item : in out Type_With_Anonymous_Controlled_Access_Type)
is
use Models.A;
begin
if With_Heap_Cleaning then
Item.Cleanup;
end if;
declare
A : constant Models.A.Controlled_Access_Type
:= new Models.A.Controlled_Type;
begin
Item.A := A;
end;
end Indirect_Assignment;
end Models.B;
^ permalink raw reply [relevance 4%]
* Re: Questions on Storage Pools
@ 2013-08-13 19:36 6% ` AdaMagica
0 siblings, 0 replies; 200+ results
From: AdaMagica @ 2013-08-13 19:36 UTC (permalink / raw)
On Monday, August 12, 2013 7:14:23 PM UTC+2, Adam Beneschan wrote:
> I think you're confusing "finalization" with "storage reclamation". They're not the same thing.
I guess you're right. The dust falling out of the worn RM is clearing now.
Thanx Adam.
> An access type can have a Storage_Size clause, or it can have a Storage_Pool clause. It cannot have both (13.11(3)).
Yes, I know.
> If it has a Storage_Size clause, the intent is that some block of memory (whose size is Storage_Size plus possibly a little extra) is set aside, and all "new" operations that return the access type use memory in that block for the new object.
I understand and know this. But: Is there a GNAT GPL 2013 bug in this program:
declare
type Dyn is new Ada.Finalization.Controlled with record
I: Integer;
end record;
overriding procedure Finalize (X: in out Dyn) is
begin
Put_Line ("Finalizing" & Integer'Image (X.I));
end Finalize;
type Dyn_Access is access Dyn
with Storage_Size => 100;
procedure Free is new Ada.Unchecked_Deallocation (Dyn, Dyn_Access);
-- Dyn_Access is frozen here, so the collection is implicitly defined here.
Ptr: array (1 .. 5) of Dyn_Access;
begin
Ptr (1) := new Dyn'(Ada.Finalization.Controlled with I => 1);
Ptr (2) := new Dyn'(Ada.Finalization.Controlled with I => 2);
Ptr (3) := new Dyn'(Ada.Finalization.Controlled with I => 3);
Free (Ptr (2)); -- Finalize is called here
Ptr (2) := new Dyn'(Ada.Finalization.Controlled with I => 4);
-- RM 7.6.1(11.1/3)
-- Each nonderived access type T has an associated collection, which is the set of objects
-- created by allocators of T... Unchecked_Deallocation removes an object from its collection.
-- Finalization of a collection consists of finalization of each object in the collection,
-- in an arbitrary order. The collection of an access type is an object implicitly declared
-- at the following place:
-- RM 7.6.1(11.2/3)
-- For a named access type, the first freezing point (see 13.14) of the type.
-- RM 13.11(18)
-- If Storage_Size is specified for an access type, then ... the storage for the pool is
-- reclaimed when the master containing the declaration of the access type is left.
Put_Line ("Must finalize collection now and reclaim pool storage.");
end; -- no Finalize called here!
There is no finalization of the still existing allocated objects. The collection is dying, so it should be finalized and with it all still existing allocated objects. It's irrelevant if there is the aspect Storage_Size or not.
If there is Storage_Size, the storage will be freed. If there is none, the storage remains allocated (with finalized objects inside). Correct?
^ permalink raw reply [relevance 6%]
* Re: Ada and string literals
@ 2013-02-01 21:16 7% ` gautier_niouzes
0 siblings, 0 replies; 200+ results
From: gautier_niouzes @ 2013-02-01 21:16 UTC (permalink / raw)
Le mercredi 30 janvier 2013 17:52:32 UTC+1, codeallergy a écrit :
> another question: how free a object from a procedure ?
with Ada.Unchecked_Deallocation;
...
procedure Free is new Ada.Unchecked_Deallocation(String, String_Access);
> example:
> procedure Free_Abc (Target : access String)
> is
> begin
> GNAT.Strings.Free(Target); -- error
> end Free_Abc;
>
> this code produce the error: actual for "X" must be a variable
>
> why disallow that ?
The access parameter seems to be like an "in" parameter and treated as a local constant (only a guess, I don't use access parameters).
What you pass as an "in" parameter is not certainly a variable
You could have a call like Free_Abc(null);
Similarly you could have
procedure Do_something(x: in Integer) is
begin
x:= x + 1; -- same error
end;
But with the "in" parameter, you could have a call like
Do_something(1234);
which makes the x:= x + 1 nonsensical.
Cheers
Gautier
^ permalink raw reply [relevance 7%]
* Re: Question about library-level functions
@ 2012-12-15 10:50 7% ` ytomino
0 siblings, 0 replies; 200+ results
From: ytomino @ 2012-12-15 10:50 UTC (permalink / raw)
On Saturday, December 15, 2012 6:47:10 PM UTC+9, AdaMagica wrote:
> I guess that, since P is unused, the compiler optimizes the sequence of calls
> and finalizes P first.
hurm...So, I tried to change it to do explicit free P.
---- %< ----
with Ada.Text_IO;
with Ada.Unchecked_Deallocation;
with lifetime;
with alloc;
procedure main is
begin
Ada.Text_IO.Put_Line ("before");
declare
type A is access all lifetime.T;
procedure Free is new Ada.Unchecked_Deallocation (lifetime.T, A);
P : A := A(alloc);
begin
Ada.Text_IO.Put_Line ("lifetime");
Free (P);
end;
Ada.Text_IO.Put_Line ("after");
end main;
---- %> ----
As a result, lifetime.Finalize was called twice.
% ./main
before
Initialize (0000000100100090)
Finalize (0000000100100090)
lifetime
Finalize (0000000100100090)
after
> Finalize may not be called in Alloc,
Surely, lifetime.Finalize may be called in 'Alloc'.
The backtrace of gdb is:
#0 lifetime__finalize__2 (object=) at lifetime.adb:7
#1 0x0000000100001a9c in lifetime__tFD () at lifetime.adb:4
#2 0x000000010000da39 in system__finalization_masters__finalize (master=) at s-finmas.adb:241
#3 0x00000001000026d8 in _ada_alloc () at alloc.adb:5
#4 0x00000001000028f2 in _ada_main () at main.adb:11
> since the object must be created in place
> (it's limited - there cannot be an intermediate object as in the unlimited
> case).
lifetime.T is limited. However, an access value of it is not limited.
Perhaps AARM 7.6.1 says the anonymous access type belongs to innermost master.
The master is usually in the package and lets objects live long time.
I imagine, if a function is library-level, there is no place which it puts the master, so the master is inside of the function...???
^ permalink raw reply [relevance 7%]
* Re: Task with access to itself?
@ 2012-12-05 14:18 5% ` Dmitry A. Kazakov
0 siblings, 0 replies; 200+ results
From: Dmitry A. Kazakov @ 2012-12-05 14:18 UTC (permalink / raw)
On Wed, 05 Dec 2012 14:53:53 +0100, Jacob Sparre Andersen wrote:
> I would like to maintain a collection of tasks, where the tasks
> themselves can register their availability.
[...]
> Any suggestions?
Active object?
type Active_Object is
abstract new Ada.Finalization.Limited_Controlled with private;
overriding procedure Initialize (Object : in out Active_Object);
overriding procedure Finalize (Object : in out Active_Object);
procedure Do_Stuff (Object : in out Active_Object) is abstract;
private
task type Worker (Object : not null access Active_Object'Class) is
entry Stop;
end Worker;
type Active_Object is
abstract new Ada.Finalization.Limited_Controlled with
record
Handler : not null access Worker :=
new Worker (Active_Object'Access);
end record;
-------------------------------------------------------------------------------------------
procedure Initialize (Object : in out Active_Object) is
begin
-- Register Object or else its task
end Initialize;
procedure Finalize (Object : in out Active_Object) is
type Worker_Ptr is access all Worker;
Ptr : Worker_Ptr;
procedure Free is
new Ada.Unchecked_Deallocation (Worker, Worker_Ptr)
begin
-- Unregister
Object.Handler.Stop;
while not Object.Handler'Terminated loop
delay 0.001;
end loop;
Ptr := Object.Handler.all'Unchecked_Access;
Free (Ptr);
end Finalize;
--
Regards,
Dmitry A. Kazakov
http://www.dmitry-kazakov.de
^ permalink raw reply [relevance 5%]
* GNATCOLL SQLite rollback vs cursor
@ 2012-08-31 10:34 5% Stephen Leake
0 siblings, 0 replies; 200+ results
From: Stephen Leake @ 2012-08-31 10:34 UTC (permalink / raw)
I've come across a strange problem using GNATCOLL with SQLite, and I'm
hoping someone can shed some light on it.
Here's code illustrating the problem:
-- Fixes bug
with Ada.Directories;
with Ada.Text_IO; use Ada.Text_IO;
with Ada.Unchecked_Deallocation;
with GNATCOLL.SQL.Exec; use GNATCOLL.SQL.Exec;
with GNATCOLL.SQL.Sqlite;
procedure Rollback_Bug_3
is
Db_Filename : constant String := "books.db";
Connection : Database_Connection;
type Cursor_Access_Type is access all Forward_Cursor;
Cursor : Cursor_Access_Type;
procedure Free is new Ada.Unchecked_Deallocation (Forward_Cursor, Cursor_Access_Type);
procedure Insert
(First : in String;
Last : in String)
is
begin
Put_Line ("Insert " & First & " " & Last);
Execute
(Connection,
"INSERT INTO Author (First, Last) VALUES (""" & First & """, """ & Last & """)");
if not Connection.Success then
-- GNATCOLL SQLite has obscure behavior with respect to
-- cursors and rollback; if a cursor is active, it prevents
-- Rollback from working (SQLite reports "database locked").
-- It doesn't prevent a successful INSERT. So we have to
-- Finalize any cursor before calling Rollback. Another
-- GNATCOLL quirk makes Finalize (Cursor) not visible, so we
-- use allocations. Sigh.
Free (Cursor); -- delete this to see the problem
Rollback (Connection);
else
Commit (Connection);
end if;
-- Find the just inserted ID for mapping (not using
-- Exec.Last_ID becuase I didn't know about it :)
if Cursor = null then
Cursor := new Forward_Cursor;
end if;
Cursor.Fetch
(Connection,
"SELECT ID, First, Last FROM Author WHERE First = """ & First & """ and Last = """ & Last & """");
if Cursor.Has_Row then
Put_Line ("ID => " & Cursor.Value (0));
end if;
end Insert;
begin
-- Create db from scratch
if Ada.Directories.Exists (Db_Filename) then
Ada.Directories.Delete_File (Db_Filename);
end if;
Connection := Build_Connection (GNATCOLL.SQL.Sqlite.Setup (Db_Filename));
-- Create Author table
Execute
(Connection,
"CREATE TABLE Author (ID INTEGER PRIMARY KEY, First TEXT, Last TEXT)");
Execute
(Connection,
"CREATE UNIQUE INDEX Author_Last on Author (Last, First)");
Execute
(Connection,
"CREATE UNIQUE INDEX Author_First on Author (First, Last)");
-- insert a couple of items, checking for success
Insert ("Ada", "Lovelace");
Insert ("Charles", "Babbage");
-- So far so good. Now try to insert Ada Lovelace again; fails
-- because of 'unique' constraint on Author_Name index
Insert ("Ada", "Lovelace");
-- Database be ok; try to add another name
Insert ("Grace", "Hopper");
end Rollback_Bug_3;
This code works properly, giving a reasonable error message for the
attempt to insert a duplicate message:
./rollback_bug_3.exe
Insert Ada Lovelace
ID => 1
Insert Charles Babbage
ID => 2
Insert Ada Lovelace
[SQL.ERROR] Failed to execute INSERT INTO Author (First, Last) VALUES ("Ada", "Lovelace") error=constraint failed
ID => 1
Insert Grace Hopper
ID => 3
However, my first version of this did not free the cursor; commenting
that out gives:
./rollback_bug_3.exe
Insert Ada Lovelace
ID => 1
Insert Charles Babbage
ID => 2
Insert Ada Lovelace
[SQL.ERROR] Failed to execute INSERT INTO Author (First, Last) VALUES ("Ada", "Lovelace") error=constraint failed
[SQL.ERROR] Failed to execute ROLLBACK error=database is locked
ID => 1
Insert Grace Hopper
[SQL.ERROR] Failed to execute BEGIN error=SQL logic error or missing database
[SQL.ERROR] Failed to execute ROLLBACK error=database is locked
Apparently the cursor holds some sort of lock on the database. But I can
insert new records while the cursor is active; the only thing I can't do
is rollback.
This seems to be an SQLite issue, not a GNATCOLL issue, so perhaps I
should take this to an SQLite mailing list.
--
-- Stephe
^ permalink raw reply [relevance 5%]
* Re: Tasking, AWS and segmentation faults
@ 2012-04-04 19:09 6% ` Vadim Godunko
0 siblings, 0 replies; 200+ results
From: Vadim Godunko @ 2012-04-04 19:09 UTC (permalink / raw)
On Apr 4, 8:08 pm, tonyg <tonytheg...@gmail.com> wrote:
> I have a function which is an aws response. In that function I have an array of 86400 records which are processed. I was sort of expecting an error and I got one which is
>
> Exception name: STORAGE_ERROR
> Message: s-intman.adb:139 explicit raise
>
> I think I need to reserve some space using the storage pragma but I am wondering if anyone experienced in using AWS have any advice
I guess that you allocate this array on stack, isn't it? You need to
allocate it using 'new' and deallocate it after use by instantiation
of Ada.Unchecked_Deallocation.
^ permalink raw reply [relevance 6%]
* Re: Preventing Unchecked_Deallocation?
2012-02-05 16:42 5% ` Simon Belmont
@ 2012-02-07 16:27 7% ` Robert A Duff
0 siblings, 0 replies; 200+ results
From: Robert A Duff @ 2012-02-07 16:27 UTC (permalink / raw)
Simon Belmont <sbelmont700@gmail.com> writes:
> When you say erroneous, do you mean forbidden by the language (i.e. an
> exception)
No.
>... or that it will cause undefined operation?
Yes. I suggest you look up the definition of "erroneous"
in the Ada RM. It doesn't mean what it means in normal English.
I'm planning to write an AdaCore "gem" on this confusing subject
one of these days.
Ada's "erroneous behavior" is roughly equivalent to C's "undefined
behavior".
>...My concern is
> that if a unit exposes an access value to other units, any of them may
> use UD to delete the object at any time. Obviously this sort of
> behavior would cause the program to quickly crash due to a null
> pointer, ...
That's not obvious! It might crash slowly. Worst of all,
it might not crash -- it might do exactly what you wanted,
and now you have a latent bug that might rear it's ugly
head years later.
As others have suggested, the usual solution is to use
a private type.
You could also have a configuration pragma:
pragma Restrictions(No_Dependence => Ada.Unchecked_Deallocation);
or the GNAT-specific:
pragma Restriction_Warnings(No_Dependence => Ada.Unchecked_Deallocation);
The latter is more flexible.
- Bob
^ permalink raw reply [relevance 7%]
* Re: Preventing Unchecked_Deallocation?
@ 2012-02-05 16:42 5% ` Simon Belmont
2012-02-07 16:27 7% ` Robert A Duff
0 siblings, 1 reply; 200+ results
From: Simon Belmont @ 2012-02-05 16:42 UTC (permalink / raw)
On Feb 4, 9:40 am, AdaMagica <christ-usch.gr...@t-online.de> wrote:
> Don't understand your problem. However, keep in mind that UD with a
> type different from the one with which the objects were allocated is
> erroneous.
When you say erroneous, do you mean forbidden by the language (i.e. an
exception) or that it will cause undefined operation? My concern is
that if a unit exposes an access value to other units, any of them may
use UD to delete the object at any time. Obviously this sort of
behavior would cause the program to quickly crash due to a null
pointer, but all things being equal I would prefer a compile-time
mechanism to prevent the UD outright. For instance:
package ud is
function Get return not null access Integer;
end ud;
package body ud is
type Int_Ptr is access all Integer;
o : Int_Ptr := new Integer'(42);
function Get return not null access Integer is
begin
return o;
end Get;
end ud;
procedure test is
type Fake_Ptr is access all Integer;
procedure Free is new Ada.Unchecked_Deallocation (Object => Integer,
Name => Fake_Ptr);
p : Fake_Ptr;
begin
p := Fake_Ptr(ud.Get); -- cast to a local type
Free (p); -- phuck the whole program
end test;
-sb
^ permalink raw reply [relevance 5%]
* Re: Delayed deallocation of non-terminated task in Gnat?
2011-08-30 18:57 0% ` Niklas Holsti
@ 2011-08-30 19:23 0% ` Dmitry A. Kazakov
0 siblings, 0 replies; 200+ results
From: Dmitry A. Kazakov @ 2011-08-30 19:23 UTC (permalink / raw)
On Tue, 30 Aug 2011 21:57:54 +0300, Niklas Holsti wrote:
> Dmitry A. Kazakov wrote:
>> On Tue, 30 Aug 2011 08:38:52 -0700 (PDT), Adam Beneschan wrote:
>>
>>> I'm having a bit of difficulty figuring out from
>>> the RM what the exact semantics of finalizing an unterminated task
>>> object are, but I'm pretty sure that aborting the task is not one of
>>> them. (Note that this applies only to tasks without discriminants.
>>> If the task has discriminants, freeing it is an
>>> error---13.11.2(11ff).)
>>
>> What is the difference? Is it an attempt to have freed tasks running
>> further? Or an attempt to construct a race condition, e.g. when the task
>> being freed has an open terminate alternative or else has been accepted a
>> rendezvous and now is going down?
>
> I assume that by "it" above, Dmitry is referring to the AdaCore notice
> about a change in the way Unchecked_Deallocation works in on tasks in
> GNAT, as quoted by Marc in his original post:
No, I meant the rationale behind ARM 13.11.2(11), which looks dubious to
me.
> "If Unchecked_Deallocation is called on a non-terminated task (which was
> previously a no-op), the task is now marked to be freed automatically
> when it terminates."
>
> It seems to me that the new behaviour is more useful than the old behaviour.
Maybe. But it is unclear if it is consistent with the expectations of a
naive user. Which is: Unchecked_Deallocation awaits for the task
termination and then frees whatever memory the task is using.
>> Considering this standard pattern:
>>
>> type Object;
>> task type Worker (Self : not null access Object'Class) is
>> entry Shut_Down;
>> end Worker;
>> type Worker_Ptr is access Worker;
>> type Object is new Ada.Finalization.Limited_Controlled with record
>> Worker : Worker_Ptr;
>> end Object;
>> overriding procedure Finalize (This : in out Object);
>
> (I don't think that the use of a controlled type is central to the
> example. Am I wrong, Dmitry?)
It is the most common case when a task has a discriminant. Since task as a
component is a non-starter, the only work-around would be a controlled type
removing its access-to-task component from Finalize.
>> Now the following is a race with a bounded error:
>
> As I understand it, there was a race under the old behaviour, but not
> under the new behaviour.
Well, it could be read as if the choice offered by ARM 13.11.2(12) was
taken. Though according to ARM, it is still a bounded error, and maybe even
worse than that (see the scenario below).
>> procedure Finalize (This : in out Object) is
>> procedure Free is new Ada.Unchecked_Deallocation (...);
>> begin
>> if This.Worker /= null then
>> This.Worker.Shut_Down;
>> Free (This.Worker);
>
> With the old behaviour of Unchecked_Deallocation, the effect of this
> Free call depended on the state of This.Worker: if the task was not yet
> terminated, Free had no effect; if the task was terminated, Free
> deallocated the task object.
>
> With the new behaviour, the task object is always deallocated, either by
> the Free call (if the task is already terminated at that time) or by
> the RTS when the task terminates later, after the Free call.
This is unclear. Because if Free is not blocked, the Object's Finalize
continues, possibly ends (and then the object is freed), while the task is
still running and possibly accessing the object through its discriminant.
This kind of error is unbounded in contradiction to ARM 13.11.2(11). It
would be rather catastrophic behavior.
--
Regards,
Dmitry A. Kazakov
http://www.dmitry-kazakov.de
^ permalink raw reply [relevance 0%]
* Re: Delayed deallocation of non-terminated task in Gnat?
2011-08-30 16:42 7% ` Dmitry A. Kazakov
@ 2011-08-30 18:57 0% ` Niklas Holsti
2011-08-30 19:23 0% ` Dmitry A. Kazakov
0 siblings, 1 reply; 200+ results
From: Niklas Holsti @ 2011-08-30 18:57 UTC (permalink / raw)
Dmitry A. Kazakov wrote:
> On Tue, 30 Aug 2011 08:38:52 -0700 (PDT), Adam Beneschan wrote:
>
>> I'm having a bit of difficulty figuring out from
>> the RM what the exact semantics of finalizing an unterminated task
>> object are, but I'm pretty sure that aborting the task is not one of
>> them. (Note that this applies only to tasks without discriminants.
>> If the task has discriminants, freeing it is an
>> error---13.11.2(11ff).)
>
> What is the difference? Is it an attempt to have freed tasks running
> further? Or an attempt to construct a race condition, e.g. when the task
> being freed has an open terminate alternative or else has been accepted a
> rendezvous and now is going down?
I assume that by "it" above, Dmitry is referring to the AdaCore notice
about a change in the way Unchecked_Deallocation works in on tasks in
GNAT, as quoted by Marc in his original post:
"If Unchecked_Deallocation is called on a non-terminated task (which was
previously a no-op), the task is now marked to be freed automatically
when it terminates."
It seems to me that the new behaviour is more useful than the old behaviour.
> Considering this standard pattern:
>
> type Object;
> task type Worker (Self : not null access Object'Class) is
> entry Shut_Down;
> end Worker;
> type Worker_Ptr is access Worker;
> type Object is new Ada.Finalization.Limited_Controlled with record
> Worker : Worker_Ptr;
> end Object;
> overriding procedure Finalize (This : in out Object);
(I don't think that the use of a controlled type is central to the
example. Am I wrong, Dmitry?)
> Now the following is a race with a bounded error:
As I understand it, there was a race under the old behaviour, but not
under the new behaviour.
> procedure Finalize (This : in out Object) is
> procedure Free is new Ada.Unchecked_Deallocation (...);
> begin
> if This.Worker /= null then
> This.Worker.Shut_Down;
> Free (This.Worker);
With the old behaviour of Unchecked_Deallocation, the effect of this
Free call depended on the state of This.Worker: if the task was not yet
terminated, Free had no effect; if the task was terminated, Free
deallocated the task object.
With the new behaviour, the task object is always deallocated, either by
the Free call (if the task is already terminated at that time) or by
the RTS when the task terminates later, after the Free call.
> end if;
> end Finalize;
>
> which shall be rewritten as:
Under the old behavior, this rewrite was necessary to ensure that the
task is deallocated. Under the new behaviour, it is not necessary. As I
understand it.
> procedure Finalize (This : in out Object) is
> procedure Free is new Ada.Unchecked_Deallocation (...);
> begin
> if This.Worker /= null then
> This.Worker.Shut_Down;
> while not Worker'Terminated loop
> delay 0.1;
> end loop;
> Free (This.Worker);
> end if;
> end Finalize;
--
Niklas Holsti
Tidorum Ltd
niklas holsti tidorum fi
. @ .
^ permalink raw reply [relevance 0%]
* Re: Delayed deallocation of non-terminated task in Gnat?
@ 2011-08-30 16:42 7% ` Dmitry A. Kazakov
2011-08-30 18:57 0% ` Niklas Holsti
0 siblings, 1 reply; 200+ results
From: Dmitry A. Kazakov @ 2011-08-30 16:42 UTC (permalink / raw)
On Tue, 30 Aug 2011 08:38:52 -0700 (PDT), Adam Beneschan wrote:
> I'm having a bit of difficulty figuring out from
> the RM what the exact semantics of finalizing an unterminated task
> object are, but I'm pretty sure that aborting the task is not one of
> them. (Note that this applies only to tasks without discriminants.
> If the task has discriminants, freeing it is an
> error---13.11.2(11ff).)
What is the difference? Is it an attempt to have freed tasks running
further? Or an attempt to construct a race condition, e.g. when the task
being freed has an open terminate alternative or else has been accepted a
rendezvous and now is going down?
Considering this standard pattern:
type Object;
task type Worker (Self : not null access Object'Class) is
entry Shut_Down;
end Worker;
type Worker_Ptr is access Worker;
type Object is new Ada.Finalization.Limited_Controlled with record
Worker : Worker_Ptr;
end Object;
overriding procedure Finalize (This : in out Object);
Now the following is a race with a bounded error:
procedure Finalize (This : in out Object) is
procedure Free is new Ada.Unchecked_Deallocation (...);
begin
if This.Worker /= null then
This.Worker.Shut_Down;
Free (This.Worker);
end if;
end Finalize;
which shall be rewritten as:
procedure Finalize (This : in out Object) is
procedure Free is new Ada.Unchecked_Deallocation (...);
begin
if This.Worker /= null then
This.Worker.Shut_Down;
while not Worker'Terminated loop
delay 0.1;
end loop;
Free (This.Worker);
end if;
end Finalize;
Is it so?
--
Regards,
Dmitry A. Kazakov
http://www.dmitry-kazakov.de
^ permalink raw reply [relevance 7%]
* Re: Using local storage pools...
2011-02-23 19:01 7% Using local storage pools Brian Drummond
@ 2011-02-23 20:51 0% ` Ludovic Brenta
0 siblings, 0 replies; 200+ results
From: Ludovic Brenta @ 2011-02-23 20:51 UTC (permalink / raw)
Brian Drummond writes:
> I am trying to learn a little about storage pools, with a view to
> (hopefully) using local pools to improve the Binary_Trees benchmark in
> the same way as some of the faster C benchmarks.
>
> Arguably they cheat : they do not explicitly free each tree node (the
> "free" call has been deleted!) but free the entire pool at the end of
> the loop. But if that's valid, Ada should be able to do the same.
>
> http://gcc.gnu.org/onlinedocs/gcc-4.1.2/gnat_ugn_unw/Some-Useful-Memory-Pools.html
> suggests System.Pool_Local offers a way to do likewise - a pool that
> is automatically reclaimed when it goes out of scope.
>
> This turns out to have its own performance problem, but that is
> another story...
>
> The question(or four) for now is ... should the following really raise
> Storage_Error, i.e. am I doing something silly, and if so, what? Or
> is this a bug in Gnat?
>
> NOTE - using System.Pool_Global.Unbounded_No_Reclaim_Pool (commented
> out) instead of the pool shown, works as expected.
>
> (Tested on GCC4.5.0 and Libre 2010)
>
> - Brian
>
> ------------------------------------------------------------------------------------
> with System.Pool_Local;
> with System.Pool_Global;
> with Ada.Unchecked_Deallocation;
>
> procedure pooltest is
>
> type Node;
> type Treenode is access Node;
> type Node is record
> Left : Treenode := null;
> Right : Treenode := null;
> Item : Integer := 0;
> end record;
>
> P : System.Pool_Local.Unbounded_Reclaim_Pool;
> --P : System.Pool_Global.Unbounded_No_Reclaim_Pool;
> for Treenode'Storage_Pool use P;
>
> procedure free is new Ada.Unchecked_Deallocation(Node, Treenode);
>
> TestNode : Treenode;
>
> begin
> Testnode := new Node'(null, null, 1);
> free(Testnode);
> end pooltest;
> ------------------------------------------------------------------------------------
This looks like a genuine bug at s-pooloc.adb:114. To trigger the bug,
two conditions must hold simultaneously:
* the pool contains exactly one allocated object.
* the user calls Unchecked_Deallocation on this object.
The buggy code is:
procedure Deallocate
(Pool : in out Unbounded_Reclaim_Pool;
Address : System.Address;
Storage_Size : SSE.Storage_Count;
Alignment : SSE.Storage_Count)
is
pragma Warnings (Off, Storage_Size);
pragma Warnings (Off, Alignment);
Allocated : constant System.Address := Address - Pointers_Size;
begin
if Prev (Allocated).all = Null_Address then
Pool.First := Next (Allocated).all;
Prev (Pool.First).all := Null_Address; ------- <- Storage_Error
else
Next (Prev (Allocated).all).all := Next (Allocated).all;
end if;
if Next (Allocated).all /= Null_Address then
Prev (Next (Allocated).all).all := Prev (Allocated).all;
end if;
Memory.Free (Allocated);
end Deallocate;
This procedure is *not* called by the finalization of the pool, which
simply walks the linked list of nodes and deallocates each one, but does
not modify any nodes.
Because this pool is intended for use without any explicit
Unchecked_Deallocation, I would qualify this bug as minor.
The workaround, in your case, is to simply not do any
Unchecked_Deallocation and let the finalization of the storage pool do
the deallocation.
--
Ludovic Brenta.
^ permalink raw reply [relevance 0%]
* Using local storage pools...
@ 2011-02-23 19:01 7% Brian Drummond
2011-02-23 20:51 0% ` Ludovic Brenta
0 siblings, 1 reply; 200+ results
From: Brian Drummond @ 2011-02-23 19:01 UTC (permalink / raw)
I am trying to learn a little about storage pools, with a view to (hopefully)
using local pools to improve the Binary_Trees benchmark in the same way as some
of the faster C benchmarks.
Arguably they cheat : they do not explicitly free each tree node (the "free"
call has been deleted!) but free the entire pool at the end of the loop.
But if that's valid, Ada should be able to do the same.
http://gcc.gnu.org/onlinedocs/gcc-4.1.2/gnat_ugn_unw/Some-Useful-Memory-Pools.html
suggests System.Pool_Local offers a way to do likewise - a pool that is
automatically reclaimed when it goes out of scope.
This turns out to have its own performance problem, but that is another story...
The question(or four) for now is ... should the following really raise
Storage_Error, i.e. am I doing something silly, and if so, what?
Or is this a bug in Gnat?
NOTE - using System.Pool_Global.Unbounded_No_Reclaim_Pool
(commented out) instead of the pool shown, works as expected.
(Tested on GCC4.5.0 and Libre 2010)
- Brian
------------------------------------------------------------------------------------
with System.Pool_Local;
with System.Pool_Global;
with Ada.Unchecked_Deallocation;
procedure pooltest is
type Node;
type Treenode is access Node;
type Node is record
Left : Treenode := null;
Right : Treenode := null;
Item : Integer := 0;
end record;
P : System.Pool_Local.Unbounded_Reclaim_Pool;
--P : System.Pool_Global.Unbounded_No_Reclaim_Pool;
for Treenode'Storage_Pool use P;
procedure free is new Ada.Unchecked_Deallocation(Node, Treenode);
TestNode : Treenode;
begin
Testnode := new Node'(null, null, 1);
free(Testnode);
end pooltest;
------------------------------------------------------------------------------------
^ permalink raw reply [relevance 7%]
* Re: Need some light on using Ada or not
@ 2011-02-21 13:44 5% ` Simon Wright
0 siblings, 0 replies; 200+ results
From: Simon Wright @ 2011-02-21 13:44 UTC (permalink / raw)
[-- Attachment #1: Type: text/plain, Size: 367 bytes --]
Brian Drummond <brian_drummond@btconnect.com> writes:
> As this is my first experiment with tasking, comments are welcome (and
> I'd be interested to see your version).
See end.
> If people think this is worth submitting to the shootout, I'll go
> ahead.
I think it definitely is: the only Ada code for binary-trees is
single-threaded, so looks needlessly poor.
[-- Attachment #2: simple multi-thread version of binary trees benchmark --]
[-- Type: text/plain, Size: 5283 bytes --]
----------------------------------------------------------------
-- BinaryTrees
--
-- Ada 95 (GNAT)
--
-- Contributed by Jim Rogers
-- Modified by Simon Wright
----------------------------------------------------------------
with Tree_Nodes; use Tree_Nodes;
with Ada.Text_IO; use Ada.Text_IO;
with Ada.Integer_Text_IO; use Ada.Integer_Text_IO;
with Ada.Command_Line; use Ada.Command_Line;
with Ada.Characters.Latin_1; use Ada.Characters.Latin_1;
with System;
procedure Binarytrees is
Min_Depth : constant Positive := 4;
N : Natural := 1;
Stretch_Tree : Tree_Node;
Long_Lived_Tree : Tree_Node;
Max_Depth : Positive;
Stretch_Depth : Positive;
task type Check_Tree is
pragma Priority (System.Default_Priority - 1);
entry Start (Iterations : Positive; Depth : Positive);
entry Sum (Result : out Integer);
end Check_Tree;
task body Check_Tree is
Iterations : Positive;
Depth : Positive;
Tree : Tree_Node;
Check : Integer := 0;
begin
accept Start (Iterations : Positive; Depth : Positive) do
Check_Tree.Iterations := Iterations;
Check_Tree.Depth := Depth;
end Start;
for J in 1 .. Iterations loop
Tree := Bottom_Up_Tree (J, Depth);
Check := Check + Item_Check (Tree);
Delete_Tree (Tree);
Tree := Bottom_Up_Tree (-J, Depth);
Check := Check + Item_Check (Tree);
Delete_Tree (Tree);
end loop;
accept Sum (Result : out Integer) do
Result := Check;
end Sum;
end Check_Tree;
begin
if Argument_Count > 0 then
N := Positive'Value (Argument (1));
end if;
Max_Depth := Positive'Max (Min_Depth + 2, N);
Stretch_Depth := Max_Depth + 1;
Stretch_Tree := Bottom_Up_Tree (0, Stretch_Depth);
Put ("stretch tree of depth ");
Put (Item => Stretch_Depth, Width => 1);
Put (Ht & " check: ");
Put (Item => Item_Check (Stretch_Tree), Width => 1);
New_Line;
Delete_Tree (Stretch_Tree);
Long_Lived_Tree := Bottom_Up_Tree (0, Max_Depth);
declare
subtype Check_Trees_Array_Range
is Natural range 0 .. (Max_Depth - Min_Depth) / 2;
Check_Trees : array (Check_Trees_Array_Range) of Check_Tree;
function Depth (For_Entry : Check_Trees_Array_Range) return Natural
is
begin
return For_Entry * 2 + Min_Depth;
end Depth;
function Iterations (For_Entry : Check_Trees_Array_Range) return Positive
is
begin
return 2 ** (Max_Depth - Depth (For_Entry) + Min_Depth);
end Iterations;
begin
for D in Check_Trees'Range loop
Check_Trees (D).Start (Iterations => Iterations (D),
Depth => Depth (D));
end loop;
for D in Check_Trees'Range loop
Put (Item => Iterations (D) * 2, Width => 0);
Put (Ht & " trees of depth ");
Put (Item => Depth (D), Width => 0);
declare
Check : Integer;
begin
Check_Trees (D).Sum (Result => Check);
Put (Ht & " check: ");
Put (Item => Check, Width => 0);
end;
New_Line;
end loop;
end;
Put ("long lived tree of depth ");
Put (Item => Max_Depth, Width => 0);
Put (Ht & " check: ");
Put (Item => Item_Check (Long_Lived_Tree), Width => 0);
New_Line;
Delete_Tree (Long_Lived_Tree);
end BinaryTrees;
----------------------------------------------------------------
-- BinaryTrees
--
-- Ada 95 (GNAT)
--
-- Contributed by Jim Rogers
-- Modified by Simon Wright
----------------------------------------------------------------
with Ada.Unchecked_Deallocation;
package body Tree_Nodes is
function Bottom_Up_Tree (Item : Integer; Depth : Natural) return Tree_Node
is
begin
if Depth > 0 then
return new Node'(Bottom_Up_Tree (2 * Item - 1, Depth - 1),
Bottom_Up_Tree (2 * Item, Depth - 1),
Item);
else
return new Node'(null, null, Item);
end if;
end Bottom_Up_Tree;
function Item_Check (This : Tree_Node) return Integer
is
begin
if This.Left = null then
return This.Item;
else
return This.Item + Item_Check (This.Left) - Item_Check (This.Right);
end if;
end Item_Check;
procedure Delete_Tree (This : in out Tree_Node)
is
procedure Free is new Ada.Unchecked_Deallocation (Node, Tree_Node);
begin
if This /= null then
Delete_Tree (This.Left);
Delete_Tree (This.Right);
Free (This);
end if;
end Delete_Tree;
end Tree_Nodes;
----------------------------------------------------------------
-- BinaryTrees
--
-- Ada 95 (GNAT)
--
-- Contributed by Jim Rogers
-- Modified by Simon Wright
----------------------------------------------------------------
package Tree_Nodes is
type Tree_Node is private;
function Bottom_Up_Tree (Item : Integer; Depth : Natural) return Tree_Node;
function Item_Check (This : Tree_Node) return Integer;
procedure Delete_Tree (This : in out Tree_Node);
private
type Node;
type Tree_Node is access Node;
type Node is record
Left : Tree_Node;
Right : Tree_Node;
Item : Integer := 0;
end record;
end Tree_Nodes;
^ permalink raw reply [relevance 5%]
* Re: User Defined Storage Pool : did you ever experiment with it ?
@ 2011-01-24 23:34 0% ` Yannick Duchêne (Hibou57)
0 siblings, 0 replies; 200+ results
From: Yannick Duchêne (Hibou57) @ 2011-01-24 23:34 UTC (permalink / raw)
Le Mon, 24 Jan 2011 15:04:30 +0100, Timo Warns
<Timo.Warns@informatik.uni-oldenburg.de> a écrit:
> As an example, Ada Gem #77 (http://www.adacore.com/2010/01/11/gem-77/)
> shows
> how to use the GNAT debug storage pool for analyzing the memory usage of
> a
> program.
From the above link:
> with My_Package;
> with Ada.Unchecked_Deallocation;
> procedure Main is
> procedure Unchecked_Free is
> new Ada.Unchecked_Deallocation (Integer, Integer_Access);
> Ptr : Integer_Access;
Seems either a use My_Package or a “My_Package.” prefix is missing in the
declaration of Ptr.
From the same link:
> GNAT.Debug_Pools can also give false warnings when
> dereferencing a pointer to aliased data on the stack
> (which was never allocated via a “new” operator, but was
> accessed via an ‘Access attribute).
How can a storage pool catch dereferencing ?
I skipped part II and III which are GNAT or vendor specifics by essence.
Thanks for that pointer.
--
Si les chats miaulent et font autant de vocalises bizarres, c’est pas pour
les chiens.
“I am fluent in ASCII” [Warren 2010]
^ permalink raw reply [relevance 0%]
* Re: User Defined Storage Pool : Example
@ 2011-01-22 9:47 5% ` anon
1 sibling, 0 replies; 200+ results
From: anon @ 2011-01-22 9:47 UTC (permalink / raw)
-- referance delete for spacing
-- Found on www.adapower.com
--
-- http://www.adapower.com/index.php?Command=Class&ClassID=Advanced&CID=222
--
-- Files:
-- memory_management-test.adb
-- memory_management-support.ads
-- memory_management-support.adb
-- memory_management.ads
-- memory_management.adb
--
-- To compile and run:
--
-- >gnat make memory_management-test.adb
-- >memory_management-test
--
-- Memory Management with Storage Pools (Anh Vo)
--
-- Memory management can cause real headache due to memory leakage over
-- time. That is, memory allocation is not properly deallocated after the
-- call. When the memory runs out, the result could be catastrophic for
-- some applications. This problem can be recued by garbage collector
-- built-in the compiler such as Java. However, the cost of run-time
-- overhead is high.
-- Here comes Ada 95 to the recue. How is it possible you may ask? Ah!
-- Ada 95 provides a feature called Storage Pool. It allows the users
-- have total control over the memory management. Best of all, it does
-- not involve run-time overhead as garbage collector. When it is
-- combined with controlled type, the memory leakage problem is history.
-- As shown in the test case, 100 storage elements were allocated
-- initially. Then, these storage elements are reused again and again. It
-- is pretty cool isn't it? Enjoy.
--------------------------------------------
-- File => memory_management-test.adb
--
with Ada.Finalization ;
with Ada.Text_Io ;
with Memory_Management.Support ;
procedure Memory_Management.Test is
use Ada ;
use Text_Io ;
begin
Put_Line ("********* Memory Control Testing Starts **********") ;
for Index in 1 .. 10 loop
declare
David_Botton : Support.General_Data ;
Nick_Roberts : Support.General_Data ;
Anh_Vo : Support.General_Data ;
begin
David_Botton := ( Finalization.Controlled with
Id => new Integer' ( 111 ),
Name => new String' ( "David Botton" ) ) ;
Nick_Roberts := ( Finalization.Controlled with
Id => new Integer' ( 222 ),
Name => new String' ( "Nick Roberts" ) ) ;
Anh_Vo := ( Finalization.Controlled with
Id => new Integer' ( 333 ),
Name => new String' ( "Anh Vo" ) ) ;
end ;
end loop ;
Put_Line ( "Memory Management Test Passes" ) ;
exception
when others =>
Put_Line ( "Memory Management Test Fails" ) ;
end Memory_Management.Test ;
--------------------------------------------
-- File => memory_management-support.ads
--
with Ada.Finalization ;
package Memory_Management.Support is
use Ada ;
-- Adjust the storage size according to the application
Big_Pool : User_Pool ( Size => 100 ) ;
type Int_Acc is access Integer ;
for Int_Acc'Storage_Pool use Big_Pool ;
type Str_Acc is access all String ;
for Str_Acc'Storage_Pool use Int_Acc'Storage_Pool ;
type General_Data is new Finalization.Controlled
with record
Id : Int_Acc ;
Name : Str_Acc ;
end record ;
procedure Initialize ( Object : in out General_Data ) ;
procedure Finalize ( Object : in out General_Data ) ;
end Memory_Management.Support ;
--------------------------------------------
-- File => memory_management-support.adb
--
with Ada.Unchecked_Deallocation ;
package body Memory_Management.Support is
procedure Free is new Ada.Unchecked_Deallocation
( Integer, Int_Acc ) ;
procedure Free is new Ada.Unchecked_Deallocation
( String, Str_Acc ) ;
procedure Initialize ( Object : in out General_Data ) is
begin
null ;
end Initialize ;
procedure Finalize ( Object : in out General_Data ) is
begin
Free ( Object.Id ) ;
Free ( Object.Name ) ;
end Finalize ;
end Memory_Management.Support ;
--------------------------------------------
-- File => memory_management.ads
--
with System.Storage_Pools ;
with System.Storage_Elements ;
package Memory_Management is
use System ;
use Storage_Elements ;
use Storage_Pools ;
type User_Pool ( Size : Storage_Count ) is new
Root_Storage_Pool with private ;
procedure Allocate ( Pool : in out User_Pool ;
Storage_Address : out Address ;
Size_In_Storage_Elements : in Storage_Count ;
Alignment : in Storage_Count ) ;
procedure Deallocate
( Pool : in out User_Pool ;
Storage_Address : in Address ;
Size_In_Storage_Elements : in Storage_Count ;
Alignment : in Storage_Count ) ;
function Storage_Size ( Pool : in User_Pool )
return Storage_Count ;
-- Exeption declaration
Memory_Exhausted : exception ;
Item_Too_Big : exception ;
private
type User_Pool ( Size : Storage_Count ) is new Root_Storage_Pool
with record
Data : Storage_Array ( 1 .. Size ) ;
Addr_Index : Storage_Count := 1 ;
end record ;
end Memory_Management ;
--------------------------------------------
-- File => memory_management.adb
--
with Ada.Exceptions ;
with Ada.Text_Io ;
with System ;
with System.Storage_Elements ;
with System.Address_To_Access_Conversions ;
package body Memory_Management is
use Ada ;
use Text_Io ;
use System ;
use Storage_Elements ;
use type Storage_Count ;
Package_Name : constant String := "Memory_Management." ;
-- Used to turn on/off the debug information
Debug_On : Boolean := True ; -- False ;
type Holder is record
Next_Address : Address := System.Null_Address ;
end record ;
package Addr_To_Acc is new Address_To_Access_Conversions ( Holder ) ;
-- Keep track of the size of memory block for reuse
Free_Storage_Keeper : array ( Storage_Count range 1 .. 100 )
of Address := ( others => Null_Address ) ;
procedure Display_Info ( Message : string ;
With_New_Line : Boolean := True ) is
begin
if Debug_On then
if With_New_Line then
Put_Line ( Message ) ;
else
Put ( Message ) ;
end if ;
end if ;
end Display_Info ;
procedure Allocate ( Pool : in out User_Pool ;
Storage_Address : out Address ;
Size_In_Storage_Elements : in Storage_Count ;
Alignment : in Storage_Count ) is
Procedure_Name : constant String := "Allocate" ;
Temp_Address : Address := Null_Address ;
Marker : Storage_Count ;
begin
Marker := ( Size_In_Storage_Elements + Alignment - 1 )
/ Alignment ;
if Free_Storage_Keeper ( Marker ) /= Null_Address then
Storage_Address := Free_Storage_Keeper ( Marker ) ;
Free_Storage_Keeper (Marker) :=
Addr_To_Acc.To_Pointer
( Free_Storage_Keeper ( Marker ) ).Next_Address ;
else
Temp_Address := Pool.Data (Pool.Addr_Index)'Address ;
Pool.Addr_Index := Pool.Addr_Index
+ Alignment
* ( ( Size_In_Storage_Elements
+ Alignment - 1 )
/ Alignment ) ;
-- make sure memory is available as requested
if Pool.Addr_Index > Pool.Size then
Exceptions.Raise_Exception ( Storage_Error'Identity,
"Storage exhausted in "
& Package_Name
& Procedure_Name ) ;
else
Storage_Address := Temp_Address ;
end if ;
end if ;
Display_Info ( "Address allocated from pool: "
& Integer_Address'Image
( To_Integer ( Storage_Address ) ) ) ;
Display_Info ( "storage elements allocated from pool: "
& Storage_Count'Image
( Size_In_Storage_Elements ) ) ;
Display_Info ( "Alignment in allocation operation: "
& Storage_Count'Image ( Alignment ) ) ;
exception
when Error : others => -- Object too big or memory exhausted
Display_Info ( Exceptions.Exception_Information ( Error ) ) ;
raise ;
end Allocate ;
procedure Deallocate
( Pool : in out User_Pool ;
Storage_Address : in Address ;
Size_In_Storage_Elements : in Storage_Count ;
Alignment : in Storage_Count ) is
Marker : Storage_Count ;
begin
Marker := ( Size_In_Storage_Elements + Alignment - 1)
/ Alignment ;
Addr_To_Acc.To_Pointer ( Storage_Address ).Next_Address :=
Free_Storage_Keeper ( Marker ) ;
Free_Storage_Keeper ( Marker ) := Storage_Address ;
Display_Info ( "Address returned to pool: "
& Integer_Address'Image
( To_Integer ( Storage_Address ) ) ) ;
Display_Info ( "storage elements returned to pool: "
& Storage_Count'Image
( Size_In_Storage_Elements ) ) ;
Display_Info ( "Alignment used in deallocation: "
& Storage_Count'Image ( Alignment ) ) ;
end Deallocate ;
function Storage_Size ( Pool : in User_Pool )
return Storage_Count is
begin
return Pool.Size ;
end Storage_Size ;
end Memory_Management ;
^ permalink raw reply [relevance 5%]
* Re: GNAT bug - still in 2010?
2010-10-27 15:00 7% GNAT bug - still in 2010? Maciej Sobczak
@ 2010-10-27 16:11 0% ` Alexander S. Mentis
0 siblings, 0 replies; 200+ results
From: Alexander S. Mentis @ 2010-10-27 16:11 UTC (permalink / raw)
Maciej Sobczak wrote:
> Consider:
>
> with Ada.Unchecked_Deallocation;
>
> procedure Test is
>
> package P is
> type My_Interface is limited interface;
> procedure Do_Something (X : in out My_Interface) is abstract;
> end P;
>
> protected type My_Protected is new P.My_Interface with
> overriding
> procedure Do_Something;
> end My_Protected;
>
> protected body My_Protected is
> overriding
> procedure Do_Something is
> begin
> null;
> end Do_Something;
> end My_Protected;
>
> type My_Protected_Ptr is access My_Protected;
>
> procedure Free is new Ada.Unchecked_Deallocation
> (Object => My_Protected, Name => My_Protected_Ptr);
>
> Ptr : My_Protected_Ptr;
>
> begin
> -- here come dragons:
> --Free (Ptr);
> null;
> end Test;
>
>
> If the indicated line (call to Free) is uncommented, GNAT crashes in
> flames (GNAT BUG DETECTED).
>
> I was finally able to reduce this to a minimal example, which might be
> a good candidate for bug report (one in the long series of bugs
> related to interfaces), but before I submit it I would like to kindly
> ask you to confirm if this is still the case with GNAT 2010.
> Certainly the bug is in versions GPL 2009 (20090519) and in 4.4.0
> 20080314.
Yes, under Windows it demonstrates the same behavior.
^ permalink raw reply [relevance 0%]
* GNAT bug - still in 2010?
@ 2010-10-27 15:00 7% Maciej Sobczak
2010-10-27 16:11 0% ` Alexander S. Mentis
0 siblings, 1 reply; 200+ results
From: Maciej Sobczak @ 2010-10-27 15:00 UTC (permalink / raw)
Consider:
with Ada.Unchecked_Deallocation;
procedure Test is
package P is
type My_Interface is limited interface;
procedure Do_Something (X : in out My_Interface) is abstract;
end P;
protected type My_Protected is new P.My_Interface with
overriding
procedure Do_Something;
end My_Protected;
protected body My_Protected is
overriding
procedure Do_Something is
begin
null;
end Do_Something;
end My_Protected;
type My_Protected_Ptr is access My_Protected;
procedure Free is new Ada.Unchecked_Deallocation
(Object => My_Protected, Name => My_Protected_Ptr);
Ptr : My_Protected_Ptr;
begin
-- here come dragons:
--Free (Ptr);
null;
end Test;
If the indicated line (call to Free) is uncommented, GNAT crashes in
flames (GNAT BUG DETECTED).
I was finally able to reduce this to a minimal example, which might be
a good candidate for bug report (one in the long series of bugs
related to interfaces), but before I submit it I would like to kindly
ask you to confirm if this is still the case with GNAT 2010.
Certainly the bug is in versions GPL 2009 (20090519) and in 4.4.0
20080314.
--
Maciej Sobczak * http://www.inspirel.com
^ permalink raw reply [relevance 7%]
* Re: S-expression I/O in Ada
2010-08-17 17:01 6% ` Natasha Kerensikova
@ 2010-08-27 13:19 3% ` Natasha Kerensikova
1 sibling, 0 replies; 200+ results
From: Natasha Kerensikova @ 2010-08-27 13:19 UTC (permalink / raw)
Hello,
Here is my third attempt, hopefully avoiding the mistakes I did before.
I wanted to have a go at an access-based implementation, and while it
seems to end up without roughly the same complexity as my previous
Doubly_Linked_List-based attempt, I felt incredibly much more at home
with it. Is it genuinely more simple in some way, or is it just my
pointer-juggling experience from C?
The interface is relatively limited, but it's enough for all the needs I
ever had.
The limited interface long with the Container objects make me pretty
confident in the correctness of the memory management.
I'm still not satisfied with the indentation, it still feels much too
shallow for my tastes, and the general look of my sources feels it needs
much more spacing out.
As usual, all comments that can help me writing better Ada code and/or
becoming a better Ada noob are warmly welcome.
Thanks in advance for your help,
Natasha
with Ada.Finalization;
private with Ada.Containers.Vectors;
package Sexp is
type Container is tagged limited private;
-- container that keeps tracks of allocated data
type Cursor is private;
-- object that refers to a S-expression node
-- it's the only way a client can interact with S-expression contents
type Node_Kind is (Atom_Node, List_Node);
-- a node is either an atom or a list
type Octet is range 0 .. 255;
type Atom_Data is array (Positive range <>) of Octet;
-- publicly defined to allow object conversion anywhere
---------------
-- Constants --
---------------
No_Element : constant Cursor;
---------------------
-- Atom converters --
---------------------
procedure Atom_To_String(Data : in Atom_Data; Image : out String);
procedure String_To_Atom(Image : in String; Data : out Atom_Data);
-- conversion between existing objects, assumed to be of equal length
function To_String(Data : in Atom_Data) return String;
function To_Atom(Image : in String) return Atom_Data;
-- constructing one type from the other
-----------------------
-- Container methods --
-----------------------
procedure Reset(Universe : in out Container);
-- reset the container using an empty list node as the new root
procedure Reset(Universe : in out Container; Root_Atom : in Atom_Data);
-- reset the container using the given atom data as root
procedure Reset(Universe : in out Container; Root_Atom : in String);
-- reset the container using the given string as root atom
-----------------------
-- Cursor management --
-----------------------
function Root(From : in Container) return Cursor;
function Next(Position : in Cursor) return Cursor;
procedure Next(Position : in out Cursor);
--------------------
-- Node accessors --
--------------------
function Is_Atom(Position : in Cursor) return Boolean;
function Is_List(Position : in Cursor) return Boolean;
function Kind(Position : in Cursor) return Node_Kind;
-- raise Constraint_Error when Position is No_Element
--------------------
-- Atom accessors --
--------------------
-- They all raise Constraint_Error when the given Cursor does not refer
-- to an atom node.
function To_Atom(Position : in Cursor) return Atom_Data;
function To_String(Position : in Cursor) return String;
procedure Query_Atom
(Position : in Cursor;
Process : not null access procedure(Data : in Atom_Data));
function Atom_Length(Position : in Cursor) return Natural;
-------------------
-- List accessor --
-------------------
function Sublist(Position : in Cursor) return Cursor;
-- raise Constraint_Error when Position does not refer to a list
-----------------------
-- Node constructors --
-----------------------
-- They all raise Constraint_Error when Position is No_Element
procedure Append_Empty_List
(Universe : in out Container;
Position : in Cursor);
procedure Append
(Universe : in out Container;
Position : in Cursor;
Atom : in Atom_Data);
procedure Append
(Universe : in out Container;
Position : in Cursor;
Image : in String);
---------------
-- Iterators --
---------------
procedure Iterate
(Start : in Cursor;
Process_Atom : access procedure(Data : in Atom_Data);
Process_List : access procedure(First : in Cursor));
procedure Iterate_Over_Atoms
(Start : in Cursor;
Process : not null access procedure(Data : in Atom_Data));
procedure Iterate_Over_Lists
(Start : in Cursor;
Process : not null access procedure(First : in Cursor));
procedure Iterate_Over_Commands
(Start : in Cursor;
Execute : not null access procedure(Command : in String;
Arguments : in Cursor));
private
----------------------
-- Type definitions --
----------------------
type Node(<>);
type Atom_Access is access Atom_Data;
type Node_Access is access Node;
type Node (Kind : Node_Kind) is
record
Next : Node_Access;
case Kind is
when Atom_Node => Atom : Atom_Access;
when List_Node => Child : Node_Access;
end case;
end record;
package Nodes is
new Ada.Containers.Vectors
(Index_Type => Positive,
Element_Type => Node_Access);
package Atoms is
new Ada.Containers.Vectors
(Index_Type => Positive,
Element_Type => Atom_Access);
type Container is
new Ada.Finalization.Limited_Controlled with record
List_Node : Nodes.Vector;
Atom_List : Atoms.Vector;
Root : Node_Access;
end record;
type Cursor is
record
Parent : Node_Access;
Node : Node_Access;
end record;
-----------------------
-- Container methods --
-----------------------
procedure Clean_Atoms(Universe : in out Container);
procedure Clean_Nodes(Universe : in out Container);
overriding
procedure Finalize(This : in out Container);
procedure Make_Atom
(Maker : in out Container;
Atom : out Atom_Access;
Data : in Atom_Data);
procedure Make_Atom
(Maker : in out Container;
Atom : out Atom_Access;
Image : in String);
procedure Make_Node
(Maker : in out Container;
Node : out Node_Access;
Kind : in Node_Kind);
procedure Make_Node_Atom
(Maker : in out Container;
Node : out Node_Access;
Data : in Atom_Data);
procedure Make_Node_Atom
(Maker : in out Container;
Node : out Node_Access;
Image : in String);
procedure Make_Node_List
(Maker : in out Container;
Node : out Node_Access;
Child : in Node_Access := null);
---------------
-- Constants --
---------------
No_Element : constant Cursor := (Parent => null, Node => null);
end Sexp;
with Ada.Unchecked_Deallocation;
package body Sexp is
procedure Free is
new Ada.Unchecked_Deallocation(Node, Node_Access);
procedure Free is
new Ada.Unchecked_Deallocation(Atom_Data, Atom_Access);
------------------------------------
-- String vs Atom_Data converters --
------------------------------------
procedure String_To_Atom(Image : in String; Data : out Atom_Data) is
begin
for i in Image'Range loop
Data(i - Image'First + Data'First) := Character'Pos(Image(i));
end loop;
end String_To_Atom;
procedure Atom_To_String(Data : in Atom_Data; Image : out String) is
begin
for i in Data'Range loop
Image(i - Data'First + Image'First) := Character'Val(Data(i));
end loop;
end Atom_To_String;
function To_Atom(Image : in String) return Atom_Data is
Data : Atom_Data(1 .. Image'Length);
begin
String_To_Atom(Image, Data);
return Data;
end To_Atom;
function To_String(Data : in Atom_Data) return String is
Image : String(Data'Range);
begin
Atom_To_String(Data, Image);
return Image;
end To_String;
-------------------------------
-- Container private methods --
-------------------------------
procedure Clean_Atoms(Universe : in out Container) is
Current : Atoms.Cursor := Atoms.First(Universe.Atom_List);
Atom : Atom_Access;
begin
while Atoms.Has_Element(Current) loop
Atom := Atoms.Element(Current);
Free(Atom);
Atoms.Next(Current);
end loop;
Atoms.Clear(Universe.Atom_List);
end Clean_Atoms;
procedure Clean_Nodes(Universe : in out Container) is
Current : Nodes.Cursor := Nodes.First(Universe.List_Node);
Node : Node_Access;
begin
while Nodes.Has_Element(Current) loop
Node := Nodes.Element(Current);
Free(Node);
Nodes.Next(Current);
end loop;
Nodes.Clear(Universe.List_Node);
end Clean_Nodes;
overriding
procedure Finalize(This : in out Container) is
begin
Clean_Nodes(This);
Clean_Atoms(This);
end Finalize;
procedure Make_Atom
(Maker : in out Container;
Atom : out Atom_Access;
Data : in Atom_Data) is
begin
Atom := new Atom_Data(Data'Range);
Atom.All := Data;
Atoms.Append(Maker.Atom_List, Atom);
end Make_Atom;
procedure Make_Atom
(Maker : in out Container;
Atom : out Atom_Access;
Image : in String) is
begin
Atom := new Atom_Data(1 .. Image'Length);
String_To_Atom(Image, Atom.All);
Atoms.Append(Maker.Atom_List, Atom);
end Make_Atom;
procedure Make_Node
(Maker : in out Container;
Node : out Node_Access;
Kind : in Node_Kind) is
begin
Node := new Sexp.Node(Kind);
Nodes.Append(Maker.List_Node, Node);
end Make_Node;
procedure Make_Node_Atom
(Maker : in out Container;
Node : out Node_Access;
Data : in Atom_Data) is
begin
Make_Node(Maker, Node, Atom_Node);
Make_Atom(Maker, Node.Atom, Data);
end Make_Node_Atom;
procedure Make_Node_Atom
(Maker : in out Container;
Node : out Node_Access;
Image : in String) is
begin
Make_Node(Maker, Node, Atom_Node);
Make_Atom(Maker, Node.Atom, Image);
end Make_Node_Atom;
procedure Make_Node_List
(Maker : in out Container;
Node : out Node_Access;
Child : in Node_Access := null) is
begin
Make_Node(Maker, Node, List_Node);
Node.Child := Child;
end Make_Node_List;
------------------------------
-- Container public methods --
------------------------------
procedure Reset(Universe : in out Container) is
begin
Clean_Nodes(Universe);
Clean_Atoms(Universe);
Make_Node_List(Universe, Universe.Root);
end Reset;
procedure Reset(Universe : in out Container; Root_Atom : in Atom_Data) is
begin
Clean_Nodes(Universe);
Clean_Atoms(Universe);
Make_Node_Atom(Universe, Universe.Root, Root_Atom);
end Reset;
procedure Reset(Universe : in out Container; Root_Atom : in String) is
begin
Clean_Nodes(Universe);
Clean_Atoms(Universe);
Make_Node_Atom(Universe, Universe.Root, Root_Atom);
end Reset;
-----------------------
-- Cursor management --
-----------------------
function Root(From : in Container) return Cursor is
Result : Cursor := (Parent => null, Node => From.Root);
begin
return Result;
end Root;
function Next(Position : in Cursor) return Cursor is
Result : Cursor := No_Element;
begin
if Position.Node /= null and then Position.Node.Next /= null then
Result.Parent := Position.Node;
Result.Node := Position.Node.Next;
end if;
return Result;
end Next;
procedure Next(Position : in out Cursor) is
begin
if Position.Node /= null then
if Position.Node.Next /= null then
Position.Parent := Position.Node;
Position.Node := Position.Parent.Next;
else
Position := No_Element;
end if;
end if;
end Next;
--------------------
-- Node accessors --
--------------------
function Is_Atom(Position : in Cursor) return Boolean is
begin
return Position.Node /= null and then Position.Node.Kind = Atom_Node;
end Is_Atom;
function Is_List(Position : in Cursor) return Boolean is
begin
return Position.Node /= null and then Position.Node.Kind = List_Node;
end Is_List;
function Kind(Position : in Cursor) return Node_Kind is
begin
if Position.Node = null then
raise Constraint_Error with "Position cursor has no element";
end if;
return Position.Node.Kind;
end Kind;
--------------------
-- Atom accessors --
--------------------
function To_Atom(Position : in Cursor) return Atom_Data is
begin
if not Is_Atom(Position) then
raise Constraint_Error with "Position cursor is not an atom";
end if;
return Position.Node.Atom.all;
end To_Atom;
function To_String(Position : in Cursor) return String is
begin
if not Is_Atom(Position) then
raise Constraint_Error with "Position cursor is not an atom";
end if;
return To_String(Position.Node.Atom.all);
end To_String;
procedure Query_Atom
(Position : in Cursor;
Process : not null access procedure(Data : in Atom_Data)) is
begin
if not Is_Atom(Position) then
raise Constraint_Error with "Position cursor is not an atom";
end if;
Process(Position.Node.Atom.all);
end Query_Atom;
function Atom_Length(Position : in Cursor) return Natural is
begin
if not Is_Atom(Position) then
raise Constraint_Error with "Position cursor is not an atom";
end if;
return Position.Node.Atom'Length;
end Atom_Length;
-------------------
-- List accessor --
-------------------
function Sublist(Position : in Cursor) return Cursor is
Result : Cursor;
begin
if not Is_List(Position) then
raise Constraint_Error with "Position cursor is not a list";
end if;
Result.Parent := Position.Node;
Result.Node := Position.Node.Child;
return Result;
end Sublist;
-----------------------
-- Node constructors --
-----------------------
procedure Append_Empty_List
(Universe : in out Container;
Position : in Cursor)
is
Current : Node_Access := Position.Node;
begin
if Current /= null then
raise Constraint_Error with "Position cursor has no element";
end if;
while Current.Next /= null loop
Current := Current.Next;
end loop;
Make_Node_List(Universe, Current.Next);
end Append_Empty_List;
procedure Append
(Universe : in out Container;
Position : in Cursor;
Atom : in Atom_Data)
is
Current : Node_Access := Position.Node;
begin
if Current /= null then
raise Constraint_Error with "Position cursor has no element";
end if;
while Current.Next /= null loop
Current := Current.Next;
end loop;
Make_Node_Atom(Universe, Current.Next, Atom);
end Append;
procedure Append
(Universe : in out Container;
Position : in Cursor;
Image : in String)
is
Current : Node_Access := Position.Node;
begin
if Current /= null then
raise Constraint_Error with "Position cursor has no element";
end if;
while Current.Next /= null loop
Current := Current.Next;
end loop;
Make_Node_Atom(Universe, Current.Next, Image);
end Append;
---------------
-- Iterators --
---------------
procedure Iterate
(Start : in Cursor;
Process_Atom : access procedure(Data : in Atom_Data);
Process_List : access procedure(First : in Cursor))
is
Current : Node_Access := Start.Node;
First : Cursor;
begin
if Process_Atom = null then
if Process_List /= null then
Iterate_Over_Lists(Start, Process_List);
end if;
elsif Process_List = null then
Iterate_Over_Atoms(Start, Process_Atom);
else
while Current /= null loop
case Current.Kind is
when Atom_Node =>
Process_Atom(Current.Atom.all);
when List_Node =>
First.Parent := Current;
First.Node := Current.Child;
Process_List(First);
end case;
Current := Current.Next;
end loop;
end if;
end Iterate;
procedure Iterate_Over_Atoms
(Start : in Cursor;
Process : not null access procedure(Data : in Atom_Data))
is
Current : Node_Access := Start.Node;
begin
while Current /= null loop
if Current.Kind = Atom_Node then
Process(Current.Atom.all);
end if;
end loop;
end Iterate_Over_Atoms;
procedure Iterate_Over_Lists
(Start : in Cursor;
Process : not null access procedure(First : in Cursor))
is
Current : Node_Access := Start.Node;
First : Cursor;
begin
while Current /= null loop
if Current.Kind = List_Node then
First.Parent := Current;
First.Node := Current.Child;
Process(First);
end if;
end loop;
end Iterate_Over_Lists;
procedure Iterate_Over_Commands
(Start : in Cursor;
Execute : not null access procedure(Command : in String;
Arguments : in Cursor))
is
Current : Node_Access := Start.Node;
Arg : Cursor;
begin
while Current /= null loop
if Current.Kind = Atom_Node then
Execute(To_String(Current.Atom.all), No_Element);
elsif Current.Child.Kind = Atom_node then
Arg.Parent := Current.Child;
Arg.Node := Current.Child.Next;
Execute(To_String(Current.Child.Atom.all), Arg);
end if;
end loop;
end Iterate_Over_Commands;
end Sexp;
^ permalink raw reply [relevance 3%]
* Re: S-expression I/O in Ada
@ 2010-08-17 17:01 6% ` Natasha Kerensikova
2010-08-27 13:19 3% ` Natasha Kerensikova
1 sibling, 0 replies; 200+ results
From: Natasha Kerensikova @ 2010-08-17 17:01 UTC (permalink / raw)
Hello,
here is my first try at a S_Expressions package, which is supposed to
handle the in-memory representations. I first planned to begin with the
Sexp_Stream I imagined, but it proved much more difficult than I
thought, so I went for the easier package first.
Even though I'm much more used to C than to Ada, I have the feeling it's
horribly ugly and that using access types all over the place like I did
is extremely poor. Yet I just can't find out exactly how it's wrong, nor
how to get it right.
Would any other you be kind enough to have a look at it, and point me
where I did wrong and explain me how wrong it is, be it on high-level
package design to low-level implementation choice and anything in
between including code style.
Thanks in advance for your help,
Natacha
with Ada.Finalization;
package S_Expressions is
-- atom related types
-- they are public to allow atom <--> object converters anywhere
type Octet is range 0 .. 255;
type Atom_Data is array (Integer range <>) of Octet;
function To_String (From: in Atom_Data) return String;
-- S-expression private types
type Node_Content is (Atom, List);
type Node (Content: Node_Content) is
new Ada.Finalization.Controlled with private;
type Access_Node is access Node;
-- Node accessors
function Get_Atom(node: not null Access_Node) return Atom_Data;
function Get_Child(node: not null Access_Node) return Access_Node;
function Get_Next(node: not null Access_Node) return Access_Node;
function Get_Node_Type(node: not null Access_Node) return Node_Content;
-- Node constructors
function New_Atom_Node(contents: Atom_Data; next: Access_Node)
return Access_Node;
function New_List_Node(child, next: Access_Node)
return Access_Node;
private
type Access_Atom_Data is access Atom_Data;
type Node (Content: Node_Content) is
new Ada.Finalization.Controlled with record
Next: Access_Node;
case Content is
when Atom =>
Atom: Access_Atom_Data;
when List =>
Child: Access_Node;
end case;
end record;
overriding procedure Adjust(object: in out Node);
overriding procedure Finalize(object: in out Node);
end S_Expressions;
with Ada.Unchecked_Deallocation;
package body S_Expressions is
procedure Free is
new Ada.Unchecked_Deallocation (Node, Access_Node);
procedure Free is
new Ada.Unchecked_Deallocation (Atom_Data, Access_Atom_Data);
-- Atom data duplication
function Duplicate(object: in Access_Atom_Data) return Access_Atom_Data is
new_object: Access_Atom_Data;
begin
if object /= Null then
new_object := new Atom_Data(object'Range);
new_object.All := object.All;
end if;
return new_object;
end Duplicate;
-- Deep node duplication
function Duplicate(object: in Access_Node) return Access_Node is
new_object: Access_Node;
begin
if object /= Null then
case object.Content is
when Atom =>
new_object := new Node (Atom);
new_object.Atom := Duplicate(object.Atom);
when List =>
new_object := new Node (List);
new_object.Child := Duplicate(object.Child);
end case;
new_object.Next := Duplicate(object.Next);
end if;
return new_object;
end Duplicate;
-- atom to string converter
function To_String(from: Atom_Data) return String is
to: String(from'Range);
begin
for i in from'Range loop
to(i) := Character'Val(from(i) + 1);
end loop;
return to;
end To_String;
-- deep copy of node objects
overriding procedure Adjust(object: in out Node) is
begin
case object.Content is
when Atom =>
object.Atom := Duplicate(object.Atom);
when List =>
object.Child := Duplicate(object.Child);
end case;
object.Next := Duplicate(object.Next);
end Adjust;
-- deep release of node objects
overriding procedure Finalize(object: in out Node) is
begin
case object.Content is
when Atom => Free(object.Atom);
when List => Free(object.Child);
end case;
Free(object.Next);
end;
-- Node acessors
function Get_Node_Type(node: not null Access_Node) return Node_Content is
begin
return node.Content;
end;
function Get_Atom(node: not null Access_Node) return Atom_Data is
begin
return node.Atom.All;
end;
function Get_Child(node: not null Access_Node) return Access_Node is
begin
return node.Child;
end;
function Get_Next(node: not null Access_Node) return Access_Node is
begin
return node.Next;
end;
-- Node constructors
function New_Atom_Node(contents: Atom_Data; next: Access_Node)
return Access_Node is
new_node: Access_Node;
begin
new_node := new Node (Atom);
new_node.Atom := Duplicate (contents'Access);
new_node.Next := next;
return new_node;
end;
function New_List_Node(child, next: Access_Node)
return Access_Node is
new_node: Access_Node;
begin
new_node := new Node (List);
new_node.Child := Duplicate (child);
new_node.Next := next;
return new_node;
end;
end S_Expressions;
^ permalink raw reply [relevance 6%]
* Re: ANN: Simple components for Ada v3.9
@ 2010-07-13 16:35 6% ` Dmitry A. Kazakov
0 siblings, 0 replies; 200+ results
From: Dmitry A. Kazakov @ 2010-07-13 16:35 UTC (permalink / raw)
On Tue, 13 Jul 2010 05:45:11 -0700 (PDT), Ludovic Brenta wrote:
> Dmitry A. Kazakov wrote:
>> On Mon, 12 Jul 2010 22:36:09 +0200, Dirk Heinrichs wrote:
>>> Dmitry A. Kazakov wrote:
>>
>>>> The version 3.9 has experimental packages for Debian and Fedora linux.
>>>> Note that due to gcc 4.4 bugs not all features are available. See release
>>>> notes:
>>
>>>>http://www.dmitry-kazakov.de/distributions/components_debian.htm
>>
>>> For which debian version are those packages? I assume "testing", because of
>>> gcc 4.4.
>>
>> Yes it is the "squeeze".
>>
>>> OTOH you state that "APQ persistence layer is not supported because
>>> APQ is not yet packaged.", but APQ packages are available for "testing". So
>>> I'm a bit confused.
>>
>> It wasn't there last time I looked for it. Do you have the package names
>> (bin and dev)? I will take a look.
>
> libapq1-dev (database-independent part)
> libapq-postgresql1-dev (PostgreSQL-specific part)
Thanks.
>> P.S. In any case in order to use the persistent layer of Simple Components,
>> the gcc 4.4 must be fixed first. The current version has controlled types
>> broken and some other severe issues.
>
> Wow, that's a pretty grave problem; if what you say is true, a fix in
> the stable GCC 4.4 branch is justified. What is the bugzilla number
> for this bug?
There are several. For example this one:
with Ada.Finalization;
with Ada.Unchecked_Deallocation;
with Ada.Text_IO;
procedure Controlled_Array is
type T is new Ada.Finalization.Limited_Controlled with record
C : Natural := 0;
end record;
overriding procedure Finalize (X : in out T);
procedure Finalize (X : in out T) is
begin
if X.C = 0 then
Ada.Text_IO.Put_Line ("Successful finalization");
else
Ada.Text_IO.Put_Line ("Illegal count in finalization" &
Integer'Image (X.C));
raise Program_Error;
end if;
end Finalize;
type T_Ptr is access T'Class;
type H is new Ada.Finalization.Controlled with record
P : T_Ptr;
end record;
overriding procedure Finalize (X : in out H);
overriding procedure Adjust (X : in out H);
procedure Finalize (X : in out H) is
procedure Free is new Ada.Unchecked_Deallocation (T'Class, T_Ptr);
begin
if X.P /= null then
X.P.C := X.P.C - 1;
if X.P.C = 0 then
Free (X.P);
end if;
end if;
end Finalize;
procedure Adjust (X : in out H) is
begin
X.P.C := X.P.C + 1;
end Adjust;
type H_Array is array (Positive range <>) of H;
function Create return H is
Result : H;
begin
Result.P := new T;
Result.P.C := 1;
return Result;
end Create;
List : H_Array := (Create, Create, Create);
First : T_Ptr := List (List'First).P;
begin
Ada.Text_IO.Put_Line ("Count" & Integer'Image (First.C));
end Controlled_Array;
Some others can be found in the Simple Components tests.
I am not sure if I posted any of them there. I did report to AdaCore. Most
of them were fixed prior GNAT GPL 2009 was published.
Is a merge with GPL 2009/10 planned? I am asking because I still don't
understand that complex mechanics governing FSF releases. In particular
merits of posting two-three years old bugs all fixed in GNAT GPL, like the
above bug.
I do have a base of bug reports I sent to AdaCore, but unfortunately I
cannot post most of them, because they contain proprietary code. Then, of
course, there are lots of bugs reported by other AdaCore customers. So my
uneducated guess, would rather be: let them do the merge first, and then
we'll see.
--
Regards,
Dmitry A. Kazakov
http://www.dmitry-kazakov.de
^ permalink raw reply [relevance 6%]
* Re: This MIDI stuff, would someone be interested in reviewing my code?
2010-03-08 11:40 6% This MIDI stuff, would someone be interested in reviewing my code? John McCabe
@ 2010-03-13 8:12 0% ` Christophe Chaumet
0 siblings, 0 replies; 200+ results
From: Christophe Chaumet @ 2010-03-13 8:12 UTC (permalink / raw)
John McCabe a �crit :
> Hi
>
> It's still early days but, if I'm going to be using Ada to try to
> build this app I want, it would be nice to write it in a style that
> looks appropriate. I'm aware of the Q&S guide but I was hoping that
> someone could take a quick look at the code I've written (it's only 80
> lines or so, and it's down below) and see if there's anything
> obviously stupid I'm doing.
>
> My specific thoughts on this are:
>
> 1) Perhaps I should be using limited withs in some places to get
> access to the primitive operators/functions of the stuff in
> Interfaces.C/.strings and Win32 etc.
>
> 2) The for loops: for devId in Win32.UINT range 0..(NumOutputDevices -
> 1) etc. These are protected by a "if NumOutputDevices < 0" condition
> but before I realised my mistake I found that when NumOutputDevices is
> 0, the loop executes as many times as it can before it crashed. This
> was obviously because NumOutputDevices was 0, so the range
> "0..(NumOutputDevices - 1)" was 0..4929blahblah due to Win32.UINT
> being a modular type. I looked at the option to use something like:
> for index in Win32.UINT range 1..NumOuputDevices loop
> declare
> devId : Win32.UINT := index - 1;
> begin
> ...
> end;
> end loop;
> but stuck with the original with the conditional round it.
>
> 3) Would it be more appropriate to use something like
> Win32.UINT'Image() instead of getting an instantiation of the
> Modular_IO package?
>
> Anyway - thanks to anyone who can be bothered to look at this. It will
> be much appreciated, and thanks for everyone's help so far.
>
> John
>
>
> ===================
> with Ada.Text_IO;
> with Ada.Unchecked_Deallocation;
>
> with Interfaces.C; use Interfaces.C;
> with Interfaces.C.Strings; use Interfaces.C.Strings;
>
> with Win32; use Win32;
> with Win32.Mmsystem; use Win32.Mmsystem;
>
> procedure MidiDevs is
> NumInputDevices : Win32.UINT;
> NumOutputDevices : Win32.UINT;
>
> res : Win32.Mmsystem.MMRESULT;
> midiInCaps : Win32.Mmsystem.LPMIDIINCAPS;
> midiOutCaps : Win32.Mmsystem.LPMIDIOUTCAPS;
>
> package UINTText_IO is new Ada.Text_IO.Modular_IO(Win32.UINT);
> package MMText_IO is new
> Ada.Text_IO.Modular_IO(Win32.Mmsystem.MMRESULT);
>
> procedure Free is new
> Ada.Unchecked_Deallocation(Win32.Mmsystem.MIDIINCAPS,
> Win32.Mmsystem.LPMIDIINCAPS);
> procedure Free is new
> Ada.Unchecked_Deallocation(Win32.Mmsystem.MIDIOUTCAPS,
> Win32.Mmsystem.LPMIDIOUTCAPS);
>
> begin
> NumInputDevices := Win32.Mmsystem.midiInGetNumDevs;
> NumOutputDevices := Win32.Mmsystem.midiOutGetNumDevs;
> midiInCaps := new Win32.Mmsystem.MIDIINCAPS;
> midiOutCaps := new Win32.Mmsystem.MIDIOUTCAPS;
>
> Ada.Text_IO.Put("There are ");
> UINTText_IO.Put(NumInputDevices, 0);
> Ada.Text_IO.Put(" input devices available, and ");
> UINTText_IO.Put(NumOutputDevices, 0);
> Ada.Text_IO.Put_Line(" output devices available.");
>
> if NumInputDevices > 0
> then
> Ada.Text_IO.New_Line;
> Ada.Text_IO.Put("The ");
> UINTText_IO.Put(NumInputDevices, 0);
> Ada.Text_IO.Put_Line(" input devices are:");
> Ada.Text_IO.New_Line;
>
> for devId in Win32.UINT range 0..(NumInputDevices - 1)
> loop
> res := Win32.Mmsystem.midiInGetDevCaps(devId,
> midiInCaps,
>
> (Win32.Mmsystem.MIDIINCAPS'size * Win32.BYTE'size));
> UINTText_IO.Put(devId, 0);
> Ada.Text_IO.Put(") ");
> if res = Win32.Mmsystem.MMSYSERR_NOERROR
> then
> Ada.Text_IO.Put("szPname = ");
> Ada.Text_IO.Put_Line(To_Ada(To_C(midiInCaps.szPname)));
> else
> Ada.Text_IO.Put("Query Failed. Returned ");
> MMText_IO.Put(res, 0);
> end if;
> Ada.Text_IO.New_Line;
> end loop;
> end if;
>
> if NumOutputDevices > 0
> then
> Ada.Text_IO.New_Line;
> Ada.Text_IO.Put("The ");
> UINTText_IO.Put(NumOutputDevices, 0);
> Ada.Text_IO.Put_Line(" output devices are:");
> Ada.Text_IO.New_Line;
>
> for devId in Win32.UINT range 0..(NumOutputDevices - 1)
> loop
> res := Win32.Mmsystem.midiOutGetDevCaps(devId,
> midiOutCaps,
>
> (Win32.Mmsystem.MIDIOUTCAPS'size * Win32.BYTE'size));
> UINTText_IO.Put(devId, 0);
> Ada.Text_IO.Put(") ");
> if res = Win32.Mmsystem.MMSYSERR_NOERROR
> then
> Ada.Text_IO.Put("szPname = ");
> Ada.Text_IO.Put_Line(To_Ada(To_C(midiOutCaps.szPname)));
> else
> Ada.Text_IO.Put("Query Failed. Returned ");
> MMText_IO.Put(res, 0);
> end if;
> Ada.Text_IO.New_Line;
> end loop;
> end if;
>
> Free(midiInCaps);
> Free(midiOutCaps);
>
> end MidiDevs;
>
>
Here is a working code: http://sourceforge.net/projects/canta/ written
in Ada.
^ permalink raw reply [relevance 0%]
* Re: Having a problem building with win32ada
2010-03-09 21:00 3% ` John McCabe
@ 2010-03-09 21:37 8% ` John McCabe
0 siblings, 0 replies; 200+ results
From: John McCabe @ 2010-03-09 21:37 UTC (permalink / raw)
John McCabe <john@nospam.assen.demon.co.uk.nospam> wrote:
Couple of corrections....
1) I've put Unchecked_Conversion where it should be
Unchecked_Deallocation. Replace:
> procedure Free is new
> Ada.Unchecked_Conversion(Win32.Mmsystem.LPMIDIINCAPS,
> Win32.Mmsystem.MIDIINCAPS);
> procedure Free is new
> Ada.Unchecked_Conversion(Win32.Mmsystem.LPMIDIOUTCAPS,
> Win32.Mmsystem.MIDIOUTCAPS);
With
procedure Free is new
Ada.Unchecked_Deallocation(Win32.Mmsystem.MIDIINCAPS,
Win32.Mmsystem.LPMIDIINCAPS);
procedure Free is new
Ada.Unchecked_Deallocation(Win32.Mmsystem.MIDIOUTCAPS,
Win32.Mmsystem.LPMIDIOUTCAPS);
2) In face, the replacing with aliased Win32.Mmsystem.MIDIINCAPS etc
and use of Unchecked_Access DOESN'T WORK. It stops the file open from
failing, but the calls to midiIn/OutGetDevCaps return MMRESULT value
11 whish is Invalid Parameter.
Ah well.
I've done some more searching, and it looks to me like basically the
Win32Ada binding that AdaCore are allowing people to download are a
minimum of 11 years old. Apparently the last intermetrics version
(3.0) was released in 1999. The win32-mmsystem.ads has an Intermetrics
copyright date of 1995.
This is rather unfortunate. I'd hope this would be very useful for
what I wanted to do but, to be honest, it looks like the idea is
doomed as I really don't want to have to re-create a whole set of
Win32 Ada bindings based on the existing MinGW versions of these files
(that also appear to be out of date compared to the definitions of the
types you can find on Microsoft's website).
Disappointing.
John
^ permalink raw reply [relevance 8%]
* Re: Having a problem building with win32ada
@ 2010-03-09 21:00 3% ` John McCabe
2010-03-09 21:37 8% ` John McCabe
0 siblings, 1 reply; 200+ results
From: John McCabe @ 2010-03-09 21:00 UTC (permalink / raw)
Guys
Thought I might as well add it to this thread, but I'm now having a
slight problem running with Win32Ada.
The basis of the code I'm using is in my "please review my code"
thread.
Essentially I've got the code shown below the double dashed line
(well, that's most of it).
When I run it, the Read_And_Print_Patches call _before_ outputting the
output device information is fine, but the same call _after_
outputting the output device information fails. Sometimes it just
prints the "1" prior to the Ada.Text_IO.Open call, and sometimes I get
PROGRAM_ERROR EXCEPTION_ACCESS_VIOLATION.
Now, if I change the declarations of Midi_In_Caps and Midi_Out_Caps
to:
Midi_In_Caps : aliased Win32.Mmsystem.MIDIINCAPS;
Midi_Out_Caps : aliased Win32.Mmsystem.MIDIOUTCAPS;
and use 'Unchecked_Access in the calls to midiInGetDevCaps and
midiOutGetDevCaps for those objects (and dispose of the Free calls) it
seems to work ok. That sounds like some memory isn't being allocated
properly somehow. I can't see that I'm doing anything wrong but if you
can please let me know.
One thing I noticed though is that in mmsystem.h (in the
i686-pc-mingw32 folder) the declaration of MIDIINCAPS (well,
MIDIINCAPSA as it's non-Unicode) is:
typedef struct tagMIDIINCAPSA {
WORD wMid;
WORD wPid;
MMVERSION vDriverVersion;
CHAR szPname[MAXPNAMELEN];
DWORD dwSupport;
} MIDIINCAPSA,*PMIDIINCAPSA,*LPMIDIINCAPSA;
However in win32-mmsystem.ads, the corresponding definition is:
type MIDIINCAPSA is -- mmsystem.h:835
record
wMid : Win32.WORD; -- mmsystem.h:836
wPid : Win32.WORD; -- mmsystem.h:837
vDriverVersion : MMVERSION; -- mmsystem.h:838
szPname : Win32.CHAR_Array (0 .. 31); -- mmsystem.h:839
end record;
Now call me stupid if you like, but does it not look like there's
something missing there? (i.e. the dwSupport field).
If anyone can be bothered to check this out and see what they think
your comments would be appreciated, especially if you can spot that
I've done something stupid.
Do you think this is a bug that AdaCore should know about if they
don't already?
Obviously I could go down the route of not using dynamic memory
because, as I mentioned, it seems to work that way, but I don't like
not knowing why it didn't work the other way!
=================================
-- File: MidiDevs.adb
with Ada.Text_IO;
with Ada.Unchecked_Deallocation;
with Interfaces.C;
use type Interfaces.C.Unsigned;
with Win32.Mmsystem;
use type Win32.Mmsystem.MMRESULT;
with TestFileRead;
procedure MidiDevs is
Num_Input_Devices : Win32.UINT;
Num_Output_Devices : Win32.UINT;
res : Win32.Mmsystem.MMRESULT;
Midi_In_Caps : Win32.Mmsystem.LPMIDIINCAPS;
Midi_Out_Caps : Win32.Mmsystem.LPMIDIOUTCAPS;
procedure Free is new
Ada.Unchecked_Conversion(Win32.Mmsystem.LPMIDIINCAPS,
Win32.Mmsystem.MIDIINCAPS);
procedure Free is new
Ada.Unchecked_Conversion(Win32.Mmsystem.LPMIDIOUTCAPS,
Win32.Mmsystem.MIDIOUTCAPS);
package UINT_Text_IO is new
Ada.Text_IO.Modular_IO(Win32.UINT);
package MM_Text_IO is new
Ada.Text_IO.Modular_IO(Win32.Mmsystem.MMRESULT);
begin
Num_Input_Devices := Win32.Mmsystem.midiInGetNumDevs;
Num_Output_Devices := Win32.Mmsystem.midiOutGetNumDevs;
Ada.Text_IO.Put("There are ");
UINT_Text_IO.Put(Num_Input_Devices, 0);
Ada.Text_IO.Put(" input devices available, and ");
UINT_Text_IO.Put(Num_Output_Devices, 0);
Ada.Text_IO.Put_Line(" output devices available.");
Midi_In_Caps := new Win32.Mmsystem.MIDIINCAPS;
Midi_Out_Caps := new Win32.Mmsystem.MIDIOUTCAPS;
if Num_Input_Devices > 0
then
Ada.Text_IO.New_Line;
Ada.Text_IO.Put("The ");
UINT_Text_IO.Put(Num_Input_Devices, 0);
Ada.Text_IO.Put_Line(" input devices are:");
Ada.Text_IO.New_Line;
for Device_ID in Win32.UINT range 0..(Num_Input_Devices - 1)
loop
res := Win32.Mmsystem.midiInGetDevCaps(Device_ID,
Midi_In_Caps,
Win32.Mmsystem.MIDIINCAPS'size
* Win32.BYTE'size);
UINT_Text_IO.Put(Device_ID, 0);
Ada.Text_IO.Put(") ");
if res = Win32.Mmsystem.MMSYSERR_NOERROR
then
Ada.Text_IO.Put("szPname = ");
Ada.Text_IO.Put_Line(Interfaces.C.To_Ada(Win32.To_C(Midi_In_Caps.szPname)));
else
Ada.Text_IO.Put("Query Failed. Returned ");
MM_Text_IO.Put(res, 0);
end if;
Ada.Text_IO.New_Line;
end loop;
end if;
-- Try reading in the file
TestFileRead.Read_And_Print_Patches;
Ada.Text_IO.New_Line;
if Num_Output_Devices > 0
then
Ada.Text_IO.New_Line;
Ada.Text_IO.Put("The ");
UINT_Text_IO.Put(Num_Output_Devices, 0);
Ada.Text_IO.Put_Line(" output devices are:");
Ada.Text_IO.New_Line;
for Device_ID in Win32.UINT range 0..(Num_Output_Devices - 1)
loop
res := Win32.Mmsystem.midiOutGetDevCaps(Device_ID,
Midi_Out_Caps,
Win32.Mmsystem.MIDIOUTCAPS'size
* Win32.BYTE'size);
UINT_Text_IO.Put(Device_ID, 0);
Ada.Text_IO.Put(") ");
if res = Win32.Mmsystem.MMSYSERR_NOERROR
then
Ada.Text_IO.Put("szPname = ");
Ada.Text_IO.Put_Line(Interfaces.C.To_Ada(Win32.To_C(Midi_Out_Caps.szPname)));
else
Ada.Text_IO.Put("Query Failed. Returned ");
MM_Text_IO.Put(res, 0);
end if;
Ada.Text_IO.New_Line;
end loop;
end if;
-- Try reading in the file
TestFileRead.Read_And_Print_Patches;
Ada.Text_IO.New_Line;
Free(Midi_In_Caps);
Free(Midi_Out_Caps);
end MidiDevs;
===================
=================================
-- File: TestFileRead.ads
package TestFileRead is
procedure Read_And_Print_Patches;
end TestFileRead;
===================
=================================
-- File: TestFileRead.adb
with Ada.Text_IO;
package body TestFileRead is
----------------------------
-- Read_And_Print_Patches --
----------------------------
procedure Read_And_Print_Patches is
Input_File : Ada.Text_IO.File_Type;
begin
Ada.Text_IO.Put_Line("1");
-- Note: You need a file that exists
Ada.Text_IO.Open(SysEx_File,
Ada.Text_IO.In_File,
"FILENAME.TXT");
Ada.Text_IO.Put_Line("2");
Ada.Text_IO.Close(Input_File);
Ada.Text_IO.Put_Line("3");
end Read_And_Print_Patches;
end TestFileRead;
===========
^ permalink raw reply [relevance 3%]
* This MIDI stuff, would someone be interested in reviewing my code?
@ 2010-03-08 11:40 6% John McCabe
2010-03-13 8:12 0% ` Christophe Chaumet
0 siblings, 1 reply; 200+ results
From: John McCabe @ 2010-03-08 11:40 UTC (permalink / raw)
Hi
It's still early days but, if I'm going to be using Ada to try to
build this app I want, it would be nice to write it in a style that
looks appropriate. I'm aware of the Q&S guide but I was hoping that
someone could take a quick look at the code I've written (it's only 80
lines or so, and it's down below) and see if there's anything
obviously stupid I'm doing.
My specific thoughts on this are:
1) Perhaps I should be using limited withs in some places to get
access to the primitive operators/functions of the stuff in
Interfaces.C/.strings and Win32 etc.
2) The for loops: for devId in Win32.UINT range 0..(NumOutputDevices -
1) etc. These are protected by a "if NumOutputDevices < 0" condition
but before I realised my mistake I found that when NumOutputDevices is
0, the loop executes as many times as it can before it crashed. This
was obviously because NumOutputDevices was 0, so the range
"0..(NumOutputDevices - 1)" was 0..4929blahblah due to Win32.UINT
being a modular type. I looked at the option to use something like:
for index in Win32.UINT range 1..NumOuputDevices loop
declare
devId : Win32.UINT := index - 1;
begin
...
end;
end loop;
but stuck with the original with the conditional round it.
3) Would it be more appropriate to use something like
Win32.UINT'Image() instead of getting an instantiation of the
Modular_IO package?
Anyway - thanks to anyone who can be bothered to look at this. It will
be much appreciated, and thanks for everyone's help so far.
John
===================
with Ada.Text_IO;
with Ada.Unchecked_Deallocation;
with Interfaces.C; use Interfaces.C;
with Interfaces.C.Strings; use Interfaces.C.Strings;
with Win32; use Win32;
with Win32.Mmsystem; use Win32.Mmsystem;
procedure MidiDevs is
NumInputDevices : Win32.UINT;
NumOutputDevices : Win32.UINT;
res : Win32.Mmsystem.MMRESULT;
midiInCaps : Win32.Mmsystem.LPMIDIINCAPS;
midiOutCaps : Win32.Mmsystem.LPMIDIOUTCAPS;
package UINTText_IO is new Ada.Text_IO.Modular_IO(Win32.UINT);
package MMText_IO is new
Ada.Text_IO.Modular_IO(Win32.Mmsystem.MMRESULT);
procedure Free is new
Ada.Unchecked_Deallocation(Win32.Mmsystem.MIDIINCAPS,
Win32.Mmsystem.LPMIDIINCAPS);
procedure Free is new
Ada.Unchecked_Deallocation(Win32.Mmsystem.MIDIOUTCAPS,
Win32.Mmsystem.LPMIDIOUTCAPS);
begin
NumInputDevices := Win32.Mmsystem.midiInGetNumDevs;
NumOutputDevices := Win32.Mmsystem.midiOutGetNumDevs;
midiInCaps := new Win32.Mmsystem.MIDIINCAPS;
midiOutCaps := new Win32.Mmsystem.MIDIOUTCAPS;
Ada.Text_IO.Put("There are ");
UINTText_IO.Put(NumInputDevices, 0);
Ada.Text_IO.Put(" input devices available, and ");
UINTText_IO.Put(NumOutputDevices, 0);
Ada.Text_IO.Put_Line(" output devices available.");
if NumInputDevices > 0
then
Ada.Text_IO.New_Line;
Ada.Text_IO.Put("The ");
UINTText_IO.Put(NumInputDevices, 0);
Ada.Text_IO.Put_Line(" input devices are:");
Ada.Text_IO.New_Line;
for devId in Win32.UINT range 0..(NumInputDevices - 1)
loop
res := Win32.Mmsystem.midiInGetDevCaps(devId,
midiInCaps,
(Win32.Mmsystem.MIDIINCAPS'size * Win32.BYTE'size));
UINTText_IO.Put(devId, 0);
Ada.Text_IO.Put(") ");
if res = Win32.Mmsystem.MMSYSERR_NOERROR
then
Ada.Text_IO.Put("szPname = ");
Ada.Text_IO.Put_Line(To_Ada(To_C(midiInCaps.szPname)));
else
Ada.Text_IO.Put("Query Failed. Returned ");
MMText_IO.Put(res, 0);
end if;
Ada.Text_IO.New_Line;
end loop;
end if;
if NumOutputDevices > 0
then
Ada.Text_IO.New_Line;
Ada.Text_IO.Put("The ");
UINTText_IO.Put(NumOutputDevices, 0);
Ada.Text_IO.Put_Line(" output devices are:");
Ada.Text_IO.New_Line;
for devId in Win32.UINT range 0..(NumOutputDevices - 1)
loop
res := Win32.Mmsystem.midiOutGetDevCaps(devId,
midiOutCaps,
(Win32.Mmsystem.MIDIOUTCAPS'size * Win32.BYTE'size));
UINTText_IO.Put(devId, 0);
Ada.Text_IO.Put(") ");
if res = Win32.Mmsystem.MMSYSERR_NOERROR
then
Ada.Text_IO.Put("szPname = ");
Ada.Text_IO.Put_Line(To_Ada(To_C(midiOutCaps.szPname)));
else
Ada.Text_IO.Put("Query Failed. Returned ");
MMText_IO.Put(res, 0);
end if;
Ada.Text_IO.New_Line;
end loop;
end if;
Free(midiInCaps);
Free(midiOutCaps);
end MidiDevs;
^ permalink raw reply [relevance 6%]
* Tail recursion upon task destruction
@ 2009-11-17 10:17 5% Dmitry A. Kazakov
0 siblings, 0 replies; 200+ results
From: Dmitry A. Kazakov @ 2009-11-17 10:17 UTC (permalink / raw)
Consider a task encapsulated in an object in either way:
type Device is
Driver : Driver_Task (Device'Access);
or
type Device is
Driver : not null access Driver_Task := Driver_Task (Device'Access);
Let the object is allocated dynamically and we wanted to destroy it from
the task. It seems that there is no way to do this:
task Driver_Task (Object : not null access Device) is
procedure Free is
new Ada.Unchecked_Deallocation (Device, Device_Ptr)
Self : Device_Ptr;
begin
...
accept Shut_Down;
Self := Object.all'Unchecked_Access; -- Or whatever way
Free (Self); -- This will deadlock
end Driver_Task;
The core problem is that a task cannot destroy itself, because that would
block for task termination, which never to happen.
What I do to solve this is an extra "collector task" to await for a
rendezvous with Driver_Tasks, accepting a pointer to the Device and then
after leaving the rendezvous, freeing it. That looks tedious.
Don't we need some kind of "tail recursion" for this destruction pattern?
--
Regards,
Dmitry A. Kazakov
http://www.dmitry-kazakov.de
^ permalink raw reply [relevance 5%]
* Re: Proper program structure
@ 2009-10-02 13:10 7% ` Brad Moore
0 siblings, 0 replies; 200+ results
From: Brad Moore @ 2009-10-02 13:10 UTC (permalink / raw)
Sorry, need to make a correction to my last posting.
The automatic finalization would not have worked like I would have
wanted, since the vehicle_type is an access type, finalization would
have only occurred when the access type went out of scope (at program
finalization). To get the effect I was looking for would have required
garbage collection. To correct this, I make the Vehicle_Type a
controlled record type containing an access to the internals.
I got rid of the inheritance, since it did not seem to be providing
much of a benefit.
Brad
i.e.
private with Ada.Finalization;
package Cars is
type Vehicle_Type (<>) is limited private;
function Construct return Vehicle_Type;
private
use Ada.Finalization;
type Car_Type;
type Car_Access_Type is access Car_Type;
type Vehicle_Type is new Limited_Controlled with
record
Car : Car_Access_Type;
end record;
overriding procedure Finalize (Vehicle : in out Vehicle_Type);
end Cars;
---------------------------
with Cars.Vehicle_Internal;
use Cars.Vehicle_Internal;
with Ada.Unchecked_Deallocation;
package body Cars is
type Car_Type is
record
Internals : Vehicle_Internal_Type;
end record;
procedure Free_Car is new Ada.Unchecked_Deallocation
(Object => Car_Type,
Name => Car_Access_Type);
function Construct return Vehicle_Type is
begin
return Vehicle : Vehicle_Type
do
Vehicle.Car :=
new Car_Type'(Internals => Vehicle_Internal_Type'(Construct));
return;
end return;
end Construct;
overriding procedure Finalize (Vehicle : in out Vehicle_Type) is
begin
Free_Car (Vehicle.Car);
end Finalize;
end Cars;
^ permalink raw reply [relevance 7%]
* Re: Unchecked_Deallocation of class-wide objects
2009-09-28 8:43 5% Unchecked_Deallocation of class-wide objects Maciej Sobczak
@ 2009-09-28 9:12 0% ` Dmitry A. Kazakov
0 siblings, 0 replies; 200+ results
From: Dmitry A. Kazakov @ 2009-09-28 9:12 UTC (permalink / raw)
On Mon, 28 Sep 2009 01:43:03 -0700 (PDT), Maciej Sobczak wrote:
> Is it legal and safe to deallocate class-wide objects?
>
> The problem is that such an object is allocated with its concrete
> type, whereas deallocation is defined for its class-wide type.
Yes, deallocation "dispatches" on the pointer's target.
> Consider:
>
> type Shape is tagged private;
> type Shape_Access is access Shape'Class;
>
> procedure Free_Shape is new Ada.Unchecked_Deallocation
> (Object => Shape'Class, Name => Shape_Access);
> -- ...
>
> type Circle is new Shape with ...
> -- ...
> C : Shape_Access := new Circle;
> -- ...
> Free_Shape (C);
>
> Is the Circle object allocated on the Shape-wide storage pool? From
> what I understand, this is the condition for the above to work
> properly.
In Ada pool is bound to the access type, not to the target type, which is
logical consequence that an object can be allocated on the stack.
Another consequence is that it is meaningless to talk about
Shape-wide-pool, however an implementation may indeed allocate objects of
different types in different pools transparently to the program. If it
chooses to do this for tagged types of the same hierarchy, then the pointer
should become fat and contain the type tag in it. I know no Ada compiler
that does it this way, but it is a possible scheme, IMO.
> What if Circle is allocated for some Circle_Access type which is then
> converted to Shape_Access? Can it be safely deallocated?
You could not convert it because Shape_Access is pool-specific.
(Unchecked_Conversion tells for itself)
If it were a general access to class wide then deallocator would be "doubly
dispatching" on the pool and on the target. Thus, as far as I can tell, it
is safe in both cases.
--
Regards,
Dmitry A. Kazakov
http://www.dmitry-kazakov.de
^ permalink raw reply [relevance 0%]
* Unchecked_Deallocation of class-wide objects
@ 2009-09-28 8:43 5% Maciej Sobczak
2009-09-28 9:12 0% ` Dmitry A. Kazakov
0 siblings, 1 reply; 200+ results
From: Maciej Sobczak @ 2009-09-28 8:43 UTC (permalink / raw)
Is it legal and safe to deallocate class-wide objects?
The problem is that such an object is allocated with its concrete
type, whereas deallocation is defined for its class-wide type.
Consider:
type Shape is tagged private;
type Shape_Access is access Shape'Class;
procedure Free_Shape is new Ada.Unchecked_Deallocation
(Object => Shape'Class, Name => Shape_Access);
-- ...
type Circle is new Shape with ...
-- ...
C : Shape_Access := new Circle;
-- ...
Free_Shape (C);
Is the Circle object allocated on the Shape-wide storage pool? From
what I understand, this is the condition for the above to work
properly.
What if Circle is allocated for some Circle_Access type which is then
converted to Shape_Access? Can it be safely deallocated?
I believe that the above is a pretty standard use-case, but I would
like to confirm that. Unfortunately, AARM is not very explicit about
this subject.
--
Maciej Sobczak * www.msobczak.com * www.inspirel.com
Database Access Library for Ada: www.inspirel.com/soci-ada
^ permalink raw reply [relevance 5%]
* Re: Pointer types (I mean access types)
@ 2009-07-11 19:41 7% ` anon
0 siblings, 0 replies; 200+ results
From: anon @ 2009-07-11 19:41 UTC (permalink / raw)
Most books on both languages have the link link example. just find one
for each lang and compare. Execpt for the deallocation routine, your
list look correct.
In Ada, for deallocation, there is a package "Ada.Unchecked_Deallocation" that
is used to create a Free or Delete routinue for each type. An example taken
from Ada.Text_IO is:
-- Text_AFCB is a predefined record.
procedure AFCB_Free (File : access Text_AFCB) is
type FCB_Ptr is access all Text_AFCB;
FT : FCB_Ptr := FCB_Ptr (File);
procedure Free is new Ada.Unchecked_Deallocation (Text_AFCB, FCB_Ptr);
begin
Free (FT);
end AFCB_Free;
In <t9lf55t55qh7puub368vnr55pf215d9nmh@4ax.com>, Rob Solomon <usenet@drrob1-noreply.com> writes:
>I am trying to understand how pointers work in Ada. I would like to
>know if I have the correct equivalencies
>
>Assume this declaration:
> type List_Node; -- An incomplete type declaration.
> type List_Node_Access is access List_Node;
> type List_Node is
> record
> Data : Integer;
> Next : List_Node_Access;
> end record;
>
>Ada Modula-2 (or Pascal)
>-------------------------------- ----------------------
>type Node_Access is access Node; TYPE NodeAccess = POINTER TO Node;
>Start : Node_Access; VAR Start : NodeAccess;
>Current := new Node; Current := NEW(Node);
>Current := Start; Current := Start;
>Current.all := Start.all; Current^ := Start^;
>Current.Data := 5; Current^.Data := 5;
>
>
>I never learned C or derivatives. So comparisons to C don't help me.
>
>Thanks
^ permalink raw reply [relevance 7%]
* Re: Howto read line from a stream
2009-05-31 12:56 5% ` Tomek Wałkuski
@ 2009-05-31 15:13 0% ` Dmitry A. Kazakov
0 siblings, 0 replies; 200+ results
From: Dmitry A. Kazakov @ 2009-05-31 15:13 UTC (permalink / raw)
On Sun, 31 May 2009 05:56:41 -0700 (PDT), Tomek Wa�kuski wrote:
> Thank you Dimitry. I have implemented something like this:
>
> ---------- CODE -----------
> function Get_Line (Channel : in Stream_Access) return String is
> type String_Access is access String;
> Buffer : Character;
> Result : String_Access;
> Quit : Boolean := False;
> Line_Length : Natural := 0;
> procedure Free is new Ada.Unchecked_Deallocation (String,
> String_Access);
> begin
> loop
> Character'Read (Channel, Buffer);
> if Result = null then
> Result := new String (1 .. 1);
> end if;
> if Result'Length = Line_Length then
> declare
> Old : String_Access := Result;
> begin
> Result := new String (1 .. Old'Length +1);
> Result (1 .. Old'Length) := Old.all;
> Free (Old);
> end;
> end if;
> Line_Length := Line_Length + 1;
> Result (Line_Length) := Buffer;
> if Quit = True and then Buffer = ASCII.LF then
> exit;
> elsif Buffer = ASCII.CR then
> Quit := True;
> else
> Quit := False;
> end if;
> end loop;
> return Result.all;
> end Get_Line;
> ---------- CODE -----------
The problem with above is that it is at least as inefficient as
Unbounded_String:
1. You allocate a new string per each input byte;
2. You do not keep the allocated buffer between calls to Get_Line;
3. You copy the buffer content once read;
4. It leaks memory.
The idea I tried to convey by my solution was to address the issues 1-3:
1. The buffer is allocated in big pieces, so that it would adjust to the
maximal line length in few iterations.
2. The buffer is kept between calls. 1 & 2 mean that there would be only
one or two allocations per session.
3. The buffer content is not copied. Get_Line returns of an access to
String, of which slice is then renamed.
> My protocol says that every line ends with CR & LF, only length can
> vary.
The best practice of dealing with texts (streams or not) is to use LF as a
line terminator and remove training (or any) CR's from the buffer. This
makes it working under both Linux and Windows.
--
Regards,
Dmitry A. Kazakov
http://www.dmitry-kazakov.de
^ permalink raw reply [relevance 0%]
* Re: Howto read line from a stream
2009-05-31 12:02 6% ` Dmitry A. Kazakov
@ 2009-05-31 12:56 5% ` Tomek Wałkuski
2009-05-31 15:13 0% ` Dmitry A. Kazakov
0 siblings, 1 reply; 200+ results
From: Tomek Wałkuski @ 2009-05-31 12:56 UTC (permalink / raw)
Thank you Dimitry. I have implemented something like this:
---------- CODE -----------
function Get_Line (Channel : in Stream_Access) return String is
type String_Access is access String;
Buffer : Character;
Result : String_Access;
Quit : Boolean := False;
Line_Length : Natural := 0;
procedure Free is new Ada.Unchecked_Deallocation (String,
String_Access);
begin
loop
Character'Read (Channel, Buffer);
if Result = null then
Result := new String (1 .. 1);
end if;
if Result'Length = Line_Length then
declare
Old : String_Access := Result;
begin
Result := new String (1 .. Old'Length +1);
Result (1 .. Old'Length) := Old.all;
Free (Old);
end;
end if;
Line_Length := Line_Length + 1;
Result (Line_Length) := Buffer;
if Quit = True and then Buffer = ASCII.LF then
exit;
elsif Buffer = ASCII.CR then
Quit := True;
else
Quit := False;
end if;
end loop;
return Result.all;
end Get_Line;
---------- CODE -----------
My protocol says that every line ends with CR & LF, only length can
vary.
^ permalink raw reply [relevance 5%]
* Re: Howto read line from a stream
@ 2009-05-31 12:02 6% ` Dmitry A. Kazakov
2009-05-31 12:56 5% ` Tomek Wałkuski
0 siblings, 1 reply; 200+ results
From: Dmitry A. Kazakov @ 2009-05-31 12:02 UTC (permalink / raw)
On Sun, 31 May 2009 04:29:33 -0700 (PDT), Tomek Wa�kuski wrote:
> I have done so far:
>
> function Read_Line (Channel : in Stream_Access) return String is
> Buffer : String (1 .. 1);
> Result : Unbounded_String;
> begin
> loop
> String'Read (Channel, Buffer);
> Append (Result, Buffer);
> exit when Buffer (1) = ASCII.LF;
> end loop;
> return To_String(Result);
> end Read_Line;
>
> I know, this is completely NOT smart solution.
It is OK except for Unbounded_String, especially Append per each character.
That should be very slow.
I would do something like:
with Ada.Finalization;
with Ada.Streams; use Ada.Streams;
package Buffers is
-- Buffer to accumulate read lines
type Line_Buffer is tagged limited private;
-- Get the line in the buffer (longer than the line read)
function Get_Line (Buffer : Line_Buffer) return not null access String;
-- Get the length of the line in the buffer
function Get_Length (Buffer : Line_Buffer) return Natural;
-- Read new line into the buffer
procedure Read
( Buffer : in out Line_Buffer;
Stream : in out Root_Stream_Type'Class
);
private
type String_Ptr is access String;
type Line_Buffer is new Ada.Finalization.Limited_Controlled with record
Length : Natural := 0;
Line : String_Ptr; -- The line body, dynamically allocated
end record;
overriding procedure Finalize (Buffer : in out Line_Buffer);
end Buffers;
You would use it like:
loop
Read (Buffer, Stream); -- Read line
declare
Line : String renames Buffer.Get_Line (1..Buffer.Get_Length));
begin
... -- Process Line
end;
end loop;
The implementation could be like:
with Ada.Unchecked_Deallocation;
package body Buffers is
Increment : constant := 1024;
procedure Free is new Ada.Unchecked_Deallocation (String, String_Ptr);
function Get_Line (Buffer : Line_Buffer)
return not null access String is
begin
return Buffer.Line;
end Get_Line;
function Get_Length (Buffer : Line_Buffer) return Natural is
begin
return Buffer.Length;
end Get_Length;
procedure Read
( Buffer : in out Line_Buffer;
Stream : in out Root_Stream_Type'Class
) is
Data : Character;
begin
Buffer.Length := 0;
loop
Character'Read (Stream'Access, Data);
exit when Data = Character'Val (10);
if Buffer.Line = null then
Buffer.Line := new String (1..Increment);
end if;
if Buffer.Line'Length = Buffer.Length then
declare
Old : String_Ptr := Buffer.Line;
begin
Buffer.Line := new String (1..Old'Length + Increment);
Buffer.Line (1..Old'Length) := Old.all;
Free (Old);
end;
end if;
Buffer.Length := Buffer.Length + 1;
Buffer.Line (Buffer.Length) := Data;
end loop;
end Read;
procedure Finalize (Buffer : in out Line_Buffer) is
begin
Free (Buffer.Line);
end Finalize;
end Buffers;
--
Regards,
Dmitry A. Kazakov
http://www.dmitry-kazakov.de
^ permalink raw reply [relevance 6%]
* Re: Load an object from a file
2009-04-03 13:37 5% ` Ludovic Brenta
2009-04-03 15:19 0% ` Olivier Scalbert
2009-04-09 20:32 6% ` Olivier Scalbert
@ 2009-04-19 13:08 0% ` Olivier Scalbert
2 siblings, 0 replies; 200+ results
From: Olivier Scalbert @ 2009-04-19 13:08 UTC (permalink / raw)
Hello,
I have an endianness problem. In the file, The u2 data are stored in
big-endian order. As I am working on a Pentium, the reading is done in
little-endian order. Is it possible to fix it with the representation
stuff ?
Thanks,
Olivier
Ludovic Brenta wrote:
>
> I would create a record type with one discriminant for each array,
> like so:
>
> type Constant_Pool_Array is array (Positive range <>) of cp_info;
> type Interfaces_Array is array (Positive range <>) of u2;
> -- etc.
>
> type Class_File
> (constant_pool_count,
> interfaces_count,
> fields_count,
> methods_count,
> attributes_count : u2)
> is record
> ...
> constant_pool : Constant_Pool_Array (2 .. constant_pool_count);
> ...
> interfaces : Interfaces_Array (1 .. interfaces_count);
> ... etc.
> end record;
>
>> Also how can I fill this array ?
>
> You would normally simply call the predefined Class_File'Read but this
> wouldn't work since the order of the components in type Class_File
> does not match the order in the file. So, you'd specify your own Read:
>
> function Input(
> Stream : not null access Ada.Streams.Root_Stream_Type'Class)
> return Class_File); -- see RM 13.13(22) and following
> for Class_File'Input use Input; -- as per RM 13.13(38/2)
>
> function Input(
> Stream : not null access Ada.Streams.Root_Stream_Type'Class)
> return Class_File)
> is
> Constant_Pool_Count : u2;
> type Constant_Pool_Array_Access is access Constant_Pool_Array;
> procedure Free is new Ada.Unchecked_Deallocation
> (Constant_Pool_Array, Constant_Pool_Array_Access);
> Constant_Pool : Constant_Pool_Array_Access;
> begin
> ...
> u2'Read (Stream, Constant_Pool_Count);
> Constant_Pool := new Constant_Pool_Array (1 .. Constant_Pool - 1);
> Constant_Pool_Array'Read (Stream, Constant_Pool.all);
> ...
>
> After reading all members, construct the result:
>
> declare
> Result : Class_File
> (constant_pool_count => Constant_Pool_Count,
> interfaces_count => Interfaces_Count,
> fields_count => Fields_Count,
> methods_count => Methods_Count,
> attributes_count => Attricutes_Count);
> begin
> Result.Constant_Pool := Constant_Pool.all;
> ...
> Free (Constant_Pool);
> ...
> return Result;
> end;
> end Input;
>
> You can also eliminate the use of access types and dynamic allocation
> and deallocation by nesting declare blocks, e.g.
>
> u2'Read (Stream, Constant_Pool_Count);
> declare
> Constant_Pool : Constant_Pool_Array (1 .. Constant_Pool_Count);
> begin
> Constant_Pool_Array'Read (Stream, Constant_Pool);
> ...
> u2'Read (Stream, Interfaces_Count);
> declare
> Interfaces : Interfaces_Count_Array (1 .. Interfaces_Count);
> begin
> ...
> end;
> end;
>
> HTH
>
> --
> Ludovic Brenta.
^ permalink raw reply [relevance 0%]
* Re: Problems with Scope of aliased Objects
@ 2009-04-16 15:47 5% ` Dmitry A. Kazakov
0 siblings, 0 replies; 200+ results
From: Dmitry A. Kazakov @ 2009-04-16 15:47 UTC (permalink / raw)
On Thu, 16 Apr 2009 06:43:22 -0700 (PDT), patrick.gunia@googlemail.com
wrote:
> I`ve got a question concerning the scope of Ada-variables. I got the
> following situation:
> First Approach:
> - I declare a local variable "A" of type "xy" within the declaration
> part of a procedure
> - the variable-members are set and finally put into an array
> => after leaving the procedure the variables are still accessable
> through the Array which is defined on a higher scope-level
This is wrong because it is not the variables declared in the procedure,
but copies of their values stored in the array elements.
> Second Approach:
> Now I want to restructure my code using general Access-Types for the
> declared variables.
> - I declare a variable "refA" as an alias to my variable-type
> "xy" (also in the declaration-part of the procedure)
> - I do the same operations on "refA" I did before on "A"
> - I declare an instance of a general access-type to my variable of
> type "xy" (also in the declaration-part of the procedure)
> - I pass the access-type-Instance into the Array
> => after leaving the function, I get errors during runtime
This makes no sense because of dangling pointers.
> Third Approach:
> My third approach works, but uses Heap-Memory for "A" thus I generate
> the instances dynamically within my procedure and then pass the
> general access-types into my array.
Create an array of pointers initialized by allocated objects.
> Now here�s my explanation for this:
> When leaving the function in my second approach the pointers are still
> avaiable, because they�re passed into the array, but the objects, the
> pointer point to are not, because they�re out of scope and thus
> destroyed. Is this rigth?
Yes, you have dangling pointers.
> Anf if so, what do I have to do, to get my
> second approach running, and not losing my locally declared objects
> after leaving the function.
You have to allocate the objects using 'new':
type Object is abstract ...;
type Object_Ptr is access Object'Class;
procedure Free is
new Ada.Unchecked_Deallocation (Object'Class, Object_Ptr);
type Objects_Array is array (Positive range <>) of Object_Ptr;
procedure Foo (Data : Objects_Array);
-- Derived types
type This_Object is new Object with ...;
type That_Object is new Object with ...;
declare
Data : Objects_Array := (new This_Object, new That_Object);
begin
...
Foo (Data); -- Deal with the array
...
for I in Data'Range loop
Free (Data (I)); -- Do not forget to destroy objects
end loop;
end;
Fourth solution could be to use a container of unconstrained objects or a
container of smart pointers if the objects are limited.
--
Regards,
Dmitry A. Kazakov
http://www.dmitry-kazakov.de
^ permalink raw reply [relevance 5%]
* Re: Load an object from a file
2009-04-03 13:37 5% ` Ludovic Brenta
2009-04-03 15:19 0% ` Olivier Scalbert
@ 2009-04-09 20:32 6% ` Olivier Scalbert
2009-04-19 13:08 0% ` Olivier Scalbert
2 siblings, 0 replies; 200+ results
From: Olivier Scalbert @ 2009-04-09 20:32 UTC (permalink / raw)
Hi,
I still have one question ...
How can I implement the Load_Class procedure that will use the Input
function?
I do not know how to get the needed stream from a given file name.
And I do not know how to define the Class_File_Structure result (I get
an unconstrained subtype (need initialization)).
Thanks,
Olivier
Here is my spec:
--------------------------
package jvm is
type Byte_T is range 0..255;
for Byte_T'Size use 8;
type U2_T is range 0 .. 2 ** 16 - 1;
type U4_T is range 0 .. 2 ** 32 - 1;
type cp_info_T is new Integer; -- Just for test !
type Constant_Pool_Array_T is array (U2_T range <>) of cp_info_T;
type Class_File_Structure_T(
constant_pool_count,
interfaces_count,
fields_count,
methods_count,
attributes_count : U2_T) is record
Magic : U4_T;
Minor_Version : U2_T;
Major_Version : U2_T;
Constant_Pool : Constant_Pool_Array_T (2 .. constant_pool_count);
--interfaces : Interfaces_Array_T (1 .. interfaces_count);
end record;
procedure Run;
procedure Load_Class(File_Name: String);
function Input(Stream : not null access
Ada.Streams.Root_Stream_Type'Class)
return Class_File_Structure_T; -- see RM 13.13(22)
and following
for Class_File_Structure_T'Input use Input; -- as per RM 13.13(38/2)
end jvm;
Here is the body:
--------------------------
with Ada.Text_IO; use Ada.Text_IO;
with Ada.Sequential_IO;
with Ada.Unchecked_Deallocation;
package body jvm is
procedure run is
begin
Load_Class("Main.class");
end run;
procedure Load_Class(File_Name: String) is
Class_File_Structure: Class_File_Structure_T; -- (unconstrained
subtype (need initialization)
begin
Put_Line(File_Name);
Class_file_Structure := Input(Stream ???);
end Load_Class;
function Input(Stream : not null access
Ada.Streams.Root_Stream_Type'Class)
return Class_File_Structure_T is
Magic : U4_T;
Minor_Version : U2_T;
Major_Version : U2_T;
Constant_Pool_Count : U2_T;
type Constant_Pool_Array_Access is access Constant_Pool_Array_T;
procedure Free is new Ada.Unchecked_Deallocation
(Constant_Pool_Array_T, Constant_Pool_Array_Access);
Constant_Pool : Constant_Pool_Array_Access;
begin
-- Read
U4_T'Read(Stream, Magic);
U2_T'Read(Stream, Minor_Version);
U2_T'Read(Stream, Major_Version);
U2_T'Read (Stream, Constant_Pool_Count);
Constant_Pool := new Constant_Pool_Array_T (1 ..
Constant_Pool_Count - 1);
Constant_Pool_Array_T'Read (Stream, Constant_Pool.all);
-- Fill in to the result
declare
Result : Class_File_Structure_T
(constant_pool_count => Constant_Pool_Count,
interfaces_count => 0, --Interfaces_Count,
fields_count => 0, --Fields_Count,
methods_count => 0, --Methods_Count,
attributes_count => 0); --Attricutes_Count);
begin
Result.Magic := Magic;
Result.Minor_Version := Minor_Version;
Result.Major_Version := Major_Version;
Result.Constant_Pool := Constant_Pool.all;
Free(Constant_Pool);
return Result;
end;
end;
end jvm;
Ludovic Brenta wrote:
> Olivier Scalbert wrote on comp.lang.ada:
>> Hello everybody !
>>
>> In my Ada self-study context, I was asking myself how can I create and
>> fill objects or records from a file.
>> As an example, I have tried to represent a java class file format
>> structure and fill it with a .class java file.
>>
>> The ClassFile structure is something like:
>>
>> ClassFile {
>> u4 magic;
>> u2 minor_version;
>> u2 major_version;
>> u2 constant_pool_count;
>> cp_info constant_pool[constant_pool_count-1];
>> u2 access_flags;
>> u2 this_class;
>> u2 super_class;
>> u2 interfaces_count;
>> u2 interfaces[interfaces_count];
>> u2 fields_count;
>> field_info fields[fields_count];
>> u2 methods_count;
>> method_info methods[methods_count];
>> u2 attributes_count;
>> attribute_info attributes[attributes_count];
>> }
>>
>> JVM Specs can be found there:http://java.sun.com/docs/books/jvms/second_edition/html/ClassFile.doc...
>>
>> I have no problem to represent and to fill from file, the first four fields.
>> But I do not know what is the best (Ada) way of representing the array
>> of info constant_pool as the size is only known at run time.(=
>> constant_pool_cout).
>
> I would create a record type with one discriminant for each array,
> like so:
>
> type Constant_Pool_Array is array (Positive range <>) of cp_info;
> type Interfaces_Array is array (Positive range <>) of u2;
> -- etc.
>
> type Class_File
> (constant_pool_count,
> interfaces_count,
> fields_count,
> methods_count,
> attributes_count : u2)
> is record
> ...
> constant_pool : Constant_Pool_Array (2 .. constant_pool_count);
> ...
> interfaces : Interfaces_Array (1 .. interfaces_count);
> ... etc.
> end record;
>
>> Also how can I fill this array ?
>
> You would normally simply call the predefined Class_File'Read but this
> wouldn't work since the order of the components in type Class_File
> does not match the order in the file. So, you'd specify your own Read:
>
> function Input(
> Stream : not null access Ada.Streams.Root_Stream_Type'Class)
> return Class_File); -- see RM 13.13(22) and following
> for Class_File'Input use Input; -- as per RM 13.13(38/2)
>
> function Input(
> Stream : not null access Ada.Streams.Root_Stream_Type'Class)
> return Class_File)
> is
> Constant_Pool_Count : u2;
> type Constant_Pool_Array_Access is access Constant_Pool_Array;
> procedure Free is new Ada.Unchecked_Deallocation
> (Constant_Pool_Array, Constant_Pool_Array_Access);
> Constant_Pool : Constant_Pool_Array_Access;
> begin
> ...
> u2'Read (Stream, Constant_Pool_Count);
> Constant_Pool := new Constant_Pool_Array (1 .. Constant_Pool - 1);
> Constant_Pool_Array'Read (Stream, Constant_Pool.all);
> ...
>
> After reading all members, construct the result:
>
> declare
> Result : Class_File
> (constant_pool_count => Constant_Pool_Count,
> interfaces_count => Interfaces_Count,
> fields_count => Fields_Count,
> methods_count => Methods_Count,
> attributes_count => Attricutes_Count);
> begin
> Result.Constant_Pool := Constant_Pool.all;
> ...
> Free (Constant_Pool);
> ...
> return Result;
> end;
> end Input;
>
> You can also eliminate the use of access types and dynamic allocation
> and deallocation by nesting declare blocks, e.g.
>
> u2'Read (Stream, Constant_Pool_Count);
> declare
> Constant_Pool : Constant_Pool_Array (1 .. Constant_Pool_Count);
> begin
> Constant_Pool_Array'Read (Stream, Constant_Pool);
> ...
> u2'Read (Stream, Interfaces_Count);
> declare
> Interfaces : Interfaces_Count_Array (1 .. Interfaces_Count);
> begin
> ...
> end;
> end;
>
> HTH
>
> --
> Ludovic Brenta.
^ permalink raw reply [relevance 6%]
* Re: Load an object from a file
2009-04-03 13:37 5% ` Ludovic Brenta
@ 2009-04-03 15:19 0% ` Olivier Scalbert
2009-04-09 20:32 6% ` Olivier Scalbert
2009-04-19 13:08 0% ` Olivier Scalbert
2 siblings, 0 replies; 200+ results
From: Olivier Scalbert @ 2009-04-03 15:19 UTC (permalink / raw)
Thanks Ludovic,
One more question:
with:
type u2 is new Integer;
type cp_info is new Integer;
type Constant_Pool_Array is array (Positive range <>) of cp_info;
type Interfaces_Array is array (Positive range <>) of u2;
type Class_File
(constant_pool_count,
interfaces_count,
fields_count,
methods_count,
attributes_count : u2)
is record
constant_pool : Constant_Pool_Array (2 .. constant_pool_count);
interfaces : Interfaces_Array (1 .. interfaces_count);
end record;
I have an error: expected type "Standard.Integer", in the 2 last lines.
If I replace the line:
"attributes_count : u2" by
"attributes_count : Integer"
then compile is Ok !
Don't know how to cleanly solve ...
Olivier
Ludovic Brenta wrote:
> I would create a record type with one discriminant for each array,
> like so:
>
> type Constant_Pool_Array is array (Positive range <>) of cp_info;
> type Interfaces_Array is array (Positive range <>) of u2;
> -- etc.
>
> type Class_File
> (constant_pool_count,
> interfaces_count,
> fields_count,
> methods_count,
> attributes_count : u2)
> is record
> ...
> constant_pool : Constant_Pool_Array (2 .. constant_pool_count);
> ...
> interfaces : Interfaces_Array (1 .. interfaces_count);
> ... etc.
> end record;
>
>> Also how can I fill this array ?
>
> You would normally simply call the predefined Class_File'Read but this
> wouldn't work since the order of the components in type Class_File
> does not match the order in the file. So, you'd specify your own Read:
>
> function Input(
> Stream : not null access Ada.Streams.Root_Stream_Type'Class)
> return Class_File); -- see RM 13.13(22) and following
> for Class_File'Input use Input; -- as per RM 13.13(38/2)
>
> function Input(
> Stream : not null access Ada.Streams.Root_Stream_Type'Class)
> return Class_File)
> is
> Constant_Pool_Count : u2;
> type Constant_Pool_Array_Access is access Constant_Pool_Array;
> procedure Free is new Ada.Unchecked_Deallocation
> (Constant_Pool_Array, Constant_Pool_Array_Access);
> Constant_Pool : Constant_Pool_Array_Access;
> begin
> ...
> u2'Read (Stream, Constant_Pool_Count);
> Constant_Pool := new Constant_Pool_Array (1 .. Constant_Pool - 1);
> Constant_Pool_Array'Read (Stream, Constant_Pool.all);
> ...
>
> After reading all members, construct the result:
>
> declare
> Result : Class_File
> (constant_pool_count => Constant_Pool_Count,
> interfaces_count => Interfaces_Count,
> fields_count => Fields_Count,
> methods_count => Methods_Count,
> attributes_count => Attricutes_Count);
> begin
> Result.Constant_Pool := Constant_Pool.all;
> ...
> Free (Constant_Pool);
> ...
> return Result;
> end;
> end Input;
>
> You can also eliminate the use of access types and dynamic allocation
> and deallocation by nesting declare blocks, e.g.
>
> u2'Read (Stream, Constant_Pool_Count);
> declare
> Constant_Pool : Constant_Pool_Array (1 .. Constant_Pool_Count);
> begin
> Constant_Pool_Array'Read (Stream, Constant_Pool);
> ...
> u2'Read (Stream, Interfaces_Count);
> declare
> Interfaces : Interfaces_Count_Array (1 .. Interfaces_Count);
> begin
> ...
> end;
> end;
>
> HTH
>
> --
> Ludovic Brenta.
^ permalink raw reply [relevance 0%]
* Re: Load an object from a file
@ 2009-04-03 13:37 5% ` Ludovic Brenta
2009-04-03 15:19 0% ` Olivier Scalbert
` (2 more replies)
0 siblings, 3 replies; 200+ results
From: Ludovic Brenta @ 2009-04-03 13:37 UTC (permalink / raw)
Olivier Scalbert wrote on comp.lang.ada:
> Hello everybody !
>
> In my Ada self-study context, I was asking myself how can I create and
> fill objects or records from a file.
> As an example, I have tried to represent a java class file format
> structure and fill it with a .class java file.
>
> The ClassFile structure is something like:
>
> ClassFile {
> u4 magic;
> u2 minor_version;
> u2 major_version;
> u2 constant_pool_count;
> cp_info constant_pool[constant_pool_count-1];
> u2 access_flags;
> u2 this_class;
> u2 super_class;
> u2 interfaces_count;
> u2 interfaces[interfaces_count];
> u2 fields_count;
> field_info fields[fields_count];
> u2 methods_count;
> method_info methods[methods_count];
> u2 attributes_count;
> attribute_info attributes[attributes_count];
> }
>
> JVM Specs can be found there:http://java.sun.com/docs/books/jvms/second_edition/html/ClassFile.doc...
>
> I have no problem to represent and to fill from file, the first four fields.
> But I do not know what is the best (Ada) way of representing the array
> of info constant_pool as the size is only known at run time.(=
> constant_pool_cout).
I would create a record type with one discriminant for each array,
like so:
type Constant_Pool_Array is array (Positive range <>) of cp_info;
type Interfaces_Array is array (Positive range <>) of u2;
-- etc.
type Class_File
(constant_pool_count,
interfaces_count,
fields_count,
methods_count,
attributes_count : u2)
is record
...
constant_pool : Constant_Pool_Array (2 .. constant_pool_count);
...
interfaces : Interfaces_Array (1 .. interfaces_count);
... etc.
end record;
> Also how can I fill this array ?
You would normally simply call the predefined Class_File'Read but this
wouldn't work since the order of the components in type Class_File
does not match the order in the file. So, you'd specify your own Read:
function Input(
Stream : not null access Ada.Streams.Root_Stream_Type'Class)
return Class_File); -- see RM 13.13(22) and following
for Class_File'Input use Input; -- as per RM 13.13(38/2)
function Input(
Stream : not null access Ada.Streams.Root_Stream_Type'Class)
return Class_File)
is
Constant_Pool_Count : u2;
type Constant_Pool_Array_Access is access Constant_Pool_Array;
procedure Free is new Ada.Unchecked_Deallocation
(Constant_Pool_Array, Constant_Pool_Array_Access);
Constant_Pool : Constant_Pool_Array_Access;
begin
...
u2'Read (Stream, Constant_Pool_Count);
Constant_Pool := new Constant_Pool_Array (1 .. Constant_Pool - 1);
Constant_Pool_Array'Read (Stream, Constant_Pool.all);
...
After reading all members, construct the result:
declare
Result : Class_File
(constant_pool_count => Constant_Pool_Count,
interfaces_count => Interfaces_Count,
fields_count => Fields_Count,
methods_count => Methods_Count,
attributes_count => Attricutes_Count);
begin
Result.Constant_Pool := Constant_Pool.all;
...
Free (Constant_Pool);
...
return Result;
end;
end Input;
You can also eliminate the use of access types and dynamic allocation
and deallocation by nesting declare blocks, e.g.
u2'Read (Stream, Constant_Pool_Count);
declare
Constant_Pool : Constant_Pool_Array (1 .. Constant_Pool_Count);
begin
Constant_Pool_Array'Read (Stream, Constant_Pool);
...
u2'Read (Stream, Interfaces_Count);
declare
Interfaces : Interfaces_Count_Array (1 .. Interfaces_Count);
begin
...
end;
end;
HTH
--
Ludovic Brenta.
^ permalink raw reply [relevance 5%]
* Re: Newbie question -- dereferencing access
@ 2009-03-13 17:33 3% ` Martin
0 siblings, 0 replies; 200+ results
From: Martin @ 2009-03-13 17:33 UTC (permalink / raw)
On Mar 13, 4:31 pm, Tim Rowe <spamt...@tgrowe.plus.net> wrote:
> Alex R. Mosteo wrote:
> > While these are certainly important skills, one thing you should notice when
> > transitioning to Ada is a decreased need for access types thanks to
> > unconstrained/indefinite types. I'd think that would mean that you're in the
> > right track.
>
> But I can't put an unconstrained type into a record. I realise that I
> can make the record discriminated and constrain the type on the
> discriminant, trying to write a class that gives strtok-like
> functionality -- the excercise I have set myself at the moment -- means
> that I discover the sizes of relevant strings rather late in the game.
>
> > Anyway, if you have a sound knowledge of memory management in C/C++, it's
> > pretty much the same. Don't forget to deallocate, wrap it all in a
> > controlled type.
>
> What I'm feeling the lack of is destructors for classes (sorry, for
> tagged records). I suspect I'll find what I need when I learn about
> finalizers, but whereas in C++ I learned about delete at the same time
> as I learned about new, and I learned about destructors at the same time
> as I learned about constructors, it seems strange in Ada to find access
> allocation addressed in the mainstream and access deallocation relegated
> to an advanced topic (and destructors nowhere in my sight). And yet it's
> C/C++ that has the reputation for memory leaks!
This might help:
It's my implementation of the "Ada1Z" package
Ada.Containers.Indefinite_Holders (AI0069):
File: a-coinho.ads
-- The language-defined generic package Containers.Indefinite_Holders
-- provides private type Holder and a set of operations for that
type. A
-- holder container holds a single element of an indefinite type.
--
-- A holder containers allows the declaration of an object that can
be used
-- like an uninitialized variable or component of an indefinite type.
--
-- A holder container may be *empty*. An empty holder does not
contain an
-- element.
with Ada.Finalization;
with Ada.Streams;
generic
type Element_Type (<>) is private;
with function "=" (Left, Right : Element_Type) return Boolean is
<>;
-- The actual function for the generic formal function "=" on
Element_Type
-- values is expected to define a reflexive and symmetric
relationship and
-- return the same result value each time it is called with a
particular
-- pair of values. If it behaves in some other manner, the
function "=" on
-- holder values returns an unspecified value. The exact arguments
and
-- number of calls of this generic formal function by the function
"=" on
-- holder values are unspecified.
--
-- AARM Ramification: If the actual function for "=" is not
symmetric
-- and consistent, the result returned by any of the functions
defined
-- to use "=" cannot be predicted. The implementation is not
required
-- to protect against "=" raising an exception, or returning
random
-- results, or any other "bad" behavior. And it can call "=" in
-- whatever manner makes sense. But note that only the results
of the
-- function "=" is unspecified; other subprograms are not
allowed to
-- break if "=" is bad.
package Ada.Containers.Indefinite_Holders is
pragma Preelaborate (Indefinite_Holders);
-- This package provides a "holder" of a definite type that
contains a
-- single value of an indefinite type.
-- This allows one to effectively declare an uninitialized
variable or
-- component of an indefinite type.
type Holder is tagged private;
pragma Preelaborable_Initialization (Holder);
-- The type Holder is used to represent holder containers. The
type Holder
-- needs finalization (see 7.6).
Empty_Holder : constant Holder;
-- Empty_Holder represents an empty holder object. If an object of
type
-- Holder is not otherwise initialized, it is initialized to the
same
-- value as Empty_Holder.
function "=" (Left, Right : Holder) return Boolean;
-- If Left and Right denote the same holder object, then the
function
-- returns True.
-- Otherwise, it compares the element contained in Left to the
element
-- contained in Right using the generic formal equality operator,
-- returning The Result of that operation. Any exception raised
during
-- the evaluation of element equality is propagated.
function To_Holder (New_Item : Element_Type) return Holder;
-- Returns a non-empty holder containing an element initialized to
-- New_Item.
function Is_Empty (Container : Holder) return Boolean;
-- Returns True if the holder is empty, and False if it contains
an
-- element.
procedure Clear (Container : in out Holder);
-- Removes the element from Container.
function Element (Container : Holder) return Element_Type;
-- If Container is empty, Constraint_Error is propagated.
-- Otherwise, returns the element stored in Container.
procedure Replace_Element (Container : in out Holder;
New_Item : Element_Type);
-- Replace_Element assigns the value New_Item into Container,
replacing
-- any preexisting content of Container. Container is not empty
-- after a successful call to Replace_Element.
procedure Query_Element
(Container : Holder;
Process : not null access procedure (Element : Element_Type));
-- If Container is empty, Constraint_Error is propagated.
-- Otherwise, Query_Element calls Process.all with the contained
element
-- as the argument. Program_Error is raised if Process.all tampers
with
-- the elements of Container. Any exception raised by Process.all
is
-- propagated.
procedure Update_Element
(Container : Holder;
Process : not null access procedure (Element : in out
Element_Type));
-- If Container is empty, Constraint_Error is propagated.
-- Otherwise, Query_Element calls Process.all with the contained
element
-- as the argument. Program_Error is raised if Process.all tampers
with
-- the elements of Container. Any exception raised by Process.all
is
-- propagated.
procedure Move (Target : in out Holder;
Source : in out Holder);
-- If Target denotes the same object as Source, then Move has no
effect.
-- Otherwise, the element contained by Source (if any) is removed
from
-- Source and inserted into Target, replacing any preexisting
content.
-- Source is empty after a successful call to Move.
private
type Element_Ptr is access Element_Type;
type Holder is new Ada.Finalization.Controlled with record
Contents : Element_Ptr := null;
Busy : Natural := 0;
end record;
procedure Adjust (Container : in out Holder);
procedure Finalize (Container : in out Holder);
use Ada.Streams;
procedure Write (Stream : access Root_Stream_Type'Class;
Container : Holder);
for Holder'Write use Write;
procedure Read (Stream : access Root_Stream_Type'Class;
Container : out Holder);
for Holder'Read use Read;
Empty_Holder : constant Holder := (Ada.Finalization.Controlled with
others => <>);
end Ada.Containers.Indefinite_Holders;
File: a-coinho.adb
with Ada.Unchecked_Deallocation;
with System;
package body Ada.Containers.Indefinite_Holders is
procedure Free is
new Ada.Unchecked_Deallocation (Element_Type, Element_Ptr);
---------
-- "=" --
---------
function "=" (Left, Right : Holder) return Boolean is
use type System.Address;
begin
if Left'Address = Right'Address then
return True;
end if;
if Is_Empty (Left) then
return Is_Empty (Right);
else
return not Is_Empty (Right) and then Left.Contents.all =
Right.Contents.all;
end if;
end "=";
---------------
-- To_Holder --
---------------
function To_Holder (New_Item : Element_Type) return Holder is
begin
return (Ada.Finalization.Controlled with
Contents => new Element_Type'(New_Item),
Busy => 0);
end To_Holder;
--------------
-- Is_Empty --
--------------
function Is_Empty (Container : Holder) return Boolean is
begin
return Container.Contents = null;
end Is_Empty;
-----------
-- Clear --
-----------
procedure Clear (Container : in out Holder) is
begin
if Container.Busy > 0 then
raise Program_Error with "attempt to tamper with element
(holder is busy)";
end if;
if Container.Contents /= null then
Free (Container.Contents);
Container.Busy := 0;
end if;
end Clear;
-------------
-- Element --
-------------
function Element (Container : Holder) return Element_Type is
begin
if Container.Contents = null then
raise Constraint_Error with "Container has no element";
end if;
return Container.Contents.all;
end Element;
---------------------
-- Replace_Element --
---------------------
procedure Replace_Element (Container : in out Holder;
New_Item : Element_Type) is
begin
if Container.Busy > 0 then
raise Program_Error with "attempt to tamper with element
(holder is busy)";
end if;
Clear (Container);
Container.Contents := new Element_Type'(New_Item);
end Replace_Element;
-------------------
-- Query_Element --
-------------------
procedure Query_Element
(Container : Holder;
Process : not null access procedure (Element : Element_Type))
is
H : Holder renames Container'Unrestricted_Access.all;
B : Natural renames H.Busy;
begin
if Container.Contents = null then
raise Constraint_Error with "Container has no element";
end if;
B := B + 1;
begin
Process (Container.Contents.all);
exception
when others =>
B := B - 1;
raise;
end;
B := B - 1;
end Query_Element;
--------------------
-- Update_Element --
--------------------
procedure Update_Element
(Container : Holder;
Process : not null access procedure (Element : in out
Element_Type)) is
H : Holder renames Container'Unrestricted_Access.all;
B : Natural renames H.Busy;
begin
if Container.Contents = null then
raise Constraint_Error with "Container has no element";
end if;
B := B + 1;
begin
Process (Container.Contents.all);
exception
when others =>
B := B - 1;
raise;
end;
B := B - 1;
end Update_Element;
----------
-- Move --
----------
procedure Move (Target : in out Holder;
Source : in out Holder) is
begin
if Target.Busy > 0 then
raise Program_Error with "attempt to tamper with elements
(Target is busy)";
end if;
if Source.Busy > 0 then
raise Program_Error with "attempt to tamper with elements
(Source is busy)";
end if;
if Target.Contents /= Source.Contents then
Clear (Target);
Target.Contents := Source.Contents;
Source.Contents := null;
end if;
end Move;
------------
-- Adjust --
------------
procedure Adjust (Container : in out Holder) is
begin
if Container.Contents /= null then
Container.Contents := new
Element_Type'(Container.Contents.all);
Container.Busy := 0;
end if;
end Adjust;
--------------
-- Finalize --
--------------
procedure Finalize (Container : in out Holder) is
begin
if Container.Busy > 0 then
raise Program_Error with "attempt to tamper with element
(holder is busy)";
end if;
if Container.Contents /= null then
Free (Container.Contents);
Container.Busy := 0;
end if;
end Finalize;
-----------
-- Write --
-----------
procedure Write (Stream : access Root_Stream_Type'Class;
Container : Holder) is
Is_Present : constant Boolean := Container.Contents /= null;
begin
Boolean'Write (Stream, Is_Present);
if Is_Present then
Element_Type'Output (Stream, Container.Contents.all);
end if;
end Write;
----------
-- Read --
----------
procedure Read (Stream : access Root_Stream_Type'Class;
Container : out Holder) is
Is_Present : Boolean := Boolean'Input(Stream);
begin
Clear (Container);
if Is_Present then
Container.Contents := new Element_Type'(Element_Type'Input
(Stream));
end if;
end Read;
end Ada.Containers.Indefinite_Holders;
Usual caveats about no warrenties, etc. but other than that use as you
see fit! :-)
Here's a (very) small test / demo:
File: test_ai05_0068.adb
--pragma Warnings (Off);
with Ada.Containers.Indefinite_Holders;
--pragma Warnings (On);
with Ada.Exceptions;
with Ada.Text_IO;
procedure Test_AI05_0069 is
package String_Holders is
new Ada.Containers.Indefinite_Holders (String);
My_String : String_Holders.Holder := String_Holders.To_Holder
("Hello World!");
procedure Test_Query is
procedure Do_Something (Element : String) is
begin
My_String.Clear;
end Do_Something;
begin
My_String.Query_Element (Do_Something'Access);
exception
when E : Program_Error =>
Ada.Text_Io.Put_Line ("Caught exception [" &
Ada.Exceptions.Exception_Name (E)
& "] with message [" &
Ada.Exceptions.Exception_Message (E) & "]");
end Test_Query;
procedure Test_Update is
procedure Do_Something (Element : in out String) is
begin
My_String.Clear;
Element := "asdasdas";
end Do_Something;
begin
My_String.Update_Element (Do_Something'Access);
exception
when E : Program_Error =>
Ada.Text_Io.Put_Line ("Caught exception [" &
Ada.Exceptions.Exception_Name (E)
& "] with message [" &
Ada.Exceptions.Exception_Message (E) & "]");
end Test_Update;
procedure Test_Move is
My_Other_String : String_Holders.Holder :=
String_Holders.To_Holder ("s");
begin
Ada.Text_IO.Put_Line ("Source = [" & My_String.Element & "]");
Ada.Text_IO.Put_Line ("Target = [" & My_Other_String.Element &
"]");
String_Holders.Move (Source => My_String,
Target => My_Other_String);
begin
Ada.Text_Io.Put_Line ("Source = [" & My_String.Element &
"]");
exception
when E : Constraint_Error =>
Ada.Text_Io.Put_Line ("Caught exception [" &
Ada.Exceptions.Exception_Name (E)
& "] with message [" &
Ada.Exceptions.Exception_Message (E) & "]");
end;
Ada.Text_IO.Put_Line ("Target = [" & My_Other_String.Element &
"]");
end Test_Move;
type A_Record is record
Component : String_Holders.Holder;
end record;
My_Record : A_Record;
begin
Ada.Text_IO.Put_Line ("Is_Empty = " & Boolean'Image
(My_String.Is_Empty));
My_String.Query_Element (Process => Ada.Text_IO.Put_Line'Access);
Ada.Text_IO.Put_Line ("Element = [" & My_String.Element & "]");
My_String.Replace_Element ("Wibble");
My_String.Query_Element (Process => Ada.Text_Io.Put_Line'Access);
Ada.Text_IO.Put_Line ("Element = [" & My_String.Element & "]");
My_String.Clear;
Ada.Text_Io.Put_Line ("Is_Empty = " & Boolean'Image
(My_String.Is_Empty));
begin
Ada.Text_Io.Put_Line ("Element = [" & My_String.Element & "]");
Ada.Text_Io.Put_Line ("*** Should have raised exception");
exception
when E : Constraint_Error =>
Ada.Text_Io.Put_Line ("Caught exception [" &
Ada.Exceptions.Exception_Name (E)
& "] with message [" &
Ada.Exceptions.Exception_Message (E) & "]");
end;
My_String.Replace_Element ("Wibble again");
Test_Query;
Test_Update;
Test_Move;
exception
when E : others =>
Ada.Text_Io.Put_Line ("Caught unexpected exception [" &
Ada.Exceptions.Exception_Name (E)
& "] with message [" &
Ada.Exceptions.Exception_Message (E) & "]");
end Test_AI05_0069;
Remember to include a '-a' options when you build it with GNAT.
Cheers
-- Martin
^ permalink raw reply [relevance 3%]
* Re: How to implement a server socket compatible to telnet?
2008-08-20 21:25 6% ` snoopysalive
@ 2008-08-20 22:57 0% ` anon
0 siblings, 0 replies; 200+ results
From: anon @ 2008-08-20 22:57 UTC (permalink / raw)
But he wants to deal with Telnet. It states that in the title.
And actually, a complete program PingPong is coded in the file
"GNAT.Sockets.ads " which deals with both server and client code.
Like I say KNOW your compiler and its packages That way you might be
able to skip spending time seaching the internet or books.
In <0baa592d-1291-4298-90e3-88ca85a476a8@k13g2000hse.googlegroups.com>, "snoopysalive@googlemail.com" <snoopysalive@googlemail.com> writes:
>Come on guys, stop arguing. In the end, I've found a solution:
>
>-----------------------------------------------------------------------
>with Ada.Text_IO,
> Ada.Exceptions,
> Ada.Streams,
> Ada.Unchecked_Deallocation,
> GNAT.Sockets;
>use Ada.Text_IO,
> Ada.Exceptions,
> Ada.Streams,
> GNAT.Sockets;
>
>procedure IP_Server is
>
> BUFFER_SIZE : constant Positive := 1024;
>
> type String_Access is access all String;
>
> procedure Free is new Ada.Unchecked_Deallocation
> (String, String_Access);
>
> CRLF : constant String := ASCII.CR & ASCII.LF;
> Host : constant String := "localhost";
> Port : Port_Type := 7777;
>
> Address : Sock_Addr_Type;
> Server : Socket_Type;
> Client : Socket_Type;
> Channel : Stream_Access;
>
> Data : Stream_Element_Array (1..1);
> Offset : Stream_Element_Count;
>
> Buffer : String_Access := new String (1..BUFFER_SIZE);
> Cnt : Natural := 0;
>
> Test : Float := 0.0;
>
>begin -- IP_Server
> Initialize;
>
> Address.Addr := Addresses (Get_Host_By_Name (Host), 1);
> Address.Port := Port;
>
> Create_Socket (Server);
> Set_Socket_Option (Server, Socket_Level, (Reuse_Address, True));
> Bind_Socket (Server, Address);
> Listen_Socket (Server);
> Accept_Socket (Server, Client, Address);
> Channel := Stream (Client);
>
> Cnt := 0;
> loop
> Read (Channel.all, Data (1..1), Offset);
> if Character'Val (Data (1)) = ASCII.CR or
> Character'Val (Data (1)) = ASCII.LF or
> Character'Val (Data (1)) = ASCII.NUL or
> Offset = 0 then
> exit;
> else
> Cnt := Cnt + 1;
> Buffer.all (Cnt) := Character'Val (Data (1));
> end if;
> end loop;
> -- Read values from client-stream character by character.
> -- Reading should be stopped when Windows-linefeed or
> -- NULL was found, because telnet seams to be sending
> -- strings in a Windows-like format including the
> -- terminating \0-character known from C-strings.
>
> declare
> Old : String_Access := Buffer;
> begin
> Buffer := new String'(Buffer (1..Cnt));
> Free (Old);
> end;
> -- The buffer-size of Str is 1024 elements. It's necessary
> -- to create a new String containing only relevant characters
> -- for being able to process the message further.
>
> declare
> Pong : String := "pong" & CRLF;
> O : Stream_Element_Array (1..Pong'length);
> begin
> if Buffer.all = "ping" then
> for I in Pong'range loop
> O (Stream_Element_Offset (I)) := Character'Pos (Pong (I));
> end loop;
> Write (Channel.all, O);
> end if;
> end;
> -- If Buffer's message equals "ping" the server will
> -- send "pong" to the client. "pong" must be casted
> -- from String to Stream_Element_Array first.
>
> Close_Socket (Client);
> Close_Socket (Server);
>
> Finalize;
>
>exception when E : Socket_Error =>
> Put_Line (Standard_Error, "Socket_Error => " & Exception_Message
>(E));
>
>end IP_Server;
>-----------------------------------------------------------------------------------
>
>Thanks to the thread under http://groups.google.com/group/comp.lang.ada/browse_thread/thread/c58b7bd180ea81b2
>I found out how to read character by character from the client.
>However, it's not very comfortable to cast the echo-string manually
>but it's better than not being able to communicate with telnet or
>other C-based clients.
>
>Bye,
>Matthias
^ permalink raw reply [relevance 0%]
* Re: How to implement a server socket compatible to telnet?
@ 2008-08-20 21:25 6% ` snoopysalive
2008-08-20 22:57 0% ` anon
0 siblings, 1 reply; 200+ results
From: snoopysalive @ 2008-08-20 21:25 UTC (permalink / raw)
Come on guys, stop arguing. In the end, I've found a solution:
-----------------------------------------------------------------------
with Ada.Text_IO,
Ada.Exceptions,
Ada.Streams,
Ada.Unchecked_Deallocation,
GNAT.Sockets;
use Ada.Text_IO,
Ada.Exceptions,
Ada.Streams,
GNAT.Sockets;
procedure IP_Server is
BUFFER_SIZE : constant Positive := 1024;
type String_Access is access all String;
procedure Free is new Ada.Unchecked_Deallocation
(String, String_Access);
CRLF : constant String := ASCII.CR & ASCII.LF;
Host : constant String := "localhost";
Port : Port_Type := 7777;
Address : Sock_Addr_Type;
Server : Socket_Type;
Client : Socket_Type;
Channel : Stream_Access;
Data : Stream_Element_Array (1..1);
Offset : Stream_Element_Count;
Buffer : String_Access := new String (1..BUFFER_SIZE);
Cnt : Natural := 0;
Test : Float := 0.0;
begin -- IP_Server
Initialize;
Address.Addr := Addresses (Get_Host_By_Name (Host), 1);
Address.Port := Port;
Create_Socket (Server);
Set_Socket_Option (Server, Socket_Level, (Reuse_Address, True));
Bind_Socket (Server, Address);
Listen_Socket (Server);
Accept_Socket (Server, Client, Address);
Channel := Stream (Client);
Cnt := 0;
loop
Read (Channel.all, Data (1..1), Offset);
if Character'Val (Data (1)) = ASCII.CR or
Character'Val (Data (1)) = ASCII.LF or
Character'Val (Data (1)) = ASCII.NUL or
Offset = 0 then
exit;
else
Cnt := Cnt + 1;
Buffer.all (Cnt) := Character'Val (Data (1));
end if;
end loop;
-- Read values from client-stream character by character.
-- Reading should be stopped when Windows-linefeed or
-- NULL was found, because telnet seams to be sending
-- strings in a Windows-like format including the
-- terminating \0-character known from C-strings.
declare
Old : String_Access := Buffer;
begin
Buffer := new String'(Buffer (1..Cnt));
Free (Old);
end;
-- The buffer-size of Str is 1024 elements. It's necessary
-- to create a new String containing only relevant characters
-- for being able to process the message further.
declare
Pong : String := "pong" & CRLF;
O : Stream_Element_Array (1..Pong'length);
begin
if Buffer.all = "ping" then
for I in Pong'range loop
O (Stream_Element_Offset (I)) := Character'Pos (Pong (I));
end loop;
Write (Channel.all, O);
end if;
end;
-- If Buffer's message equals "ping" the server will
-- send "pong" to the client. "pong" must be casted
-- from String to Stream_Element_Array first.
Close_Socket (Client);
Close_Socket (Server);
Finalize;
exception when E : Socket_Error =>
Put_Line (Standard_Error, "Socket_Error => " & Exception_Message
(E));
end IP_Server;
-----------------------------------------------------------------------------------
Thanks to the thread under http://groups.google.com/group/comp.lang.ada/browse_thread/thread/c58b7bd180ea81b2
I found out how to read character by character from the client.
However, it's not very comfortable to cast the echo-string manually
but it's better than not being able to communicate with telnet or
other C-based clients.
Bye,
Matthias
^ permalink raw reply [relevance 6%]
* Re: another way to shoot yourself in the foot?
@ 2008-06-24 17:52 7% ` Dmitry A. Kazakov
0 siblings, 0 replies; 200+ results
From: Dmitry A. Kazakov @ 2008-06-24 17:52 UTC (permalink / raw)
On Tue, 24 Jun 2008 13:20:54 -0400, Robert A Duff wrote:
> "Dmitry A. Kazakov" <mailbox@dmitry-kazakov.de> writes:
>
>> On Tue, 24 Jun 2008 07:59:35 -0700 (PDT), Adam Beneschan wrote:
>>
>>> I've probably lost the plot of this thread. But in regards to the
>>> example, I think the example is "no". The semantics should be exactly
>>> the same as if Interesting's body were simply "return X : T;". The
>>> first extended return statement that raises an exception doesn't have
>>> any effect, in terms of starting a new task or anything like that,
>>> because the RM explicitly says that task activation doesn't occur
>>> until after the function returns (6.5(7)).
>>
>> OK, then the notorious problem of Ada 95, that a task cannot be
>> initialized, in the sense that upon initialization you could pass
>> parameters to it via a rendezvous, is still there.
>
> The way to initialize tasks in Ada 95 and Ada 2005 is to pass
> discriminants to the task.
It is a very limited way, and in any case semantically it is different from
initialization parameters. A parameter is not required to outlive
initialization, while a discriminant is. Logically discriminant is a
constraint, it is by no way a parameter.
>> Tasks finalization does not work either, because there is no destructing
>> functions ("malfunctions" to use the name Robert Duff suggested (:-))
>> anyway.
>
> I'm not sure what the issue is, here. Masters wait for their dependent
> tasks to terminate (or be "ready" to terminate -- at a terminate
> alternative) BEFORE the task objects are finalized. So when a task
> object is finalized, it is already terminated, so it doesn't make sense
> to rendezvous with it.
Nope, it makes a lot of sense, but it just does not work. Because a task
rarely knows if it should complete. The enclosing object does not expect
its components to prematurely finalize themselves. It is just a bad design
turned upside down:
task type Foo is
Start_Up (...);
Shut_Down (...);
end Foo;
type T is new Ada.Finalization.Limited_Controlled with record
X : Foo; -- No chance to make this working
...
There is no other option than to use access to task instead:
type Foo_Ptr is access Foo;
type T is new Ada.Finalization.Limited_Controlled with record
X : Foo_Ptr; -- This is OK, but more C++ than Ada!
...
procedure Initialize (Obj : in out T) is
procedure Free is new Ada.Unchecked_Deallocation (Foo, Foo_Ptr);
begin
Obj.X := new Foo;
Obj.X.Start_Up (...);
exception
when others => -- We don't want it leaking, right?
Free (Obj.X); -- Probably this will hang, nevertheless...
raise;
end Initialize;
procedure Finalize (Obj : in out T) is
procedure Free is new Ada.Unchecked_Deallocation (Foo, Foo_Ptr);
begin
Obj.X.Shut_Down (...);
Free (Obj.X);
exception
when others =>
Free (Obj.X);
raise;
end Finalize;
A quite intrusive pattern, isn't it?
--
Regards,
Dmitry A. Kazakov
http://www.dmitry-kazakov.de
^ permalink raw reply [relevance 7%]
* Re: Question on initialization of packages
2008-06-17 10:26 6% ` Dmitry A. Kazakov
@ 2008-06-17 12:03 0% ` Reinert Korsnes
0 siblings, 0 replies; 200+ results
From: Reinert Korsnes @ 2008-06-17 12:03 UTC (permalink / raw)
First: many thanks for comments.
It gave me a nice learning curve today :-)
Dmitry A. Kazakov wrote:
> On Tue, 17 Jun 2008 11:14:59 +0200, Reinert Korsnes wrote:
>
>> Dmitry A. Kazakov wrote:
>>
>>> On Tue, 17 Jun 2008 10:07:43 +0200, Reinert Korsnes wrote:
>>>
>>>> Question: How can I be sure that "Send_Stack" is empty
>>>> at the start of the program execution ?
>>>
>>> Hmm, "sure" in which sense? To make it visible for the reader? To
>>> specify in the contract of Stack that it is initially empty?
>>
>> Yes, yes, to make it visible for the reader.
>
> I.e. you want to allow initially non-empty stacks? This does not look like
> a good idea.
Maybe a bit amataur, but down in the code I now have:
Node(i).Send_Stack := Message_Stack_p.Empty_Stack;
(thanks to your suggestions here)
Maybe I better could define a procedure "Empty_Stack(Send_Stack)" ?
reinert
>
> Anyway, if stack is non-limited, you could do something like
>
> type Stack (<>) is private;
> -- The box <> enforces object's initialization
> Empty : constant Stack; -- Initial value of an empty stack
> ...
> private
> ...
> Empty : constant Stack := null;
>
> then the user will be forced to do:
>
> Send_Stack : Stack := Empty;
>
> However, I see no reason to have stack copyable in the first line.
>
>>> As for implementation you posted, the stack is empty, because instances
>>> of access types are initialized with null (when not explicitly
>>> initialized
>>
>> Yes, but I do not like things depend on the particular implementation :-)
>
> But this particular implementation fulfills the stack contract, which
> reads "stack is initially empty." I see no problem here.
>
>>>> procedure Pop(S: in out Stack; X: out Item) is
>>>> begin
>>>> X := S.Value;
>>>> S := S.Next;
>>>> end;
>>>
>>> This is a memory leak. If you allocated a stack element on push, you
>>> should free it on pop.
>>
>> How I free it? I may not have a deep enough understanding here :-)
>
> Per a call to instantiated Ada.Unchecked_Deallocation.
>
> procedure Pop (S: in out Stack; X: out Item) is
> procedure Free is new Ada.Unchecked_Deallocation (Cell, Stack);
> Top : Stack := S;
> begin
> if Top =null then
> raise Empty_Stack_Error;
> else
> X := Top.Value;
> S := Top.Next;
> Free (Top);
> end if;
> end Pop;
>
> BTW, you don't need to keep the stack depth in its items. Do it in the
> stack object. Increment it on push and decrement on pop.
>
>>> 3. Package initialization cannot help you here, because the package
>>> declares an abstract data type of which objects can be created long
>>> after the package itself was elaborated (initialized).
>>
>> But I would like to make it clear for all that the stack is
>> empty at the start of my program!
>
> But your program starts even before package elaboration. At that point
> there is no stack at all, whether empty or not...
>
>> (also after that I may
>> change the implementation).
>
> Any implementation shall respect the stack contract, and see above...
>
>>> How are you going to maintain this? Do you want to prevent messages from
>>> being copied? Then you should reconsider the design of messages allowing
>>> their queuing without stacks. Alternatively, do you want to copy
>>> messages upon queueing (to marshal them)? Then the queue should deal
>>> with unconstrained objects:
>>>
>>> generic
>>> type Message (<>) is private;
>>> package Queue is
>>> ...
>>
>> I want to "stack away" messages to be processed later.
>> Copied, deleted etc.
>
> That does not define what happens with the message object. Do you stack
> *the* message or *a* copy/equivalent/digest of?
>
^ permalink raw reply [relevance 0%]
* Re: Question on initialization of packages
@ 2008-06-17 10:26 6% ` Dmitry A. Kazakov
2008-06-17 12:03 0% ` Reinert Korsnes
0 siblings, 1 reply; 200+ results
From: Dmitry A. Kazakov @ 2008-06-17 10:26 UTC (permalink / raw)
On Tue, 17 Jun 2008 11:14:59 +0200, Reinert Korsnes wrote:
> Dmitry A. Kazakov wrote:
>
>> On Tue, 17 Jun 2008 10:07:43 +0200, Reinert Korsnes wrote:
>>
>>> Question: How can I be sure that "Send_Stack" is empty
>>> at the start of the program execution ?
>>
>> Hmm, "sure" in which sense? To make it visible for the reader? To specify
>> in the contract of Stack that it is initially empty?
>
> Yes, yes, to make it visible for the reader.
I.e. you want to allow initially non-empty stacks? This does not look like
a good idea.
Anyway, if stack is non-limited, you could do something like
type Stack (<>) is private;
-- The box <> enforces object's initialization
Empty : constant Stack; -- Initial value of an empty stack
...
private
...
Empty : constant Stack := null;
then the user will be forced to do:
Send_Stack : Stack := Empty;
However, I see no reason to have stack copyable in the first line.
>> As for implementation you posted, the stack is empty, because instances of
>> access types are initialized with null (when not explicitly initialized
>
> Yes, but I do not like things depend on the particular implementation :-)
But this particular implementation fulfills the stack contract, which reads
"stack is initially empty." I see no problem here.
>>> procedure Pop(S: in out Stack; X: out Item) is
>>> begin
>>> X := S.Value;
>>> S := S.Next;
>>> end;
>>
>> This is a memory leak. If you allocated a stack element on push, you
>> should free it on pop.
>
> How I free it? I may not have a deep enough understanding here :-)
Per a call to instantiated Ada.Unchecked_Deallocation.
procedure Pop (S: in out Stack; X: out Item) is
procedure Free is new Ada.Unchecked_Deallocation (Cell, Stack);
Top : Stack := S;
begin
if Top =null then
raise Empty_Stack_Error;
else
X := Top.Value;
S := Top.Next;
Free (Top);
end if;
end Pop;
BTW, you don't need to keep the stack depth in its items. Do it in the
stack object. Increment it on push and decrement on pop.
>> 3. Package initialization cannot help you here, because the package
>> declares an abstract data type of which objects can be created long after
>> the package itself was elaborated (initialized).
>
> But I would like to make it clear for all that the stack is
> empty at the start of my program!
But your program starts even before package elaboration. At that point
there is no stack at all, whether empty or not...
> (also after that I may
> change the implementation).
Any implementation shall respect the stack contract, and see above...
>> How are you going to maintain this? Do you want to prevent messages from
>> being copied? Then you should reconsider the design of messages allowing
>> their queuing without stacks. Alternatively, do you want to copy messages
>> upon queueing (to marshal them)? Then the queue should deal with
>> unconstrained objects:
>>
>> generic
>> type Message (<>) is private;
>> package Queue is
>> ...
>
> I want to "stack away" messages to be processed later.
> Copied, deleted etc.
That does not define what happens with the message object. Do you stack
*the* message or *a* copy/equivalent/digest of?
--
Regards,
Dmitry A. Kazakov
http://www.dmitry-kazakov.de
^ permalink raw reply [relevance 6%]
* Re: Question on initialization of packages
@ 2008-06-17 10:18 5% ` christoph.grein
1 sibling, 0 replies; 200+ results
From: christoph.grein @ 2008-06-17 10:18 UTC (permalink / raw)
On 17 Jun., 10:50, "Dmitry A. Kazakov" <mail...@dmitry-kazakov.de>
wrote:
> As for implementation you posted, the stack is empty, because instances of
> access types are initialized with null (when not explicitly initialized
> otherwise). Below you declare:
>
> > type Stack is access Cell;
>
> And
>
> Send_Stack : Message_Stack_p.Stack; -- This will be null = empty
But N is undefined, so you have an empty stack with an undefined
number of elements.
There is no way to make it visible to users that the stack is empty
after declaration of a stack object if you hide the implementation.
You must state this as a comment; this belongs to the contract of the
ADT and you must implement it fulfilling the contract:
private
type Cell;
type Stack is access Cell;
type Cell is record
Next : Stack;
N : Integer := 0; -- better use Natural here, or will you ever
have a negative number of elements?
Value: Item;
end record;
end Stacks;
Your stack should be limited private - or do you want to copy stack
objects? Then you must be careful that deep copies are made. With this
design, you have no control over copying. A copy of a stack will be a
shallow copy.
For freeing cells, see Ada.Unchecked_Deallocation.
^ permalink raw reply [relevance 5%]
* Re: Robert Dewar's great article about the Strengths of Ada over other langauges in multiprocessing!
@ 2008-03-09 14:41 5% ` Vadim Godunko
0 siblings, 0 replies; 200+ results
From: Vadim Godunko @ 2008-03-09 14:41 UTC (permalink / raw)
On Mar 9, 4:37 pm, "Dmitry A. Kazakov" <mail...@dmitry-kazakov.de>
wrote:
>
> It is unclear in which the context you are using protected objects. I don't
> see why a protected object should be slower than, say, critical section +
> operation.
>
I have attach all source code. Protected object used for atomic
reference counting (The design may be looks strange, I just have plans
to replace protected object by the inline assembler code). C++ class
used inline assembler for the same. Both C++ class and Ada tagged type
share internal string data.
> > for J in 1 .. 1_000 loop
> > if J mod 2 = 1 then
> > B := A;
>
> Is this a deep copy?
No.
> What is controlled, array, elements, both?
Array's elements are controlled.
> What is the locking policy, per container, per element, both?
Per element.
------->-8--------
private with Ada.Finalization;
private with League.Internals.Atomics;
package League.Strings is
pragma Preelaborate;
type Universal_String is tagged private;
function To_Universal_String (Item : in Wide_Wide_String)
return Universal_String;
function To_Wide_Wide_String (Self : in Universal_String'Class)
return Wide_Wide_String;
function "=" (Left : in Universal_String;
Right : in Universal_String)
return Boolean;
private
type Utf16_String is new Wide_String;
type Utf16_String_Access is access all Utf16_String;
type Private_Data is record
Counter : aliased League.Internals.Atomics.Counter;
String : Utf16_String_Access;
Last : Natural := 0;
Length : Natural := 0;
end record;
type Private_Data_Access is access all Private_Data;
Empty_String : aliased Utf16_String := "";
Shared_Empty : aliased Private_Data
:= (String => Empty_String'Access,
others => <>);
type Universal_String is new Ada.Finalization.Controlled with
record
Data : Private_Data_Access := Shared_Empty'Access;
end record;
overriding
procedure Initialize (Self : in out Universal_String);
overriding
procedure Adjust (Self : in out Universal_String);
overriding
procedure Finalize (Self : in out Universal_String);
end League.Strings;
with Ada.Unchecked_Deallocation;
package body League.Strings is
Surrogate_First : constant := 16#D800#;
High_Surrogate_First : constant := 16#D800#;
High_Surrogate_Last : constant := 16#DBFF#;
Low_Surrogate_First : constant := 16#DC00#;
Low_Surrogate_Last : constant := 16#DFFF#;
Surrogate_Last : constant := 16#DFFF#;
subtype Surrogate_Wide_Character is Wide_Character
range Wide_Character'Val (Surrogate_First)
.. Wide_Character'Val (Surrogate_Last);
subtype High_Surrogate_Wide_Character is Surrogate_Wide_Character
range Wide_Character'Val (High_Surrogate_First)
.. Wide_Character'Val (High_Surrogate_Last);
subtype Low_Surrogate_Wide_Character is Surrogate_Wide_Character
range Wide_Character'Val (Low_Surrogate_First)
.. Wide_Character'Val (Low_Surrogate_Last);
procedure Free is
new Ada.Unchecked_Deallocation (Private_Data,
Private_Data_Access);
procedure Free is
new Ada.Unchecked_Deallocation (Utf16_String,
Utf16_String_Access);
function "=" (Left : in Universal_String;
Right : in Universal_String)
return Boolean
is
begin
raise Program_Error;
return False;
end "=";
overriding
procedure Adjust (Self : in out Universal_String) is
begin
League.Internals.Atomics.Increment (Self.Data.Counter'Access);
end Adjust;
overriding
procedure Finalize (Self : in out Universal_String) is
begin
if League.Internals.Atomics.Decrement (Self.Data.Counter'Access)
then
pragma Assert (Self.Data /= Shared_Empty'Access);
Free (Self.Data.String);
Free (Self.Data);
end if;
end Finalize;
overriding
procedure Initialize (Self : in out Universal_String) is
begin
League.Internals.Atomics.Increment (Self.Data.Counter'Access);
end Initialize;
function To_Universal_String (Item : in Wide_Wide_String)
return Universal_String
is
Aux : Utf16_String_Access
:= new Utf16_String (1 .. Item'Length * 2);
-- Reserve memory in assumption of all character will be
encoded as
-- surrogate pair.
Last : Natural := 0;
begin
for J in Item'Range loop
if Item (J) > Wide_Wide_Character'Val (Code_Point'Last)
or else Item (J) in Wide_Wide_Character'Val
(Surrogate_First)
.. Wide_Wide_Character'Val
(Surrogate_Last)
then
raise Constraint_Error
with "Wide_Wide_Character is not a valid Unicode code
point";
end if;
declare
C : constant Code_Point
:= Wide_Wide_Character'Pos (Item (J));
begin
if C <= 16#FFFF# then
Last := Last + 1;
Aux (Last) := Wide_Character'Val (C);
else
Last := Last + 1;
Aux (Last) :=
Wide_Character'Val (High_Surrogate_First + C /
16#400#);
Last := Last + 1;
Aux (Last) :=
Wide_Character'Val (Low_Surrogate_First + C mod
16#400#);
end if;
end;
end loop;
return
(Ada.Finalization.Controlled with
Data =>
new Private_Data'
(Counter => League.Internals.Atomics.One,
String => Aux,
Last => Last,
Length => Item'Length));
exception
when others =>
Free (Aux);
raise;
end To_Universal_String;
function To_Wide_Wide_String (Self : in Universal_String'Class)
return Wide_Wide_String
is
Current : Positive := 1;
begin
return Result : Wide_Wide_String (1 .. Self.Data.Length) do
for J in Result'Range loop
if Self.Data.String (Current) in Surrogate_Wide_Character
then
if Current < Self.Data.Last
and then Self.Data.String (Current)
in High_Surrogate_Wide_Character
and then Self.Data.String (Current + 1)
in Low_Surrogate_Wide_Character
then
Result (J) :=
Wide_Wide_Character'Val
((Wide_Character'Pos (Self.Data.String (Current))
- High_Surrogate_First) * 16#400#
+ (Wide_Character'Pos
(Self.Data.String (Current + 1))
- Low_Surrogate_First)
+ 16#1_0000#);
Current := Current + 2;
else
raise Constraint_Error
with "Ill-formed UTF-16 string: invalid surrogate
pair";
end if;
else
Result (J) :=
Wide_Wide_Character'Val
(Wide_Character'Pos (Self.Data.String (Current)));
Current := Current + 1;
end if;
end loop;
pragma Assert (Current = Self.Data.Last + 1);
end return;
end To_Wide_Wide_String;
end League.Strings;
private with Interfaces.C;
package League.Internals.Atomics is
pragma Preelaborate;
type Counter is private;
Zero : constant Counter;
One : constant Counter;
procedure Increment (Self : not null access Counter);
-- Atomicaly increment counter value.
function Decrement (Self : not null access Counter)
return Boolean;
-- Atomicaly decrement counter value. Returns True if counter has
zero
-- value after decrement.
private
type Counter is record
Value : Interfaces.C.int := 1;
end record;
Zero : constant Counter := (Value => 0);
One : constant Counter := (Value => 1);
end League.Internals.Atomics;
------------------------------------------------------------------------------
-- This is portable version of the package.
------------------------------------------------------------------------------
package body League.Internals.Atomics is
protected Guard is
procedure Increment (Self : not null access Counter);
procedure Decrement (Self : not null access Counter;
Zero : out Boolean);
end Guard;
function Decrement (Self : not null access Counter)
return Boolean
is
Aux : Boolean;
begin
Guard.Decrement (Self, Aux);
return Aux;
end Decrement;
protected body Guard is
procedure Decrement (Self : not null access Counter;
Zero : out Boolean)
is
use type Interfaces.C.int;
begin
Self.Value := Self.Value - 1;
Zero := Self.Value = 0;
end Decrement;
procedure Increment (Self : not null access Counter) is
use type Interfaces.C.int;
begin
Self.Value := Self.Value + 1;
end Increment;
end Guard;
procedure Increment (Self : not null access Counter) is
begin
Guard.Increment (Self);
end Increment;
end League.Internals.Atomics;
package League.Internals is
pragma Pure;
end League.Internals;
package League is
pragma Pure;
type Code_Point is mod 16#11_0000#;
for Code_Point'Size use 32;
end League;
^ permalink raw reply [relevance 5%]
* Re: Bug in Ada (SuSe 10.2) ?
2008-02-22 19:21 7% ` Georg Bauhaus
2008-02-22 21:29 0% ` Vadim Godunko
@ 2008-02-23 10:16 0% ` billjones6789
1 sibling, 0 replies; 200+ results
From: billjones6789 @ 2008-02-23 10:16 UTC (permalink / raw)
On Feb 22, 11:21 am, Georg Bauhaus <rm.plus-
bug.t...@maps.futureapps.de> wrote:
> On Fri, 2008-02-22 at 08:10 -0800, billjones6...@yahoo.com wrote:
> > Of course, the danger is only eliminated when this language-defined
> > check is fully implemented in standard mode.
>
> Here is another dangling pointer. The program is
> giving me results varying with compiler/OS. I didn't see
> how accessiblity checks could help in this case, but
> then maybe this is a different issue?
>
> with Ada.Unchecked_Deallocation;
> with Ada.Text_IO;
>
> procedure News3 is
> use Ada;
>
> type Int_Ptr is access Integer;
> Pointer: Int_Ptr;
> Dangling_Pointer: Int_Ptr;
>
> procedure Copy(Source: in out Int_Ptr; Target: out Int_Ptr) is
> procedure Oops is new Unchecked_Deallocation
> (Integer, Int_Ptr);
> begin
> Target := Source;
> Oops(Source);
> end Copy;
>
> begin
> Pointer := new Integer'(42);
> Copy(Pointer, Dangling_Pointer);
>
> Text_IO.Put_Line(Integer'image(Dangling_Pointer.all));
> end News3;
Yes, this is a different issue, and accessibility checks
unfortunately don't help in this case. The checks work for
pointers into the stack (objects declared inside subprograms
where 'access is used), not objects allocated on the heap
(where allocators (new) are used).
There are various methods available to detect such errors,
such as using the valgrind tool or special debug storage pools.
^ permalink raw reply [relevance 0%]
* Re: Bug in Ada (SuSe 10.2) ?
2008-02-22 21:29 0% ` Vadim Godunko
@ 2008-02-22 21:39 0% ` Robert A Duff
0 siblings, 0 replies; 200+ results
From: Robert A Duff @ 2008-02-22 21:39 UTC (permalink / raw)
Vadim Godunko <vgodunko@gmail.com> writes:
> On 22 яПНяПНяПН, 22:21, Georg Bauhaus <rm.plus-bug.t...@maps.futureapps.de>
> wrote:
>> On Fri, 2008-02-22 at 08:10 -0800, billjones6...@yahoo.com wrote:
>> > Of course, the danger is only eliminated when this language-defined
>> > check is fully implemented in standard mode.
>>
>> Here is another dangling pointer. The program is
>> giving me results varying with compiler/OS. I didn't see
>> how accessiblity checks could help in this case, but
>> then maybe this is a different issue?
>>
>> with Ada.Unchecked_Deallocation;
>> with Ada.Text_IO;
>>
>> procedure News3 is
>> use Ada;
>>
>> type Int_Ptr is access Integer;
>> Pointer: Int_Ptr;
>> Dangling_Pointer: Int_Ptr;
>>
>> procedure Copy(Source: in out Int_Ptr; Target: out Int_Ptr) is
>> procedure Oops is new Unchecked_Deallocation
>> (Integer, Int_Ptr);
>> begin
>> Target := Source;
>> Oops(Source);
>> end Copy;
>>
>> begin
>> Pointer := new Integer'(42);
>> Copy(Pointer, Dangling_Pointer);
>>
>> Text_IO.Put_Line(Integer'image(Dangling_Pointer.all));
>> end News3;
>
> Unchecked_Deallocation never makes program less erroneous. In the
> example it is safe to remove instantiation of Unchecked_Deallocation.
> Allocated memory will be automatically reclaimed after control flow
> leave News3 subprogram, independent does or doesn't it is a main
> subprogram.
An implementation is allowed to do such reclamation, but most do not,
unless you add a Storage_Size or Storage_Pool clause.
- Bob
^ permalink raw reply [relevance 0%]
* Re: Bug in Ada (SuSe 10.2) ?
2008-02-22 19:21 7% ` Georg Bauhaus
@ 2008-02-22 21:29 0% ` Vadim Godunko
2008-02-22 21:39 0% ` Robert A Duff
2008-02-23 10:16 0% ` billjones6789
1 sibling, 1 reply; 200+ results
From: Vadim Godunko @ 2008-02-22 21:29 UTC (permalink / raw)
On 22 фев, 22:21, Georg Bauhaus <rm.plus-bug.t...@maps.futureapps.de>
wrote:
> On Fri, 2008-02-22 at 08:10 -0800, billjones6...@yahoo.com wrote:
> > Of course, the danger is only eliminated when this language-defined
> > check is fully implemented in standard mode.
>
> Here is another dangling pointer. The program is
> giving me results varying with compiler/OS. I didn't see
> how accessiblity checks could help in this case, but
> then maybe this is a different issue?
>
> with Ada.Unchecked_Deallocation;
> with Ada.Text_IO;
>
> procedure News3 is
> use Ada;
>
> type Int_Ptr is access Integer;
> Pointer: Int_Ptr;
> Dangling_Pointer: Int_Ptr;
>
> procedure Copy(Source: in out Int_Ptr; Target: out Int_Ptr) is
> procedure Oops is new Unchecked_Deallocation
> (Integer, Int_Ptr);
> begin
> Target := Source;
> Oops(Source);
> end Copy;
>
> begin
> Pointer := new Integer'(42);
> Copy(Pointer, Dangling_Pointer);
>
> Text_IO.Put_Line(Integer'image(Dangling_Pointer.all));
> end News3;
Unchecked_Deallocation never makes program less erroneous. In the
example it is safe to remove instantiation of Unchecked_Deallocation.
Allocated memory will be automatically reclaimed after control flow
leave News3 subprogram, independent does or doesn't it is a main
subprogram.
^ permalink raw reply [relevance 0%]
* Re: Bug in Ada (SuSe 10.2) ?
@ 2008-02-22 19:21 7% ` Georg Bauhaus
2008-02-22 21:29 0% ` Vadim Godunko
2008-02-23 10:16 0% ` billjones6789
0 siblings, 2 replies; 200+ results
From: Georg Bauhaus @ 2008-02-22 19:21 UTC (permalink / raw)
On Fri, 2008-02-22 at 08:10 -0800, billjones6789@yahoo.com wrote:
> Of course, the danger is only eliminated when this language-defined
> check is fully implemented in standard mode.
Here is another dangling pointer. The program is
giving me results varying with compiler/OS. I didn't see
how accessiblity checks could help in this case, but
then maybe this is a different issue?
with Ada.Unchecked_Deallocation;
with Ada.Text_IO;
procedure News3 is
use Ada;
type Int_Ptr is access Integer;
Pointer: Int_Ptr;
Dangling_Pointer: Int_Ptr;
procedure Copy(Source: in out Int_Ptr; Target: out Int_Ptr) is
procedure Oops is new Unchecked_Deallocation
(Integer, Int_Ptr);
begin
Target := Source;
Oops(Source);
end Copy;
begin
Pointer := new Integer'(42);
Copy(Pointer, Dangling_Pointer);
Text_IO.Put_Line(Integer'image(Dangling_Pointer.all));
end News3;
^ permalink raw reply [relevance 7%]
* Re: Allocators and memory reclamation
@ 2008-01-28 22:00 8% ` Aurele
0 siblings, 0 replies; 200+ results
From: Aurele @ 2008-01-28 22:00 UTC (permalink / raw)
On Jan 28, 8:49 am, Maciej Sobczak <see.my.homep...@gmail.com> wrote:
>
> procedure Foo is
> type Int_Ptr is access Integer;
> P : Int_Ptr;
> begin
> P := new Integer;
> P := new Integer;
> P := new Integer;
> end Foo;
>
> procedure Main is
> begin
> loop
> Foo;
> end loop;
> end Main;
>
To avoid memory leak, rewrite as...
with Ada.Unchecked_Deallocation;
type Int_Ptr is access Integer;
procedure Free is new Ada.Unchecked_Deallocation( Integer,
Int_Ptr );
procedure Foo is
P : Int_Ptr;
:
begin
P := new Integer;
:
Free( P );
:
end Foo;
procedure Main is
begin
loop
Foo;
end loop;
end Main;
^ permalink raw reply [relevance 8%]
* Re: Finalization of static package variables
2007-05-11 18:12 6% ` Manuel Collado
@ 2007-05-11 18:26 0% ` Robert A Duff
0 siblings, 0 replies; 200+ results
From: Robert A Duff @ 2007-05-11 18:26 UTC (permalink / raw)
Manuel Collado <m.collado@lml.ls.fi.upm.es> writes:
> But an access variable can refer to a static variable. Is the following
> Ada95 code schema legal?
It is erroneous, which is the Ada term for "wrong, and will cause
totally unpredictable behavior at run time." Most likely,
you will corrupt the heap data structures if you try to free
objects that are not heap allocated.
Note that if you erase the "Dispose", then Edit will be finalized when
program is done.
>...What about Ada200x (or just Ada, if you want)?
Same answer.
> It seems to work in GNAT-3.15p (it lets finalize 'Edit'), but ...
>
> -------------------------------------------------
> package body View_Editor is
>
> Edit: aliased Dialog_Type :=
> Dialog (420, 350, "Conversion Rates", 'Q', Main_Font);
>
> [...snipped...]
>
> procedure Editor_Destroy is
> type Dialog_Access is access all Dialog_Type;
> procedure Dispose is
> new Ada.Unchecked_Deallocation (
> Object => Dialog_Type,
> Name => Dialog_Access );
> Pointer: Dialog_Access := Edit'access;
> begin
> Dispose (Pointer);
> end Editor_Destroy;
>
> end View_Editor;
- Bob
^ permalink raw reply [relevance 0%]
* Re: Finalization of static package variables
@ 2007-05-11 18:12 6% ` Manuel Collado
2007-05-11 18:26 0% ` Robert A Duff
0 siblings, 1 reply; 200+ results
From: Manuel Collado @ 2007-05-11 18:12 UTC (permalink / raw)
Stephen Leake escribi�:
> Manuel Collado <m.collado@lml.ls.fi.upm.es> writes:
>> Stephen Leake escribi�:
>>> Manuel Collado <m.collado@lml.ls.fi.upm.es> writes:
>>> ...
>>>> But this is probably not standard-conformant (ARM 13.11.2-16).
>>> This paragraph says:
>>> Evaluating a name that denotes a nonexistent object is erroneous.
>>> The execution of a call to an instance of Unchecked_Deallocation
>>> is erroneous if the object was created other than by an allocator
>>> for an access type whose pool is Name'Storage_Pool.
>>> I don't see how that is relevant to your problem.
>> "... erroneous ... if the object was created other than by an
>> allocator for an access type whose pool is Name'Storage_Pool."
>>
>> Are static package variables allocated in this pool?
>
> static package variables are created in the heap.
>
> If they are _pointers_, the objects that they point to are allocated in
> some pool.
>
> There is a big difference between a pointer variable, and the object
> it points to.
That's what I've teached to my students for decades :-)
But an access variable can refer to a static variable. Is the following
Ada95 code schema legal? What about Ada200x (or just Ada, if you want)?
It seems to work in GNAT-3.15p (it lets finalize 'Edit'), but ...
-------------------------------------------------
package body View_Editor is
Edit: aliased Dialog_Type :=
Dialog (420, 350, "Conversion Rates", 'Q', Main_Font);
[...snipped...]
procedure Editor_Destroy is
type Dialog_Access is access all Dialog_Type;
procedure Dispose is
new Ada.Unchecked_Deallocation (
Object => Dialog_Type,
Name => Dialog_Access );
Pointer: Dialog_Access := Edit'access;
begin
Dispose (Pointer);
end Editor_Destroy;
end View_Editor;
--------------------------------------------------
Thanks.
--
Manuel Collado - http://lml.ls.fi.upm.es/~mcollado
^ permalink raw reply [relevance 6%]
* Re: Finalization of static package variables
@ 2007-05-09 22:19 6% ` Manuel Collado
0 siblings, 1 reply; 200+ results
From: Manuel Collado @ 2007-05-09 22:19 UTC (permalink / raw)
Stephen Leake escribi�:
> Manuel Collado <m.collado@lml.ls.fi.upm.es> writes:
>
>> Variables declared in the global scope of a package body seem not to
>> be finalized automatically at the end of the whole program (using GNAT
>> 3.15p on WindowsXP).
> [...]
>> After several trial-and-error attemps, an Unchecked_Deallocation on
>> these variables seems to do the trick (the whole program terminates
>> smoothly).
>
> Unchecked_Deallocation is used on access variables (aka "pointers").
> Such variables are _not_ automatically finalized by Ada; calling
> Unchecked_Deallocation is the standard-compliant way to finalize them.
>
>> But this is probably not standard-conformant (ARM 13.11.2-16).
>
> This paragraph says:
>
> Evaluating a name that denotes a nonexistent object is erroneous.
> The execution of a call to an instance of Unchecked_Deallocation
> is erroneous if the object was created other than by an allocator
> for an access type whose pool is Name'Storage_Pool.
>
> I don't see how that is relevant to your problem.
"... erroneous ... if the object was created other than by an allocator
for an access type whose pool is Name'Storage_Pool."
Are static package variables allocated in this pool?
>
> What version of the ARM are you quoting? When you say "ARM" without a
> year, it implies "current" which means "Ada 2007" (or, informally,
> "Ada 2005").
Doesn't "using GNAT 3.15p" give you any hint :-) ?
> [...]
> Posting code that outlines what you are doing would help a lot.
------------------------------------
package body Pkg_Dialog is
My_Dialog: aliased Dialog_Type := Dialog (200, 100, "Dialog 3", 'Q');
...
procedure Do_Dialog is
begin
... exercise My_Dialog ...
declare
type Dialog_Access is access all Dialog_Type;
procedure Dispose is
new Ada.Unchecked_Deallocation (
Object => Dialog_Type,
Name => Dialog_Access );
Pointer: Dialog_Access := My_Dialog'access;
begin
Dispose (Pointer); -- force My_Dialog finalization
end;
end Do_Dialog;
end Pkg_Dialog;
-----------------------------------
Regards.
--
Manuel Collado - http://lml.ls.fi.upm.es/~mcollado
^ permalink raw reply [relevance 6%]
* Re: Impossible problem? A protected buffer to queue objects of a class-wide type
2007-04-11 13:14 5% ` Dmitry A. Kazakov
@ 2007-04-13 17:02 6% ` Matthew Heaney
1 sibling, 0 replies; 200+ results
From: Matthew Heaney @ 2007-04-13 17:02 UTC (permalink / raw)
On Apr 11, 6:34 am, "Phil Slater" <phil.sla...@baesystems.com> wrote:
> I've hit a brick wall. Every strategy I try doesn't work.
Won't the code below work?
> I need to write a generic package that exports a protected queue type that
> will act as a buffer for objects of a class-wide type.
That's fine. You can declare the generic formal type as indefinite,
to make the package more general.
Note that I have used an Ada05 feature, extended return statement, to
return the class-wide object as the result of a function. Is Ada05 is
not an option for you let me know and we'll figure something else out.
> My strategy is that
> when objects join the queue they are copied onto the heap,
Yes, that's what the solution below does.
> and an
> access-to-class-wide value is put onto the queue (could be array-based or
> linked-list-based - I don't mind).
I have created an internal buffer, implemented using the doubly-linked
list standard container, instantiated with an access type as the
generic actual.
> To retrieve an item from the queue, an
> access-to-class-wide value is removed from the queue, the heap object it
> designates is copied onto the stack, the heap object is deallocated, then
> the copy is returned.
Yes, the example below does that.
> The crux of the problem goes like this:
>
> (a) for the client code to retrieve an item, it needs to call a function; it
> can't be done through a procedure or entry "out" parameter since I can't
> declare an uninitialised variable of the class-wide type to pass as an
> actual parameter. So the client code needs to do something like this:
> declare
> Next_In_Line : Item'class := My_Buffer.Dequeue; -- My_Buffer is the
> protected queue
The problem you're having is mixing layers of abstraction. The queue
type below does indeed have a Deque function, and there is a
proctected object, but the protected object itself is an
implementation detail of the queue abstract data type.
> (b) To support this call, Dequeue must be written as a function. As such, it
> cannot change the protected queue. What I need is the "entry" functionality,
> since I want the Dequeue to wait if the queue is empty, and I want the item
> to be removed from the queue as well as retrieved.
Yes, you can do that, but you need two separate steps: the first step
is to use an entry (with a barrier) to remove the front item from the
queue's internal buffer (that's the protected object part), and then
return the value you removed from the internal buffer to the caller,
via a function (that's the abstract data type part).
In the example below I have used an extended return, since the return
type is indefinite.
> I cannot see a way through this problem, and am astounded that a language of
> this calibre seems to have rules that conspire together to make it appear
> impossible. What have I missed?
Use the Source, Luke!
--STX
private with Ada.Containers.Doubly_Linked_Lists;
generic
type ET (<>) is private;
package Queues is
type QT is limited private;
function Deque (Q : not null access QT) return ET;
procedure Enque (Q : in out QT; E : ET);
private
type ET_Access is access ET;
use Ada.Containers;
package ET_Lists is new Doubly_Linked_Lists (ET_Access);
protected type BT is
entry Get (Obj : out ET_Access);
procedure Put (Obj : ET_Access);
private
L : ET_Lists.List;
end BT;
type QT is limited record
B : BT;
end record;
end Queues;
with Ada.Unchecked_Deallocation;
package body Queues is
procedure Free is new Ada.Unchecked_Deallocation (ET, ET_Access);
protected body BT is
entry Get (Obj : out ET_Access) when not L.Is_Empty is
begin
Obj := L.First_Element;
L.Delete_First;
end;
procedure Put (Obj : ET_Access) is
begin
L.Append (Obj);
end;
end BT;
function Deque (Q : not null access QT) return ET is
Obj : ET_Access;
begin
Q.B.Get (Obj);
return E : ET := Obj.all do
Free (Obj);
end return;
end Deque;
procedure Enque (Q : in out QT; E : ET) is
begin
Q.B.Put (ET_Access'(new ET'(E)));
end;
end Queues;
Regards,
Matt
^ permalink raw reply [relevance 6%]
* Re: Impossible problem? A protected buffer to queue objects of a class-wide type
@ 2007-04-11 13:14 5% ` Dmitry A. Kazakov
2007-04-13 17:02 6% ` Matthew Heaney
1 sibling, 0 replies; 200+ results
From: Dmitry A. Kazakov @ 2007-04-11 13:14 UTC (permalink / raw)
On Wed, 11 Apr 2007 12:34:15 +0100, Phil Slater wrote:
> I've hit a brick wall. Every strategy I try doesn't work.
>
> I need to write a generic package that exports a protected queue type that
> will act as a buffer for objects of a class-wide type. My strategy is that
> when objects join the queue they are copied onto the heap, and an
> access-to-class-wide value is put onto the queue (could be array-based or
> linked-list-based - I don't mind). To retrieve an item from the queue, an
> access-to-class-wide value is removed from the queue, the heap object it
> designates is copied onto the stack, the heap object is deallocated, then
> the copy is returned.
> The crux of the problem goes like this:
>
> (a) for the client code to retrieve an item, it needs to call a function; it
> can't be done through a procedure or entry "out" parameter since I can't
> declare an uninitialised variable of the class-wide type to pass as an
> actual parameter. So the client code needs to do something like this:
> declare
> Next_In_Line : Item'class := My_Buffer.Dequeue; -- My_Buffer is the
> protected queue
>
> (b) To support this call, Dequeue must be written as a function. As such, it
> cannot change the protected queue. What I need is the "entry" functionality,
> since I want the Dequeue to wait if the queue is empty, and I want the item
> to be removed from the queue as well as retrieved.
>
> (c) In a non-concurrent environment, I would simply write two separate
> operations on the queue: a function Read_Next_Item and a procedure
> Delete_Next_Item, which the client code would call in turn. However, that's
> no good in a concurrent environment - two tasks could both call
> Read_Next_Item before the first has had a chance to call Delete_Next_Item,
> so the same item is read twice and the following item is skipped.
>
> I really do want all the heap operations through the access-to-class-wide
> type to be hidden away in the package - I did consider writing a protected
> buffer with an entry whose out parameter was an access-to-class-wide type,
> but this is highly unsatisfactory as it puts the onus for deallocating heap
> space into the client code - very messy.
>
> I cannot see a way through this problem, and am astounded that a language of
> this calibre seems to have rules that conspire together to make it appear
> impossible. What have I missed?
There are many ways to solve this.
1. You can wrap My_Buffer into a normal limited type. This will allow you
to have functions returning a class-wide:
function Get_Next (Buffer : access My_Buffer_Interface)
return Item'Class;
The implementation of Get_Next will go as follows:
function Get_Next (Buffer : access My_Buffer_Interface)
return Item'Class is
procedure Free is new Ada.Unchecked_Deallocation (Item, Item_Ptr);
Ptr : Item_Ptr;
begin
Buffer.Implementation.Get_Next (Ptr);
-- Protected operation which takes pointer out of the buffer
-- Buffer.Implementation is your protected queue
declare -- In Ada 2005 it could be done better, I suppose
This : Item'Class := Ptr.all;
begin
Free (Ptr);
return This;
end;
end Get_Next;
2. You use smart pointers to Item'Class instead of the items themselves. So
you will marshal only pointers through the queue and not the objects
themselves. This would reduce overhead of item's copying upon marshaling.
Deallocation will be handled by the smart pointer. Provided that items are
not accessed concurrently you will not need to interlock on pointer
dereferencing. Additional advantage is an ability to use limited items. [An
implementation of smart pointers can be found in Simple Components.]
--
Regards,
Dmitry A. Kazakov
http://www.dmitry-kazakov.de
^ permalink raw reply [relevance 5%]
* Re: Why does this work? (overloads)
@ 2007-02-08 18:52 6% ` Jeffrey R. Carter
0 siblings, 0 replies; 200+ results
From: Jeffrey R. Carter @ 2007-02-08 18:52 UTC (permalink / raw)
Jerry wrote:
>>
> Good point. However, it uses twice the memory, and worse, changes made
> in A are not reflected in B without repeating the assignment A := B
> (correct?) and vice versa. My Pascal trick had neither of these
> problems yet carried boundary checking using either name.
Right. But your Pascal trick is an abomination. You can do the same
thing in Ada using overlays, but it's not recommended. There's probably
also a way with access types. Something like (not tested)
type Vector is array (Natural range <>) of Real;
Max : constant := ...;
subtype Zero_Based is Vector (0 .. Max - 1);
subtype One_Based is Vector (1 .. Max );
type Zero_Ptr is access all Zero_Based;
type One_Ptr is access all One_Based;
V : aliased Zero_Based;
ZP : Zero_Ptr := V'access;
function To_One is new Ada.Unchecked_Deallocation
(Source = Zero_Ptr, Target => One_Ptr);
OP : One_Ptr := To_One (ZP);
I wouldn't recommend it.
--
Jeff Carter
"What I wouldn't give for a large sock with horse manure in it."
Annie Hall
42
^ permalink raw reply [relevance 6%]
* Re: Topological Sort Help
@ 2007-02-08 18:29 5% ` isaac2004
0 siblings, 0 replies; 200+ results
From: isaac2004 @ 2007-02-08 18:29 UTC (permalink / raw)
On Feb 8, 10:24 am, Ludovic Brenta <ludo...@ludovic-brenta.org> wrote:
> You seem to have forgotten to send the specs (package X is...), you
> just sent the bodies.
>
> --
> Ludovic Brenta.
sorry even more code here it goes
here is the sec for digraphs
WITH Ada.Text_IO; USE Ada.Text_IO;
WITH Ada.Integer_Text_IO; USE Ada.Integer_Text_IO;
WITH Sets_Generic; WITH Stacks_Generic; WITH Queues_Generic;
WITH Ada.Unchecked_Deallocation;
PACKAGE Digraphs IS
SUBTYPE Vertices IS Character RANGE 'A' .. 'Z';
TYPE Digraph IS ARRAY (Vertices RANGE <>, Vertices RANGE <>) OF
Boolean;
PACKAGE Vertex_Text_IO IS NEW Enumeration_IO(Vertices);
PACKAGE Vertex_Set IS NEW Sets_Generic(Vertices); USE Vertex_Set;
PACKAGE Vertex_Stack IS NEW Stacks_Generic(Vertices); USE
Vertex_Stack;
PACKAGE Vertex_Queue IS NEW Queues_Generic(Vertices); USE
Vertex_Queue;
TYPE DigraphPointer IS ACCESS Digraph;
TYPE StackPointer IS ACCESS Stack;
-- constructor
FUNCTION CreateGraph (InputFile : String) RETURN DigraphPointer;
-- Pre: InputFile is the name of graph file to be loaded
-- Post: Returns a pointer to digraph dynamically created according
-- to the specification in InputFile
-- (see assignment description for details)
-- destructors
PROCEDURE Dispose IS NEW
Ada.Unchecked_Deallocation(Digraph,DigraphPointer);
PROCEDURE Dispose IS NEW
Ada.Unchecked_Deallocation(Stack,StackPointer);
-- Call: Dispose(X)
-- Pre: X points to a dynamically allocated digraph / stack,
respectively
-- Post: X's memory is release back to the pool
-- modifiers
PROCEDURE AddEdge (G: IN OUT Digraph; Source, Destination: IN
Vertices);
PROCEDURE DeleteEdge (G: IN OUT Digraph; Source, Destination: IN
Vertices);
-- Pre: G, Source, and Destination are defined
-- Post: returns G with the edge <Source, Destination> added or
-- deleted respectively; AddEdge has no effect if the edge is
-- already in G; DeleteEdge has no effect if the edge is not in
G
-- accessors
FUNCTION IsReflexive (G : Digraph) RETURN Boolean;
FUNCTION IsIrreflexive (G : Digraph) RETURN Boolean;
FUNCTION IsSymmetric (G : Digraph) RETURN Boolean;
FUNCTION IsAntisymmetric (G : Digraph) RETURN Boolean;
FUNCTION IsTransitive (G : Digraph) RETURN Boolean;
FUNCTION IsConnected (G : Digraph) RETURN Boolean;
FUNCTION IsStronglyConnected (G : Digraph) RETURN Boolean;
FUNCTION HasCycle(G : Digraph) RETURN Boolean;
-- Pre: G is defined
-- Post: returns True iff G has the property
PROCEDURE DFS_SpanningTree (G : IN Digraph; StartNode : IN Vertices;
D : OUT DigraphPointer; Visited : OUT Set);
PROCEDURE BFS_SpanningTree (G : IN Digraph; StartNode : IN Vertices;
B : OUT DigraphPointer; Visited : OUT Set);
-- Pre: G, V are defined
-- Post: Allocates a new digraph that holds the depth/breadth-first
-- search minimum spanning trees, respectively, returning a
pointer in D/B
-- Returns the (sub)set of vertices present in this digraph in
Visited
PROCEDURE Topological_Sort (G: IN Digraph; Result : OUT StackPointer;
HasCycle : OUT Boolean);
-- Pre: G is defined
-- Post: Either
-- a) finds a directed cycle, and sets HasCycle to True or
-- b) topologically sorts the vertices of G, storing them in a
-- stack such that nodes will be popped in sorted order
-- the "first" or "smallest" unordered node must come first (e.g. C
before E)
-- (see assignment description for details)
-- actions
PROCEDURE DisplayGraph (G: Digraph; Present : Set := -Phi );
-- Pre: G is defined, Set optionally defined
-- Post: displays G in matrix form using T or F
-- for presence or absence of edge
-- for all vertices in Set (allows you to print subgraphs)
-- by default, Set is all vertices (complement of empty set)
-- and so the entire graph is printed
END Digraphs;
spec for stacks_generic
GENERIC
TYPE Element IS PRIVATE;
PACKAGE Stacks_Generic IS
--------------------------------------------------------------------------------
--| Specification for Generic Stacks Package, Array Implementation
--| Author: Micahel B. Feldman, The George Washington University
--| Last Modified: October 1995
--------------------------------------------------------------------------------
-- type definition
TYPE Stack (Capacity : Positive) IS LIMITED PRIVATE;
-- exported exceptions
StackFull : EXCEPTION;
StackEmpty : EXCEPTION;
PROCEDURE MakeEmpty (S : IN OUT Stack);
-- Pre: S is defined
-- Post: S is empty
PROCEDURE Push (S : IN OUT Stack; E : IN Element);
-- Pre: S and E are defined
-- Post: S is returned with E as the top element
-- Raises: StackFull if S already contains Capacity elements
PROCEDURE Pop (S : IN OUT Stack );
-- Pre: S is defined
-- Post: S is returned with the top element discarded
-- Raises: StackEmpty if S contains no elements
-- selector
FUNCTION Top (S : IN Stack) RETURN Element;
-- Pre: S is defined
-- Post: The top element of S is returned
-- Raises: StackEmpty if S contains no elements
-- inquiry operations
FUNCTION IsEmpty ( S : IN Stack) RETURN Boolean;
-- Pre: S is defined
-- Post: returns True if S is empty, False otherwise
FUNCTION IsFull ( S : IN Stack) RETURN Boolean;
-- Pre: S is defined
-- Post: returns True if S is full, False otherwise
PRIVATE
TYPE List IS ARRAY (Positive RANGE <>) OF Element;
TYPE Stack (Capacity : Positive) IS RECORD
Latest : Natural := 0;
Store : List(1 .. Capacity);
END RECORD;
END Stacks_Generic;
spec for sets_generic
GENERIC
TYPE Universe IS (<>); -- discrete type
PACKAGE Sets_Generic IS
--------------------------------------------------------------------------------
--| Specification for sets over discrete universes
--| Author: Micahel B. Feldman, The George Washington University
--| Last Modified: October 1995
--------------------------------------------------------------------------------
TYPE Set is PRIVATE;
Phi: CONSTANT Set; -- empty set
-- constructors
FUNCTION "+" (S: Set; E: Universe) RETURN Set;
FUNCTION "-" (S: Set; E: Universe) RETURN Set;
-- Pre: S and E are defined
-- Post: returns S with E inserted or deleted respectively
FUNCTION Singleton (E: Universe) RETURN Set;
FUNCTION "+" (E1, E2: Universe) RETURN Set;
-- Pre: E, E1, and E2 are defined
-- Post: returns a set made from one or two elements
FUNCTION "+" (S, T: Set) RETURN Set;
FUNCTION "*" (S, T: Set) RETURN Set;
FUNCTION "-" (S, T: Set) RETURN Set;
-- Pre: S and T are defined
-- Post: Returns the union, intersection and difference of
-- S and T, respectively
FUNCTION "-" (S : Set) RETURN Set;
-- Pre: S is defined
-- Post: returns the complement of S
-- selectors
FUNCTION IsIn (S: Set; E: Universe) RETURN Boolean;
-- Pre: S and E are defined
-- Post: returns True iff E is a member of S
FUNCTION IsEmpty (S: Set) RETURN Boolean;
-- Pre: S is defined
-- Post: returns True iff S is empty
FUNCTION SizeOf (S: Set) RETURN Natural;
-- Pre: S is defined
-- Post: returns the number of members in S
FUNCTION "<=" (S, T: Set) RETURN Boolean;
FUNCTION "<" (S, T: Set) RETURN Boolean;
-- Pre: S and T are defined
-- Post: returns True iff if S is
-- an improper or proper subset of T, respectively
PRIVATE
TYPE SetArray IS ARRAY (Universe) OF Boolean;
TYPE Set IS RECORD
Store: SetArray := (OTHERS => False);
END RECORD;
Phi: CONSTANT Set := (Store => (OTHERS => False));
END Sets_Generic;
if there is anyhting else you need, please tell me
^ permalink raw reply [relevance 5%]
* Re: in defense of GC (was Re: How come Ada isn't more popular?)
2007-02-02 21:50 5% ` Gautier
@ 2007-02-04 8:19 0% ` Ray Blaak
0 siblings, 0 replies; 200+ results
From: Ray Blaak @ 2007-02-04 8:19 UTC (permalink / raw)
Gautier <gautier@fakeaddress.nil> writes:
> Sorry for my ignorance in this field, but from a real household point of view,
> it seems to me that there is a big difference between
> (1) "stop using an object"
> and
> (2) "drop an object on the floor".
>
> In case of (1), I would hate that my object is taken from the table and thrown
> away by my garbage collecting robot GeeCee. Hey, does he know I really won't
> use my object anymore ?! In the case (2), it's OK that GeeCee takes it away,
> but then there is an action (Drop_on_the_floor) and I can do it in Ada
> (procedure Drop_on_the_floor_and_even_directly_throw_away is new
> Ada.Unchecked_Deallocation).
I was not sure if this was serious or not, so if it was...
Regarding (1), if you are not sure you will use an object anymore, then the GC
will not collect it, *by definition*, since it must be still reachable in some
way in order for it to be even possible to use. GC only collects unreachable
memory.
Regarding (2), doing a matching "drop" for every "new" is the whole trouble,
of course. What if you miss one? Well, with GC, you don't (need to) do an
explicit "drop" at all. And that's the freedom.
Now nothing is completely perfect and free. You can still have memory leaks
with GC, of course, but they are of a different kind. Instead of a lost
pointer that still refers to allocated memory, one has live objects still
being referred to in some way, i.e., "not lost" pointers that one no longer
needs to refer to.
So, the most one needs to do is to clear a pointer/reference occasionally.
Note though, that this is far far simpler than, for example, carefully
deallocating each node of some long lived complex data structure, cycles and
all. Instead one simply clears the reference to the root of entire complex
structure, and it all just goes away.
In the case of stacked based references (which are the most common kind),
there is nothing do to. New objects are made, maybe returned out to the
caller, maybe not, without regard to destruction, copy construction, etc. It
just is no longer necessary.
--
Cheers, The Rhythm is around me,
The Rhythm has control.
Ray Blaak The Rhythm is inside me,
rAYblaaK@STRIPCAPStelus.net The Rhythm has my soul.
^ permalink raw reply [relevance 0%]
* Re: in defense of GC (was Re: How come Ada isn't more popular?)
@ 2007-02-02 21:50 5% ` Gautier
2007-02-04 8:19 0% ` Ray Blaak
0 siblings, 1 reply; 200+ results
From: Gautier @ 2007-02-02 21:50 UTC (permalink / raw)
Ray Blaak:
> It is only sloppy programming in the context of manual clean up. With a valid
> GC you do not have to clean up at all. One simply stops using objects when
> they no longer need them, just "dropping them on the floor", leaving it up to
> the GC to eventually collect it.
Sorry for my ignorance in this field, but from a real household point of view,
it seems to me that there is a big difference between
(1) "stop using an object"
and
(2) "drop an object on the floor".
In case of (1), I would hate that my object is taken from the table and thrown
away by my garbage collecting robot GeeCee. Hey, does he know I really won't
use my object anymore ?! In the case (2), it's OK that GeeCee takes it away,
but then there is an action (Drop_on_the_floor) and I can do it in Ada
(procedure Drop_on_the_floor_and_even_directly_throw_away is new
Ada.Unchecked_Deallocation).
Thanks for an explanation...
______________________________________________________________
Gautier -- http://www.mysunrise.ch/users/gdm/index.htm
Ada programming -- http://www.mysunrise.ch/users/gdm/gsoft.htm
NB: For a direct answer, e-mail address on the Web site!
^ permalink raw reply [relevance 5%]
* Re: Deallocating list of polymorphic objects?
2006-11-30 23:40 7% Deallocating list of polymorphic objects? Michael Rohan
@ 2006-12-01 1:24 6% ` Randy Brukardt
0 siblings, 0 replies; 200+ results
From: Randy Brukardt @ 2006-12-01 1:24 UTC (permalink / raw)
"Michael Rohan" <mrohan@ACM.ORG> wrote in message
news:1164930027.758923.119740@h54g2000cwb.googlegroups.com...
...
> I would like to construct a list of polymorphic objects that,
> as part of the list's finalization, deallocates the objects on
> the list. Basically, I have a vector of pointers to Object'Class.
> The objects are added to the list via procedures defined for
> the list, e.g., append an integer, append a floating point.
> These append procedures allocate objects derived from the
> base Object type for the type being appended, e.g.,
> Integer_Object, which is private to the list package.
>
> Since I want the deallocation to be dispatching, it needs to take an
> access parameter which is then converted to a pointer for the object
> being deallocated, e.g., an Integer_Pointer, and then passed to an
> Unchecked_Deallocation procedure.
To deallocate the elements, then just doing it should work fine:
procedure Free is new Ada.Unchecked_Deallocation (Object'Class,
Object_Pointer);
Unchecked_Deallocation of the Objects will call Finalize on them, so that
any internal cleanup can be done. (That's presuming that Object is also
derived from Controlled, but IMHO that should be true of virtually all
complex types in new Ada code. Remember that Object can still be abstract
even if derived.) You could also uses a separate "Ready-me-for-Deallocation"
dispatching routine, but that is neither as safe nor fool-proof as just
letting Ada do it: there are special rules in the language that insure that
Finalize is always called at least once.
The important thing here is that (using the terminology of the Ada 2007
predefined containers) the container is responsible for deallocating the
elements as a whole, but any internal cleanup is the responsibility of the
elements themselves. It's not possible (in general) to have objects that
deallocate themselves -- but that's actually a good thing: an object should
be responsible for cleaning its contents up, but only the client can know
how that object is going to be used, and thus how the memory should be
deallocated. Otherwise you have unnecessary coupling between the object and
its clients: the object type cannot be reliably used to declare objects on
the stack (or in the predefined containers, or anywhere that non-standard
storage pools are used, etc.).
Summary: The objects and the list are separate abstractions and should be
kept separate. The list should allocate and deallocation elements (objects);
the objects themselves should do any internal cleanup needed.
Randy Brukardt.
^ permalink raw reply [relevance 6%]
* Deallocating list of polymorphic objects?
@ 2006-11-30 23:40 7% Michael Rohan
2006-12-01 1:24 6% ` Randy Brukardt
0 siblings, 1 reply; 200+ results
From: Michael Rohan @ 2006-11-30 23:40 UTC (permalink / raw)
Hi Folks,
I would like to construct a list of polymorphic objects that,
as part of the list's finalization, deallocates the objects on
the list. Basically, I have a vector of pointers to Object'Class.
The objects are added to the list via procedures defined for
the list, e.g., append an integer, append a floating point.
These append procedures allocate objects derived from the
base Object type for the type being appended, e.g.,
Integer_Object, which is private to the list package.
Since I want the deallocation to be dispatching, it needs to take an
access parameter which is then converted to a pointer for the object
being deallocated, e.g., an Integer_Pointer, and then passed to an
Unchecked_Deallocation procedure.
The code below (formatted to minimize the size of this posting) does
what I expect:
$ gnatmake -gnat05 list_test
gcc -c -gnat05 list_test.adb
gcc -c -gnat05 lists.adb
gnatbind -x list_test.ali
gnatlink list_test.ali
$ ./list_test
Finalizing a list
Integer object: 1
Float object: -1.00000E+00
Integer object: 2
Float object: -2.00000E+00
However, I have a feeling there is something "bad" about this type of
deallocation, probably related to storage pool but I'm not familiar
enough with storage pools to be sure.
Would anyone care to comment on how safe/unsafe this deallocation
scheme is?
Take care,
Michael
---
list_test.adb
---------------------------------------------------------------------------
with Lists;
procedure List_Test is
L : Lists.List_Type;
begin
Lists.Append (L, 1);
Lists.Append (L, -1.0);
Lists.Append (L, 2);
Lists.Append (L, -2.0);
end List_Test;
---
lists.ads
---------------------------------------------------------------------------
with Ada.Finalization;
with Ada.Containers.Vectors;
package Lists is
type List_Type is limited private;
procedure Append (L : in out List_Type; I : Integer);
procedure Append (L : in out List_Type; F : Float);
private
type Object is abstract tagged null record;
type Object_Pointer is access all Object'Class;
procedure Print (Pointer : access Object) is abstract;
procedure Deallocate (Pointer : access Object) is abstract;
package List_Vector_Package is
new Ada.Containers.Vectors (Index_Type => Natural,
Element_Type => Object_Pointer);
type List_Type is new Ada.Finalization.Limited_Controlled with
record
Contents : List_Vector_Package.Vector;
end record;
overriding procedure Finalize (L : in out List_Type);
end Lists;
---
lists.adb
---------------------------------------------------------------------------
with Ada.Text_IO;
with Ada.Unchecked_Deallocation;
package body Lists is
use Ada.Containers;
use List_Vector_Package;
package Integer_Objects is
type Integer_Object is new Object with record
I : Integer;
end record;
overriding procedure Print (Pointer : access Integer_Object);
overriding procedure Deallocate (Pointer : access
Integer_Object);
end Integer_Objects;
package Float_Objects is
type Float_Object is new Object with record
F : Float;
end record;
overriding procedure Print (Pointer : access Float_Object);
overriding procedure Deallocate (Pointer : access Float_Object);
end Float_Objects;
use Float_Objects;
use Integer_Objects;
package body Integer_Objects is
type Integer_Pointer is access all Integer_Object;
procedure Free is
new Ada.Unchecked_Deallocation (Integer_Object,
Integer_Pointer);
procedure Print (Pointer : access Integer_Object) is
begin
Ada.Text_IO.Put_Line ("Integer object: " & Pointer.I'Img);
end Print;
procedure Deallocate (Pointer : access Integer_Object) is
I_Pointer : Integer_Pointer := Integer_Pointer (Pointer);
begin
Print (Pointer);
Free (I_Pointer);
end Deallocate;
end Integer_Objects;
package body Float_Objects is
type Float_Pointer is access all Float_Object;
procedure Free is
new Ada.Unchecked_Deallocation (Float_Object, Float_Pointer);
procedure Print (Pointer : access Float_Object) is
begin
Ada.Text_IO.Put_Line ("Float object: " & Pointer.F'Img);
end Print;
procedure Deallocate (Pointer : access Float_Object) is
I_Pointer : Float_Pointer := Float_Pointer (Pointer);
begin
Print (Pointer);
Free (I_Pointer);
end Deallocate;
end Float_Objects;
procedure Append (L : in out List_Type; I : Integer) is
begin
Append (L.Contents, new Integer_Object'(I => I));
end Append;
procedure Append (L : in out List_Type; F : Float) is
begin
Append (L.Contents, new Float_Object'(F => F));
end Append;
procedure Finalize (L : in out List_Type) is
Pointer : Object_Pointer;
begin
Ada.Text_IO.Put_Line ("Finalizing a list");
if L.Contents.Length > 0 then
for I in 0 .. Integer (L.Contents.Length - 1) loop
Pointer := Element (L.Contents, I);
Deallocate (Pointer);
end loop;
end if;
end Finalize;
end Lists;
^ permalink raw reply [relevance 7%]
* Re: Finalization
2006-11-21 9:02 6% ` Finalization Philippe Tarroux
@ 2006-11-21 9:22 0% ` Dmitry A. Kazakov
0 siblings, 0 replies; 200+ results
From: Dmitry A. Kazakov @ 2006-11-21 9:22 UTC (permalink / raw)
On Tue, 21 Nov 2006 10:02:35 +0100, Philippe Tarroux wrote:
> I have a problem trying to use controlled types. My purpose was to use
> finalize to deallocate a big data structure each time a reuse.
>
> I wrote a simpler program that exhibits the problem too. here is the
> code followed by a comment on what I observed:
>
> with Ada.Unchecked_Deallocation,
> Ada.Finalization;
>
> package Final is
> type Vector is array (Positive range <>) of Float;
> type Vector_Ptr is access Vector;
>
> procedure Free is new Ada.Unchecked_Deallocation (Vector, Vector_Ptr);
>
> type Obj is new Ada.Finalization.Controlled with record
> X : Vector_Ptr := null;
> end record;
Note that Obj is declared Controlled, not Limited_Controlled, therefore the
function Process would make a copy of it. When you are dealing with copies
of pointers (the field X), you should decide what you would do with
multiple pointers to the same object, especially upon finalization. In any
case you have to override Adjust (and probably use reference counting). But
I suppose it should better be Limited_Controlled.
> overriding
> procedure Finalize (O : in out Obj);
> procedure Process (O : in out Obj);
> function Process return Obj;
> end Final;
>
>
> with Ada.Text_Io;
>
> package body Final is
> package Text_Io renames Ada.Text_Io;
>
> procedure Finalize (O : in out Obj) is
> begin
> Text_Io.Put ("Finalize: "); Text_Io.New_Line;
(Use Put_Line for that)
> Free (O.X);
> end Finalize;
>
> procedure Process (O : in out Obj) is
> begin
> Text_Io.Put ("In process procedure"); Text_Io.New_Line;
> Finalize(O);
You don't need that. It breaks your design. As a rule, Finalize should be
called once, and almost never explicitly.
> O.X := new Vector (1 .. 100);
> end Process;
>
> function Process return Obj is
> O : Obj;
> begin
> Text_Io.Put ("In process function"); Text_Io.New_Line;
> O.Process;
> return O;
> end Process;
This is broken. You allocate a new vector in Process, then a shallow copy
of is made in "return 0." Then O is destructed and as a result Finalize
kills that vector. The caller receives the shallow copy object with a
dangling pointer in the filed X.
> end Final;
>
> with Ada.Text_Io,
> Final;
>
> procedure main is
> O : Final.Obj;
> begin
> for I in 1 .. 100 loop
> Ada.Text_Io.put(Integer'Image(I)); Ada.Text_Io.New_Line;
> O := Final.Process;
> -- O.Process;
> end loop;
Do it this way:
for I in 1 .. 100 loop
declare
O : Obj; -- Ideally Initialize should allocate the vector
begin
Process (O); -- Don't allocate anything here
end; -- Finalize takes care of vector
end loop;
> Ada.Text_Io.put(Integer'Image(I)); Ada.Text_Io.New_Line;
> O := Final.Process;
> -- O.Process;
> end loop;
> Ada.Text_Io.Put("Fin"); Ada.Text_Io.New_Line;
> end Main;
>
> and the resulting execution trace:
>
> 1
> In process function
> In process procedure
> Finalize:
> Finalize:
> Finalize:
> Finalize:
> 2
> and so on...until:
> 7
> In process function
> In process procedure
> Finalize:
> Finalize:
> Finalize:
> Finalize:
> 8
> In process function
> In process procedure
> Finalize:
> process exited with status 128
>
> When I use the function call the program stops with an unexpected error
> that seems to be different from one compiler to another (I tried gnat
> gcc 3.4.6 on Windows and the Debian gnat version on Linux). The message
> depends also on the type of structure to be freed (vector or
> vector'class). Even when the program raises PROGRAM_ERROR I am unable
> to trap the exception. I tried to follow what happens under gdb and
> observed that an unexpected signal cencerning the heap is received by
> the program.
>
> When i use the procedure call (commented out in the main program), all
> is correct but I suspect that the memory is not deallocated at each call
> in the main loop since there i s only one call to Finalize at the end of
> the program.
>
> Does somebody has any idea of what happens? Do you think there is a
> faulty construct in my code?
Yes, see above.
--
Regards,
Dmitry A. Kazakov
http://www.dmitry-kazakov.de
^ permalink raw reply [relevance 0%]
* Finalization
@ 2006-11-21 9:02 6% ` Philippe Tarroux
2006-11-21 9:22 0% ` Finalization Dmitry A. Kazakov
0 siblings, 1 reply; 200+ results
From: Philippe Tarroux @ 2006-11-21 9:02 UTC (permalink / raw)
I have a problem trying to use controlled types. My purpose was to use
finalize to deallocate a big data structure each time a reuse.
I wrote a simpler program that exhibits the problem too. here is the
code followed by a comment on what I observed:
with Ada.Unchecked_Deallocation,
Ada.Finalization;
package Final is
type Vector is array (Positive range <>) of Float;
type Vector_Ptr is access Vector;
procedure Free is new Ada.Unchecked_Deallocation (Vector, Vector_Ptr);
type Obj is new Ada.Finalization.Controlled with record
X : Vector_Ptr := null;
end record;
overriding
procedure Finalize (O : in out Obj);
procedure Process (O : in out Obj);
function Process return Obj;
end Final;
with Ada.Text_Io;
package body Final is
package Text_Io renames Ada.Text_Io;
procedure Finalize (O : in out Obj) is
begin
Text_Io.Put ("Finalize: "); Text_Io.New_Line;
Free (O.X);
end Finalize;
procedure Process (O : in out Obj) is
begin
Text_Io.Put ("In process procedure"); Text_Io.New_Line;
Finalize(O);
O.X := new Vector (1 .. 100);
end Process;
function Process return Obj is
O : Obj;
begin
Text_Io.Put ("In process function"); Text_Io.New_Line;
O.Process;
return O;
end Process;
end Final;
with Ada.Text_Io,
Final;
procedure main is
O : Final.Obj;
begin
for I in 1 .. 100 loop
Ada.Text_Io.put(Integer'Image(I)); Ada.Text_Io.New_Line;
O := Final.Process;
-- O.Process;
end loop;
Ada.Text_Io.Put("Fin"); Ada.Text_Io.New_Line;
end Main;
and the resulting execution trace:
1
In process function
In process procedure
Finalize:
Finalize:
Finalize:
Finalize:
2
and so on...until:
7
In process function
In process procedure
Finalize:
Finalize:
Finalize:
Finalize:
8
In process function
In process procedure
Finalize:
process exited with status 128
When I use the function call the program stops with an unexpected error
that seems to be different from one compiler to another (I tried gnat
gcc 3.4.6 on Windows and the Debian gnat version on Linux). The message
depends also on the type of structure to be freed (vector or
vector'class). Even when the program raises PROGRAM_ERROR I am unable
to trap the exception. I tried to follow what happens under gdb and
observed that an unexpected signal cencerning the heap is received by
the program.
When i use the procedure call (commented out in the main program), all
is correct but I suspect that the memory is not deallocated at each call
in the main loop since there i s only one call to Finalize at the end of
the program.
Does somebody has any idea of what happens? Do you think there is a
faulty construct in my code?
Thanks for your help
Philippe Tarroux
^ permalink raw reply [relevance 6%]
* Re: GNAT compiler switches and optimization
@ 2006-10-23 0:10 5% ` Georg Bauhaus
0 siblings, 0 replies; 200+ results
From: Georg Bauhaus @ 2006-10-23 0:10 UTC (permalink / raw)
On Sun, 2006-10-22 at 14:24 -0400, Jeffrey Creem wrote:
> It sounds like you are running some different code and I'd be hestitant
> to make any assertions about runtime for certain constructs without
> seeing it since
It is appended below.
> 2) You mention something about just accessing first, middle and last of
> your arrays so it really sounds like you really are just timing
> allocations and and not actually really hitting the array indexing
> (though hard to say without seeing the code).
Yes, I had concentrated on just this question, asked by Thomas Krauss,
about stack versus heap allocation. If a program is not frequently
allocating and freeing arrays (or matrices, etc.), the the effects
might be less of an issue, if they are an issue at all when there
is no initialization.
But I imagined allocation is just what is happening all the time
if you have a function that computes matrices of varying sizes?
OTOH, I find very different results on GNU/Linux (for which I only
have a number of GNATs). Stack allocation appears to be consuming
next to no time. (Commit on write? Just remembering an offset?)
Below the following program, there is a patch that adds trivial
initialization loops. With them, a comparison of stack vs heap
on GNU/Linux seems in favor of the stack. I can't check this on
Windows right now, though.
with Ada.Calendar;
with Ada.Text_IO;
with Ada.Unchecked_Deallocation;
procedure main is
use Ada.Calendar, Ada;
type LIST is array (NATURAL range <>) of BOOLEAN;
for LIST'component_size use 8;
-- for a "normal" array, not packed or other magic
type LIST_PTR is access LIST;
procedure free is new Ada.Unchecked_Deallocation
(LIST, LIST_PTR);
accu: BOOLEAN := false;
-- The allocating functions read and write this variable
-- using components of the local arrays.
-- (This should prevent some optimizations.)
function allocate(size: POSITIVE) return BOOLEAN;
-- use a local `LIST` of length `size`
function allocate_heap(size: POSITIVE) return BOOLEAN;
-- use a pointer to a new `LIST` of length `size`
function image(t: TIME) return STRING;
-- the current time as a `STRING` value
function allocate(size: POSITIVE) return BOOLEAN is
done: LIST(1 .. size); -- pragma volatile(done);
result: BOOLEAN;
begin
if done(size / 2) then
result := false;
end if;
done(done'last) := accu and done(done'first);
result := done(done'last) and done(done'first);
return result;
end allocate;
function allocate_heap(size: POSITIVE) return BOOLEAN is
done: LIST_PTR;
result: BOOLEAN;
begin
done := new LIST(1 .. size);
if done(size / 2) then
result := false;
end if;
done(done'last) := accu and done(done'first);
result := done(done'first) and done(done'first);
Free(done);
return result;
end allocate_heap;
function image(t: TIME) return STRING is
year: YEAR_NUMBER;
day: DAY_NUMBER;
month: MONTH_NUMBER;
sec: DURATION;
begin
split(t, year, month, day, sec);
return YEAR_NUMBER'image(year)
& MONTH_NUMBER'image(month)
& DAY_NUMBER'image(day)
& DURATION'image(sec);
end image;
start, finish: TIME;
begin
Text_IO.put_line("using a stack");
start := clock;
for run in 1 .. 25 loop
for k in 1 .. 2000 loop
accu := allocate(5000 * k);
end loop;
end loop;
finish := clock;
Text_IO.put_line("from" & image(start)
& " to" & image(finish)
& " = " & DURATION'image(finish - start));
Text_IO.put_line("accu " & BOOLEAN'image(accu));
Text_IO.put_line("using a heap");
start := clock;
for run in 1 .. 25 loop
for k in 1 .. 2000 loop
accu := allocate_heap(5000 * k);
end loop;
end loop;
finish := clock;
Text_IO.put_line("from" & image(start)
& " to" & image(finish)
& " = " & DURATION'image(finish - start));
Text_IO.put_line("accu " & BOOLEAN'image(accu));
end main;
--- stack_use_testing.ada 2006/10/22 23:51:48 1.1
+++ stack_use_testing.ada 2006/10/22 23:52:12
@@ -33,2 +33,3 @@
begin
+ for k in done'range loop done(k) := false; end loop;
if done(size / 2) then
@@ -46,2 +47,3 @@
done := new LIST(1 .. size);
+ for k in done'range loop done(k) := false; end loop;
if done(size / 2) then
@@ -75,4 +77,4 @@
start := clock;
- for run in 1 .. 25 loop
- for k in 1 .. 2000 loop
+ for run in 1 .. 2 loop
+ for k in 1 .. 200 loop
accu := allocate(5000 * k);
@@ -90,4 +92,4 @@
start := clock;
- for run in 1 .. 25 loop
- for k in 1 .. 2000 loop
+ for run in 1 .. 2 loop
+ for k in 1 .. 200 loop
accu := allocate_heap(5000 * k);
^ permalink raw reply [relevance 5%]
* Re: Free'ing dynamic abstract tagged types..
@ 2006-09-21 22:12 7% ` Randy Brukardt
0 siblings, 0 replies; 200+ results
From: Randy Brukardt @ 2006-09-21 22:12 UTC (permalink / raw)
"ldb" <ldb_nospam@hotmail.com> wrote in message
news:1158872883.994303.80430@b28g2000cwb.googlegroups.com...
> Ok, so I have this abstract tagged type called Person (for the sake of
> discussion), and I have an Access_Person (which is access all
> people'class).
>
> I have some derived types, like Man and Child, with their own added
> fields. And I have defined Access_Man, Access_Child, as normal accesses
> to these types.
>
> I want to free an Access_Person that was dynamically allocated.
> ap : Access_Person;
> begin
> ap := Access_Person(new Man);
> free(ap);
> ...
>
> I can't figure out how to write the free routine, since unchecked
> deallocation wants a pointer (presumably access_man), but all I have is
> a class-wide pointer, and I can't figure out how, or if, I can convert
> it. Does that make sense?
No. ;-)
You just free the access and let the compiler take care of it. That is, just
instantiate Unchecked_Deallocation appropriately:
procedure Person_Free is new Ada.Unchecked_Deallocation (Person'Class,
Access_Person);
and then call it.
> Using free(ap.all), I can make an abstract function that will dispatch
> and free any nested allocations, but I can't seem to get it to free the
> record, itself.
Right, you have to do that on the pointer. You could write something like:
procedure Free (P : Access_Person) is
begin
Free (P.all); -- Free the contents
Person_Free (P); -- Free the object itself.
end Free;
but if the derived types need internal clean-up, it's better to make the
whole tree controlled and let the compiler do all of the internal clean-up:
that makes it much harder to forget.
Since you can't add Controlled to an inheritance tree after the fact, I
think that *all* tagged type trees should be derived from Controlled or
Limited_Controlled. (Otherwise, you're saying that the extensions don't need
any clean-up, which is likely to be constraining.)
Randy.
^ permalink raw reply [relevance 7%]
* Re: Address of an object
2006-09-15 23:31 0% ` Adam Beneschan
@ 2006-09-16 8:13 0% ` Dmitry A. Kazakov
0 siblings, 0 replies; 200+ results
From: Dmitry A. Kazakov @ 2006-09-16 8:13 UTC (permalink / raw)
On 15 Sep 2006 16:31:54 -0700, Adam Beneschan wrote:
> Dmitry A. Kazakov wrote:
>> Both X'Address and Unchecked_Conversion of a pointer to X would not give
>> the true address of X (i.e. the address returned by Allocate of the
>> corresponding storage pool). For an array type, X'Address is the address of
>> the first element, the dope is out.
>>
>> Is there any better way than this extremely ugly and slow:
>>
>> type Fake_Pool is new Root_Storage_Pool with record
>> Location : Address;
>> end record;
>>
>> procedure Allocate (...) is -- Never called
>> begin
>> raise Program_Error;
>> end Allocate;
>>
>> procedure Deallocate
>> ( Pool : in out Fake_Pool;
>> Storage_Address : in Address;
>> Size : Storage_Count;
>> Alignment : Storage_Count
>> ) is
>> begin
>> Pool.Location := Storage_Address;
>> end Deallocate;
>>
>> function Storage_Size (Pool : Fake_Pool) -- Never called
>> return Storage_Count is
>> begin
>> return 0;
>> end Storage_Size;
>>
>> function Address_Of (Pointer : Object_Ptr) return Address is
>> Pool : Fake_Pool; -- A controlled object, that must be slow!
>> type Fake_Ptr is access Object_Type;
>> for Fake_Ptr'Storage_Pool use Pool;
>> function To_Fake is
>> new Ada.Unchecked_Conversion (Object_Ptr, Fake_Ptr);
>> procedure Free is
>> new Ada.Unchecked_Deallocation (Object_Type, Fake_Ptr);
>> Ptr : Fake_Ptr := To_Fake (Pointer);
>> begin
>> Free (Ptr);
>> return Pool.Location;
>> end Address_Of;
>>
>> ?
>
> This sounds highly implementation-dependent.
At best!
> I don't think there's an implementation-independent way to get what
> you're looking for (and, frankly, I'm not even sure there's an
> implementation-independent way to *define* what you're looking for).
> Assuming that you're interested in only one implementation, perhaps you
> can ask the implementors to provide an implementation-dependent
> attribute or something to give you what you need.
Hmm, actually it is quite easy to define formally:
Let P be a pointer to X. Then what I need is the address A, which the pool
P'Storage_Pool returned when X was allocated there. This is the same
address the pool will receive upon freeing X.
----------
The problem behind. What I need is to be able to add some dopes to the
objects allocated in *my* pool. new T calls to the pool's Allocate, but the
address it returns gets mangled by the compiler, when converted to the
pointer P [for example, when T is String]. So, having P I cannot get at my
dope. Its address should be
A = P.all'Address - Offs
where Offs is known, alas, to the compiler only. The compiler must know
that, otherwise it couldn't pass that to Deallocate.
--
Regards,
Dmitry A. Kazakov
http://www.dmitry-kazakov.de
^ permalink raw reply [relevance 0%]
* Re: Address of an object
2006-09-15 20:24 5% Address of an object Dmitry A. Kazakov
@ 2006-09-15 23:31 0% ` Adam Beneschan
2006-09-16 8:13 0% ` Dmitry A. Kazakov
0 siblings, 1 reply; 200+ results
From: Adam Beneschan @ 2006-09-15 23:31 UTC (permalink / raw)
Dmitry A. Kazakov wrote:
> Both X'Address and Unchecked_Conversion of a pointer to X would not give
> the true address of X (i.e. the address returned by Allocate of the
> corresponding storage pool). For an array type, X'Address is the address of
> the first element, the dope is out.
>
> Is there any better way than this extremely ugly and slow:
>
> type Fake_Pool is new Root_Storage_Pool with record
> Location : Address;
> end record;
>
> procedure Allocate (...) is -- Never called
> begin
> raise Program_Error;
> end Allocate;
>
> procedure Deallocate
> ( Pool : in out Fake_Pool;
> Storage_Address : in Address;
> Size : Storage_Count;
> Alignment : Storage_Count
> ) is
> begin
> Pool.Location := Storage_Address;
> end Deallocate;
>
> function Storage_Size (Pool : Fake_Pool) -- Never called
> return Storage_Count is
> begin
> return 0;
> end Storage_Size;
>
> function Address_Of (Pointer : Object_Ptr) return Address is
> Pool : Fake_Pool; -- A controlled object, that must be slow!
> type Fake_Ptr is access Object_Type;
> for Fake_Ptr'Storage_Pool use Pool;
> function To_Fake is
> new Ada.Unchecked_Conversion (Object_Ptr, Fake_Ptr);
> procedure Free is
> new Ada.Unchecked_Deallocation (Object_Type, Fake_Ptr);
> Ptr : Fake_Ptr := To_Fake (Pointer);
> begin
> Free (Ptr);
> return Pool.Location;
> end Address_Of;
>
> ?
This sounds highly implementation-dependent. I don't know what an
Object_Ptr points to; but if it points to something that could be
represented, in some implementations, as discontiguous data, then the
above won't necessarily work---calling the instance of
Unchecked_Deallocation could well cause the storage pool Deallocate
routine to be called more than once. And then your result will be
whatever was passed to the last Deallocate call, which may or may not
be meaningful.
I don't think there's an implementation-independent way to get what
you're looking for (and, frankly, I'm not even sure there's an
implementation-independent way to *define* what you're looking for).
Assuming that you're interested in only one implementation, perhaps you
can ask the implementors to provide an implementation-dependent
attribute or something to give you what you need.
-- Adam
^ permalink raw reply [relevance 0%]
* Address of an object
@ 2006-09-15 20:24 5% Dmitry A. Kazakov
2006-09-15 23:31 0% ` Adam Beneschan
0 siblings, 1 reply; 200+ results
From: Dmitry A. Kazakov @ 2006-09-15 20:24 UTC (permalink / raw)
Both X'Address and Unchecked_Conversion of a pointer to X would not give
the true address of X (i.e. the address returned by Allocate of the
corresponding storage pool). For an array type, X'Address is the address of
the first element, the dope is out.
Is there any better way than this extremely ugly and slow:
type Fake_Pool is new Root_Storage_Pool with record
Location : Address;
end record;
procedure Allocate (...) is -- Never called
begin
raise Program_Error;
end Allocate;
procedure Deallocate
( Pool : in out Fake_Pool;
Storage_Address : in Address;
Size : Storage_Count;
Alignment : Storage_Count
) is
begin
Pool.Location := Storage_Address;
end Deallocate;
function Storage_Size (Pool : Fake_Pool) -- Never called
return Storage_Count is
begin
return 0;
end Storage_Size;
function Address_Of (Pointer : Object_Ptr) return Address is
Pool : Fake_Pool; -- A controlled object, that must be slow!
type Fake_Ptr is access Object_Type;
for Fake_Ptr'Storage_Pool use Pool;
function To_Fake is
new Ada.Unchecked_Conversion (Object_Ptr, Fake_Ptr);
procedure Free is
new Ada.Unchecked_Deallocation (Object_Type, Fake_Ptr);
Ptr : Fake_Ptr := To_Fake (Pointer);
begin
Free (Ptr);
return Pool.Location;
end Address_Of;
?
--
Regards,
Dmitry A. Kazakov
http://www.dmitry-kazakov.de
^ permalink raw reply [relevance 5%]
* Re: Why people wants to complicate code with Ada.Unchecked_Deallocation?
2006-07-27 22:52 7% ` Simon Wright
@ 2006-07-27 23:28 7% ` Robert A Duff
0 siblings, 0 replies; 200+ results
From: Robert A Duff @ 2006-07-27 23:28 UTC (permalink / raw)
Simon Wright <simon@pushface.org> writes:
> I don't see how having a storage pool of your own affects the need for
> unchecked deallocation? If your user wants to return the memory to
> your special pool she still has to use deallocation!
If you have a lot of objects with similar lifetimes, you can put them
all together in one pool, and deallocate the whole pool at once,
at the appropriate time. Presuming you have a storage pool type
that knows how to do that, of course.
This is sometimes safer than deallocating them one by one, because you
have fewer places where you need to worry about "when is it safe to
deallocate?", and because you can't forget to deallocate some of the
individual objects. It sometimes less safe, though, because you might
throw the baby out with the bathwater. It depends on the program.
It's a very efficient way to manage storage. Allocation can be just a
few instructions per object, and deallocation can be a small fraction of
one instruction per object.
- Bob
^ permalink raw reply [relevance 7%]
* Re: Why people wants to complicate code with Ada.Unchecked_Deallocation?
2006-07-27 15:49 7% ` adaworks
2006-07-27 19:11 7% ` Jeffrey R. Carter
@ 2006-07-27 22:52 7% ` Simon Wright
2006-07-27 23:28 7% ` Robert A Duff
1 sibling, 1 reply; 200+ results
From: Simon Wright @ 2006-07-27 22:52 UTC (permalink / raw)
<adaworks@sbcglobal.net> writes:
> That being said, I also find it uncommon for Ada designers to
> understand the storage-pool feature well enough to take advantage of
> it. Perhaps we need to put together a collection of storage pool
> management examples demonstrating how this feature of the language
> can be more effectively applied in a variety of circumstances. This
> could reduce the amount of unchecked operations on storage
> management.
I don't see how having a storage pool of your own affects the need for
unchecked deallocation? If your user wants to return the memory to
your special pool she still has to use deallocation!
I see in
http://www.adapower.com/index.php?Command=Class&ClassID=Advanced&CID=218
that Matt used 'storage pool' in a non-Ada sense, ie list of available
entities, in that case tasks.
http://en.wikibooks.org/wiki/Ada_Programming/Types/access might be a
good place for storage pool examples?
^ permalink raw reply [relevance 7%]
* Re: Why people wants to complicate code with Ada.Unchecked_Deallocation?
2006-07-27 15:49 7% ` adaworks
@ 2006-07-27 19:11 7% ` Jeffrey R. Carter
2006-07-27 22:52 7% ` Simon Wright
1 sibling, 0 replies; 200+ results
From: Jeffrey R. Carter @ 2006-07-27 19:11 UTC (permalink / raw)
adaworks@sbcglobal.net wrote:
>>
> I usually agree with you Jeff. In this case, we are in close agreement
> except on one point. Ada includes a storage-pool capability that
> allows for a wide range of storage management policies. I would
> expect that to be a better option in situations where there is a concern
> for dependable, predictbale storage management.
That's another way to deallocate storage without all the opportunities
for errors commonly found in languages like C. If your uses of access
types and values are hidden, as is generally good practice, then so will
be your storage pool. To the clients of the abstraction, it's invisible
and probably makes no difference which you use.
> That being said, I also find it uncommon for Ada designers to understand
> the storage-pool feature well enough to take advantage of it. Perhaps
> we need to put together a collection of storage pool management
> examples demonstrating how this feature of the language can be
> more effectively applied in a variety of circumstances. This could
> reduce the amount of unchecked operations on storage management.
In addition, in practice, it's usually more complex than controlled
types doing unchecked deallocation on finalization. Such examples would
be a good addition to the Ada pedagogical collection.
--
Jeff Carter
"Perfidious English mouse-dropping hoarders."
Monty Python & the Holy Grail
10
^ permalink raw reply [relevance 7%]
* Re: Why people wants to complicate code with Ada.Unchecked_Deallocation?
2006-07-26 21:28 7% ` Jeffrey R. Carter
@ 2006-07-27 15:49 7% ` adaworks
2006-07-27 19:11 7% ` Jeffrey R. Carter
2006-07-27 22:52 7% ` Simon Wright
0 siblings, 2 replies; 200+ results
From: adaworks @ 2006-07-27 15:49 UTC (permalink / raw)
"Jeffrey R. Carter" <spam.not.jrcarter@acm.not.spam.org> wrote in message
news:P7Rxg.1101345$xm3.664765@attbi_s21...
>
> It means that if a program won't run out of storage without unchecked
> deallocation, why bother putting it in? On the other hand, if a program will
> run out of storage without unchecked deallocation, it will fail unless you do
> deallocate storage, so you probably do want and need to put it in.
>
I usually agree with you Jeff. In this case, we are in close agreement
except on one point. Ada includes a storage-pool capability that
allows for a wide range of storage management policies. I would
expect that to be a better option in situations where there is a concern
for dependable, predictbale storage management.
That being said, I also find it uncommon for Ada designers to understand
the storage-pool feature well enough to take advantage of it. Perhaps
we need to put together a collection of storage pool management
examples demonstrating how this feature of the language can be
more effectively applied in a variety of circumstances. This could
reduce the amount of unchecked operations on storage management.
I am now wondering what storage management policies are used for
the Charles libraries. Unchecked-deallocation?
Richard Riehle
^ permalink raw reply [relevance 7%]
* Re: Why people wants to complicate code with Ada.Unchecked_Deallocation?
2006-07-26 19:34 13% Why people wants to complicate code with Ada.Unchecked_Deallocation? fabio de francesco
` (3 preceding siblings ...)
2006-07-27 0:07 8% ` Peter C. Chapin
@ 2006-07-27 11:54 7% ` gautier_niouzes
4 siblings, 0 replies; 200+ results
From: gautier_niouzes @ 2006-07-27 11:54 UTC (permalink / raw)
fabio:
[...]
> Does it mean that, for safety sake, programmers should not care about memory
> consumption?
>
> I am not sure I can agree with that. I've been tought that any "malloc"
> and "new" must be followed by "free" and "delete".
>
> What do you think about this issue?
I'm rather of your opinion.
If you start leaving memory leaks all around units it can become very
annoying as the projects grow and age.
You cannot predict if the target system will be plentiful enough to
absorb possible leaks or how long or on which input data size the
program will run.
It can happen that the pollution size at time t is a power of t times a
power of input data units or something like that...
IMHO it's a fully cultural problem.
Some people have tendency to say "just buy more storage, it's cheap",
other prefer to keep control of the rubbish...
Gautier
______________________________________________________________
Ada programming -- http://www.mysunrise.ch/users/gdm/gsoft.htm
NB: For a direct answer, e-mail address on the Web site!
^ permalink raw reply [relevance 7%]
* Re: Why people wants to complicate code with Ada.Unchecked_Deallocation?
2006-07-26 19:34 13% Why people wants to complicate code with Ada.Unchecked_Deallocation? fabio de francesco
` (2 preceding siblings ...)
2006-07-26 21:28 7% ` Jeffrey R. Carter
@ 2006-07-27 0:07 8% ` Peter C. Chapin
2006-07-27 11:54 7% ` gautier_niouzes
4 siblings, 0 replies; 200+ results
From: Peter C. Chapin @ 2006-07-27 0:07 UTC (permalink / raw)
fabio de francesco wrote:
> What do you think about this issue?
It seems to me that in library units you pretty much have to use
Unchecked_Deallocation because you don't know much about the memory
requirements or constraints of the calling application. However, if you
are creating an abstract data type and you hide the deallocation in a
Finalize procedure, you probably aren't going to have a lot of trouble.
Peter
^ permalink raw reply [relevance 8%]
* Re: Why people wants to complicate code with Ada.Unchecked_Deallocation?
2006-07-26 19:34 13% Why people wants to complicate code with Ada.Unchecked_Deallocation? fabio de francesco
2006-07-26 19:51 8% ` Georg Bauhaus
2006-07-26 19:56 8% ` Simon Wright
@ 2006-07-26 21:28 7% ` Jeffrey R. Carter
2006-07-27 15:49 7% ` adaworks
2006-07-27 0:07 8% ` Peter C. Chapin
2006-07-27 11:54 7% ` gautier_niouzes
4 siblings, 1 reply; 200+ results
From: Jeffrey R. Carter @ 2006-07-26 21:28 UTC (permalink / raw)
fabio de francesco wrote:
>
> The following statement is from Cohen's "Ada as a second language":
>
> "Ada.Unchecked_Deallocation must be used with caution. As we shall see, it
> can lead to subtle but devastating errors. If storage for allocated object
> is plentiful, there is no point in complicating the program to keep track
> of which allocated objects are no longer needed".
>
> Does it mean that, for safety sake, programmers should not care about memory
> consumption?
>
> What do you think about this issue?
It means that if a program won't run out of storage without unchecked
deallocation, why bother putting it in? On the other hand, if a program
will run out of storage without unchecked deallocation, it will fail
unless you do deallocate storage, so you probably do want and need to
put it in.
In most cases, the use of access types and values can be hidden, so the
opportunity for "devastating errors" is limited and not as big a concern
as in C, where allocation and deallocation are usually scattered
throughout the code. With the use of controlled types automatically
performing deallocation during finalization, the opportunities for
errors is limited further. So, in practice, it's not really that big of
an issue.
--
Jeff Carter
"My mind is a raging torrent, flooded with rivulets of
thought, cascading into a waterfall of creative alternatives."
Blazing Saddles
89
^ permalink raw reply [relevance 7%]
* Re: Why people wants to complicate code with Ada.Unchecked_Deallocation?
2006-07-26 19:34 13% Why people wants to complicate code with Ada.Unchecked_Deallocation? fabio de francesco
2006-07-26 19:51 8% ` Georg Bauhaus
@ 2006-07-26 19:56 8% ` Simon Wright
2006-07-26 21:28 7% ` Jeffrey R. Carter
` (2 subsequent siblings)
4 siblings, 0 replies; 200+ results
From: Simon Wright @ 2006-07-26 19:56 UTC (permalink / raw)
fabio de francesco <cancella.fabiomdf@alice.elimina.it> writes:
> The following statement is from Cohen's "Ada as a second language":
>
> "Ada.Unchecked_Deallocation must be used with caution. As we shall
> see, it can lead to subtle but devastating errors. If storage for
> allocated object is plentiful, there is no point in complicating the
> program to keep track of which allocated objects are no longer
> needed".
In my world, storage is not plentiful, so we absolutely must keep
track of it! (but I certainly would _not_ bother over-much for an
off-line tool that runs to completion and isn't a heavy memory user
anyway).
^ permalink raw reply [relevance 8%]
* Re: Why people wants to complicate code with Ada.Unchecked_Deallocation?
2006-07-26 19:34 13% Why people wants to complicate code with Ada.Unchecked_Deallocation? fabio de francesco
@ 2006-07-26 19:51 8% ` Georg Bauhaus
2006-07-26 19:56 8% ` Simon Wright
` (3 subsequent siblings)
4 siblings, 0 replies; 200+ results
From: Georg Bauhaus @ 2006-07-26 19:51 UTC (permalink / raw)
On Wed, 2006-07-26 at 21:34 +0200, fabio de francesco wrote:
> "If storage for allocated object
> is plentiful,...
> Does it mean that, for safety sake, programmers should not care about memory
> consumption?
A program, run once an hour, to see how many new items have
been added to a database, report the number, and be done,
may well leave memory management to the system facilities IMHO.
That's safe, too, because I can't pass the wrong pointer
to an Unchecked_Deallocation.
^ permalink raw reply [relevance 8%]
* Why people wants to complicate code with Ada.Unchecked_Deallocation?
@ 2006-07-26 19:34 13% fabio de francesco
2006-07-26 19:51 8% ` Georg Bauhaus
` (4 more replies)
0 siblings, 5 replies; 200+ results
From: fabio de francesco @ 2006-07-26 19:34 UTC (permalink / raw)
Hi all.
The following statement is from Cohen's "Ada as a second language":
"Ada.Unchecked_Deallocation must be used with caution. As we shall see, it
can lead to subtle but devastating errors. If storage for allocated object
is plentiful, there is no point in complicating the program to keep track
of which allocated objects are no longer needed".
Does it mean that, for safety sake, programmers should not care about memory
consumption?
I am not sure I can agree with that. I've been tought that any "malloc"
and "new" must be followed by "free" and "delete".
What do you think about this issue?
fabio de francesco
^ permalink raw reply [relevance 13%]
* Re: How to properly clean up an extended, generic structure?
2006-07-09 13:42 7% How to properly clean up an extended, generic structure? Peter C. Chapin
2006-07-09 14:29 0% ` jimmaureenrogers
2006-07-09 14:33 0% ` Ludovic Brenta
@ 2006-07-09 14:49 0% ` Björn Persson
2 siblings, 0 replies; 200+ results
From: Björn Persson @ 2006-07-09 14:49 UTC (permalink / raw)
Peter C. Chapin wrote:
> I've created a procedure Destroy_Tree that uses an instance of
> Ada.Unchecked_Deallocation to remove all the nodes in a given tree.
> Destroy_Tree is meant to be used when a tree is no longer needed and it
> serves the role of a destructor (using C++ terminology). It occurs to
> me, though, that Item_Type might have its own clean up needs.
You need controlled types. Derive your tree type from
Ada.Finalization.Controlled, and instead of Destroy_Tree write a
procedure Finalize, overriding the Finalize that's declared in
Ada.Finalization. Finalize will then be executed automatically when the
object is destroyed.
Item types that need cleaning up should also be controlled. Each item
will then be finalized when its tree node is finalized.
--
Bj�rn Persson PGP key A88682FD
omb jor ers @sv ge.
r o.b n.p son eri nu
^ permalink raw reply [relevance 0%]
* Re: How to properly clean up an extended, generic structure?
2006-07-09 13:42 7% How to properly clean up an extended, generic structure? Peter C. Chapin
2006-07-09 14:29 0% ` jimmaureenrogers
@ 2006-07-09 14:33 0% ` Ludovic Brenta
2006-07-09 14:49 0% ` Björn Persson
2 siblings, 0 replies; 200+ results
From: Ludovic Brenta @ 2006-07-09 14:33 UTC (permalink / raw)
Peter C. Chapin writes:
> Right now I'm working on a generic package that implements splay
> trees. My generic parameters look like:
>
> generic
> type Item_Type is private;
> with function "<"(L : Item_Type; R : Item_Type) return Boolean;
> package Splay_Tree is ...
>
>
> I've created a procedure Destroy_Tree that uses an instance of
> Ada.Unchecked_Deallocation to remove all the nodes in a given
> tree. Destroy_Tree is meant to be used when a tree is no longer needed
> and it serves the role of a destructor (using C++ terminology). It
> occurs to me, though, that Item_Type might have its own clean up
> needs. I assume that Unchecked_Deallocation knows nothing about
> that. Thus my code currently might be improperly cleaning up the
> Item_Types in each tree node. In C++ this is not a problem because
> deleting a node invokes the node's destructor (if there is one) so the
> issue is handled automatically. My question is how do I best deal with
> this in Ada?
>
> I could pass a clean up procedure for Item_Types as another generic
> parameter. However, in cases where no such procedure is necessary (for
> example, when Item_Type is just Integer), such a solution seems
> awkward. Is there a nicer solution?
You do not need to change anything to your Splay_Tree; instead, just
pass a controlled type as the Item_Type. A controlled type is a type
derived from Ada.Finalization.Controlled(*). You override its
Finalize procedure to reclaim the storage for the item; that's the
equivalent of a destructor in C++. The language guarantees (ARM
7.6(1)) that the instance of Unchecked_Deallocation will call your
Finalize, much like delete in C++ will call your destructor.
For more details, see ARM 7.6.
(*) or Limited_Controlled, but your generic does not accept limited
types, which is probably OK for a container.
HTH
--
Ludovic Brenta.
^ permalink raw reply [relevance 0%]
* Re: How to properly clean up an extended, generic structure?
2006-07-09 13:42 7% How to properly clean up an extended, generic structure? Peter C. Chapin
@ 2006-07-09 14:29 0% ` jimmaureenrogers
2006-07-09 14:33 0% ` Ludovic Brenta
2006-07-09 14:49 0% ` Björn Persson
2 siblings, 0 replies; 200+ results
From: jimmaureenrogers @ 2006-07-09 14:29 UTC (permalink / raw)
Peter C. Chapin wrote:
> I've created a procedure Destroy_Tree that uses an instance of
> Ada.Unchecked_Deallocation to remove all the nodes in a given tree.
> Destroy_Tree is meant to be used when a tree is no longer needed and it
> serves the role of a destructor (using C++ terminology). It occurs to
> me, though, that Item_Type might have its own clean up needs. I assume
> that Unchecked_Deallocation knows nothing about that. Thus my code
> currently might be improperly cleaning up the Item_Types in each tree
> node. In C++ this is not a problem because deleting a node invokes the
> node's destructor (if there is one) so the issue is handled
> automatically. My question is how do I best deal with this in Ada?
>
> I could pass a clean up procedure for Item_Types as another generic
> parameter. However, in cases where no such procedure is necessary (for
> example, when Item_Type is just Integer), such a solution seems awkward.
> Is there a nicer solution?
You should read up on Ada controlled types. The tree itself can be a
controlled type. The tree elements may or may not be controlled types.
Ada controlled types allow you to specify actions to be taken upon
initialization, adjustment, and finalization of a data element. These
actions effectively mimic many of the characteristics of C++
constructors and destructors.
Jim Rogers
^ permalink raw reply [relevance 0%]
* How to properly clean up an extended, generic structure?
@ 2006-07-09 13:42 7% Peter C. Chapin
2006-07-09 14:29 0% ` jimmaureenrogers
` (2 more replies)
0 siblings, 3 replies; 200+ results
From: Peter C. Chapin @ 2006-07-09 13:42 UTC (permalink / raw)
Hello! I'm working on improving my Ada skills by assigning myself little
programming exercises and then solving them in Ada. I come from a C++
background so I tend to see the world in C++ terms. I realize that isn't
necessarily helpful.
Right now I'm working on a generic package that implements splay trees.
My generic parameters look like:
generic
type Item_Type is private;
with function "<"(L : Item_Type; R : Item_Type) return Boolean;
package Splay_Tree is ...
I've created a procedure Destroy_Tree that uses an instance of
Ada.Unchecked_Deallocation to remove all the nodes in a given tree.
Destroy_Tree is meant to be used when a tree is no longer needed and it
serves the role of a destructor (using C++ terminology). It occurs to
me, though, that Item_Type might have its own clean up needs. I assume
that Unchecked_Deallocation knows nothing about that. Thus my code
currently might be improperly cleaning up the Item_Types in each tree
node. In C++ this is not a problem because deleting a node invokes the
node's destructor (if there is one) so the issue is handled
automatically. My question is how do I best deal with this in Ada?
I could pass a clean up procedure for Item_Types as another generic
parameter. However, in cases where no such procedure is necessary (for
example, when Item_Type is just Integer), such a solution seems awkward.
Is there a nicer solution?
Peter
^ permalink raw reply [relevance 7%]
* Re: Not null feature with anonymous and named access types
2006-06-17 1:21 0% ` Randy Brukardt
@ 2006-06-17 8:24 0% ` Dmitry A. Kazakov
0 siblings, 0 replies; 200+ results
From: Dmitry A. Kazakov @ 2006-06-17 8:24 UTC (permalink / raw)
On Fri, 16 Jun 2006 20:21:10 -0500, Randy Brukardt wrote:
> "Dmitry A. Kazakov" <mailbox@dmitry-kazakov.de> wrote in message
> news:1xjx7454hmql7.14ype2u114tz2.dlg@40tude.net...
> ...
>> * There is a language design problem that not-null is a subtype constraint
>> rather than a type, so Ada.Unchecked_Deallocation cannot reject
>> instantiation with a not-null pointer, as it probably should. But that is
>> a problem of generics, not of null-pointers. But this is another story.
>
> This is doubly wrong: "not null" is *not* a constraint (it's something else
> altogether).
I didn't check it, so I thought that GNAT was correct. Thank you for
clarification.
However, if anonymous not-null access is a distinct type then it cannot be
implicitly converted to/from a (normal) anonymous access type, or?
> And it is required to match on generic instantiations (the
> version of GNAT used is wrong here, not the language).
That is a good news (to Ada, I mean (:-)))
> Note that Ada
> requires matching constraints in some cases for generics (remember
> "statically matching subtypes"?) -- this has nothing to do with types.
Hmm, that was about the target type constraints.
What I mean is that any access type is itself a type and could
[potentially] have constrained subtypes with the constraints of its own.
Not-null could be treated as such constraint. The storage pool could be
another (if we wished to eliminate anonymous access types), discriminants,
(if were allowed for access types) could be third.
--
Regards,
Dmitry A. Kazakov
http://www.dmitry-kazakov.de
^ permalink raw reply [relevance 0%]
* Re: Not null feature with anonymous and named access types
2006-06-15 8:21 5% ` Dmitry A. Kazakov
@ 2006-06-17 1:21 0% ` Randy Brukardt
2006-06-17 8:24 0% ` Dmitry A. Kazakov
0 siblings, 1 reply; 200+ results
From: Randy Brukardt @ 2006-06-17 1:21 UTC (permalink / raw)
"Dmitry A. Kazakov" <mailbox@dmitry-kazakov.de> wrote in message
news:1xjx7454hmql7.14ype2u114tz2.dlg@40tude.net...
...
> * There is a language design problem that not-null is a subtype constraint
> rather than a type, so Ada.Unchecked_Deallocation cannot reject
> instantiation with a not-null pointer, as it probably should. But that is
a
> problem of generics, not of null-pointers. But this is another story.
This is doubly wrong: "not null" is *not* a constraint (it's something else
altogether). And it is required to match on generic instantiations (the
version of GNAT used is wrong here, not the language). Note that Ada
requires matching constraints in some cases for generics (remember
"statically matching subtypes"?) -- this has nothing to do with types.
Randy.
^ permalink raw reply [relevance 0%]
* Re: Not null feature with anonymous and named access types
@ 2006-06-15 8:21 5% ` Dmitry A. Kazakov
2006-06-17 1:21 0% ` Randy Brukardt
0 siblings, 1 reply; 200+ results
From: Dmitry A. Kazakov @ 2006-06-15 8:21 UTC (permalink / raw)
On 14 Jun 2006 20:48:28 -0700, Anh Vo wrote:
> Dmitry A. Kazakov wrote:
>> On 14 Jun 2006 08:37:13 -0700, Anh Vo wrote:
>>
>> via *this* pointer, which does not mean that it cannot be reclaimed at all.
>> Consider trivial stack allocated aliased variable.
>
> I am afraid I do not understand "this* pointer means.
You can have many pointers and other references to the same memory.
> What I was
> talking about not null access object using heap memory, not aliased
> variable at all. See my code snipet from my original post.
That's no problem. You just shouldn't mix referencing objects and memory
management. Not-null access types aren't intended for memory management. So
your example is flawed [*].
>> No, you just don't use not-null pointers where deallocation is possible /
>> necessary. That's the very idea of not-null pointers.
>
> I weight memory leak more important than convenient way of using null
> excluded pointer. I am fine with not null pointer pointing to an
> aliased object. In this case, attemptingp to deallocate the pointer is
> clearly a language violation.
But an aliased object, in a wider sense, that you have a more than one
reference to it, is the only case where non-null pointer should be used!
--------------
* There is a language design problem that not-null is a subtype constraint
rather than a type, so Ada.Unchecked_Deallocation cannot reject
instantiation with a not-null pointer, as it probably should. But that is a
problem of generics, not of null-pointers. But this is another story.
--
Regards,
Dmitry A. Kazakov
http://www.dmitry-kazakov.de
^ permalink raw reply [relevance 5%]
* Re: How-to on using the adacl-gc packages
@ 2006-05-15 20:13 6% ` Simon Wright
0 siblings, 0 replies; 200+ results
From: Simon Wright @ 2006-05-15 20:13 UTC (permalink / raw)
"Martin Krischik" <krischik@users.sourceforge.net> writes:
> I know at least one memory allocation problem where I have not yet
> found a solution for - no matter how much engineering I have put into
> the problem:
>
> task type T;
> type T_Access is access T;
>
> ...
>
> X : T_Access := new T;
What I do in ColdFrame is (with a bit of concatenation and elision)
type Instance (<>)
is new ---- with private;
type Handle is access all Instance;
private
task type T (This : access Instance) is
-----
entry -----;
end T;
type T_P is access T;
procedure Free is new Ada.Unchecked_Deallocation (T, T_P);
type Instance is new ----- with record
The_T : T_P;
-----
end record;
procedure Free is new Ada.Unchecked_Deallocation (Instance, Handle);
procedure Delete (This : in out Handle) is
-----
begin
-----
abort This.The_T.all;
Free (This.The_T);
-----
Free (This);
end Delete;
which has caused us no problems (GNAT, NT, Linux, MacOS, VxWorks)[1];
but I'm always prepared to be told I'm wrong.
A while back AdaCore pointed me towards LRM 13.11.2(9):
Free(X), when X is not equal to null [...] deallocates the storage
occupied by the object designated by X. [...] There is one
exception: if the object being freed contains tasks, the object
might not be deallocated.
It's not clear to me quite what 'contains tasks' means. From a
position of ignorance, I could argue that The_T.all doesn't _contain_
a task, it _is_ a task.
> The last I read only recently here was: task types are small - don't
> bother deallocating them. Anybody got any better advice?
It all depends how often you do it and what your platform's memory
availability is! On VxWorks (5.4, PowerPC) you are stuck with the
physical memory ...
[1] except when people called Delete from the task that was to be
deleted. I catch this now.
^ permalink raw reply [relevance 6%]
* Re: Type safety on wikipedia
2006-01-27 0:38 0% ` jimmaureenrogers
@ 2006-01-27 18:54 0% ` Martin Krischik
0 siblings, 0 replies; 200+ results
From: Martin Krischik @ 2006-01-27 18:54 UTC (permalink / raw)
jimmaureenrogers@worldnet.att.net wrote:
>
> Florian Weimer wrote:
>> Now, suppose that X is a pool-specific access value for some type T,
>> and Free is a corresponding instance of Ada.Unchecked_Deallocation.
>> Suppose that
>>
>>
>> Free (X);
>>
>> has just been exected. Suppose the next thing to be evaluated is
>>
>> declare
>> Y : T := X.all;
>> begin
>> ...
>
>
> Let's look at an actual program doing an equivalent action:
> with Ada.Text_Io;
>
> procedure Access_Test is
> type Int_Access is access Integer;
> P : Int_Access;
> begin
> P := null;
> Ada.Text_Io.Put_Line(Integer'Image(P.All));
> end Access_Test;
Make that
with Ada.Text_Io;
procedure Access_Test is
type Int_Access is access Integer;
procedure Deallocate is new Unchecked_Deallocation ....
P : Int_Access := new Integer;
Q : Int_Access := P;
begin
Deallocate (P);
Ada.Text_Io.Put_Line(Integer'Image(Q.All));
end Access_Test;
That is what the garbage collection chapter of the article is all about.
For a type save language behavior of this code snippet must be well
defined. But in Ada it is not.
Martin
--
mailto://krischik@users.sourceforge.net
Ada programming at: http://ada.krischik.com
^ permalink raw reply [relevance 0%]
* Re: Type safety on wikipedia
2006-01-26 19:07 7% ` Florian Weimer
2006-01-27 0:38 0% ` jimmaureenrogers
@ 2006-01-27 11:34 0% ` Alex R. Mosteo
1 sibling, 0 replies; 200+ results
From: Alex R. Mosteo @ 2006-01-27 11:34 UTC (permalink / raw)
Florian Weimer wrote:
>>Even with unchecked conversion Ada has the 'Valid attribute, allowing
>>the programmer to determine if the result of an unchecked conversion is
>>a valid value.
>
>
> Only in very limited cases.
>
>
>>I do not see how Unchecked_Deallocation interferes with type safety.
>
>
> The following is just a rough sketch, but maybe it helps to clarify
> the terms.
>
> A type system gives you a subset of all expressions which are
> well-typed (in Ada, 1 + 1 is well-typed, but 1.0 + 1 is not).
>
> A type-safe language has a type system with these two properties: any
> well-typed expression which is not a value can be reduced to a simpler
> expression, according to a set of run-time evaluation rules (which
> define the semantics of the language) -- and these simplification
> steps preserve the well-typedness of expressions.
>
> (Of course, considerable notational overhead is needed to apply this
> definitions in a rigorous manner to real-world programming languages.)
>
> Now, suppose that X is a pool-specific access value for some type T,
> and Free is a corresponding instance of Ada.Unchecked_Deallocation.
> Suppose that
>
>
> Free (X);
>
> has just been exected. Suppose the next thing to be evaluated is
>
> declare
> Y : T := X.all;
> begin
> ...
>
> Now X.all is not a value, so it has to reduce (at run-time) to some
> other expression. But the language definition explicitly tells you
> that no such rule exists. Therefore, the first rule I mentioned is
> violated, and Ada with Ada.Unchecked_Deallocation is not type-safe.
Thanks for your effort in making us understand. However, there's still
something fundamental that I'm not grasping.
According to the current Wikipedia article, Java is believed to be type
safe. However, one can have null pointers in Java. For example:
public class Test {
public static void main (String args[]) {
Integer x = new Integer (5);
Integer y = null;
System.out.println ("X + Y: " + (x + y));
}
}
will compile without warnings with latest JDK1.5 and run as:
$ java Test
X: 5
Exception in thread "main" java.lang.NullPointerException
at Test.main(Test.java:7)
This means that Java has explicit rules for when this happens that
differ from those in Ada? Since Ada also detects null pointer usage, and
per your example it makes Ada type unsafe.
Conversely, I understand that evaluations that yield out-of-range values
don't make a language type-unsafe because these cases have well-defined
rules of behavior.
Maybe I should go now to read the original paper linked from the wikipedia.
^ permalink raw reply [relevance 0%]
* Re: Type safety on wikipedia
2006-01-26 19:07 7% ` Florian Weimer
@ 2006-01-27 0:38 0% ` jimmaureenrogers
2006-01-27 18:54 0% ` Martin Krischik
2006-01-27 11:34 0% ` Alex R. Mosteo
1 sibling, 1 reply; 200+ results
From: jimmaureenrogers @ 2006-01-27 0:38 UTC (permalink / raw)
Florian Weimer wrote:
> Now, suppose that X is a pool-specific access value for some type T,
> and Free is a corresponding instance of Ada.Unchecked_Deallocation.
> Suppose that
>
>
> Free (X);
>
> has just been exected. Suppose the next thing to be evaluated is
>
> declare
> Y : T := X.all;
> begin
> ...
Let's look at an actual program doing an equivalent action:
with Ada.Text_Io;
procedure Access_Test is
type Int_Access is access Integer;
P : Int_Access;
begin
P := null;
Ada.Text_Io.Put_Line(Integer'Image(P.All));
end Access_Test;
The problem is one of attempting to dereference a null access object.
The above program compiles without error.
When run, I get the following error message:
raised CONSTRAINT_ERROR: access_test.adb:8 access check failed
It appears that Ada's runtime checks detect an erroneous problem.
I would say that a program that terminates with a CONSTRAINT_ERROR
has not exhibited the same kind of improper behavior as a program that
does not detect the problem.
In C, while it is an error to de-reference a null pointer, the runtime
system
does nothing to detect the problem. C programs continue with really
nasty
garbage values.
Jim Rogers
^ permalink raw reply [relevance 0%]
* Re: Type safety on wikipedia
@ 2006-01-26 19:07 7% ` Florian Weimer
2006-01-27 0:38 0% ` jimmaureenrogers
2006-01-27 11:34 0% ` Alex R. Mosteo
0 siblings, 2 replies; 200+ results
From: Florian Weimer @ 2006-01-26 19:07 UTC (permalink / raw)
> Even with unchecked conversion Ada has the 'Valid attribute, allowing
> the programmer to determine if the result of an unchecked conversion is
> a valid value.
Only in very limited cases.
> I do not see how Unchecked_Deallocation interferes with type safety.
The following is just a rough sketch, but maybe it helps to clarify
the terms.
A type system gives you a subset of all expressions which are
well-typed (in Ada, 1 + 1 is well-typed, but 1.0 + 1 is not).
A type-safe language has a type system with these two properties: any
well-typed expression which is not a value can be reduced to a simpler
expression, according to a set of run-time evaluation rules (which
define the semantics of the language) -- and these simplification
steps preserve the well-typedness of expressions.
(Of course, considerable notational overhead is needed to apply this
definitions in a rigorous manner to real-world programming languages.)
Now, suppose that X is a pool-specific access value for some type T,
and Free is a corresponding instance of Ada.Unchecked_Deallocation.
Suppose that
Free (X);
has just been exected. Suppose the next thing to be evaluated is
declare
Y : T := X.all;
begin
...
Now X.all is not a value, so it has to reduce (at run-time) to some
other expression. But the language definition explicitly tells you
that no such rule exists. Therefore, the first rule I mentioned is
violated, and Ada with Ada.Unchecked_Deallocation is not type-safe.
^ permalink raw reply [relevance 7%]
* Re: Unchecked deallocation issues
@ 2005-12-09 10:06 7% ` Alex R. Mosteo
0 siblings, 0 replies; 200+ results
From: Alex R. Mosteo @ 2005-12-09 10:06 UTC (permalink / raw)
ejijott@gmail.com wrote:
> Mhmm, hmm. Tried using just Free(Node) and indeed Node goes null..
> which puzzles me even more.. the litterature im using states that
> (freely translated from swedish):
>
> "... using this technique to return dynamically allocated memory you,
> yourself, is responsible for making sure that there will exist no
> pointers to memory with undefined content".
>
> In my binary tree, if I call Free() on, for example, an leaf .. would
> the parents left/right point to "memory with undefined content"? And if
> so, how would I go about to make it not point to that? Im guessing that
> Free(parent.left) would be the same as calling Free(Node) since they
> are both of type Storage? Or have I completly misunderstood the use of
> the pointers?
Unchecked_Deallocation will nullify just the pointer passed to it. I.e.,
aliased pointers will not be accordingly nullified. It's plain and old
allocate/free strategy.
declare
type String_Access is access all String;
procedure Free is new Ada.Unchecked_Deallocation
(String, String_Access);
A : String_Access := new String'("Hello");
B : String_Access := A;
begin
Free (A);
-- Now A is null but B now points to deallocated space.
end; -- Disclaimer: not compiled.
> What would an concrete example be of not making sure that there exists
> no pointers to memory with undefined content? (I.e. screwing it up :) )
You can do it the old way; i.e. by hand. In that respect the package
Gnat.Debug_Pools can be very handy to find problems.
I think there was an article about "Smart_Pointers" which specifically
implement a pointer abstraction where freeing a pointer automatically
nullified every aliased pointer to the same data.
[Sorry, I just can't find it now. It usually came near the top in google
when looking for ada smart pointer but no more it seems].
(Not to be confused with some other smart pointers where the smart bit
refers to automatic deallocation when references go to zero, a la Java.
That would be, for example:
http://www.adapower.com/index.php?Command=Class&ClassID=Patterns&CID=276
)
^ permalink raw reply [relevance 7%]
* Re: Unchecked deallocation issues
@ 2005-12-09 6:40 6% ` Jeffrey R. Carter
0 siblings, 1 reply; 200+ results
From: Jeffrey R. Carter @ 2005-12-09 6:40 UTC (permalink / raw)
ejijott@gmail.com wrote:
> Right.. code snippet above is a part of my BST Remove() handling. The
> issue I'm having is using unchecked deallocation... what im figuring
> here is that my Free() procedure frees the part of memory that contains
> my value, but does nothing to the pointer itself. So, if I just call
> Free() on an value-pointed-to and directly after print out
> value-pointed-to it _could_ still print out whatever it contains, but
> it could change at any time due to the fact that that part of memory is
> part of the pool again? And to solve this, I should set the pointer of
> the pointed-to-value to null ... is my implementation of this correct,
> as in this snippet:
>
> Free(Node);
> Node:=null;
ARM 13.11.2: "After executing Free(X), the value of X is null. [where Free is an
instantiation of Ada.Unchecked_Deallocation]"
--
Jeff Carter
"Why don't you bore a hole in yourself and let the sap run out?"
Horse Feathers
49
^ permalink raw reply [relevance 6%]
* Re: function "&" for strings type cause memory problem.
@ 2005-11-11 8:25 6% ` bubble
0 siblings, 0 replies; 200+ results
From: bubble @ 2005-11-11 8:25 UTC (permalink / raw)
dear all:
thank your reply.
correct me if I'm wrong.
maybe the subject should be
function "&" crash in thread's stack size is too small, even if you have a
big heap memory.
I knew to allocate a "large" object in stack is a bad idea.(another
question:how to define "large" to stack?)
and I allocate the large object in heap memory in previous case.
It's seem so beauty :)
if "&" is creating its result on the stack ,it still has potential risk.
in others.
I don't want to tell my programer:
" you can not use & for string or array,it has 1% probability to crash"
I want to say.
" & for string or array merge don't crash, but you will get worst
performace"
" you can change code and you will get better performance"
To Jeff and Dmitry.
in fact.
the the kernel(ada part) just crash "few" times.
It work perfectly until now after I change something like new test case .
my string are not so big,
I give you the extreme example.
because I just want to say bugs often happen in extreme case.
and I have not find any documents to increasing stack size in VB6.
please see new test case.
--------for test.adb-----------------------
with Ada.Text_IO;
Use Ada.Text_Io;
With stringFunctionPatch;
procedure test Is
Type Access_String Is Access String;
String1 : String := (1 .. 10_000_000 => 'a');
String2 : String := (1 .. 10_000_000 => 'b');
function "&" (Left,Right:string)Return String Renames
StringFunctionPatch."&"; --enable/disable the line
begin
declare
Nstring2 : access_string := null;
begin
Nstring2 := new String'(String1 & String2);
Put_Line("Test 2 Passed ");
end;
end test;
---------------------stringFunctionPatch.ads-------------------
package stringFunctionPatch is
Function "&"(Left,Right:string)Return String;
end stringFunctionPatch;
--------------------stringFunctionPatch.adb-------------------
with Ada.Finalization;
With Ada.Unchecked_Deallocation;
package body stringFunctionPatch is
type string_pointer is access String;
Procedure Free Is New Ada.Unchecked_Deallocation(String,String_Pointer);
type Buffer is new Ada.Finalization.Controlled with record
Data:string_pointer:=Null;
end record;
procedure Finalize (Object : in out Buffer) Is
Begin
Free(Object.Data);
End;
function "&" (Left, Right : String) return String Is
StringBuffer:Buffer;
Begin
Stringbuffer.Data:=New String (1 .. Left'Length + Right'Length);
Stringbuffer.Data.all (1 .. left'Last) := left;
Stringbuffer.Data.all ( Left'Last+1 .. Left'Last + Right'Last):=Right
;
return Stringbuffer.Data.all;
end "&";
end stringFunctionPatch;
^ permalink raw reply [relevance 6%]
* Re: Memory Mapped Storage Pools.
[not found] <pan.2005.10.26.22.16.09.200167@nowhere.net>
@ 2005-10-26 1:41 5% ` Dan Baysinger
0 siblings, 0 replies; 200+ results
From: Dan Baysinger @ 2005-10-26 1:41 UTC (permalink / raw)
I use mmap'ed storage for essentially the same reasons that you gave.
However, I just derived from System.Storage_Pools.Root_Storage_Pool and
overrode all of the subprograms to allocate the requested objects
using mmap and deallocate with unmap.
The Root_Storage _Pool type was extended with a private pointer to a
linked list of allocations made for the client's storage pool. I used
an opaque type (incomplete declaration in the spec's private area and
completion in the body) for the elements of the allocation linked list
to discourage (not actually prevent) users from trying to manipulate the
allocations directly.
You need to override finalization so that it walks the allocation list
and unmaps all allocations for the user's storage pool.
Also, I mmapped to /dev/zero so that an actual file was not created.
This has worked quite well for my purposes, and its usage is completely
compatible with the storage_pool specification for access types, the
'new' allocator, and Ada.Unchecked_Deallocation. From the user's
perspective the behavior is identical to that of a storage pool created
System.Storage_Pools.Root_Storage_Pool.
Dan Baysinger
Freejack wrote:
> Ada Storage Pools, in Unix/Posix type environments, are typically
> handled via the omnipresent C malloc() routine. While this undoubtedly
> simplifies compiler/runtime development, it has left me desiring a
> mechanism with a bit more control.
>
> So I've begun working on a library that allocates storage pools through
> the lower level mmap() suite of system utilities. I'm tentatively calling
> it Custom_Storage.Mapped_Pools
>
> It's intended use is for very large allocations that are intended to be
> returned to the system upon finalization, rather than having the extra
> memory linger in the program's process "space".
>
> Such a package's interfaces need to be carefully designed so as to prevent
> it's client developers from going ape shit every time they need a clear
> definition of exactly what the routine is going to do to the rest of their
> process space. Hence I would like some advice. How would you like to see
> such a package laid out? Should I make a set of thick or thin bindings to
> the mmap() facilities to go along with the Mapped_Pools package? What
> things should I keep in mind as to making the package portable to other
> environments with an mmap() facility?
>
> Any tips would be appreciated.
>
> Freejack
^ permalink raw reply [relevance 5%]
* Adding support for multiple tasks in wxAda
@ 2005-10-25 14:02 3% Lucretia
0 siblings, 0 replies; 200+ results
From: Lucretia @ 2005-10-25 14:02 UTC (permalink / raw)
Hi,
Here's that question I promised I'd bring in ;-D
Here's the basic structure of wxAda types which can handle events.
<wx.Base.Event_Handler>
package wx.Base.Event_Handler is
-- This is the actual type (wxEvtHandler) we are creating here.
type Event_Handler_Type is new wx.Base.Object.Object_Type with
private;
...
procedure Add_Pending_Event(
Self : in out Event_Handler_Type;
Event : in wxEvent.Event_Type);
-- The Connect procedure need to be a generic, so that the Callback
can be passed properly. It can be a number of different types.
generic
type Connect_Callback_Type is private;
procedure Connect(
Self : in Event_Handler_Type'Class;
Id,
LastId : in wx.Base.Id.Id_Type;
EventType : in wxEvent.Event_Id_Type;
Callback : in Connect_Callback_Type);
...
function Process_Event(
Self : in Event_Handler_Type;
Event : in wxEvent.Event_Type) return Boolean;
...
end wx.Base.Event_Handler;
</wx.Base.Event_Handler>
<wx.Core.Window>
package wx.Core.Window is
-- This is the actual type (wxWindow) we are creating here.
type Window_Type is new wx.Base.Event_Handler.Event_Handler_Type with
private;
...
end wx.Core.Window;
</wx.Core.Window>
<wx.Core.Control>
package wx.Core.Control is
-- This is the actual type (wxControl) we are creating here.
type Control_Type is new wx.Core.Window.Window_Type with private;
...
end wx.Core.Control;
</wx.Core.Control>
This basically means that all windows and controls can handle their own
events.
The Connect generic procedure in wx.Base.Event_Handler is used to
connect event id's to callbacks, it's this generic that glues the C/C++
code to the Ada code, via the C wxEvtHandler_Connect function. Within
this function I use a C++ static function as the basic event handler
callback and package up the data passed to Connect from wxAda as the
callback data. Then within this callback, I then unpack the data from
wxAda and call the event handler within Ada (exported as a C function).
<wxbase_evthandler.cc>
void wxAdaCallbackObject::EventHandler(wxEvent &Event)
{
wxAdaCallbackObject *CallbackObject =
wx_static_cast(wxAdaCallbackObject *,
Event.m_callbackUserData);
Ada_Event_Handler(
CallbackObject->_ParentEventHandler,
CallbackObject->_Callback,
&Event,
Event.GetClassInfo()->GetClassName());
}
void wxEvtHandler_Connect(
wxAdaEvtHandler *Self,
int Id,
int LastId,
int EventType,
void *ParentEventHandler,
void *Callback)
{
wxObjectEventFunction EventCallback =
wx_static_cast(wxObjectEventFunction,
&wxAdaCallbackObject::EventHandler);
Self->Connect(
Id,
LastId,
EventType,
EventCallback,
new wxAdaCallbackObject(ParentEventHandler, Callback));
}
</wxbase_evthandler.cc>
>From this function I then determine whether it is a wxAda derived type
(inside Create_Ada_Event). If so, there exists a wxAda type which I can
just get hold of otherwise I "new" a proxy type. This returned event
type is then passed as a parameter to the actual Ada callback function
which was originally passed to the Connect generic above.
This proxy type has to be allocated dynamically, because at this point
we only know an event has been triggered, but not which type of event.
Inside the event handler (at the Ada level) the programmer will provide
a callback with the correct event type as a parameter, so we implicitly
convert the event type to the correct type to get the extra primitives
and/or data that that event type implements.
<wx.Base.Event_Handler>
package body wx.Base.Event_Handler is
...
procedure Ada_Event_Handler(
Parent : Event_Handler_Class;
Callback : in Event_Function;
Event : in System.Address;
Class_Name : in Interfaces.C.Strings.chars_ptr) is
CXX_Class_Name : String :=
Interfaces.C.To_Ada(Interfaces.C.Strings.Value(Class_Name));
Ada_Event : wxEvent.Event_Class := null;
type Event_Access is access all wxEvent.Event_Type;
procedure Free is new Ada.Unchecked_Deallocation(
Object => wxEvent.Event_Type,
Name => Event_Access);
function To_Access is new Ada.Unchecked_Conversion(
Source => wxEvent.Event_Class,
Target => Event_Access);
Ada_Event_Acccess : Event_Access := null;
begin
Text_IO.Put_Line("Ada_Event_Handler: " & CXX_Class_Name);
Ada_Event := Create_Ada_Event(Event, CXX_Class_Name);
Callback(Parent, wxEvent.Event_Type(Ada_Event.all));
if CXX_Class_Name /= "wxAdaEvent" then
-- The next line would work, if it didn't get called again on
exit of the app!
--Finalize(Ada_Event.all);
Ada_Event_Acccess := To_Access(Ada_Event);
Free(Ada_Event_Acccess);
end if;
return;
end Ada_Event_Handler;
...
end wx.Base.Event_Handler;
</wx.Base.Event_Handler>
In wxWidgets a programmer would normally create a window (usually a
wxPanel) and then layout the controls on this panel, all the event
handlers (the callbacks) for the controls would be connected to the
wxPanel rather than the individual controls. It would be possible to
set up an event handler for each control, but that's really a special
case.
So given a contrived example, some Panel_Type has some controls
displayed upon it. There are a load of event handlers connected to the
Panel_Type. We also have one task per control, which does some trivial
update by sending events to the Panel_Type. Now we need to make the
event handling protected in some way, but seeing as Ada_Event_Handler
is essentially called from C this could be a problem. If I were to
create a protected type for handling events, can this safely be called
from C or from within a C function (Ada_Event_Handler)?
Thanks,
Luke.
^ permalink raw reply [relevance 3%]
* Re: Ada memory management seems slow
2005-10-13 18:39 6% ` Makhno
2005-10-14 9:59 0% ` Alex R. Mosteo
2005-10-14 14:49 0% ` Martin Krischik
@ 2005-10-16 0:40 7% ` Robert A Duff
2 siblings, 0 replies; 200+ results
From: Robert A Duff @ 2005-10-16 0:40 UTC (permalink / raw)
"Makhno" <root@127.0.0.1> writes:
> > GNAT uses malloc and free from the C library for memory management - so
> > performace is the same as with C. Only with C nobody measures the
> > performance - people just expect malloc and free to be as fast as
> > possible.
>
> I find this difficult to believe - I have experience of using free() in C,
> and unless the lists are far bigger than I think they are, C is nowhere near
> as slow as this.
> Is there any way I can check precisely what Ada is using?
You can dump out the assembly language produced by the compiler.
You can read the run-time library sources.
You can single-step through the code using gdb.
>...The program is
> calling something called FREE which is defined as some sort of deallocator
> called Ada.Unchecked_Deallocation
Yeah, that's the usual way to deallocate things in Ada --
Unchecked_Deallocation is pretty-much analogous to free() in C.
I'm pretty sure Unchecked_Deallocation uses the same "free()" that C
code would use. It's not very efficient (I've written more
efficient allocators), but it's not horrible.
What makes you think that memory deallocation is the problem?
Perhaps some other code is causing the problem.
I mentioned finalization in another post.
Also, Ada needs to do some locking around memory [de]allocation
primitives; that might be something to look into.
- Bob
^ permalink raw reply [relevance 7%]
* Re: Ada memory management seems slow
2005-10-13 18:39 6% ` Makhno
2005-10-14 9:59 0% ` Alex R. Mosteo
@ 2005-10-14 14:49 0% ` Martin Krischik
2005-10-16 0:40 7% ` Robert A Duff
2 siblings, 0 replies; 200+ results
From: Martin Krischik @ 2005-10-14 14:49 UTC (permalink / raw)
Makhno wrote:
>> GNAT uses malloc and free from the C library for memory management - so
>> performace is the same as with C. Only with C nobody measures the
>> performance - people just expect malloc and free to be as fast as
>> possible.
>
> I find this difficult to believe - I have experience of using free() in C,
> and unless the lists are far bigger than I think they are, C is nowhere
> near as slow as this.
Do you use Ada.Finalization? Ada.Finalization can eat performace when
compared with C. C does not have automatic finalisation.
> Is there any way I can check precisely what Ada is using? The program is
> calling something called FREE which is defined as some sort of deallocator
> called Ada.Unchecked_Deallocation
You can look up the source code. From you installation directory you should
have something like:
.../lib/gcc/x86_64-unknown-linux-gnu/3.4.5/adainclude
Where you find almost the full sources for all gnat library functions. Look
at s-crtl.ads where the actual malloc call is.
>>> I was wondering what options are available for memory management, or
>>> whether I am inadvertently using a 'slow' mode.
>>
>> Well there is indeed a memory debug option - but its off by default.
>
> I'm using gnatmake with -O3.
In which case GNAT will automaticy inline if possible - using the sources
mentioned above ;-)
Well, I have a cold - maybe someone else can elaborate on finalisation.
Martin
--
mailto://krischik@users.sourceforge.net
Ada programming at: http://ada.krischik.com
^ permalink raw reply [relevance 0%]
* Re: Ada memory management seems slow
2005-10-13 18:39 6% ` Makhno
@ 2005-10-14 9:59 0% ` Alex R. Mosteo
2005-10-14 14:49 0% ` Martin Krischik
2005-10-16 0:40 7% ` Robert A Duff
2 siblings, 0 replies; 200+ results
From: Alex R. Mosteo @ 2005-10-14 9:59 UTC (permalink / raw)
Makhno wrote:
>>GNAT uses malloc and free from the C library for memory management - so
>>performace is the same as with C. Only with C nobody measures the
>>performance - people just expect malloc and free to be as fast as
>>possible.
>
>
> I find this difficult to believe - I have experience of using free() in C,
> and unless the lists are far bigger than I think they are, C is nowhere near
> as slow as this.
> Is there any way I can check precisely what Ada is using? The program is
> calling something called FREE which is defined as some sort of deallocator
> called Ada.Unchecked_Deallocation
I'd look in what others have indicated: Is Finalization involved? How
many objects are you finalizing? Is there some expensive computation
taking place there?
Other than that, you could use some profiler. People has reported mixed
success with gprof (look for past threads in this group); valgrind could
be of use too.
>>>I was wondering what options are available for memory management, or
>>>whether I am inadvertently using a 'slow' mode.
>>
>>Well there is indeed a memory debug option - but its off by default.
>
>
> I'm using gnatmake with -O3.
>
>
^ permalink raw reply [relevance 0%]
* Re: Ada memory management seems slow
@ 2005-10-13 18:39 6% ` Makhno
2005-10-14 9:59 0% ` Alex R. Mosteo
` (2 more replies)
0 siblings, 3 replies; 200+ results
From: Makhno @ 2005-10-13 18:39 UTC (permalink / raw)
> GNAT uses malloc and free from the C library for memory management - so
> performace is the same as with C. Only with C nobody measures the
> performance - people just expect malloc and free to be as fast as
> possible.
I find this difficult to believe - I have experience of using free() in C,
and unless the lists are far bigger than I think they are, C is nowhere near
as slow as this.
Is there any way I can check precisely what Ada is using? The program is
calling something called FREE which is defined as some sort of deallocator
called Ada.Unchecked_Deallocation
>> I was wondering what options are available for memory management, or
>> whether I am inadvertently using a 'slow' mode.
>
> Well there is indeed a memory debug option - but its off by default.
I'm using gnatmake with -O3.
^ permalink raw reply [relevance 6%]
* Re: Memeory management
@ 2005-09-05 21:43 5% ` tmoran
0 siblings, 0 replies; 200+ results
From: tmoran @ 2005-09-05 21:43 UTC (permalink / raw)
>wonder that are there any constrains on the memory allocated for
>variable declaraions? However, I did not allocate and deallocate memory
>as I did in C, does Ada provide automatically garbage collection?
A particular Ada compiler, with a particular set of compile options,
and a particular OS, and a particular target machine, will of course
have some particular memory limitation. How much memory do you need?
If you declare variables in the ordinary way, e.g.
procedure P(N : Positive) is
Vector : array(1 .. N) of Integer;
Bigger_Vector : array(1 .. 5*N) of Integer;
Var1, Var2 : Float;
begin
Ada will automatically allocate space for Vector, Bigger_Vector, Var1, and
Var2 at the beginning and deallocate on exit.
If you allocate explicitly from the heap using access types (pointers)
and "new" then the Ada specification does not say whether the
implementation must do automatic garbage collection or not. Most don't,
so you would need to explicitly use Ada.Unchecked_Deallocation to do your
deallocations. (Many Ada applications are real time and it would be be
Bad if your train control program started doing extensive garbage
collection just when a sensor detected an obstacle on the track.)
^ permalink raw reply [relevance 5%]
* Re: Ada.Containers.Indefinite_Ordered_Maps of gcc 4.0.1 has bug ?
@ 2005-08-06 13:13 3% ` Y.Tomino
0 siblings, 0 replies; 200+ results
From: Y.Tomino @ 2005-08-06 13:13 UTC (permalink / raw)
To: Matthew Heaney
[-- Attachment #1: Type: text/plain, Size: 745 bytes --]
I send a-ciorma.ad? as attachments.
(C:\mingw\lib\gcc\i686-pc-mingw32\4.0.1\adainclude\a-ciorma.ads,
C:\mingw\lib\gcc\i686-pc-mingw32\4.0.1\adainclude\a-ciorma.adb)
I built gcc 4.0.1 with "--enable-languages=c,ada,c++ --prefix=/mingw".
Thanks.
YT
Matthew Heaney wrote:
> "Y.Tomino" <demoonlit@panathenaia.halfmoon.jp> writes:
>
>
>>Ada.Containers.Indefinite_Ordered_Maps.Adjust seems to me having bug.
>>Although good if it's my misunderstanding.
>
>
> I just ran your examples, and didn't get any exceptions.
>
> It might be the case that you're using an older version of the sources.
> Can you go into your adainclude directory, and send me your copies of
> a-ciorma.ad?. (That, or send me the context around line 407.)
>
> -Matt
[-- Attachment #2: a-ciorma.ads --]
[-- Type: text/plain, Size: 7655 bytes --]
------------------------------------------------------------------------------
-- --
-- GNAT LIBRARY COMPONENTS --
-- --
-- ADA.CONTAINERS.INDEFINITE_ORDERED_MAPS --
-- --
-- S p e c --
-- --
-- Copyright (C) 2004 Free Software Foundation, Inc. --
-- --
-- This specification is derived from the Ada Reference Manual for use with --
-- GNAT. The copyright notice above, and the license provisions that follow --
-- apply solely to the contents of the part following the private keyword. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
-- ware Foundation; either version 2, or (at your option) any later ver- --
-- sion. GNAT is distributed in the hope that it will be useful, but WITH- --
-- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY --
-- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License --
-- for more details. You should have received a copy of the GNU General --
-- Public License distributed with GNAT; see file COPYING. If not, write --
-- to the Free Software Foundation, 59 Temple Place - Suite 330, Boston, --
-- MA 02111-1307, USA. --
-- --
-- As a special exception, if other files instantiate generics from this --
-- unit, or you link this unit with other files to produce an executable, --
-- this unit does not by itself cause the resulting executable to be --
-- covered by the GNU General Public License. This exception does not --
-- however invalidate any other reasons why the executable file might be --
-- covered by the GNU Public License. --
-- --
-- This unit was originally developed by Matthew J Heaney. --
------------------------------------------------------------------------------
with Ada.Containers.Red_Black_Trees;
with Ada.Finalization;
with Ada.Streams;
generic
type Key_Type (<>) is private;
type Element_Type (<>) is private;
with function "<" (Left, Right : Key_Type) return Boolean is <>;
with function "=" (Left, Right : Element_Type) return Boolean is <>;
package Ada.Containers.Indefinite_Ordered_Maps is
pragma Preelaborate (Indefinite_Ordered_Maps);
type Map is tagged private;
type Cursor is private;
Empty_Map : constant Map;
No_Element : constant Cursor;
function "=" (Left, Right : Map) return Boolean;
function Length (Container : Map) return Count_Type;
function Is_Empty (Container : Map) return Boolean;
procedure Clear (Container : in out Map);
function Key (Position : Cursor) return Key_Type;
function Element (Position : Cursor) return Element_Type;
procedure Query_Element
(Position : Cursor;
Process : not null access procedure (Key : Key_Type;
Element : Element_Type));
procedure Update_Element
(Position : Cursor;
Process : not null access procedure (Key : Key_Type;
Element : in out Element_Type));
procedure Replace_Element (Position : Cursor; By : Element_Type);
procedure Move (Target : in out Map; Source : in out Map);
procedure Insert
(Container : in out Map;
Key : Key_Type;
New_Item : Element_Type;
Position : out Cursor;
Inserted : out Boolean);
procedure Insert
(Container : in out Map;
Key : Key_Type;
New_Item : Element_Type);
procedure Include
(Container : in out Map;
Key : Key_Type;
New_Item : Element_Type);
procedure Replace
(Container : in out Map;
Key : Key_Type;
New_Item : Element_Type);
procedure Delete
(Container : in out Map;
Key : Key_Type);
procedure Exclude
(Container : in out Map;
Key : Key_Type);
procedure Delete
(Container : in out Map;
Position : in out Cursor);
procedure Delete_First (Container : in out Map);
procedure Delete_Last (Container : in out Map);
function Contains
(Container : Map;
Key : Key_Type) return Boolean;
function Find
(Container : Map;
Key : Key_Type) return Cursor;
function Element
(Container : Map;
Key : Key_Type) return Element_Type;
function Floor
(Container : Map;
Key : Key_Type) return Cursor;
function Ceiling
(Container : Map;
Key : Key_Type) return Cursor;
function First (Container : Map) return Cursor;
function First_Key (Container : Map) return Key_Type;
function First_Element (Container : Map) return Element_Type;
function Last (Container : Map) return Cursor;
function Last_Key (Container : Map) return Key_Type;
function Last_Element (Container : Map) return Element_Type;
function Next (Position : Cursor) return Cursor;
function Previous (Position : Cursor) return Cursor;
procedure Next (Position : in out Cursor);
procedure Previous (Position : in out Cursor);
function Has_Element (Position : Cursor) return Boolean;
function "<" (Left, Right : Cursor) return Boolean;
function ">" (Left, Right : Cursor) return Boolean;
function "<" (Left : Cursor; Right : Key_Type) return Boolean;
function ">" (Left : Cursor; Right : Key_Type) return Boolean;
function "<" (Left : Key_Type; Right : Cursor) return Boolean;
function ">" (Left : Key_Type; Right : Cursor) return Boolean;
procedure Iterate
(Container : Map;
Process : not null access procedure (Position : Cursor));
procedure Reverse_Iterate
(Container : Map;
Process : not null access procedure (Position : Cursor));
private
type Node_Type;
type Node_Access is access Node_Type;
package Tree_Types is
new Red_Black_Trees.Generic_Tree_Types (Node_Access);
use Tree_Types;
use Ada.Finalization;
type Map is new Controlled with record
Tree : Tree_Type := (Length => 0, others => null);
end record;
procedure Adjust (Container : in out Map);
procedure Finalize (Container : in out Map) renames Clear;
type Map_Access is access constant Map;
for Map_Access'Storage_Size use 0;
type Cursor is record
Container : Map_Access;
Node : Node_Access;
end record;
No_Element : constant Cursor := Cursor'(null, null);
use Ada.Streams;
procedure Write
(Stream : access Root_Stream_Type'Class;
Container : Map);
for Map'Write use Write;
procedure Read
(Stream : access Root_Stream_Type'Class;
Container : out Map);
for Map'Read use Read;
Empty_Map : constant Map :=
(Controlled with Tree => (Length => 0, others => null));
end Ada.Containers.Indefinite_Ordered_Maps;
[-- Attachment #3: a-ciorma.adb --]
[-- Type: text/plain, Size: 25588 bytes --]
------------------------------------------------------------------------------
-- --
-- GNAT LIBRARY COMPONENTS --
-- --
-- ADA.CONTAINERS.INDEFINITE_ORDERED_MAPS --
-- --
-- B o d y --
-- --
-- Copyright (C) 2004 Free Software Foundation, Inc. --
-- --
-- This specification is derived from the Ada Reference Manual for use with --
-- GNAT. The copyright notice above, and the license provisions that follow --
-- apply solely to the contents of the part following the private keyword. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
-- ware Foundation; either version 2, or (at your option) any later ver- --
-- sion. GNAT is distributed in the hope that it will be useful, but WITH- --
-- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY --
-- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License --
-- for more details. You should have received a copy of the GNU General --
-- Public License distributed with GNAT; see file COPYING. If not, write --
-- to the Free Software Foundation, 59 Temple Place - Suite 330, Boston, --
-- MA 02111-1307, USA. --
-- --
-- As a special exception, if other files instantiate generics from this --
-- unit, or you link this unit with other files to produce an executable, --
-- this unit does not by itself cause the resulting executable to be --
-- covered by the GNU General Public License. This exception does not --
-- however invalidate any other reasons why the executable file might be --
-- covered by the GNU Public License. --
-- --
-- This unit was originally developed by Matthew J Heaney. --
------------------------------------------------------------------------------
with Ada.Unchecked_Deallocation;
with Ada.Containers.Red_Black_Trees.Generic_Operations;
pragma Elaborate_All (Ada.Containers.Red_Black_Trees.Generic_Operations);
with Ada.Containers.Red_Black_Trees.Generic_Keys;
pragma Elaborate_All (Ada.Containers.Red_Black_Trees.Generic_Keys);
with System; use type System.Address;
package body Ada.Containers.Indefinite_Ordered_Maps is
use Red_Black_Trees;
type Key_Access is access Key_Type;
type Element_Access is access Element_Type;
type Node_Type is limited record
Parent : Node_Access;
Left : Node_Access;
Right : Node_Access;
Color : Red_Black_Trees.Color_Type := Red;
Key : Key_Access;
Element : Element_Access;
end record;
-----------------------------
-- Node Access Subprograms --
-----------------------------
-- These subprograms provide a functional interface to access fields
-- of a node, and a procedural interface for modifying these values.
function Color (Node : Node_Access) return Color_Type;
pragma Inline (Color);
function Left (Node : Node_Access) return Node_Access;
pragma Inline (Left);
function Parent (Node : Node_Access) return Node_Access;
pragma Inline (Parent);
function Right (Node : Node_Access) return Node_Access;
pragma Inline (Right);
procedure Set_Parent (Node : Node_Access; Parent : Node_Access);
pragma Inline (Set_Parent);
procedure Set_Left (Node : Node_Access; Left : Node_Access);
pragma Inline (Set_Left);
procedure Set_Right (Node : Node_Access; Right : Node_Access);
pragma Inline (Set_Right);
procedure Set_Color (Node : Node_Access; Color : Color_Type);
pragma Inline (Set_Color);
-----------------------
-- Local Subprograms --
-----------------------
function Copy_Node (Source : Node_Access) return Node_Access;
pragma Inline (Copy_Node);
function Copy_Tree (Source_Root : Node_Access) return Node_Access;
procedure Delete_Tree (X : in out Node_Access);
procedure Free (X : in out Node_Access);
function Is_Equal_Node_Node
(L, R : Node_Access) return Boolean;
pragma Inline (Is_Equal_Node_Node);
function Is_Greater_Key_Node
(Left : Key_Type;
Right : Node_Access) return Boolean;
pragma Inline (Is_Greater_Key_Node);
function Is_Less_Key_Node
(Left : Key_Type;
Right : Node_Access) return Boolean;
pragma Inline (Is_Less_Key_Node);
--------------------------
-- Local Instantiations --
--------------------------
package Tree_Operations is
new Red_Black_Trees.Generic_Operations
(Tree_Types => Tree_Types,
Null_Node => Node_Access'(null));
use Tree_Operations;
package Key_Ops is
new Red_Black_Trees.Generic_Keys
(Tree_Operations => Tree_Operations,
Key_Type => Key_Type,
Is_Less_Key_Node => Is_Less_Key_Node,
Is_Greater_Key_Node => Is_Greater_Key_Node);
procedure Free_Key is
new Ada.Unchecked_Deallocation (Key_Type, Key_Access);
procedure Free_Element is
new Ada.Unchecked_Deallocation (Element_Type, Element_Access);
function Is_Equal is
new Tree_Operations.Generic_Equal (Is_Equal_Node_Node);
---------
-- "<" --
---------
function "<" (Left, Right : Cursor) return Boolean is
begin
return Left.Node.Key.all < Right.Node.Key.all;
end "<";
function "<" (Left : Cursor; Right : Key_Type) return Boolean is
begin
return Left.Node.Key.all < Right;
end "<";
function "<" (Left : Key_Type; Right : Cursor) return Boolean is
begin
return Left < Right.Node.Key.all;
end "<";
---------
-- "=" --
---------
function "=" (Left, Right : Map) return Boolean is
begin
if Left'Address = Right'Address then
return True;
end if;
return Is_Equal (Left.Tree, Right.Tree);
end "=";
---------
-- ">" --
---------
function ">" (Left, Right : Cursor) return Boolean is
begin
return Right.Node.Key.all < Left.Node.Key.all;
end ">";
function ">" (Left : Cursor; Right : Key_Type) return Boolean is
begin
return Right < Left.Node.Key.all;
end ">";
function ">" (Left : Key_Type; Right : Cursor) return Boolean is
begin
return Right.Node.Key.all < Left;
end ">";
------------
-- Adjust --
------------
procedure Adjust (Container : in out Map) is
Tree : Tree_Type renames Container.Tree;
N : constant Count_Type := Tree.Length;
X : constant Node_Access := Tree.Root;
begin
if N = 0 then
pragma Assert (X = null);
return;
end if;
Tree := (Length => 0, others => null);
Tree.Root := Copy_Tree (X);
Tree.First := Min (Tree.Root);
Tree.Last := Max (Tree.Root);
Tree.Length := N;
end Adjust;
-------------
-- Ceiling --
-------------
function Ceiling (Container : Map; Key : Key_Type) return Cursor is
Node : constant Node_Access := Key_Ops.Ceiling (Container.Tree, Key);
begin
if Node = null then
return No_Element;
else
return Cursor'(Container'Unchecked_Access, Node);
end if;
end Ceiling;
-----------
-- Clear --
-----------
procedure Clear (Container : in out Map) is
Tree : Tree_Type renames Container.Tree;
Root : Node_Access := Tree.Root;
begin
Tree := (Length => 0, others => null);
Delete_Tree (Root);
end Clear;
-----------
-- Color --
-----------
function Color (Node : Node_Access) return Color_Type is
begin
return Node.Color;
end Color;
--------------
-- Contains --
--------------
function Contains (Container : Map; Key : Key_Type) return Boolean is
begin
return Find (Container, Key) /= No_Element;
end Contains;
---------------
-- Copy_Node --
---------------
function Copy_Node (Source : Node_Access) return Node_Access is
Target : constant Node_Access :=
new Node_Type'(Parent => null,
Left => null,
Right => null,
Color => Source.Color,
Key => Source.Key,
Element => Source.Element);
begin
return Target;
end Copy_Node;
---------------
-- Copy_Tree --
---------------
function Copy_Tree (Source_Root : Node_Access) return Node_Access is
Target_Root : Node_Access := Copy_Node (Source_Root);
P, X : Node_Access;
begin
if Source_Root.Right /= null then
Target_Root.Right := Copy_Tree (Source_Root.Right);
Target_Root.Right.Parent := Target_Root;
end if;
P := Target_Root;
X := Source_Root.Left;
while X /= null loop
declare
Y : Node_Access := Copy_Node (X);
begin
P.Left := Y;
Y.Parent := P;
if X.Right /= null then
Y.Right := Copy_Tree (X.Right);
Y.Right.Parent := Y;
end if;
P := Y;
X := X.Left;
end;
end loop;
return Target_Root;
exception
when others =>
Delete_Tree (Target_Root);
raise;
end Copy_Tree;
------------
-- Delete --
------------
procedure Delete
(Container : in out Map;
Position : in out Cursor)
is
begin
if Position = No_Element then
return;
end if;
if Position.Container /= Map_Access'(Container'Unchecked_Access) then
raise Program_Error;
end if;
Delete_Node_Sans_Free (Container.Tree, Position.Node);
Free (Position.Node);
Position.Container := null;
end Delete;
procedure Delete (Container : in out Map; Key : Key_Type) is
X : Node_Access := Key_Ops.Find (Container.Tree, Key);
begin
if X = null then
raise Constraint_Error;
else
Delete_Node_Sans_Free (Container.Tree, X);
Free (X);
end if;
end Delete;
------------------
-- Delete_First --
------------------
procedure Delete_First (Container : in out Map) is
Position : Cursor := First (Container);
begin
Delete (Container, Position);
end Delete_First;
-----------------
-- Delete_Last --
-----------------
procedure Delete_Last (Container : in out Map) is
Position : Cursor := Last (Container);
begin
Delete (Container, Position);
end Delete_Last;
-----------------
-- Delete_Tree --
-----------------
procedure Delete_Tree (X : in out Node_Access) is
Y : Node_Access;
begin
while X /= null loop
Y := X.Right;
Delete_Tree (Y);
Y := X.Left;
Free (X);
X := Y;
end loop;
end Delete_Tree;
-------------
-- Element --
-------------
function Element (Position : Cursor) return Element_Type is
begin
return Position.Node.Element.all;
end Element;
function Element (Container : Map; Key : Key_Type) return Element_Type is
Node : constant Node_Access := Key_Ops.Find (Container.Tree, Key);
begin
return Node.Element.all;
end Element;
-------------
-- Exclude --
-------------
procedure Exclude (Container : in out Map; Key : Key_Type) is
X : Node_Access := Key_Ops.Find (Container.Tree, Key);
begin
if X /= null then
Delete_Node_Sans_Free (Container.Tree, X);
Free (X);
end if;
end Exclude;
----------
-- Find --
----------
function Find (Container : Map; Key : Key_Type) return Cursor is
Node : constant Node_Access := Key_Ops.Find (Container.Tree, Key);
begin
if Node = null then
return No_Element;
else
return Cursor'(Container'Unchecked_Access, Node);
end if;
end Find;
-----------
-- First --
-----------
function First (Container : Map) return Cursor is
begin
if Container.Tree.First = null then
return No_Element;
else
return Cursor'(Container'Unchecked_Access, Container.Tree.First);
end if;
end First;
-------------------
-- First_Element --
-------------------
function First_Element (Container : Map) return Element_Type is
begin
return Container.Tree.First.Element.all;
end First_Element;
---------------
-- First_Key --
---------------
function First_Key (Container : Map) return Key_Type is
begin
return Container.Tree.First.Key.all;
end First_Key;
-----------
-- Floor --
-----------
function Floor (Container : Map; Key : Key_Type) return Cursor is
Node : constant Node_Access := Key_Ops.Floor (Container.Tree, Key);
begin
if Node = null then
return No_Element;
else
return Cursor'(Container'Unchecked_Access, Node);
end if;
end Floor;
----------
-- Free --
----------
procedure Free (X : in out Node_Access) is
procedure Deallocate is
new Ada.Unchecked_Deallocation (Node_Type, Node_Access);
begin
if X /= null then
Free_Key (X.Key);
Free_Element (X.Element);
Deallocate (X);
end if;
end Free;
-----------------
-- Has_Element --
-----------------
function Has_Element (Position : Cursor) return Boolean is
begin
return Position /= No_Element;
end Has_Element;
-------------
-- Include --
-------------
procedure Include
(Container : in out Map;
Key : Key_Type;
New_Item : Element_Type)
is
Position : Cursor;
Inserted : Boolean;
K : Key_Access;
E : Element_Access;
begin
Insert (Container, Key, New_Item, Position, Inserted);
if not Inserted then
K := Position.Node.Key;
E := Position.Node.Element;
Position.Node.Key := new Key_Type'(Key);
Position.Node.Element := new Element_Type'(New_Item);
Free_Key (K);
Free_Element (E);
end if;
end Include;
------------
-- Insert --
------------
procedure Insert
(Container : in out Map;
Key : Key_Type;
New_Item : Element_Type;
Position : out Cursor;
Inserted : out Boolean)
is
function New_Node return Node_Access;
pragma Inline (New_Node);
procedure Insert_Post is
new Key_Ops.Generic_Insert_Post (New_Node);
procedure Insert_Sans_Hint is
new Key_Ops.Generic_Conditional_Insert (Insert_Post);
--------------
-- New_Node --
--------------
function New_Node return Node_Access is
Node : Node_Access := new Node_Type;
begin
Node.Key := new Key_Type'(Key);
Node.Element := new Element_Type'(New_Item);
return Node;
exception
when others =>
-- On exception, deallocate key and elem
Free (Node);
raise;
end New_Node;
-- Start of processing for Insert
begin
Insert_Sans_Hint
(Container.Tree,
Key,
Position.Node,
Inserted);
Position.Container := Container'Unchecked_Access;
end Insert;
procedure Insert
(Container : in out Map;
Key : Key_Type;
New_Item : Element_Type)
is
Position : Cursor;
Inserted : Boolean;
begin
Insert (Container, Key, New_Item, Position, Inserted);
if not Inserted then
raise Constraint_Error;
end if;
end Insert;
--------------
-- Is_Empty --
--------------
function Is_Empty (Container : Map) return Boolean is
begin
return Container.Tree.Length = 0;
end Is_Empty;
------------------------
-- Is_Equal_Node_Node --
------------------------
function Is_Equal_Node_Node
(L, R : Node_Access) return Boolean is
begin
return L.Element.all = R.Element.all;
end Is_Equal_Node_Node;
-------------------------
-- Is_Greater_Key_Node --
-------------------------
function Is_Greater_Key_Node
(Left : Key_Type;
Right : Node_Access) return Boolean
is
begin
-- k > node same as node < k
return Right.Key.all < Left;
end Is_Greater_Key_Node;
----------------------
-- Is_Less_Key_Node --
----------------------
function Is_Less_Key_Node
(Left : Key_Type;
Right : Node_Access) return Boolean is
begin
return Left < Right.Key.all;
end Is_Less_Key_Node;
-------------
-- Iterate --
-------------
procedure Iterate
(Container : Map;
Process : not null access procedure (Position : Cursor))
is
procedure Process_Node (Node : Node_Access);
pragma Inline (Process_Node);
procedure Local_Iterate is
new Tree_Operations.Generic_Iteration (Process_Node);
------------------
-- Process_Node --
------------------
procedure Process_Node (Node : Node_Access) is
begin
Process (Cursor'(Container'Unchecked_Access, Node));
end Process_Node;
-- Start of processing for Iterate
begin
Local_Iterate (Container.Tree);
end Iterate;
---------
-- Key --
---------
function Key (Position : Cursor) return Key_Type is
begin
return Position.Node.Key.all;
end Key;
----------
-- Last --
----------
function Last (Container : Map) return Cursor is
begin
if Container.Tree.Last = null then
return No_Element;
else
return Cursor'(Container'Unchecked_Access, Container.Tree.Last);
end if;
end Last;
------------------
-- Last_Element --
------------------
function Last_Element (Container : Map) return Element_Type is
begin
return Container.Tree.Last.Element.all;
end Last_Element;
--------------
-- Last_Key --
--------------
function Last_Key (Container : Map) return Key_Type is
begin
return Container.Tree.Last.Key.all;
end Last_Key;
----------
-- Left --
----------
function Left (Node : Node_Access) return Node_Access is
begin
return Node.Left;
end Left;
------------
-- Length --
------------
function Length (Container : Map) return Count_Type is
begin
return Container.Tree.Length;
end Length;
----------
-- Move --
----------
procedure Move (Target : in out Map; Source : in out Map) is
begin
if Target'Address = Source'Address then
return;
end if;
Move (Target => Target.Tree, Source => Source.Tree);
end Move;
----------
-- Next --
----------
function Next (Position : Cursor) return Cursor is
begin
if Position = No_Element then
return No_Element;
end if;
declare
Node : constant Node_Access := Tree_Operations.Next (Position.Node);
begin
if Node = null then
return No_Element;
else
return Cursor'(Position.Container, Node);
end if;
end;
end Next;
procedure Next (Position : in out Cursor) is
begin
Position := Next (Position);
end Next;
------------
-- Parent --
------------
function Parent (Node : Node_Access) return Node_Access is
begin
return Node.Parent;
end Parent;
--------------
-- Previous --
--------------
function Previous (Position : Cursor) return Cursor is
begin
if Position = No_Element then
return No_Element;
end if;
declare
Node : constant Node_Access :=
Tree_Operations.Previous (Position.Node);
begin
if Node = null then
return No_Element;
end if;
return Cursor'(Position.Container, Node);
end;
end Previous;
procedure Previous (Position : in out Cursor) is
begin
Position := Previous (Position);
end Previous;
-------------------
-- Query_Element --
-------------------
procedure Query_Element
(Position : Cursor;
Process : not null access procedure (Element : Element_Type))
is
begin
Process (Position.Node.Key.all, Position.Node.Element.all);
end Query_Element;
----------
-- Read --
----------
procedure Read
(Stream : access Root_Stream_Type'Class;
Container : out Map)
is
N : Count_Type'Base;
function New_Node return Node_Access;
pragma Inline (New_Node);
procedure Local_Read is new Tree_Operations.Generic_Read (New_Node);
--------------
-- New_Node --
--------------
function New_Node return Node_Access is
Node : Node_Access := new Node_Type;
begin
Node.Key := new Key_Type'(Key_Type'Input (Stream));
Node.Element := new Element_Type'(Element_Type'Input (Stream));
return Node;
exception
when others =>
-- Deallocate key and elem too on exception
Free (Node);
raise;
end New_Node;
-- Start of processing for Read
begin
Clear (Container);
Count_Type'Base'Read (Stream, N);
pragma Assert (N >= 0);
Local_Read (Container.Tree, N);
end Read;
-------------
-- Replace --
-------------
procedure Replace
(Container : in out Map;
Key : Key_Type;
New_Item : Element_Type)
is
Node : constant Node_Access :=
Key_Ops.Find (Container.Tree, Key);
K : Key_Access;
E : Element_Access;
begin
if Node = null then
raise Constraint_Error;
end if;
K := Node.Key;
E := Node.Element;
Node.Key := new Key_Type'(Key);
Node.Element := new Element_Type'(New_Item);
Free_Key (K);
Free_Element (E);
end Replace;
---------------------
-- Replace_Element --
---------------------
procedure Replace_Element (Position : Cursor; By : Element_Type) is
X : Element_Access := Position.Node.Element;
begin
Position.Node.Element := new Element_Type'(By);
Free_Element (X);
end Replace_Element;
---------------------
-- Reverse_Iterate --
---------------------
procedure Reverse_Iterate
(Container : Map;
Process : not null access procedure (Position : Cursor))
is
procedure Process_Node (Node : Node_Access);
pragma Inline (Process_Node);
procedure Local_Reverse_Iterate is
new Tree_Operations.Generic_Reverse_Iteration (Process_Node);
------------------
-- Process_Node --
------------------
procedure Process_Node (Node : Node_Access) is
begin
Process (Cursor'(Container'Unchecked_Access, Node));
end Process_Node;
-- Start of processing for Reverse_Iterate
begin
Local_Reverse_Iterate (Container.Tree);
end Reverse_Iterate;
-----------
-- Right --
-----------
function Right (Node : Node_Access) return Node_Access is
begin
return Node.Right;
end Right;
---------------
-- Set_Color --
---------------
procedure Set_Color (Node : Node_Access; Color : Color_Type) is
begin
Node.Color := Color;
end Set_Color;
--------------
-- Set_Left --
--------------
procedure Set_Left (Node : Node_Access; Left : Node_Access) is
begin
Node.Left := Left;
end Set_Left;
----------------
-- Set_Parent --
----------------
procedure Set_Parent (Node : Node_Access; Parent : Node_Access) is
begin
Node.Parent := Parent;
end Set_Parent;
---------------
-- Set_Right --
---------------
procedure Set_Right (Node : Node_Access; Right : Node_Access) is
begin
Node.Right := Right;
end Set_Right;
--------------------
-- Update_Element --
--------------------
procedure Update_Element
(Position : Cursor;
Process : not null access procedure (Element : in out Element_Type))
is
begin
Process (Position.Node.Key.all, Position.Node.Element.all);
end Update_Element;
-----------
-- Write --
-----------
procedure Write
(Stream : access Root_Stream_Type'Class;
Container : Map)
is
procedure Process (Node : Node_Access);
pragma Inline (Process);
procedure Iterate is
new Tree_Operations.Generic_Iteration (Process);
-------------
-- Process --
-------------
procedure Process (Node : Node_Access) is
begin
Key_Type'Output (Stream, Node.Key.all);
Element_Type'Output (Stream, Node.Element.all);
end Process;
-- Start of processing for Write
begin
Count_Type'Base'Write (Stream, Container.Tree.Length);
Iterate (Container.Tree);
end Write;
end Ada.Containers.Indefinite_Ordered_Maps;
^ permalink raw reply [relevance 3%]
* Re: Help needed for ada package
[not found] <1122305318.728942.304120@f14g2000cwb.googlegroups.com>
@ 2005-07-26 3:17 7% ` Steve
0 siblings, 0 replies; 200+ results
From: Steve @ 2005-07-26 3:17 UTC (permalink / raw)
<strictly_mk@hotmail.com> wrote in message
news:1122305318.728942.304120@f14g2000cwb.googlegroups.com...
> To anyone interested,
>
> I very urgently need this ada 95 package written for me and I am
> willing to pay anyone for their time. Here is the specification;
>
> The is supposed to be a basic database to monitor a group of made up
> citizens and their badness rating.
>
> generic
> type ID is (<>); --some discrete type to be put here
> package POP is
> --update database
> type Rating is new Integer range 0..255;
> procedure Rate (Citizen : in ID;
> Badness : in Rating);
> procedure Associate (Citizen_1, Citizen_2 : in ID);
> --query the database
> function Most_Dangerous return ID;
> function Next_Member return ID;
> function More_In_Group return Boolean;
> --administrative
> procedure reset;
> end POP;
>
Sorry I don't have enough time to write the whole thing write now, but
here's a start (maybe someone else will step in to fill in another routine):
with Ada.Unchecked_Deallocation;
package body POP is
type
RO0O is record lll1 : ID; ll1l : Rating; end record; type
ROO0 is array( positive range <> ) of
RO0O; type R0OO is access all ROO0;
procedure RO00 is new Ada.Unchecked_Deallocation( ROO0, R0OO );
R00O : R0OO; R0O0 : Natural := 0;
procedure Associate (Citizen_1, Citizen_2 : in ID) is
begin
null;
end Associate;
function More_In_Group return Boolean is
begin
return More_In_Group;
end More_In_Group;
function Most_Dangerous return ID is
begin
return Most_Dangerous;
end Most_Dangerous;
function Next_Member return ID is
begin
return Next_Member;
end Next_Member;
procedure Rate
(Citizen : in ID; Badness : in Rating) is begin
if R0O0 = 0 then R00O := new ROO0( 1 .. 100 ); end if;
if R0O0 + 1 > R00O.all'length then
declare R000 : R0OO; begin R000 := new
ROO0( 1 .. R0O0 + 100 ); R000.all( 1 .. R0O0 ) :=
R00O.all( 1 .. R0O0 ); RO00( R00O ); R00O :=
R000; end; end if; R0O0 := R0O0 + 1;
R00O( R0O0 ).lll1 := citizen; R00O( R0O0 ).ll1l := badness; end
Rate;
procedure reset is
begin
null;
end reset;
end POP;
Steve
(The Duck)
>
> You cannot change this specification in any way other than to insert
> the appropriate type for ID;
> As you can see this is supposed to be a database package, it should not
> however do any input or output to the screent as the GUI is being
> designed by someone else.
>
> Rate is supposed to enter a citizen with his/her ID (integer) and their
> badness (integer) into the database.
> Associate is used to tell the database two citizens are associated to
> be in the same group.
> Most_Dangerous is supposed to return the citizen with the highest
> badness rating. This function can do anything if the database is empty.
> Next_Member reports a previously unreported member of the group to
> which the most dangerous citizen belongs. This function can do anything
> if the there are no more unreported members.
> More_In_Group which is true exactly when there are unreported members
> of the group to which the most recently reported most dangerous citizen
> belongs. This function can do anything if there is no previous call to
> Most_Dangerous.
> The procedure rest resets the database to its original state.
>
> There will be no more than 1 million citizens entered. Updates should
> be optimised at the expense of queries. Do not worry too much about
> error handling.
>
> The program is supposed to be compiled on gnat. I require both the code
> and a compiled file.
>
> Again, if anyone is interested I'm willing to pay for your services.
>
^ permalink raw reply [relevance 7%]
* Re: Unchecked_Conversion and task pointer.
@ 2005-07-07 20:18 7% ` Dmitry A. Kazakov
0 siblings, 0 replies; 200+ results
From: Dmitry A. Kazakov @ 2005-07-07 20:18 UTC (permalink / raw)
On 7 Jul 2005 08:50:55 -0700, e.coli wrote:
> look at this exemple:
> ----------------------------------------------------
> with Ada.Unchecked_Conversion;
> with Ada.Text_Io;
>
> procedure Main is
>
> task type Cain is
> entry Who_Are_You;
> end Cain;
>
> task type Abel is
> entry Who_Are_You;
> end Abel;
>
> type Ptr_Cain is access Cain;
> type Ptr_Abel is access Abel;
>
> task body Cain is
> begin
> loop
> accept Who_Are_You;
> Ada.Text_Io.Put_Line(Item => "I'm Cain");
> end loop;
> end Cain;
>
>
> task body Abel is
> begin
> loop
> accept Who_Are_You;
> Ada.Text_Io.Put_Line(Item => "I'm Abel");
> end loop;
> end Abel;
>
>
> function Mess_Up is
> new Ada.Unchecked_Conversion
> (
> Source => Ptr_Cain,
> Target => Ptr_Abel);
>
> X : Ptr_Cain;
> Y : Ptr_Abel;
>
> begin
> X:= new Cain;
> Y:= new Abel;
> X.Who_Are_You;
> Y.Who_Are_You;
> Y:=Mess_Up(X);
> -- where are your brother?
> X.Who_Are_You;
> Y.Who_Are_You;
> end Main;
> ------------------------------------------------
>
> how work Unchecked_Conversion with task pointer?
Better not to know... (:-))
> the behavior depend by the compiler?
Task types are not tagged in Ada (alas). So if you are trying to have a
kind of task types hierarchy you should use mix-in. Example:
with Ada.Unchecked_Deallocation;
package Persons is
type Corpse is abstract tagged null record;
function Get_Name (Context : Corpse) return String is abstract;
task type Soul (Context : access Corpse'Class) is
entry Who_Are_You;
end Soul;
type Soul_Ptr is access all Soul;
procedure Free is new Ada.Unchecked_Deallocation (Soul, Soul_Ptr);
type Abel is new Corpse with null record;
function Get_Name (Context : Abel) return String;
type Cain is new Corpse with null record;
function Get_Name (Context : Cain) return String;
end Persons;
----------------------
with Ada.Text_IO;
package body Persons is
task body Soul is
begin
loop
select
accept Who_Are_You;
Ada.Text_IO.Put_Line ("I'm " & Get_Name (Context.all));
or terminate;
end select;
end loop;
end Soul;
function Get_Name (Context : Abel) return String is
begin
return "Abel";
end Get_Name;
function Get_Name (Context : Cain) return String is
begin
return "Cain";
end Get_Name;
end Persons;
------------------------
with Persons; use Persons;
procedure Test is
X : aliased Abel;
Y : aliased Cain;
Ptr : Soul_Ptr;
begin
Ptr := new Soul (X'Unchecked_Access);
Ptr.Who_Are_You;
Free (Ptr);
Ptr := new Soul (Y'Unchecked_Access);
Ptr.Who_Are_You;
Free (Ptr);
delay 1.0; -- Let Text_IO task flush all buffers
end Test;
--
Regards,
Dmitry A. Kazakov
http://www.dmitry-kazakov.de
^ permalink raw reply [relevance 7%]
* Memory_Management
@ 2005-04-19 1:39 5% Bini
0 siblings, 0 replies; 200+ results
From: Bini @ 2005-04-19 1:39 UTC (permalink / raw)
with Ada.Finalization;
with Memory_Management;
package Pkg is
My_Pool : Memory_Management.User_Pool(Size => 500);
type My_Int is access Integer;
for My_Int'Storage_Pool use My_Pool;
type My_Data is new Ada.Finalization.Controlled with record
Value : My_Int;
end record;
procedure Initialize(Data : in out My_Data);
procedure Finalize(Data : in out My_Data);
end Pkg;
with Ada.Unchecked_Deallocation;
package body Pkg is
.
.
procedure Finalize(Data : in out My_Data) is
begin
Free(Data.Value);
end Finalize;
.
.
end Pkg;
with Ada.Text_IO;
with Ada.Finalization;
with Pkg;
procedure Fun is
package TIO renames Ada.Text_IO;
package AF renames Ada.Finalization;
I1, I2 : Pkg.My_Data;
I3 : Pkg.My_Int;
begin
I1 := (AF.Controlled with Value => new Integer'(123));
TIO.Put_Line(I1.Value.all'Img);
I2 := (AF.Controlled with Value => new Integer'(456));
TIO.Put_Line(I2.Value.all'Img);
I3 := new Integer'(789);
TIO.Put_Line(I3.all'Img);
end Fun;
===> I write some test code with Memory_Management
package(http://www.adapower.com/index.php?Command=Class&ClassID=Advanced&CID=222)
from Anh Vo
fun.exe result is
0
0
789
and I1.Value'Address and I2.Value'Address is equal.
I can not understand this result.
My English is poor.
Thank You.
^ permalink raw reply [relevance 5%]
* Re: Hierarchy destruction in Ada
@ 2004-12-12 15:38 6% ` Dmitry A. Kazakov
0 siblings, 0 replies; 200+ results
From: Dmitry A. Kazakov @ 2004-12-12 15:38 UTC (permalink / raw)
On 12 Dec 2004 07:18:32 -0800, Michael Mounteney wrote:
> Ada 95 provides a mechanism with tagged and type'class to allow
> dynamic dispatch. So if one has:
>
> procedure something (O : basetype'class) is
> begin
> enact (O);
> end something;
>
> then as we all know, with the appropriate redefinitions of enact ()
> for the subtypes of basetype, we have dynamic dispatch. But what
> about deallocation ? I want to declare:
>
> type handle is access all basetype;
You should use class-wide pointers if you want dispatch on them:
type Handle is access all BaseType'Class;
> procedure dispose (ptr : in out handle);
>
> and can't see how to make this deallocate the correct object.
> Obviously, one can dynamically dispatch on ptr.all but it seems
> impossible to solve the complete problem without an unchecked
> conversion. Anyone ?
procedure Dispose is
new Ada.Unchecked_Deallocation (BaseType'Class, Handle);
--
Regards,
Dmitry A. Kazakov
http://www.dmitry-kazakov.de
^ permalink raw reply [relevance 6%]
* Re: Use of Unchecked_Deallocation and pragma Controlled
2004-11-24 23:47 7% Use of Unchecked_Deallocation and pragma Controlled Mark Lorenzen
@ 2004-11-25 6:25 0% ` Simon Wright
0 siblings, 0 replies; 200+ results
From: Simon Wright @ 2004-11-25 6:25 UTC (permalink / raw)
Mark Lorenzen <mark.lorenzen@ofir.dk> writes:
> When Unchecked_Deallocation is used to reclaim the storage claimed
> by an object, the pragma Controlled must be use to prevent automatic
> reclamation (ie. "garbage collection") of storage which would
> otherwise result in "double deallocation" of the object.
>
> Example:
>
> type Access_T is access T;
> Pragma Controlled (Access_T);
>
> procedure Free is new Ada.Unchecked_Deallocation(T, Access_T);
>
> begin
> A : Access_T := new T;
> B : Access_T := A;
>
> ...
>
> Free(T); -- OK, reclaim the storage.
> end; -- OK only if pragma Controlled has been applied.
> -- Otherwise B could be reclaimed by garbage collection,
> -- resulting in double deallocation of A.
>
> Question: Do you guys actually use pragma Controlled even if no
> current Ada compiler generates code with garbage collection?
I don't believe there are any Ada compilers (other than those targeted
to a JVM) that do garbage collection.
But even if there were, it seems to me it would be a pretty crappy
implementation that didn't notice you doing the Free and remember
somehow not to collect the garbage. I rather suspect it wouldn't pass
ACATS either. I wouldn't buy it.
On the other hand, the AARM
<http://www.adaic.org/standards/95aarm/html/AA-13-11-3.html> goes into
a lot of detail about it, so perhaps I'm just confused .. thank
heavens the compiler I'm using doesn't do it! One less thing to worry
about.
--
Simon Wright 100% Ada, no bugs.
^ permalink raw reply [relevance 0%]
* Use of Unchecked_Deallocation and pragma Controlled
@ 2004-11-24 23:47 7% Mark Lorenzen
2004-11-25 6:25 0% ` Simon Wright
0 siblings, 1 reply; 200+ results
From: Mark Lorenzen @ 2004-11-24 23:47 UTC (permalink / raw)
When Unchecked_Deallocation is used to reclaim the storage claimed by
an object, the pragma Controlled must be use to prevent automatic
reclamation (ie. "garbage collection") of storage which would otherwise result
in "double deallocation" of the object.
Example:
type Access_T is access T;
Pragma Controlled (Access_T);
procedure Free is new Ada.Unchecked_Deallocation(T, Access_T);
begin
A : Access_T := new T;
B : Access_T := A;
...
Free(T); -- OK, reclaim the storage.
end; -- OK only if pragma Controlled has been applied.
-- Otherwise B could be reclaimed by garbage collection,
-- resulting in double deallocation of A.
Question: Do you guys actually use pragma Controlled even if no
current Ada compiler generates code with garbage collection?
Regards,
- Mark Lorenzen
^ permalink raw reply [relevance 7%]
* Re: Unchecked deallocation question
2004-11-24 15:38 6% Unchecked deallocation question Alex R. Mosteo
@ 2004-11-24 17:24 0% ` Jeffrey Carter
0 siblings, 0 replies; 200+ results
From: Jeffrey Carter @ 2004-11-24 17:24 UTC (permalink / raw)
Alex R. Mosteo wrote:
> type Root is tagged record ...
>
> type Root_Access is access Root;
>
> type Derived is new Root with ...
>
> type Derived_Access is access Derived;
>
> procedure Free is
> new Ada.Unchecked_Deallocation (Root'Class, Root_Access);
Root_Access designates Root, not Root'Class.
>
> declare
> It : Derived_Access := new Derived;
> begin
> Free (Root_Access (It)); -- <-- THIS DEALLOCATION I'M ASKING
> end;
>
> The purpose is to have a single deallocator in the root package and to
> not have to instantiate a lot of deallocators for derived types.
You'd be better off having
type Root_Access is access Root'Class;
procedure Free is new ...
...
It : Root_Access := new Derived;
...
Free (It);
But you'd really be better off not using access types, or encapsulating
and hiding their use if that's not possible.
--
Jeff Carter
"My name is Jim, but most people call me ... Jim."
Blazing Saddles
39
^ permalink raw reply [relevance 0%]
* Unchecked deallocation question
@ 2004-11-24 15:38 6% Alex R. Mosteo
2004-11-24 17:24 0% ` Jeffrey Carter
0 siblings, 1 reply; 200+ results
From: Alex R. Mosteo @ 2004-11-24 15:38 UTC (permalink / raw)
I'm wondering if this is correct:
type Root is tagged record ...
type Root_Access is access Root;
type Derived is new Root with ...
type Derived_Access is access Derived;
procedure Free is
new Ada.Unchecked_Deallocation (Root'Class, Root_Access);
declare
It : Derived_Access := new Derived;
begin
Free (Root_Access (It)); -- <-- THIS DEALLOCATION I'M ASKING
end;
Assuming that all involved access types use the same Storage_Pool.
The purpose is to have a single deallocator in the root package and to
not have to instantiate a lot of deallocators for derived types.
^ permalink raw reply [relevance 6%]
* Re: Memory leak - What the ...?
2004-10-11 8:59 6% ` Alex R. Mosteo
@ 2004-10-11 18:24 6% ` Stephen Leake
0 siblings, 0 replies; 200+ results
From: Stephen Leake @ 2004-10-11 18:24 UTC (permalink / raw)
To: comp.lang.ada
mosteo@gmail.com (Alex R. Mosteo) writes:
> Stephen Leake <stephen_leake@acm.org> wrote in message news:<mailman.270.1097458825.390.comp.lang.ada@ada-france.org>...
> > mosteo@gmail.com (Alex R. Mosteo) writes:
> >
> > > Hi,
> > >
> > > as the topic says, this post is about some code which leaks. I'm now
> > > sure of having trapped the leak, but I don't understand where is my
> > > error.
> >
> > Please post a complete compilable example, so I can run it with gnat 5.02a1.
>
> Here's the example. Gnatmem shows that it leaks heavily. So I must
> have understood something really wrong about controlled types. I need
> to get this right.
Hmm. This inspired me to try GNAT.Debug_Pools. Here's the instrumented
code:
with Ada.Finalization;
with Ada.Streams;
with GNAT.Debug_Pools;
package Test_Aux is
type Stream_Element_Array_Access is access Ada.Streams.Stream_Element_Array;
Pool : GNAT.Debug_Pools.Debug_Pool;
for Stream_Element_Array_Access'Storage_Pool use Pool;
type Udp_Message is new Ada.Finalization.Controlled with record
Data : Stream_Element_Array_Access;
end record;
function Create (Data : in Ada.Streams.Stream_Element_Array) return Udp_Message;
procedure Adjust (This : in out Udp_Message);
procedure Finalize (This : in out Udp_Message);
end Test_Aux;
with Ada.Unchecked_Deallocation;
package body Test_Aux is
function Create (Data : in Ada.Streams.Stream_Element_Array) return Udp_Message
is
Msg : Udp_Message :=
(Ada.Finalization.Controlled with
Data => new Ada.Streams.Stream_Element_Array'(Data));
begin
return Msg;
end Create;
procedure Adjust (This : in out Udp_Message) is
begin
if This.Data /= null then
This.Data := new Ada.Streams.Stream_Element_Array'(This.Data.all);
end if;
end Adjust;
procedure Finalize (This : in out Udp_Message) is
procedure Free is new Ada.Unchecked_Deallocation
(Ada.Streams.Stream_Element_Array, Stream_Element_Array_Access);
begin
Free (This.Data);
end Finalize;
end Test_Aux;
with Ada.Exceptions;
with Ada.Streams; use Ada.Streams;
with Ada.Text_IO; use Ada.Text_IO;
with Test_Aux; use Test_Aux;
with GNAT.Debug_Pools;
procedure Test is
procedure Pool_Info is new GNAT.Debug_Pools.Print_Info (Put_Line);
Empty : Udp_Message;
Arr : array (1 .. 1000) of Udp_Message;
begin
Put_Line ("Adding...");
for I in Arr'Range loop
Arr (I) := Create ((1 .. Stream_Element_Offset (I) => Stream_Element'First));
end loop;
Put_Line ("Deleting...");
for I in Arr'Range loop
Arr (I) := Empty;
end loop;
Pool_Info (Pool);
exception
when E: others =>
Put_Line ("Exception: " & Ada.Exceptions.Exception_Information (E));
end test;
Compiling with GNAT 5.02a1 and running, we get:
gnatmake -k -g -O0 -gnatf -gnato -gnatwa -gnatwe -gnatwL -gnatVa -I.. test -largs -bargs -E -cargs
gcc -c -I./ -g -O0 -gnatf -gnato -gnatwa -gnatwe -gnatwL -gnatVa -I.. -I- ..\test.adb
gcc -c -I./ -g -O0 -gnatf -gnato -gnatwa -gnatwe -gnatwL -gnatVa -I.. -I- ..\test_aux.adb
gnatbind -aO./ -I.. -E -I- -x test.ali
gnatlink test.ali -g
./test.exe
Adding...
Deleting...
Total allocated bytes : 1530000
Total logically deallocated bytes : 1530000
Total physically deallocated bytes : 0
Current Water Mark: 0
High Water Mark: 511008
Which seems to indicate no leak.
I don't see anything obviously wrong with the code.
There may be a bug with this in GNAT 3.15p on your OS.
Try adding Text_IO.Put_Line in each call, and trace one object's
lifetime; that often makes things clear.
--
-- Stephe
^ permalink raw reply [relevance 6%]
* Re: Memory leak - What the ...?
@ 2004-10-11 10:21 6% Christoph Karl Walter Grein
0 siblings, 0 replies; 200+ results
From: Christoph Karl Walter Grein @ 2004-10-11 10:21 UTC (permalink / raw)
To: comp.lang.ada
with Ada.Text_Io;
use Ada.Text_Io;
with Ada.Unchecked_Deallocation;
package body Test_Aux is
function Create (Data : in Stream_Element_Array) return Udp_Message is
Msg : Udp_Message := (Ada.Finalization.Controlled with
Data => new Stream_Element_Array'(Data));
begin
Put_Line ("Create" & Stream_Element_Offset'Image (Data'Last));
return Msg;
end Create;
procedure Adjust (This : in out Udp_Message) is
begin
if This.Data /= null then
Put_Line ("Adjust" & Stream_Element_Offset'Image (This.Data'Last));
This.Data := new Stream_Element_Array'(This.Data.all);
else
Put_Line ("Adjust null");
end if;
end Adjust;
procedure Finalize (This : in out Udp_Message) is
procedure Free is new Ada.Unchecked_Deallocation
(Stream_Element_Array,
Stream_Element_Array_Access);
begin
if This.Data /= null then
Put_Line ("Finalize" &
Stream_Element_Offset'Image (This.Data'Last));
else
Put_Line ("Finalize null");
end if;
Free (This.Data);
end Finalize;
end Test_Aux;
with Ada.Exceptions;
with Ada.Streams;
use Ada.Streams;
use Ada;
with Text_Io;
use Text_Io;
with Test_Aux;
use Test_Aux;
procedure Test_It is
Empty : Udp_Message;
Arr : array (1 .. 2) of Udp_Message;
-- Initialize is called for Empty and each component of Arr;
-- does nothing since not overridden.
begin
Text_Io.Put_Line ("Adding...");
for I in Arr'Range loop
Arr (I) := Create ((1 .. Stream_Element_Offset (I) =>
Stream_Element'First));
-- Create 1 => Create an intermediate object Msg in place
-- with Data as given.
-- Neither Initialize nor Adjust is called.
-- Adjust 1 => Some internal
-- Finalize 1 => copying of the intermediate object
-- Finalize null => Finalize (Arr (I)); Left side of assignment
-- statement; does nothing since Data = null.
-- Copy Msg to Arr (I) - Shallow copy.
-- Adjust 1 => Adjust (Arr (I)); Make a deep copy from
-- This.Data.all (this is the intermediate Msg.Data).
-- Finalize 1 => Finalize Msg - Destruct the intermediate object,
-- i.e. de-allocate Msg.Data.
-- Create 2
-- Adjust 2
-- Finalize 2
-- Finalize null
-- Adjust 2
-- Finalize 2
end loop;
-- I cannot see a problem here.
Text_Io.Put_Line ("Deleting...");
for I in Arr'Range loop
Arr (I) := Empty;
-- Finalize 1 => Finalize (Arr (I)); Left side of assignment
-- statement; de-allocates Data.
-- Copy Empty to Arr (I)
-- Adjust null => Adjust (Arr (I)); does nothing since
-- Empty.Data = null.
-- Finalize 2
-- Adjust null
end loop;
-- Finalize null
-- Finalize null
-- Finalize null
-- Finalize is called for each component of Arr in inverse sequence, then
-- for Empty.
-- Does nothing since Data = null always.
--
-- I can't see a problem.
exception
when E: others =>
Text_Io.Put_Line ("Exception: " & Exceptions.Exception_Information (E));
end Test_It;
__________________________________________________________
Mit WEB.DE FreePhone mit hoechster Qualitaet ab 0 Ct./Min.
weltweit telefonieren! http://freephone.web.de/?mc=021201
^ permalink raw reply [relevance 6%]
* Re: Memory leak - What the ...?
@ 2004-10-11 8:59 6% ` Alex R. Mosteo
2004-10-11 18:24 6% ` Stephen Leake
0 siblings, 1 reply; 200+ results
From: Alex R. Mosteo @ 2004-10-11 8:59 UTC (permalink / raw)
Stephen Leake <stephen_leake@acm.org> wrote in message news:<mailman.270.1097458825.390.comp.lang.ada@ada-france.org>...
> mosteo@gmail.com (Alex R. Mosteo) writes:
>
> > Hi,
> >
> > as the topic says, this post is about some code which leaks. I'm now
> > sure of having trapped the leak, but I don't understand where is my
> > error.
>
> Please post a complete compilable example, so I can run it with gnat 5.02a1.
Here's the example. Gnatmem shows that it leaks heavily. So I must
have understood something really wrong about controlled types. I need
to get this right.
The example will create 1000 messages and then delete them
overwritting them with an empty value.
I suppose gnatchop will suffice (beware: use ./test and not simply
test):
with Ada.Finalization;
with Ada.Streams; use Ada.Streams;
package Test_Aux is
type Stream_Element_Array_Access is access
Ada.Streams.Stream_Element_Array;
type Udp_Message is new Ada.Finalization.Controlled with record
Data : Stream_Element_Array_Access;
end record;
------------
-- Create --
------------
function Create (Data : in Stream_Element_Array) return
Udp_Message;
procedure Adjust (This : in out Udp_Message);
procedure Finalize (This : in out Udp_Message);
end Test_Aux;
with Ada.Unchecked_Deallocation;
package body Test_Aux is
------------
-- Create --
------------
function Create (Data : in Stream_Element_Array) return Udp_Message
is
Msg : Udp_Message :=
(Ada.Finalization.Controlled with
Data => new Stream_Element_Array'(Data));
begin
return Msg;
end Create;
procedure Adjust (This : in out Udp_Message) is
begin
if This.Data /= null then
This.Data := new Stream_Element_Array'(This.Data.all);
end if;
end Adjust;
procedure Finalize (This : in out Udp_Message) is
procedure Free is new Ada.Unchecked_Deallocation (
Stream_Element_Array, Stream_Element_Array_Access);
begin
Free (This.Data);
end Finalize;
end Test_Aux;
with Ada.Exceptions;
with Ada.Streams; use Ada.Streams;
use Ada;
with Text_IO; use Text_IO;
with Test_Aux; use Test_Aux;
procedure Test is
Empty : Udp_Message;
Arr : array (1 .. 1000) of Udp_Message;
begin
Text_Io.Put_Line ("Adding...");
for I in Arr'Range loop
Arr (I) := Create ((1 .. Stream_Element_Offset (I) =>
Stream_Element'First));
end loop;
Text_Io.Put_Line ("Deleting...");
for I in Arr'Range loop
Arr (I) := Empty;
end loop;
exception
when E: others =>
Text_IO.Put_Line ("Exception: " &
Exceptions.Exception_Information (E));
end test;
^ permalink raw reply [relevance 6%]
* Re: Ada memory management?
@ 2004-10-07 12:06 6% ` Martin Krischik
0 siblings, 0 replies; 200+ results
From: Martin Krischik @ 2004-10-07 12:06 UTC (permalink / raw)
matthias_k wrote:
> Hey there,
>
> since there is an allocator 'new' in Ada, I was wondering if there is a
> 'delete' too. I've heard there is a special technique called Storage
> Pool in Ada to write own memory managers, but what is the default
> deallocator?
Two option open: Your Ada has garbage collection or you use
Ada.Unchecked_Deallocation.
AFAIK: Only Ada's targeting the JVM have garbage collection. However for
GNAT you can use the Boehm Collector which is part of the GCC.
Mind you: A good collection class library will free you from almost all
memory management.
With Regards
Martin
--
mailto://krischik@users.sourceforge.net
http://www.ada.krischik.com
^ permalink raw reply [relevance 6%]
* Re: Ada memory management?
2004-10-07 10:00 6% Christoph Karl Walter Grein
@ 2004-10-07 12:00 0% ` Martin Krischik
0 siblings, 0 replies; 200+ results
From: Martin Krischik @ 2004-10-07 12:00 UTC (permalink / raw)
Christoph Karl Walter Grein wrote:
> procedure Does_This_Leak is
> type Int_Ptr is access Integer;
> ptr: Int_Ptr;
> begin
> ptr := new Integer;
> end Does_This_Leak;
>
> Of course this leaks, and imagine how much!
Well depends if garbage collection is available. The sad news are that only
Ada's targeting JVM have garbage collection.
> Consider Ada.Unchecked_Deallocation. It's called Unchecked because it's
> your very chore to take care of not producing dangling pointers.
Or using a garbage collected storrage pool.
With Regards
Martin
--
mailto://krischik@users.sourceforge.net
http://www.ada.krischik.com
^ permalink raw reply [relevance 0%]
* Re: Ada memory management?
@ 2004-10-07 10:00 6% Christoph Karl Walter Grein
2004-10-07 12:00 0% ` Martin Krischik
0 siblings, 1 reply; 200+ results
From: Christoph Karl Walter Grein @ 2004-10-07 10:00 UTC (permalink / raw)
To: comp.lang.ada
procedure Does_This_Leak is
type Int_Ptr is access Integer;
ptr: Int_Ptr;
begin
ptr := new Integer;
end Does_This_Leak;
Of course this leaks, and imagine how much!
Consider Ada.Unchecked_Deallocation. It's called Unchecked because it's your very chore to take care of not
producing dangling pointers.
________________________________________________________________
Verschicken Sie romantische, coole und witzige Bilder per SMS!
Jetzt neu bei WEB.DE FreeMail: http://freemail.web.de/?mc=021193
^ permalink raw reply [relevance 6%]
* Re: Smarter Generics
@ 2004-08-15 1:32 6% ` Francois G. Dorais
0 siblings, 0 replies; 200+ results
From: Francois G. Dorais @ 2004-08-15 1:32 UTC (permalink / raw)
Frank J. Lhota wrote:
> The recent thread on "A Simple Ada Problem" got me thinking about a
> limitation of Ada generics. Generic are a great way of generalizing an
> implementation strategy for a particular problem, but generics cannot (or
> cannot easily) select one of several implementation strategies based on the
> generic parameters.
>
> Take the following simple example: Assume that I want to implement stacks of
> limited length, e.g. a stack that I can push or pop elements of a given
> type, but with a limit on how many elements will be on the stack at one
> time:
>
> generic
> type Stack_Element is private;
> Max_Length : in Positive;
> package Limited_Stacks is
>
> type Stack_Type is limited private;
> Stack_Overflow, Stack_Underflow : exception;
>
> procedure Push ( Item : in Stack_Element; Onto : in out
> Stack_Type );
> procedure Pop ( Item : out Stack_Element; Onto : in out
> Stack_Type );
>
> private
> ...
> end Limited_Stacks;
>
> Two possible implementation strategies:
>
> 1. We could implement the stack as an array of Max_Length elements, along
> with a component indicating the current length.
> 2. We could maintain an adjustable list of pointers to elements allocated
> from the heap.
>
> Obviously, implementation 1 would be faster and more convenient if
> Max_Length * Stack_Element'Size is relatively small. Implementation 2
> involves additional overhead, but can handle cases where stack elements can
> vary quite a bit in size.
>
> What would be great is if there were some way to write Limited_Stacks so
> that the implementation strategy could be chosen based on the generic
> parameters, so that we could do something like this:
>
> if Max_Length * Stack_Element'Size <= Some_Threshold then
> -- Static memory allocation should be fine
> Implement Limited_Stacks using strategy 1;
> else
> -- Size could be a problem, better go with pointers.
> Implement Limited_Stacks using strategy 2;
> end if;
>
> AFAIK neither Ada generics nor C++ templates have this level of
> intelligence. Would smarter generics be a worthwhile addition to Ada, and if
> so, what form should it take?
Hmmm... I guess Ada is smarter than C++ after all :)
-- Alternative Methods Example
generic
type Element_Type is private;
Stack_Limit : in Positive;
package Limited_Stacks is
type Limited_Stack_Type is limited private;
procedure Push (Stack : in out Limited_Stack_Type;
Item : in Element_Type);
procedure Pop (Stack : in out Limited_Stack_Type;
Item : out Element_Type);
function Method (Stack : in Limited_Stack_Type) return
String;
-- Returns "ARRAY" or "LIST" for testing purposes...
Stack_Overflow, Stack_Underflow : exception;
private
type Element_Array is array (1 .. Stack_Limit) of
Element_Type;
type Element_Record;
type Element_Pointer is access Element_Record;
type Element_Record is record
Item : Element_Type;
Pred : Element_Pointer;
end record;
Null_Element_Pointer : constant Element_Pointer := null;
type Limited_Stack_Alternative (Use_Array : Boolean) is
record
Stack_Length : Natural := 0;
case Use_Array is
when True =>
Stack_Array : Element_Array;
when False =>
Stack_Pointer : Element_Pointer :=
Null_Element_Pointer;
end case;
end record;
type Limited_Stack_Type is new Limited_Stack_Alternative
(Element_Type'Size * Stack_Limit <= 1024 * 8);
end Limited_Stacks;
with Ada.Unchecked_Deallocation;
package body Limited_Stacks is
procedure Free is new Ada.Unchecked_Deallocation
(Element_Record, Element_Pointer);
procedure Push (Stack : in out Limited_Stack_Type;
Item : in Element_Type) is
begin
if Stack.Stack_Length = Stack_Limit then
raise Stack_Overflow;
end if;
Stack.Stack_Length := Stack.Stack_Length + 1;
case Stack.Use_Array is
when True =>
Stack.Stack_Array(Stack.Stack_Length) := Item;
when False =>
declare
New_Pointer : Element_Pointer
:= new Element_Record'(Item => Item, Pred
=> Stack.Stack_Pointer);
begin
Stack.Stack_Pointer := New_Pointer;
end;
end case;
end Push;
procedure Pop (Stack : in out Limited_Stack_Type;
Item : out Element_Type) is
begin
if Stack.Stack_Length = 0 then
raise Stack_Underflow;
end if;
case Stack.Use_Array is
when True =>
Item := Stack.Stack_Array(Stack.Stack_Length);
when False =>
declare
Old_Pointer : Element_Pointer :=
Stack.Stack_Pointer;
begin
if Stack.Stack_Pointer =
Null_Element_Pointer then
-- This shouldn't happen but this
-- implementation is not meant for
-- concurrent access...
raise Program_Error;
end if;
Stack.Stack_Pointer := Stack.Stack_Pointer.Pred;
Free(Old_Pointer);
end;
end case;
Stack.Stack_Length := Stack.Stack_Length - 1;
end Pop;
function Method (Stack : in Limited_Stack_Type) return
String is
begin
case Stack.Use_Array is
when True =>
return "ARRAY";
when False =>
return "LIST";
end case;
end Method;
end Limited_Stacks;
with Ada.Text_IO;
use Ada.Text_IO;
with Limited_Stacks;
procedure Test_Limited_Stacks is
type Kilo_String is new String (1 .. 1000);
type Deca_String is new String (1 .. 10);
package Kilo_Stacks is new Limited_Stacks (Kilo_String, 16);
package Deca_Stacks is new Limited_Stacks (Deca_String, 16);
Kilo_Stack : Kilo_Stacks.Limited_Stack_Type;
Deca_Stack : Deca_Stacks.Limited_Stack_Type;
begin
Put_Line("Kilo_Stack uses method " &
Kilo_Stacks.Method(Kilo_Stack));
Put_Line("Deca_Stack uses method " &
Deca_Stacks.Method(Deca_Stack));
end Test_Limited_Stacks;
-- End Example
^ permalink raw reply [relevance 6%]
* Re: Basic program with tasks goes out of memory
2004-08-05 15:18 8% ` Dmitry A. Kazakov
@ 2004-08-07 4:04 7% ` Dmitriy Anisimkov
1 sibling, 0 replies; 200+ results
From: Dmitriy Anisimkov @ 2004-08-07 4:04 UTC (permalink / raw)
wojtek@power.com.pl (Wojtek Narczynski) wrote in message
>
> Any idea why this program (extracted from AdaSockets example)
> eventually eats up all RAM? Runtime leak or my ignorance?
I think the only way to do not leak memory on dynamically allocated
tasks,
is to have a task for deallocate terminated tasks. And each
dynamically allocated task have to pass its pointer to the Destructor
before termination.
The Destructor have to be like that.
-------------------------------
task body Destructor is
Rf : Relay_Access;
procedure Free is new Ada.Unchecked_Deallocation (Relay,
Relay_Access);
begin
loop
select
accept Free_Task (R : Relay_Access) do
Rf := R;
end Free_Task;
end select;
loop
exit when Rf'Terminated;
delay 0.001;
end loop;
Free (Rf);
end loop;
exception when E : others =>
Unexpected (E, "Destructor");
end Destructor;
-------------------------
The complete application with task Destructor usage is in the
http://www.ada-ru.org/src/relay.adb
It has a same as tcprelay.adb (from AdaSockets) functionality, but
with dynamically created task deallocation.
It would be good to have a method to wait until task termination like
on entry call. Maybe something like that.
----------------------------------
task body Destructor is
Rf : Relay_Access;
procedure Free is new Ada.Unchecked_Deallocation (Relay,
Relay_Access);
begin
loop
select
accept Free_Task (R : Relay_Access) do
Rf := R;
end Free_Task;
end select;
select
Rf'Wait_Termination;
or delay 10.0;
-- Could not wait more.
null;
end loop;
Free (Rf);
end loop;
exception when E : others =>
Unexpected (E, "Destructor");
end Destructor;
-------------------------
^ permalink raw reply [relevance 7%]
* Re: Basic program with tasks goes out of memory
@ 2004-08-05 15:18 8% ` Dmitry A. Kazakov
2004-08-07 4:04 7% ` Dmitriy Anisimkov
1 sibling, 0 replies; 200+ results
From: Dmitry A. Kazakov @ 2004-08-05 15:18 UTC (permalink / raw)
On 5 Aug 2004 07:55:27 -0700, Wojtek Narczynski wrote:
> Hello,
>
> Any idea why this program (extracted from AdaSockets example)
> eventually eats up all RAM? Runtime leak or my ignorance?
>
> with Ada.Exceptions; use Ada.Exceptions;
> with Ada.Text_IO; use Ada.Text_IO;
with Ada.Unchecked_Deallocation;
> procedure Listener is
>
> task type Echo is
> entry Start;
> end Echo;
>
> task body Echo is
>
> begin
> select
> accept Start do
> null;
> end Start;
> or
> terminate;
> end select;
>
> exception
> when others =>
> Put_Line ("Strange error");
> end Echo;
>
> type Echo_Access is access Echo;
procedure Free is new Ada.Unchecked_Deallocation (Echo, Echo_Access);
> Dummy : Echo_Access;
>
> begin
>
> loop
> Dummy := new Echo;
> Dummy.Start;
> -- The statement below merely "delays" the problem
> delay 0.001;
Free (Dummy);
> end loop;
>
> end Listener;
You allocate Echo, but never deallocate it.
--
Regards,
Dmitry A. Kazakov
http://www.dmitry-kazakov.de
^ permalink raw reply [relevance 8%]
* Re: A simple ADA puzzle (I haven't the answer)
@ 2004-06-16 16:21 4% ` Frank J. Lhota
0 siblings, 0 replies; 200+ results
From: Frank J. Lhota @ 2004-06-16 16:21 UTC (permalink / raw)
The problem with your definition of String_Type is that an unconstrained
object of this type would require an outrageous amount of memory. Assume
that we declare:
My_Name : STRING_TYPE;
Since My_Name is unconstrained, we can assign any STRING_TYPE value to
My_Name, including
My_Name := STRING_TYPE'( Len => Integer'Last, String => ( others => '
' ) );
So even though My_Name.Len is initially 0, My_Name must be allocated enough
space to contain the largest object of STRING_TYPE. Frankly, I'd be
surprised if there was space for one such object. There is nothing
surprising about getting some sort of error when declaring an array of 3
unconstrained objects of type STRING_TYPE, although Storage_Error should
have been raised instead of Constraint_Error.
The right way to fix this depends on one question: is there a reasonable
upper bound to the length of the Len discriminant?
----------------------------------------
If there is a reasonable upper limit on the LEN discriminant, say 100, we
can constrain the LEN component as follows:
type LEN_TYPE is array (INTEGER range <>)
of CHARACTER;
subtype STRING_LEN is INTEGER range 0 .. 100;
type STRING_TYPE (LEN : STRING_LEN := 0) is
record
STRING : LEN_TYPE (1 .. LEN);
end record;
With these declararations, LEN is constrained to be no larger than 100. You
can now declare an unconstrained object of type STRING_TYPE without
requiring ridiculous amounts of space.
----------------------------------------
If there is no reasonable upper limit on the LEN discriminant, if say LEN
can vary from 1 to hundreds of thousands, then the best solution would be to
use an array of pointers. This would be the only reasonable way to create an
array of objects of widely varying sizes. For example:
type LEN_TYPE is array (INTEGER range <>)
of CHARACTER;
type STRING_TYPE (LEN : INTEGER := 0) is
record
STRING : LEN_TYPE (1 .. LEN);
end record;
type STRING_ACC is access all STRING_TYPE;
procedure Deallocate is
new Ada.Unchecked_Deallocation( STRING_TYPE, STRING_ACC );
type UNC2_ARRAY_TYPE is array (INTEGER range <>)
of STRING_ACC;
This solution does require that the array component values be allocated (and
deallocated once you are finished with them), but it does allow you to make
a table of STRING_TYPE values that take on the full range of LEN
discriminants.
^ permalink raw reply [relevance 4%]
* Re: [newbie] simple(?) data structures
@ 2004-06-13 14:47 5% ` Stephen Leake
0 siblings, 0 replies; 200+ results
From: Stephen Leake @ 2004-06-13 14:47 UTC (permalink / raw)
To: comp.lang.ada
Roland Illig <roland.illig@gmx.de> writes:
> Many thanks for your detailed answer. Now I know what I forgot to say.
> The thing that makes the definition of the data structure that
> complicated is that I want to choose the size of the Go_Board at
> runtime and I want to pass that Go_Board to other subprograms. Is that
> possible with packages?
For a run-time determined size, the answer in Ada is the same as in
C++; you need to allocate the board object after reading in the size.
However, there are two ways to do this in Ada. The most powerful is
with access types:
package Go_Board is
type size_Type is range 10 .. 50;
type Board_Type (size : Size_Type) is tagged limited private;
type Board_Access_Type is access Board_Type;
...
end Go_Board;
with Go_Board;
with Ada.Command_Line;
procedure Go_Main
Size : constant Go_Board.Size_Type := Go_Board.Size_Type'Value
(Ada.Command_Line.Argument (1));
Board : Go_Board.Board_Access_Type := new Go_Board.Board_Type (Size);
begin
-- play go.
end Go_Main;
This will allow you to change the size again after playing one game;
deallocate Board (using an instance of Ada.Unchecked_Deallocation),
and allocate it again. Then you have to be careful not to save a copy
of the pointer to the board after the board is destroyed.
The other way is to declare the board in a local block:
with Go_Board;
with Ada.Command_Line;
procedure Go_Main
Size : constant Go_Board.Size_Type := Go_Board.Size_Type'Value
(Ada.Command_Line.Argument (1));
begin
declare
Board : Go_Board. Go_Board.Board_Type (Size);
begin
-- play go.
end;
end Go_Main;
The second way doesn't need the access type; the board is "allocated"
on the stack. But Board is only visible in the local block, which can
be a problem for some applications. And, you can't change the size
after playing one game. This might be a good way to start; learn about
access types later.
--
-- Stephe
^ permalink raw reply [relevance 5%]
Results 1-200 of ~500 next (older) | reverse | options above
-- pct% links below jump to the message on this page, permalinks otherwise --
2004-06-12 22:23 [newbie] simple(?) data structures Roland Illig
2004-06-13 0:10 ` Ludovic Brenta
2004-06-13 3:13 ` Roland Illig
2004-06-13 14:47 5% ` Stephen Leake
2004-06-16 15:40 A simple ADA puzzle (I haven't the answer) Abby
2004-06-16 16:21 4% ` Frank J. Lhota
2004-08-05 14:55 Basic program with tasks goes out of memory Wojtek Narczynski
2004-08-05 15:18 8% ` Dmitry A. Kazakov
2004-08-07 4:04 7% ` Dmitriy Anisimkov
2004-08-14 19:55 Smarter Generics Frank J. Lhota
2004-08-15 1:32 6% ` Francois G. Dorais
2004-10-07 9:39 Ada memory management? matthias_k
2004-10-07 12:06 6% ` Martin Krischik
2004-10-07 10:00 6% Christoph Karl Walter Grein
2004-10-07 12:00 0% ` Martin Krischik
2004-10-10 21:33 Memory leak - What the ...? Alex R. Mosteo
2004-10-11 1:40 ` Stephen Leake
2004-10-11 8:59 6% ` Alex R. Mosteo
2004-10-11 18:24 6% ` Stephen Leake
2004-10-11 10:21 6% Christoph Karl Walter Grein
2004-11-24 15:38 6% Unchecked deallocation question Alex R. Mosteo
2004-11-24 17:24 0% ` Jeffrey Carter
2004-11-24 23:47 7% Use of Unchecked_Deallocation and pragma Controlled Mark Lorenzen
2004-11-25 6:25 0% ` Simon Wright
2004-12-12 15:18 Hierarchy destruction in Ada Michael Mounteney
2004-12-12 15:38 6% ` Dmitry A. Kazakov
2005-04-19 1:39 5% Memory_Management Bini
2005-07-07 15:50 Unchecked_Conversion and task pointer e.coli
2005-07-07 20:18 7% ` Dmitry A. Kazakov
[not found] <1122305318.728942.304120@f14g2000cwb.googlegroups.com>
2005-07-26 3:17 7% ` Help needed for ada package Steve
2005-08-06 11:57 Ada.Containers.Indefinite_Ordered_Maps of gcc 4.0.1 has bug ? Y.Tomino
2005-08-06 12:54 ` Matthew Heaney
2005-08-06 13:13 3% ` Y.Tomino
2005-09-05 21:02 Memeory management Zheng Wang
2005-09-05 21:43 5% ` tmoran
2005-10-12 21:49 Ada memory management seems slow Makhno
2005-10-13 16:39 ` Martin Krischik
2005-10-13 18:39 6% ` Makhno
2005-10-14 9:59 0% ` Alex R. Mosteo
2005-10-14 14:49 0% ` Martin Krischik
2005-10-16 0:40 7% ` Robert A Duff
2005-10-25 14:02 3% Adding support for multiple tasks in wxAda Lucretia
[not found] <pan.2005.10.26.22.16.09.200167@nowhere.net>
2005-10-26 1:41 5% ` Memory Mapped Storage Pools Dan Baysinger
2005-11-10 8:25 function "&" for strings type cause memory problem bubble
2005-11-11 8:25 6% ` bubble
2005-12-09 5:15 Unchecked deallocation issues ejijott
2005-12-09 6:40 6% ` Jeffrey R. Carter
2005-12-09 9:22 ` ejijott
2005-12-09 10:06 7% ` Alex R. Mosteo
2006-01-26 7:28 Type safety on wikipedia Martin Krischik
2006-01-26 13:53 ` jimmaureenrogers
2006-01-26 19:07 7% ` Florian Weimer
2006-01-27 0:38 0% ` jimmaureenrogers
2006-01-27 18:54 0% ` Martin Krischik
2006-01-27 11:34 0% ` Alex R. Mosteo
2006-05-14 17:34 How-to on using the adacl-gc packages Erik J Pessers
2006-05-14 18:26 ` Steve Whalen
2006-05-15 6:52 ` Martin Krischik
2006-05-15 20:13 6% ` Simon Wright
2006-05-22 4:54 Ada vs Fortran for scientific applications Nasser Abbasi
2006-05-22 13:02 ` Jean-Pierre Rosen
2006-05-22 15:23 ` Dan Nagle
2006-05-23 8:25 ` Jean-Pierre Rosen
2006-05-23 17:09 ` Dick Hendrickson
2006-05-24 14:50 ` robin
2006-05-24 15:19 ` Dick Hendrickson
2006-05-25 3:40 ` robin
2006-05-25 5:04 ` Nasser Abbasi
2006-05-25 6:04 ` Richard Maine
2006-05-25 12:09 ` Dr. Adrian Wrigley
2006-05-25 12:45 ` Gordon Sande
2006-07-09 20:52 ` adaworks
2006-11-20 9:39 ` robin
2006-11-21 9:02 6% ` Finalization Philippe Tarroux
2006-11-21 9:22 0% ` Finalization Dmitry A. Kazakov
2006-06-12 20:33 Not null feature with anonymous and named access types Anh Vo
2006-06-12 21:26 ` Björn Persson
2006-06-12 23:13 ` Anh Vo
2006-06-13 7:53 ` Dmitry A. Kazakov
2006-06-13 15:27 ` Anh Vo
2006-06-14 15:13 ` Alex R. Mosteo
2006-06-14 15:37 ` Anh Vo
2006-06-14 17:00 ` Dmitry A. Kazakov
2006-06-15 3:48 ` Anh Vo
2006-06-15 8:21 5% ` Dmitry A. Kazakov
2006-06-17 1:21 0% ` Randy Brukardt
2006-06-17 8:24 0% ` Dmitry A. Kazakov
2006-07-09 13:42 7% How to properly clean up an extended, generic structure? Peter C. Chapin
2006-07-09 14:29 0% ` jimmaureenrogers
2006-07-09 14:33 0% ` Ludovic Brenta
2006-07-09 14:49 0% ` Björn Persson
2006-07-26 19:34 13% Why people wants to complicate code with Ada.Unchecked_Deallocation? fabio de francesco
2006-07-26 19:51 8% ` Georg Bauhaus
2006-07-26 19:56 8% ` Simon Wright
2006-07-26 21:28 7% ` Jeffrey R. Carter
2006-07-27 15:49 7% ` adaworks
2006-07-27 19:11 7% ` Jeffrey R. Carter
2006-07-27 22:52 7% ` Simon Wright
2006-07-27 23:28 7% ` Robert A Duff
2006-07-27 0:07 8% ` Peter C. Chapin
2006-07-27 11:54 7% ` gautier_niouzes
2006-09-15 20:24 5% Address of an object Dmitry A. Kazakov
2006-09-15 23:31 0% ` Adam Beneschan
2006-09-16 8:13 0% ` Dmitry A. Kazakov
2006-09-21 21:08 Free'ing dynamic abstract tagged types ldb
2006-09-21 22:12 7% ` Randy Brukardt
2006-10-20 10:47 GNAT compiler switches and optimization tkrauss
2006-10-20 22:11 ` Jeffrey R. Carter
2006-10-20 23:52 ` Jeffrey Creem
2006-10-21 7:37 ` Gautier
2006-10-21 16:35 ` Jeffrey Creem
2006-10-21 17:04 ` Pascal Obry
2006-10-21 21:22 ` Jeffrey Creem
2006-10-22 3:03 ` Jeffrey Creem
2006-10-22 7:39 ` Jeffrey R. Carter
2006-10-22 11:48 ` tkrauss
2006-10-22 18:02 ` Georg Bauhaus
2006-10-22 18:24 ` Jeffrey Creem
2006-10-23 0:10 5% ` Georg Bauhaus
2006-11-30 23:40 7% Deallocating list of polymorphic objects? Michael Rohan
2006-12-01 1:24 6% ` Randy Brukardt
2007-01-23 5:53 How come Ada isn't more popular? artifact.one
2007-01-23 6:37 ` adaworks
2007-01-25 11:31 ` Ali Bendriss
2007-01-27 5:12 ` Charles D Hixson
2007-01-27 9:52 ` Markus E Leypold
2007-01-27 22:01 ` Charles D Hixson
2007-01-27 23:24 ` Markus E Leypold
2007-01-28 9:14 ` Dmitry A. Kazakov
2007-01-28 15:06 ` Markus E Leypold
2007-01-29 14:37 ` Dmitry A. Kazakov
2007-01-29 15:50 ` Markus E Leypold
2007-01-31 10:55 ` Dmitry A. Kazakov
2007-01-31 15:16 ` Markus E Leypold
2007-02-01 14:22 ` Dmitry A. Kazakov
2007-02-01 19:31 ` Ray Blaak
2007-02-01 22:54 ` Randy Brukardt
2007-02-02 1:37 ` in defense of GC (was Re: How come Ada isn't more popular?) Ray Blaak
2007-02-02 21:50 5% ` Gautier
2007-02-04 8:19 0% ` Ray Blaak
2007-02-04 19:54 Topological Sort Help isaac2004
2007-02-04 21:45 ` Ludovic Brenta
2007-02-05 20:30 ` isaac2004
2007-02-05 20:39 ` Ludovic Brenta
2007-02-06 2:18 ` isaac2004
2007-02-06 9:06 ` Ludovic Brenta
2007-02-08 1:19 ` isaac2004
2007-02-08 9:25 ` Ludovic Brenta
2007-02-08 18:14 ` isaac2004
2007-02-08 18:24 ` Ludovic Brenta
2007-02-08 18:29 5% ` isaac2004
2007-02-07 4:39 Why does this work? (overloads) Jerry
2007-02-07 19:02 ` Jeffrey R. Carter
2007-02-07 20:53 ` Jerry
2007-02-08 0:53 ` Jeffrey R. Carter
2007-02-08 10:40 ` Jerry
2007-02-08 18:52 6% ` Jeffrey R. Carter
2007-04-11 11:34 Impossible problem? A protected buffer to queue objects of a class-wide type Phil Slater
2007-04-11 13:14 5% ` Dmitry A. Kazakov
2007-04-13 17:02 6% ` Matthew Heaney
2007-05-08 21:55 Finalization of static package variables Manuel Collado
2007-05-09 8:20 ` Stephen Leake
2007-05-09 22:19 6% ` Manuel Collado
2007-05-10 10:55 ` Stephen Leake
2007-05-11 18:12 6% ` Manuel Collado
2007-05-11 18:26 0% ` Robert A Duff
2008-01-28 13:49 Allocators and memory reclamation Maciej Sobczak
2008-01-28 22:00 8% ` Aurele
2008-02-19 8:47 Bug in Ada (SuSe 10.2) ? Reinert Korsnes
2008-02-19 9:08 ` Niklas Holsti
2008-02-19 9:53 ` Reinert Korsnes
2008-02-19 11:21 ` Ludovic Brenta
2008-02-20 12:41 ` Reinert Korsnes
2008-02-20 16:50 ` Adam Beneschan
2008-02-20 18:31 ` Jeffrey R. Carter
2008-02-20 23:22 ` Adam Beneschan
2008-02-21 0:31 ` Randy Brukardt
2008-02-21 8:56 ` Jean-Pierre Rosen
2008-02-21 9:08 ` Alex R. Mosteo
2008-02-21 9:27 ` Ludovic Brenta
2008-02-21 9:46 ` billjones6789
2008-02-21 22:32 ` Randy Brukardt
2008-02-22 16:10 ` billjones6789
2008-02-22 19:21 7% ` Georg Bauhaus
2008-02-22 21:29 0% ` Vadim Godunko
2008-02-22 21:39 0% ` Robert A Duff
2008-02-23 10:16 0% ` billjones6789
2008-03-08 6:04 Robert Dewar's great article about the Strengths of Ada over other langauges in multiprocessing! ME
2008-03-08 22:11 ` Maciej Sobczak
2008-03-09 8:20 ` Pascal Obry
2008-03-09 12:40 ` Vadim Godunko
2008-03-09 13:37 ` Dmitry A. Kazakov
2008-03-09 14:41 5% ` Vadim Godunko
2008-06-17 8:07 Question on initialization of packages Reinert Korsnes
2008-06-17 8:50 ` Dmitry A. Kazakov
2008-06-17 9:14 ` Reinert Korsnes
2008-06-17 10:26 6% ` Dmitry A. Kazakov
2008-06-17 12:03 0% ` Reinert Korsnes
2008-06-17 10:18 5% ` christoph.grein
2008-06-20 9:03 another way to shoot yourself in the foot? fedya_fedyakoff
2008-06-20 10:05 ` christoph.grein
2008-06-20 19:27 ` Robert A Duff
2008-06-20 23:37 ` Jeffrey R. Carter
2008-06-21 8:56 ` Dmitry A. Kazakov
2008-06-22 20:44 ` Robert A Duff
2008-06-23 7:49 ` Dmitry A. Kazakov
2008-06-24 14:59 ` Adam Beneschan
2008-06-24 16:41 ` Dmitry A. Kazakov
2008-06-24 17:20 ` Robert A Duff
2008-06-24 17:52 7% ` Dmitry A. Kazakov
2008-08-08 11:31 How to implement a server socket compatible to telnet? snoopysalive
2008-08-08 16:24 ` anon
2008-08-10 22:15 ` Robert A Duff
2008-08-10 23:34 ` anon
2008-08-11 1:31 ` Robert A Duff
2008-08-11 18:26 ` anon
2008-08-11 18:59 ` Samuel Tardieu
2008-08-20 21:25 6% ` snoopysalive
2008-08-20 22:57 0% ` anon
2009-03-11 20:26 Newbie question -- dereferencing access Tim Rowe
2009-03-11 20:46 ` Ludovic Brenta
2009-03-12 9:57 ` Tim Rowe
2009-03-12 12:13 ` christoph.grein
2009-03-12 13:30 ` Ed Falis
2009-03-13 9:55 ` Tim Rowe
2009-03-13 11:06 ` Alex R. Mosteo
2009-03-13 16:31 ` Tim Rowe
2009-03-13 17:33 3% ` Martin
2009-04-03 12:01 Load an object from a file Olivier Scalbert
2009-04-03 13:37 5% ` Ludovic Brenta
2009-04-03 15:19 0% ` Olivier Scalbert
2009-04-09 20:32 6% ` Olivier Scalbert
2009-04-19 13:08 0% ` Olivier Scalbert
2009-04-16 13:43 Problems with Scope of aliased Objects patrick.gunia
2009-04-16 15:47 5% ` Dmitry A. Kazakov
2009-05-31 10:41 Howto read line from a stream Tomek Walkuski
2009-05-31 11:29 ` Tomek Wałkuski
2009-05-31 12:02 6% ` Dmitry A. Kazakov
2009-05-31 12:56 5% ` Tomek Wałkuski
2009-05-31 15:13 0% ` Dmitry A. Kazakov
2009-07-11 0:03 Pointer types (I mean access types) Rob Solomon
2009-07-11 19:41 7% ` anon
2009-09-28 8:43 5% Unchecked_Deallocation of class-wide objects Maciej Sobczak
2009-09-28 9:12 0% ` Dmitry A. Kazakov
2009-09-30 21:25 Proper program structure Maciej Sobczak
2009-10-01 6:34 ` Brad Moore
2009-10-01 9:39 ` Maciej Sobczak
2009-10-01 15:36 ` Brad Moore
2009-10-01 20:01 ` Maciej Sobczak
2009-10-02 5:44 ` Brad Moore
2009-10-02 13:10 7% ` Brad Moore
2009-11-17 10:17 5% Tail recursion upon task destruction Dmitry A. Kazakov
2010-03-05 11:41 Having a problem building with win32ada John McCabe
2010-03-09 21:00 3% ` John McCabe
2010-03-09 21:37 8% ` John McCabe
2010-03-08 11:40 6% This MIDI stuff, would someone be interested in reviewing my code? John McCabe
2010-03-13 8:12 0% ` Christophe Chaumet
2010-07-11 20:52 ANN: Simple components for Ada v3.9 Dmitry A. Kazakov
2010-07-12 20:36 ` Dirk Heinrichs
2010-07-13 7:55 ` Dmitry A. Kazakov
2010-07-13 12:45 ` Ludovic Brenta
2010-07-13 16:35 6% ` Dmitry A. Kazakov
2010-08-01 12:17 S-expression I/O in Ada Natacha Kerensikova
2010-08-17 17:01 6% ` Natasha Kerensikova
2010-08-27 13:19 3% ` Natasha Kerensikova
2010-10-27 15:00 7% GNAT bug - still in 2010? Maciej Sobczak
2010-10-27 16:11 0% ` Alexander S. Mentis
2011-01-22 0:04 User Defined Storage Pool : did you ever experiment with it ? Yannick Duchêne (Hibou57)
2011-01-22 9:47 5% ` User Defined Storage Pool : Example anon
2011-01-24 14:04 ` User Defined Storage Pool : did you ever experiment with it ? Timo Warns
2011-01-24 23:34 0% ` Yannick Duchêne (Hibou57)
2011-02-18 22:52 Need some light on using Ada or not Luis P. Mendes
2011-02-19 13:07 ` Brian Drummond
2011-02-19 14:36 ` Georg Bauhaus
2011-02-19 18:25 ` Brian Drummond
2011-02-20 14:34 ` Brian Drummond
2011-02-20 15:45 ` jonathan
2011-02-20 19:49 ` Pascal Obry
2011-02-20 19:57 ` Brian Drummond
2011-02-20 22:47 ` Simon Wright
2011-02-21 12:52 ` Brian Drummond
2011-02-21 13:44 5% ` Simon Wright
2011-02-23 19:01 7% Using local storage pools Brian Drummond
2011-02-23 20:51 0% ` Ludovic Brenta
2011-08-30 13:22 Delayed deallocation of non-terminated task in Gnat? Marc C
2011-08-30 15:38 ` Adam Beneschan
2011-08-30 16:42 7% ` Dmitry A. Kazakov
2011-08-30 18:57 0% ` Niklas Holsti
2011-08-30 19:23 0% ` Dmitry A. Kazakov
2012-02-02 23:41 Preventing Unchecked_Deallocation? Simon Belmont
2012-02-04 14:40 ` AdaMagica
2012-02-05 16:42 5% ` Simon Belmont
2012-02-07 16:27 7% ` Robert A Duff
2012-04-04 16:08 Tasking, AWS and segmentation faults tonyg
2012-04-04 19:09 6% ` Vadim Godunko
2012-08-31 10:34 5% GNATCOLL SQLite rollback vs cursor Stephen Leake
2012-12-05 13:53 Task with access to itself? Jacob Sparre Andersen
2012-12-05 14:18 5% ` Dmitry A. Kazakov
2012-12-15 3:38 Question about library-level functions ytomino
2012-12-15 9:47 ` AdaMagica
2012-12-15 10:50 7% ` ytomino
2013-01-30 0:44 Ada and string literals codeallergy
2013-01-30 7:08 ` Niklas Holsti
2013-01-30 11:50 ` Mart van de Wege
2013-01-30 16:52 ` codeallergy
2013-02-01 21:16 7% ` gautier_niouzes
2013-08-10 21:45 Questions on Storage Pools AdaMagica
2013-08-12 17:14 ` Adam Beneschan
2013-08-13 19:36 6% ` AdaMagica
2013-08-28 11:49 Anonymous access types are evil, why? ake.ragnar.dahlgren
2013-08-30 16:16 4% ` Gerhard Rummel
2013-09-11 10:45 Reference counting and idempotent finalize Natasha Kerensikova
2013-09-11 12:21 5% ` Jeffrey R. Carter
2013-11-12 11:09 Increasing GNAT's heap Dmitry A. Kazakov
2013-11-12 13:26 ` Georg Bauhaus
2013-11-12 14:00 ` Dmitry A. Kazakov
2013-11-12 19:30 6% ` Georg Bauhaus
2014-05-16 7:37 6% Help with type definition hanslad
2014-06-15 10:10 Termination of periodic tasks Natasha Kerensikova
2014-06-15 16:54 ` Jeffrey Carter
2014-06-16 14:02 ` Natasha Kerensikova
2014-06-16 17:08 ` Jeffrey Carter
2014-06-17 6:57 ` Natasha Kerensikova
2014-06-17 7:37 ` Dmitry A. Kazakov
2014-06-17 7:47 ` Natasha Kerensikova
2014-06-17 8:45 7% ` Dmitry A. Kazakov
2014-06-17 12:02 ` Jacob Sparre Andersen
2014-06-17 19:32 3% ` Natasha Kerensikova
2014-07-05 6:43 Position of "use" Victor Porton
2014-07-09 10:36 ` anon
2014-07-09 15:14 ` Adam Beneschan
2014-07-10 1:27 ` anon
2014-07-10 9:50 ` AdaMagica
2014-07-10 13:10 ` J-P. Rosen
2014-07-10 15:57 ` Adam Beneschan
2014-07-10 17:47 0% ` Tero Koskinen
2014-07-17 18:15 Type_Invariant and Finalize Natasha Kerensikova
2014-07-17 21:30 6% ` Type_Invariant and instance creation (was: Type_Invariant and Finalize) Simon Wright
2014-07-18 6:17 7% Mission-Critical Design: Ada.Unchecked_Deallocation vs Garbage Collection NiGHTS
2014-07-18 6:25 8% ` Jeffrey Carter
2014-07-18 7:51 8% ` J-P. Rosen
2014-07-19 9:07 7% ` Pascal Obry
2014-07-18 12:41 7% ` Dennis Lee Bieber
2014-07-23 22:07 7% ` Robert A Duff
2014-07-24 1:00 6% ` Dennis Lee Bieber
2014-07-24 6:52 8% ` Simon Wright
2014-08-12 6:54 6% A simple question about the "new" allocator NiGHTS
2014-08-12 7:35 0% ` Dmitry A. Kazakov
2014-08-12 13:38 0% ` G.B.
2014-08-12 15:10 0% ` Adam Beneschan
2014-08-12 16:07 0% ` Jeffrey Carter
2014-09-03 9:38 newbie: can't read fast enough... :-) memory leaks gdotone
2014-09-03 10:17 6% ` Pascal Obry
2014-09-04 4:57 0% ` Brad Moore
2014-09-23 0:43 6% Trying to understand Ada.Finalization.Controlled assignment mechanics Jeremiah
2014-10-30 15:59 7% Question regarding example code in AI12-0140 Mark Lorenzen
2014-10-30 16:21 0% ` Adam Beneschan
2014-10-31 19:40 0% ` AdaMagica
2014-11-01 15:31 0% ` Brad Moore
2014-11-08 3:58 0% ` Randy Brukardt
2015-02-02 5:50 7% Did I find mamory leak in Generic Image Decoder (GID) ? reinkor
2015-02-24 9:07 silly ravenscar question jan.de.kruyf
2015-02-24 11:02 ` Jacob Sparre Andersen
2015-02-24 11:23 ` jan.de.kruyf
2015-02-24 15:30 6% ` Brad Moore
2015-02-24 11:24 6% ` J-P. Rosen
2015-02-24 12:10 6% ` jan.de.kruyf
2015-07-26 7:11 6% Why does `Unchecked_Deallocation` need the access type? EGarrulo
2015-07-26 8:54 0% ` Dmitry A. Kazakov
2015-07-26 11:16 8% ` Niklas Holsti
2015-07-27 14:28 Running a preprocessor from GPS? EGarrulo
2015-07-27 20:26 ` Randy Brukardt
2015-07-28 11:36 ` EGarrulo
2015-07-28 21:12 ` Randy Brukardt
2015-07-28 22:11 6% ` EGarrulo
2015-07-29 20:32 6% ` Randy Brukardt
2015-12-31 4:15 Abortable Timed Action T.G.
2015-12-31 6:40 ` Anh Vo
2015-12-31 7:32 ` T.G.
2015-12-31 16:21 ` Anh Vo
2015-12-31 18:09 ` T.G.
2016-01-06 21:14 ` Anh Vo
2016-01-08 20:24 4% ` T.G.
2016-01-09 8:45 0% ` Simon Wright
2016-04-05 2:03 5% Ada 2005,Doubly_Linked_List with Controlled parameter George J
2016-06-15 23:50 Finalization and class-wide views Alejandro R. Mosteo
2016-06-16 11:10 6% ` Alejandro R. Mosteo
2016-08-25 20:17 zLibAda vs ZipAda (which should I use, if any)? Aurele
2016-08-25 23:07 ` Aurele
2016-08-25 23:43 ` gautier_niouzes
2016-08-25 23:55 ` Aurele
2016-08-26 0:18 ` gautier_niouzes
2016-08-26 1:44 ` Aurele
2016-08-26 12:36 ` gautier_niouzes
2016-08-26 14:23 ` Aurele
2016-08-26 15:16 ` gautier_niouzes
2016-08-26 16:05 ` Aurele
2016-08-26 23:04 ` Aurele
2016-08-27 5:30 ` gautier_niouzes
2016-08-27 11:52 ` Aurele
2016-08-27 16:31 ` Aurele
2016-08-27 19:15 5% ` gautier_niouzes
2017-05-06 2:23 Portable memory barrier? Jere
2017-05-07 20:18 ` Robert Eachus
2017-05-08 7:45 ` Dmitry A. Kazakov
2017-05-08 15:56 ` Robert Eachus
2017-05-08 16:22 ` Dmitry A. Kazakov
2017-05-09 19:53 ` Randy Brukardt
2017-05-09 20:27 ` Dmitry A. Kazakov
2017-05-11 0:35 ` Randy Brukardt
2017-05-11 8:24 ` Dmitry A. Kazakov
2017-05-15 22:53 ` Randy Brukardt
2017-05-18 17:44 4% ` Dmitry A. Kazakov
2017-05-18 21:01 0% ` Randy Brukardt
2017-09-14 5:09 use Ada.Text_IO in main() or Package? Mace Ayres
2017-09-14 6:21 ` gautier_niouzes
2017-09-14 6:47 ` Mace Ayres
2017-09-14 7:13 ` gautier_niouzes
2017-09-14 9:37 ` Mace Ayres
2017-09-14 9:49 5% ` gautier_niouzes
2017-12-03 2:14 Full view of a private partial view cannot be a subtype Jere
2017-12-04 20:49 ` Randy Brukardt
2017-12-05 12:56 ` Jere
2017-12-05 20:12 ` Randy Brukardt
2017-12-17 15:26 ` Jere
2017-12-17 15:39 ` Dmitry A. Kazakov
2017-12-19 1:01 4% ` Jere
2017-12-19 9:08 0% ` Dmitry A. Kazakov
2017-12-19 13:08 0% ` Jere
2017-12-19 19:10 0% ` Stephen Leake
2018-04-15 21:48 How to get Ada to “cross the chasm”? Dan'l Miller
2018-05-03 23:14 ` How to get Ada to ?cross the chasm?? Randy Brukardt
2018-05-04 0:07 ` Paul Rubin
2018-05-04 23:29 ` Randy Brukardt
2018-05-05 23:35 ` Paul Rubin
2018-05-06 8:34 ` Niklas Holsti
2018-05-06 9:53 ` Dmitry A. Kazakov
2018-05-06 15:32 ` Niklas Holsti
2018-05-06 17:40 ` Dmitry A. Kazakov
2018-05-06 19:27 ` Niklas Holsti
2018-05-06 21:02 ` Dmitry A. Kazakov
2018-05-07 1:31 ` Paul Rubin
2018-05-07 7:25 ` Dmitry A. Kazakov
2018-05-07 17:49 ` Paul Rubin
2018-05-07 19:05 ` Dmitry A. Kazakov
2018-05-07 20:29 ` Paul Rubin
2018-05-08 7:34 ` Dmitry A. Kazakov
2018-05-09 5:02 ` Paul Rubin
2018-05-09 8:25 ` Dmitry A. Kazakov
2018-05-09 21:33 ` Paul Rubin
2018-05-10 21:58 ` Randy Brukardt
2018-05-10 22:52 ` Paul Rubin
2018-05-11 7:21 8% ` Niklas Holsti
2018-04-18 8:01 4% Augmented active object pattern Dmitry A. Kazakov
2018-05-29 19:41 Memory pools John Perry
2018-05-31 19:28 5% ` gorgelo
2018-05-31 19:33 4% ` gorgelo
2019-01-24 23:56 6% ? Is ok return a type derived from ada.finalization.controlled from a "Pure_Function" ? thanks danielcheagle
2019-01-25 21:20 0% ` Randy Brukardt
2019-01-26 17:02 0% ` Daniel Norte Moraes
2019-02-02 20:01 4% Tracing a race condition Jere
2020-01-27 0:22 7% Having problems instantiating a child class with an extension aggregate b.mcguinness747
2020-03-23 23:16 6% GNAT vs Matlab - operation on multidimensional complex matrices darek
2021-04-17 21:45 Unchecked_Deallocation with tagged types DrPi
2021-04-17 22:29 6% ` Rod Kay
2021-04-17 22:36 6% ` Rod Kay
2021-04-18 9:06 0% ` DrPi
2021-04-18 9:07 6% ` Jeffrey R. Carter
2021-04-18 8:21 8% ` Dmitry A. Kazakov
2021-04-18 8:46 ` Gautier write-only address
2021-04-18 9:09 ` Jeffrey R. Carter
2021-04-18 10:13 ` Dmitry A. Kazakov
2022-04-16 3:44 6% ` Thomas
2022-04-16 8:09 0% ` Dmitry A. Kazakov
2021-04-18 10:20 ` J-P. Rosen
2021-04-18 10:34 ` Dmitry A. Kazakov
2021-04-18 15:14 ` J-P. Rosen
2021-04-18 15:23 ` Gautier write-only address
2021-04-18 15:53 ` J-P. Rosen
2021-04-18 16:08 9% ` Gautier write-only address
2022-04-16 5:00 0% ` Thomas
2021-04-18 9:13 0% ` DrPi
2021-09-13 0:53 Custom Storage Pool questions Jere
2021-09-15 16:43 4% ` Simon Wright
2021-09-29 9:09 6% On absurdity of collections 7.6.1 (11.1/3) Dmitry A. Kazakov
2022-10-23 12:31 6% 2-dimensional view on 1 dimensional array Marek
2023-01-22 21:34 Real_Arrays on heap with overloaded operators and clean syntax Jim Paloander
2023-01-22 21:56 ` Joakim Strandberg
2023-01-22 22:07 ` Jim Paloander
2023-01-22 22:42 ` Joakim Strandberg
2023-01-22 22:49 ` Jim Paloander
2023-01-22 23:14 ` Gautier write-only address
2023-01-23 1:14 8% ` Leo Brewin
2023-01-23 6:01 0% ` Jim Paloander
2023-11-14 21:11 8% Unchecked_Deallocation with tagged class type Blady
2023-11-14 22:42 0% ` Dmitry A. Kazakov
2023-11-15 20:26 7% ` Blady
2023-11-15 21:17 0% ` Dmitry A. Kazakov
This is a public inbox, see mirroring instructions
for how to clone and mirror all data and code used for this inbox