ack/lang/pc/test/callc.p

#
program callc(input,output) ;
var success: integer ;
procedure rcsid ; begin writeln('$Header$') end ;
function kwad(val:integer) : integer ; extern ;
procedure cmain ; extern ;
procedure incs ; begin success:=success+1 end ;
procedure pptr( function ptwice(val:integer):integer ) ; extern ;
#ifndef NOFLOAT
function ceval( function pinside(val:integer):real ): boolean ; extern ;
function outside(val:integer):real ;
begin
	outside:= 1.411
end ;
procedure envellop ;
var testval: integer ;
function  inside(val:integer):real ;
begin
	if testval<>1234 then writeln('The static link is incorrect')
		 else success:=success+1 ;
	inside:=sqrt(val)
end ;
begin
	testval:=1234 ;
	if ceval(inside) then success:=success+1
		 else writeln('Calling inside through C doesn''t work');
	if ceval(outside) then success:=success+1
		 else writeln('Calling outside through C doesn''t work')
end;
#endif
procedure cptr( function pkwad(val:integer):integer ) ;
begin
	if ( pkwad(-2)<>4 ) and (pkwad(-8)<>64) then
		writeln('Using C function pointers in Pascal doesn''t work')
	else
		success:=success+1
end ;
function twice(val:integer) : integer ;
begin
	twice:= 2*val
end ;
begin
	success:=0 ;
	if (kwad(2)<>4) and (kwad(8)<>64) then
		writeln('C cals don''t work')
	else
		success:=success+1 ;
	cmain;
	pptr(twice) ;
#ifndef NOFLOAT
	envellop ;
#endif
	if success <>
#ifdef NOFLOAT
	4
#else
	7
#endif
	then writeln('Only ',success,' tests passed')
		      else writeln('All tests passed')
end.