*** empty log message ***

diff --git a/lang/pc/test/callc.p b/lang/pc/test/callc.p
new file mode 100644 (file)
index 0000000..003b008
--- /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 (file)
index 0000000..060634a
--- /dev/null
+++ b/lang/pc/test/cmod.c
@@ -0,0 +1,58 @@
+#include <stdio.h>
+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 ;
+}