with Ada.Text_IO;
with Ada.Finalization;
with GNAT.Debug_Utilities;
procedure Test is
type T is new Ada.Finalization.Limited_Controlled with null record;
overriding procedure Finalize(Object : in out T) is
begin
Ada.Text_IO.Put_Line("finalize " & GNAT.Debug_Utilities.Image(Object'Address));
end Finalize;
begin
Ada.Text_IO.Put_Line("begin");
Scope : declare
type T_Access is access T; -- スコープ限定のアクセス型
It : T_Access := new T;
begin
Ada.Text_IO.Put_Line("Address = " & GNAT.Debug_Utilities.Image(It.all'Address));
end Scope;
Ada.Text_IO.Put_Line("end");
end Test;
begin
Address = 16#0027_6018#
finalize 16#0027_6018#
end
関数の間接参照
with Ada.Calendar.Formatting;
with Ada.Text_IO;
procedure Sample is
type Image_Access is access function(Value : Ada.Calendar.Time; Include_Time_Fraction : Boolean := False) return String;
Image : not null Image_Access := Ada.Calendar.Formatting.Image'Access;
begin
Ada.Text_IO.Put_Line(Image.all(Ada.Calendar.Clock)(1 .. 10));
end Sample;
2006-03-28
関数のオーバーロード
with Ada.Text_IO;
with Ada.Integer_Text_IO;
procedure Sample is
procedure Put(Item : in String) renames Ada.Text_IO.Put;
procedure Put(Item : in Integer) is
begin
Ada.Integer_Text_IO.Put(Item, Width => 1);
end Put;
begin
Put("1 + 1 = ");
Put(1 + 1);
end Sample;
1 + 1 = 2
出力パラメータ
with Ada.Text_IO; use Ada.Text_IO;
with Ada.Integer_Text_IO; use Ada.Integer_Text_IO;
procedure Sample is
procedure Foo(Bar : out Integer) is
begin
Bar := 4567;
end Foo;
Test : Integer;
begin
Test := 1234;
Put(Test); New_Line;
Foo(Test);
Put(Test); New_Line;
end Sample;
1234
4567
ネストした関数
with Ada.Text_IO; use Ada.Text_IO;
with Ada.Integer_Text_IO; use Ada.Integer_Text_IO;
procedure Sample is
procedure Foo is
procedure Xyzzy(Value: Integer); -- forward宣言可能なので相互再帰も可能
Bar : Integer;
procedure Xyzzy(Value: Integer) is
begin
Bar := Bar + Value;
end Xyzzy;
begin
Bar := 10;
Put(Bar); New_Line;
Xyzzy(1000);
Put(Bar); New_Line;
end Foo;
begin
Foo;
end Sample;
10
1010
Downward closure
with Ada.Long_Long_Float_Text_IO; use Ada.Long_Long_Float_Text_IO;
procedure Sample is
subtype Real is Long_Long_Float;
function Integral(Func : not null access function(X : Real) return Real;
First, Last : Real; D : Real := 0.001) return Real
is
Result : Real := 0.0;
I : Real := First;
begin
while I < Last loop
Result := Result + Func(I);
I := I + D;
end loop;
return Result / ((First + Last) / D);
end Integral;
-- Σ(I=0..1)Σ(J=0..1)I*J
function F1(X : Real) return Real is
function F2(X : Real) return Real is
begin
return F1.X * X;
-- 頭悪い求め方ですがあまり複雑な式は私が検算できないのでorz
end F2;
begin
return Integral(F2'Access, 0.0, 1.0);
end F1;
begin
Put(Integral(F1'Access, 0.0, 1.0));
end Sample;
2.49500250000000001E-01
可変個引数の真似
with Ada.Integer_Text_IO;
procedure Sample is
type Integer_Array is array(Positive range <>) of Integer;
function Sum(Items : Integer_Array) return Integer is
begin
if Items'Length = 0 then
return 0;
else
return Items(Items'First) + Sum(Items(Items'First + 1 .. Items'Last));
end if;
end Sum;
begin
Ada.Integer_Text_IO.Put(Sum((1, 2, 3, 4)));
end Sample;
10
固定長配列
with Ada.Text_IO; use Ada.Text_IO;
with Ada.Integer_Text_IO; use Ada.Integer_Text_IO;
procedure Sample is
Array1 : constant array(0 .. 2, 0 .. 1) of Integer := (
(0, 1),
(2, 3),
(4, 5));
type Integer_Array is array(Integer range <>) of Integer;
Array2 : constant array(0 .. 2) of Integer_Array(0 .. 1) := (
(0, 1),
(2, 3),
(4, 5));
begin
Put("Array1'Length = "); Put(Array1'Length); New_Line;
Put("Array1'Length(1) = "); Put(Array1'Length(1)); New_Line;
Put("Array1'Length(2) = "); Put(Array1'Length(2)); New_Line;
Put("Array2'Length = "); Put(Array2'Length); New_Line;
Put("Array2(0)'Length = "); Put(Array2(0)'Length); New_Line;
end Sample;
with Ada.Text_IO; use Ada.Text_IO;
with Ada.Integer_Text_IO;
procedure Sample is
type Integer_Array is array(Positive range <>) of Integer;
procedure Put(Value : Integer_Array) is
begin
for I in Value'Range loop
Ada.Integer_Text_IO.Put(Value(I), 4);
end loop;
end Put;
Array1 : access Integer_Array;
begin
Array1 := new Integer_Array(1 .. 3);
for I in Array1'Range loop
Array1(I) := I;
end loop;
Put(Array1.all); New_Line;
Array1 := new Integer_Array'(Array1.all & (4 .. 5 => 0));
Put(Array1.all); New_Line;
Array1 := new Integer_Array'(Array1(1 .. 2));
Put(Array1.all); New_Line;
end Sample;
1 2 3
1 2 3 0 0
1 2
要素が1bit長の配列
with Ada.Text_IO; use Ada.Text_IO;
procedure Sample is
type Boolean_Bits is array(Natural range <>) of Boolean;
for Boolean_Bits'Component_Size use 1;
procedure Put(Value : Boolean_Bits) is
Text : constant array(Boolean) of Character := "01";
begin
for I in Value'Range loop
Put(Text(Value(I)));
end loop;
end Put;
type Bit is mod 2;
type Integer_Bits is array(Natural range <>) of Bit;
for Integer_Bits'Component_Size use 1;
procedure Put(Value : Integer_Bits) is
Text : constant array(Bit) of Character := "01";
begin
for I in Value'Range loop
Put(Text(Value(I)));
end loop;
end Put;
type Primary_Color is (R, G, B);
type Mixed_Color is array(Primary_Color) of Boolean;
for Mixed_Color'Component_Size use 1;
procedure Put(Value : Mixed_Color) is
Text : constant array(Primary_Color, Boolean) of Character := ("-R", "-G", "-B");
begin
for I in Value'Range loop
Put(Text(I, Value(I)));
end loop;
end Put;
begin
Put(Boolean_Bits'(False, True, True)); New_Line;
Put(Boolean_Bits'(True, False, False) or Boolean_Bits'(False, False, True)); New_Line;
Put(Boolean_Bits'(True, True, False) and Boolean_Bits'(False, True, True)); New_Line;
Put(Integer_Bits'(0, 1, 1, 0, 1, 1, 0, 1)); New_Line;
Put(Mixed_Color'(R => True, others => False) or Mixed_Color'(B => True, others => False)); New_Line;
Put(Mixed_Color'(R | G => True, others => False) and Mixed_Color'(G | B => True, others => False)); New_Line;
end Sample;
011
101
010
01101101
可変長文字列
with Ada.Strings.Unbounded; use Ada.Strings.Unbounded;
with Ada.Text_IO; use Ada.Text_IO;
with Ada.Strings.Unbounded.Text_IO; use Ada.Strings.Unbounded.Text_IO;
procedure Sample is
s, s2 : Unbounded_String;
begin
s := To_Unbounded_String("Ada");
Put("s = "); Put(s); New_Line;
s2 := s;
Replace_Element(s2, 1, 'c');
Replace_Element(s2, 2, 'c');
Put("変更した s2 = "); Put(s2); New_Line;
Put("元の s = "); Put(s); New_Line;
s := s & "phi";
Put("結合した s = "); Put(s); New_Line;
if s < "Java" then
Put("s < Java"); New_Line;
else
Put("s >= Java"); New_Line;
end if;
end Sample;
s = Ada
変更した s2 = cca
元の s = Ada
結合した s = Adaphi
s < Java
配列のスライシング
with Ada.Text_IO; use Ada.Text_IO;
with Ada.Integer_Text_IO; use Ada.Integer_Text_IO;
procedure Sample is
type Integer_Array is array(Positive range <>) of Integer;
procedure Put(Item : Integer_Array) is
begin
for I in Item'Range loop
Put(Item(I), Width => 4);
end loop;
end Put;
Array1 : Integer_Array(1 .. 10);
begin
for I in Array1'Range loop
Array1(I) := I;
end loop;
Put(Array1); New_Line;
Put(Array1(1 .. 5)); New_Line;
Put(Array1(6 .. 10)); New_Line;
end Sample;
1 2 3 4 5 6 7 8 9 10
1 2 3 4 5
6 7 8 9 10
境界チェック
with Ada.Text_IO;
with Ada.Exceptions;
procedure Sample is
pragma Unsuppress(Range_Check);
type Integer_Array is array(Natural range <>) of Integer;
Array1: array(0 .. 3) of Integer;
Array2: access Integer_Array;
begin
begin
for i in 0 .. 4 loop
Array1(i) := i;
end loop;
exception
when E : Constraint_Error =>
Ada.Text_IO.Put_Line(Ada.Exceptions.Exception_Name(E));
end;
Array2 := new Integer_Array(0 .. 3);
begin
for i in 0 .. 4 loop
Array2(i) := i;
end loop;
exception
when E : Constraint_Error =>
Ada.Text_IO.Put_Line(Ada.Exceptions.Exception_Information(E));
end;
end Sample;
CONSTRAINT_ERROR
Exception name: CONSTRAINT_ERROR
Message: a_range_check.adb:20 index check failed
連想配列
with Ada.Containers.Indefinite_Ordered_Maps;
with Ada.Text_IO; use Ada.Text_IO;
procedure Sample is
package String_Maps is
new Ada.Containers.Indefinite_Ordered_Maps(String, String);
use String_Maps;
Stand : String_Maps.Map;
begin
Insert(Stand, "空条承太郎", "スター・プラチナ");
Insert(Stand, "アラビア・ファッツ", "サン");
Insert(Stand, "猫草", "ストレイ・キャット");
Insert(Stand, "サーレー", "クラフト・ワーク");
Put(Stand.Element("猫草")); New_Line;
declare
procedure Process(Position : in String_Maps.Cursor) is
begin
Put(Key(Position)); Put(" = "); Put(Element(Position)); New_Line;
end Process;
begin
Iterate(Stand, Process'Access);
end;
end Sample;
with Ada.Text_IO; use Ada.Text_IO;
procedure Sample is
subtype Digit is Natural range 0 .. 9;
type My_Integer is new Integer;
procedure Proc(X : in out Integer) is
begin
X := 10;
end Proc;
procedure Overloaded(X : in Integer) is
begin
Put("Integer ");
end Overloaded;
procedure Overloaded(X : in My_Integer) is
begin
Put("My_Integer ");
end Overloaded;
function Get return Digit is
begin
return 1;
end Get;
function Get return My_Integer is
begin
return 2;
end Get;
X : Integer;
Y : My_Integer;
begin
Proc(X);
-- Proc(Y); -- error
Overloaded(X);
Overloaded(Y);
X := Get; Put(X'Img);
Y := Get; Put(Y'Img);
end Sample;
Integer My_Integer 1 2
文字列から列挙型へ
with Ada.Text_IO;
procedure Sample is
type Items is (Light, Misa, Higuchi, Mikami);
begin
case Items'Value(Ada.Text_IO.Get_Line) is
when Light => Ada.Text_IO.Put("FUHAHAHAHAHAHA...");
when Misa => Ada.Text_IO.Put("HAIJITSURYOKUDESU");
when Higuchi => Ada.Text_IO.Put("BAKAKA");
when Mikami => Ada.Text_IO.Put("GOD");
end case;
exception
when Constraint_Error => Ada.Text_IO.Put("Please wait 40 seconds.");
end Sample;
light
FUHAHAHAHAHAHA...
インターフェイス
with Ada.Text_IO;
procedure Sample is
package P is
type Printable is interface;
procedure Print(Object : Printable) is abstract;
end P;
type Test is new P.Printable with null record;
procedure Print(Object : Test) is
begin
Ada.Text_IO.Put_Line("The world!!");
end Print;
procedure Put(Value : P.Printable'Class) is
begin
P.Print(Value);
end Put;
X : Test;
begin
Put(X);
end Sample;
The world!!
演算子オーバーロード
with Ada.Text_IO; use Ada.Text_IO;
with Ada.Integer_Text_IO; use Ada.Integer_Text_IO;
procedure Sample is
type Decimal_Column is range 0 .. 9;
type Decimal_Integer is array(Natural range <>) of Decimal_Column;
function "+"(X, Y : Decimal_Integer) return Decimal_Integer is
Min : Natural := Natural'Min(X'First, Y'First);
Max : Natural := Natural'Max(X'Last, Y'Last);
Result : Decimal_Integer(Min .. Max + 1);
Work : Natural := 0;
begin
for I in Min .. Max loop
if I in X'Range then
Work := Work + Natural(X(I));
end if;
if I in Y'Range then
Work := Work + Natural(Y(I));
end if;
Result(I) := Decimal_Column(Work rem 10);
Work := Work / 10;
end loop;
return Result;
end "+";
function "abs"(X : Decimal_Integer) return Natural is
Result : Natural := 0;
begin
for I in X'Range loop
Result := Result + Natural(X(I)) * 10 ** I;
end loop;
return Result;
end "abs";
X : Decimal_Integer := (0, 1);
Y : Decimal_Integer := (0, 0, 1);
begin
Put(abs (X + Y)); New_Line;
end Sample;
110
パッケージ
with Pure_Package;
with Preelaborate_Package;
with Initializing_Package;
procedure Sample is
begin
null;
end Sample;
-- with Preelaborate_Package; -- error
-- with Initializing_Package; -- error
with Ada.Numerics.Long_Long_Elementary_Functions; use Ada.Numerics.Long_Long_Elementary_Functions;
package Pure_Package is
pragma Pure;
Const : constant := 0;
-- Var : Integer; -- error
-- Expr : constant Long_Long_Float := Sin(0.0); -- error
end Pure_Package;
with Pure_Package;
-- with Initializing_Package; -- error
with Ada.Numerics.Long_Long_Elementary_Functions; use Ada.Numerics.Long_Long_Elementary_Functions;
package Preelaborate_Package is
pragma Preelaborate;
Const : constant := 0;
Var : Integer;
-- Expr : constant Long_Long_Float := Sin(0.0); -- error
end Preelaborate_Package;
with Pure_Package;
with Preelaborate_Package;
with Ada.Numerics.Long_Long_Elementary_Functions; use Ada.Numerics.Long_Long_Elementary_Functions;
package Initializing_Package is
pragma Elaborate_Body;
Const : constant := 0;
Var : Integer;
Expr : constant Long_Long_Float := Sin(0.0);
end Initializing_Package;
with Ada.Text_IO;
package body Initializing_Package is
begin
Ada.Text_IO.Put_Line("initialize");
end Initializing_Package;
initialize
型を可変としたインスタンスの作成
with Ada.Tags.Generic_Dispatching_Constructor;
with Ada.Text_IO; use Ada.Text_IO;
procedure Sample is
package S is
type T is abstract tagged record
Data : access String;
end record;
function Create(Params : access String) return T is abstract;
end S;
function Virtual_Create is new Ada.Tags.Generic_Dispatching_Constructor(
T => S.T, Parameters => String, Constructor => S.Create);
procedure Put(Item : S.T'Class) is
begin
Put(Ada.Tags.Expanded_Name(Item'Tag)); Put('-'); Put(Item.Data.all); New_Line;
end Put;
type T1 is new S.T with null record;
function Create(Params : access String) return T1 is
begin
return T1'(Data => new String'(Params.all)); -- difference scope
end Create;
Instance : S.T'Class := Virtual_Create(T1'Tag, new String'("tesutesu"));
begin
Put(Instance);
end Sample;
SAMPLE.T1-tesutesu
階層の深いところでの継承
with Ada.Text_IO;
with Ada.Tags;
procedure Sample is
type S is tagged null record;
function F return S'Class is
type D is new S with null record;
begin
return D'(null record); -- 持ち出せるか?
end F;
begin
Ada.Text_IO.Put_Line(Ada.Tags.External_Tag(F'Tag));
end Sample;
with Ada.Long_Long_Float_Text_IO; use Ada.Long_Long_Float_Text_IO;
procedure Sample is
subtype Real is Long_Long_Float;
type Rect is tagged record
Top, Left, Right, Bottom : Real;
end record;
function Width(Object : Rect'Class) return Real is
begin
return Object.Right - Object.Left;
end Width;
X : Rect := (10.0, 15.0, 30.0, 40.0);
begin
Put(X.Width);
end Sample;
1.50000000000000000E+01
インラインアセンブラ
with Ada.Text_IO;
with System.Machine_Code;
with Interfaces;
procedure Sample is
function Has_MMX return Boolean is
use ASCII; -- Obsoleteなんだけどね
use type Interfaces.Unsigned_32;
Result : Interfaces.Unsigned_32;
begin
System.Machine_Code.Asm("cpuid",
Inputs => Interfaces.Unsigned_32'Asm_Input("a", 1),
Outputs => Interfaces.Unsigned_32'Asm_Output("=d", Result));
return (Result and 16#800000#) /= 0;
end Has_MMX;
begin
if Has_MMX then
Ada.Text_IO.Put("MMX OK");
else
Ada.Text_IO.Put("NO MMX");
end if;
end Sample;
MMX OK
ハードウェアへの直接アクセス
with Interfaces;
with System;
procedure Sample is
Register : Interfaces.Unsigned_16;
for Register'Address use System'To_Address(16#12345678#);
-- アドレス空間をOSに管理されている状態でトチ狂ったことを
begin
Register := 16#abcd#;
end Sample;
with Ada.Long_Long_Float_Text_IO; use Ada.Long_Long_Float_Text_IO;
with Ada.Numerics.Long_Long_Elementary_Functions;
procedure Sample is
package Math renames Ada.Numerics.Long_Long_Elementary_Functions;
subtype Real is Long_Long_Float;
type Point is record
X, Y : Real;
end record;
function "abs"(Object : Point) return Real is
begin
return Math.Sqrt(Object.X ** 2 + Object.Y ** 2);
end "abs";
begin
Put(abs Point'(X => 3.0, Y => 4.0));
end Sample;
5.00000000000000000E+00
明示的なメモリ割り当て
with System.Storage_Pools;
with System.Pool_Global;
with System.Storage_Elements;
with Ada.Unchecked_Deallocation;
procedure Sample is
Memory1 : System.Address;
type Storage_Access is access System.Storage_Elements.Storage_Array;
procedure Free is new Ada.Unchecked_Deallocation(System.Storage_Elements.Storage_Array, Storage_Access);
Memory2 : Storage_Access;
begin
-- メモリマネージャを直接呼ぶ
System.Storage_Pools.Allocate(
Pool => System.Storage_Pools.Root_Storage_Pool'Class(System.Pool_Global.Global_Pool_Object),
Storage_Address => Memory1,
Size_In_Storage_Elements => 100,
Alignment => 4);
System.Storage_Pools.Deallocate(
Pool => System.Storage_Pools.Root_Storage_Pool'Class(System.Pool_Global.Global_Pool_Object),
Storage_Address => Memory1,
Size_In_Storage_Elements => 100,
Alignment => 4);
-- 理由が無ければこれで充分(サイズが記録される分オーバーヘッドあるけど)
Memory2 := new System.Storage_Elements.Storage_Array(1 .. 100);
Free(Memory2);
end Sample;
CLR向けコンパイル
with Mssyst.Console; use Mssyst;
with Mssyst.String; use Mssyst.String;
procedure Hello is
begin
Console.WriteLine(+"hello");
end Hello;
hello
ネイティブコードコンパイル
function A_Native(X : String) return Integer is
Result : Integer := 0;
begin
for I in X'Range loop
Result := Result + Character'Pos(X(I));
end loop;
return Result;
end A_Native;
with Ada.Containers.Vectors;
with Ada.Containers.Doubly_Linked_Lists;
with Ada.Text_IO; use Ada.Text_IO;
procedure Sample is
generic
type Element_Type is private;
with package Vectors is new Ada.Containers.Vectors(
Index_Type => Positive, -- 完全なAda2005ならothers => <>とできるのですが
Element_Type => Element_Type);
with package Lists is new Ada.Containers.Doubly_Linked_Lists(
Element_Type => Element_Type);
package Vector_To_List_Conversions is
function To_List(Container : Vectors.Vector) return Lists.List;
end Vector_To_List_Conversions;
package body Vector_To_List_Conversions is
function To_List(Container : Vectors.Vector) return Lists.List is
use Lists;
Result : Lists.List; -- 完全なAda2005ならreturn Result : Lists.List doとできるのですが
begin
for I in Container.First_Index .. Container.Last_Index loop
Append(Result, Container.Element(I));
end loop;
return Result;
end To_List;
end Vector_To_List_Conversions;
package Character_Vectors is new Ada.Containers.Vectors(Positive, Character);
package Character_Lists is new Ada.Containers.Doubly_Linked_Lists(Character);
use Character_Vectors;
use Character_Lists;
package Characters_Conversion is new Vector_To_List_Conversions(
Character, Character_Vectors, Character_Lists);
X : Character_Vectors.Vector := To_Vector(3);
begin
X.Replace_Element(1, 'A');
X.Replace_Element(2, 'd');
X.Replace_Element(3, 'a');
declare
Y : Character_Lists.List := Characters_Conversion.To_List(X);
Position : Character_Lists.Cursor := Y.First;
begin
while Has_Element(Position) loop
Put(Element(Position));
Next(Position);
end loop;
New_Line;
end;
end Sample;
Ada
総称関数
with Ada.Text_IO; use Ada.Text_IO;
with Ada.Integer_Text_IO; use Ada.Integer_Text_IO;
with Ada.Long_Long_Float_Text_IO; use Ada.Long_Long_Float_Text_IO;
with Ada.Numerics.Long_Long_Elementary_Functions; use Ada.Numerics.Long_Long_Elementary_Functions;
procedure Sample is
subtype Real is Long_Long_Float;
generic
type Value is private;
type Value_Array is array(Positive range <>) of Value;
Initial : in Value;
with function "**" (Left, Right : Value) return Value is <>;
function Fold(Values : Value_Array) return Value;
function Fold(Values : Value_Array) return Value is
Result : Value := Initial;
begin
for I in Values'Range loop
Result := Result ** Values(I);
end loop;
return Result;
end Fold;
type Integer_Array is array(Positive range <>) of Integer;
type Real_Array is array(Positive range <>) of Real;
function Sum is new Fold(Integer, Integer_Array, 0, "+");
function Sum is new Fold(Real, Real_Array, 0.0, "+");
function Prod is new Fold(Integer, Integer_Array, 1, "*");
function Add_Log(X, Y : Real) return Real is
begin
return X + Log(Y);
end Add_Log;
function Sum_Log is new Fold(Real, Real_Array, 0.0, Add_Log);
begin
Put(Sum(Integer_Array'(1, 2, 3, 4))); New_Line;
Put(Sum(Real_Array'(1.5, 2.5, 3.5, 4.5))); New_Line;
Put(Prod(Integer_Array'(1, 2, 3, 4))); New_Line;
Put(Sum_Log(Real_Array'(1.5, 2.5, 3.5, 4.5))); New_Line;
end Sample;
with Ada.Tags;
with Ada.Text_IO;
procedure Sample is
type S is tagged null record;
type T1 is new S with record Value : Integer; end record;
type T2 is new S with null record;
type T11 is new T1 with null record;
procedure Test(Object : S'Class) is
use type Ada.Tags.Tag;
begin
if Object'Tag = T1'Tag then
Ada.Text_IO.Put_Line("true T1");
declare
Object : T1 renames T1'Class(Test.Object);
begin
Ada.Text_IO.Put_Line(Object.Value'Img);
end;
elsif Object in T1'Class then
Ada.Text_IO.Put_Line("derived T1");
declare
Object : T1'Class renames T1'Class(Test.Object);
begin
Ada.Text_IO.Put_Line(Object.Value'Img);
end;
else
Ada.Text_IO.Put_Line("others");
end if;
end Test;
begin
Test(T1'(S'(null record) with Value => 1));
Test(T11'(T1'(S'(null record) with Value => 2) with null record));
Test(T2'(null record));
end Sample;
true T1
1
derived T1
2
others
ループ文
with Ada.Text_IO; use Ada.Text_IO;
procedure Sample is
X, Y : Integer;
begin
for I in 1 .. 9 loop
Put(I'Img);
end loop;
New_Line;
for I in reverse 1 .. 9 loop
Put(I'Img);
end loop;
New_Line;
X := 1;
while X < 100 loop
Put(X'Img);
X := X * 2;
end loop;
New_Line;
X := 10;
Outer : loop
Y := 1;
Inner : loop
Put("*");
exit Outer when X = Y and then X = 6;
exit when X = Y;
Y := Y + 1;
end loop Inner;
New_Line;
X := X - 1;
end loop Outer;
end Sample;
with Ada.Finalization;
with Ada.Text_IO; use Ada.Text_IO;
procedure Sample is
type Foo(Name : Character) is new Ada.Finalization.Limited_Controlled with null record;
overriding procedure Initialize(Object : in out Foo);
overriding procedure Finalize(Object : in out Foo);
overriding procedure Initialize(Object : in out Foo) is
begin
Put(Object.Name); Put(".begin"); New_Line;
end Initialize;
overriding procedure Finalize(Object : in out Foo) is
begin
Put(Object.Name); Put(".end"); New_Line;
end Finalize;
procedure Test is
bar : Foo('x');
hoge : Foo := (Ada.Finalization.Limited_Controlled with Name => 'y');
xyzzy : access Foo := new Foo('z');
begin
pragma Unreferenced(bar);
pragma Unreferenced(hoge);
pragma Unreferenced(xyzzy);
Put("y.manual-begin"); New_Line;
end Test;
begin
Put("test begin"); New_Line;
Test;
Put("test end"); New_Line;
end Sample;
test begin
x.begin
z.begin
y.manual-begin
z.end
y.end
x.end
test end
例外処理
with Ada.Exceptions;
with Ada.Text_IO;
with GNAT.Debug_Utilities;
with Ada.Exceptions.Traceback;
-- with GNAT.Traceback.Symbolic;
-- libaddr2line.aがあれば便利になります
procedure Sample is
procedure Proc(Params : Boolean;
Invalid_Data, Overflow : Ada.Exceptions.Exception_Id) is
begin
if Params then
Ada.Exceptions.Raise_Exception(Invalid_Data);
else
Ada.Exceptions.Raise_Exception(Overflow);
end if;
end Proc;
My_Exception_1 : exception;
My_Exception_2 : exception;
begin
Ada.Text_IO.Put_Line("before");
Proc(True, My_Exception_1'Identity, My_Exception_2'Identity);
Ada.Text_IO.Put_Line("after");
exception
when E : My_Exception_1 =>
declare
Traceback : Ada.Exceptions.Traceback.Tracebacks_Array :=
Ada.Exceptions.Traceback.Tracebacks(E);
begin
for I in reverse Traceback'Range loop
Ada.Text_IO.Put_Line(GNAT.Debug_Utilities.Image(Traceback(I)));
end loop;
--Ada.Text_IO.Put_Line(GNAT.Traceback.Symbolic.Symbolic_Traceback(Traceback));
end;
Ada.Text_IO.Put_Line(Ada.Exceptions.Exception_Information(E));
Ada.Exceptions.Reraise_Occurrence(E);
when E : others =>
Ada.Text_IO.Put_Line(Ada.Exceptions.Exception_Information(E));
end Sample;
with Ada.Text_IO; use Ada.Text_IO;
procedure Sample is
protected Sync is
function Get return Integer; -- Read Lock (gccではWrite Lock…)
procedure Set(New_Value : Integer; Name : Character); -- Write Lock
entry Enter;
entry Leave;
private
Value : Integer := 0;
Locked : Boolean := False;
end Sync;
protected body Sync is
function Get return Integer is
begin
return Value;
end Get;
procedure Set(New_Value : Integer; Name : Character) is
begin
Value := New_Value;
Put(Name); Put(Value'Img); New_Line;
end Set;
entry Enter when not Locked is
begin
Locked := True;
end Enter;
entry Leave when Locked is
begin
Locked := False;
end Leave;
end Sync;
task type Thread(Name : Character) is
entry Start;
end Thread;
task body Thread is
Local : Integer;
begin
accept Start;
for I in 1 .. 10 loop
Sync.Enter; -- これと
Local := Sync.Get;
delay 1.0;
Sync.Set(Local + 1, Name);
Sync.Leave; -- これを外すとThread1による更新が失われるように
end loop;
end Thread;
Thread1 : Thread('a');
Thread2 : Thread('b');
begin
Thread1.Start;
delay 0.5;
Thread2.Start;
end Sample;
a 1
b 2
a 3
b 4
a 5
b 6
a 7
b 8
a 9
b 10
a 11
b 12
a 13
b 14
a 15
b 16
a 17
b 18
a 19
b 20
列挙型
with Ada.Text_IO; use Ada.Text_IO;
with Ada.Unchecked_Conversion;
procedure Sample is
type THoge is (Moge, Xyzzy, Hage);
for THoge use (Moge => 0, Xyzzy => 1, Hage => 5);
type THoge_Integer is range 0 .. 5;
function Hoge_To_Integer is new Ada.Unchecked_Conversion(THoge, THoge_Integer);
Hoge : THoge;
procedure Xyzzy is null; -- overloading
type Foo is (Xyzzy, Moge, Hage, Bar); -- overloading
begin
Put("Moge = "); Put(THoge'Pos(Moge)'Img); Put(Hoge_To_Integer(Moge)'Img); New_Line;
Put("Xyzzy = "); Put(THoge'Pos(Xyzzy)'Img); Put(Hoge_To_Integer(Xyzzy)'Img); New_Line;
Put("Hage = "); Put(THoge'Pos(Hage)'Img); Put(Hoge_To_Integer(Hage)'Img); New_Line;
Put("THoge'Last = "); Put(THoge'First'Img); New_Line;
Put("THoge'First = "); Put(THoge'Last'Img); New_Line;
Hoge := Xyzzy;
Put("Hoge = "); Put(Hoge'Img); New_Line;
Hoge := THoge'Succ(Hoge);
Put("Succ(Hoge) = "); Put(Hoge'Img); New_Line;
end Sample;
with Ada.Text_IO; use Ada.Text_IO;
with Ada.Long_Float_Text_IO; use Ada.Long_Float_Text_IO;
with Ada.Numerics.Long_Elementary_Functions; use Ada.Numerics.Long_Elementary_Functions;
with Ada.Long_Long_Float_Text_IO; use Ada.Long_Long_Float_Text_IO;
with Ada.Numerics.Long_Long_Elementary_Functions; use Ada.Numerics.Long_Long_Elementary_Functions;
procedure Sample is
begin
Put(Sqrt(Long_Float'(2.0))); New_Line;
Put(Sqrt(Long_Long_Float'(2.0))); New_Line;
end Sample;
1.41421356237310E+00
1.41421356237309505E+00
複素数
with Ada.Text_IO; use Ada.Text_IO;
with Ada.Long_Long_Float_Text_IO; use Ada.Long_Long_Float_Text_IO;
with Ada.Numerics.Long_Long_Complex_Types; use Ada.Numerics.Long_Long_Complex_Types;
procedure Sample is
foo : Complex;
hoge : Imaginary;
xyzzy : Complex;
begin
foo := 1.0 + 1.0 * i;
hoge := 0.5 * i;
xyzzy := foo * hoge;
Put("foo = "); Put(Re(foo)); Put(" + "); Put(Im(foo)); Put(" * i"); New_Line;
Put("hoge = "); Put(Im(hoge)); Put("i"); New_Line;
Put("xyzzy = "); Put(Re(xyzzy)); Put(" + "); Put(Im(xyzzy)); Put(" * i"); New_Line;
end Sample;
foo = 1.00000000000000000E+00 + 1.00000000000000000E+00 * i
hoge = 5.00000000000000000E-01i
xyzzy = -5.00000000000000000E-01 + 5.00000000000000000E-01 * i
構造体のアラインメント
with Ada.Text_IO; use Ada.Text_IO;
with Ada.Integer_Text_IO; use Ada.Integer_Text_IO;
with Interfaces;
procedure Samples is
type Integer_4 is range -1 .. 14; -- 幅が16個までなら
for Integer_4'Size use 4; -- なんでも4ビットに押し込める
type Integer_1 is mod 2;
type T is record
X : Integer_4;
Y : Integer_1;
Z : Interfaces.Integer_32;
end record;
type Aligned_T is new T;
for Aligned_T'Alignment use 16;
type Packed_T is new T;
pragma Pack(Packed_T);
type Represented_T is new T;
for Represented_T use record
X at 0 range 2..5;
Y at 0 range 6..6;
Z at 0 range 7..39;
end record;
begin
Put(T'Size); New_Line;
Put(Aligned_T'Size); New_Line;
Put(Packed_T'Size); New_Line;
Put(Represented_T'Size); New_Line;
end Samples;
64
64
37
40
Cへの直接アクセス
with Interfaces.C;
procedure Sample is
procedure printf(format : not null access constant Interfaces.C.char);
procedure printf(format : not null access constant Interfaces.C.char; x : Interfaces.C.int);
procedure printf(format : not null access constant Interfaces.C.char; x : Interfaces.C.double);
pragma Import(C, printf, "printf");
use type Interfaces.C.char_array;
begin
declare
Format : aliased constant Interfaces.C.char_array := "Hello." & Interfaces.C.char'Val(10) & Interfaces.C.nul;
begin
printf(Format(Format'First)'Access);
end;
declare
Format : aliased constant Interfaces.C.char_array := "%d" & Interfaces.C.char'Val(10) & Interfaces.C.nul;
begin
printf(Format(Format'First)'Access, 123);
end;
declare
Format : aliased constant Interfaces.C.char_array := "%f" & Interfaces.C.char'Val(10) & Interfaces.C.nul;
begin
printf(Format(Format'First)'Access, 99.9);
end;
end Sample;
Hello.
123
99.900000
標準的なオブジェクトファイルの生成
with Interfaces.C;
function Add(X, Y : Interfaces.C.int) return Interfaces.C.int;
pragma Export(C, Add, "add"); -- 規約を指定すると名前の変形もやってくれる
function Add(X, Y : Interfaces.C.int) return Interfaces.C.int is
use type Interfaces.C.int;
begin
return X + Y;
end Add;
#include <stdio.h>
extern int add(int, int);
int main()
{
printf("%d", add(2, 3));
return 0;
}
5
マクロテキストプリプロセッサ
with Ada.Text_IO; use Ada.Text_IO;
procedure Sample is
$VAR : String := "Hello";
begin
Ada.Text_IO.Put($VAR);
end Sample;
> gnatprep -DVAR=Hello sample.adb con
with Ada.Text_IO; use Ada.Text_IO;
procedure Sample is
Hello : String := "Hello";
begin
Ada.Text_IO.Put(Hello);
end Sample;
条件コンパイル
with Ada.Text_IO; use Ada.Text_IO;
procedure Sample is
begin
#if WINDOWS'Defined then
Put("Windows");
#else
Put("POSIX");
#end if;
end Sample;
> gnatprep -DWINDOWS sample.adb con
with Ada.Text_IO; use Ada.Text_IO;
procedure Sample is
begin
Put("Windows");
end Sample;
Unicodeソースファイル
with Ada.Wide_Text_IO;
procedure Sample is
変数 : constant Wide_String := "こんにちは";
begin
Ada.Wide_Text_IO.Put(変数);
end Sample;
with Ada.Containers.Generic_Array_Sort;
with Ada.Strings.Equal_Case_Insensitive;
with Ada.Strings.Less_Case_Insensitive;
with Ada.Text_IO; use Ada.Text_IO;
procedure Test is
type String_Access is access constant String;
function "=" (X, Y : String) return Boolean renames Ada.Strings.Equal_Case_Insensitive;
function "<" (X, Y : String) return Boolean renames Ada.Strings.Less_Case_Insensitive;
function "<" (X, Y : String_Access) return Boolean is
begin
return X.all < Y.all;
end "<";
type String_Array is array(Positive range <>) of String_Access;
procedure Sort is new Ada.Containers.Generic_Array_Sort(Positive, String_Access, String_Array);
Table : String_Array := (
new String'("with"),
new String'("Ada"),
new String'("Containers"),
new String'("Generic_Array_Sort"),
new String'("Strings"),
new String'("Equal_Case_Insensitive"),
new String'("Less_Case_Insensitive"),
new String'("Text_IO"),
new String'("use"),
new String'("procedure"));
begin
if "Abc" = "aBC" then
Sort(Table);
for I in Table'Range loop
Put(Table(I).all); New_Line;
end loop;
end if;
end Test;
Ada
Containers
Equal_Case_Insensitive
Generic_Array_Sort
Less_Case_Insensitive
procedure
Strings
Text_IO
use
with
TLS
with Ada.Task_Attributes;
with Ada.Task_Identification;
with Ada.Text_IO; use Ada.Text_IO;
with Ada.Integer_Text_IO; use Ada.Integer_Text_IO;
procedure Test is
package A is new Ada.Task_Attributes(Integer, 0);
task type T is
entry Start;
end T;
task body T is
begin
accept Start;
loop
A.Reference.all := A.Reference.all + 1;
Put(Ada.Task_Identification.Image(T'Identity));
Put(A.Reference.all);
New_Line;
delay 1.0;
end loop;
end T;
X, Y : T;
begin
X.Start;
delay 0.5;
Y.Start;
loop
delay 5.0;
Put("TLS of X = ");
Put(A.Value(X'Identity));
New_Line;
end loop;
end Test;
with Ada.Interrupts.Names;
package Handlers is
protected Handlers is
procedure SIGINT;
pragma Attach_Handler(SIGINT, Ada.Interrupts.Names.SIGINT);
end Handlers;
end Handlers;
with Ada.Text_IO; use Ada.Text_IO;
with GNAT.OS_Lib;
package body Handlers is
protected body Handlers is
procedure SIGINT is
begin
Put_Line(Standard_Error, "SIGINT");
GNAT.OS_Lib.OS_Exit(1);
end SIGINT;
end Handlers;
end Handlers;
with Ada.Text_IO; use Ada.Text_IO;
with Handlers; pragma Unreferenced(Handlers);
procedure Test is
begin
loop
delay 1.0;
Put('*');
end loop;
end Test;