lang/pc/test/callc.p

   1 #
   2 program callc(input,output) ;
   3 var success: integer ;
   4 procedure rcsid ; begin writeln('$Id: callc.p,v 2.3 1994/06/24 12:36:41 ceriel Exp $') end ;
   5 function kwad(val:integer) : integer ; extern ;
   6 procedure cmain ; extern ;
   7 procedure incs ; begin success:=success+1 end ;
   8 procedure pptr( function ptwice(val:integer):integer ) ; extern ;
   9 #ifndef NOFLOAT
  10 function ceval( function pinside(val:integer):real ): boolean ; extern ;
  11 function outside(val:integer):real ;
  12 begin
  13         outside:= 1.411
  14 end ;
  15 procedure envellop ;
  16 var testval: integer ;
  17 function  inside(val:integer):real ;
  18 begin
  19         if testval<>1234 then writeln('The static link is incorrect')
  20                  else success:=success+1 ;
  21         inside:=sqrt(val)
  22 end ;
  23 begin
  24         testval:=1234 ;
  25         if ceval(inside) then success:=success+1
  26                  else writeln('Calling inside through C doesn''t work');
  27         if ceval(outside) then success:=success+1
  28                  else writeln('Calling outside through C doesn''t work')
  29 end;
  30 #endif
  31 procedure cptr( function pkwad(val:integer):integer ) ;
  32 begin
  33         if ( pkwad(-2)<>4 ) and (pkwad(-8)<>64) then
  34                 writeln('Using C function pointers in Pascal doesn''t work')
  35         else
  36                 success:=success+1
  37 end ;
  38 function twice(val:integer) : integer ;
  39 begin
  40         twice:= 2*val
  41 end ;
  42 begin
  43         success:=0 ;
  44         if (kwad(2)<>4) and (kwad(8)<>64) then
  45                 writeln('C cals don''t work')
  46         else
  47                 success:=success+1 ;
  48         cmain;
  49         pptr(twice) ;
  50 #ifndef NOFLOAT
  51         envellop ;
  52 #endif
  53         if success <>
  54 #ifdef NOFLOAT
  55         4
  56 #else
  57         7
  58 #endif
  59         then writeln('Only ',success,' tests passed')
  60                       else writeln('All tests passed')
  61 end.