diff options
Diffstat (limited to 'gcc/testsuite/ada/acats/support/f392c00.a')
-rw-r--r-- | gcc/testsuite/ada/acats/support/f392c00.a | 267 |
1 files changed, 0 insertions, 267 deletions
diff --git a/gcc/testsuite/ada/acats/support/f392c00.a b/gcc/testsuite/ada/acats/support/f392c00.a deleted file mode 100644 index 8a470e7d4de..00000000000 --- a/gcc/testsuite/ada/acats/support/f392c00.a +++ /dev/null @@ -1,267 +0,0 @@ --- F392C00.A --- --- Grant of Unlimited Rights --- --- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, --- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained --- unlimited rights in the software and documentation contained herein. --- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making --- this public release, the Government intends to confer upon all --- recipients unlimited rights equal to those held by the Government. --- These rights include rights to use, duplicate, release or disclose the --- released technical data and computer software in whole or in part, in --- any manner and for any purpose whatsoever, and to have or permit others --- to do so. --- --- DISCLAIMER --- --- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR --- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED --- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE --- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE --- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A --- PARTICULAR PURPOSE OF SAID MATERIAL. ---* --- --- FOUNDATION DESCRIPTION: --- This foundation provides a basis for tagged type and dispatching --- tests. Each test describes the utilizations. --- --- CHANGE HISTORY: --- 06 Dec 94 SAIC ACVC 2.0 --- 24 OCT 95 SAIC Updated for ACVC 2.0.1 --- ---! - -package F392C00_1 is -- Switches - - type Toggle is tagged private; ---------------------------------- Toggle - - function Create return Toggle; - procedure Flip ( It : in out Toggle ); - function On ( It : Toggle'Class ) return Boolean; - function Off ( It : Toggle'Class ) return Boolean; - - type Dimmer is new Toggle with private; ------------------------- Dimmer - - type Luminance is range 0..100; - - function Create return Dimmer; - procedure Flip ( It : in out Dimmer ); - procedure Brighten( It : in out Dimmer; - By : in Luminance := 10 ); - procedure Dim ( It : in out Dimmer; - By : in Luminance := 10 ); - function Intensity( It : Dimmer ) return Luminance; - - type Auto_Dimmer is new Dimmer with private; --------------- Auto_Dimmer - - function Create return Auto_Dimmer; - procedure Flip ( It: in out Auto_Dimmer ); - procedure Set_Auto ( It: in out Auto_Dimmer ); - procedure Clear_Auto( It: in out Auto_Dimmer ); - -- procedure Set_Manual( It: in out Auto_Dimmer ) renames Clear_Auto; - procedure Set_Cutin ( It: in out Auto_Dimmer; Lumens: in Luminance ); - procedure Set_Cutout( It: in out Auto_Dimmer; Lumens: in Luminance ); - - function Auto ( It: Auto_Dimmer ) return Boolean; - function Cutout_Threshold( It: Auto_Dimmer ) return Luminance; - function Cutin_Threshold ( It: Auto_Dimmer ) return Luminance; - - function TC_CW_TI( Key : Character ) return Toggle'Class; - - function TC_Non_Disp( It: Toggle ) return Boolean; - function TC_Non_Disp( It: Dimmer ) return Boolean; - function TC_Non_Disp( It: Auto_Dimmer ) return Boolean; - -private - - type Toggle is tagged record - On : Boolean := False; - end record; - - type Dimmer is new Toggle with record - Intensity : Luminance := 100; - end record; - - type Auto_Dimmer is new Dimmer with record - Cutout_Threshold : Luminance := 60; - Cutin_Threshold : Luminance := 40; - Auto_Engaged : Boolean := False; - end record; - -end F392C00_1; - -with TCTouch; -package body F392C00_1 is - - function Create return Toggle is - begin - TCTouch.Touch( '1' ); ------------------------------------------------ 1 - return Toggle'( On => True ); - end Create; - - function Create return Dimmer is - begin - TCTouch.Touch( '2' ); ------------------------------------------------ 2 - return Dimmer'( On => True, Intensity => 75 ); - end Create; - - function Create return Auto_Dimmer is - begin - TCTouch.Touch( '3' ); ------------------------------------------------ 3 - return Auto_Dimmer'( On => True, Intensity => 25, - Cutout_Threshold | Cutin_Threshold => 50, - Auto_Engaged => True ); - end Create; - - procedure Flip ( It : in out Toggle ) is - begin - TCTouch.Touch( 'A' ); ------------------------------------------------ A - It.On := not It.On; - end Flip; - - function On( It : Toggle'Class ) return Boolean is - begin - TCTouch.Touch( 'B' ); ------------------------------------------------ B - return It.On; - end On; - - function Off( It : Toggle'Class ) return Boolean is - begin - TCTouch.Touch( 'C' ); ------------------------------------------------ C - return not It.On; - end Off; - - procedure Brighten( It : in out Dimmer; - By : in Luminance := 10 ) is - begin - TCTouch.Touch( 'D' ); ------------------------------------------------ D - if (It.Intensity+By) <= Luminance'Last then - It.Intensity := It.Intensity+By; - else - It.Intensity := Luminance'Last; - end if; - end Brighten; - - procedure Dim ( It : in out Dimmer; - By : in Luminance := 10 ) is - begin - TCTouch.Touch( 'E' ); ------------------------------------------------ E - if (It.Intensity-By) >= Luminance'First then - It.Intensity := It.Intensity-By; - else - It.Intensity := Luminance'First; - end if; - end Dim; - - function Intensity( It : Dimmer ) return Luminance is - begin - TCTouch.Touch( 'F' ); ------------------------------------------------ F - if On(It) then - return It.Intensity; - else - return Luminance'First; - end if; - end Intensity; - - procedure Flip ( It : in out Dimmer ) is - begin - TCTouch.Touch( 'G' ); ------------------------------------------------ G - if On( It ) and (It.Intensity < 50) then - It.Intensity := Luminance'Last - It.Intensity; - else - Flip( Toggle( It ) ); - end if; - end Flip; - - procedure Set_Auto ( It: in out Auto_Dimmer ) is - begin - TCTouch.Touch( 'H' ); ------------------------------------------------ H - It.Auto_Engaged := True; - end Set_Auto; - - procedure Clear_Auto( It: in out Auto_Dimmer ) is - begin - TCTouch.Touch( 'I' ); ------------------------------------------------ I - It.Auto_Engaged := False; - end Clear_Auto; - - function Auto ( It: Auto_Dimmer ) return Boolean is - begin - TCTouch.Touch( 'J' ); ------------------------------------------------ J - return It.Auto_Engaged; - end Auto; - - procedure Flip ( It: in out Auto_Dimmer ) is - begin - TCTouch.Touch( 'K' ); ------------------------------------------------ K - if It.Auto_Engaged then - if Off(It) then - Flip( Dimmer( It ) ); - else - It.Auto_Engaged := False; - end if; - else - Flip( Dimmer( It ) ); - end if; - end Flip; - - procedure Set_Cutin ( It : in out Auto_Dimmer; - Lumens : in Luminance) is - begin - TCTouch.Touch( 'L' ); ------------------------------------------------ L - It.Cutin_Threshold := Lumens; - end Set_Cutin; - - procedure Set_Cutout( It : in out Auto_Dimmer; - Lumens : in Luminance) is - begin - TCTouch.Touch( 'M' ); ------------------------------------------------ M - It.Cutout_Threshold := Lumens; - end Set_Cutout; - - function Cutout_Threshold( It : Auto_Dimmer ) return Luminance is - begin - TCTouch.Touch( 'N' ); ------------------------------------------------ N - return It.Cutout_Threshold; - end Cutout_Threshold; - - function Cutin_Threshold ( It : Auto_Dimmer ) return Luminance is - begin - TCTouch.Touch( 'O' ); ------------------------------------------------ O - return It.Cutin_Threshold; - end Cutin_Threshold; - - function TC_CW_TI( Key : Character ) return Toggle'Class is - begin - TCTouch.Touch( 'W' ); ------------------------------------------------ W - case Key is - when 'T' | 't' => return Toggle'( On => True ); - when 'D' | 'd' => return Dimmer'( On => True, Intensity => 75 ); - when 'A' | 'a' => return Auto_Dimmer'( On => True, Intensity => 25, - Cutout_Threshold | Cutin_Threshold => 50, - Auto_Engaged => True ); - when others => null; - end case; - end TC_CW_TI; - - function TC_Non_Disp( It: Toggle ) return Boolean is - begin - TCTouch.Touch( 'X' ); ------------------------------------------------ X - return It.On; - end TC_Non_Disp; - - function TC_Non_Disp( It: Dimmer ) return Boolean is - begin - TCTouch.Touch( 'Y' ); ------------------------------------------------ Y - return It.On; - end TC_Non_Disp; - - function TC_Non_Disp( It: Auto_Dimmer ) return Boolean is - begin - TCTouch.Touch( 'Z' ); ------------------------------------------------ Z - return It.On; - end TC_Non_Disp; - -end F392C00_1; |