Imported Upstream version 9.5.0upstream/9.5.0upstream

5 files changed, 207 insertions, 13 deletions

diff --git a/ipl/cfuncs/Makefile b/ipl/cfuncs/Makefile
index d8b1ba2..802e85b 100644
--- a/ipl/cfuncs/Makefile
+++ b/ipl/cfuncs/Makefile
@@ -14,7 +14,7 @@ FUNCLIB = libcfunc.so
 .SUFFIXES: .c .o
 .c.o:			; $(CC) $(CFLAGS) $(CFDYN) -c $<
 
-FUNCS = bitcount.o files.o fpoll.o internal.o lgconv.o osf.o \
+FUNCS = bitcount.o external.o files.o fpoll.o internal.o lgconv.o osf.o \
 	pack.o ppm.o process.o tconnect.o
 CSRC = $(FUNCS:.o=.c)
 
@@ -25,7 +25,8 @@ default:	cfunc.u2 $(FUNCLIB)
 # library
 
 $(FUNCLIB):	$(FUNCS) mklib.sh
-		CC="$(CC)" CFLAGS="$(CFLAGS)" sh mklib.sh $(FUNCLIB) $(FUNCS)
+		CC="$(CC)" CFLAGS="$(CFLAGS)" BIN="../../bin" \
+		    sh mklib.sh $(FUNCLIB) $(FUNCS)
 $(FUNCS):	icall.h
 
 
diff --git a/ipl/cfuncs/external.c b/ipl/cfuncs/external.c
new file mode 100644
index 0000000..afb96fa
--- /dev/null
+++ b/ipl/cfuncs/external.c
@@ -0,0 +1,154 @@
+/*
+############################################################################
+#
+#	File:     external.c
+#
+#	Subject:  Functions to demonstrate Icon external values
+#
+#	Author:   Gregg M. Townsend
+#
+#	Date:     October 29, 2009
+#
+############################################################################
+#
+#   This file is in the public domain.
+#
+############################################################################
+#
+#  These functions demonstrate the use of external values.
+#
+#  extxmin()	creates a minimal external type
+#  extxstr(s)	creates an external hold a string and trivial checksum
+#  extxreal(r)	creates a fully customized external type holding a real value
+#
+############################################################################
+#
+#  Requires:  Dynamic loading
+#
+############################################################################
+*/
+
+#include <string.h>
+#include "icall.h"
+
+/*
+ * minimal external type with no parameters
+ */
+int extxmin(int argc, descriptor argv[])   /*: create minimal external value */
+   {
+   RetExternal(alcexternal(0, 0, 0));
+   }
+
+/*
+ * custom external holding a string and a trivial checksum
+ */
+
+/* custom external data block extends the standard block */
+typedef struct sblock {
+   externalblock eb;
+   unsigned short cksum;
+   char string[];
+   } sblock;
+
+/* type name returns "xstr" */
+static int sname(int argc, descriptor argv[]) {
+   RetConstStringN("xstr", 4);
+   }
+
+/* image returns "xstr_N(cksum:string)" with no special string escapes */
+static int simage(int argc, descriptor argv[]) {
+   sblock *b = (sblock*)ExternalBlock(argv[1]);
+   char buffer[1000];	/* not robust against huge strings */
+   RetStringN(buffer,
+      sprintf(buffer, "xstr_%ld(%05d:%s)", b->eb.id, b->cksum, b->string));
+   }
+
+/* list of custom functions for constructor */
+static funclist sfuncs = {
+   NULL,	/* cmp */
+   NULL,	/* copy */
+   sname,	/* name */
+   simage,	/* image */
+   };
+
+/* finally, the exported constructor function, extxstr(s) */
+int extxstr(int argc, descriptor argv[])   /*: create string-valued external */
+   {
+   sblock *new;
+   char *p;
+   int slen;
+
+   ArgString(1);
+   slen = StringLen(argv[1]);
+   new = (sblock *)alcexternal(sizeof(sblock) + slen + 1, &sfuncs, 0);
+   memcpy(new->string, StringAddr(argv[1]), slen);
+   new->string[slen] = '\0';
+   int cksum = 0;
+   for (p = new->string; *p; p++)
+       cksum = 37 * cksum + (unsigned char) *p;
+   new->cksum = cksum;
+   RetExternal((externalblock*)new);
+   }
+
+
+/*
+ * custom real-valued external with lots of trimmings
+ */
+
+/* custom external data block extends the standard block */
+typedef struct rblock {
+   externalblock eb;
+   float value;
+   } rblock;
+
+/* comparison function for sorting */
+static int rcmp(int argc, descriptor argv[]) {
+   rblock *eb1 = (rblock*)ExternalBlock(argv[1]);
+   rblock *eb2 = (rblock*)ExternalBlock(argv[2]);
+   if (eb1->value < eb2->value) RetInteger(-1);
+   if (eb1->value > eb2->value) RetInteger(+1);
+   if (eb1->eb.id < eb2->eb.id) RetInteger(-1);
+   if (eb1->eb.id > eb2->eb.id) RetInteger(+1);
+   RetInteger(0);
+   }
+
+/* copy function duplicates block, getting new serial number */
+static int rcopy(int argc, descriptor argv[]) {
+   externalblock *b = ExternalBlock(argv[1]);
+   rblock *old = (rblock*)b;
+   rblock *new = (rblock *)alcexternal(sizeof(rblock), b->funcs, 0);
+   new->value = old->value;
+   RetExternal((externalblock*)new);
+   }
+
+/* type name returns "xreal" */
+static int rname(int argc, descriptor argv[]) {
+   RetConstStringN("xreal", 5);
+   }
+
+/* image returns "xreal_N(V)" */
+static int rimage(int argc, descriptor argv[]) {
+   rblock *b = (rblock*)ExternalBlock(argv[1]);
+   char buffer[100];
+   RetStringN(buffer,
+      sprintf(buffer, "xreal_%ld(%.1f)", b->eb.id, b->value));
+   }
+
+/* list of custom functions for constructor */
+static funclist rfuncs = {
+   rcmp,	/* cmp */
+   rcopy,	/* copy */
+   rname,	/* name */
+   rimage,	/* image */
+   };
+
+/* finally, the exported constructor function, extxreal(r) */
+int extxreal(int argc, descriptor argv[])    /*: create real-valued external */
+   {
+   rblock *new;
+
+   ArgReal(1);
+   float v = RealVal(argv[1]);
+   new = (rblock *)alcexternal(sizeof(rblock), &rfuncs, &v);
+   RetExternal((externalblock*)new);
+   }
diff --git a/ipl/cfuncs/fpoll.c b/ipl/cfuncs/fpoll.c
index f209e0d..9230e18 100644
--- a/ipl/cfuncs/fpoll.c
+++ b/ipl/cfuncs/fpoll.c
@@ -7,7 +7,7 @@
 #
 #	Author:   Gregg M. Townsend
 #
-#	Date:     November 27, 2001
+#	Date:     October 27, 2009
 #
 ############################################################################
 #
@@ -29,6 +29,7 @@
 */
 
 #include <stdio.h>
+#include <string.h>	/* for memset call from FD_ZERO (solaris gcc) */
 #include <sys/types.h>
 #include <sys/time.h>
 
diff --git a/ipl/cfuncs/icall.h b/ipl/cfuncs/icall.h
index 2718dfa..14089a5 100644
--- a/ipl/cfuncs/icall.h
+++ b/ipl/cfuncs/icall.h
@@ -7,7 +7,7 @@
 #
 #	Author:   Gregg M. Townsend
 #
-#	Date:     November 17, 2004
+#	Date:     October 29, 2009
 #
 ############################################################################
 #
@@ -15,7 +15,7 @@
 #
 ############################################################################
 #
-#   Contributor: Kostas Oikonomou
+#   Contributors: Kostas Oikonomou, Carl Sturtivant
 #
 ############################################################################
 #
@@ -38,14 +38,14 @@
 #
 ############################################################################
 #
-#   IconType(d) returns one of the characters {cfinprsCILRST} indicating
-#   the type of a value according to the key on page 247 of the Red Book
-#   or page 273 of the Blue Book (The Icon Programming Language).
+#   IconType(d) returns one of the characters {cfinprsCEILRST} indicating
+#   the type of a value based on the key on page 273 of the Blue Book (The
+#   Icon Programming Language).  The character E indicates external data;
 #   The character I indicates a large (multiprecision) integer.
 #
-#   Only a few of these types (i, r, f, s) are easily manipulated in C.
+#   Only a few of these types (i, r, f, s, E) are easily manipulated in C.
 #   Given that the type has been verified, the following macros return
-#   the value of a descriptor in C terms:
+#   a value from a descriptor in C terms:
 #
 #	IntegerVal(d)	value of a integer (type 'i') as a C long
 #	RealVal(d)	value of a real (type 'r') as a C double
@@ -58,6 +58,7 @@
 #	StringLen(d)	length of string
 #
 #	ListLen(d)	length of list
+#	ExternalBlock(d) address of heap block for external data
 #
 #   These macros check the type of an argument, converting if necessary,
 #   and returning an error code if the argument is wrong:
@@ -66,6 +67,7 @@
 #	ArgReal(i)		check that argv[i] is a real number
 #	ArgString(i)		check that argv[i] is a string
 #	ArgList(i)		check that argv[i] is a list
+#	ArgExternal(i,f)	check that argv[i] is an external w/ funcblock f
 #
 #   Caveats:
 #      Allocation failure is not detected.
@@ -80,6 +82,7 @@
 #	RetInteger(i)		return integer value i
 #	RetReal(v)		return real value v
 #	RetFile(fp,status,name)	return (newly opened) file
+#	RetExternal(e)		return block at addr e made by alcexternal()
 #	RetString(s)		return null-terminated string s
 #	RetStringN(s, n)	return string s whose length is n
 #	RetAlcString(s, n)	return already-allocated string
@@ -121,11 +124,13 @@
 #define T_Integer	 1		/* integer */
 #define T_Real		 3		/* real number */
 #define T_File		 5		/* file, including window */
+#define T_External	19		/* externally defined data */
 
 #define D_Null		(T_Null     | D_Typecode)
 #define D_Integer	(T_Integer  | D_Typecode)
 #define D_Real		(T_Real     | D_Typecode | F_Ptr)
 #define D_File		(T_File     | D_Typecode | F_Ptr)
+#define D_External	(T_External | D_Typecode | F_Ptr)
 
 #define Fs_Read		0001		/* file open for reading */
 #define Fs_Write	0002		/* file open for writing */
@@ -139,10 +144,25 @@ typedef struct { word title; double rval; } realblock;
 typedef struct { word title; FILE *fp; word stat; descriptor fname; } fileblock;
 typedef struct { word title, size, id; void *head, *tail; } listblock;
 
+typedef struct externalblock {
+   word title, size, id;
+   struct funclist *funcs;
+   word data[];
+} externalblock;
+
+typedef struct funclist {
+   int (*extlcmp)  (int argc, descriptor argv[]);
+   int (*extlcopy) (int argc, descriptor argv[]);
+   int (*extlname) (int argc, descriptor argv[]);
+   int (*extlimage)(int argc, descriptor argv[]);
+} funclist;
+
 
 char *alcstr(char *s, word len);
 realblock *alcreal(double v);
 fileblock *alcfile(FILE *fp, int stat, descriptor *name);
+externalblock *alcexternal(long nbytes, funclist *f, void *data);
+
 int cnv_c_str(descriptor *s, descriptor *d);
 int cnv_int(descriptor *s, descriptor *d);
 int cnv_real(descriptor *s, descriptor *d);
@@ -152,7 +172,7 @@ double getdbl(descriptor *d);
 extern descriptor nulldesc;		/* null descriptor */
 
 
-#define IconType(d) ((d).dword>=0 ? 's' : "niIrcfpRL.S.T.....C"[(d).dword&31])
+#define IconType(d) ((d).dword>=0 ? 's' : "niIrcfpRL.S.T.....CE"[(d).dword&31])
 
 
 #define IntegerVal(d) ((d).vword)
@@ -170,6 +190,8 @@ extern descriptor nulldesc;		/* null descriptor */
 
 #define ListLen(d) (((listblock *)((d).vword))->size)
 
+#define ExternalBlock(d) ((externalblock *)(d).vword)
+
 
 #define ArgInteger(i) do { if (argc < (i)) Error(101); \
 if (!cnv_int(&argv[i],&argv[i])) ArgError(i,101); } while (0)
@@ -184,6 +206,12 @@ if (!cnv_str(&argv[i],&argv[i])) ArgError(i,103); } while (0)
 do {if (argc < (i)) Error(108); \
 if (IconType(argv[i]) != 'L') ArgError(i,108); } while(0)
 
+#define ArgExternal(i,f) \
+do {if (argc < (i)) Error(131); \
+if (IconType(argv[i]) != 'E') ArgError(i,131); \
+if (ExternalBlock(argv[i])->funclist != (f)) ArgError(i,132); \
+} while(0)
+
 
 #define RetArg(i) return (argv[0] = argv[i], 0)
 
@@ -198,6 +226,8 @@ do { descriptor dd; dd.vword = (word)alcstr(name, dd.dword = strlen(name)); \
    argv->dword = D_File; argv->vword = (word)alcfile(fp, stat, &dd); \
    return 0; } while (0)
 
+#define RetExternal(e) return (argv->dword=D_External, argv->vword=(word)(e), 0)
+
 #define RetString(s) \
 do { word n = strlen(s); \
 argv->dword = n; argv->vword = (word)alcstr(s,n); return 0; } while (0)
diff --git a/ipl/cfuncs/mklib.sh b/ipl/cfuncs/mklib.sh
index 533af0b..4caeca4 100755
--- a/ipl/cfuncs/mklib.sh
+++ b/ipl/cfuncs/mklib.sh
@@ -3,6 +3,7 @@
 #  mklib libname.so obj.o ...
 
 CC=${CC-cc}
+BIN=${BIN-../../bin}
 
 LIBNAME=${1?"usage: $0 libname obj..."}
 shift
@@ -11,9 +12,16 @@ SYS=`uname -s`
 set -x
 case "$SYS" in
    Linux*|*BSD*|GNU*)
-      gcc -shared -o $LIBNAME -fPIC "$@";;
+      $CC -shared -o $LIBNAME -fPIC "$@";;
+   CYGWIN*)
+      # move the win32 import library for iconx.exe callbacks
+      # created when iconx.exe was built
+      if [ -e $BIN/../src/runtime/iconx.a ]; then
+         mv $BIN/../src/runtime/iconx.a $BIN
+      fi
+      $CC -shared -Wl,--enable-auto-import -o $LIBNAME "$@" $BIN/iconx.a;;
    Darwin*)
-      cc -bundle -undefined suppress -flat_namespace -o $LIBNAME "$@";;
+      $CC -bundle -undefined suppress -flat_namespace -o $LIBNAME "$@";;
    SunOS*)
       $CC $CFLAGS -G -o $LIBNAME "$@" -lc -lsocket;;
    HP-UX*)