1 files changed, 136 insertions, 0 deletions
diff --git a/src/runtime/rexternal.r b/src/runtime/rexternal.r
new file mode 100644
index 0000000..c3a33c6
--- /dev/null
+++ b/src/runtime/rexternal.r
@@ -0,0 +1,136 @@
+/*
+ * File: rexternal.r
+ *  Functions dealing with external values and their custom functions.
+ *
+ *  Functions in this file that declare (argc, argv) signatures
+ *  follow the ipl/cfuncs/icall.h calling conventions and call
+ *  dynamically loaded C functions if available for this external type.
+ */
+
+/*
+ * callextfunc(func, d1, d2) -- call func(argc, argv) via icall.h conventions.
+ * 
+ * func() is called with argv=1 if d2 is null or argv=2 if not.
+ */
+struct descrip callextfunc(int (*func)(int, dptr), dptr dp1, dptr dp2) {
+   struct descrip stack[3];
+   int nargs = 1;
+
+   stack[0] = nulldesc;
+   stack[1] = *dp1;
+   if (dp2 != NULL) {
+      stack[2] = *dp2;
+      nargs = 2;
+      }
+   if (func(nargs, stack) != 0)
+      syserr("external value helper function did not succeed");
+   return stack[0];
+   }
+
+/*
+ * extlname(argc, argv) - return the name of the type of external value argv[1].
+ */
+int extlname(int argc, dptr argv)
+   {
+   struct b_external *block = (struct b_external *)BlkLoc(argv[1]);
+   struct b_extlfuns *funcs = block->funcs;
+
+   if (funcs->extlname != NULL) {
+      funcs->extlname(1, argv);		/* call custom name function */
+      if (! is:string(argv[0]))
+         syserr("extlname: not a string");
+      }
+   else {
+      argv[0].dword = 8;		/* strlen("external") */
+      argv[0].vword.sptr = "external";
+      }
+   return 0;
+   }
+
+/*
+ * extlimage(argc, argv) - return the image of external value argv[1].
+ *
+ * Always sets argv[0] to a valid string, but returns Error
+ * if storage is not available for formatting the details.
+ */
+int extlimage(int argc, dptr argv)
+   {
+   struct b_external *block = (struct b_external *)BlkLoc(argv[1]);
+   struct b_extlfuns *funcs = block->funcs;
+   word len;
+   int nwords;
+
+   if (funcs->extlimage != NULL) {
+      funcs->extlimage(1, argv);	/* call custom image function */
+      if (! is:string(argv[0]))
+         syserr("extlimage: not a string");
+      return 0;
+      }
+
+   extlname(1, &argv[0]);		/* get type name, result in argv[0] */
+   len = StrLen(argv[0]);
+   Protect(reserve(Strings, len + 30), return Error);
+   Protect(StrLoc(argv[0]) = alcstr(StrLoc(argv[0]), len), return Error);
+   /*
+    * to type name append "_<id>(nwords)"
+    */
+   nwords = ((char*)block + block->blksize - (char*)block->data) / sizeof(word);
+   len += sprintf(StrLoc(argv[0]) + len, "_%ld(%d)", (long)block->id, nwords);
+   StrLen(argv[0]) = len;
+   return 0;
+   }
+
+/*
+ * extlcmp(argc, argv) - compare two external values argv[1] and argv[2].
+ */
+
+int extlcmp(int argc, dptr argv) {
+   struct b_external *block1 = (struct b_external *)BlkLoc(argv[1]);
+   struct b_external *block2 = (struct b_external *)BlkLoc(argv[2]);
+   struct b_extlfuns *funcs = block1->funcs;
+
+   /*
+    * If the two values share the same function list, then by definition
+    * they are the same type and are compared using a custom function if
+    * one is provided in the list.
+    */
+   if (block1->funcs == block2->funcs && funcs->extlcmp != NULL) {
+      funcs->extlcmp(1, argv);		/* call custom comparison function */
+      if (! is:integer(argv[0]))
+         syserr("extlcmp: not an integer");
+      }
+   else {
+      /*
+       * Otherwise, sort by name and then by serial number.
+       */
+      struct descrip name1 = callextfunc(&extlname, &argv[1], NULL);
+      struct descrip name2 = callextfunc(&extlname, &argv[2], NULL);
+      long result = lexcmp(&name1, &name2);
+      if (result == Equal)
+         result = block1->id - block2->id;
+      argv[0].dword = D_Integer;
+      argv[0].vword.integr = result;
+      }
+   return 0;
+   }
+
+/*
+ * extlcopy(argc, argv) - return a copy of external value argv[1].
+ *
+ * By default this is the original descriptor.
+ */
+
+int extlcopy(int argc, dptr argv) {
+   struct b_external *block = (struct b_external *)BlkLoc(argv[1]);
+   struct b_extlfuns *funcs = block->funcs;
+
+   if (funcs->extlcopy != NULL) {
+      funcs->extlcopy(1, argv);		/* call custom copy function */
+      if (Qual(argv[0]) || Type(argv[0]) != T_External)
+         syserr("extlcopy: not an external");
+      }
+   else {
+      argv[0] = argv[1];		/* the identical external value */
+      }
+   return 0;
+   }