Imported Upstream version 9.5.0upstream/9.5.0upstream

1 files changed, 154 insertions, 0 deletions

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