From 727e3c59346da4f91284b34b4c18f2e0ba155e53 Mon Sep 17 00:00:00 2001 From: 3gg <3gg@shellblade.net> Date: Sat, 9 Aug 2025 16:03:28 +0200 Subject: Initial commit --- arrays/arrays.gpr | 5 ++ arrays/src/arrays.adb | 127 ++++++++++++++++++++++++++++++++++++++ basics/basics.gpr | 5 ++ basics/src/main.adb | 108 +++++++++++++++++++++++++++++++++ guess/guess.gpr | 5 ++ guess/src/guess.adb | 20 ++++++ hello/hello.gpr | 5 ++ hello/src/main.adb | 108 +++++++++++++++++++++++++++++++++ list/list.gpr | 5 ++ list/src/list.adb | 46 ++++++++++++++ more-types/src/types.adb | 116 +++++++++++++++++++++++++++++++++++ more-types/types.gpr | 5 ++ records/records.gpr | 5 ++ records/src/records.adb | 28 +++++++++ ring_buffer/ring_buffer.gpr | 5 ++ ring_buffer/src/ring_buffer.adb | 94 ++++++++++++++++++++++++++++ stack/src/main.adb | 20 ++++++ stack/src/stack.adb | 31 ++++++++++ stack/src/stack.ads | 26 ++++++++ stack/stack.gpr | 5 ++ tree/src/main.adb | 14 +++++ tree/src/tree.adb | 12 ++++ tree/src/tree.ads | 18 ++++++ tree/tree.gpr | 5 ++ typing/src/typing.adb | 131 ++++++++++++++++++++++++++++++++++++++++ typing/typing.gpr | 5 ++ 26 files changed, 954 insertions(+) create mode 100644 arrays/arrays.gpr create mode 100644 arrays/src/arrays.adb create mode 100644 basics/basics.gpr create mode 100644 basics/src/main.adb create mode 100644 guess/guess.gpr create mode 100644 guess/src/guess.adb create mode 100644 hello/hello.gpr create mode 100644 hello/src/main.adb create mode 100644 list/list.gpr create mode 100644 list/src/list.adb create mode 100644 more-types/src/types.adb create mode 100644 more-types/types.gpr create mode 100644 records/records.gpr create mode 100644 records/src/records.adb create mode 100644 ring_buffer/ring_buffer.gpr create mode 100644 ring_buffer/src/ring_buffer.adb create mode 100644 stack/src/main.adb create mode 100644 stack/src/stack.adb create mode 100644 stack/src/stack.ads create mode 100644 stack/stack.gpr create mode 100644 tree/src/main.adb create mode 100644 tree/src/tree.adb create mode 100644 tree/src/tree.ads create mode 100644 tree/tree.gpr create mode 100644 typing/src/typing.adb create mode 100644 typing/typing.gpr diff --git a/arrays/arrays.gpr b/arrays/arrays.gpr new file mode 100644 index 0000000..3d7ea37 --- /dev/null +++ b/arrays/arrays.gpr @@ -0,0 +1,5 @@ +project Arrays is + for Source_Dirs use ("src"); + for Object_Dir use "obj"; + for Main use ("arrays.adb"); +end Arrays; diff --git a/arrays/src/arrays.adb b/arrays/src/arrays.adb new file mode 100644 index 0000000..e851fc6 --- /dev/null +++ b/arrays/src/arrays.adb @@ -0,0 +1,127 @@ +with Ada.Text_IO; use Ada.Text_IO; +with Ada.Strings.Unbounded; use Ada.Strings.Unbounded; + +procedure Arrays is + ----------------------------------------------------------------------------- + -- Arrays 101. + -- + -- The index is strongly-typed and can be any discrete type. + -- + -- Iterations over the index type are preferred over iterations over specific + -- index values. + ----------------------------------------------------------------------------- + procedure Test_Array is + type My_Int is range 0 .. 1_000; + type Index is range 1 .. 5; + + type My_Int_Array is array (Index) of My_Int; + + function To_String (A : My_Int_Array) return String is + S : Unbounded_String; + begin + for I in Index loop + S := S & My_Int'Image (A (I)) & " "; + end loop; + return To_String (S); + end To_String; + + Arr : My_Int_Array := (2, 3, 5, 7, 11); + -- This array is not actually empty; its size is determined by the range of + -- its index type, which in this example is 1 .. 5. + Empty_Arr : My_Int_Array; + begin + Put_Line ("Arr = " & To_String (Arr)); + Put_Line ("Arr is " & Integer'Image (Arr'Size) & " bytes"); + + Put_Line ("Empty_Arr = " & To_String (Empty_Arr)); + Put_Line ("Empty_Arr is " & Integer'Image (Empty_Arr'Size) & " bytes"); + end Test_Array; + + ----------------------------------------------------------------------------- + -- Enums as array indices. + ----------------------------------------------------------------------------- + procedure Test_Enum_Array is + type Month is (Jan, Feb, Mar, Apr, May, Jun, Jul, Aug, Sep, Oct, Nov, Dec); + type Day is range 1 .. 31; + + Month_Days : array (Month) of Day := + (31, 28, 31, 30, 31, 30, 31, 31, 30, 31, 30, 31); + begin + for M in Month loop + Put_Line + (Month'Image (M) & " has " & Day'Image (Month_Days (M)) & " days"); + end loop; + end Test_Enum_Array; + + ----------------------------------------------------------------------------- + -- Arrays in ADA are bounds-checked. + ----------------------------------------------------------------------------- + procedure Test_Bounds is + Arr : array (Integer range 1 .. 5) of Integer := (3, 4, 7, 8, 9); + begin + Arr (1) := 17; + Arr (5) := 18; + --Arr (6) := 19; -- Error. + end Test_Bounds; + + ----------------------------------------------------------------------------- + -- Use the Range attribute to iterate over an array with an anonymous range. + ----------------------------------------------------------------------------- + procedure Test_Anonymous_Range is + Arr : array (3 .. 7) of Integer := (5, 8, 3, 5, 3); + begin + for I in Arr'Range loop + Put_Line + ("Index " & Integer'Image (I) & " has value " & + Integer'Image (Arr (I))); + end loop; + end Test_Anonymous_Range; + + ----------------------------------------------------------------------------- + -- Unconstrained arrays. + -- + -- The size/bounds are provided when creating an instance of the array type. + ----------------------------------------------------------------------------- + procedure Test_Unbounded_Array is + type Day is (Mon, Tue, Wed, Thu, Fri, Sat, Sun); + type Days_Arr is array (Integer range <>) of Day; + + Days_Off : Days_Arr := (Sat, Sun); + begin + Put ("Holidays: "); + for D in Days_Off'Range loop + Put (Day'Image (Days_Off (D)) & " "); + end loop; + New_Line; + end Test_Unbounded_Array; + + ----------------------------------------------------------------------------- + -- Bounds are automatically inferred from the initialization value. + ----------------------------------------------------------------------------- + procedure Test_Auto_Bounds is + Arr : array (Natural range <>) of Integer := (2, 3, 4); + begin + for I in Arr'First .. Arr'Last loop + Put_Line ("Arr(" & Integer'Image (I) & ") = " & Integer'Image (Arr (I))); + end loop; + end Test_Auto_Bounds; + + ----------------------------------------------------------------------------- + -- Array slices. + ----------------------------------------------------------------------------- + procedure Test_Slices is + Str : String := "Hello world"; + begin + Str (7 .. 11) := "there"; + Put_Line (Str); + end Test_Slices; + +begin + Test_Array; + Test_Enum_Array; + Test_Bounds; + Test_Anonymous_Range; + Test_Unbounded_Array; + Test_Auto_Bounds; + Test_Slices; +end Arrays; diff --git a/basics/basics.gpr b/basics/basics.gpr new file mode 100644 index 0000000..a217eed --- /dev/null +++ b/basics/basics.gpr @@ -0,0 +1,5 @@ +project Basics is + for Source_Dirs use ("src"); + for Object_Dir use "obj"; + for Main use ("main.adb"); +end Basics; diff --git a/basics/src/main.adb b/basics/src/main.adb new file mode 100644 index 0000000..63339ae --- /dev/null +++ b/basics/src/main.adb @@ -0,0 +1,108 @@ +with Ada.Text_IO; use Ada.Text_IO; +with Ada.Integer_Text_IO; use Ada.Integer_Text_IO; + +procedure Main is + procedure Read_Number is + N : Integer; + begin + Put_Line ("Please enter a number"); + Get (N); + if N > 0 then + Put_Line ("The number is positive"); + elsif N = 0 then + Put_Line ("The number is zero"); + else + Put_Line ("The number is negative"); + end if; + end Read_Number; + + procedure Test_Loop is + N : Integer := 0; + begin + loop + exit when N = 5; + N := N + 1; + Put_Line ("Test loop"); + end loop; + end Test_Loop; + + procedure Test_Even_Odd is + begin + for I in 0 .. 10 loop + Put_Line (I'Image & " is " & (if I mod 2 = 1 then "Odd" else "Even")); + end loop; + end Test_Even_Odd; + + procedure My_Swap (A : in out Integer; B : in out Integer) is + C : Integer; + begin + C := A; + A := B; + B := C; + end My_Swap; + + procedure Test_My_Swap is + A : Integer := 1; + B : Integer := 3; + begin + Put_Line ("Before swap: " & A'Image & B'Image); + My_Swap (A, B); + Put_Line ("After swap: " & A'Image & B'Image); + end Test_My_Swap; + + function Fib (N : Integer) return Integer is + F0 : Integer := 0; + F1 : Integer := 1; + F : Integer := 0; + begin + for I in 2 .. N loop + F := F0 + F1; + F0 := F1; + F1 := F; + end loop; + return F; + end Fib; + + function Factorial (N : Integer) return Integer is + F : Integer := 1; + begin + for I in 2 .. N loop + F := F * I; + end loop; + return F; + end Factorial; + + procedure Test_Functions is + N : Integer; + begin + Put_Line ("Enter a number:"); + Get (N); + Put_Line ("Fib(" & N'Image & ") = " & Fib (N)'Image); + Put_Line ("Factorial(" & N'Image & ") = " & Factorial (N)'Image); + end Test_Functions; + + procedure Test_Integers is + type Day is range 1 .. 7; + My_Day : Day := 3; + Other_Day : Day; + begin + for D in Day loop + Put_Line ("Day" & D'Image); + end loop; + Put_Line (My_Day'Image); + Other_Day := My_Day + Day (4); + Put_Line (Other_Day'Image); + end Test_Integers; + +begin + -- This is a comment. + Put_Line ("Hello world!"); + + Test_Loop; + Test_Even_Odd; + Test_My_Swap; + Test_Integers; + + --Read_Number; + Test_Functions; +end Main; diff --git a/guess/guess.gpr b/guess/guess.gpr new file mode 100644 index 0000000..ee53cfa --- /dev/null +++ b/guess/guess.gpr @@ -0,0 +1,5 @@ +project Guess is + for Source_Dirs use ("src"); + for Object_Dir use "obj"; + for Main use ("guess.adb"); +end Guess; diff --git a/guess/src/guess.adb b/guess/src/guess.adb new file mode 100644 index 0000000..dc394fa --- /dev/null +++ b/guess/src/guess.adb @@ -0,0 +1,20 @@ +with Ada.Text_IO; use Ada.Text_IO; +with Ada.Integer_Text_IO; use Ada.Integer_Text_IO; + +procedure Guess is + Answer : Integer := 47; + Guess : Integer; +begin + loop + Put ("Enter a number: "); + Get (Guess); + if Guess < Answer then + Put_Line ("Too low!"); + elsif Guess > Answer then + Put_Line ("Too high!"); + elsif Guess = Answer then + Put_Line ("Correct!"); + end if; + exit when Guess = Answer; + end loop; +end Guess; diff --git a/hello/hello.gpr b/hello/hello.gpr new file mode 100644 index 0000000..3f34ae9 --- /dev/null +++ b/hello/hello.gpr @@ -0,0 +1,5 @@ +project Hello is + for Source_Dirs use ("src"); + for Object_Dir use "obj"; + for Main use ("main.adb"); +end Hello; diff --git a/hello/src/main.adb b/hello/src/main.adb new file mode 100644 index 0000000..c9cb966 --- /dev/null +++ b/hello/src/main.adb @@ -0,0 +1,108 @@ +with Ada.Text_IO; use Ada.Text_IO; +with Ada.Integer_Text_IO; use Ada.Integer_Text_IO; + +procedure main is + + function Factorial (N : Integer) return Integer is + F : Integer := 1; + begin + for i in 2 .. N loop + F := F * i; + end loop; + return F; + end Factorial; + + function Fib (N : Integer) return Integer is + F : array (0 .. N) of Integer; + begin + F (0) := 0; + F (1) := 1; + for I in F'First + 2 .. F'Last loop + F (I) := F (I - 2) + F (I - 1); + end loop; + return F (N); + end Fib; + + function Fib_Rec (N : Integer) return Integer is + begin + if N = 0 then + return 0; + elsif N = 1 then + return 1; + else + return Fib_Rec (N - 1) + Fib_Rec (N - 2); + end if; + end Fib_Rec; + + procedure Greet_5 is + counter : Integer := 1; + begin + Put_Line ("Greet_5"); + loop + Put_Line ("Counter: " & Integer'Image (counter)); + exit when counter = 5; + counter := counter + 1; + end loop; + end Greet_5; + + procedure Greet_With_While is + counter : Integer := 1; + begin + Put_Line ("Greet_With_While"); + while counter <= 5 loop + Put_Line ("Counter: " & Integer'Image (counter)); + counter := counter + 1; + end loop; + end Greet_With_While; + + procedure Swap (A, B : in out Integer) is + Tmp : Integer; + begin + Tmp := A; + A := B; + B := Tmp; + end Swap; + + procedure Guessing_Game is + Answer : Integer := 47; + Guess : Integer; + begin + loop + Put ("Enter a number: "); + Get (Guess); + if Guess < Answer then + Put_Line ("Too low!"); + elsif Guess > Answer then + Put_Line ("Too high!"); + else + Put_Line ("Correct!"); + exit; + end if; + end loop; + end Guessing_Game; + + N : Integer; + X : Integer := 2; + Y : Integer := 3; + +begin + Put ("Enter an integer value: "); + Get (N); + if N >= 0 then + Put_Line ("Fib(" & Integer'Image (N) & ") = " & Integer'Image (Fib (N))); + Put_Line + ("Factorial(" & Integer'Image (N) & ") = " & + Integer'Image (Factorial (N))); + else + Put_Line ("Please enter a non-negative integer"); + end if; + + Greet_5; + Greet_With_While; + + Put_Line ("Swapping " & Integer'Image (X) & " and " & Integer'Image (Y)); + Swap (X, Y); + Put_Line ("X = " & Integer'Image (X) & ", Y = " & Integer'Image (Y)); + + Guessing_Game; +end main; diff --git a/list/list.gpr b/list/list.gpr new file mode 100644 index 0000000..5095383 --- /dev/null +++ b/list/list.gpr @@ -0,0 +1,5 @@ +project List is + for Source_Dirs use ("src"); + for Object_Dir use "obj"; + for Main use ("list.adb"); +end List; diff --git a/list/src/list.adb b/list/src/list.adb new file mode 100644 index 0000000..c8910d6 --- /dev/null +++ b/list/src/list.adb @@ -0,0 +1,46 @@ +with Ada.Text_IO; use Ada.Text_IO; + +procedure List is + + type MyList; + + type MyList_Access is access MyList; + + type MyList is record + Value : Integer := 0; + Next : MyList_Access := null; + end record; + + function Length (XS : access constant MyList) return Integer is + L : Integer := 0; + Node : access constant MyList := XS; + begin + while Node /= null loop + L := L + 1; + Node := Node.Next; + end loop; + return L; + end Length; + + procedure Print_List (XS : access constant MyList) is + begin + if XS /= null then + Put (Integer'Image (XS.Value) & " "); + Print_List (XS.Next); + end if; + end Print_List; + + function Build_List return MyList_Access is + XS : MyList_Access := new MyList'(1, new MyList'(2, new MyList'(3, null))); + begin + return XS; + end Build_List; + + XS : MyList_Access := Build_List; + +begin + Put ("List: "); + Print_List (XS); + New_Line; + Put_Line ("The list has length " & Integer'Image (Length (XS))); +end List; diff --git a/more-types/src/types.adb b/more-types/src/types.adb new file mode 100644 index 0000000..4e7590f --- /dev/null +++ b/more-types/src/types.adb @@ -0,0 +1,116 @@ +with Ada.Text_IO; use Ada.Text_IO; + +procedure Types is + + ----------------------------------------------------------------------------- + -- Record initialization. + ----------------------------------------------------------------------------- + procedure Test_Point is + type Point is record + X : Integer := 0; + Y : Integer := 0; + end record; + + Origin_1 : Point; -- Default initialization. + Origin_2 : Point := (0, 0); -- Explicit, unnamed. + Origin_3 : Point := (X => 0, Y => 0); -- Explicit, named. + Origin_4 : Point := (X => <>, Y => <>); -- Explicit, using defaults. + Origin_5 : Point := (X | Y => 0); -- Initialize both values. + Origin_6 : Point := Point'(0,0); -- Qualified expression. + begin + Put_Line ("Origin: " & Integer'Image (Origin_5.X) & ", " + & Integer'Image (Origin_5.Y)); + end Test_Point; + + ----------------------------------------------------------------------------- + -- Pointers. + ----------------------------------------------------------------------------- + procedure Test_Pointer is + type Month_Type is (Jan, Feb, Mar, Apr, May, Jun, + Jul, Aug, Sep, Oct, Nov, Dec); + + type Date is record + Day : Integer range 1 .. 31; + Month : Month_Type; + Year : Integer; + end record; + + -- Access types are nominally typed, not structurally typed. + -- If we "own" a type X, we typically also declare an access type named + -- X_Acc, so that there is a canonical name for the access type to X. + type Date_Acc is access Date; -- Pointer to Date type. + type Different_Date_Acc is access Date; -- Different type. + + Null_Date : Date_Acc := null; + + -- Allocate values of the access type using the 'new' keyword. + D : Date_Acc := new Date; + + -- Constraints can be given when instantiating the type. + Buffer : access String := new String(1 .. 5); + + -- We can also initialize along with the allocation. + Hello_Str : access String := new String'("Hello"); + + procedure Test_Null (D : Date_Acc; Name : String) is + begin + -- Dereferencing of D happens implicitly. Here we can treat D as an + -- actual Date. + if D = null then + Put_Line (Name & " is null"); + else + Put_Line (Name & " is not null"); + end if; + end Test_Null; + + begin + Test_Null (Null_Date, "Null_Date"); + Test_Null (D, "D"); + end Test_Pointer; + + ----------------------------------------------------------------------------- + -- Mutually recursive types. + -- + -- Similar to C++, we can forward-declare a type to break the loop. + ----------------------------------------------------------------------------- + + procedure Test_MyList is + type MyList; + type MyList_Acc is access MyList; + + type MyList is record + Value : Integer := 0; + Next : MyList_Acc := null; + end record; + + function Cons (X : Integer; L : MyList_Acc) return MyList_Acc is + Head : MyList_Acc := new MyList; + begin + Head.Value := X; + Head.Next := L; + return Head; + end Cons; + + procedure Print_List (L : access constant MyList) is + Node : access constant MyList := L; + begin + Put ("["); + while Node /= null loop + Put (Integer'Image (Node.Value) & " "); + Node := Node.next; + end loop; + Put_Line ("]"); + end Print_List; + + InitialList : MyList_Acc := new MyList'(4, null); + ModifiedList : MyList_Acc; + begin + ModifiedList := Cons (1, Cons (2, Cons (3, InitialList))); + Print_List (ModifiedList); + end Test_MyList; + +begin + Test_Point; + Test_Pointer; + Test_MyList; +end Types; diff --git a/more-types/types.gpr b/more-types/types.gpr new file mode 100644 index 0000000..740bcfd --- /dev/null +++ b/more-types/types.gpr @@ -0,0 +1,5 @@ +project Types is + for Source_Dirs use ("src"); + for Object_Dir use "obj"; + for Main use ("types.adb"); +end Types; diff --git a/records/records.gpr b/records/records.gpr new file mode 100644 index 0000000..aad6944 --- /dev/null +++ b/records/records.gpr @@ -0,0 +1,5 @@ +project Records is + for Source_Dirs use ("src"); + for Object_Dir use "obj"; + for Main use ("records.adb"); +end Records; diff --git a/records/src/records.adb b/records/src/records.adb new file mode 100644 index 0000000..f3c60ae --- /dev/null +++ b/records/src/records.adb @@ -0,0 +1,28 @@ +with Ada.Text_IO; use Ada.Text_IO; + +procedure Records is + + type Month_Type is (January, February, March, April, May, June, July, August, + September, October, November, December); + + type Date is record + Day : Integer range 1 .. 31 := 1; + Month : Month_Type := January; + Year : Integer := 1970; + end record; + + function To_String (D : Date) return String is + begin + return Month_Type'Image (D.Month) & " " & Integer'Image (D.Day) & ", " & + Integer'Image(D.Year); + end To_String; + + Epoch : Date; + Ada_Birthday : Date := (10, December, 1815); + Leap_Day_2020 : Date := (29, February, 2020); + +begin + Put_Line ("Epoch is " & To_String (Epoch)); + Put_Line ("Ada's birthday is " & To_String (Ada_Birthday)); + Put_Line ("Leap day 2020: " & To_String (Leap_Day_2020)); +end Records; diff --git a/ring_buffer/ring_buffer.gpr b/ring_buffer/ring_buffer.gpr new file mode 100644 index 0000000..bac706f --- /dev/null +++ b/ring_buffer/ring_buffer.gpr @@ -0,0 +1,5 @@ +project Ring_Buffer is + for Source_Dirs use ("src"); + for Object_Dir use "obj"; + for Main use ("ring_buffer.adb"); +end Ring_Buffer; diff --git a/ring_buffer/src/ring_buffer.adb b/ring_buffer/src/ring_buffer.adb new file mode 100644 index 0000000..500ec5c --- /dev/null +++ b/ring_buffer/src/ring_buffer.adb @@ -0,0 +1,94 @@ +with Ada.Text_IO; use Ada.Text_IO; + +procedure Ring_Buffer is + + type Natural_Array is array (Natural range <>) of Integer; + + type Ring_Buffer (Capacity : Natural) is record + Start_Index : Natural := 0; -- TODO: somehow make these 'mod Size'. + Cur_Index : Natural := 0; + Empty : Boolean := True; + -- TODO: the index type should be 'mod Size'. + -- TODO: 0 .. Capacity wastes 1 slot of space. + Buffer : Natural_Array (0 .. Capacity) := (others => 0); + end record; + + function Size (RB : Ring_Buffer) return Natural is + begin + if RB.Empty then + return 0; + elsif RB.Cur_Index = RB.Start_Index then + return RB.Capacity; + else + return (RB.Cur_Index - RB.Start_Index) mod RB.Capacity; + end if; + end Size; + + function Push (RB : in out Ring_Buffer; Value : Integer) return Boolean is + begin + if Size (RB) = RB.Capacity then + return False; + else + RB.Buffer (RB.Cur_Index) := Value; + RB.Cur_Index := (RB.Cur_Index + 1) mod RB.Capacity; + RB.Empty := False; + return True; + end if; + end Push; + + procedure Push (RB : in out Ring_Buffer; Value : Integer) is + unused : Boolean := Push (RB, Value); + begin + return; + end Push; + + function Pop (RB : in out Ring_Buffer; Value : out Integer) return Boolean is + begin + if Size (RB) = 0 then + return False; + else + Value := RB.Buffer (RB.Start_Index); + RB.Start_Index := (RB.Start_Index + 1) mod RB.Capacity; + if RB.Start_Index = RB.Cur_Index then + RB.Empty := True; + end if; + return True; + end if; + end Pop; + + procedure Pop (RB : in out Ring_Buffer) is + Dummy : Integer; + unused : Boolean := Pop (RB, Dummy); + begin + return; + end Pop; + + procedure Print (RB : Ring_Buffer) is + begin + Put ("["); + for I in 0 .. Size (RB) - 1 loop + Put (Integer'Image (RB.Buffer ((RB.Start_Index + I) mod RB.Capacity))); + end loop; + Put_Line ("]"); + end Print; + + Capacity : constant Natural := 5; + RB : Ring_Buffer (Capacity); + +begin + Push (RB, 1); + Push (RB, 2); + Push (RB, 3); + Push (RB, 4); + Push (RB, 5); + -- Full! + Push (RB, 6); + Push (RB, 7); + -- Make some space. + Pop (RB); + Pop (RB); + -- Push more. + Push (RB, 8); + Push (RB, 9); + Print (RB); +end Ring_Buffer; diff --git a/stack/src/main.adb b/stack/src/main.adb new file mode 100644 index 0000000..977a46b --- /dev/null +++ b/stack/src/main.adb @@ -0,0 +1,20 @@ +with Ada.Assertions; use Ada.Assertions; +with Ada.Integer_Text_IO; use Ada.Integer_Text_IO; +with Ada.Text_IO; use Ada.Text_IO; + +with Stack; + +procedure Main is + package IntStack is new Stack (Integer); + S : IntStack.Stack; + Val : Integer; +begin + Put_Line ("Hello world!"); + for I in 1 .. 5 loop + IntStack.Push (S, I); + end loop; + while not IntStack.Empty (S) loop + Assert (IntStack.Pop (S, Val)); + Put_Line (Val'Image); + end loop; +end Main; diff --git a/stack/src/stack.adb b/stack/src/stack.adb new file mode 100644 index 0000000..4dc8fb1 --- /dev/null +++ b/stack/src/stack.adb @@ -0,0 +1,31 @@ +with Ada.Unchecked_Deallocation; + +package body Stack is + procedure Free is new Ada.Unchecked_Deallocation (Node, Node_Access); + + procedure Push (S : in out Stack; Val : T) is + New_Top : Node_Access := new Node; + begin + New_Top.Val := Val; + New_Top.Bottom := S.Top; + S.Top := New_Top; + end Push; + + function Pop (S : in out Stack; Val : out T) return Boolean is + Old_Top : Node_Access := S.Top; + begin + if Old_Top /= null then + Val := Old_Top.Val; + S.Top := Old_Top.Bottom; + Free (Old_Top); + return True; + else + return False; + end if; + end Pop; + + function Empty (S : Stack) return Boolean is + begin + return S.Top = null; + end Empty; +end Stack; diff --git a/stack/src/stack.ads b/stack/src/stack.ads new file mode 100644 index 0000000..4f390e3 --- /dev/null +++ b/stack/src/stack.ads @@ -0,0 +1,26 @@ +generic + type T is private; +package Stack is + type Stack is private; + + -- Push a value into the stack. + procedure Push (S : in out Stack; Val : T); + + -- Pop a value from the stack. + function Pop (S : in out Stack; Val : out T) return Boolean; + + -- Return true if the stack is empty, false otherwise. + function Empty (S : Stack) return Boolean; +private + type Node; + type Node_Access is access Node; + + type Node is record + Val : T; + Bottom : Node_Access; + end record; + + type Stack is record + Top : Node_Access; + end record; +end Stack; diff --git a/stack/stack.gpr b/stack/stack.gpr new file mode 100644 index 0000000..70e045c --- /dev/null +++ b/stack/stack.gpr @@ -0,0 +1,5 @@ +project Stack is + for Source_Dirs use ("src"); + for Object_Dir use "obj"; + for Main use ("main.adb"); +end Stack; \ No newline at end of file diff --git a/tree/src/main.adb b/tree/src/main.adb new file mode 100644 index 0000000..b9ece1a --- /dev/null +++ b/tree/src/main.adb @@ -0,0 +1,14 @@ +with Ada.Text_IO; use Ada.Text_IO; + +with Tree; + +procedure Main is + package IntTree is new Tree (Integer); + T : IntTree.Tree_Access := new IntTree.Tree; +begin + T.Left := new IntTree.Tree; + T.Right := new IntTree.Tree; + T.Right.Left := new IntTree.Tree; + + Put_Line ("Tree height:" & IntTree.Height (T)'Image); +end Main; diff --git a/tree/src/tree.adb b/tree/src/tree.adb new file mode 100644 index 0000000..7e4a897 --- /dev/null +++ b/tree/src/tree.adb @@ -0,0 +1,12 @@ +package body tree is + + function Height (T : Tree_Access) return Integer is + begin + if T = null then + return 0; + else + return 1 + Integer'Max (Height (T.Left), Height (T.Right)); + end if; + end Height; + +end tree; diff --git a/tree/src/tree.ads b/tree/src/tree.ads new file mode 100644 index 0000000..1cf26fc --- /dev/null +++ b/tree/src/tree.ads @@ -0,0 +1,18 @@ +generic + type T is private; + +package tree is + + type Tree; + type Tree_Access is access Tree; + + type Tree is record + Val : T; + Left : Tree_Access; + Right : Tree_Access; + end record; + + -- Returns the height of the tree. + function Height (T : Tree_Access) return Integer; + +end tree; diff --git a/tree/tree.gpr b/tree/tree.gpr new file mode 100644 index 0000000..bef680a --- /dev/null +++ b/tree/tree.gpr @@ -0,0 +1,5 @@ +project Tree is + for Source_Dirs use ("src"); + for Object_Dir use "obj"; + for Main use ("main.adb"); +end Tree; diff --git a/typing/src/typing.adb b/typing/src/typing.adb new file mode 100644 index 0000000..876c5db --- /dev/null +++ b/typing/src/typing.adb @@ -0,0 +1,131 @@ +with Ada.Text_IO; use Ada.Text_IO; + +procedure Typing is + -- Notes: + -- Every "built-in" type in Ada is defined with facilities generally available + -- to the user. + + ------------------------------------------------------------------------------ + -- Ranged integers. + ------------------------------------------------------------------------------ + type My_Int is range -1 .. 20; + + function Overflow (X : My_Int) return My_Int is + begin + return X + 1; + end Overflow; + + procedure Test_My_Int is + -- N overflows. + --N : My_Int := Overflow (My_Int'Last); + + -- C is equal to (12 + 15) / 2 = 13. + -- The reason C does not overflow is that type-level overflows are performed + -- at specific boundaries for efficiency reasons, in this case when the + -- result of the computation is assigned to the variable C. The value 13 is + -- within the range of My_Int, so we do not get an overflow exception in this + -- case. + A : My_Int := 12; + B : My_Int := 15; + C : My_Int := (A + B) / 2; + begin + for I in My_int loop + Put_Line (My_Int'Image (I)); + end loop; + + --Put_Line ("My_Int N = " & My_Int'Image (N)); + Put_Line ("My_Int C = " & My_Int'Image (C)); + end Test_My_Int; + + ------------------------------------------------------------------------------ + -- Unsigned integers / modular types. + ------------------------------------------------------------------------------ + type Mod_Int is mod 5; + + procedure Test_Mod_Int is + A : Mod_Int := 2; + B : Mod_Int := 4; + C : Mod_Int := A + B; -- C = 1. No overflow, implicit mod operation. + begin + Put_Line ("Mod_Int C = " & Mod_Int'Image (C)); + end Test_Mod_Int; + + ------------------------------------------------------------------------------ + -- Enumerations. + ------------------------------------------------------------------------------ + type Days is (Monday, Tuesday, Wednesday, Thursday, Friday, Saturday, Sunday); + + procedure Test_Days is + begin + for D in Days loop + Put (Days'Image (D)); + case D is + when Monday .. Friday => Put_Line (" -> weekday"); + when Saturday .. Sunday => Put_Line (" -> weekend"); + end case; + end loop; + end Test_Days; + + ------------------------------------------------------------------------------ + -- Floats with ranges. + ------------------------------------------------------------------------------ + type T_Norm is new Float range -1.0 .. +1.0; + + procedure Test_T_Norm is + A : T_Norm := 0.5; + begin + Put_Line ("A = " & T_Norm'Image (A)); + end Test_T_Norm; + + ------------------------------------------------------------------------------ + -- Casting. + ------------------------------------------------------------------------------ + type Meters is new Float; + type Miles is new Float; + + procedure Test_Units is + Dist_Imperial : Miles; + Dist_Metric : constant Meters := 100.0; + begin + Dist_Imperial := Miles (Dist_Metric) / 1609.0; + Put_Line (Meters'Image (Dist_Metric) & " meters is " & Miles'Image (Dist_Imperial) & " miles"); + end Test_Units; + + ------------------------------------------------------------------------------ + -- Derived types. + -- + -- Derived types introduce a new type and usually constrain the parent type. + ------------------------------------------------------------------------------ + type SSN is new Integer range 0 .. 999_99_9999; + + procedure Test_SSN is + X : SSN := 111_22_3333; + begin + Put_Line("SSN X = " & SSN'Image (X)); + end Test_SSN; + + ------------------------------------------------------------------------------ + -- Subtypes types. + -- + -- Subtypes express constraints without introducing a new type. + -- Constraints are enforced at runtime. + ------------------------------------------------------------------------------ + subtype Weekend_Days is Days range Saturday .. Sunday; + + procedure Test_Subtypes is + A : Weekend_Days := Saturday; + B : Days := A; -- OK. + begin + Put_Line ("Day B is " & Days'Image (B)); + --A := Monday; -- Runtime exception. + end Test_Subtypes; + +begin + Test_My_Int; + Test_Mod_Int; + Test_Days; + Test_T_Norm; + Test_Units; + Test_SSN; + Test_Subtypes; +end Typing; diff --git a/typing/typing.gpr b/typing/typing.gpr new file mode 100644 index 0000000..fdc5051 --- /dev/null +++ b/typing/typing.gpr @@ -0,0 +1,5 @@ +project Typing is + for Source_Dirs use ("src"); + for Object_Dir use "obj"; + for Main use ("typing.adb"); +end Typing; -- cgit v1.2.3