Programmer's ROM - The Computer Language Library/programmersrom.iso/ada/print/pret.tst

Text File | 1988-05-03 | 12.6 KB | 505 lines

--::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::
--all.in
--::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::
-- tests pretty printer on a variety of constructs: context clause, package
-- specification, private part, package body, record types, rep specs,
-- package renames, generic instantiation, basic declarations, procedure body,
-- stub, function body, exception handler, case, loop, block, selective wait
with a; use a; with b; with c; with d;

package outermost is
type t;
private
type t is array (1 .. 2) of natural;
end;

package body outermost is

type psw is record sm:byte_mask; prot_key: integer range 0 .. 3;
machine_state: state_Mask; end record;

for psw use record at mod 8; sm at 0*word range 0 .. 7;
 prot_key at 0*word range 10 .. 11; machine_state at 0*word range 12 ..15;
 end record;

 type x is record first : component; second : component;
 end record;

 type y is array ( 1 ..   10)of integer;

 integer_object : integer;
 var1 : y;
 var2 : t;

package z renames d;
package apackage is new c(natural);

procedure first_procedure is
procedure b is separate;
function "=" return String is
begin
x;
y;
begin
z(q);
exception
when invalid_q => put("Invalid q");
when others => raise;
end;
return q;
end;



begin
case integer_object is
when 1 | 2 | 15 => null;
when 3 =>
b.put("integer_object is 3");
when others =>
loop integer_object := integer_object + 2;
if integer_object = 0 then
b.put("integer_object is 0");
elsif integer_object > 2 then
if var2(integer_object) = 10 then
b.switch(var2(integer_object));
end if;
b.put("integer_object is greater than 2");
else
b.switch(integer_Object);
end if;
exit when integer_object > 100; end loop;
end case;

select accept a; or accept b; or delay 1.5; or when c => accept d;
or when d => accept e;
    else i := 1; b := 2; end select;

end;
end;
--::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::
--andthen.in
--::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::
-- tests spacing of tokens for "and then" and "or else"
procedure x is
begin
if ((a and b) and then c) or else ((d or e) or else q) then
b; else x; end if; end;
--::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::
--binop.in
--::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::
-- test binary vs. unary operators.
procedure a is
begin
   a := + 1 -( - 3);
   b := 1-3;
   c := 1+3-(+2)+(-1);
end;
--::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::
--blanks.in
--::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::
-- Tests that blanks in the source are printed
procedure a is


b : integer;

begin
if a = b then


if a = b then
if a = b then

if a= b then
fool
;
end if; end if; end if; end if; end;
--::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::
--closeid.in
--::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::
-- Tests that closing identifiers are printed out

-- test normal nesting
package body a is package body b is end; end;

package body a is package body b is end b; end;

package body a is package b is end; end a;

package body x is procedure a is procedure b is begin null; end; begin null;
end; end;

procedure a is procedure b is begin null; end; begin null; end;

-- test nesting of blocks
package body x is begin a:begin b:begin null; end; end; end;

package body x is begin a:begin b:begin null; end b; end; end;

package body x is begin a:begin b:begin null; end; end a; end;

package body x is begin begin b:begin null; end; end; end;

package body x is begin a:begin begin null; end; end; end;

package body x is begin begin begin null; end; end; end;

package body x is begin begin b:begin null; end b; end a; end;

package body x is begin begin begin null; end a; end b; end;

package body x is begin a:begin begin null; end b; end a; end;

package body x is begin a: begin begin null; end b; end; end;

-- test nesting of loops
package body x is begin a:loop b:loop null; end loop; end loop; end;

package body x is begin a:loop b:loop null; end loop b; end loop; end;

package body x is begin a:loop b:loop null; end loop; end loop a; end;

package body x is begin loop b:loop null; end loop; end loop; end;

package body x is begin a:loop loop null; end loop; end loop; end;

package body x is begin loop loop null; end loop; end loop; end;

package body x is begin loop b:loop null; end loop b; end loop a; end;

package body x is begin loop loop null; end loop a; end loop b; end;

package body x is begin a:loop loop null; end loop b; end loop a; end;

package body x is begin a:loop loop null; end loop b; end loop; end;

-- test nesting of loops and blocks
package body x is begin a:begin b:loop null; end loop; end ; end;

package body x is begin a:loop b:loop begin null; end a; end loop b; end loop;
 end;

package body x is begin begin a:loop b:loop null; end loop; end loop a; end;
end;

-- test functions and procedures

function x return y is begin null; end;

procedure x is begin null; end;

function "=" return z is begin null; end;

procedure x is function "+" return y is begin null; end;begin null; end;

-- test separate units

procedure x is procedure y is separate; begin null; end;

function x return y is procedure y is separate; begin null;end;

function "-" return x is task body a is separate; begin null; end;

package body a is package body b is separate; begin null; end;

package body x is function y return z is separate; end;

package body x is procedure y is separate; end;

package body x is task body y is separate; end;

-- tasks

procedure x is task y is entry b; end; begin null; end;

package body a is task b; end;

package body x is task body y is begin null; end; begin null; end;

-- accepts

procedure s is begin select accept a; end select; end;

procedure s is begin select accept a do i := 1; end; end select; end;
--::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::
--colon.in
--::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::
-- tests lining up colons.  Tests that only sequences of object and number
-- declaration are lined up
procedure a is
x : integer; -- comment
xyz : constant := 2+3;

type y is array(1 .. 10)of integer;
a,b,c: integer;
xx, -- comment
d  -- comment
,
e : natural;
subtype two is natural range 2 .. 2;
f,g,h: integer;
yy, -- comment
atwentycharactername  -- comment
,
i : natural;

begin
j := k+1;
end;
procedure foo(i : integer; j : natural; k : positive);


procedure foo( -- comment
x : integer; -- comment
 y : natural; -- comment
 name : positive -- comment
);

procedure foo(
x : integer; -- comment
 y : natural; -- comment
 name : positive; -- comment
name2:natural
);
--::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::
--comment.in
--::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::
-- test comments with formatting on or off.
procedure a is -- test comments
i : integer;-- another test
      -- a comment
begin-- another comment
a := i;-- should put on next line (with preceding blank if formatting on)
j := 2;
end;
--::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::
--deepif.in
--::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::
-- tests nesting of very deep if statements (should stop indenting after a
-- certain point.
procedure longif is
begin
if a = b then
if a = b then
if a = b then
if a = b then
if a = b then
if a = b then
if a = b then
if a = b then
if a = b then
if a = b then
if a = b then
if a = b then
if a = b then
if a = b then
if a = b then
if a = b then
if a = b then
if a = b then
if a = b then
if a = b then
if a = b then
if a = b then
if a = b then
if a = b then
if a = b then
if a = b then
if a = b then
if a = b then
if a = b then
if a = b then
if a = b then
if a = b then
if a = b then
if a = b then
if a = b then
if a = b then
if a = b then
if a = b then
if a = b then
if a = b then
if a = b then
if a = b then
if a = b then
if a = b then
if a = b then
if a = b then
if a = b then
if a = b then
if a = b then
if a = b then
if a = b then
if a = b then
if a = b then
if a = b then
if a = b then
if a = b then
if a = b then
if a = b then
foo;
end if;
end if;
end if;
end if;
end if;
end if;
end if;
end if;
end if;
end if;
end if;
end if;
end if;
end if;
end if;
end if;
end if;
end if;
end if;
end if;
end if;
end if;
end if;
end if;
end if;
end if;
end if;
end if;
end if;
end if;
end if;
end if;
end if;
end if;
end if;
end if;
end if;
end if;
end if;
end if;
end if;
end if;
end if;
end if;
end if;
end if;
end if;
end if;
end if;
end if;
end if;
end if;
end if;
end if;
end if;
end if;
end if;
end if;
end;
--::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::
--delim.in
--::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::
-- tests basic delimiters
procedure foo (i: integer) is
begin
i := 4#3#;
case a is
when x | y | z =>
put (%hi|#%%%);
put (%a%%b%);
put ("a""b");
 put ("a%%b");
  put (%a"b%);
   put ("a%b");
   put (%%%%);
   put ("""");
   put ("%");
   put (%"%);
end case;
end;
--::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::
--depth.in
--::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::
-- contains several levels of nested units to test the DEPTH parameter
with a;
package a is
 i : integer; j : integer;
 package b is c : integer; d : integer;
 procedure a; function b return String;
 package c is a : integer; private b : integer; end; end;
 end;package body a is
function "<" return x is
procedure p is begin null; end;
begin null; end;
end;
--::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::
--error.in
--::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::
-- contains syntax error
procedure b is
begin
q := 3
end b;
--::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::
--generic.in
--::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::
-- tests indentation of generic specifications
generic
type elem is private;
procedure exchange(u,v: in out elem);

generic type item is private; with function "*"(u,v: item) return
item is <>; function squaring(x:item) return item;

generic type item is private; type vector is array(positive range <>) of
item; with function sum (w,y:x) return item; package on_vectors is
function sum(a,b:vector) return vector; function sigma(a:vector) return
item; length_error:exception; end;

generic package a is n:integer; end ;

--::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::
--multiple.in
--::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::
-- test multiple units in one file.
procedure a is begin null; end; procedure b is begin null; end;

--::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::
--task.in
--::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::
-- test task constructs
package body b is
begin
-- selective wait tests, alternative is accept statement
select accept a; end select;
select accept a; or accept b; end select;
select accept a; or accept b; or accept c; end select;
select accept a; or accept b; or accept c; else i := 1; b := 2;end select;
select accept a; or accept b; or when c => accept d; or when d => accept e;
    end select;
-- selective wait tests, alternative is delay statement
select delay 1.5; end select;
select delay 1.5; or delay 2.5; end select;
select delay 1.5 ; or delay 2.5; or delay 3.5; end select;
select delay 1.5; or delay 1.5; or delay 3.5; else i := 1; b := 2;end select;
select delay 1.5; or delay 2.5; or when c => delay 4.5; or when d => delay
60.0;    end select;
-- selective wait tests, alternative is terminate alternative
select terminate; end select;
select terminate; or delay 2.5; end select;
select terminate; or terminate; or terminate; end select;
select terminate; or terminate; or when c => terminate; or when d => terminate;
end select;
-- conditional entry call tests
select jk; else i := 1; j := 2; end select;
select jk; i := 1; j := 2; else k :=1; end select;
-- timed entry call tests
select jk; or delay 2.5; end select;
select jk; i := 1; j:=2; or delay 2.5;end select;
select jk; or delay 2.5; i := 1; end select;
select jk; i := 1; j := 2; or delay 2.5; i := 1; j := 2; end select;
end;