diff --git a/lang/pc/test/callc.p b/lang/pc/test/callc.p new file mode 100644 index 000000000..003b008da --- /dev/null +++ b/lang/pc/test/callc.p @@ -0,0 +1,50 @@ +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 ; +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; +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) ; + envellop ; + if success <>7 then writeln('Only ',success,' tests passed') + else writeln('All tests passed') +end. diff --git a/lang/pc/test/cmod.c b/lang/pc/test/cmod.c new file mode 100644 index 000000000..060634a79 --- /dev/null +++ b/lang/pc/test/cmod.c @@ -0,0 +1,58 @@ +#include +char rcs_id[] = "$Header$" ; + +typedef struct { + int (*p_func)() ; + char *p_slink ; +} p_fiptr ; + +typedef struct { + double (*p_func)() ; + char *p_slink ; +} p_ffptr ; + +int kwad(val) int val ; { return val*val ; } +cmain() { + p_fiptr p_kwad ; + + /* Test calling pascal procedures */ + if ( twice(7)!=14 || twice(-9)!=-18 ) { + printf("Calling pascal from C doesn't work\n") ; + fflush(stdout) ; + } + else + incs() ; + /* Test passing C function pointers */ + p_kwad.p_slink= (char *)0 ; p_kwad.p_func= kwad ; + cptr(p_kwad) ; +} +pptr(p_twice) p_fiptr p_twice ; { + if ( p_twice.p_slink!=(char *)0 ) { + printf("Pascal outer procedure static link unequal to zero\n") ; + fflush(stdout) ; + } + + if ( p_twice.p_func(-7)!=-14 || p_twice.p_func(9)!=18 ) { + printf("Passing pascal functions to C doesn't work\n") ; + fflush(stdout) ; + } + else incs() ; +} + +double callpas(pasfunc,par) p_ffptr pasfunc ; int par ; { + /* Call a Pascal function, both inner block and outer block */ + /* Function must return a double, (In pascal terms: real) */ + /* and have one integer parameter */ + /* The static link - if present - must be the first parameter */ + if ( pasfunc.p_slink ) { + return (*pasfunc.p_func)(pasfunc.p_slink,par) ; + } else { + return (*pasfunc.p_func)(par) ; + } +} + +int ceval(p_inside) p_ffptr p_inside ; { + double resval ; + resval= callpas(p_inside,2) ; + return resval>1.41 && resval<1.42 ; +}