From f9b105e07a4ec4160363c3f317c612c3bc4820fb Mon Sep 17 00:00:00 2001
From: keie <none@none>
Date: Thu, 17 Jan 1985 12:43:04 +0000
Subject: [PATCH] *** empty log message ***

---
 lang/pc/test/callc.p | 50 ++++++++++++++++++++++++++++++++++++++
 lang/pc/test/cmod.c  | 58 ++++++++++++++++++++++++++++++++++++++++++++
 2 files changed, 108 insertions(+)
 create mode 100644 lang/pc/test/callc.p
 create mode 100644 lang/pc/test/cmod.c

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 <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 ;
+}
-- 
2.34.1