From 554fd8c5195424bdbcabf5de30fdc183aba391bd Mon Sep 17 00:00:00 2001 From: upstream source tree Date: Sun, 15 Mar 2015 20:14:05 -0400 Subject: obtained gcc-4.6.4.tar.bz2 from upstream website; verified gcc-4.6.4.tar.bz2.sig; imported gcc-4.6.4 source tree from verified upstream tarball. downloading a git-generated archive based on the 'upstream' tag should provide you with a source tree that is binary identical to the one extracted from the above tarball. if you have obtained the source via the command 'git clone', however, do note that line-endings of files in your working directory might differ from line-endings of the respective files in the upstream repository. --- gcc/testsuite/ada/acats/support/f392c00.a | 267 ++++++++++++++++++++++++++++++ 1 file changed, 267 insertions(+) create mode 100644 gcc/testsuite/ada/acats/support/f392c00.a (limited to 'gcc/testsuite/ada/acats/support/f392c00.a') diff --git a/gcc/testsuite/ada/acats/support/f392c00.a b/gcc/testsuite/ada/acats/support/f392c00.a new file mode 100644 index 000000000..8a470e7d4 --- /dev/null +++ b/gcc/testsuite/ada/acats/support/f392c00.a @@ -0,0 +1,267 @@ +-- 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; -- cgit v1.2.3