clipsruby 0.0.2

data/ext/clipsruby/miscfun.c

@@ -0,0 +1,1801 @@
+   /*******************************************************/
+   /*      "C" Language Integrated Production System      */
+   /*                                                     */
+   /*            CLIPS Version 6.41  12/04/22             */
+   /*                                                     */
+   /*            MISCELLANEOUS FUNCTIONS MODULE           */
+   /*******************************************************/
+
+/*************************************************************/
+/* Purpose:                                                  */
+/*                                                           */
+/* Principal Programmer(s):                                  */
+/*      Gary D. Riley                                        */
+/*                                                           */
+/* Contributing Programmer(s):                               */
+/*      Brian L. Dantes                                      */
+/*                                                           */
+/* Revision History:                                         */
+/*                                                           */
+/*      6.23: Correction for FalseSymbol/TrueSymbol. DR0859  */
+/*                                                           */
+/*            Corrected compilation errors for files         */
+/*            generated by constructs-to-c. DR0861           */
+/*                                                           */
+/*            Changed name of variable exp to theExp         */
+/*            because of Unix compiler warnings of shadowed  */
+/*            definitions.                                   */
+/*                                                           */
+/*      6.24: Removed CONFLICT_RESOLUTION_STRATEGIES,        */
+/*            DYNAMIC_SALIENCE, INCREMENTAL_RESET,           */
+/*            LOGICAL_DEPENDENCIES, IMPERATIVE_METHODS       */
+/*            INSTANCE_PATTERN_MATCHING,                     */
+/*            IMPERATIVE_MESSAGE_HANDLERS, and               */
+/*            AUXILIARY_MESSAGE_HANDLERS compilation flags.  */
+/*                                                           */
+/*            Renamed BOOLEAN macro type to intBool.         */
+/*                                                           */
+/*      6.30: Support for long long integers.                */
+/*                                                           */
+/*            Used gensprintf instead of sprintf.            */
+/*                                                           */
+/*            Removed conditional code for unsupported       */
+/*            compilers/operating systems.                   */
+/*                                                           */
+/*            Renamed EX_MATH compiler flag to               */
+/*            EXTENDED_MATH_FUNCTIONS.                       */
+/*                                                           */
+/*            Combined BASIC_IO and EXT_IO compilation       */
+/*            flags into the IO_FUNCTIONS compilation flag.  */
+/*                                                           */
+/*            Removed code associated with HELP_FUNCTIONS    */
+/*            and EMACS_EDITOR compiler flags.               */
+/*                                                           */
+/*            Added operating-system function.               */
+/*                                                           */
+/*            Added new function (for future use).           */
+/*                                                           */
+/*            Added const qualifiers to remove C++           */
+/*            deprecation warnings.                          */
+/*                                                           */
+/*            Removed deallocating message parameter from    */
+/*            EnvReleaseMem.                                 */
+/*                                                           */
+/*            Removed support for BLOCK_MEMORY.              */
+/*                                                           */
+/*      6.31: Added local-time and gm-time functions.        */
+/*                                                           */
+/*      6.40: Changed restrictions from char * to            */
+/*            CLIPSLexeme * to support strings               */
+/*            originating from sources that are not          */
+/*            statically allocated.                          */
+/*                                                           */
+/*            Added Env prefix to GetEvaluationError and     */
+/*            SetEvaluationError functions.                  */
+/*                                                           */
+/*            Added Env prefix to GetHaltExecution and       */
+/*            SetHaltExecution functions.                    */
+/*                                                           */
+/*            Refactored code to reduce header dependencies  */
+/*            in sysdep.c.                                   */
+/*                                                           */
+/*            Pragma once and other inclusion changes.       */
+/*                                                           */
+/*            Added support for booleans with <stdbool.h>.   */
+/*                                                           */
+/*            Removed use of void pointers for specific      */
+/*            data structures.                               */
+/*                                                           */
+/*            Removed VAX_VMS support.                       */
+/*                                                           */
+/*            Removed mv-append and length functions.        */
+/*                                                           */
+/*            UDF redesign.                                  */
+/*                                                           */
+/*            The system function now returns the completion */
+/*            status of the command. If no arguments are     */
+/*            passed, the return value indicates whether a   */
+/*            command processor is available.                */
+/*                                                           */
+/*            Added get-error, set-error, and clear-error    */
+/*            functions.                                     */
+/*                                                           */
+/*            Added void function.                           */
+/*                                                           */
+/*            Function operating system returns MAC-OS       */
+/*            instead of MAC-OS-X.                           */
+/*                                                           */
+/*            Removed WINDOW_INTERFACE flag.                 */
+/*                                                           */
+/*      6.41: Added SYSTEM_FUNCTION compiler flag.           */
+/*                                                           */
+/*            Used gensnprintf in place of gensprintf and.   */
+/*            sprintf.                                       */
+/*                                                           */
+/*************************************************************/
+
+#include <stdio.h>
+#include <string.h>
+#include <time.h>
+
+#include "setup.h"
+
+#include "argacces.h"
+#include "envrnmnt.h"
+#include "exprnpsr.h"
+#include "memalloc.h"
+#include "multifld.h"
+#include "prntutil.h"
+#include "router.h"
+#include "sysdep.h"
+#include "utility.h"
+
+#if DEFFUNCTION_CONSTRUCT
+#include "dffnxfun.h"
+#endif
+
+#if DEFTEMPLATE_CONSTRUCT
+#include "factfun.h"
+#include "tmpltutl.h"
+#endif
+
+#include "miscfun.h"
+
+#define MISCFUN_DATA 9
+
+struct miscFunctionData
+  {
+   long long GensymNumber;
+   CLIPSValue errorCode;
+  };
+
+#define MiscFunctionData(theEnv) ((struct miscFunctionData *) GetEnvironmentData(theEnv,MISCFUN_DATA))
+
+/***************************************/
+/* LOCAL INTERNAL FUNCTION DEFINITIONS */
+/***************************************/
+
+   static void                    ExpandFuncMultifield(Environment *,UDFValue *,Expression *,
+                                                       Expression **,void *);
+   static int                     FindLanguageType(Environment *,const char *);
+   static void                    ConvertTime(Environment *,UDFValue *,struct tm *);
+
+/*****************************************************************/
+/* MiscFunctionDefinitions: Initializes miscellaneous functions. */
+/*****************************************************************/
+void MiscFunctionDefinitions(
+  Environment *theEnv)
+  {
+   AllocateEnvironmentData(theEnv,MISCFUN_DATA,sizeof(struct miscFunctionData),NULL);
+   MiscFunctionData(theEnv)->GensymNumber = 1;
+   MiscFunctionData(theEnv)->errorCode.lexemeValue = FalseSymbol(theEnv);
+   Retain(theEnv,MiscFunctionData(theEnv)->errorCode.header);
+
+#if ! RUN_TIME
+   AddUDF(theEnv,"exit","v",0,1,"l",ExitCommand,"ExitCommand",NULL);
+
+   AddUDF(theEnv,"gensym","y",0,0,NULL,GensymFunction,"GensymFunction",NULL);
+   AddUDF(theEnv,"gensym*","y",0,0,NULL,GensymStarFunction,"GensymStarFunction",NULL);
+   AddUDF(theEnv,"setgen","l",1,1,"l",SetgenFunction,"SetgenFunction",NULL);
+
+#if SYSTEM_FUNCTION
+   AddUDF(theEnv,"system","ly",0,UNBOUNDED,"sy",SystemCommand,"SystemCommand",NULL);
+#endif
+   AddUDF(theEnv,"length$","l",1,1,"m",LengthFunction,"LengthFunction",NULL);
+   AddUDF(theEnv,"time","d",0,0,NULL,TimeFunction,"TimeFunction",NULL);
+   AddUDF(theEnv,"local-time","m",0,0,NULL,LocalTimeFunction,"LocalTimeFunction",NULL);
+   AddUDF(theEnv,"gm-time","m",0,0,NULL,GMTimeFunction,"GMTimeFunction",NULL);
+
+   AddUDF(theEnv,"random","l",0,2,"l",RandomFunction,"RandomFunction",NULL);
+   AddUDF(theEnv,"seed","v",1,1,"l",SeedFunction,"SeedFunction",NULL);
+   AddUDF(theEnv,"conserve-mem","v",1,1,"y",ConserveMemCommand,"ConserveMemCommand",NULL);
+   AddUDF(theEnv,"release-mem","l",0,0,NULL,ReleaseMemCommand,"ReleaseMemCommand",NULL);
+#if DEBUGGING_FUNCTIONS
+   AddUDF(theEnv,"mem-used","l",0,0,NULL,MemUsedCommand,"MemUsedCommand",NULL);
+   AddUDF(theEnv,"mem-requests","l",0,0,NULL,MemRequestsCommand,"MemRequestsCommand",NULL);
+#endif
+
+   AddUDF(theEnv,"options","v",0,0,NULL,OptionsCommand,"OptionsCommand",NULL);
+
+   AddUDF(theEnv,"operating-system","y",0,0,NULL,OperatingSystemFunction,"OperatingSystemFunction",NULL);
+   AddUDF(theEnv,"(expansion-call)","*",0,UNBOUNDED,NULL,ExpandFuncCall,"ExpandFuncCall",NULL);
+   AddUDF(theEnv,"expand$","*",1,1,"m",DummyExpandFuncMultifield,"DummyExpandFuncMultifield",NULL);
+   FuncSeqOvlFlags(theEnv,"expand$",false,false);
+   AddUDF(theEnv,"(set-evaluation-error)","y",0,0,NULL,CauseEvaluationError,"CauseEvaluationError",NULL);
+   AddUDF(theEnv,"set-sequence-operator-recognition","b",1,1,"y",SetSORCommand,"SetSORCommand",NULL);
+   AddUDF(theEnv,"get-sequence-operator-recognition","b",0,0,NULL,GetSORCommand,"GetSORCommand",NULL);
+   AddUDF(theEnv,"get-function-restrictions","s",1,1,"y",GetFunctionRestrictions,"GetFunctionRestrictions",NULL);
+   AddUDF(theEnv,"create$","m",0,UNBOUNDED,NULL,CreateFunction,"CreateFunction",NULL);
+   AddUDF(theEnv,"apropos","v",1,1,"y",AproposCommand,"AproposCommand",NULL);
+   AddUDF(theEnv,"get-function-list","m",0,0,NULL,GetFunctionListFunction,"GetFunctionListFunction",NULL);
+   AddUDF(theEnv,"funcall","*",1,UNBOUNDED,"*;sy",FuncallFunction,"FuncallFunction",NULL);
+   AddUDF(theEnv,"new","*",1,UNBOUNDED,"*;y",NewFunction,"NewFunction",NULL);
+   AddUDF(theEnv,"call","*",1,UNBOUNDED,"*",CallFunction,"CallFunction",NULL);
+   AddUDF(theEnv,"timer","d",0,UNBOUNDED,NULL,TimerFunction,"TimerFunction",NULL);
+
+   AddUDF(theEnv,"get-error","*",0,0,NULL,GetErrorFunction,"GetErrorFunction",NULL);
+   AddUDF(theEnv,"clear-error","*",0,0,NULL,ClearErrorFunction,"ClearErrorFunction",NULL);
+   AddUDF(theEnv,"set-error","v",1,1,NULL,SetErrorFunction,"SetErrorFunction",NULL);
+
+   AddUDF(theEnv,"void","v",0,0,NULL,VoidFunction,"VoidFunction",NULL);
+#endif
+  }
+
+/*****************************************************/
+/* ExitCommand: H/L command for exiting the program. */
+/*****************************************************/
+void ExitCommand(
+  Environment *theEnv,
+  UDFContext *context,
+  UDFValue *returnValue)
+  {
+   unsigned int argCnt;
+   int status;
+   UDFValue theArg;
+
+   argCnt = UDFArgumentCount(context);
+
+   if (argCnt == 0)
+     { ExitRouter(theEnv,EXIT_SUCCESS); }
+   else
+    {
+     if (! UDFFirstArgument(context,INTEGER_BIT,&theArg))
+       { ExitRouter(theEnv,EXIT_SUCCESS); }
+
+     status = (int) theArg.integerValue->contents;
+     if (GetEvaluationError(theEnv)) return;
+     ExitRouter(theEnv,status);
+    }
+
+   return;
+  }
+
+/******************************************************************/
+/* CreateFunction: H/L access routine for the create$ function.   */
+/******************************************************************/
+void CreateFunction(
+  Environment *theEnv,
+  UDFContext *context,
+  UDFValue *returnValue)
+  {
+   StoreInMultifield(theEnv,returnValue,GetFirstArgument(),true);
+  }
+
+/*****************************************************************/
+/* SetgenFunction: H/L access routine for the setgen function.   */
+/*****************************************************************/
+void SetgenFunction(
+  Environment *theEnv,
+  UDFContext *context,
+  UDFValue *returnValue)
+  {
+   long long theLong;
+
+   /*====================================================*/
+   /* Check to see that an integer argument is provided. */
+   /*====================================================*/
+
+   if (! UDFNthArgument(context,1,INTEGER_BIT,returnValue))
+     { return; }
+
+   /*========================================*/
+   /* The integer must be greater than zero. */
+   /*========================================*/
+
+   theLong = returnValue->integerValue->contents;
+
+   if (theLong < 1LL)
+     {
+      UDFInvalidArgumentMessage(context,"integer (greater than or equal to 1)");
+      returnValue->integerValue = CreateInteger(theEnv,MiscFunctionData(theEnv)->GensymNumber);
+      return;
+     }
+
+   /*==============================================*/
+   /* Set the gensym index to the number provided. */
+   /*==============================================*/
+
+   MiscFunctionData(theEnv)->GensymNumber = theLong;
+  }
+
+/****************************************/
+/* GensymFunction: H/L access routine   */
+/*   for the gensym function.           */
+/****************************************/
+void GensymFunction(
+  Environment *theEnv,
+  UDFContext *context,
+  UDFValue *returnValue)
+  {
+   char genstring[128];
+
+   /*================================================*/
+   /* Create a symbol using the current gensym index */
+   /* as the postfix.                                */
+   /*================================================*/
+
+   gensnprintf(genstring,sizeof(genstring),"gen%lld",MiscFunctionData(theEnv)->GensymNumber);
+   MiscFunctionData(theEnv)->GensymNumber++;
+
+   /*====================*/
+   /* Return the symbol. */
+   /*====================*/
+
+   returnValue->lexemeValue = CreateSymbol(theEnv,genstring);
+  }
+
+/************************************************/
+/* GensymStarFunction: H/L access routine for   */
+/*   the gensym* function.                      */
+/************************************************/
+void GensymStarFunction(
+  Environment *theEnv,
+  UDFContext *context,
+  UDFValue *returnValue)
+  {
+   /*====================*/
+   /* Return the symbol. */
+   /*====================*/
+
+   GensymStar(theEnv,returnValue);
+  }
+
+/************************************/
+/* GensymStar: C access routine for */
+/*   the gensym* function.          */
+/************************************/
+void GensymStar(
+  Environment *theEnv,
+  UDFValue *returnValue)
+  {
+   char genstring[128];
+
+   /*=======================================================*/
+   /* Create a symbol using the current gensym index as the */
+   /* postfix. If the symbol is already present in the      */
+   /* symbol table, then continue generating symbols until  */
+   /* a unique symbol is found.                             */
+   /*=======================================================*/
+
+   do
+     {
+      gensnprintf(genstring,sizeof(genstring),"gen%lld",MiscFunctionData(theEnv)->GensymNumber);
+      MiscFunctionData(theEnv)->GensymNumber++;
+     }
+   while (FindSymbolHN(theEnv,genstring,SYMBOL_BIT) != NULL);
+
+   /*====================*/
+   /* Return the symbol. */
+   /*====================*/
+
+   returnValue->lexemeValue = CreateSymbol(theEnv,genstring);
+  }
+
+/********************************************/
+/* RandomFunction: H/L access routine for   */
+/*   the random function.                   */
+/********************************************/
+void RandomFunction(
+  Environment *theEnv,
+  UDFContext *context,
+  UDFValue *returnValue)
+  {
+   unsigned int argCount;
+   long long rv;
+   UDFValue theArg;
+   long long begin, end;
+
+   /*====================================*/
+   /* The random function accepts either */
+   /* zero or two arguments.             */
+   /*====================================*/
+
+   argCount = UDFArgumentCount(context);
+
+   if ((argCount != 0) && (argCount != 2))
+     {
+      PrintErrorID(theEnv,"MISCFUN",2,false);
+      WriteString(theEnv,STDERR,"Function random expected either 0 or 2 arguments\n");
+     }
+
+   /*========================================*/
+   /* Return the randomly generated integer. */
+   /*========================================*/
+
+   rv = genrand();
+
+   if (argCount == 2)
+     {
+      if (! UDFFirstArgument(context,INTEGER_BIT,&theArg))
+        { return; }
+      begin = theArg.integerValue->contents;
+
+      if (! UDFNextArgument(context,INTEGER_BIT,&theArg))
+        { return; }
+
+      end = theArg.integerValue->contents;
+      if (end < begin)
+        {
+         PrintErrorID(theEnv,"MISCFUN",3,false);
+         WriteString(theEnv,STDERR,"Function random expected argument #1 to be less than argument #2\n");
+         returnValue->integerValue = CreateInteger(theEnv,rv);
+         return;
+        }
+
+      rv = begin + (rv % ((end - begin) + 1));
+     }
+
+   returnValue->integerValue = CreateInteger(theEnv,rv);
+  }
+
+/******************************************/
+/* SeedFunction: H/L access routine for   */
+/*   the seed function.                   */
+/******************************************/
+void SeedFunction(
+  Environment *theEnv,
+  UDFContext *context,
+  UDFValue *returnValue)
+  {
+   UDFValue theValue;
+
+   /*==========================================================*/
+   /* Check to see that a single integer argument is provided. */
+   /*==========================================================*/
+
+   if (! UDFFirstArgument(context,INTEGER_BIT,&theValue))
+     { return; }
+
+   /*=============================================================*/
+   /* Seed the random number generator with the provided integer. */
+   /*=============================================================*/
+
+   genseed((unsigned int) theValue.integerValue->contents);
+  }
+
+/********************************************/
+/* LengthFunction: H/L access routine for   */
+/*   the length$ function.                  */
+/********************************************/
+void LengthFunction(
+  Environment *theEnv,
+  UDFContext *context,
+  UDFValue *returnValue)
+  {
+   UDFValue theArg;
+
+   /*====================================================*/
+   /* The length$ function expects exactly one argument. */
+   /*====================================================*/
+
+   if (! UDFFirstArgument(context, MULTIFIELD_BIT, &theArg))
+     { return; }
+
+   /*==============================================*/
+   /* Return the number of fields in the argument. */
+   /*==============================================*/
+
+   returnValue->value = CreateInteger(theEnv,(long long) theArg.range);
+  }
+
+/*******************************************/
+/* ReleaseMemCommand: H/L access routine   */
+/*   for the release-mem function.         */
+/*******************************************/
+void ReleaseMemCommand(
+  Environment *theEnv,
+  UDFContext *context,
+  UDFValue *returnValue)
+  {
+   /*========================================*/
+   /* Release memory to the operating system */
+   /* and return the amount of memory freed. */
+   /*========================================*/
+
+   returnValue->integerValue = CreateInteger(theEnv,ReleaseMem(theEnv,-1));
+  }
+
+/******************************************/
+/* ConserveMemCommand: H/L access routine */
+/*   for the conserve-mem command.        */
+/******************************************/
+void ConserveMemCommand(
+  Environment *theEnv,
+  UDFContext *context,
+  UDFValue *returnValue)
+  {
+   const char *argument;
+   UDFValue theValue;
+
+   /*===================================*/
+   /* The conserve-mem function expects */
+   /* a single symbol argument.         */
+   /*===================================*/
+
+   if (! UDFFirstArgument(context,SYMBOL_BIT,&theValue))
+     { return; }
+
+   argument = theValue.lexemeValue->contents;
+
+   /*====================================================*/
+   /* If the argument is the symbol "on", then store the */
+   /* pretty print representation of a construct when it */
+   /* is defined.                                        */
+   /*====================================================*/
+
+   if (strcmp(argument,"on") == 0)
+     { SetConserveMemory(theEnv,true); }
+
+   /*======================================================*/
+   /* Otherwise, if the argument is the symbol "off", then */
+   /* don't store the pretty print representation of a     */
+   /* construct when it is defined.                        */
+   /*======================================================*/
+
+   else if (strcmp(argument,"off") == 0)
+     { SetConserveMemory(theEnv,false); }
+
+   /*=====================================================*/
+   /* Otherwise, generate an error since the only allowed */
+   /* arguments are "on" or "off."                        */
+   /*=====================================================*/
+
+   else
+     {
+      UDFInvalidArgumentMessage(context,"symbol with value on or off");
+      return;
+     }
+
+   return;
+  }
+
+#if DEBUGGING_FUNCTIONS
+
+/****************************************/
+/* MemUsedCommand: H/L access routine   */
+/*   for the mem-used command.          */
+/****************************************/
+void MemUsedCommand(
+  Environment *theEnv,
+  UDFContext *context,
+  UDFValue *returnValue)
+  {
+   /*============================================*/
+   /* Return the amount of memory currently held */
+   /* (both for current use and for later use).  */
+   /*============================================*/
+
+   returnValue->integerValue = CreateInteger(theEnv,MemUsed(theEnv));
+  }
+
+/********************************************/
+/* MemRequestsCommand: H/L access routine   */
+/*   for the mem-requests command.          */
+/********************************************/
+void MemRequestsCommand(
+  Environment *theEnv,
+  UDFContext *context,
+  UDFValue *returnValue)
+  {
+   /*==================================*/
+   /* Return the number of outstanding */
+   /* memory requests.                 */
+   /*==================================*/
+
+   returnValue->integerValue = CreateInteger(theEnv,MemRequests(theEnv));
+  }
+
+#endif
+
+/****************************************/
+/* AproposCommand: H/L access routine   */
+/*   for the apropos command.           */
+/****************************************/
+void AproposCommand(
+  Environment *theEnv,
+  UDFContext *context,
+  UDFValue *returnValue)
+  {
+   const char *argument;
+   UDFValue theArg;
+   CLIPSLexeme *hashPtr = NULL;
+   size_t theLength;
+
+   /*=======================================================*/
+   /* The apropos command expects a single symbol argument. */
+   /*=======================================================*/
+
+   if (! UDFFirstArgument(context,SYMBOL_BIT,&theArg))
+     { return; }
+
+   /*=======================================*/
+   /* Determine the length of the argument. */
+   /*=======================================*/
+
+   argument = theArg.lexemeValue->contents;
+   theLength = strlen(argument);
+
+   /*====================================================================*/
+   /* Print each entry in the symbol table that contains the argument as */
+   /* a substring. When using a non-ANSI compiler, only those strings    */
+   /* that contain the substring starting at the beginning of the string */
+   /* are printed.                                                       */
+   /*====================================================================*/
+
+   while ((hashPtr = GetNextSymbolMatch(theEnv,argument,theLength,hashPtr,true,NULL)) != NULL)
+     {
+      WriteString(theEnv,STDOUT,hashPtr->contents);
+      WriteString(theEnv,STDOUT,"\n");
+     }
+  }
+
+/****************************************/
+/* OptionsCommand: H/L access routine   */
+/*   for the options command.           */
+/****************************************/
+void OptionsCommand(
+  Environment *theEnv,
+  UDFContext *context,
+  UDFValue *returnValue)
+  {
+   /*=======================*/
+   /* Set the return value. */
+   /*=======================*/
+
+   returnValue->voidValue = VoidConstant(theEnv);
+
+   /*=================================*/
+   /* Print the state of the compiler */
+   /* flags for this executable.      */
+   /*=================================*/
+
+   WriteString(theEnv,STDOUT,"Machine type: ");
+
+#if GENERIC
+   WriteString(theEnv,STDOUT,"Generic ");
+#endif
+#if UNIX_V
+   WriteString(theEnv,STDOUT,"UNIX System V or 4.2BSD ");
+#endif
+#if DARWIN
+   WriteString(theEnv,STDOUT,"Darwin ");
+#endif
+#if LINUX
+   WriteString(theEnv,STDOUT,"Linux ");
+#endif
+#if UNIX_7
+   WriteString(theEnv,STDOUT,"UNIX System III Version 7 or Sun Unix ");
+#endif
+#if MAC_XCD
+   WriteString(theEnv,STDOUT,"Apple Macintosh with Xcode");
+#endif
+#if WIN_MVC
+   WriteString(theEnv,STDOUT,"Microsoft Windows with Microsoft Visual C++");
+#endif
+#if WIN_GCC
+   WriteString(theEnv,STDOUT,"Microsoft Windows with DJGPP");
+#endif
+WriteString(theEnv,STDOUT,"\n");
+
+WriteString(theEnv,STDOUT,"Defrule construct is ");
+#if DEFRULE_CONSTRUCT
+  WriteString(theEnv,STDOUT,"ON\n");
+#else
+  WriteString(theEnv,STDOUT,"OFF\n");
+#endif
+
+WriteString(theEnv,STDOUT,"Defmodule construct is ");
+#if DEFMODULE_CONSTRUCT
+  WriteString(theEnv,STDOUT,"ON\n");
+#else
+  WriteString(theEnv,STDOUT,"OFF\n");
+#endif
+
+WriteString(theEnv,STDOUT,"Deftemplate construct is ");
+#if DEFTEMPLATE_CONSTRUCT
+  WriteString(theEnv,STDOUT,"ON\n");
+#else
+  WriteString(theEnv,STDOUT,"OFF\n");
+#endif
+
+WriteString(theEnv,STDOUT,"  Fact-set queries are ");
+#if FACT_SET_QUERIES
+  WriteString(theEnv,STDOUT,"ON\n");
+#else
+  WriteString(theEnv,STDOUT,"OFF\n");
+#endif
+
+#if DEFTEMPLATE_CONSTRUCT
+
+WriteString(theEnv,STDOUT,"  Deffacts construct is ");
+#if DEFFACTS_CONSTRUCT
+  WriteString(theEnv,STDOUT,"ON\n");
+#else
+  WriteString(theEnv,STDOUT,"OFF\n");
+#endif
+
+#endif
+
+WriteString(theEnv,STDOUT,"Defglobal construct is ");
+#if DEFGLOBAL_CONSTRUCT
+  WriteString(theEnv,STDOUT,"ON\n");
+#else
+  WriteString(theEnv,STDOUT,"OFF\n");
+#endif
+
+WriteString(theEnv,STDOUT,"Deffunction construct is ");
+#if DEFFUNCTION_CONSTRUCT
+  WriteString(theEnv,STDOUT,"ON\n");
+#else
+  WriteString(theEnv,STDOUT,"OFF\n");
+#endif
+
+WriteString(theEnv,STDOUT,"Defgeneric/Defmethod constructs are ");
+#if DEFGENERIC_CONSTRUCT
+  WriteString(theEnv,STDOUT,"ON\n");
+#else
+  WriteString(theEnv,STDOUT,"OFF\n");
+#endif
+
+WriteString(theEnv,STDOUT,"Object System is ");
+#if OBJECT_SYSTEM
+  WriteString(theEnv,STDOUT,"ON\n");
+#else
+  WriteString(theEnv,STDOUT,"OFF\n");
+#endif
+
+#if OBJECT_SYSTEM
+
+WriteString(theEnv,STDOUT,"  Definstances construct is ");
+#if DEFINSTANCES_CONSTRUCT
+  WriteString(theEnv,STDOUT,"ON\n");
+#else
+  WriteString(theEnv,STDOUT,"OFF\n");
+#endif
+
+WriteString(theEnv,STDOUT,"  Instance-set queries are ");
+#if INSTANCE_SET_QUERIES
+  WriteString(theEnv,STDOUT,"ON\n");
+#else
+  WriteString(theEnv,STDOUT,"OFF\n");
+#endif
+
+WriteString(theEnv,STDOUT,"  Binary loading of instances is ");
+#if BLOAD_INSTANCES
+  WriteString(theEnv,STDOUT,"ON\n");
+#else
+  WriteString(theEnv,STDOUT,"OFF\n");
+#endif
+
+WriteString(theEnv,STDOUT,"  Binary saving of instances is ");
+#if BSAVE_INSTANCES
+  WriteString(theEnv,STDOUT,"ON\n");
+#else
+  WriteString(theEnv,STDOUT,"OFF\n");
+#endif
+
+#endif
+
+WriteString(theEnv,STDOUT,"Extended math function package is ");
+#if EXTENDED_MATH_FUNCTIONS
+  WriteString(theEnv,STDOUT,"ON\n");
+#else
+  WriteString(theEnv,STDOUT,"OFF\n");
+#endif
+
+WriteString(theEnv,STDOUT,"Text processing function package is ");
+#if TEXTPRO_FUNCTIONS
+  WriteString(theEnv,STDOUT,"ON\n");
+#else
+  WriteString(theEnv,STDOUT,"OFF\n");
+#endif
+
+WriteString(theEnv,STDOUT,"Bload capability is ");
+#if BLOAD_ONLY
+  WriteString(theEnv,STDOUT,"BLOAD ONLY");
+#endif
+#if BLOAD
+  WriteString(theEnv,STDOUT,"BLOAD");
+#endif
+#if BLOAD_AND_BSAVE
+  WriteString(theEnv,STDOUT,"BLOAD AND BSAVE");
+#endif
+#if (! BLOAD_ONLY) && (! BLOAD) && (! BLOAD_AND_BSAVE)
+  WriteString(theEnv,STDOUT,"OFF ");
+#endif
+WriteString(theEnv,STDOUT,"\n");
+
+WriteString(theEnv,STDOUT,"Construct compiler is ");
+#if CONSTRUCT_COMPILER
+  WriteString(theEnv,STDOUT,"ON\n");
+#else
+  WriteString(theEnv,STDOUT,"OFF\n");
+#endif
+
+WriteString(theEnv,STDOUT,"I/O function package is ");
+#if IO_FUNCTIONS
+  WriteString(theEnv,STDOUT,"ON\n");
+#else
+  WriteString(theEnv,STDOUT,"OFF\n");
+#endif
+
+WriteString(theEnv,STDOUT,"String function package is ");
+#if STRING_FUNCTIONS
+  WriteString(theEnv,STDOUT,"ON\n");
+#else
+  WriteString(theEnv,STDOUT,"OFF\n");
+#endif
+
+WriteString(theEnv,STDOUT,"Multifield function package is ");
+#if MULTIFIELD_FUNCTIONS
+  WriteString(theEnv,STDOUT,"ON\n");
+#else
+  WriteString(theEnv,STDOUT,"OFF\n");
+#endif
+
+WriteString(theEnv,STDOUT,"Debugging function package is ");
+#if DEBUGGING_FUNCTIONS
+  WriteString(theEnv,STDOUT,"ON\n");
+#else
+  WriteString(theEnv,STDOUT,"OFF\n");
+#endif
+
+WriteString(theEnv,STDOUT,"Developer flag is ");
+#if DEVELOPER
+   WriteString(theEnv,STDOUT,"ON\n");
+#else
+   WriteString(theEnv,STDOUT,"OFF\n");
+#endif
+
+WriteString(theEnv,STDOUT,"Run time module is ");
+#if RUN_TIME
+  WriteString(theEnv,STDOUT,"ON\n");
+#else
+  WriteString(theEnv,STDOUT,"OFF\n");
+#endif
+  }
+
+/***********************************************/
+/* OperatingSystemFunction: H/L access routine */
+/*   for the operating system function.        */
+/***********************************************/
+void OperatingSystemFunction(
+  Environment *theEnv,
+  UDFContext *context,
+  UDFValue *returnValue)
+  {
+#if GENERIC
+   returnValue->lexemeValue = CreateSymbol(theEnv,"UNKNOWN");
+#elif UNIX_V
+   returnValue->lexemeValue = CreateSymbol(theEnv,"UNIX-V");
+#elif UNIX_7
+   returnValue->lexemeValue = CreateSymbol(theEnv,"UNIX-7");
+#elif LINUX
+   returnValue->lexemeValue = CreateSymbol(theEnv,"LINUX");
+#elif DARWIN
+   returnValue->lexemeValue = CreateSymbol(theEnv,"DARWIN");
+#elif MAC_XCD
+   returnValue->lexemeValue = CreateSymbol(theEnv,"MAC-OS");
+#elif WINDOWS_OS
+   returnValue->lexemeValue = CreateSymbol(theEnv,"WINDOWS");
+#else
+   returnValue->lexemeValue = CreateSymbol(theEnv,"UNKNOWN");
+#endif
+  }
+
+/********************************************************************
+  NAME         : ExpandFuncCall
+  DESCRIPTION  : This function is a wrap-around for a normal
+                   function call.  It preexamines the argument
+                   expression list and expands any references to the
+                   sequence operator.  It builds a copy of the
+                   function call expression with these new arguments
+                   inserted and evaluates the function call.
+  INPUTS       : A data object buffer
+  RETURNS      : Nothing useful
+  SIDE EFFECTS : Expressions alloctaed/deallocated
+                 Function called and arguments evaluated
+                 EvaluationError set on errors
+  NOTES        : None
+ *******************************************************************/
+void ExpandFuncCall(
+  Environment *theEnv,
+  UDFContext *context,
+  UDFValue *returnValue)
+  {
+   Expression *newargexp,*fcallexp;
+   struct functionDefinition *func;
+
+   /* ======================================================================
+      Copy the original function call's argument expression list.
+      Look for expand$ function callsexpressions and replace those
+        with the equivalent expressions of the expansions of evaluations
+        of the arguments.
+      ====================================================================== */
+   newargexp = CopyExpression(theEnv,GetFirstArgument()->argList);
+   ExpandFuncMultifield(theEnv,returnValue,newargexp,&newargexp,
+                        FindFunction(theEnv,"expand$"));
+
+   /* ===================================================================
+      Build the new function call expression with the expanded arguments.
+      Check the number of arguments, if necessary, and call the thing.
+      =================================================================== */
+   fcallexp = get_struct(theEnv,expr);
+   fcallexp->type = GetFirstArgument()->type;
+   fcallexp->value = GetFirstArgument()->value;
+   fcallexp->nextArg = NULL;
+   fcallexp->argList = newargexp;
+   if (fcallexp->type == FCALL)
+     {
+      func = fcallexp->functionValue;
+      if (CheckFunctionArgCount(theEnv,func,CountArguments(newargexp)) == false)
+        {
+         returnValue->lexemeValue = FalseSymbol(theEnv);
+         ReturnExpression(theEnv,fcallexp);
+         return;
+        }
+     }
+#if DEFFUNCTION_CONSTRUCT
+   else if (fcallexp->type == PCALL)
+     {
+      if (CheckDeffunctionCall(theEnv,(Deffunction *) fcallexp->value,
+              CountArguments(fcallexp->argList)) == false)
+        {
+         returnValue->lexemeValue = FalseSymbol(theEnv);
+         ReturnExpression(theEnv,fcallexp);
+         SetEvaluationError(theEnv,true);
+         return;
+        }
+     }
+#endif
+
+   EvaluateExpression(theEnv,fcallexp,returnValue);
+   ReturnExpression(theEnv,fcallexp);
+  }
+
+/***********************************************************************
+  NAME         : DummyExpandFuncMultifield
+  DESCRIPTION  : The expansion of multifield arguments is valid only
+                 when done for a function call.  All these expansions
+                 are handled by the H/L wrap-around function
+                 (expansion-call) - see ExpandFuncCall.  If the H/L
+                 function, epand-multifield is ever called directly,
+                 it is an error.
+  INPUTS       : Data object buffer
+  RETURNS      : Nothing useful
+  SIDE EFFECTS : EvaluationError set
+  NOTES        : None
+ **********************************************************************/
+void DummyExpandFuncMultifield(
+  Environment *theEnv,
+  UDFContext *context,
+  UDFValue *returnValue)
+  {
+   returnValue->lexemeValue = FalseSymbol(theEnv);
+   SetEvaluationError(theEnv,true);
+   PrintErrorID(theEnv,"MISCFUN",1,false);
+   WriteString(theEnv,STDERR,"The function 'expand$' must be used in the argument list of a function call.\n");
+  }
+
+/***********************************************************************
+  NAME         : ExpandFuncMultifield
+  DESCRIPTION  : Recursively examines an expression and replaces
+                   PROC_EXPAND_MULTIFIELD expressions with the expanded
+                   evaluation expression of its argument
+  INPUTS       : 1) A data object result buffer
+                 2) The expression to modify
+                 3) The address of the expression, in case it is
+                    deleted entirely
+                 4) The address of the H/L function expand$
+  RETURNS      : Nothing useful
+  SIDE EFFECTS : Expressions allocated/deallocated as necessary
+                 Evaluations performed
+                 On errors, argument expression set to call a function
+                   which causes an evaluation error when evaluated
+                   a second time by actual caller.
+  NOTES        : THIS ROUTINE MODIFIES EXPRESSIONS AT RUNTIME!!  MAKE
+                 SURE THAT THE Expression PASSED IS SAFE TO CHANGE!!
+ **********************************************************************/
+static void ExpandFuncMultifield(
+  Environment *theEnv,
+  UDFValue *returnValue,
+  Expression *theExp,
+  Expression **sto,
+  void *expmult)
+  {
+   Expression *newexp,*top,*bot;
+   size_t i; /* 6.04 Bug Fix */
+
+   while (theExp != NULL)
+     {
+      if (theExp->value == expmult)
+        {
+         EvaluateExpression(theEnv,theExp->argList,returnValue);
+         ReturnExpression(theEnv,theExp->argList);
+         if ((EvaluationData(theEnv)->EvaluationError) ||
+             (returnValue->header->type != MULTIFIELD_TYPE))
+           {
+            theExp->argList = NULL;
+            if ((EvaluationData(theEnv)->EvaluationError == false) &&
+                (returnValue->header->type != MULTIFIELD_TYPE))
+              ExpectedTypeError2(theEnv,"expand$",1);
+            theExp->value = FindFunction(theEnv,"(set-evaluation-error)");
+            EvaluationData(theEnv)->EvaluationError = false;
+            EvaluationData(theEnv)->HaltExecution = false;
+            return;
+           }
+         top = bot = NULL;
+         for (i = returnValue->begin ; i < (returnValue->begin + returnValue->range) ; i++)
+           {
+            newexp = get_struct(theEnv,expr);
+            newexp->type = returnValue->multifieldValue->contents[i].header->type;
+            newexp->value = returnValue->multifieldValue->contents[i].value;
+            newexp->argList = NULL;
+            newexp->nextArg = NULL;
+            if (top == NULL)
+              top = newexp;
+            else
+              bot->nextArg = newexp;
+            bot = newexp;
+           }
+         if (top == NULL)
+           {
+            *sto = theExp->nextArg;
+            rtn_struct(theEnv,expr,theExp);
+            theExp = *sto;
+           }
+         else
+           {
+            bot->nextArg = theExp->nextArg;
+            *sto = top;
+            rtn_struct(theEnv,expr,theExp);
+            sto = &bot->nextArg;
+            theExp = bot->nextArg;
+           }
+        }
+      else
+        {
+         if (theExp->argList != NULL)
+           ExpandFuncMultifield(theEnv,returnValue,theExp->argList,&theExp->argList,expmult);
+         sto = &theExp->nextArg;
+         theExp = theExp->nextArg;
+        }
+     }
+  }
+
+/****************************************************************
+  NAME         : CauseEvaluationError
+  DESCRIPTION  : Dummy function use to cause evaluation errors on
+                   a function call to generate error messages
+  INPUTS       : None
+  RETURNS      : A pointer to the FalseSymbol
+  SIDE EFFECTS : EvaluationError set
+  NOTES        : None
+ ****************************************************************/
+void CauseEvaluationError(
+  Environment *theEnv,
+  UDFContext *context,
+  UDFValue *returnValue)
+  {
+   SetEvaluationError(theEnv,true);
+   returnValue->lexemeValue = FalseSymbol(theEnv);
+  }
+
+/************************************************/
+/* GetSORCommand: H/L access routine for the    */
+/*   get-sequence-operator-recognition command. */
+/************************************************/
+void GetSORCommand(
+  Environment *theEnv,
+  UDFContext *context,
+  UDFValue *returnValue)
+  {
+   returnValue->lexemeValue = CreateBoolean(theEnv,GetSequenceOperatorRecognition(theEnv));
+  }
+
+/************************************************/
+/* SetSORCommand: H/L access routine for the    */
+/*   set-sequence-operator-recognition command. */
+/************************************************/
+void SetSORCommand(
+  Environment *theEnv,
+  UDFContext *context,
+  UDFValue *returnValue)
+  {
+#if (! RUN_TIME) && (! BLOAD_ONLY)
+   UDFValue theArg;
+
+   if (! UDFFirstArgument(context,SYMBOL_BIT,&theArg))
+     { return; }
+
+   returnValue->lexemeValue = CreateBoolean(theEnv,SetSequenceOperatorRecognition(theEnv,theArg.value != FalseSymbol(theEnv)));
+#else
+   returnValue->lexemeValue = CreateBoolean(theEnv,ExpressionData(theEnv)->SequenceOpMode);
+#endif
+  }
+
+/********************************************************************
+  NAME         : GetFunctionRestrictions
+  DESCRIPTION  : Gets DefineFunction2() restriction list for function
+  INPUTS       : None
+  RETURNS      : A string containing the function restriction codes
+  SIDE EFFECTS : EvaluationError set on errors
+  NOTES        : None
+ ********************************************************************/
+void GetFunctionRestrictions(
+  Environment *theEnv,
+  UDFContext *context,
+  UDFValue *returnValue)
+  {
+   UDFValue theArg;
+   struct functionDefinition *fptr;
+   char *stringBuffer = NULL;
+   size_t bufferPosition = 0;
+   size_t bufferMaximum = 0;
+
+   if (! UDFFirstArgument(context,SYMBOL_BIT,&theArg))
+     { return; }
+
+   fptr = FindFunction(theEnv,theArg.lexemeValue->contents);
+   if (fptr == NULL)
+     {
+      CantFindItemErrorMessage(theEnv,"function",theArg.lexemeValue->contents,true);
+      SetEvaluationError(theEnv,true);
+      returnValue->lexemeValue = CreateString(theEnv,"");
+      return;
+     }
+
+   if (fptr->minArgs == UNBOUNDED)
+     {
+      stringBuffer = AppendToString(theEnv,"0",
+                                    stringBuffer,&bufferPosition,&bufferMaximum);
+     }
+   else
+     {
+      stringBuffer = AppendToString(theEnv,LongIntegerToString(theEnv,fptr->minArgs),
+                                    stringBuffer,&bufferPosition,&bufferMaximum);
+     }
+
+   stringBuffer = AppendToString(theEnv,";",
+                                 stringBuffer,&bufferPosition,&bufferMaximum);
+
+   if (fptr->maxArgs == UNBOUNDED)
+     {
+      stringBuffer = AppendToString(theEnv,"*",
+                                    stringBuffer,&bufferPosition,&bufferMaximum);
+     }
+   else
+     {
+      stringBuffer = AppendToString(theEnv,LongIntegerToString(theEnv,fptr->maxArgs),
+                                    stringBuffer,&bufferPosition,&bufferMaximum);
+     }
+     
+   stringBuffer = AppendToString(theEnv,";",
+                                 stringBuffer,&bufferPosition,&bufferMaximum);
+
+   if (fptr->restrictions == NULL)
+     {
+      stringBuffer = AppendToString(theEnv,"*",
+                                    stringBuffer,&bufferPosition,&bufferMaximum);
+     }
+   else
+     {
+      stringBuffer = AppendToString(theEnv,fptr->restrictions->contents,
+                                    stringBuffer,&bufferPosition,&bufferMaximum);
+     }
+
+   returnValue->lexemeValue = CreateString(theEnv,stringBuffer);
+
+   rm(theEnv,stringBuffer,bufferMaximum);
+  }
+
+/*************************************************/
+/* GetFunctionListFunction: H/L access routine   */
+/*   for the get-function-list function.         */
+/*************************************************/
+void GetFunctionListFunction(
+  Environment *theEnv,
+  UDFContext *context,
+  UDFValue *returnValue)
+  {
+   struct functionDefinition *theFunction;
+   Multifield *theList;
+   unsigned long functionCount = 0;
+
+   for (theFunction = GetFunctionList(theEnv);
+        theFunction != NULL;
+        theFunction = theFunction->next)
+     { functionCount++; }
+
+   returnValue->begin = 0;
+   returnValue->range = functionCount;
+   theList = CreateMultifield(theEnv,functionCount);
+   returnValue->value = theList;
+
+   for (theFunction = GetFunctionList(theEnv), functionCount = 0;
+        theFunction != NULL;
+        theFunction = theFunction->next, functionCount++)
+     {
+      theList->contents[functionCount].lexemeValue = theFunction->callFunctionName;
+     }
+  }
+
+/***************************************/
+/* FuncallFunction: H/L access routine */
+/*   for the funcall function.         */
+/***************************************/
+void FuncallFunction(
+  Environment *theEnv,
+  UDFContext *context,
+  UDFValue *returnValue)
+  {
+   size_t j;
+   UDFValue theArg;
+   Expression theReference;
+   const char *name;
+   Multifield *theMultifield;
+   struct expr *lastAdd = NULL, *nextAdd, *multiAdd;
+   struct functionDefinition *theFunction = NULL;
+
+   /*==================================*/
+   /* Set up the default return value. */
+   /*==================================*/
+
+   returnValue->lexemeValue = FalseSymbol(theEnv);
+
+   /*============================================*/
+   /* Get the name of the function to be called. */
+   /*============================================*/
+
+   if (! UDFFirstArgument(context,LEXEME_BITS,&theArg))
+     { return; }
+
+   /*====================*/
+   /* Find the function. */
+   /*====================*/
+
+   name = theArg.lexemeValue->contents;
+   if (! GetFunctionReference(theEnv,name,&theReference))
+     {
+      ExpectedTypeError1(theEnv,"funcall",1,"function, deffunction, or generic function name");
+      return;
+     }
+
+   /*====================================*/
+   /* Functions with specialized parsers */
+   /* cannot be used with funcall.       */
+   /*====================================*/
+
+   if (theReference.type == FCALL)
+     {
+      theFunction = FindFunction(theEnv,name);
+      if (theFunction->parser != NULL)
+        {
+         ExpectedTypeError1(theEnv,"funcall",1,"function without specialized parser");
+         return;
+        }
+     }
+
+   /*======================================*/
+   /* Add the arguments to the expression. */
+   /*======================================*/
+
+   ExpressionInstall(theEnv,&theReference);
+
+   while (UDFHasNextArgument(context))
+     {
+      if (! UDFNextArgument(context,ANY_TYPE_BITS,&theArg))
+        {
+         ExpressionDeinstall(theEnv,&theReference);
+         return;
+        }
+
+      switch(theArg.header->type)
+        {
+         case MULTIFIELD_TYPE:
+           nextAdd = GenConstant(theEnv,FCALL,FindFunction(theEnv,"create$"));
+
+           if (lastAdd == NULL)
+             { theReference.argList = nextAdd; }
+           else
+             { lastAdd->nextArg = nextAdd; }
+           lastAdd = nextAdd;
+
+           multiAdd = NULL;
+           theMultifield = theArg.multifieldValue;
+           for (j = theArg.begin; j < (theArg.begin + theArg.range); j++)
+             {
+              nextAdd = GenConstant(theEnv,theMultifield->contents[j].header->type,
+                                           theMultifield->contents[j].value);
+              if (multiAdd == NULL)
+                { lastAdd->argList = nextAdd; }
+              else
+                { multiAdd->nextArg = nextAdd; }
+              multiAdd = nextAdd;
+             }
+
+           ExpressionInstall(theEnv,lastAdd);
+           break;
+
+         default:
+           nextAdd = GenConstant(theEnv,theArg.header->type,theArg.value);
+           if (lastAdd == NULL)
+             { theReference.argList = nextAdd; }
+           else
+             { lastAdd->nextArg = nextAdd; }
+           lastAdd = nextAdd;
+           ExpressionInstall(theEnv,lastAdd);
+           break;
+        }
+     }
+
+   /*===========================================================*/
+   /* Verify a deffunction has the correct number of arguments. */
+   /*===========================================================*/
+
+#if DEFFUNCTION_CONSTRUCT
+   if (theReference.type == PCALL)
+     {
+      if (CheckDeffunctionCall(theEnv,(Deffunction *) theReference.value,CountArguments(theReference.argList)) == false)
+        {
+         PrintErrorID(theEnv,"MISCFUN",4,false);
+         WriteString(theEnv,STDERR,"Function 'funcall' called with the wrong number of arguments for deffunction '");
+         WriteString(theEnv,STDERR,DeffunctionName((Deffunction *) theReference.value));
+         WriteString(theEnv,STDERR,"'.\n");
+         ExpressionDeinstall(theEnv,&theReference);
+         ReturnExpression(theEnv,theReference.argList);
+         return;
+        }
+     }
+#endif
+
+   /*=========================================*/
+   /* Verify the correct number of arguments. */
+   /*=========================================*/
+
+// TBD Support run time check of arguments
+#if ! RUN_TIME
+   if (theReference.type == FCALL)
+     {
+      if (CheckExpressionAgainstRestrictions(theEnv,&theReference,theFunction,name))
+        {
+         ExpressionDeinstall(theEnv,&theReference);
+         ReturnExpression(theEnv,theReference.argList);
+         return;
+        }
+     }
+#endif
+
+   /*======================*/
+   /* Call the expression. */
+   /*======================*/
+
+   EvaluateExpression(theEnv,&theReference,returnValue);
+
+   /*========================================*/
+   /* Return the expression data structures. */
+   /*========================================*/
+
+   ExpressionDeinstall(theEnv,&theReference);
+   ReturnExpression(theEnv,theReference.argList);
+  }
+
+/***********************************/
+/* NewFunction: H/L access routine */
+/*   for the new function.         */
+/***********************************/
+void NewFunction(
+  Environment *theEnv,
+  UDFContext *context,
+  UDFValue *returnValue)
+  {
+   int theType;
+   UDFValue theValue;
+   const char *name;
+
+   /*==================================*/
+   /* Set up the default return value. */
+   /*==================================*/
+
+   returnValue->lexemeValue = FalseSymbol(theEnv);
+
+   /*====================================*/
+   /* Get the name of the language type. */
+   /*====================================*/
+
+   if (! UDFFirstArgument(context,SYMBOL_BIT,&theValue))
+     { return; }
+
+   /*=========================*/
+   /* Find the language type. */
+   /*=========================*/
+
+   name = theValue.lexemeValue->contents;
+
+   theType = FindLanguageType(theEnv,name);
+
+   if (theType == -1)
+     {
+      ExpectedTypeError1(theEnv,"new",1,"external language");
+      return;
+     }
+
+   /*====================================================*/
+   /* Invoke the new function for the specific language. */
+   /*====================================================*/
+
+   if ((EvaluationData(theEnv)->ExternalAddressTypes[theType] != NULL) &&
+       (EvaluationData(theEnv)->ExternalAddressTypes[theType]->newFunction != NULL))
+     { (*EvaluationData(theEnv)->ExternalAddressTypes[theType]->newFunction)(context,returnValue); }
+  }
+
+/************************************/
+/* CallFunction: H/L access routine */
+/*   for the new function.          */
+/************************************/
+void CallFunction(
+  Environment *theEnv,
+  UDFContext *context,
+  UDFValue *returnValue)
+  {
+   int theType;
+   UDFValue theValue;
+   const char *name;
+   CLIPSExternalAddress *theEA;
+
+   /*==================================*/
+   /* Set up the default return value. */
+   /*==================================*/
+
+   returnValue->lexemeValue = FalseSymbol(theEnv);
+
+   /*=========================*/
+   /* Get the first argument. */
+   /*=========================*/
+
+   if (! UDFFirstArgument(context,SYMBOL_BIT | EXTERNAL_ADDRESS_BIT,&theValue))
+     { return; }
+
+   /*============================================*/
+   /* If the first argument is a symbol, then it */
+   /* should be an external language type.       */
+   /*============================================*/
+
+   if (theValue.header->type == SYMBOL_TYPE)
+     {
+      name = theValue.lexemeValue->contents;
+
+      theType = FindLanguageType(theEnv,name);
+
+      if (theType == -1)
+        {
+         ExpectedTypeError1(theEnv,"call",1,"external language symbol or external address");
+         return;
+        }
+
+      /*====================================================================*/
+      /* Invoke the call function for the specific language. Typically this */
+      /* will invoke a static method of a class (specified with the third   */
+      /* and second arguments to the call function.                         */
+      /*====================================================================*/
+
+      if ((EvaluationData(theEnv)->ExternalAddressTypes[theType] != NULL) &&
+          (EvaluationData(theEnv)->ExternalAddressTypes[theType]->callFunction != NULL))
+        { (*EvaluationData(theEnv)->ExternalAddressTypes[theType]->callFunction)(context,&theValue,returnValue); }
+
+      return;
+     }
+
+   /*===============================================*/
+   /* If the first argument is an external address, */
+   /* then we can determine the external language   */
+   /* type be examining the pointer.                */
+   /*===============================================*/
+
+   if (theValue.header->type == EXTERNAL_ADDRESS_TYPE)
+     {
+      theEA = theValue.externalAddressValue;
+
+      theType = theEA->type;
+
+      if ((EvaluationData(theEnv)->ExternalAddressTypes[theType] != NULL) &&
+          (EvaluationData(theEnv)->ExternalAddressTypes[theType]->callFunction != NULL))
+        { (*EvaluationData(theEnv)->ExternalAddressTypes[theType]->callFunction)(context,&theValue,returnValue); }
+
+      return;
+     }
+  }
+
+/*********************/
+/* FindLanguageType: */
+/*********************/
+static int FindLanguageType(
+  Environment *theEnv,
+  const char *languageName)
+  {
+   int theType;
+
+   for (theType = 0; theType < EvaluationData(theEnv)->numberOfAddressTypes; theType++)
+     {
+      if (strcmp(EvaluationData(theEnv)->ExternalAddressTypes[theType]->name,languageName) == 0)
+        { return(theType); }
+     }
+
+   return -1;
+  }
+
+/************************************/
+/* TimeFunction: H/L access routine */
+/*   for the time function.         */
+/************************************/
+void TimeFunction(
+  Environment *theEnv,
+  UDFContext *context,
+  UDFValue *returnValue)
+  {
+   /*==================*/
+   /* Return the time. */
+   /*==================*/
+
+   returnValue->floatValue = CreateFloat(theEnv,gentime());
+  }
+
+/****************************************/
+/* ConvertTime: Function for converting */
+/*   time for local-time and gm-time.   */
+/****************************************/
+static void ConvertTime(
+  Environment *theEnv,
+  UDFValue *returnValue,
+  struct tm *info)
+  {
+   returnValue->begin = 0;
+   returnValue->range = 9;
+   returnValue->value = CreateMultifield(theEnv,9L);
+   
+   returnValue->multifieldValue->contents[0].integerValue = CreateInteger(theEnv,info->tm_year + 1900);
+   returnValue->multifieldValue->contents[1].integerValue = CreateInteger(theEnv,info->tm_mon + 1);
+   returnValue->multifieldValue->contents[2].integerValue = CreateInteger(theEnv,info->tm_mday);
+   returnValue->multifieldValue->contents[3].integerValue = CreateInteger(theEnv,info->tm_hour);
+   returnValue->multifieldValue->contents[4].integerValue = CreateInteger(theEnv,info->tm_min);
+   returnValue->multifieldValue->contents[5].integerValue = CreateInteger(theEnv,info->tm_sec);
+
+   switch (info->tm_wday)
+     {
+      case 0:
+        returnValue->multifieldValue->contents[6].lexemeValue = CreateSymbol(theEnv,"Sunday");
+        break;
+
+      case 1:
+        returnValue->multifieldValue->contents[6].lexemeValue = CreateSymbol(theEnv,"Monday");
+        break;
+
+      case 2:
+        returnValue->multifieldValue->contents[6].lexemeValue = CreateSymbol(theEnv,"Tuesday");
+        break;
+
+      case 3:
+        returnValue->multifieldValue->contents[6].lexemeValue = CreateSymbol(theEnv,"Wednesday");
+        break;
+
+      case 4:
+        returnValue->multifieldValue->contents[6].lexemeValue = CreateSymbol(theEnv,"Thursday");
+        break;
+
+      case 5:
+        returnValue->multifieldValue->contents[6].lexemeValue = CreateSymbol(theEnv,"Friday");
+        break;
+
+      case 6:
+        returnValue->multifieldValue->contents[6].lexemeValue = CreateSymbol(theEnv,"Saturday");
+        break;
+     }
+
+   returnValue->multifieldValue->contents[7].integerValue = CreateInteger(theEnv,info->tm_yday);
+
+   if (info->tm_isdst > 0)
+     { returnValue->multifieldValue->contents[8].lexemeValue = TrueSymbol(theEnv); }
+   else if (info->tm_isdst == 0)
+     { returnValue->multifieldValue->contents[8].lexemeValue = FalseSymbol(theEnv); }
+   else
+     { returnValue->multifieldValue->contents[8].lexemeValue = CreateSymbol(theEnv,"UNKNOWN"); }
+  }
+
+/*****************************************/
+/* LocalTimeFunction: H/L access routine */
+/*   for the local-time function.        */
+/*****************************************/
+void LocalTimeFunction(
+  Environment *theEnv,
+  UDFContext *context,
+  UDFValue *returnValue)
+  {
+   time_t rawtime;
+   struct tm *info;
+
+   /*=====================*/
+   /* Get the local time. */
+   /*=====================*/
+
+   time(&rawtime);
+   info = localtime(&rawtime);
+
+   ConvertTime(theEnv,returnValue,info);
+  }
+
+/**************************************/
+/* GMTimeFunction: H/L access routine */
+/*   for the gm-time function.        */
+/**************************************/
+void GMTimeFunction(
+  Environment *theEnv,
+  UDFContext *context,
+  UDFValue *returnValue)
+  {
+   time_t rawtime;
+   struct tm *info;
+
+   /*=====================*/
+   /* Get the local time. */
+   /*=====================*/
+
+   time(&rawtime);
+   info = gmtime(&rawtime);
+
+   ConvertTime(theEnv,returnValue,info);
+  }
+
+/***************************************/
+/* TimerFunction: H/L access routine   */
+/*   for the timer function.           */
+/***************************************/
+void TimerFunction(
+  Environment *theEnv,
+  UDFContext *context,
+  UDFValue *returnValue)
+  {
+   double startTime;
+   UDFValue theArg;
+
+   startTime = gentime();
+
+   while (UDFHasNextArgument(context) &&
+          (! GetHaltExecution(theEnv)))
+     { UDFNextArgument(context,ANY_TYPE_BITS,&theArg); }
+
+   returnValue->floatValue = CreateFloat(theEnv,gentime() - startTime);
+  }
+
+#if SYSTEM_FUNCTION
+/***************************************/
+/* SystemCommand: H/L access routine   */
+/*   for the system function.          */
+/***************************************/
+void SystemCommand(
+  Environment *theEnv,
+  UDFContext *context,
+  UDFValue *returnValue)
+  {
+   char *commandBuffer = NULL;
+   size_t bufferPosition = 0;
+   size_t bufferMaximum = 0;
+   UDFValue tempValue;
+   const char *theString;
+
+   /*============================================================*/
+   /* Concatenate the arguments together to form a single string */
+   /* containing the command to be sent to the operating system. */
+   /*============================================================*/
+
+   while (UDFHasNextArgument(context))
+     {
+      if (! UDFNextArgument(context,LEXEME_BITS,&tempValue))
+        {
+         returnValue->lexemeValue = FalseSymbol(theEnv);
+         return;
+        }
+
+     theString = tempValue.lexemeValue->contents;
+
+     commandBuffer = AppendToString(theEnv,theString,commandBuffer,&bufferPosition,&bufferMaximum);
+    }
+
+   /*=======================================*/
+   /* Execute the operating system command. */
+   /*=======================================*/
+
+   returnValue->integerValue = CreateInteger(theEnv,gensystem(theEnv,commandBuffer));
+
+   /*==================================================*/
+   /* Return the string buffer containing the command. */
+   /*==================================================*/
+
+   if (commandBuffer != NULL)
+     { rm(theEnv,commandBuffer,bufferMaximum); }
+  }
+#endif
+
+/****************************************/
+/* GetErrorFunction: H/L access routine */
+/*   for the geterror function.         */
+/****************************************/
+void GetErrorFunction(
+  Environment *theEnv,
+  UDFContext *context,
+  UDFValue *returnValue)
+  {
+   CLIPSToUDFValue(&MiscFunctionData(theEnv)->errorCode,returnValue);
+  }
+
+/*****************/
+/* SetErrorValue */
+/*****************/
+void SetErrorValue(
+  Environment *theEnv,
+  TypeHeader *theValue)
+  {
+   Release(theEnv,MiscFunctionData(theEnv)->errorCode.header);
+   
+   if (theValue == NULL)
+     { MiscFunctionData(theEnv)->errorCode.lexemeValue = FalseSymbol(theEnv); }
+   else
+     { MiscFunctionData(theEnv)->errorCode.header = theValue; }
+     
+   Retain(theEnv,MiscFunctionData(theEnv)->errorCode.header);
+  }
+
+/*******************/
+/* ClearErrorValue */
+/*******************/
+void ClearErrorValue(
+  Environment *theEnv)
+  {
+   Release(theEnv,MiscFunctionData(theEnv)->errorCode.header);
+   MiscFunctionData(theEnv)->errorCode.lexemeValue = FalseSymbol(theEnv);
+   Retain(theEnv,MiscFunctionData(theEnv)->errorCode.header);
+  }
+
+/******************************************/
+/* ClearErrorFunction: H/L access routine */
+/*   for the clear-error function.        */
+/******************************************/
+void ClearErrorFunction(
+  Environment *theEnv,
+  UDFContext *context,
+  UDFValue *returnValue)
+  {
+   CLIPSToUDFValue(&MiscFunctionData(theEnv)->errorCode,returnValue);
+   ClearErrorValue(theEnv);
+  }
+
+/****************************************/
+/* SetErrorFunction: H/L access routine */
+/*   for the set-error function.        */
+/****************************************/
+void SetErrorFunction(
+  Environment *theEnv,
+  UDFContext *context,
+  UDFValue *returnValue)
+  {
+   CLIPSValue cv;
+   UDFValue theArg;
+   
+   if (! UDFFirstArgument(context,ANY_TYPE_BITS,&theArg))
+     { return; }
+     
+   NormalizeMultifield(theEnv,&theArg);
+   cv.value = theArg.value;
+   SetErrorValue(theEnv,cv.header);
+  }
+
+/************************************/
+/* VoidFunction: H/L access routine */
+/*   for the void function.         */
+/************************************/
+void VoidFunction(
+  Environment *theEnv,
+  UDFContext *context,
+  UDFValue *returnValue)
+  {
+   returnValue->voidValue = VoidConstant(theEnv);
+  }