コードの欠片

自動的なメモリ解放

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;
Array1'Length    =           3
Array1'Length(1) =           3
Array1'Length(2) =           2
Array2'Length    =           3
Array2(0)'Length =           2

無制約配列

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;
raised PROGRAM_ERROR : sample.adb:8 accessibility check failed

ドット記法

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;
raised PROGRAM_ERROR : EXCEPTION_ACCESS_VIOLATION (撃沈)

VMTを持たないオブジェクト

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;
	.file	"a_native.adb"
	.text
	.p2align 4,,15
.globl __ada_a_native
	.def	__ada_a_native;	.scl	2;	.type	32;	.endef
__ada_a_native:
	pushl	%ebp
	movl	%esp, %ebp
	movl	12(%ebp), %ecx
	pushl	%edi
	movl	8(%ebp), %edx
	pushl	%esi
	xorl	%esi, %esi
	pushl	%ebx
	movl	(%ecx), %ebx
	movl	4(%ecx), %eax
	cmpl	%eax, %ebx
	jg	L4
	movzbl	(%edx), %edi
	cmpl	%eax, %ebx
	movl	%edi, %esi
	je	L4
	subl	%ebx, %eax
	xorl	%ecx, %ecx
	movl	%eax, %ebx
	.p2align 4,,15
L7:
	movzbl	1(%edx), %eax
	incl	%ecx
	incl	%edx
	addl	%eax, %esi
	cmpl	%ebx, %ecx
	jne	L7
L4:
	popl	%ebx
	movl	%esi, %eax
	popl	%esi
	popl	%edi
	popl	%ebp
	ret

総称パッケージ

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;
         10
 1.20000000000000000E+01
         24
 4.07859620525396152E+00

ダウンキャスト

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;
 1 2 3 4 5 6 7 8 9
 9 8 7 6 5 4 3 2 1
 1 2 4 8 16 32 64
**********
*********
********
*******
******

RAII

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;
>gnatmake -g sample.adb -bargs -E
gcc -c -g sample.adb
gnatbind -aO./ -E -I- -x sample.ali
gnatlink sample.ali -g

>sample
before
16#77E4_1418#
16#0040_1286#
16#0040_1234#
16#0040_1467#
16#0040_1AA5#
16#0040_1B6C#
16#0040_5541#
16#0040_4882#
16#0040_4827#
Exception name: SAMPLE.MY_EXCEPTION_1
Call stack traceback locations:
0x404827 0x404882 0x405541 0x401b6c 0x401aa5 0x401467 0x401234 0x401286 0x77e414
18


Execution terminated by unhandled exception
Exception name: SAMPLE.MY_EXCEPTION_1
Call stack traceback locations:
0x404827 0x404882 0x405541 0x401b6c 0x401aa5 0x401467 0x401234 0x401286 0x77e414
18

>addr2line -e sample.exe 0x405541
e:/build/gcc/ada/rts/a-except.adb:844

>addr2line -e sample.exe 0x401b6c
D:/Programming/tests/AdaException/sample.adb:11

タスクと保護オブジェクト

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;
Moge =  0 0
Xyzzy =  1 1
Hage =  2 5
THoge'Last = MOGE
THoge'First = HAGE
Hoge = XYZZY
Succ(Hoge) = HAGE

拡張精度浮動小数点数

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;
> gnatmake -gnat05 -gnatW8 sample.adb
gcc -c -gnat05 -gnatW8 sample.adb
gnatbind -x sample.ali
gnatlink sample.ali

> sample
縺薙s縺ォ縺。縺ッ (UTF-8で出力されている)

ディレクトリの探索

-- 現在のgccのAdaライブラリの実装ではマルチバイト文字を含むファイル名で
-- More_EntriesがName_Errorを起こします
with Ada.Text_IO;
with Ada.Directories;
procedure Sample is
	Search : Ada.Directories.Search_Type;
begin
	Ada.Directories.Start_Search(
		Search => Search,
		Directory => Ada.Directories.Current_Directory,
		Pattern => "*",
		Filter => Ada.Directories.Filter_Type'(
			Ada.Directories.Directory |
			Ada.Directories.Ordinary_File |
			Ada.Directories.Special_File => True));
	while Ada.Directories.More_Entries(Search => Search) loop
		declare
			Directory_Entry : Ada.Directories.Directory_Entry_Type;
		begin
			Ada.Directories.Get_Next_Entry(
				Search => Search,
				Directory_Entry => Directory_Entry);
			declare
				Name : String renames Ada.Directories.Simple_Name(
					Directory_Entry => Directory_Entry);
			begin
				Ada.Text_IO.Put_Line(Name);
			end;
		end;
	end loop;
	Ada.Directories.End_Search(Search => Search);
end Sample;
.
..
a_varargs.ali
a_array.adb
a_bitset.adb
a_case_by_string.adb
a_delegate.adb
a_downward_closure.adb
a_gc.adb
a_map.adb
(以下略)

大文字小文字を区別しない文字列比較

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;
x_00276B60          1
y_00279A50          1
x_00276B60          2
y_00279A50          2
x_00276B60          3
y_00279A50          3
x_00276B60          4
y_00279A50          4
x_00276B60          5
y_00279A50          5
x_00276B60          6
TLS of X =           6
y_00279A50          6
x_00276B60          7
y_00279A50          7

割り込みハンドラ

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;
***SIGINT (Ctrl+Cを押した)