home *** CD-ROM | disk | FTP | other *** search
/ Power Programming / powerprogramming1994.iso / progtool / pli / runpli1a.arc / RUN.C < prev    next >
C/C++ Source or Header  |  1989-02-01  |  298KB  |  7,576 lines
  1. #include <stdio.h>
  2. #include <ctype.h>
  3. #include <process.h>
  4. #include <stdlib.h>
  5. #include <string.h>
  6. #include <malloc.h>
  7. #include <math.h>
  8. #include <time.h>
  9.  
  10. #define INCL_BASE 1           /* remove for DOS compile */
  11. #ifdef INCL_BASE
  12. #include <os2.h>
  13. #else
  14. #include <dos.h>
  15. #endif
  16.  
  17. #define TRUE 1
  18. #define FALSE 0
  19. #define page_size 16384
  20.  
  21. typedef struct text
  22.           {
  23.             int           length;
  24.             unsigned char *value;
  25.           } *text_ptr;
  26.  
  27. typedef struct value_header
  28.            {
  29.              char       type;
  30.              union
  31.                {
  32.                  int      *boolean;
  33.                  FILE     **dataset;
  34.                  long     *integer;
  35.                  double   *real;
  36.                  text_ptr string;
  37.                }        value_ptr;
  38.            } *value_header_ptr;
  39.  
  40. typedef struct queue_node
  41.                  {
  42.                    value_header_ptr  argument_header_ptr;
  43.                    struct queue_node *next;
  44.                  } *queue_node_ptr;
  45.  
  46. typedef struct variable
  47.                  {
  48.                    char             *name;
  49.                    queue_node_ptr   subscripts;
  50.                    value_header_ptr variable_value_header_ptr;
  51.                    struct variable  *predecessor_ptr;
  52.                    struct variable  *smaller_successor_ptr;
  53.                    struct variable  *larger_successor_ptr;
  54.                  } *variable_ptr;
  55.  
  56. static value_header_ptr abs_header_ptr(queue_node_ptr,char *,int);
  57. static void             add_argc(int);
  58. static void             add_argv(int,char *);
  59. static value_header_ptr add_terms(value_header_ptr,value_header_ptr);
  60. static value_header_ptr and_factors(value_header_ptr,value_header_ptr);
  61. static value_header_ptr atan_header_ptr(queue_node_ptr,char *,int);
  62. static value_header_ptr boolean_comparison(value_header_ptr,char *,
  63.                          value_header_ptr);
  64. static value_header_ptr char_header_ptr(queue_node_ptr,char *,int);
  65. static value_header_ptr concatenate_terms(value_header_ptr,value_header_ptr);
  66. static value_header_ptr copy_of_arguments(value_header_ptr);
  67. static queue_node_ptr   copy_of_queue(queue_node_ptr);
  68. static value_header_ptr copy_of_subscripts(value_header_ptr);
  69. static value_header_ptr cos_header_ptr(queue_node_ptr,char *,int);
  70. static value_header_ptr dataset_comparison(value_header_ptr,char *,
  71.                          value_header_ptr);
  72. static value_header_ptr date_header_ptr(queue_node_ptr,char *,int);
  73. static value_header_ptr divide_factors(value_header_ptr,value_header_ptr);
  74. static value_header_ptr endfile_header_ptr(queue_node_ptr,char *,int);
  75. static value_header_ptr exec_header_ptr(queue_node_ptr,char *,int);
  76. static value_header_ptr exp_header_ptr(queue_node_ptr,char *,int);
  77. static value_header_ptr factor_header_ptr(int);
  78. static value_header_ptr false_header_ptr(queue_node_ptr,char *,int);
  79. static value_header_ptr float_header_ptr(queue_node_ptr,char *,int);
  80. static void             free_value(value_header_ptr);
  81. static void             free_variables(void);
  82. static value_header_ptr function_header_ptr(int);
  83. static void             get_comparison_operator(char *);
  84. static void             get_factor_operator(char *);
  85. static value_header_ptr getchar_header_ptr(queue_node_ptr,char *,int);
  86. static value_header_ptr getint_header_ptr(queue_node_ptr,char *,int);
  87. static value_header_ptr getreal_header_ptr(queue_node_ptr,char *,int);
  88. static value_header_ptr getstring_header_ptr(queue_node_ptr,char *,int);
  89. static void             get_source_char(void);
  90. static void             get_term_operator(char *);
  91. static void             get_token(void);
  92. static value_header_ptr index_header_ptr(queue_node_ptr,char *,int);
  93. static value_header_ptr integer_comparison(value_header_ptr,char *,
  94.                          value_header_ptr);
  95. static void             interpret_assignment(int,queue_node_ptr);
  96. static void             interpret_do(int);
  97. static value_header_ptr interpret_expression(int);
  98. static void             interpret_if(int);
  99. static void             interpret_procedure(int,queue_node_ptr);
  100. static void             interpret_statement(int);
  101. static value_header_ptr length_header_ptr(queue_node_ptr,char *,int);
  102. static value_header_ptr lineno_header_ptr(queue_node_ptr,char *,int);
  103. static value_header_ptr log_header_ptr(queue_node_ptr,char *,int);
  104.        int              main(int,char **);
  105. static value_header_ptr mod_header_ptr(queue_node_ptr,char *,int);
  106. static value_header_ptr multiply_factors(value_header_ptr,value_header_ptr);
  107. static value_header_ptr new_boolean_header_ptr(void);
  108. static value_header_ptr new_dataset_header_ptr(void);
  109. static value_header_ptr new_integer_header_ptr(void);
  110. static value_header_ptr new_real_header_ptr(void);
  111. static value_header_ptr new_string_header_ptr(unsigned);
  112. static value_header_ptr open_header_ptr(queue_node_ptr,char *,int);
  113. static value_header_ptr or_terms(value_header_ptr,value_header_ptr);
  114. static value_header_ptr ord_header_ptr(queue_node_ptr,char *,int);
  115. static void             perform_close(int,queue_node_ptr);
  116. static void             perform_clrscr(int,queue_node_ptr);
  117. static void             perform_pliretc(int,queue_node_ptr);
  118. static void             perform_print(int,queue_node_ptr);
  119. static void             perform_putcrlf(int,queue_node_ptr);
  120. static void             perform_troff(int,queue_node_ptr);
  121. static void             perform_tron(int,queue_node_ptr);
  122. static value_header_ptr pi_header_ptr(queue_node_ptr,char *,int);
  123. static int              pli_strcmp(text_ptr,text_ptr);
  124. static void             pli_strcpy(text_ptr,text_ptr);
  125. static value_header_ptr pliretv_header_ptr(queue_node_ptr,char *,int);
  126. static value_header_ptr real_comparison(value_header_ptr,char *,
  127.                          value_header_ptr);
  128. static value_header_ptr repeat_header_ptr(queue_node_ptr,char *,int);
  129. static value_header_ptr simple_expression_header_ptr(int);
  130. static value_header_ptr sin_header_ptr(queue_node_ptr,char *,int);
  131. static value_header_ptr sqr_header_ptr(queue_node_ptr,char *,int);
  132. static value_header_ptr sqrt_header_ptr(queue_node_ptr,char *,int);
  133. static value_header_ptr str_header_ptr(queue_node_ptr,char *,int);
  134. static value_header_ptr string_comparison(value_header_ptr,char *,
  135.                          value_header_ptr);
  136. static value_header_ptr string_header_ptr(int);
  137. static value_header_ptr substr_header_ptr(queue_node_ptr,char *,int);
  138. static value_header_ptr subtract_terms(value_header_ptr,value_header_ptr);
  139. static value_header_ptr sysin_header_ptr(queue_node_ptr,char *,int);
  140. static value_header_ptr sysprint_header_ptr(queue_node_ptr,char *,int);
  141. static value_header_ptr term_header_ptr(int);
  142. static value_header_ptr time_header_ptr(queue_node_ptr,char *,int);
  143. static value_header_ptr translate_header_ptr(queue_node_ptr,char *,int);
  144. static long             tree_balancer(long);
  145. static value_header_ptr true_header_ptr(queue_node_ptr,char *,int);
  146. static value_header_ptr trunc_header_ptr(queue_node_ptr,char *,int);
  147. static value_header_ptr unsigned_integer_header_ptr(void);
  148. static value_header_ptr unsigned_number_header_ptr(int);
  149. static value_header_ptr upper_header_ptr(queue_node_ptr,char *,int);
  150. static int              variable_comparison(char *,queue_node_ptr,char *,
  151.                          queue_node_ptr);
  152. static value_header_ptr variable_header_ptr(char *,int,queue_node_ptr);
  153. static value_header_ptr verify_header_ptr(queue_node_ptr,char *,int);
  154.  
  155. static int          fatal_error;
  156. static char         identifier [256];
  157. static char         page [page_size];
  158. static int          page_index;
  159. static long         page_num;
  160. static int          return_code;
  161. static char         source_char;
  162. static long         source_column_num;
  163. static int          source_eof;
  164. FILE                *source_file;
  165. static long         source_index;
  166. static long         source_line_num;
  167. static char         source_token [256];
  168. static unsigned char substitute [256] =
  169.          {
  170.            0x8d,0x8f,0x47,0xba,0xcc,0x12,0x09,0x74,
  171.            0xcb,0xf3,0xb4,0x88,0xf8,0xd1,0x08,0x4c,
  172.            0xa1,0x32,0x48,0x98,0xbd,0xaa,0xea,0xa2,
  173.            0x28,0xbc,0x66,0xe8,0xf4,0x5a,0x83,0x46,
  174.            0xa4,0x0e,0x3b,0x3e,0x14,0x4d,0x1c,0x0a,
  175.            0x92,0xfd,0x79,0xa8,0x67,0x41,0xe3,0x70,
  176.            0xc2,0x56,0xdd,0x6c,0xbb,0x38,0x17,0xc1,
  177.            0xae,0xb7,0x60,0x43,0x9e,0x34,0x22,0x7b,
  178.            0xe6,0x61,0x54,0xa0,0x00,0xcf,0xd0,0x64,
  179.            0xab,0x93,0xb6,0x86,0xee,0xdb,0x8e,0xb8,
  180.            0x6f,0xb2,0x57,0xd5,0xe9,0x85,0x0d,0x5d,
  181.            0x18,0xd9,0x82,0x6e,0x94,0x2b,0xb1,0xda,
  182.            0x2d,0x0f,0x90,0xed,0xde,0x95,0x4b,0xf1,
  183.            0x3d,0x3c,0x6b,0x2a,0xc9,0x21,0xfc,0xdf,
  184.            0x16,0x3a,0x9d,0x7f,0x37,0xbf,0xc7,0x9a,
  185.            0x25,0x49,0x0c,0xb9,0x91,0x03,0x97,0x35,
  186.            0x39,0x2c,0x63,0x62,0x1e,0x73,0x7e,0xa3,
  187.            0x45,0x71,0x44,0x40,0x9f,0xe2,0x13,0x3f,
  188.            0x68,0xc6,0xc4,0xfa,0x4a,0x07,0x58,0x23,
  189.            0xa5,0x4e,0x27,0x10,0x7c,0xd2,0x84,0x26,
  190.            0x76,0xac,0x55,0xad,0x5e,0xe7,0x5b,0x04,
  191.            0xd4,0xd7,0x89,0x96,0x0b,0x72,0xff,0xca,
  192.            0xc0,0x6a,0x8a,0xfe,0x5c,0x99,0x01,0xd6,
  193.            0x1f,0xdc,0xa7,0x78,0xf6,0x50,0x1b,0xe5,
  194.            0xec,0x42,0x8b,0x36,0xcd,0x75,0x59,0x30,
  195.            0x1d,0xe1,0x2e,0xbe,0x77,0xc5,0xb3,0xf2,
  196.            0x11,0x52,0x53,0xe4,0x87,0x15,0x2f,0xf5,
  197.            0x1a,0xb0,0x5f,0x9c,0xa6,0x69,0x05,0x7a,
  198.            0xf7,0x6d,0xb5,0x24,0x81,0x80,0x9b,0xce,
  199.            0x33,0xf9,0x65,0x19,0xeb,0xd3,0x31,0xef,
  200.            0x20,0xf0,0x51,0x7d,0xa9,0x8c,0x02,0xaf,
  201.            0x29,0xc3,0xc8,0xe0,0xfb,0xd8,0x4f,0x06
  202.          };
  203. static int          trace;
  204. static variable_ptr variable_head;
  205.  
  206. int main(argc,argv)
  207.  int  argc;
  208.  char *argv[];
  209.   {
  210.     int arg_index;
  211.  
  212.     fatal_error=FALSE;
  213.     return_code=0;
  214.     trace=FALSE;
  215.     if (argc >= 2)
  216.       if ((source_file=fopen(argv[1],"rb")) == NULL)
  217.         {
  218.           fatal_error=TRUE;
  219.           printf("Fatal error:  cannot open %s for input.\n",argv[1]);
  220.         }
  221.       else
  222.         {
  223.           source_char=' ';
  224.           source_eof=FALSE;
  225.           source_line_num=(long) 1;
  226.           source_column_num=(long) 0;
  227.           page_index=page_size;
  228.           page_num=(long) -1;
  229.           variable_head=NULL;
  230.           arg_index=1;
  231.           add_argc(argc-1);
  232.           while ((! fatal_error) && (arg_index < argc))
  233.             {
  234.               add_argv(arg_index,argv[arg_index]);
  235.               arg_index++;
  236.             }
  237.           while ((! source_eof) && (! fatal_error))
  238.             {
  239.               get_token();
  240.               if (source_token[0] != ' ')
  241.                 interpret_statement(TRUE);
  242.             }
  243.           fclose(source_file);
  244.           free_variables();
  245.         }
  246.     else
  247.       {
  248.         fatal_error=TRUE;
  249.         printf("RUN interprets PL/I-like statements.\n\n");
  250.         printf("  Usage:  RUN <source file>\n");
  251.         printf("Example:  RUN C:\\USER\\WORK\\RUN.INP\n");
  252.       }
  253.     if (fatal_error)
  254.       return_code=2000;
  255.     return(return_code);
  256.   }
  257.  
  258. static void add_argc(argc)
  259.   int  argc;
  260.     {
  261.       if ((variable_head=(struct variable *)
  262.        malloc((unsigned) sizeof(struct variable))) == NULL)
  263.         {
  264.           fatal_error=TRUE;
  265.           printf("Fatal error:  out of memory at ");
  266.           printf("line %ld, column %ld.\n",
  267.            source_line_num,source_column_num);
  268.         }
  269.       if (! fatal_error)
  270.         {
  271.           if (((*variable_head).name=malloc((unsigned) 5)) == NULL)
  272.             {
  273.               fatal_error=TRUE;
  274.               printf("Fatal error:  out of memory at ");
  275.               printf("line %ld, column %ld.\n",
  276.                source_line_num,source_column_num);
  277.               free((char *) variable_head);
  278.               variable_head=NULL;
  279.             }
  280.         }
  281.       if (! fatal_error)
  282.         {
  283.           strcpy((*variable_head).name,"ARGC");
  284.           (*variable_head).subscripts=NULL;
  285.           if (((*variable_head).variable_value_header_ptr
  286.            =(struct value_header *)
  287.            malloc((unsigned) sizeof(struct value_header)))
  288.            == NULL)
  289.             {
  290.               fatal_error=TRUE;
  291.               printf("Fatal error:  out of memory at ");
  292.               printf("line %ld, column %ld.\n",
  293.                source_line_num,source_column_num);
  294.               free((*variable_head).name);
  295.               free((char *) variable_head);
  296.               variable_head=NULL;
  297.             }
  298.         }
  299.       if (! fatal_error)
  300.         {
  301.           (*((*variable_head).variable_value_header_ptr)).
  302.            type='I';
  303.           if (((*((*variable_head).variable_value_header_ptr)).
  304.            value_ptr.integer=(long *)
  305.            malloc((unsigned) sizeof(long))) == NULL)
  306.             {
  307.               fatal_error=TRUE;
  308.               printf("Fatal error:  out of memory at ");
  309.               printf("line %ld, column %ld.\n",
  310.                source_line_num,source_column_num);
  311.               free((char *)
  312.                (*variable_head).variable_value_header_ptr);
  313.               free((*variable_head).name);
  314.               free((char *) variable_head);
  315.               variable_head=NULL;
  316.             }
  317.         }
  318.       if (! fatal_error)
  319.         {
  320.           *((*((*variable_head).variable_value_header_ptr)).
  321.            value_ptr.integer)=(long) argc;
  322.           (*variable_head).predecessor_ptr=NULL;
  323.           (*variable_head).smaller_successor_ptr=NULL;
  324.           (*variable_head).larger_successor_ptr=NULL;
  325.         }
  326.       return;
  327.     }
  328.  
  329. static void add_argv(arg_index,arg)
  330.   int  arg_index;
  331.   char *arg;
  332.     {
  333.       int              comparison;
  334.       int              finished;
  335.       variable_ptr     new_variable_ptr;
  336.       variable_ptr     old_variable_ptr;
  337.  
  338.       if ((new_variable_ptr=(struct variable *)
  339.        malloc((unsigned) sizeof(struct variable)))
  340.        == NULL)
  341.         {
  342.           fatal_error=TRUE;
  343.           printf("Fatal error:  out of memory at ");
  344.           printf("line %ld, column %ld.\n",
  345.           source_line_num,source_column_num);
  346.         }
  347.       if (! fatal_error)
  348.         {
  349.           if (((*new_variable_ptr).name=malloc((unsigned) 5)) == NULL)
  350.             {
  351.               fatal_error=TRUE;
  352.               printf("Fatal error:  out of memory at ");
  353.               printf("line %ld, column %ld.\n",
  354.                source_line_num,source_column_num);
  355.               free((char *) variable_head);
  356.               variable_head=NULL;
  357.             }
  358.         }
  359.       if (! fatal_error)
  360.         {
  361.           strcpy((*new_variable_ptr).name,"ARGV");
  362.           if (((*new_variable_ptr).subscripts=(struct queue_node *)
  363.            malloc((unsigned) sizeof(struct queue_node))) == NULL)
  364.             {
  365.               fatal_error=TRUE;
  366.               printf("Fatal error:  out of memory at ");
  367.               printf("line %ld, column %ld.\n",
  368.                source_line_num,source_column_num);
  369.               free((*new_variable_ptr).name);
  370.               free((char *) new_variable_ptr);
  371.               new_variable_ptr=NULL;
  372.             }
  373.         }
  374.       if (! fatal_error)
  375.         {
  376.           (*((*new_variable_ptr).subscripts)).next=NULL;
  377.           if (((*((*new_variable_ptr).subscripts)).
  378.            argument_header_ptr=(struct value_header *)
  379.            malloc((unsigned) sizeof(struct value_header))) == NULL)
  380.             {
  381.               fatal_error=TRUE;
  382.               printf("Fatal error:  out of memory at ");
  383.               printf("line %ld, column %ld.\n",
  384.                source_line_num,source_column_num);
  385.               free((char *) (*new_variable_ptr).subscripts);
  386.               free((*new_variable_ptr).name);
  387.               free((char *) new_variable_ptr);
  388.               new_variable_ptr=NULL;
  389.             }
  390.         }
  391.       if (! fatal_error)
  392.         {
  393.           (*((*((*new_variable_ptr).subscripts)).
  394.            argument_header_ptr)).type='I';
  395.           if (((*((*((*new_variable_ptr).subscripts)).
  396.            argument_header_ptr)).value_ptr.integer=(long *)
  397.            malloc((unsigned) sizeof(long))) == NULL)
  398.             {
  399.               fatal_error=TRUE;
  400.               printf("Fatal error:  out of memory at ");
  401.               printf("line %ld, column %ld.\n",
  402.                source_line_num,source_column_num);
  403.               free((char *)
  404.                (*((*new_variable_ptr).subscripts)).argument_header_ptr);
  405.               free((char *) (*new_variable_ptr).subscripts);
  406.               free((*new_variable_ptr).name);
  407.               free((char *) new_variable_ptr);
  408.               new_variable_ptr=NULL;
  409.             }
  410.         }
  411.       if (! fatal_error)
  412.         {
  413.           *((*((*((*new_variable_ptr).subscripts)).
  414.            argument_header_ptr)).value_ptr.integer)
  415.            =tree_balancer((long) arg_index);
  416.           if (((*new_variable_ptr).variable_value_header_ptr
  417.            =(struct value_header *)
  418.            malloc((unsigned) sizeof(struct value_header))) == NULL)
  419.             {
  420.               fatal_error=TRUE;
  421.               printf("Fatal error:  out of memory at ");
  422.               printf("line %ld, column %ld.\n",
  423.                source_line_num,source_column_num);
  424.               free((char *)
  425.                (*((*((*new_variable_ptr).subscripts)).
  426.                argument_header_ptr)).value_ptr.integer);
  427.               free((char *)
  428.                (*((*new_variable_ptr).subscripts)).argument_header_ptr);
  429.               free((char *) (*new_variable_ptr).subscripts);
  430.               free((*new_variable_ptr).name);
  431.               free((char *) new_variable_ptr);
  432.               new_variable_ptr=NULL;
  433.             }
  434.         }
  435.       if (! fatal_error)
  436.         {
  437.           (*((*new_variable_ptr).
  438.            variable_value_header_ptr)).type='S';
  439.           if (((*((*new_variable_ptr).variable_value_header_ptr)).
  440.            value_ptr.string=(struct text *)
  441.            malloc((unsigned) sizeof(struct text))) == NULL)
  442.             {
  443.               fatal_error=TRUE;
  444.               printf("Fatal error:  out of memory at ");
  445.               printf("line %ld, column %ld.\n",
  446.                source_line_num,source_column_num);
  447.               free((char *)
  448.                (*new_variable_ptr).
  449.                variable_value_header_ptr);
  450.               free((char *)
  451.                (*((*((*new_variable_ptr).subscripts)).
  452.                argument_header_ptr)).value_ptr.integer);
  453.               free((char *)
  454.                (*((*new_variable_ptr).subscripts)).argument_header_ptr);
  455.               free((char *) (*new_variable_ptr).subscripts);
  456.               free((*new_variable_ptr).name);
  457.               free((char *) new_variable_ptr);
  458.               new_variable_ptr=NULL;
  459.             }
  460.         }
  461.       if (! fatal_error)
  462.         {
  463.           (*((*((*new_variable_ptr).
  464.            variable_value_header_ptr)).
  465.            value_ptr.string)).length=strlen(arg);
  466.           if (((*((*((*new_variable_ptr).
  467.            variable_value_header_ptr)).value_ptr.string)).value=
  468.            malloc((unsigned) 1+strlen(arg))) == NULL)
  469.             {
  470.               fatal_error=TRUE;
  471.               printf("Fatal error:  out of memory at ");
  472.               printf("line %ld, column %ld.\n",
  473.                source_line_num,source_column_num);
  474.               free((char *) (*((*new_variable_ptr).
  475.                variable_value_header_ptr)).value_ptr.string);
  476.               free((char *)
  477.                (*new_variable_ptr).variable_value_header_ptr);
  478.               free((char *)
  479.                (*((*((*new_variable_ptr).subscripts)).
  480.                argument_header_ptr)).value_ptr.integer);
  481.               free((char *)
  482.                (*((*new_variable_ptr).subscripts)).argument_header_ptr);
  483.               free((char *) (*new_variable_ptr).subscripts);
  484.               free((*new_variable_ptr).name);
  485.               free((char *) new_variable_ptr);
  486.               new_variable_ptr=NULL;
  487.             }
  488.         }
  489.       if (! fatal_error)
  490.         {
  491.           strcpy((*((*((*new_variable_ptr).
  492.            variable_value_header_ptr)).value_ptr.string)).value,arg);
  493.         }
  494.       if (! fatal_error)
  495.         {
  496.           if (variable_head == NULL)
  497.             {
  498.               variable_head=new_variable_ptr;
  499.               (*variable_head).predecessor_ptr=NULL;
  500.               (*variable_head).smaller_successor_ptr=NULL;
  501.               (*variable_head).larger_successor_ptr=NULL;
  502.             }
  503.           else
  504.             {
  505.               old_variable_ptr=variable_head;
  506.               finished=FALSE;
  507.               do
  508.                 {
  509.                   comparison=variable_comparison((*new_variable_ptr).name,
  510.                    (*new_variable_ptr).subscripts,(*old_variable_ptr).name,
  511.                    (*old_variable_ptr).subscripts);
  512.                   if (comparison < 0)
  513.                     if ((*old_variable_ptr).smaller_successor_ptr == NULL)
  514.                       {
  515.                         (*new_variable_ptr).predecessor_ptr
  516.                          =old_variable_ptr;
  517.                         (*new_variable_ptr).
  518.                          smaller_successor_ptr=NULL;
  519.                         (*new_variable_ptr).
  520.                          larger_successor_ptr=NULL;
  521.                         (*old_variable_ptr).
  522.                          smaller_successor_ptr
  523.                          =new_variable_ptr;
  524.                         finished=TRUE;
  525.                       }
  526.                     else
  527.                       old_variable_ptr
  528.                        =(*old_variable_ptr).smaller_successor_ptr;
  529.                   else
  530.                     if ((*old_variable_ptr).larger_successor_ptr
  531.                      == NULL)
  532.                       {
  533.                         (*new_variable_ptr).predecessor_ptr
  534.                          =old_variable_ptr;
  535.                         (*new_variable_ptr).
  536.                          smaller_successor_ptr=NULL;
  537.                         (*new_variable_ptr).
  538.                          larger_successor_ptr=NULL;
  539.                         (*old_variable_ptr).
  540.                          larger_successor_ptr
  541.                          =new_variable_ptr;
  542.                         finished=TRUE;
  543.                       }
  544.                     else
  545.                       old_variable_ptr
  546.                        =(*old_variable_ptr).larger_successor_ptr;
  547.                 }
  548.               while (! finished);
  549.             }
  550.         }
  551.       return;
  552.     }
  553.  
  554. static void free_variables()
  555.   {
  556.     int            bypass_smaller_name;
  557.     variable_ptr   current_ptr;
  558.     int            finished;
  559.     int            larger_predecessor_found;
  560.     queue_node_ptr new_queue_head;
  561.     variable_ptr   previous_ptr;
  562.     queue_node_ptr queue_head;
  563.  
  564.     if (variable_head != NULL)
  565.       {
  566.         current_ptr=variable_head;
  567.         finished=FALSE;
  568.         bypass_smaller_name=FALSE;
  569.         do
  570.           {
  571.             if (! bypass_smaller_name)
  572.               while ((*current_ptr).smaller_successor_ptr != NULL)
  573.                 current_ptr=(*current_ptr).smaller_successor_ptr;
  574.             free_value((*current_ptr).variable_value_header_ptr);
  575.             if ((*current_ptr).larger_successor_ptr != NULL)
  576.               {
  577.                 current_ptr=(*current_ptr).larger_successor_ptr;
  578.                 bypass_smaller_name=FALSE;
  579.               }
  580.             else
  581.               {
  582.                 larger_predecessor_found=FALSE;
  583.                 do
  584.                   {
  585.                     if ((*current_ptr).predecessor_ptr == NULL)
  586.                       finished=TRUE;
  587.                     else
  588.                       {
  589.                         previous_ptr=current_ptr;
  590.                         current_ptr=(*previous_ptr).predecessor_ptr;
  591.                         if (variable_comparison((*current_ptr).name,
  592.                          (*current_ptr).subscripts,(*previous_ptr).name,
  593.                          (*previous_ptr).subscripts) > 0)
  594.                           larger_predecessor_found=TRUE;
  595.                         free((*previous_ptr).name);
  596.                         queue_head=(*previous_ptr).subscripts;
  597.                         while (queue_head != NULL)
  598.                           {
  599.                             new_queue_head=(*queue_head).next;
  600.                             free_value((*queue_head).argument_header_ptr);
  601.                             free((char *) queue_head);
  602.                             queue_head=new_queue_head;
  603.                           }
  604.                         free((char *) previous_ptr);
  605.                       }
  606.                   }
  607.                while ((! finished) && (! larger_predecessor_found));
  608.                bypass_smaller_name=TRUE;
  609.               }
  610.           }
  611.         while (! finished);
  612.         free((*variable_head).name);
  613.         queue_head=(*variable_head).subscripts;
  614.         while (queue_head != NULL)
  615.           {
  616.             new_queue_head=(*queue_head).next;
  617.             free_value((*queue_head).argument_header_ptr);
  618.             free((char *) queue_head);
  619.             queue_head=new_queue_head;
  620.           }
  621.         free((char *) variable_head);
  622.       }
  623.     return;
  624.   }
  625.  
  626. static void get_source_char()
  627.   {
  628.     static int char_count;
  629.  
  630.     if (source_eof)
  631.       source_char=' ';
  632.     else
  633.       {
  634.         do
  635.           {
  636.             if (page_index >= page_size)
  637.               {
  638.                 char_count=fread(&page[0],1,page_size,source_file);
  639.                 if (char_count < page_size)
  640.                   page[char_count]=(char) 26;
  641.                 page_num++;
  642.                 page_index=0;
  643.               }
  644.             source_char=page[page_index];
  645.             page_index++;
  646.             if (source_char != (char) 26)
  647.               {
  648.                 if (source_char == (char) 13)
  649.                   {
  650.                     source_line_num++;
  651.                     source_column_num=(long) 0;
  652.                   }
  653.                 else
  654.                   {
  655.                     if (source_char != (char) 10)
  656.                       source_column_num++;
  657.                   }
  658.               }
  659.           }
  660.         while ((source_char != (char) 26)
  661.         &&     ((source_char == (char) 13) || (source_char == (char) 10)));
  662.         source_eof=(source_char == (char) 26);
  663.         if (source_eof) source_char=' ';
  664.       }
  665.     return;
  666.   }
  667.  
  668. static void get_token()
  669.   {
  670.     register int  token_index;
  671.  
  672.     while ((source_char == ' ')
  673.     &&     (! source_eof))
  674.       get_source_char();
  675.     if (isalpha((int) source_char))
  676.       {
  677.         token_index=0;
  678.         while ((isalnum((int) source_char) || (source_char == '_'))
  679.         &&     (! source_eof))
  680.           {
  681.             if (token_index < 255)
  682.               source_token[token_index++]=(char) toupper((int) source_char);
  683.             get_source_char();
  684.           }
  685.         source_token[token_index]='\0';
  686.       }
  687.     else
  688.       {
  689.         source_token[0]=source_char;
  690.         source_token[1]='\0';
  691.         get_source_char();
  692.       }
  693.     return;
  694.   }
  695.  
  696. static void free_value(header_ptr)
  697.   value_header_ptr header_ptr;
  698.     {
  699.       if (header_ptr != NULL)
  700.         {
  701.           switch ((*header_ptr).type)
  702.             {
  703.               case 'B':
  704.                 free((char *) (*header_ptr).value_ptr.boolean);
  705.                 break;
  706.               case 'D':
  707.                 free((char *) (*header_ptr).value_ptr.dataset);
  708.                 break;
  709.               case 'I':
  710.                 free((char *) (*header_ptr).value_ptr.integer);
  711.                 break;
  712.               case 'R':
  713.                 free((char *) (*header_ptr).value_ptr.real);
  714.                 break;
  715.               default:
  716.                 free((*((*header_ptr).value_ptr.string)).value);
  717.                 free((char *) (*header_ptr).value_ptr.string);
  718.                 break;
  719.             }
  720.          free((char *) header_ptr);
  721.         }
  722.       return;
  723.     }
  724.  
  725. static value_header_ptr new_boolean_header_ptr()
  726.   {
  727.     value_header_ptr result_header_ptr;
  728.  
  729.     if ((result_header_ptr=(struct value_header *)
  730.      malloc((unsigned) sizeof(struct value_header))) == NULL)
  731.       {
  732.         fatal_error=TRUE;
  733.         result_header_ptr=NULL;
  734.         printf("Fatal error:  out of memory at ");
  735.         printf("line %ld, column %ld.\n",
  736.          source_line_num,source_column_num);
  737.       }
  738.     else
  739.       {
  740.         (*result_header_ptr).type='B';
  741.         if (((*result_header_ptr).value_ptr.boolean=(int *)
  742.          malloc((unsigned) sizeof(int))) == NULL)
  743.           {
  744.             fatal_error=TRUE;
  745.             free((char *) result_header_ptr);
  746.             result_header_ptr=NULL;
  747.             printf("Fatal error:  out of memory at ");
  748.             printf("line %ld, column %ld.\n",
  749.              source_line_num,source_column_num);
  750.           }
  751.         else
  752.           *((*result_header_ptr).value_ptr.boolean)=TRUE;
  753.       }
  754.     return(result_header_ptr);
  755.   }
  756.  
  757. static value_header_ptr new_dataset_header_ptr()
  758.   {
  759.     value_header_ptr result_header_ptr;
  760.  
  761.     if ((result_header_ptr=(struct value_header *)
  762.      malloc((unsigned) sizeof(struct value_header))) == NULL)
  763.       {
  764.         fatal_error=TRUE;
  765.         result_header_ptr=NULL;
  766.         printf("Fatal error:  out of memory at ");
  767.         printf("line %ld, column %ld.\n",
  768.          source_line_num,source_column_num);
  769.       }
  770.     else
  771.       {
  772.         (*result_header_ptr).type='D';
  773.         if (((*result_header_ptr).value_ptr.dataset=(FILE **)
  774.          malloc((unsigned) sizeof(FILE *))) == NULL)
  775.           {
  776.             fatal_error=TRUE;
  777.             free((char *) result_header_ptr);
  778.             result_header_ptr=NULL;
  779.             printf("Fatal error:  out of memory at ");
  780.             printf("line %ld, column %ld.\n",
  781.              source_line_num,source_column_num);
  782.           }
  783.         else
  784.           *((*result_header_ptr).value_ptr.dataset)=NULL;
  785.       }
  786.     return(result_header_ptr);
  787.   }
  788.  
  789. static value_header_ptr new_integer_header_ptr()
  790.   {
  791.     value_header_ptr result_header_ptr;
  792.  
  793.     if ((result_header_ptr=(struct value_header *)
  794.      malloc((unsigned) sizeof(struct value_header))) == NULL)
  795.       {
  796.         fatal_error=TRUE;
  797.         result_header_ptr=NULL;
  798.         printf("Fatal error:  out of memory at ");
  799.         printf("line %ld, column %ld.\n",
  800.          source_line_num,source_column_num);
  801.       }
  802.     else
  803.       {
  804.         (*result_header_ptr).type='I';
  805.         if (((*result_header_ptr).value_ptr.integer=(long *)
  806.          malloc((unsigned) sizeof(long))) == NULL)
  807.           {
  808.             fatal_error=TRUE;
  809.             free((char *) result_header_ptr);
  810.             result_header_ptr=NULL;
  811.             printf("Fatal error:  out of memory at ");
  812.             printf("line %ld, column %ld.\n",
  813.              source_line_num,source_column_num);
  814.           }
  815.         else
  816.           *((*result_header_ptr).value_ptr.integer)=0;
  817.       }
  818.     return(result_header_ptr);
  819.   }
  820.  
  821. static value_header_ptr new_real_header_ptr()
  822.   {
  823.     value_header_ptr result_header_ptr;
  824.  
  825.     if ((result_header_ptr=(struct value_header *)
  826.      malloc((unsigned) sizeof(struct value_header))) == NULL)
  827.       {
  828.         fatal_error=TRUE;
  829.         result_header_ptr=NULL;
  830.         printf("Fatal error:  out of memory at ");
  831.         printf("line %ld, column %ld.\n",
  832.          source_line_num,source_column_num);
  833.       }
  834.     else
  835.       {
  836.         (*result_header_ptr).type='R';
  837.         if (((*result_header_ptr).value_ptr.real=(double *)
  838.          malloc((unsigned) sizeof(double))) == NULL)
  839.           {
  840.             fatal_error=TRUE;
  841.             free((char *) result_header_ptr);
  842.             result_header_ptr=NULL;
  843.             printf("Fatal error:  out of memory at ");
  844.             printf("line %ld, column %ld.\n",
  845.              source_line_num,source_column_num);
  846.           }
  847.         else
  848.           *((*result_header_ptr).value_ptr.real)=0.0;
  849.       }
  850.     return(result_header_ptr);
  851.   }
  852.  
  853. static value_header_ptr new_string_header_ptr(string_length)
  854.   unsigned string_length;
  855.     {
  856.       value_header_ptr result_header_ptr;
  857.  
  858.       if (string_length > (unsigned) 32767)
  859.         {
  860.           fatal_error=TRUE;
  861.           result_header_ptr=NULL;
  862.           printf(
  863.         "Fatal error:  string length exceeds 32767 at line %ld, column %ld.\n",
  864.            source_line_num,source_column_num);
  865.         }
  866.       else
  867.         if ((result_header_ptr=(struct value_header *)
  868.          malloc((unsigned) sizeof(struct value_header))) == NULL)
  869.           {
  870.             fatal_error=TRUE;
  871.             result_header_ptr=NULL;
  872.             printf("Fatal error:  out of memory at ");
  873.             printf("line %ld, column %ld.\n",
  874.              source_line_num,source_column_num);
  875.           }
  876.         else
  877.           {
  878.             (*result_header_ptr).type='S';
  879.             if (((*result_header_ptr).value_ptr.string=(struct text *)
  880.              malloc((unsigned) sizeof(struct text))) == NULL)
  881.               {
  882.                 fatal_error=TRUE;
  883.                 result_header_ptr=NULL;
  884.                 printf("Fatal error:  out of memory at ");
  885.                 printf("line %ld, column %ld.\n",
  886.                  source_line_num,source_column_num);
  887.               }
  888.             else
  889.               {
  890.                 (*((*result_header_ptr).value_ptr.string)).length
  891.                  =string_length;
  892.                 if (((*((*result_header_ptr).value_ptr.string)).value=
  893.                  (unsigned char *) malloc((unsigned) (1+string_length)))
  894.                  == NULL)
  895.                   {
  896.                     fatal_error=TRUE;
  897.                     free((char *) result_header_ptr);
  898.                     result_header_ptr=NULL;
  899.                     printf("Fatal error:  out of memory at ");
  900.                     printf("line %ld, column %ld.\n",
  901.                      source_line_num,source_column_num);
  902.                   }
  903.                 else
  904.                   *((*((*result_header_ptr).value_ptr.string)).value)
  905.                    =(unsigned char) '\0';
  906.               }
  907.           }
  908.       return(result_header_ptr);
  909.     }
  910.  
  911. static int pli_strcmp(string_1,string_2)
  912.   text_ptr string_1;
  913.   text_ptr string_2;
  914.     {
  915.       unsigned char char_1;
  916.       unsigned char char_2;
  917.       register int  char_index;
  918.       unsigned char *char_ptr_1;
  919.       unsigned char *char_ptr_2;
  920.       int           length_1;
  921.       int           length_2;
  922.       int           result;
  923.  
  924.       result=0;
  925.       char_index=0;
  926.       char_ptr_1=(*string_1).value;
  927.       char_ptr_2=(*string_2).value;
  928.       length_1=(*string_1).length;
  929.       length_2=(*string_2).length;
  930.       while ((result == 0)
  931.       &&     (char_index < length_1)
  932.       &&     (char_index < length_2))
  933.          {
  934.            char_1=*char_ptr_1;
  935.            char_2=*char_ptr_2;
  936.            if (char_1 < char_2)
  937.              result=-1;
  938.            else
  939.              if (char_1 > char_2)
  940.                result=1;
  941.              else
  942.                {
  943.                  char_index++;
  944.                  char_ptr_1++;
  945.                  char_ptr_2++;
  946.                }
  947.         }
  948.       char_2=(unsigned char) ' ';
  949.       while ((result == 0)
  950.       &&     (char_index < length_1))
  951.         {
  952.           char_1=*char_ptr_1;
  953.           if (char_1 < char_2)
  954.             result=-1;
  955.           else
  956.             if (char_1 > char_2)
  957.               result=1;
  958.             else
  959.               {
  960.                 char_index++;
  961.                 char_ptr_1++;
  962.               }
  963.         }
  964.       char_1=(unsigned char) ' ';
  965.       while ((result == 0)
  966.       &&     (char_index < length_2))
  967.         {
  968.           char_2=*char_ptr_2;
  969.           if (char_1 < char_2)
  970.             result=-1;
  971.           else
  972.             if (char_1 > char_2)
  973.               result=1;
  974.             else
  975.               {
  976.                 char_index++;
  977.                 char_ptr_2++;
  978.               }
  979.         }
  980.       return(result);
  981.     }
  982.  
  983. static void pli_strcpy(string_1,string_2)
  984.   text_ptr string_1;
  985.   text_ptr string_2;
  986.     {
  987.       register int  char_index;
  988.       unsigned char *char_ptr_1;
  989.       unsigned char *char_ptr_2;
  990.       int           string_length;
  991.  
  992.       char_ptr_1=(*string_1).value;
  993.       char_ptr_2=(*string_2).value;
  994.       string_length=(*string_2).length;
  995.       for (char_index=0; char_index < string_length; char_index++)
  996.         {
  997.           *char_ptr_1=*char_ptr_2;
  998.           char_ptr_1++;
  999.           char_ptr_2++;
  1000.         }
  1001.       *char_ptr_1=(unsigned char) '\0';
  1002.       return;
  1003.     }
  1004.  
  1005. static value_header_ptr string_header_ptr(evaluate)
  1006.   int evaluate;
  1007.     {
  1008.       value_header_ptr new_result_header_ptr;
  1009.       value_header_ptr result_header_ptr;
  1010.       int              string_index;
  1011.       unsigned         string_length;
  1012.       int              string_terminated;
  1013.  
  1014.       string_index=-1;
  1015.       string_length=(unsigned) 0;
  1016.       result_header_ptr=new_string_header_ptr((unsigned) 0);
  1017.       string_terminated=FALSE;
  1018.       while ((! fatal_error) && (! string_terminated) && (! source_eof))
  1019.         {
  1020.           get_source_char();
  1021.           if (source_char == '\'')
  1022.             {
  1023.               get_source_char();
  1024.               if (source_char == '\'')
  1025.                 {
  1026.                   string_length++;
  1027.                   new_result_header_ptr=new_string_header_ptr(string_length);
  1028.                   if (! fatal_error)
  1029.                     {
  1030.                       pli_strcpy((*new_result_header_ptr).value_ptr.string,
  1031.                        (*result_header_ptr).value_ptr.string);
  1032.                       string_index++;
  1033.                       (*((*new_result_header_ptr).value_ptr.string)).value[
  1034.                        string_index]=(unsigned char) source_char;
  1035.                       (*((*new_result_header_ptr).value_ptr.string)).value[
  1036.                        string_length]=(unsigned char) '\0';
  1037.                       free_value(result_header_ptr);
  1038.                       result_header_ptr=new_result_header_ptr;
  1039.                     }
  1040.                 }
  1041.               else
  1042.                 string_terminated=TRUE;
  1043.             }
  1044.           else
  1045.             {
  1046.               string_length++;
  1047.               new_result_header_ptr=new_string_header_ptr(string_length);
  1048.               if (! fatal_error)
  1049.                 {
  1050.                   pli_strcpy((*new_result_header_ptr).value_ptr.string,
  1051.                    (*result_header_ptr).value_ptr.string);
  1052.                   string_index++;
  1053.                   (*((*new_result_header_ptr).value_ptr.string)).value[
  1054.                    string_index]=(unsigned char) source_char;
  1055.                   (*((*new_result_header_ptr).value_ptr.string)).value[
  1056.                    string_length]=(unsigned char) '\0';
  1057.                   free_value(result_header_ptr);
  1058.                   result_header_ptr=new_result_header_ptr;
  1059.                 }
  1060.             }
  1061.         }
  1062.       if (! evaluate)
  1063.         {
  1064.           free_value(result_header_ptr);
  1065.           result_header_ptr=NULL;
  1066.         }
  1067.       return(result_header_ptr);
  1068.     }
  1069.  
  1070. static long tree_balancer(argument)
  1071.   long argument;
  1072.     {
  1073.       union
  1074.         {
  1075.           struct
  1076.             {
  1077.               unsigned char number_1;
  1078.               unsigned char number_2;
  1079.               unsigned char number_3;
  1080.               unsigned char number_4;
  1081.             } byte;
  1082.           struct
  1083.             {
  1084.               unsigned int number_01 : 1;
  1085.               unsigned int number_02 : 1;
  1086.               unsigned int number_03 : 1;
  1087.               unsigned int number_04 : 1;
  1088.               unsigned int number_05 : 1;
  1089.               unsigned int number_06 : 1;
  1090.               unsigned int number_07 : 1;
  1091.               unsigned int number_08 : 1;
  1092.               unsigned int number_09 : 1;
  1093.               unsigned int number_10 : 1;
  1094.               unsigned int number_11 : 1;
  1095.               unsigned int number_12 : 1;
  1096.               unsigned int number_13 : 1;
  1097.               unsigned int number_14 : 1;
  1098.               unsigned int number_15 : 1;
  1099.               unsigned int number_16 : 1;
  1100.               unsigned int number_17 : 1;
  1101.               unsigned int number_18 : 1;
  1102.               unsigned int number_19 : 1;
  1103.               unsigned int number_20 : 1;
  1104.               unsigned int number_21 : 1;
  1105.               unsigned int number_22 : 1;
  1106.               unsigned int number_23 : 1;
  1107.               unsigned int number_24 : 1;
  1108.               unsigned int number_25 : 1;
  1109.               unsigned int number_26 : 1;
  1110.               unsigned int number_27 : 1;
  1111.               unsigned int number_28 : 1;
  1112.               unsigned int number_29 : 1;
  1113.               unsigned int number_30 : 1;
  1114.               unsigned int number_31 : 1;
  1115.               unsigned int number_32 : 1;
  1116.             } bit;
  1117.         } intermediate;
  1118.       union
  1119.         {
  1120.           long       signed_long;
  1121.           struct
  1122.             {
  1123.               unsigned char number_1;
  1124.               unsigned char number_2;
  1125.               unsigned char number_3;
  1126.               unsigned char number_4;
  1127.             } byte;
  1128.           struct
  1129.             {
  1130.               unsigned int number_01 : 1;
  1131.               unsigned int number_02 : 1;
  1132.               unsigned int number_03 : 1;
  1133.               unsigned int number_04 : 1;
  1134.               unsigned int number_05 : 1;
  1135.               unsigned int number_06 : 1;
  1136.               unsigned int number_07 : 1;
  1137.               unsigned int number_08 : 1;
  1138.               unsigned int number_09 : 1;
  1139.               unsigned int number_10 : 1;
  1140.               unsigned int number_11 : 1;
  1141.               unsigned int number_12 : 1;
  1142.               unsigned int number_13 : 1;
  1143.               unsigned int number_14 : 1;
  1144.               unsigned int number_15 : 1;
  1145.               unsigned int number_16 : 1;
  1146.               unsigned int number_17 : 1;
  1147.               unsigned int number_18 : 1;
  1148.               unsigned int number_19 : 1;
  1149.               unsigned int number_20 : 1;
  1150.               unsigned int number_21 : 1;
  1151.               unsigned int number_22 : 1;
  1152.               unsigned int number_23 : 1;
  1153.               unsigned int number_24 : 1;
  1154.               unsigned int number_25 : 1;
  1155.               unsigned int number_26 : 1;
  1156.               unsigned int number_27 : 1;
  1157.               unsigned int number_28 : 1;
  1158.               unsigned int number_29 : 1;
  1159.               unsigned int number_30 : 1;
  1160.               unsigned int number_31 : 1;
  1161.               unsigned int number_32 : 1;
  1162.             } bit;
  1163.         } result;
  1164.       register int round;
  1165.  
  1166.       result.signed_long=argument;
  1167.       for (round=1; round <= 8; round++)
  1168.         {
  1169.           intermediate.bit.number_01=result.bit.number_04;
  1170.           intermediate.bit.number_02=result.bit.number_29;
  1171.           intermediate.bit.number_03=result.bit.number_06;
  1172.           intermediate.bit.number_04=result.bit.number_09;
  1173.           intermediate.bit.number_05=result.bit.number_26;
  1174.           intermediate.bit.number_06=result.bit.number_25;
  1175.           intermediate.bit.number_07=result.bit.number_16;
  1176.           intermediate.bit.number_08=result.bit.number_15;
  1177.           intermediate.bit.number_09=result.bit.number_24;
  1178.           intermediate.bit.number_10=result.bit.number_31;
  1179.           intermediate.bit.number_11=result.bit.number_02;
  1180.           intermediate.bit.number_12=result.bit.number_18;
  1181.           intermediate.bit.number_13=result.bit.number_32;
  1182.           intermediate.bit.number_14=result.bit.number_03;
  1183.           intermediate.bit.number_15=result.bit.number_20;
  1184.           intermediate.bit.number_16=result.bit.number_30;
  1185.           intermediate.bit.number_17=result.bit.number_08;
  1186.           intermediate.bit.number_18=result.bit.number_27;
  1187.           intermediate.bit.number_19=result.bit.number_13;
  1188.           intermediate.bit.number_20=result.bit.number_11;
  1189.           intermediate.bit.number_21=result.bit.number_01;
  1190.           intermediate.bit.number_22=result.bit.number_17;
  1191.           intermediate.bit.number_23=result.bit.number_10;
  1192.           intermediate.bit.number_24=result.bit.number_05;
  1193.           intermediate.bit.number_25=result.bit.number_07;
  1194.           intermediate.bit.number_26=result.bit.number_14;
  1195.           intermediate.bit.number_27=result.bit.number_19;
  1196.           intermediate.bit.number_28=result.bit.number_23;
  1197.           intermediate.bit.number_29=result.bit.number_21;
  1198.           intermediate.bit.number_30=result.bit.number_28;
  1199.           intermediate.bit.number_31=result.bit.number_12;
  1200.           intermediate.bit.number_32=result.bit.number_22;
  1201.           result.byte.number_1=substitute[intermediate.byte.number_1];
  1202.           result.byte.number_2=substitute[intermediate.byte.number_2];
  1203.           result.byte.number_3=substitute[intermediate.byte.number_3];
  1204.           result.byte.number_4=substitute[intermediate.byte.number_4];
  1205.         }
  1206.       return(result.signed_long);
  1207.     }
  1208.  
  1209. static int variable_comparison(name_1,queue_head_1,name_2,queue_head_2)
  1210.   char           *name_1;
  1211.   queue_node_ptr queue_head_1;
  1212.   char           *name_2;
  1213.   queue_node_ptr queue_head_2;
  1214.     {
  1215.       int       boolean_1;
  1216.       int       boolean_2;
  1217.       union  {
  1218.                FILE *file_ptr;
  1219.                long address;
  1220.              }  dataset_1;
  1221.       union  {
  1222.                FILE *file_ptr;
  1223.                long address;
  1224.              }  dataset_2;
  1225.       long      integer_1;
  1226.       long      integer_2;
  1227.       double    real_1;
  1228.       double    real_2;
  1229.       int       result;
  1230.       char      type_1;
  1231.       char      type_2;
  1232.  
  1233.       result=strcmp(name_1,name_2);
  1234.       if (result == 0)
  1235.         {
  1236.           while ((result == 0)
  1237.           &&     (queue_head_1 != NULL)
  1238.           &&     (queue_head_2 != NULL))
  1239.             {
  1240.               type_1=(*((*queue_head_1).argument_header_ptr)).type;
  1241.               type_2=(*((*queue_head_2).argument_header_ptr)).type;
  1242.               if (type_1 < type_2)
  1243.                 result=-1;
  1244.               else
  1245.                 if (type_1 > type_2)
  1246.                   result=1;
  1247.                 else
  1248.                   switch (type_1)
  1249.                     {
  1250.                       case 'B':
  1251.                         boolean_1=*((*((*queue_head_1).argument_header_ptr)).
  1252.                          value_ptr.boolean);
  1253.                         boolean_2=*((*((*queue_head_2).argument_header_ptr)).
  1254.                          value_ptr.boolean);
  1255.                         if (boolean_1)
  1256.                           {
  1257.                             if (! boolean_2)
  1258.                               result=1;
  1259.                           }
  1260.                         else
  1261.                           {
  1262.                             if (boolean_2)
  1263.                               result=-1;
  1264.                           }
  1265.                         break;
  1266.                       case 'D':
  1267.                         dataset_1.file_ptr
  1268.                          =*((*((*queue_head_1).argument_header_ptr)).
  1269.                          value_ptr.dataset);
  1270.                         dataset_2.file_ptr
  1271.                          =*((*((*queue_head_2).argument_header_ptr)).
  1272.                          value_ptr.dataset);
  1273.                         if (dataset_1.address < dataset_2.address)
  1274.                           result=-1;
  1275.                         else
  1276.                           {
  1277.                             if (dataset_1.address > dataset_2.address)
  1278.                               result=1;
  1279.                           }
  1280.                         break;
  1281.                       case 'I':
  1282.                         integer_1=*((*((*queue_head_1).argument_header_ptr)).
  1283.                          value_ptr.integer);
  1284.                         integer_2=*((*((*queue_head_2).argument_header_ptr)).
  1285.                          value_ptr.integer);
  1286.                         if (integer_1 < integer_2)
  1287.                           result=-1;
  1288.                         else
  1289.                           {
  1290.                             if (integer_1 > integer_2)
  1291.                               result=1;
  1292.                           }
  1293.                         break;
  1294.                       case 'R':
  1295.                         real_1=*((*((*queue_head_1).argument_header_ptr)).
  1296.                          value_ptr.real);
  1297.                         real_2=*((*((*queue_head_2).argument_header_ptr)).
  1298.                          value_ptr.real);
  1299.                         if (real_1 < real_2)
  1300.                           result=-1;
  1301.                         else
  1302.                           {
  1303.                             if (real_1 > real_2)
  1304.                               result=1;
  1305.                           }
  1306.                         break;
  1307.                       default:
  1308.                         result=pli_strcmp(
  1309.                          (*((*queue_head_1).argument_header_ptr)).
  1310.                          value_ptr.string,
  1311.                          (*((*queue_head_2).argument_header_ptr)).
  1312.                          value_ptr.string);
  1313.                         break;
  1314.                     }
  1315.               queue_head_1=(*queue_head_1).next;
  1316.               queue_head_2=(*queue_head_2).next;
  1317.             }
  1318.           if (result == 0)
  1319.             {
  1320.               if (queue_head_1 == NULL)
  1321.                 {
  1322.                   if (queue_head_2 != NULL)
  1323.                     result=-1;
  1324.                 }
  1325.               else
  1326.                 {
  1327.                   if (queue_head_2 == NULL)
  1328.                     result=1;
  1329.                 }
  1330.             }
  1331.         }
  1332.       return(result);
  1333.     }
  1334.  
  1335. static value_header_ptr copy_of_arguments(argument_header_ptr)
  1336.  value_header_ptr argument_header_ptr;
  1337.   {
  1338.     value_header_ptr result_header_ptr;
  1339.  
  1340.     if (argument_header_ptr == NULL)
  1341.       result_header_ptr=NULL;
  1342.     else
  1343.       switch ((*argument_header_ptr).type)
  1344.         {
  1345.           case 'B':
  1346.             result_header_ptr=new_boolean_header_ptr();
  1347.             if (! fatal_error)
  1348.              *((*(result_header_ptr)).value_ptr.boolean)
  1349.               =*((*argument_header_ptr).value_ptr.boolean);
  1350.             break;
  1351.           case 'D':
  1352.             result_header_ptr=new_dataset_header_ptr();
  1353.             if (! fatal_error)
  1354.              *((*(result_header_ptr)).value_ptr.dataset)
  1355.               =*((*argument_header_ptr).value_ptr.dataset);
  1356.             break;
  1357.           case 'I':
  1358.             result_header_ptr=new_integer_header_ptr();
  1359.             if (! fatal_error)
  1360.              *((*(result_header_ptr)).value_ptr.integer)
  1361.               =*((*argument_header_ptr).value_ptr.integer);
  1362.             break;
  1363.           case 'R':
  1364.             result_header_ptr=new_real_header_ptr();
  1365.             if (! fatal_error)
  1366.              *((*(result_header_ptr)).value_ptr.real)
  1367.               =*((*argument_header_ptr).value_ptr.real);
  1368.             break;
  1369.           default:
  1370.             result_header_ptr
  1371.              =new_string_header_ptr((unsigned)
  1372.              (*((*argument_header_ptr).value_ptr.string)).length);
  1373.             if (! fatal_error)
  1374.              pli_strcpy((*(result_header_ptr)).value_ptr.string,
  1375.               (*argument_header_ptr).value_ptr.string);
  1376.             break;
  1377.         }
  1378.     return(result_header_ptr);
  1379.   }
  1380.  
  1381. static value_header_ptr copy_of_subscripts(argument_header_ptr)
  1382.  value_header_ptr argument_header_ptr;
  1383.   {
  1384.     value_header_ptr result_header_ptr;
  1385.  
  1386.     if (argument_header_ptr == NULL)
  1387.       result_header_ptr=NULL;
  1388.     else
  1389.       switch ((*argument_header_ptr).type)
  1390.         {
  1391.           case 'B':
  1392.             result_header_ptr=new_boolean_header_ptr();
  1393.             if (! fatal_error)
  1394.              *((*(result_header_ptr)).value_ptr.boolean)
  1395.               =*((*argument_header_ptr).value_ptr.boolean);
  1396.             break;
  1397.           case 'D':
  1398.             result_header_ptr=new_dataset_header_ptr();
  1399.             if (! fatal_error)
  1400.              *((*(result_header_ptr)).value_ptr.dataset)
  1401.               =*((*argument_header_ptr).value_ptr.dataset);
  1402.             break;
  1403.           case 'I':
  1404.             result_header_ptr=new_integer_header_ptr();
  1405.             if (! fatal_error)
  1406.              *((*(result_header_ptr)).value_ptr.integer)
  1407.               =tree_balancer(*((*argument_header_ptr).value_ptr.integer));
  1408.             break;
  1409.           case 'R':
  1410.             result_header_ptr=new_real_header_ptr();
  1411.             if (! fatal_error)
  1412.              *((*(result_header_ptr)).value_ptr.real)
  1413.               =*((*argument_header_ptr).value_ptr.real);
  1414.             break;
  1415.           default:
  1416.             result_header_ptr
  1417.              =new_string_header_ptr((unsigned)
  1418.              (*((*argument_header_ptr).value_ptr.string)).length);
  1419.             if (! fatal_error)
  1420.              pli_strcpy((*(result_header_ptr)).value_ptr.string,
  1421.               (*argument_header_ptr).value_ptr.string);
  1422.             break;
  1423.         }
  1424.     return(result_header_ptr);
  1425.   }
  1426.  
  1427. static queue_node_ptr copy_of_queue(queue_head)
  1428.   queue_node_ptr queue_head;
  1429.     {
  1430.       queue_node_ptr copy_queue_head;
  1431.       queue_node_ptr copy_queue_tail;
  1432.       queue_node_ptr new_copy_queue_tail;
  1433.       queue_node_ptr new_queue_head;
  1434.  
  1435.       copy_queue_head=NULL;
  1436.       copy_queue_tail=NULL;
  1437.       while ((queue_head != NULL) && (! fatal_error))
  1438.         {
  1439.           new_queue_head=(*queue_head).next;
  1440.           if (copy_queue_head == NULL)
  1441.             if ((copy_queue_head=(queue_node_ptr)
  1442.              malloc((unsigned) sizeof(struct queue_node))) == NULL)
  1443.               {
  1444.                 fatal_error=TRUE;
  1445.                 printf(
  1446.                  "Fatal error:  out of memory at line %ld, column %ld.\n",
  1447.                  source_line_num,source_column_num);
  1448.               }
  1449.             else
  1450.               {
  1451.                 copy_queue_tail=copy_queue_head;
  1452.                 (*copy_queue_head).next=NULL;
  1453.                 (*copy_queue_head).argument_header_ptr
  1454.                  =copy_of_subscripts((*queue_head).argument_header_ptr);
  1455.               }
  1456.           else
  1457.             if ((new_copy_queue_tail=(queue_node_ptr)
  1458.              malloc((unsigned) sizeof(struct queue_node))) == NULL)
  1459.               {
  1460.                 fatal_error=TRUE;
  1461.                 printf(
  1462.                  "Fatal error:  out of memory at line %ld, column %ld.\n",
  1463.                  source_line_num,source_column_num);
  1464.               }
  1465.             else
  1466.               {
  1467.                 (*new_copy_queue_tail).next=NULL;
  1468.                 (*copy_queue_tail).next=new_copy_queue_tail;
  1469.                 copy_queue_tail=new_copy_queue_tail;
  1470.                 (*new_copy_queue_tail).argument_header_ptr
  1471.                  =copy_of_subscripts((*queue_head).argument_header_ptr);
  1472.               }
  1473.           queue_head=new_queue_head;
  1474.         }
  1475.       return(copy_queue_head);
  1476.     }
  1477.  
  1478. static value_header_ptr variable_header_ptr(variable_name,evaluate,queue_head)
  1479.   char           *variable_name;
  1480.   int            evaluate;
  1481.   queue_node_ptr queue_head;
  1482.     {
  1483.       int              comparison;
  1484.       int              finished;
  1485.       queue_node_ptr   new_queue_copy;
  1486.       variable_ptr     parameter_ptr;
  1487.       queue_node_ptr   queue_copy;
  1488.       value_header_ptr result_header_ptr;
  1489.       int              variable_found;
  1490.  
  1491.       if (evaluate)
  1492.         {
  1493.           variable_found=FALSE;
  1494.           if (variable_head != NULL)
  1495.             {
  1496.               parameter_ptr=variable_head;
  1497.               queue_copy=copy_of_queue(queue_head);
  1498.               finished=FALSE;
  1499.               do
  1500.                 {
  1501.                   comparison=variable_comparison(variable_name,queue_copy,
  1502.                    (*parameter_ptr).name,(*parameter_ptr).subscripts);
  1503.                   if (comparison < 0)
  1504.                     if ((*parameter_ptr).smaller_successor_ptr == NULL)
  1505.                       finished=TRUE;
  1506.                     else
  1507.                       parameter_ptr=(*parameter_ptr).smaller_successor_ptr;
  1508.                   else
  1509.                     if (comparison > 0)
  1510.                       if ((*parameter_ptr).larger_successor_ptr == NULL)
  1511.                         finished=TRUE;
  1512.                       else
  1513.                         parameter_ptr=(*parameter_ptr).larger_successor_ptr;
  1514.                     else
  1515.                       {
  1516.                         variable_found=TRUE;
  1517.                         result_header_ptr
  1518.                          =copy_of_arguments(
  1519.                          (*parameter_ptr).variable_value_header_ptr);
  1520.                         finished=TRUE;
  1521.                       }
  1522.                 }
  1523.               while (! finished);
  1524.               while (queue_copy != NULL)
  1525.                 {
  1526.                   new_queue_copy=(*queue_copy).next;
  1527.                   free_value((*queue_copy).argument_header_ptr);
  1528.                   free((char *) queue_copy);
  1529.                   queue_copy=new_queue_copy;
  1530.                 }
  1531.             }
  1532.           if (! variable_found)
  1533.             result_header_ptr=NULL;
  1534.         }
  1535.       else
  1536.         result_header_ptr=NULL;
  1537.       return(result_header_ptr);
  1538.     }
  1539.  
  1540. static value_header_ptr unsigned_integer_header_ptr()
  1541.     {
  1542.       unsigned long    result;
  1543.       value_header_ptr result_header_ptr;
  1544.       unsigned long    tem_unsigned_long;
  1545.  
  1546.       result=(unsigned long) 0;
  1547.       do
  1548.         {
  1549.           if ((source_char >= '0') && (source_char <= '9'))
  1550.             {
  1551.               tem_unsigned_long=(unsigned long) source_char;
  1552.               tem_unsigned_long-=(unsigned long) '0';
  1553.               result*=(unsigned long) 10;
  1554.               result+=tem_unsigned_long;
  1555.               if (result <= 0x7fffffff)
  1556.                 get_source_char();
  1557.             }
  1558.         }
  1559.       while ((source_char >= '0') && (source_char <= '9')
  1560.       &&     (result <= 0x7fffffff));
  1561.       if (result <= 0x7fffffff)
  1562.         {
  1563.           result_header_ptr=new_integer_header_ptr();
  1564.           if (! fatal_error)
  1565.             *((*result_header_ptr).value_ptr.integer)=(long) result;
  1566.         }
  1567.       else
  1568.         {
  1569.           fatal_error=TRUE;
  1570.           result_header_ptr=NULL;
  1571.           printf(
  1572.            "Fatal error:  integer constant too big at line %ld, column %ld.\n",
  1573.            source_line_num,source_column_num);
  1574.         }
  1575.       return(result_header_ptr);
  1576.     }
  1577.  
  1578. static value_header_ptr unsigned_number_header_ptr(evaluate)
  1579.   int evaluate;
  1580.     {
  1581.       value_header_ptr exponent_header_ptr;
  1582.       char             exponent_sign;
  1583.       long             exponent_value;
  1584.       double           factor;
  1585.       value_header_ptr result_header_ptr;
  1586.       double           tem_real_1;
  1587.       double           tem_real_2;
  1588.  
  1589.       result_header_ptr=unsigned_integer_header_ptr();
  1590.       if (! fatal_error)
  1591.         {
  1592.           if (source_char == '.')
  1593.             {
  1594.               tem_real_1=(double) *((*result_header_ptr).value_ptr.integer);
  1595.               free_value(result_header_ptr);
  1596.               result_header_ptr=new_real_header_ptr();
  1597.               if (! fatal_error)
  1598.                 {
  1599.                   *((*result_header_ptr).value_ptr.real)=tem_real_1;
  1600.                   get_source_char();
  1601.                   if (isdigit((int) source_char))
  1602.                     {
  1603.                       factor=1.0;
  1604.                       while (isdigit((int) source_char))
  1605.                         {
  1606.                           factor=factor/10.0;
  1607.                           tem_real_2=(float) source_char;
  1608.                           tem_real_2-=(float) '0';
  1609.                           tem_real_1+=factor*tem_real_2;
  1610.                           get_source_char();
  1611.                         }
  1612.                       *((*result_header_ptr).value_ptr.real)=tem_real_1;
  1613.                     }
  1614.                   else
  1615.                     {
  1616.                       fatal_error=TRUE;
  1617.                       free_value(result_header_ptr);
  1618.                       result_header_ptr=NULL;
  1619.                       printf(
  1620.                   "Fatal error:  decimal part of real number is missing at\n");
  1621.                       printf(
  1622.                   "line %ld, column %ld.\n",source_line_num,source_column_num);
  1623.                     }
  1624.                 }
  1625.             }
  1626.           if (! fatal_error)
  1627.             {
  1628.               if ((source_char == 'e') || (source_char == 'E'))
  1629.                 {
  1630.                   if ((*result_header_ptr).type == 'I')
  1631.                     {
  1632.                       tem_real_1
  1633.                        =(double) *((*result_header_ptr).value_ptr.integer);
  1634.                       free_value(result_header_ptr);
  1635.                       result_header_ptr=new_real_header_ptr();
  1636.                       if (! fatal_error)
  1637.                         *((*result_header_ptr).value_ptr.real)=tem_real_1;
  1638.                     }
  1639.                   if (! fatal_error)
  1640.                     {
  1641.                       get_source_char();
  1642.                       if (source_eof)
  1643.                         {
  1644.                           fatal_error=TRUE;
  1645.                           free_value(result_header_ptr);
  1646.                           result_header_ptr=NULL;
  1647.                           printf(
  1648.                            "Fatal error:  file ends before real number ");
  1649.                           printf(
  1650.                            "completed.\n");
  1651.                         }
  1652.                     }
  1653.                   if (! fatal_error)
  1654.                     {
  1655.                       if ((source_char == '+')
  1656.                       ||  (source_char == '-'))
  1657.                         {
  1658.                           exponent_sign=source_char;
  1659.                           get_source_char();
  1660.                         }
  1661.                       else
  1662.                         exponent_sign=' ';
  1663.                     }
  1664.                   if (! fatal_error)
  1665.                     {
  1666.                       if (source_eof)
  1667.                         {
  1668.                           fatal_error=TRUE;
  1669.                           free_value(result_header_ptr);
  1670.                           result_header_ptr=NULL;
  1671.                           printf(
  1672.                            "Fatal error:  file ends before real number ");
  1673.                           printf(
  1674.                            "completed.\n");
  1675.                         }
  1676.                     }
  1677.                   if (! fatal_error)
  1678.                     {
  1679.                       if (! isdigit((int) source_char))
  1680.                         {
  1681.                           fatal_error=TRUE;
  1682.                           free_value(result_header_ptr);
  1683.                           result_header_ptr=NULL;
  1684.                           printf(
  1685.                 "Fatal error:  nonnumeric exponent at line %ld, column %ld.\n",
  1686.                            source_line_num,source_column_num);
  1687.                         }
  1688.                     }
  1689.                   if (! fatal_error)
  1690.                     exponent_header_ptr=unsigned_integer_header_ptr();
  1691.                   if (! fatal_error)
  1692.                     {
  1693.                       if (*((*exponent_header_ptr).value_ptr.integer)
  1694.                        > (long) 37)
  1695.                         {
  1696.                           fatal_error=TRUE;
  1697.                           free_value(result_header_ptr);
  1698.                           free_value(exponent_header_ptr);
  1699.                           result_header_ptr=NULL;
  1700.                           printf(
  1701.                 "Fatal error:  exponent too large at line %ld, column %ld.\n",
  1702.                            source_line_num,source_column_num);
  1703.                         }
  1704.                     }
  1705.                   if (! fatal_error)
  1706.                     {
  1707.                       tem_real_1=1.0;
  1708.                       exponent_value
  1709.                        =*((*exponent_header_ptr).value_ptr.integer);
  1710.                       free_value(exponent_header_ptr);
  1711.                       while (exponent_value > (long) 0)
  1712.                         {
  1713.                           exponent_value--;
  1714.                           tem_real_1*=10.0;
  1715.                         }
  1716.                       if (exponent_sign == '-')
  1717.                         tem_real_1=1.0/tem_real_1;
  1718.                       if (*((*result_header_ptr).value_ptr.real) != 0.0)
  1719.                         {
  1720.                           tem_real_2=(log(tem_real_1)
  1721.                            +log(fabs(*((*result_header_ptr).value_ptr.real))))
  1722.                            /log(10.0);
  1723.                           if (tem_real_2 < -37.0)
  1724.                             *((*result_header_ptr).value_ptr.real)=0.0;
  1725.                           else
  1726.                             if (tem_real_2 > 37.0)
  1727.                               {
  1728.                                 fatal_error=TRUE;
  1729.                                 free_value(result_header_ptr);
  1730.                                 result_header_ptr=NULL;
  1731.                                 printf(
  1732.                      "Fatal error:  real too large at line %ld, column %ld.\n",
  1733.                                  source_line_num,source_column_num);
  1734.                               }
  1735.                             else
  1736.                               *((*result_header_ptr).value_ptr.real)
  1737.                                *=tem_real_1;
  1738.                         }
  1739.                     }
  1740.                 }
  1741.             }
  1742.         }
  1743.       if (! evaluate)
  1744.         {
  1745.           free_value(result_header_ptr);
  1746.           result_header_ptr=NULL;
  1747.         }
  1748.       return(result_header_ptr);
  1749.     }
  1750.  
  1751. static value_header_ptr abs_header_ptr(queue_head,function_name,evaluate)
  1752.   queue_node_ptr queue_head;
  1753.   char           *function_name;
  1754.   int            evaluate;
  1755.     {
  1756.       value_header_ptr result_header_ptr;
  1757.  
  1758.       if (queue_head == NULL)
  1759.         {
  1760.           fatal_error=TRUE;
  1761.           result_header_ptr=NULL;
  1762.           printf(
  1763.           "Fatal error:  argument to function \"%s\" is missing on\n",
  1764.            function_name);
  1765.           printf("     line %ld, column %ld.\n",source_line_num,
  1766.            source_column_num);
  1767.         }
  1768.       else
  1769.         if ((*queue_head).next == NULL)
  1770.           if (evaluate)
  1771.             if ((*((*queue_head).argument_header_ptr)).type == 'I')
  1772.               {
  1773.                 result_header_ptr=new_integer_header_ptr();
  1774.                 if (! fatal_error)
  1775.                   *((*result_header_ptr).value_ptr.integer)
  1776.                    =labs(*((*((*queue_head).argument_header_ptr)).
  1777.                    value_ptr.integer));
  1778.               }
  1779.             else
  1780.               if ((*((*queue_head).argument_header_ptr)).type == 'R')
  1781.                 {
  1782.                   result_header_ptr=new_real_header_ptr();
  1783.                   if (! fatal_error)
  1784.                     *((*result_header_ptr).value_ptr.real)
  1785.                      =fabs(*((*((*queue_head).argument_header_ptr)).
  1786.                      value_ptr.real));
  1787.                 }
  1788.               else
  1789.                 {
  1790.                   fatal_error=TRUE;
  1791.                   result_header_ptr=NULL;
  1792.                   printf(
  1793. "Fatal error:  other than a number supplied as argument to function \"%s\"\n",
  1794.                    function_name);
  1795.                   printf("     on line %ld, column %ld.\n",source_line_num,
  1796.                    source_column_num);
  1797.                 }
  1798.           else
  1799.             result_header_ptr=NULL;
  1800.         else
  1801.           {
  1802.             fatal_error=TRUE;
  1803.             result_header_ptr=NULL;
  1804.             printf(
  1805.           "Fatal error:  extraneous argument supplied to function \"%s\" on\n",
  1806.              function_name);
  1807.             printf("     line %ld, column %ld.\n",source_line_num,
  1808.              source_column_num);
  1809.           }
  1810.       return(result_header_ptr);
  1811.     }
  1812.  
  1813. static value_header_ptr atan_header_ptr(queue_head,function_name,evaluate)
  1814.   queue_node_ptr queue_head;
  1815.   char           *function_name;
  1816.   int            evaluate;
  1817.     {
  1818.       value_header_ptr result_header_ptr;
  1819.       double           tem_real;
  1820.  
  1821.       if (queue_head == NULL)
  1822.         {
  1823.           fatal_error=TRUE;
  1824.           result_header_ptr=NULL;
  1825.           printf(
  1826.           "Fatal error:  argument to function \"%s\" is missing on\n",
  1827.            function_name);
  1828.           printf("     line %ld, column %ld.\n",source_line_num,
  1829.            source_column_num);
  1830.         }
  1831.       else
  1832.         if ((*queue_head).next == NULL)
  1833.           if (evaluate)
  1834.             if ((*((*queue_head).argument_header_ptr)).type == 'I')
  1835.               {
  1836.                 tem_real=(double) *((*((*queue_head).argument_header_ptr)).
  1837.                    value_ptr.integer);
  1838.                 result_header_ptr=new_real_header_ptr();
  1839.                 if (! fatal_error)
  1840.                   *((*result_header_ptr).value_ptr.real)=atan(tem_real);
  1841.               }
  1842.             else
  1843.               if ((*((*queue_head).argument_header_ptr)).type == 'R')
  1844.                 {
  1845.                   result_header_ptr=new_real_header_ptr();
  1846.                   if (! fatal_error)
  1847.                     *((*result_header_ptr).value_ptr.real)
  1848.                      =atan(*((*((*queue_head).argument_header_ptr)).
  1849.                      value_ptr.real));
  1850.                 }
  1851.               else
  1852.                 {
  1853.                   fatal_error=TRUE;
  1854.                   result_header_ptr=NULL;
  1855.                   printf(
  1856. "Fatal error:  other than a number supplied as argument to function \"%s\"\n",
  1857.                    function_name);
  1858.                   printf("     on line %ld, column %ld.\n",source_line_num,
  1859.                    source_column_num);
  1860.                 }
  1861.           else
  1862.             result_header_ptr=NULL;
  1863.         else
  1864.           {
  1865.             fatal_error=TRUE;
  1866.             result_header_ptr=NULL;
  1867.             printf(
  1868.           "Fatal error:  extraneous argument supplied to function \"%s\" on\n",
  1869.              function_name);
  1870.             printf("     line %ld, column %ld.\n",source_line_num,
  1871.              source_column_num);
  1872.           }
  1873.       return(result_header_ptr);
  1874.     }
  1875.  
  1876. static value_header_ptr char_header_ptr(queue_head,function_name,evaluate)
  1877.   queue_node_ptr queue_head;
  1878.   char           *function_name;
  1879.   int            evaluate;
  1880.     {
  1881.       value_header_ptr result_header_ptr;
  1882.       long             tem_integer;
  1883.  
  1884.       if (queue_head == NULL)
  1885.         {
  1886.           fatal_error=TRUE;
  1887.           result_header_ptr=NULL;
  1888.           printf(
  1889.           "Fatal error:  argument to function \"%s\" is missing on\n",
  1890.            function_name);
  1891.           printf("     line %ld, column %ld.\n",source_line_num,
  1892.            source_column_num);
  1893.         }
  1894.       else
  1895.         if ((*queue_head).next == NULL)
  1896.           if (evaluate)
  1897.             if ((*((*queue_head).argument_header_ptr)).type == 'I')
  1898.               {
  1899.                 tem_integer=*((*((*queue_head).argument_header_ptr)).
  1900.                    value_ptr.integer);
  1901.                 if (((long) 0 <= tem_integer) && (tem_integer <= (long) 255))
  1902.                   {
  1903.                     result_header_ptr=new_string_header_ptr((unsigned) 1);
  1904.                     if (! fatal_error)
  1905.                       {
  1906.                         *((*((*result_header_ptr).value_ptr.string)).value)
  1907.                          =(unsigned char) tem_integer;
  1908.                         *((*((*result_header_ptr).value_ptr.string)).value+1)
  1909.                          =(unsigned char) '\0';
  1910.                       }
  1911.                   }
  1912.                 else
  1913.                   {
  1914.                     fatal_error=TRUE;
  1915.                     result_header_ptr=NULL;
  1916.                     printf(
  1917.                   "Fatal error:  argument to CHAR is not between 0 and 255\n");
  1918.                     printf("     on line %ld, column %ld.\n",source_line_num,
  1919.                      source_column_num);
  1920.                   }
  1921.               }
  1922.             else
  1923.               {
  1924.                 fatal_error=TRUE;
  1925.                 result_header_ptr=NULL;
  1926.                 printf(
  1927.                  "Fatal error:  argument to CHAR is other than an integer\n");
  1928.                 printf("     on line %ld, column %ld.\n",source_line_num,
  1929.                  source_column_num);
  1930.               }
  1931.           else
  1932.             result_header_ptr=NULL;
  1933.         else
  1934.           {
  1935.             fatal_error=TRUE;
  1936.             result_header_ptr=NULL;
  1937.             printf(
  1938.           "Fatal error:  extraneous argument supplied to function \"%s\" on\n",
  1939.              function_name);
  1940.             printf("     line %ld, column %ld.\n",source_line_num,
  1941.              source_column_num);
  1942.           }
  1943.       return(result_header_ptr);
  1944.     }
  1945.  
  1946. static value_header_ptr cos_header_ptr(queue_head,function_name,evaluate)
  1947.   queue_node_ptr queue_head;
  1948.   char           *function_name;
  1949.   int            evaluate;
  1950.     {
  1951.       value_header_ptr result_header_ptr;
  1952.       double           tem_real;
  1953.  
  1954.       if (queue_head == NULL)
  1955.         {
  1956.           fatal_error=TRUE;
  1957.           result_header_ptr=NULL;
  1958.           printf(
  1959.           "Fatal error:  argument to function \"%s\" is missing on\n",
  1960.            function_name);
  1961.           printf("     line %ld, column %ld.\n",source_line_num,
  1962.            source_column_num);
  1963.         }
  1964.       else
  1965.         if ((*queue_head).next == NULL)
  1966.           if (evaluate)
  1967.             if ((*((*queue_head).argument_header_ptr)).type == 'I')
  1968.               {
  1969.                 tem_real=(double) *((*((*queue_head).argument_header_ptr)).
  1970.                    value_ptr.integer);
  1971.                 result_header_ptr=new_real_header_ptr();
  1972.                 if (! fatal_error)
  1973.                   *((*result_header_ptr).value_ptr.real)=cos(tem_real);
  1974.               }
  1975.             else
  1976.               if ((*((*queue_head).argument_header_ptr)).type == 'R')
  1977.                 {
  1978.                   result_header_ptr=new_real_header_ptr();
  1979.                   if (! fatal_error)
  1980.                     *((*result_header_ptr).value_ptr.real)
  1981.                      =cos(*((*((*queue_head).argument_header_ptr)).
  1982.                      value_ptr.real));
  1983.                 }
  1984.               else
  1985.                 {
  1986.                   fatal_error=TRUE;
  1987.                   result_header_ptr=NULL;
  1988.                   printf(
  1989. "Fatal error:  other than a number supplied as argument to function \"%s\"\n",
  1990.                    function_name);
  1991.                   printf("     on line %ld, column %ld.\n",source_line_num,
  1992.                    source_column_num);
  1993.                 }
  1994.           else
  1995.             result_header_ptr=NULL;
  1996.         else
  1997.           {
  1998.             fatal_error=TRUE;
  1999.             result_header_ptr=NULL;
  2000.             printf(
  2001.           "Fatal error:  extraneous argument supplied to function \"%s\" on\n",
  2002.              function_name);
  2003.             printf("     line %ld, column %ld.\n",source_line_num,
  2004.              source_column_num);
  2005.           }
  2006.       return(result_header_ptr);
  2007.     }
  2008.  
  2009. static value_header_ptr date_header_ptr(queue_head,function_name,evaluate)
  2010.   queue_node_ptr queue_head;
  2011.   char           *function_name;
  2012.   int            evaluate;
  2013.     {
  2014.       unsigned char    *char_ptr_1;
  2015.       char             *char_ptr_2;
  2016.       char             date_and_time [26];
  2017.       long             elapsed_time;
  2018.       struct tm        *local_time;
  2019.       value_header_ptr result_header_ptr;
  2020.  
  2021.       if (queue_head != NULL)
  2022.         {
  2023.           fatal_error=TRUE;
  2024.           result_header_ptr=NULL;
  2025.           printf(
  2026.           "Fatal error:  extraneous argument supplied to function \"%s\" on\n",
  2027.            function_name);
  2028.           printf("     line %ld, column %ld.\n",source_line_num,
  2029.            source_column_num);
  2030.         }
  2031.       else
  2032.         if (evaluate)
  2033.           {
  2034.             result_header_ptr=new_string_header_ptr(6);
  2035.             if (! fatal_error)
  2036.               {
  2037.                 char_ptr_1=(*((*result_header_ptr).value_ptr.string)).value;
  2038.                 time(&elapsed_time);
  2039.                 local_time=localtime(&elapsed_time);
  2040.                 strcpy(&date_and_time[0],asctime(local_time));
  2041.                 strncpy((char *) char_ptr_1,&date_and_time[22],2);
  2042.                 *(char_ptr_1+2)=(unsigned char) '\0';
  2043.                 date_and_time[7]='\0';
  2044.                 char_ptr_2=&date_and_time[4];
  2045.                 if      (strcmp(char_ptr_2,"Jan") == 0)
  2046.                   strcat((char *) char_ptr_1,"01");
  2047.                 else if (strcmp(char_ptr_2,"Feb") == 0)
  2048.                   strcat((char *) char_ptr_1,"02");
  2049.                 else if (strcmp(char_ptr_2,"Mar") == 0)
  2050.                   strcat((char *) char_ptr_1,"03");
  2051.                 else if (strcmp(char_ptr_2,"Apr") == 0)
  2052.                   strcat((char *) char_ptr_1,"04");
  2053.                 else if (strcmp(char_ptr_2,"May") == 0)
  2054.                   strcat((char *) char_ptr_1,"05");
  2055.                 else if (strcmp(char_ptr_2,"Jun") == 0)
  2056.                   strcat((char *) char_ptr_1,"06");
  2057.                 else if (strcmp(char_ptr_2,"Jul") == 0)
  2058.                   strcat((char *) char_ptr_1,"07");
  2059.                 else if (strcmp(char_ptr_2,"Aug") == 0)
  2060.                   strcat((char *) char_ptr_1,"08");
  2061.                 else if (strcmp(char_ptr_2,"Sep") == 0)
  2062.                   strcat((char *) char_ptr_1,"09");
  2063.                 else if (strcmp(char_ptr_2,"Oct") == 0)
  2064.                   strcat((char *) char_ptr_1,"10");
  2065.                 else if (strcmp(char_ptr_2,"Nov") == 0)
  2066.                   strcat((char *) char_ptr_1,"11");
  2067.                 else
  2068.                   strcat((char *) char_ptr_1,"12");
  2069.                 strncat((char *) char_ptr_1,&date_and_time[8],2);
  2070.               }
  2071.           }
  2072.         else
  2073.           result_header_ptr=NULL;
  2074.       return(result_header_ptr);
  2075.     }
  2076.  
  2077. static value_header_ptr endfile_header_ptr(queue_head,function_name,evaluate)
  2078.   queue_node_ptr queue_head;
  2079.   char           *function_name;
  2080.   int            evaluate;
  2081.     {
  2082.       FILE             *file;
  2083.       value_header_ptr result_header_ptr;
  2084.  
  2085.       if (queue_head == NULL)
  2086.         {
  2087.           result_header_ptr=new_boolean_header_ptr();
  2088.           if (! fatal_error)
  2089.             {
  2090.               if (feof(stdin) == 0)
  2091.                 *((*result_header_ptr).value_ptr.boolean)=FALSE;
  2092.               else
  2093.                 *((*result_header_ptr).value_ptr.boolean)=TRUE;
  2094.             }
  2095.         }
  2096.       else
  2097.         if ((*queue_head).next == NULL)
  2098.           if (evaluate)
  2099.             if ((*((*queue_head).argument_header_ptr)).type == 'D')
  2100.               {
  2101.                 file=*((*((*queue_head).argument_header_ptr)).
  2102.                  value_ptr.dataset);
  2103.                 result_header_ptr=new_boolean_header_ptr();
  2104.                 if (! fatal_error)
  2105.                   {
  2106.                     if (feof(file) == 0)
  2107.                       *((*result_header_ptr).value_ptr.boolean)=FALSE;
  2108.                     else
  2109.                       *((*result_header_ptr).value_ptr.boolean)=TRUE;
  2110.                   }
  2111.               }
  2112.             else
  2113.               {
  2114.                 fatal_error=TRUE;
  2115.                 result_header_ptr=NULL;
  2116.                 printf(
  2117.            "Fatal error:  argument to ENDFILE is other than a file pointer\n");
  2118.                 printf("     on line %ld, column %ld.\n",source_line_num,
  2119.                  source_column_num);
  2120.               }
  2121.           else
  2122.             result_header_ptr=NULL;
  2123.         else
  2124.           {
  2125.             fatal_error=TRUE;
  2126.             result_header_ptr=NULL;
  2127.             printf(
  2128.           "Fatal error:  extraneous argument supplied to function \"%s\" on\n",
  2129.              function_name);
  2130.             printf("     line %ld, column %ld.\n",source_line_num,
  2131.              source_column_num);
  2132.           }
  2133.       return(result_header_ptr);
  2134.     }
  2135.  
  2136. static value_header_ptr exec_header_ptr(queue_head,function_name,evaluate)
  2137.   queue_node_ptr queue_head;
  2138.   char           *function_name;
  2139.   int            evaluate;
  2140.     {
  2141.       value_header_ptr result_header_ptr;
  2142.  
  2143.       if (queue_head == NULL)
  2144.         {
  2145.           fatal_error=TRUE;
  2146.           result_header_ptr=NULL;
  2147.           printf(
  2148.           "Fatal error:  argument to function \"%s\" is missing on\n",
  2149.            function_name);
  2150.           printf("     line %ld, column %ld.\n",source_line_num,
  2151.            source_column_num);
  2152.         }
  2153.       else
  2154.         if ((*queue_head).next == NULL)
  2155.           if (evaluate)
  2156.             if ((*((*queue_head).argument_header_ptr)).type == 'S')
  2157.               {
  2158.                 result_header_ptr=new_boolean_header_ptr();
  2159.                 if (! fatal_error)
  2160.                   {
  2161.                     if (system(
  2162.                      (char *) (*((*((*queue_head).argument_header_ptr)).
  2163.                      value_ptr.string)).value) == 0)
  2164.                       *((*result_header_ptr).value_ptr.boolean)=TRUE;
  2165.                     else
  2166.                       *((*result_header_ptr).value_ptr.boolean)=FALSE;
  2167.                   }
  2168.               }
  2169.             else
  2170.               {
  2171.                 fatal_error=TRUE;
  2172.                 result_header_ptr=NULL;
  2173.                 printf(
  2174. "Fatal error:  other than a string supplied as argument to function \"%s\"\n",
  2175.                  function_name);
  2176.                 printf("     on line %ld, column %ld.\n",source_line_num,
  2177.                  source_column_num);
  2178.               }
  2179.           else
  2180.             result_header_ptr=NULL;
  2181.         else
  2182.           {
  2183.             fatal_error=TRUE;
  2184.             result_header_ptr=NULL;
  2185.             printf(
  2186.           "Fatal error:  extraneous argument supplied to function \"%s\" on\n",
  2187.              function_name);
  2188.             printf("     line %ld, column %ld.\n",source_line_num,
  2189.              source_column_num);
  2190.           }
  2191.       return(result_header_ptr);
  2192.     }
  2193.  
  2194. static value_header_ptr exp_header_ptr(queue_head,function_name,evaluate)
  2195.   queue_node_ptr queue_head;
  2196.   char           *function_name;
  2197.   int            evaluate;
  2198.     {
  2199.       value_header_ptr result_header_ptr;
  2200.       double           tem_real_1;
  2201.       double           tem_real_2;
  2202.  
  2203.       if (queue_head == NULL)
  2204.         {
  2205.           fatal_error=TRUE;
  2206.           result_header_ptr=NULL;
  2207.           printf(
  2208.           "Fatal error:  argument to function \"%s\" is missing on\n",
  2209.            function_name);
  2210.           printf("     line %ld, column %ld.\n",source_line_num,
  2211.            source_column_num);
  2212.         }
  2213.       else
  2214.         if ((*queue_head).next == NULL)
  2215.           if (evaluate)
  2216.             if ((*((*queue_head).argument_header_ptr)).type == 'I')
  2217.               {
  2218.                 tem_real_1=(double) *((*((*queue_head).argument_header_ptr)).
  2219.                    value_ptr.integer);
  2220.                 result_header_ptr=new_real_header_ptr();
  2221.                 if (! fatal_error)
  2222.                   {
  2223.                     tem_real_2=tem_real_1/log(10.0);
  2224.                     if (tem_real_2 < -37.0)
  2225.                       *((*result_header_ptr).value_ptr.real)=0.0;
  2226.                     else
  2227.                       if (tem_real_2 > 37.0)
  2228.                         {
  2229.                           fatal_error=TRUE;
  2230.                           free_value(result_header_ptr);
  2231.                           result_header_ptr=NULL;
  2232.                           printf(
  2233.        "Fatal error:  argument to EXP is too large at line %ld, column %ld.\n",
  2234.                            source_line_num,source_column_num);
  2235.                         }
  2236.                       else
  2237.                         *((*result_header_ptr).value_ptr.real)=exp(tem_real_1);
  2238.                   }
  2239.               }
  2240.             else
  2241.               if ((*((*queue_head).argument_header_ptr)).type == 'R')
  2242.                 {
  2243.                   tem_real_1=*((*((*queue_head).argument_header_ptr)).
  2244.                      value_ptr.real);
  2245.                   result_header_ptr=new_real_header_ptr();
  2246.                   if (! fatal_error)
  2247.                     {
  2248.                       tem_real_2=tem_real_1/log(10.0);
  2249.                       if (tem_real_2 < -37.0)
  2250.                         *((*result_header_ptr).value_ptr.real)=0.0;
  2251.                       else
  2252.                         if (tem_real_2 > 37.0)
  2253.                           {
  2254.                             fatal_error=TRUE;
  2255.                             free_value(result_header_ptr);
  2256.                             result_header_ptr=NULL;
  2257.                             printf(
  2258.        "Fatal error:  argument to EXP is too large at line %ld, column %ld.\n",
  2259.                              source_line_num,source_column_num);
  2260.                           }
  2261.                         else
  2262.                           *((*result_header_ptr).value_ptr.real)
  2263.                            =exp(tem_real_1);
  2264.                     }
  2265.                 }
  2266.               else
  2267.                 {
  2268.                   fatal_error=TRUE;
  2269.                   result_header_ptr=NULL;
  2270.                   printf(
  2271. "Fatal error:  other than a number supplied as argument to function \"%s\"\n",
  2272.                    function_name);
  2273.                   printf("     on line %ld, column %ld.\n",source_line_num,
  2274.                    source_column_num);
  2275.                 }
  2276.           else
  2277.             result_header_ptr=NULL;
  2278.         else
  2279.           {
  2280.             fatal_error=TRUE;
  2281.             result_header_ptr=NULL;
  2282.             printf(
  2283.           "Fatal error:  extraneous argument supplied to function \"%s\" on\n",
  2284.              function_name);
  2285.             printf("     line %ld, column %ld.\n",source_line_num,
  2286.              source_column_num);
  2287.           }
  2288.       return(result_header_ptr);
  2289.     }
  2290.  
  2291. static value_header_ptr false_header_ptr(queue_head,function_name,evaluate)
  2292.   queue_node_ptr queue_head;
  2293.   char           *function_name;
  2294.   int            evaluate;
  2295.     {
  2296.       value_header_ptr result_header_ptr;
  2297.  
  2298.       if (queue_head != NULL)
  2299.         {
  2300.           fatal_error=TRUE;
  2301.           result_header_ptr=NULL;
  2302.           printf(
  2303.           "Fatal error:  extraneous argument supplied to function \"%s\" on\n",
  2304.            function_name);
  2305.           printf("     line %ld, column %ld.\n",source_line_num,
  2306.            source_column_num);
  2307.         }
  2308.       else
  2309.         if (evaluate)
  2310.           {
  2311.             result_header_ptr=new_boolean_header_ptr();
  2312.             if (! fatal_error)
  2313.               *((*result_header_ptr).value_ptr.boolean)=FALSE;
  2314.           }
  2315.         else
  2316.           result_header_ptr=NULL;
  2317.       return(result_header_ptr);
  2318.     }
  2319.  
  2320. static value_header_ptr float_header_ptr(queue_head,function_name,evaluate)
  2321.   queue_node_ptr queue_head;
  2322.   char           *function_name;
  2323.   int            evaluate;
  2324.     {
  2325.       value_header_ptr result_header_ptr;
  2326.       int              status;
  2327.  
  2328.       if (queue_head == NULL)
  2329.         {
  2330.           fatal_error=TRUE;
  2331.           result_header_ptr=NULL;
  2332.           printf(
  2333.           "Fatal error:  argument to function \"%s\" is missing on\n",
  2334.            function_name);
  2335.           printf("     line %ld, column %ld.\n",source_line_num,
  2336.            source_column_num);
  2337.         }
  2338.       else
  2339.         if ((*queue_head).next == NULL)
  2340.           if (evaluate)
  2341.             if ((*((*queue_head).argument_header_ptr)).type == 'I')
  2342.               {
  2343.                 result_header_ptr=new_real_header_ptr();
  2344.                 if (! fatal_error)
  2345.                   *((*result_header_ptr).value_ptr.real)
  2346.                    =(double) *((*((*queue_head).argument_header_ptr)).
  2347.                    value_ptr.integer);
  2348.               }
  2349.             else
  2350.               if ((*((*queue_head).argument_header_ptr)).type == 'R')
  2351.                 {
  2352.                   result_header_ptr=new_real_header_ptr();
  2353.                   if (! fatal_error)
  2354.                     *((*result_header_ptr).value_ptr.real)
  2355.                      =*((*((*queue_head).argument_header_ptr)).
  2356.                      value_ptr.real);
  2357.                 }
  2358.               else
  2359.                 if ((*((*queue_head).argument_header_ptr)).type == 'B')
  2360.                   {
  2361.                     result_header_ptr=new_real_header_ptr();
  2362.                     if (! fatal_error)
  2363.                       {
  2364.                         if (*((*((*queue_head).argument_header_ptr)).
  2365.                          value_ptr.boolean))
  2366.                           *((*result_header_ptr).value_ptr.real)=1.0;
  2367.                         else
  2368.                           *((*result_header_ptr).value_ptr.real)=0.0;
  2369.                       }
  2370.                   }
  2371.                 else
  2372.                   if ((*((*queue_head).argument_header_ptr)).type == 'S')
  2373.                     {
  2374.                       result_header_ptr=new_real_header_ptr();
  2375.                       if (! fatal_error)
  2376.                         {
  2377.                           status=sscanf((char *)
  2378.                            (*((*((*queue_head).argument_header_ptr)).
  2379.                            value_ptr.string)).value,"%lf",
  2380.                            (*result_header_ptr).value_ptr.real);
  2381.                           if ((status == EOF) || (status == 0))
  2382.                             {
  2383.                               fatal_error=TRUE;
  2384.                               free_value(result_header_ptr);
  2385.                               result_header_ptr=NULL;
  2386.                               printf(
  2387.                    "Fatal error:  argument to FLOAT cannot be converted on\n");
  2388.                               printf("     line %ld, column %ld.\n",
  2389.                                source_line_num,source_column_num);
  2390.                             }
  2391.                         }
  2392.                     }
  2393.                   else
  2394.                     {
  2395.                       fatal_error=TRUE;
  2396.                       result_header_ptr=NULL;
  2397.                       printf(
  2398.  "Fatal error:  argument to FLOAT is other than Boolean, number, or string\n");
  2399.                       printf("     on line %ld, column %ld.\n",
  2400.                        source_line_num,source_column_num);
  2401.                     }
  2402.           else
  2403.             result_header_ptr=NULL;
  2404.         else
  2405.           {
  2406.             fatal_error=TRUE;
  2407.             result_header_ptr=NULL;
  2408.             printf(
  2409.           "Fatal error:  extraneous argument supplied to function \"%s\" on\n",
  2410.              function_name);
  2411.             printf("     line %ld, column %ld.\n",source_line_num,
  2412.              source_column_num);
  2413.           }
  2414.       return(result_header_ptr);
  2415.     }
  2416.  
  2417. static value_header_ptr getchar_header_ptr(queue_head,function_name,evaluate)
  2418.   queue_node_ptr queue_head;
  2419.   char           *function_name;
  2420.   int            evaluate;
  2421.     {
  2422.       int              current_char;
  2423.       value_header_ptr result_header_ptr;
  2424.  
  2425.       if (queue_head != NULL)
  2426.         if ((*queue_head).next == NULL)
  2427.           if (evaluate)
  2428.             if ((*((*queue_head).argument_header_ptr)).type == 'D')
  2429.               {
  2430.                 current_char=fgetc(
  2431.                  *((*((*queue_head).argument_header_ptr)).value_ptr.dataset));
  2432.                 if (current_char == EOF)
  2433.                   {
  2434.                     result_header_ptr=new_string_header_ptr(0);
  2435.                     if (! fatal_error)
  2436.                       *((*((*result_header_ptr).value_ptr.string)).value)
  2437.                        =(unsigned char) '\0';
  2438.                   }
  2439.                 else
  2440.                   {
  2441.                     result_header_ptr=new_string_header_ptr(1);
  2442.                     if (! fatal_error)
  2443.                       {
  2444.                         *((*((*result_header_ptr).value_ptr.string)).value)
  2445.                          =(unsigned char) current_char;
  2446.                         *((*((*result_header_ptr).value_ptr.string)).value+1)
  2447.                          =(unsigned char) '\0';
  2448.                       }
  2449.                   }
  2450.               }
  2451.             else
  2452.               {
  2453.                 fatal_error=TRUE;
  2454.                 result_header_ptr=NULL;
  2455.                 printf(
  2456.         "Fatal error:  argument to GETCHAR is other than a file pointer on\n");
  2457.                 printf("     line %ld, column %ld.\n",source_line_num,
  2458.                  source_column_num);
  2459.               }
  2460.           else
  2461.             result_header_ptr=NULL;
  2462.         else
  2463.           {
  2464.             fatal_error=TRUE;
  2465.             result_header_ptr=NULL;
  2466.             printf(
  2467.           "Fatal error:  extraneous argument supplied to function \"%s\" on\n",
  2468.              function_name);
  2469.             printf("     line %ld, column %ld.\n",source_line_num,
  2470.              source_column_num);
  2471.           }
  2472.       else
  2473.         if (evaluate)
  2474.           {
  2475.             current_char=fgetc(stdin);
  2476.             if (current_char == EOF)
  2477.               {
  2478.                 result_header_ptr=new_string_header_ptr(0);
  2479.                 if (! fatal_error)
  2480.                   *((*((*result_header_ptr).value_ptr.string)).value)
  2481.                    =(unsigned char) '\0';
  2482.               }
  2483.             else
  2484.               {
  2485.                 result_header_ptr=new_string_header_ptr(1);
  2486.                 if (! fatal_error)
  2487.                   {
  2488.                     *((*((*result_header_ptr).value_ptr.string)).value)
  2489.                      =(unsigned char) current_char;
  2490.                     *((*((*result_header_ptr).value_ptr.string)).value+1)
  2491.                      =(unsigned char) '\0';
  2492.                   }
  2493.               }
  2494.           }
  2495.         else
  2496.           result_header_ptr=NULL;
  2497.       return(result_header_ptr);
  2498.     }
  2499.  
  2500. static value_header_ptr getint_header_ptr(queue_head,function_name,evaluate)
  2501.   queue_node_ptr queue_head;
  2502.   char           *function_name;
  2503.   int            evaluate;
  2504.     {
  2505.       int              num_fields_read;
  2506.       value_header_ptr result_header_ptr;
  2507.       long             tem_integer;
  2508.  
  2509.       if (queue_head != NULL)
  2510.         if ((*queue_head).next == NULL)
  2511.           if (evaluate)
  2512.             if ((*((*queue_head).argument_header_ptr)).type == 'D')
  2513.               {
  2514.                 num_fields_read=fscanf(
  2515.                  *((*((*queue_head).argument_header_ptr)).value_ptr.dataset),
  2516.                  "%I",&tem_integer);
  2517.                 if (num_fields_read == 0)
  2518.                   tem_integer=(long) 0;
  2519.                 result_header_ptr=new_integer_header_ptr();
  2520.                 if (! fatal_error)
  2521.                   *((*result_header_ptr).value_ptr.integer)=tem_integer;
  2522.               }
  2523.             else
  2524.               {
  2525.                 fatal_error=TRUE;
  2526.                 result_header_ptr=NULL;
  2527.                 printf(
  2528.          "Fatal error:  argument to GETINT is other than a file pointer on\n");
  2529.                 printf("     line %ld, column %ld.\n",source_line_num,
  2530.                  source_column_num);
  2531.               }
  2532.           else
  2533.             result_header_ptr=NULL;
  2534.         else
  2535.           {
  2536.             fatal_error=TRUE;
  2537.             result_header_ptr=NULL;
  2538.             printf(
  2539.           "Fatal error:  extraneous argument supplied to function \"%s\" on\n",
  2540.              function_name);
  2541.             printf("     line %ld, column %ld.\n",source_line_num,
  2542.              source_column_num);
  2543.           }
  2544.       else
  2545.         if (evaluate)
  2546.           {
  2547.             num_fields_read=scanf("%I",&tem_integer);
  2548.             if (num_fields_read == 0)
  2549.               tem_integer=(long) 0;
  2550.             result_header_ptr=new_integer_header_ptr();
  2551.             if (! fatal_error)
  2552.               *((*result_header_ptr).value_ptr.integer)=tem_integer;
  2553.           }
  2554.         else
  2555.           result_header_ptr=NULL;
  2556.       return(result_header_ptr);
  2557.     }
  2558.  
  2559. static value_header_ptr getreal_header_ptr(queue_head,function_name,evaluate)
  2560.   queue_node_ptr queue_head;
  2561.   char           *function_name;
  2562.   int            evaluate;
  2563.     {
  2564.       int              num_fields_read;
  2565.       value_header_ptr result_header_ptr;
  2566.       double           tem_real;
  2567.  
  2568.       if (queue_head != NULL)
  2569.         if ((*queue_head).next == NULL)
  2570.           if (evaluate)
  2571.             if ((*((*queue_head).argument_header_ptr)).type == 'D')
  2572.               {
  2573.                 num_fields_read=fscanf(
  2574.                  *((*((*queue_head).argument_header_ptr)).value_ptr.dataset),
  2575.                  "%lf",&tem_real);
  2576.                 if (num_fields_read == 0)
  2577.                   tem_real=0.0;
  2578.                 result_header_ptr=new_real_header_ptr();
  2579.                 if (! fatal_error)
  2580.                   *((*result_header_ptr).value_ptr.real)=tem_real;
  2581.               }
  2582.             else
  2583.               {
  2584.                 fatal_error=TRUE;
  2585.                 result_header_ptr=NULL;
  2586.                 printf(
  2587.         "Fatal error:  argument to GETREAL is other than a file pointer on\n");
  2588.                 printf("     line %ld, column %ld.\n",source_line_num,
  2589.                  source_column_num);
  2590.               }
  2591.           else
  2592.             result_header_ptr=NULL;
  2593.         else
  2594.           {
  2595.             fatal_error=TRUE;
  2596.             result_header_ptr=NULL;
  2597.             printf(
  2598.           "Fatal error:  extraneous argument supplied to function \"%s\" on\n",
  2599.              function_name);
  2600.             printf("     line %ld, column %ld.\n",source_line_num,
  2601.              source_column_num);
  2602.           }
  2603.       else
  2604.         if (evaluate)
  2605.           {
  2606.             num_fields_read=scanf("%lf",&tem_real);
  2607.             if (num_fields_read == 0)
  2608.               tem_real=0.0;
  2609.             result_header_ptr=new_real_header_ptr();
  2610.             if (! fatal_error)
  2611.               *((*result_header_ptr).value_ptr.real)=tem_real;
  2612.           }
  2613.         else
  2614.           result_header_ptr=NULL;
  2615.       return(result_header_ptr);
  2616.     }
  2617.  
  2618. static value_header_ptr getstring_header_ptr(queue_head,function_name,evaluate)
  2619.   queue_node_ptr queue_head;
  2620.   char           *function_name;
  2621.   int            evaluate;
  2622.     {
  2623.       int              current_char;
  2624.       value_header_ptr new_result_header_ptr;
  2625.       value_header_ptr result_header_ptr;
  2626.       unsigned         string_length;
  2627.  
  2628.       if (queue_head != NULL)
  2629.         if ((*queue_head).next == NULL)
  2630.           if (evaluate)
  2631.             if ((*((*queue_head).argument_header_ptr)).type == 'D')
  2632.               {
  2633.                 string_length=0;
  2634.                 result_header_ptr=new_string_header_ptr(string_length);
  2635.                 if (! fatal_error)
  2636.                   {
  2637.                     *((*((*result_header_ptr).value_ptr.string)).value)
  2638.                      =(unsigned char) '\0';
  2639.                     do
  2640.                       {
  2641.                         current_char=fgetc(
  2642.                          *((*((*queue_head).argument_header_ptr)).value_ptr.
  2643.                          dataset));
  2644.                         if ((current_char != EOF)
  2645.                         &&  (current_char != 10))
  2646.                           {
  2647.                             string_length++;
  2648.                             new_result_header_ptr
  2649.                              =new_string_header_ptr(string_length);
  2650.                             if (! fatal_error)
  2651.                               {
  2652.                                 pli_strcpy(
  2653.                                  (*new_result_header_ptr).value_ptr.string,
  2654.                                  (*result_header_ptr).value_ptr.string);
  2655.                                 (*((*new_result_header_ptr).value_ptr.string)).
  2656.                                  value[string_length-1]
  2657.                                  =(unsigned char) current_char;
  2658.                                 (*((*new_result_header_ptr).value_ptr.string)).
  2659.                                  value[string_length]=(unsigned char) '\0';
  2660.                                 free_value(result_header_ptr);
  2661.                                 result_header_ptr=new_result_header_ptr;
  2662.                               }
  2663.                           }
  2664.                       }
  2665.                     while ((! fatal_error)
  2666.                     &&     (current_char != EOF)
  2667.                     &&     (current_char != 10));
  2668.                     if ((*((*result_header_ptr).value_ptr.string)).value[
  2669.                      string_length-1] == (unsigned) 13)
  2670.                       {
  2671.                         string_length--;
  2672.                         (*((*result_header_ptr).value_ptr.string)).value[
  2673.                          string_length]=(unsigned char) '\0';
  2674.                         (*((*result_header_ptr).value_ptr.string)).length
  2675.                          =string_length;
  2676.                       }
  2677.                   }
  2678.               }
  2679.             else
  2680.               {
  2681.                 fatal_error=TRUE;
  2682.                 result_header_ptr=NULL;
  2683.                 printf(
  2684.       "Fatal error:  argument to GETSTRING is other than a file pointer on\n");
  2685.                 printf("     line %ld, column %ld.\n",source_line_num,
  2686.                  source_column_num);
  2687.               }
  2688.           else
  2689.             result_header_ptr=NULL;
  2690.         else
  2691.           {
  2692.             fatal_error=TRUE;
  2693.             result_header_ptr=NULL;
  2694.             printf(
  2695.           "Fatal error:  extraneous argument supplied to function \"%s\" on\n",
  2696.              function_name);
  2697.             printf("     line %ld, column %ld.\n",source_line_num,
  2698.              source_column_num);
  2699.           }
  2700.       else
  2701.         if (evaluate)
  2702.           {
  2703.             string_length=0;
  2704.             result_header_ptr=new_string_header_ptr(string_length);
  2705.             if (! fatal_error)
  2706.               {
  2707.                 *((*((*result_header_ptr).value_ptr.string)).value)
  2708.                  =(unsigned char) '\0';
  2709.                 fflush(stdin);
  2710.                 do
  2711.                   {
  2712.                     current_char=fgetc(stdin);
  2713.                     if ((current_char != EOF)
  2714.                     &&  (current_char != 10))
  2715.                       {
  2716.                         string_length++;
  2717.                         new_result_header_ptr
  2718.                          =new_string_header_ptr(string_length);
  2719.                         if (! fatal_error)
  2720.                           {
  2721.                             pli_strcpy(
  2722.                              (*new_result_header_ptr).value_ptr.string,
  2723.                              (*result_header_ptr).value_ptr.string);
  2724.                             (*((*new_result_header_ptr).value_ptr.string)).
  2725.                              value[string_length-1]
  2726.                              =(unsigned char) current_char;
  2727.                             (*((*new_result_header_ptr).value_ptr.string)).
  2728.                              value[string_length]=(unsigned char) '\0';
  2729.                             free_value(result_header_ptr);
  2730.                             result_header_ptr=new_result_header_ptr;
  2731.                           }
  2732.                       }
  2733.                   }
  2734.                 while ((! fatal_error)
  2735.                 &&     (current_char != EOF)
  2736.                 &&     (current_char != 10));
  2737.                 if ((*((*result_header_ptr).value_ptr.string)).value[
  2738.                  string_length-1] == (unsigned) 13)
  2739.                   {
  2740.                     string_length--;
  2741.                     (*((*result_header_ptr).value_ptr.string)).value[
  2742.                      string_length]=(unsigned char) '\0';
  2743.                     (*((*result_header_ptr).value_ptr.string)).length
  2744.                      =string_length;
  2745.                   }
  2746.               }
  2747.           }
  2748.         else
  2749.           result_header_ptr=NULL;
  2750.       return(result_header_ptr);
  2751.     }
  2752.  
  2753. static value_header_ptr index_header_ptr(queue_head,function_name,evaluate)
  2754.   queue_node_ptr queue_head;
  2755.   char           *function_name;
  2756.   int            evaluate;
  2757.     {
  2758.       long             char_index_2;
  2759.       unsigned char    *char_ptr_1;
  2760.       unsigned char    *char_ptr_2;
  2761.       unsigned char    *char_ptr_3;
  2762.       unsigned char    *char_ptr_4;
  2763.       unsigned char    *char_ptr_5;
  2764.       long             length_1;
  2765.       long             length_2;
  2766.       int              match_found;
  2767.       long             num_trials;
  2768.       long             result;
  2769.       value_header_ptr result_header_ptr;
  2770.  
  2771.       if (queue_head == NULL)
  2772.         {
  2773.           fatal_error=TRUE;
  2774.           result_header_ptr=NULL;
  2775.           printf(
  2776.           "Fatal error:  argument to function \"%s\" is missing on\n",
  2777.            function_name);
  2778.           printf("     line %ld, column %ld.\n",source_line_num,
  2779.            source_column_num);
  2780.         }
  2781.       else
  2782.         if ((*queue_head).next == NULL)
  2783.           {
  2784.             fatal_error=TRUE;
  2785.             result_header_ptr=NULL;
  2786.             printf(
  2787.              "Fatal error:  argument to function \"%s\" is missing on\n",
  2788.              function_name);
  2789.             printf("     line %ld, column %ld.\n",source_line_num,
  2790.              source_column_num);
  2791.           }
  2792.         else
  2793.           if ((*((*queue_head).next)).next == NULL)
  2794.             if (evaluate)
  2795.               if ((*((*queue_head).argument_header_ptr)).type == 'S')
  2796.                 if ((*((*((*queue_head).next)).argument_header_ptr)).type
  2797.                  == 'S')
  2798.                   {
  2799.                     result_header_ptr=new_integer_header_ptr();
  2800.                     if (! fatal_error)
  2801.                       {
  2802.                         char_ptr_1=(*((*((*queue_head).
  2803.                          argument_header_ptr)).value_ptr.string)).value;
  2804.                         length_1=(*((*((*queue_head).
  2805.                          argument_header_ptr)).value_ptr.string)).length;
  2806.                         char_ptr_2=(*((*((*((*queue_head).next)).
  2807.                          argument_header_ptr)).value_ptr.string)).value;
  2808.                         length_2=(*((*((*((*queue_head).next)).
  2809.                          argument_header_ptr)).value_ptr.string)).length;
  2810.                         if (length_2 == (long) 0)
  2811.                           *((*result_header_ptr).value_ptr.integer)=(long) 0;
  2812.                         else
  2813.                           {
  2814.                             num_trials=length_1-length_2+(long) 1;
  2815.                             char_ptr_3=char_ptr_1;
  2816.                             match_found=FALSE;
  2817.                             result=(long) 1;
  2818.                             while ((result <= num_trials)
  2819.                             &&     (! match_found))
  2820.                               {
  2821.                                 char_ptr_4=char_ptr_2;
  2822.                                 char_index_2=(long) 1;
  2823.                                 char_ptr_5=char_ptr_3;
  2824.                                 while ((char_index_2 <= length_2)
  2825.                                 &&     (*char_ptr_4 == *char_ptr_5))
  2826.                                   {
  2827.                                     char_ptr_4++;
  2828.                                     char_ptr_5++;
  2829.                                     char_index_2++;
  2830.                                   }
  2831.                                 if (char_index_2 > length_2)
  2832.                                   match_found=TRUE;
  2833.                                 else
  2834.                                   {
  2835.                                     char_ptr_3++;
  2836.                                     result++;
  2837.                                   }
  2838.                               }
  2839.                             if (match_found)
  2840.                               *((*result_header_ptr).value_ptr.integer)=result;
  2841.                             else
  2842.                               *((*result_header_ptr).value_ptr.integer)
  2843.                                =(long) 0;
  2844.                           }
  2845.                       }
  2846.                   }
  2847.                 else
  2848.                   {
  2849.                     fatal_error=TRUE;
  2850.                     result_header_ptr=NULL;
  2851.                     printf(
  2852.             "Fatal error:  second argument to INDEX is other than a string\n");
  2853.                     printf("     on line %ld, column %ld.\n",source_line_num,
  2854.                      source_column_num);
  2855.                   }
  2856.               else
  2857.                 {
  2858.                   fatal_error=TRUE;
  2859.                   result_header_ptr=NULL;
  2860.                   printf(
  2861.              "Fatal error:  first argument to INDEX is other than a string\n");
  2862.                   printf("     on line %ld, column %ld.\n",source_line_num,
  2863.                    source_column_num);
  2864.                 }
  2865.             else
  2866.               result_header_ptr=NULL;
  2867.           else
  2868.             {
  2869.               fatal_error=TRUE;
  2870.               result_header_ptr=NULL;
  2871.               printf(
  2872.           "Fatal error:  extraneous argument supplied to function \"%s\" on\n",
  2873.                function_name);
  2874.               printf("     line %ld, column %ld.\n",source_line_num,
  2875.                source_column_num);
  2876.             }
  2877.       return(result_header_ptr);
  2878.     }
  2879.  
  2880. static value_header_ptr length_header_ptr(queue_head,function_name,evaluate)
  2881.   queue_node_ptr queue_head;
  2882.   char           *function_name;
  2883.   int            evaluate;
  2884.     {
  2885.       value_header_ptr result_header_ptr;
  2886.  
  2887.       if (queue_head == NULL)
  2888.         {
  2889.           fatal_error=TRUE;
  2890.           result_header_ptr=NULL;
  2891.           printf(
  2892.           "Fatal error:  argument to function \"%s\" is missing on\n",
  2893.            function_name);
  2894.           printf("     line %ld, column %ld.\n",source_line_num,
  2895.            source_column_num);
  2896.         }
  2897.       else
  2898.         if ((*queue_head).next == NULL)
  2899.           if (evaluate)
  2900.             if ((*((*queue_head).argument_header_ptr)).type == 'S')
  2901.               {
  2902.                 result_header_ptr=new_integer_header_ptr();
  2903.                 if (! fatal_error)
  2904.                   *((*result_header_ptr).value_ptr.integer)=(long)
  2905.                    (*((*((*queue_head).argument_header_ptr)).
  2906.                    value_ptr.string)).length;
  2907.               }
  2908.             else
  2909.               {
  2910.                 fatal_error=TRUE;
  2911.                 result_header_ptr=NULL;
  2912.                 printf(
  2913.                  "Fatal error:  argument to LENGTH is other than a string\n");
  2914.                 printf("     on line %ld, column %ld.\n",source_line_num,
  2915.                  source_column_num);
  2916.               }
  2917.           else
  2918.             result_header_ptr=NULL;
  2919.         else
  2920.           {
  2921.             fatal_error=TRUE;
  2922.             result_header_ptr=NULL;
  2923.             printf(
  2924.           "Fatal error:  extraneous argument supplied to function \"%s\" on\n",
  2925.              function_name);
  2926.             printf("     line %ld, column %ld.\n",source_line_num,
  2927.              source_column_num);
  2928.           }
  2929.       return(result_header_ptr);
  2930.     }
  2931.  
  2932. static value_header_ptr lineno_header_ptr(queue_head,function_name,evaluate)
  2933.   queue_node_ptr queue_head;
  2934.   char           *function_name;
  2935.   int            evaluate;
  2936.     {
  2937.       value_header_ptr result_header_ptr;
  2938.  
  2939.       if (queue_head != NULL)
  2940.         {
  2941.           fatal_error=TRUE;
  2942.           result_header_ptr=NULL;
  2943.           printf(
  2944.           "Fatal error:  extraneous argument supplied to function \"%s\" on\n",
  2945.            function_name);
  2946.           printf("     line %ld, column %ld.\n",source_line_num,
  2947.            source_column_num);
  2948.         }
  2949.       else
  2950.         if (evaluate)
  2951.           {
  2952.             result_header_ptr=new_integer_header_ptr();
  2953.             if (! fatal_error)
  2954.               *((*result_header_ptr).value_ptr.integer)=source_line_num;
  2955.           }
  2956.         else
  2957.           result_header_ptr=NULL;
  2958.       return(result_header_ptr);
  2959.     }
  2960.  
  2961. static value_header_ptr log_header_ptr(queue_head,function_name,evaluate)
  2962.   queue_node_ptr queue_head;
  2963.   char           *function_name;
  2964.   int            evaluate;
  2965.     {
  2966.       value_header_ptr result_header_ptr;
  2967.       double           tem_real;
  2968.  
  2969.       if (queue_head == NULL)
  2970.         {
  2971.           fatal_error=TRUE;
  2972.           result_header_ptr=NULL;
  2973.           printf(
  2974.           "Fatal error:  argument to function \"%s\" is missing on\n",
  2975.            function_name);
  2976.           printf("     line %ld, column %ld.\n",source_line_num,
  2977.            source_column_num);
  2978.         }
  2979.       else
  2980.         if ((*queue_head).next == NULL)
  2981.           if (evaluate)
  2982.             if ((*((*queue_head).argument_header_ptr)).type == 'I')
  2983.               {
  2984.                 tem_real=(double) *((*((*queue_head).argument_header_ptr)).
  2985.                    value_ptr.integer);
  2986.                 result_header_ptr=new_real_header_ptr();
  2987.                 if (! fatal_error)
  2988.                   {
  2989.                     if (tem_real > 0.0)
  2990.                       *((*result_header_ptr).value_ptr.real)=log(tem_real);
  2991.                     else
  2992.                       {
  2993.                         fatal_error=TRUE;
  2994.                         free_value(result_header_ptr);
  2995.                         result_header_ptr=NULL;
  2996.                         printf(
  2997.     "Fatal error:  argument to LOG is not positive at line %ld, column %ld.\n",
  2998.                          source_line_num,source_column_num);
  2999.                       }
  3000.                   }
  3001.               }
  3002.             else
  3003.               if ((*((*queue_head).argument_header_ptr)).type == 'R')
  3004.                 {
  3005.                   tem_real=*((*((*queue_head).argument_header_ptr)).
  3006.                      value_ptr.real);
  3007.                   result_header_ptr=new_real_header_ptr();
  3008.                   if (! fatal_error)
  3009.                     {
  3010.                       if (tem_real > 0.0)
  3011.                         *((*result_header_ptr).value_ptr.real)=log(tem_real);
  3012.                       else
  3013.                         {
  3014.                           fatal_error=TRUE;
  3015.                           free_value(result_header_ptr);
  3016.                           result_header_ptr=NULL;
  3017.                           printf(
  3018.     "Fatal error:  argument to LOG is not positive at line %ld, column %ld.\n",
  3019.                            source_line_num,source_column_num);
  3020.                         }
  3021.                     }
  3022.                 }
  3023.               else
  3024.                 {
  3025.                   fatal_error=TRUE;
  3026.                   result_header_ptr=NULL;
  3027.                   printf(
  3028. "Fatal error:  other than a number supplied as argument to function \"%s\"\n",
  3029.                    function_name);
  3030.                   printf("     on line %ld, column %ld.\n",source_line_num,
  3031.                    source_column_num);
  3032.                 }
  3033.           else
  3034.             result_header_ptr=NULL;
  3035.         else
  3036.           {
  3037.             fatal_error=TRUE;
  3038.             result_header_ptr=NULL;
  3039.             printf(
  3040.           "Fatal error:  extraneous argument supplied to function \"%s\" on\n",
  3041.              function_name);
  3042.             printf("     line %ld, column %ld.\n",source_line_num,
  3043.              source_column_num);
  3044.           }
  3045.       return(result_header_ptr);
  3046.     }
  3047.  
  3048. static value_header_ptr mod_header_ptr(queue_head,function_name,evaluate)
  3049.   queue_node_ptr queue_head;
  3050.   char           *function_name;
  3051.   int            evaluate;
  3052.     {
  3053.       value_header_ptr result_header_ptr;
  3054.       long             tem_int_1;
  3055.       long             tem_int_2;
  3056.       long             tem_int_3;
  3057.  
  3058.       if (queue_head == NULL)
  3059.         {
  3060.           fatal_error=TRUE;
  3061.           result_header_ptr=NULL;
  3062.           printf(
  3063.           "Fatal error:  argument to function \"%s\" is missing on\n",
  3064.            function_name);
  3065.           printf("     line %ld, column %ld.\n",source_line_num,
  3066.            source_column_num);
  3067.         }
  3068.       else
  3069.         if ((*queue_head).next == NULL)
  3070.           {
  3071.             fatal_error=TRUE;
  3072.             result_header_ptr=NULL;
  3073.             printf(
  3074.              "Fatal error:  argument to function \"%s\" is missing on\n",
  3075.              function_name);
  3076.             printf("     line %ld, column %ld.\n",source_line_num,
  3077.              source_column_num);
  3078.           }
  3079.         else
  3080.           if ((*((*queue_head).next)).next == NULL)
  3081.             if (evaluate)
  3082.               if ((*((*queue_head).argument_header_ptr)).type == 'I')
  3083.                 if ((*((*((*queue_head).next)).argument_header_ptr)).type
  3084.                  == 'I')
  3085.                   if (*((*((*((*queue_head).next)).argument_header_ptr)).
  3086.                    value_ptr.integer) == 0)
  3087.                     {
  3088.                       fatal_error=TRUE;
  3089.                       result_header_ptr=NULL;
  3090.                       printf(
  3091.                        "Fatal error:  second argument to MOD is zero\n");
  3092.                       printf("     on line %ld, column %ld.\n",source_line_num,
  3093.                        source_column_num);
  3094.                     }
  3095.                   else
  3096.                     {
  3097.                       result_header_ptr=new_integer_header_ptr();
  3098.                       if (! fatal_error)
  3099.                         {
  3100.                           tem_int_1
  3101.                            =*((*((*queue_head).argument_header_ptr)).
  3102.                            value_ptr.integer);
  3103.                           tem_int_2
  3104.                            =*((*((*((*queue_head).next)).argument_header_ptr)).
  3105.                            value_ptr.integer);
  3106.                           tem_int_3=tem_int_1/tem_int_2;
  3107.                           tem_int_3*=tem_int_2;
  3108.                           *((*result_header_ptr).value_ptr.integer)
  3109.                            =tem_int_1-tem_int_3;
  3110.                         }
  3111.                     }
  3112.                 else
  3113.                   {
  3114.                     fatal_error=TRUE;
  3115.                     result_header_ptr=NULL;
  3116.                     printf(
  3117.             "Fatal error:  second argument to MOD is other than an integer\n");
  3118.                     printf("     on line %ld, column %ld.\n",source_line_num,
  3119.                      source_column_num);
  3120.                   }
  3121.               else
  3122.                 {
  3123.                   fatal_error=TRUE;
  3124.                   result_header_ptr=NULL;
  3125.                   printf(
  3126.              "Fatal error:  first argument to MOD is other than an integer\n");
  3127.                   printf("     on line %ld, column %ld.\n",source_line_num,
  3128.                    source_column_num);
  3129.                 }
  3130.             else
  3131.               result_header_ptr=NULL;
  3132.           else
  3133.             {
  3134.               fatal_error=TRUE;
  3135.               result_header_ptr=NULL;
  3136.               printf(
  3137.           "Fatal error:  extraneous argument supplied to function \"%s\" on\n",
  3138.                function_name);
  3139.               printf("     line %ld, column %ld.\n",source_line_num,
  3140.                source_column_num);
  3141.             }
  3142.       return(result_header_ptr);
  3143.     }
  3144.  
  3145. static value_header_ptr open_header_ptr(queue_head,function_name,evaluate)
  3146.   queue_node_ptr queue_head;
  3147.   char           *function_name;
  3148.   int            evaluate;
  3149.     {
  3150.       value_header_ptr result_header_ptr;
  3151.  
  3152.       if (queue_head == NULL)
  3153.         {
  3154.           fatal_error=TRUE;
  3155.           result_header_ptr=NULL;
  3156.           printf(
  3157.           "Fatal error:  argument to function \"%s\" is missing on\n",
  3158.            function_name);
  3159.           printf("     line %ld, column %ld.\n",source_line_num,
  3160.            source_column_num);
  3161.         }
  3162.       else
  3163.         if ((*queue_head).next == NULL)
  3164.           {
  3165.             fatal_error=TRUE;
  3166.             result_header_ptr=NULL;
  3167.             printf(
  3168.              "Fatal error:  argument to function \"%s\" is missing on\n",
  3169.              function_name);
  3170.             printf("     line %ld, column %ld.\n",source_line_num,
  3171.              source_column_num);
  3172.           }
  3173.         else
  3174.           if ((*((*queue_head).next)).next == NULL)
  3175.             if (evaluate)
  3176.               if ((*((*queue_head).argument_header_ptr)).type == 'S')
  3177.                 if ((*((*((*queue_head).next)).argument_header_ptr)).type
  3178.                  == 'S')
  3179.                   {
  3180.                     result_header_ptr=new_dataset_header_ptr();
  3181.                     if (! fatal_error)
  3182.                       {
  3183.                         *((*result_header_ptr).value_ptr.dataset)
  3184.                          =fopen((*((*((*queue_head).
  3185.                          argument_header_ptr)).value_ptr.string)).value,
  3186.                          (*((*((*((*queue_head).next)).
  3187.                          argument_header_ptr)).value_ptr.string)).value);
  3188.                         if (*((*result_header_ptr).value_ptr.dataset) == NULL)
  3189.                           {
  3190.                             fatal_error=TRUE;
  3191.                             free_value(result_header_ptr);
  3192.                             result_header_ptr=NULL;
  3193.                             printf(
  3194.                         "Fatal error:  cannot OPEN \"%s\" in mode \"%s\" on\n",
  3195.                              (*((*((*queue_head).argument_header_ptr)).
  3196.                              value_ptr.string)).value,
  3197.                              (*((*((*((*queue_head).next)).
  3198.                              argument_header_ptr)).value_ptr.string)).value);
  3199.                             printf("     on line %ld, column %ld.\n",
  3200.                              source_line_num,source_column_num);
  3201.                           }
  3202.                       }
  3203.                   }
  3204.                 else
  3205.                   {
  3206.                     fatal_error=TRUE;
  3207.                     result_header_ptr=NULL;
  3208.                     printf(
  3209.             "Fatal error:  second argument to OPEN is other than a string\n");
  3210.                     printf("     on line %ld, column %ld.\n",source_line_num,
  3211.                      source_column_num);
  3212.                   }
  3213.               else
  3214.                 {
  3215.                   fatal_error=TRUE;
  3216.                   result_header_ptr=NULL;
  3217.                   printf(
  3218.              "Fatal error:  first argument to OPEN is other than a string\n");
  3219.                   printf("     on line %ld, column %ld.\n",source_line_num,
  3220.                    source_column_num);
  3221.                 }
  3222.             else
  3223.               result_header_ptr=NULL;
  3224.           else
  3225.             {
  3226.               fatal_error=TRUE;
  3227.               result_header_ptr=NULL;
  3228.               printf(
  3229.           "Fatal error:  extraneous argument supplied to function \"%s\" on\n",
  3230.                function_name);
  3231.               printf("     line %ld, column %ld.\n",source_line_num,
  3232.                source_column_num);
  3233.             }
  3234.       return(result_header_ptr);
  3235.     }
  3236.  
  3237. static value_header_ptr ord_header_ptr(queue_head,function_name,evaluate)
  3238.   queue_node_ptr queue_head;
  3239.   char           *function_name;
  3240.   int            evaluate;
  3241.     {
  3242.       value_header_ptr result_header_ptr;
  3243.  
  3244.       if (queue_head == NULL)
  3245.         {
  3246.           fatal_error=TRUE;
  3247.           result_header_ptr=NULL;
  3248.           printf(
  3249.           "Fatal error:  argument to function \"%s\" is missing on\n",
  3250.            function_name);
  3251.           printf("     line %ld, column %ld.\n",source_line_num,
  3252.            source_column_num);
  3253.         }
  3254.       else
  3255.         if ((*queue_head).next == NULL)
  3256.           if (evaluate)
  3257.             if ((*((*queue_head).argument_header_ptr)).type == 'S')
  3258.               if ((*((*((*queue_head).argument_header_ptr)).value_ptr.string)).
  3259.                length == 0)
  3260.                 {
  3261.                   fatal_error=TRUE;
  3262.                   result_header_ptr=NULL;
  3263.                   printf(
  3264.                    "Fatal error:  argument to ORD has length zero\n");
  3265.                   printf("     on line %ld, column %ld.\n",source_line_num,
  3266.                    source_column_num);
  3267.                 }
  3268.               else
  3269.                 {
  3270.                   result_header_ptr=new_integer_header_ptr();
  3271.                   if (! fatal_error)
  3272.                     *((*result_header_ptr).value_ptr.integer)
  3273.                      =(long) *((*((*((*queue_head).argument_header_ptr)).
  3274.                      value_ptr.string)).value);
  3275.                 }
  3276.             else
  3277.               {
  3278.                 fatal_error=TRUE;
  3279.                 result_header_ptr=NULL;
  3280.                 printf(
  3281.                  "Fatal error:  argument to ORD is other than a string\n");
  3282.                 printf("     on line %ld, column %ld.\n",source_line_num,
  3283.                  source_column_num);
  3284.               }
  3285.           else
  3286.             result_header_ptr=NULL;
  3287.         else
  3288.           {
  3289.             fatal_error=TRUE;
  3290.             result_header_ptr=NULL;
  3291.             printf(
  3292.           "Fatal error:  extraneous argument supplied to function \"%s\" on\n",
  3293.              function_name);
  3294.             printf("     line %ld, column %ld.\n",source_line_num,
  3295.              source_column_num);
  3296.           }
  3297.       return(result_header_ptr);
  3298.     }
  3299.  
  3300. static value_header_ptr pi_header_ptr(queue_head,function_name,evaluate)
  3301.   queue_node_ptr queue_head;
  3302.   char           *function_name;
  3303.   int            evaluate;
  3304.     {
  3305.       value_header_ptr result_header_ptr;
  3306.  
  3307.       if (queue_head != NULL)
  3308.         {
  3309.           fatal_error=TRUE;
  3310.           result_header_ptr=NULL;
  3311.           printf(
  3312.           "Fatal error:  extraneous argument supplied to function \"%s\" on\n",
  3313.            function_name);
  3314.           printf("     line %ld, column %ld.\n",source_line_num,
  3315.            source_column_num);
  3316.         }
  3317.       else
  3318.         if (evaluate)
  3319.           {
  3320.             result_header_ptr=new_real_header_ptr();
  3321.             if (! fatal_error)
  3322.               *((*result_header_ptr).value_ptr.real)=4.0*atan(1.0);
  3323.           }
  3324.         else
  3325.           result_header_ptr=NULL;
  3326.       return(result_header_ptr);
  3327.     }
  3328.  
  3329. static value_header_ptr pliretv_header_ptr(queue_head,function_name,evaluate)
  3330.   queue_node_ptr queue_head;
  3331.   char           *function_name;
  3332.   int            evaluate;
  3333.     {
  3334.       value_header_ptr result_header_ptr;
  3335.  
  3336.       if (queue_head != NULL)
  3337.         {
  3338.           fatal_error=TRUE;
  3339.           result_header_ptr=NULL;
  3340.           printf(
  3341.           "Fatal error:  extraneous argument supplied to function \"%s\" on\n",
  3342.            function_name);
  3343.           printf("     line %ld, column %ld.\n",source_line_num,
  3344.            source_column_num);
  3345.         }
  3346.       else
  3347.         if (evaluate)
  3348.           {
  3349.             result_header_ptr=new_integer_header_ptr();
  3350.             if (! fatal_error)
  3351.               *((*result_header_ptr).value_ptr.integer)=return_code;
  3352.           }
  3353.         else
  3354.           result_header_ptr=NULL;
  3355.       return(result_header_ptr);
  3356.     }
  3357.  
  3358. static value_header_ptr repeat_header_ptr(queue_head,function_name,evaluate)
  3359.   queue_node_ptr queue_head;
  3360.   char           *function_name;
  3361.   int            evaluate;
  3362.     {
  3363.       long             char_index;
  3364.       unsigned char    *char_ptr_1;
  3365.       unsigned char    *char_ptr_2;
  3366.       unsigned char    *char_ptr_3;
  3367.       value_header_ptr result_header_ptr;
  3368.       long             tem_int_1;
  3369.       long             tem_int_2;
  3370.       long             result_length;
  3371.       double           tem_real_1;
  3372.       double           tem_real_2;
  3373.       double           tem_real_3;
  3374.  
  3375.       if (queue_head == NULL)
  3376.         {
  3377.           fatal_error=TRUE;
  3378.           result_header_ptr=NULL;
  3379.           printf(
  3380.           "Fatal error:  argument to function \"%s\" is missing on\n",
  3381.            function_name);
  3382.           printf("     line %ld, column %ld.\n",source_line_num,
  3383.            source_column_num);
  3384.         }
  3385.       else
  3386.         if ((*queue_head).next == NULL)
  3387.           {
  3388.             fatal_error=TRUE;
  3389.             result_header_ptr=NULL;
  3390.             printf(
  3391.              "Fatal error:  argument to function \"%s\" is missing on\n",
  3392.              function_name);
  3393.             printf("     line %ld, column %ld.\n",source_line_num,
  3394.              source_column_num);
  3395.           }
  3396.         else
  3397.           if ((*((*queue_head).next)).next == NULL)
  3398.             if (evaluate)
  3399.               if ((*((*queue_head).argument_header_ptr)).type == 'S')
  3400.                 if ((*((*((*queue_head).next)).argument_header_ptr)).type
  3401.                  == 'I')
  3402.                   {
  3403.                     char_ptr_1=(*((*((*queue_head).argument_header_ptr)).
  3404.                      value_ptr.string)).value;
  3405.                     tem_int_1=(*((*((*queue_head).argument_header_ptr)).
  3406.                      value_ptr.string)).length;
  3407.                     tem_int_2
  3408.                      =*((*((*((*queue_head).next)).
  3409.                      argument_header_ptr)).value_ptr.integer);
  3410.                     if (tem_int_2 >= (long) 0)
  3411.                       if (tem_int_1 == 0)
  3412.                         {
  3413.                           result_header_ptr
  3414.                            =new_string_header_ptr((unsigned) 0);
  3415.                           if (! fatal_error)
  3416.                             *((*((*result_header_ptr).value_ptr.string)).value)
  3417.                             =(unsigned char) '\0';
  3418.                         }
  3419.                       else
  3420.                         {
  3421.                           tem_real_1=(double) tem_int_1;
  3422.                           tem_real_2=(double) tem_int_2;
  3423.                           tem_real_3
  3424.                            =(log(fabs(tem_real_1))+log(fabs(tem_real_2+1.0)))
  3425.                            /log(2.0);
  3426.                           if (tem_real_3 >= 15.0)
  3427.                             {
  3428.                               fatal_error=TRUE;
  3429.                               result_header_ptr=NULL;
  3430.                              printf(
  3431.                           "Fatal error:  result of REPEAT too long on line\n");
  3432.                               printf(
  3433.                                "     %ld, column %ld.\n",source_line_num,
  3434.                                source_column_num);
  3435.                             }
  3436.                           else
  3437.                             {
  3438.                               result_length=tem_int_1;
  3439.                               result_length*=(tem_int_2+(long) 1);
  3440.                               result_header_ptr
  3441.                                =new_string_header_ptr(
  3442.                                (unsigned) result_length);
  3443.                               if (! fatal_error)
  3444.                                 {
  3445.                                   char_ptr_3
  3446.                                    =(*((*result_header_ptr).value_ptr.string)).
  3447.                                    value;
  3448.                                   while (tem_int_2 >= (long) 0)
  3449.                                     {
  3450.                                       char_ptr_2=char_ptr_1;
  3451.                                       for (char_index=(long) 0;
  3452.                                        char_index < tem_int_1;
  3453.                                        char_index++)
  3454.                                         {
  3455.                                           *char_ptr_3=*char_ptr_2;
  3456.                                           char_ptr_3++;
  3457.                                           char_ptr_2++;
  3458.                                         }
  3459.                                       tem_int_2--;
  3460.                                     }
  3461.                                 }
  3462.                             }
  3463.                         }
  3464.                     else
  3465.                       result_header_ptr=copy_of_arguments(
  3466.                        (*queue_head).argument_header_ptr);
  3467.                   }
  3468.                 else
  3469.                   {
  3470.                     fatal_error=TRUE;
  3471.                     result_header_ptr=NULL;
  3472.                     printf(
  3473.          "Fatal error:  second argument to REPEAT is other than an integer\n");
  3474.                     printf("     on line %ld, column %ld.\n",source_line_num,
  3475.                      source_column_num);
  3476.                   }
  3477.               else
  3478.                 {
  3479.                   fatal_error=TRUE;
  3480.                   result_header_ptr=NULL;
  3481.                   printf(
  3482.             "Fatal error:  first argument to REPEAT is other than a string\n");
  3483.                   printf("     on line %ld, column %ld.\n",source_line_num,
  3484.                    source_column_num);
  3485.                 }
  3486.             else
  3487.               result_header_ptr=NULL;
  3488.           else
  3489.             {
  3490.               fatal_error=TRUE;
  3491.               result_header_ptr=NULL;
  3492.               printf(
  3493.           "Fatal error:  extraneous argument supplied to function \"%s\" on\n",
  3494.                function_name);
  3495.               printf("     line %ld, column %ld.\n",source_line_num,
  3496.                source_column_num);
  3497.             }
  3498.       return(result_header_ptr);
  3499.     }
  3500.  
  3501. static value_header_ptr sin_header_ptr(queue_head,function_name,evaluate)
  3502.   queue_node_ptr queue_head;
  3503.   char           *function_name;
  3504.   int            evaluate;
  3505.     {
  3506.       value_header_ptr result_header_ptr;
  3507.       double           tem_real;
  3508.  
  3509.       if (queue_head == NULL)
  3510.         {
  3511.           fatal_error=TRUE;
  3512.           result_header_ptr=NULL;
  3513.           printf(
  3514.           "Fatal error:  argument to function \"%s\" is missing on\n",
  3515.            function_name);
  3516.           printf("     line %ld, column %ld.\n",source_line_num,
  3517.            source_column_num);
  3518.         }
  3519.       else
  3520.         if ((*queue_head).next == NULL)
  3521.           if (evaluate)
  3522.             if ((*((*queue_head).argument_header_ptr)).type == 'I')
  3523.               {
  3524.                 tem_real=(double) *((*((*queue_head).argument_header_ptr)).
  3525.                    value_ptr.integer);
  3526.                 result_header_ptr=new_real_header_ptr();
  3527.                 if (! fatal_error)
  3528.                   *((*result_header_ptr).value_ptr.real)=sin(tem_real);
  3529.               }
  3530.             else
  3531.               if ((*((*queue_head).argument_header_ptr)).type == 'R')
  3532.                 {
  3533.                   result_header_ptr=new_real_header_ptr();
  3534.                   if (! fatal_error)
  3535.                     *((*result_header_ptr).value_ptr.real)
  3536.                      =sin(*((*((*queue_head).argument_header_ptr)).
  3537.                      value_ptr.real));
  3538.                 }
  3539.               else
  3540.                 {
  3541.                   fatal_error=TRUE;
  3542.                   result_header_ptr=NULL;
  3543.                   printf(
  3544. "Fatal error:  other than a number supplied as argument to function \"%s\"\n",
  3545.                    function_name);
  3546.                   printf("     on line %ld, column %ld.\n",source_line_num,
  3547.                    source_column_num);
  3548.                 }
  3549.           else
  3550.             result_header_ptr=NULL;
  3551.         else
  3552.           {
  3553.             fatal_error=TRUE;
  3554.             result_header_ptr=NULL;
  3555.             printf(
  3556.           "Fatal error:  extraneous argument supplied to function \"%s\" on\n",
  3557.              function_name);
  3558.             printf("     line %ld, column %ld.\n",source_line_num,
  3559.              source_column_num);
  3560.           }
  3561.       return(result_header_ptr);
  3562.     }
  3563.  
  3564. static value_header_ptr sqr_header_ptr(queue_head,function_name,evaluate)
  3565.   queue_node_ptr queue_head;
  3566.   char           *function_name;
  3567.   int            evaluate;
  3568.     {
  3569.       value_header_ptr result_header_ptr;
  3570.       long             tem_integer;
  3571.       double           tem_real_1;
  3572.       double           tem_real_2;
  3573.  
  3574.       if (queue_head == NULL)
  3575.         {
  3576.           fatal_error=TRUE;
  3577.           result_header_ptr=NULL;
  3578.           printf(
  3579.           "Fatal error:  argument to function \"%s\" is missing on\n",
  3580.            function_name);
  3581.           printf("     line %ld, column %ld.\n",source_line_num,
  3582.            source_column_num);
  3583.         }
  3584.       else
  3585.         if ((*queue_head).next == NULL)
  3586.           if (evaluate)
  3587.             if ((*((*queue_head).argument_header_ptr)).type == 'I')
  3588.               {
  3589.                 result_header_ptr=new_integer_header_ptr();
  3590.                 if (! fatal_error)
  3591.                   {
  3592.                     tem_integer
  3593.                      =*((*((*queue_head).argument_header_ptr)).
  3594.                      value_ptr.integer);
  3595.                     if (tem_integer == 0)
  3596.                       *((*result_header_ptr).value_ptr.integer)=0;
  3597.                     else
  3598.                       {
  3599.                         tem_real_1=(double) tem_integer;
  3600.                         tem_real_2=2.0*log(fabs(tem_real_1))/log(2.0);
  3601.                         if (tem_real_2 >= 31.0)
  3602.                           {
  3603.                             fatal_error=TRUE;
  3604.                             free_value(result_header_ptr);
  3605.                             result_header_ptr=NULL;
  3606.                             printf(
  3607.           "Fatal error:  argument to SQR too large on line %ld, column %ld.\n",
  3608.                              source_line_num,source_column_num);
  3609.                           }
  3610.                         else
  3611.                           *((*result_header_ptr).value_ptr.integer)
  3612.                            =tem_integer*tem_integer;
  3613.                       }
  3614.                   }
  3615.               }
  3616.             else
  3617.               if ((*((*queue_head).argument_header_ptr)).type == 'R')
  3618.                 {
  3619.                   result_header_ptr=new_real_header_ptr();
  3620.                   if (! fatal_error)
  3621.                     {
  3622.                       tem_real_1
  3623.                        =*((*((*queue_head).argument_header_ptr)).
  3624.                        value_ptr.real);
  3625.                       if (tem_real_1 == 0.0)
  3626.                         *((*result_header_ptr).value_ptr.real)=0.0;
  3627.                       else
  3628.                         {
  3629.                           tem_real_2=2.0*log(fabs(tem_real_1))/log(10.0);
  3630.                           if (tem_real_2 < -37.0)
  3631.                             *((*result_header_ptr).value_ptr.real)=0.0;
  3632.                           else
  3633.                             if (tem_real_2 > 37.0)
  3634.                               {
  3635.                                 fatal_error=TRUE;
  3636.                                 free_value(result_header_ptr);
  3637.                                 result_header_ptr=NULL;
  3638.                                 printf(
  3639.           "Fatal error:  argument to SQR too large on line %ld, column %ld.\n",
  3640.                                  source_line_num,source_column_num);
  3641.                               }
  3642.                             else
  3643.                               *((*result_header_ptr).value_ptr.real)
  3644.                                =tem_real_1*tem_real_1;
  3645.                         }
  3646.                     }
  3647.                 }
  3648.               else
  3649.                 {
  3650.                   fatal_error=TRUE;
  3651.                   result_header_ptr=NULL;
  3652.                   printf(
  3653. "Fatal error:  other than a number supplied as argument to function \"%s\"\n",
  3654.                    function_name);
  3655.                   printf("     on line %ld, column %ld.\n",source_line_num,
  3656.                    source_column_num);
  3657.                 }
  3658.           else
  3659.             result_header_ptr=NULL;
  3660.         else
  3661.           {
  3662.             fatal_error=TRUE;
  3663.             result_header_ptr=NULL;
  3664.             printf(
  3665.           "Fatal error:  extraneous argument supplied to function \"%s\" on\n",
  3666.              function_name);
  3667.             printf("     line %ld, column %ld.\n",source_line_num,
  3668.              source_column_num);
  3669.           }
  3670.       return(result_header_ptr);
  3671.     }
  3672.  
  3673. static value_header_ptr sqrt_header_ptr(queue_head,function_name,evaluate)
  3674.   queue_node_ptr queue_head;
  3675.   char           *function_name;
  3676.   int            evaluate;
  3677.     {
  3678.       value_header_ptr result_header_ptr;
  3679.       double           tem_real;
  3680.  
  3681.       if (queue_head == NULL)
  3682.         {
  3683.           fatal_error=TRUE;
  3684.           result_header_ptr=NULL;
  3685.           printf(
  3686.           "Fatal error:  argument to function \"%s\" is missing on\n",
  3687.            function_name);
  3688.           printf("     line %ld, column %ld.\n",source_line_num,
  3689.            source_column_num);
  3690.         }
  3691.       else
  3692.         if ((*queue_head).next == NULL)
  3693.           if (evaluate)
  3694.             if ((*((*queue_head).argument_header_ptr)).type == 'I')
  3695.                 {
  3696.                   tem_real=(double) *((*((*queue_head).argument_header_ptr)).
  3697.                    value_ptr.integer);
  3698.                   if (tem_real < 0.0)
  3699.                     {
  3700.                       fatal_error=TRUE;
  3701.                       result_header_ptr=NULL;
  3702.                       printf(
  3703.                      "Fatal error:  argument to function \"%s\" is negative\n",
  3704.                        function_name);
  3705.                       printf("     on line %ld, column %ld.\n",source_line_num,
  3706.                        source_column_num);
  3707.                     }
  3708.                   else
  3709.                     {
  3710.                       tem_real=sqrt(tem_real);
  3711.                       result_header_ptr=new_real_header_ptr();
  3712.                       if (! fatal_error)
  3713.                         *((*result_header_ptr).value_ptr.real)=tem_real;
  3714.                     }
  3715.                 }
  3716.             else
  3717.               if ((*((*queue_head).argument_header_ptr)).type == 'R')
  3718.                 {
  3719.                   tem_real=*((*((*queue_head).argument_header_ptr)).
  3720.                    value_ptr.real);
  3721.                   if (tem_real < 0.0)
  3722.                     {
  3723.                       fatal_error=TRUE;
  3724.                       result_header_ptr=NULL;
  3725.                       printf(
  3726.                      "Fatal error:  argument to function \"%s\" is negative\n",
  3727.                        function_name);
  3728.                       printf("     on line %ld, column %ld.\n",source_line_num,
  3729.                        source_column_num);
  3730.                     }
  3731.                   else
  3732.                     {
  3733.                       tem_real=sqrt(tem_real);
  3734.                       result_header_ptr=new_real_header_ptr();
  3735.                       if (! fatal_error)
  3736.                         *((*result_header_ptr).value_ptr.real)=tem_real;
  3737.                     }
  3738.                 }
  3739.               else
  3740.                 {
  3741.                   fatal_error=TRUE;
  3742.                   result_header_ptr=NULL;
  3743.                   printf(
  3744. "Fatal error:  other than a number supplied as argument to function \"%s\"\n",
  3745.                    function_name);
  3746.                   printf("     on line %ld, column %ld.\n",source_line_num,
  3747.                    source_column_num);
  3748.                 }
  3749.           else
  3750.             result_header_ptr=NULL;
  3751.         else
  3752.           {
  3753.             fatal_error=TRUE;
  3754.             result_header_ptr=NULL;
  3755.             printf(
  3756.           "Fatal error:  extraneous argument supplied to function \"%s\" on\n",
  3757.              function_name);
  3758.             printf("     line %ld, column %ld.\n",source_line_num,
  3759.              source_column_num);
  3760.           }
  3761.       return(result_header_ptr);
  3762.     }
  3763.  
  3764. static value_header_ptr str_header_ptr(queue_head,function_name,evaluate)
  3765.   queue_node_ptr queue_head;
  3766.   char           *function_name;
  3767.   int            evaluate;
  3768.     {
  3769.       char             buffer [256];
  3770.       value_header_ptr result_header_ptr;
  3771.  
  3772.       if (queue_head == NULL)
  3773.         {
  3774.           fatal_error=TRUE;
  3775.           result_header_ptr=NULL;
  3776.           printf(
  3777.           "Fatal error:  argument to function \"%s\" is missing on\n",
  3778.            function_name);
  3779.           printf("     line %ld, column %ld.\n",source_line_num,
  3780.            source_column_num);
  3781.         }
  3782.       else
  3783.         if ((*queue_head).next == NULL)
  3784.           if (evaluate)
  3785.             switch ((*((*queue_head).argument_header_ptr)).type)
  3786.               {
  3787.                 case 'B':
  3788.                   if
  3789.                   (*((*((*queue_head).argument_header_ptr)).value_ptr.boolean))
  3790.                     {
  3791.                       result_header_ptr=new_string_header_ptr((unsigned) 4);
  3792.                       if (! fatal_error)
  3793.                         strcpy((char *)
  3794.                          (*((*result_header_ptr).value_ptr.string)).value,
  3795.                          "TRUE");
  3796.                     }
  3797.                   else
  3798.                     {
  3799.                       result_header_ptr=new_string_header_ptr((unsigned) 5);
  3800.                       if (! fatal_error)
  3801.                         strcpy((char *)
  3802.                          (*((*result_header_ptr).value_ptr.string)).value,
  3803.                          "FALSE");
  3804.                     }
  3805.                   break;
  3806.                 case 'D':
  3807.                   buffer[sprintf(buffer,"%p",
  3808.                    *((*((*queue_head).argument_header_ptr)).value_ptr.
  3809.                    dataset))]='\0';
  3810.                   result_header_ptr
  3811.                    =new_string_header_ptr((unsigned) strlen(buffer));
  3812.                   if (! fatal_error)
  3813.                     strcpy((char *)
  3814.                      (*((*result_header_ptr).value_ptr.string)).value,buffer);
  3815.                   break;
  3816.                 case 'I':
  3817.                   buffer[sprintf(buffer,"%ld",
  3818.                    *((*((*queue_head).argument_header_ptr)).value_ptr.integer))]
  3819.                    ='\0';
  3820.                   result_header_ptr
  3821.                    =new_string_header_ptr((unsigned) strlen(buffer));
  3822.                   if (! fatal_error)
  3823.                     strcpy((char *)
  3824.                      (*((*result_header_ptr).value_ptr.string)).value,buffer);
  3825.                   break;
  3826.                 case 'R':
  3827.                   buffer[sprintf(buffer,"%lG",
  3828.                    *((*((*queue_head).argument_header_ptr)).value_ptr.real))]
  3829.                    ='\0';
  3830.                   result_header_ptr
  3831.                    =new_string_header_ptr((unsigned) strlen(buffer));
  3832.                   if (! fatal_error)
  3833.                     strcpy((char *)
  3834.                      (*((*result_header_ptr).value_ptr.string)).value,buffer);
  3835.                   break;
  3836.                 default:
  3837.                   result_header_ptr=new_string_header_ptr((unsigned)
  3838.                    (*((*((*queue_head).argument_header_ptr)).value_ptr.
  3839.                    string)).length);
  3840.                   if (! fatal_error)
  3841.                     pli_strcpy((*result_header_ptr).value_ptr.string,
  3842.                      (*((*queue_head).argument_header_ptr)).value_ptr.string);
  3843.                   break;
  3844.               }
  3845.           else
  3846.             result_header_ptr=NULL;
  3847.         else
  3848.           {
  3849.             fatal_error=TRUE;
  3850.             result_header_ptr=NULL;
  3851.             printf(
  3852.           "Fatal error:  extraneous argument supplied to function \"%s\" on\n",
  3853.              function_name);
  3854.             printf("     line %ld, column %ld.\n",source_line_num,
  3855.              source_column_num);
  3856.           }
  3857.       return(result_header_ptr);
  3858.     }
  3859.  
  3860. static value_header_ptr substr_header_ptr(queue_head,function_name,evaluate)
  3861.   queue_node_ptr queue_head;
  3862.   char           *function_name;
  3863.   int            evaluate;
  3864.     {
  3865.       unsigned char    *char_ptr;
  3866.       unsigned char    *destination_ptr;
  3867.       long             final_column;
  3868.       long             num_columns;
  3869.       int              offset;
  3870.       value_header_ptr result_header_ptr;
  3871.       unsigned char    *source_ptr;
  3872.       long             starting_column;
  3873.       int              string_length;
  3874.  
  3875.       if (queue_head == NULL)
  3876.         {
  3877.           fatal_error=TRUE;
  3878.           result_header_ptr=NULL;
  3879.           printf(
  3880.           "Fatal error:  argument to function \"%s\" is missing on\n",
  3881.            function_name);
  3882.           printf("     line %ld, column %ld.\n",source_line_num,
  3883.            source_column_num);
  3884.         }
  3885.       else
  3886.         if ((*queue_head).next == NULL)
  3887.           {
  3888.             fatal_error=TRUE;
  3889.              result_header_ptr=NULL;
  3890.             printf(
  3891.              "Fatal error:  argument to function \"%s\" is missing on\n",
  3892.              function_name);
  3893.             printf("     line %ld, column %ld.\n",source_line_num,
  3894.              source_column_num);
  3895.           }
  3896.         else
  3897.           if ((*((*queue_head).next)).next == NULL)
  3898.             if (evaluate)
  3899.               if ((*((*queue_head).argument_header_ptr)).type == 'S')
  3900.                 if ((*((*((*queue_head).next)).argument_header_ptr)).type
  3901.                  == 'I')
  3902.                   {
  3903.                     char_ptr=(*((*((*queue_head).argument_header_ptr)).
  3904.                      value_ptr.string)).value;
  3905.                     string_length=(*((*((*queue_head).argument_header_ptr)).
  3906.                      value_ptr.string)).length;
  3907.                     starting_column
  3908.                      =*((*((*((*queue_head).next)).
  3909.                      argument_header_ptr)).value_ptr.integer);
  3910.                     if (starting_column <= (long) 0)
  3911.                       {
  3912.                         fatal_error=TRUE;
  3913.                         result_header_ptr=NULL;
  3914.                         printf(
  3915.                   "Fatal error:  second argument to SUBSTR is not positive\n");
  3916.                         printf(
  3917.                          "     on line %ld, column %ld.\n",
  3918.                          source_line_num,source_column_num);
  3919.                       }
  3920.                     else
  3921.                       if (starting_column > string_length)
  3922.                         {
  3923.                           fatal_error=TRUE;
  3924.                           result_header_ptr=NULL;
  3925.                           printf(
  3926.  "Fatal error:  second argument to SUBSTR exceeds length of first argument\n");
  3927.                           printf(
  3928.                            "     on line %ld, column %ld.\n",
  3929.                            source_line_num,source_column_num);
  3930.                         }
  3931.                       else
  3932.                         {
  3933.                           num_columns=string_length-starting_column+(long) 1;
  3934.                           result_header_ptr
  3935.                            =new_string_header_ptr((unsigned) num_columns);
  3936.                           if (! fatal_error)
  3937.                             {
  3938.                               offset=(int) starting_column;
  3939.                               offset--;
  3940.                               source_ptr=char_ptr+offset;
  3941.                               destination_ptr
  3942.                                =(*((*result_header_ptr).value_ptr.string)).
  3943.                                value;
  3944.                               while (num_columns > 0)
  3945.                                 {
  3946.                                    *destination_ptr=*source_ptr;
  3947.                                    source_ptr++;
  3948.                                    destination_ptr++;
  3949.                                    num_columns--;
  3950.                                 }
  3951.                               *destination_ptr=(unsigned char) '\0';
  3952.                             }
  3953.                         }
  3954.                   }
  3955.                 else
  3956.                   {
  3957.                     fatal_error=TRUE;
  3958.                     result_header_ptr=NULL;
  3959.                     printf(
  3960.          "Fatal error:  second argument to SUBSTR is other than an integer\n");
  3961.                     printf("     on line %ld, column %ld.\n",source_line_num,
  3962.                      source_column_num);
  3963.                   }
  3964.               else
  3965.                 {
  3966.                   fatal_error=TRUE;
  3967.                   result_header_ptr=NULL;
  3968.                   printf(
  3969.             "Fatal error:  first argument to SUBSTR is other than a string\n");
  3970.                   printf("     on line %ld, column %ld.\n",source_line_num,
  3971.                    source_column_num);
  3972.                 }
  3973.             else
  3974.               result_header_ptr=NULL;
  3975.           else
  3976.             if ((*((*((*queue_head).next)).next)).next == NULL)
  3977.               if (evaluate)
  3978.                 if ((*((*queue_head).argument_header_ptr)).type == 'S')
  3979.                   if ((*((*((*queue_head).next)).argument_header_ptr)).type
  3980.                    == 'I')
  3981.                     if ((*((*((*((*queue_head).next)).next)).
  3982.                      argument_header_ptr)).type == 'I')
  3983.                       {
  3984.                         char_ptr=(*((*((*queue_head).argument_header_ptr)).
  3985.                          value_ptr.string)).value;
  3986.                         string_length
  3987.                          =(*((*((*queue_head).argument_header_ptr)).
  3988.                          value_ptr.string)).length;
  3989.                         starting_column
  3990.                          =*((*((*((*queue_head).next)).
  3991.                          argument_header_ptr)).value_ptr.integer);
  3992.                         if (starting_column <= (long) 0)
  3993.                           {
  3994.                             fatal_error=TRUE;
  3995.                             result_header_ptr=NULL;
  3996.                             printf(
  3997.                   "Fatal error:  second argument to SUBSTR is not positive\n");
  3998.                             printf(
  3999.                              "     on line %ld, column %ld.\n",
  4000.                              source_line_num,source_column_num);
  4001.                           }
  4002.                         else
  4003.                           {
  4004.                             num_columns
  4005.                              =*((*((*((*((*queue_head).next)).next)).
  4006.                              argument_header_ptr)).value_ptr.integer);
  4007.                             if (num_columns == (long) 0)
  4008.                               {
  4009.                                 result_header_ptr=new_string_header_ptr(0);
  4010.                                 if (! fatal_error)
  4011.                                   *((*((*result_header_ptr).value_ptr.string)).
  4012.                                    value)=(unsigned char) '\0';
  4013.                               }
  4014.                             else
  4015.                               {
  4016.                                 final_column=starting_column+num_columns-1;
  4017.                                 if (final_column > string_length)
  4018.                                   {
  4019.                                     fatal_error=TRUE;
  4020.                                     result_header_ptr=NULL;
  4021.                                     printf(
  4022.              "Fatal error:  SUBSTRing extends beyond end of first argument\n");
  4023.                                     printf(
  4024.                                      "     on line %ld, column %ld.\n",
  4025.                                      source_line_num,source_column_num);
  4026.                                   }
  4027.                                 else
  4028.                                   if (final_column < starting_column)
  4029.                                     {
  4030.                                       fatal_error=TRUE;
  4031.                                       result_header_ptr=NULL;
  4032.                                       printf(
  4033.                    "Fatal error:  third argument to SUBSTR is not positive\n");
  4034.                                       printf(
  4035.                                        "     on line %ld, column %ld.\n",
  4036.                                        source_line_num,source_column_num);
  4037.                                     }
  4038.                                   else
  4039.                                     {
  4040.                                       result_header_ptr
  4041.                                        =new_string_header_ptr(
  4042.                                        (unsigned) num_columns);
  4043.                                       if (! fatal_error)
  4044.                                         {
  4045.                                           offset=(int) starting_column;
  4046.                                           offset--;
  4047.                                           source_ptr=char_ptr+offset;
  4048.                                           destination_ptr
  4049.                                            =(*((*result_header_ptr).
  4050.                                            value_ptr.string)).value;
  4051.                                           while (final_column
  4052.                                            >= starting_column)
  4053.                                             {
  4054.                                               *destination_ptr=*source_ptr;
  4055.                                               source_ptr++;
  4056.                                               destination_ptr++;
  4057.                                               starting_column++;
  4058.                                             }
  4059.                                           *destination_ptr='\0';
  4060.                                         }
  4061.                                     }
  4062.                               }
  4063.                           }
  4064.                       }
  4065.                     else
  4066.                       {
  4067.                         fatal_error=TRUE;
  4068.                         result_header_ptr=NULL;
  4069.                         printf(
  4070.           "Fatal error:  third argument to SUBSTR is other than an integer\n");
  4071.                         printf("     on line %ld, column %ld.\n",
  4072.                          source_line_num,source_column_num);
  4073.                       }
  4074.                   else
  4075.                     {
  4076.                       fatal_error=TRUE;
  4077.                       result_header_ptr=NULL;
  4078.                       printf(
  4079.          "Fatal error:  second argument to SUBSTR is other than an integer\n");
  4080.                       printf("     on line %ld, column %ld.\n",source_line_num,
  4081.                        source_column_num);
  4082.                     }
  4083.                 else
  4084.                   {
  4085.                     fatal_error=TRUE;
  4086.                     result_header_ptr=NULL;
  4087.                     printf(
  4088.             "Fatal error:  first argument to SUBSTR is other than a string\n");
  4089.                     printf("     on line %ld, column %ld.\n",source_line_num,
  4090.                      source_column_num);
  4091.                   }
  4092.               else
  4093.                 result_header_ptr=NULL;
  4094.             else
  4095.               {
  4096.                 fatal_error=TRUE;
  4097.                 result_header_ptr=NULL;
  4098.                 printf(
  4099.           "Fatal error:  extraneous argument supplied to function \"%s\" on\n",
  4100.                  function_name);
  4101.                 printf("     line %ld, column %ld.\n",source_line_num,
  4102.                  source_column_num);
  4103.               }
  4104.       return(result_header_ptr);
  4105.     }
  4106.  
  4107. static value_header_ptr sysin_header_ptr(queue_head,function_name,evaluate)
  4108.   queue_node_ptr queue_head;
  4109.   char           *function_name;
  4110.   int            evaluate;
  4111.     {
  4112.       value_header_ptr result_header_ptr;
  4113.  
  4114.       if (queue_head != NULL)
  4115.         {
  4116.           fatal_error=TRUE;
  4117.           result_header_ptr=NULL;
  4118.           printf(
  4119.           "Fatal error:  extraneous argument supplied to function \"%s\" on\n",
  4120.            function_name);
  4121.           printf("     line %ld, column %ld.\n",source_line_num,
  4122.            source_column_num);
  4123.         }
  4124.       else
  4125.         if (evaluate)
  4126.           {
  4127.             result_header_ptr=new_dataset_header_ptr();
  4128.             if (! fatal_error)
  4129.               *((*result_header_ptr).value_ptr.dataset)=stdin;
  4130.           }
  4131.         else
  4132.           result_header_ptr=NULL;
  4133.       return(result_header_ptr);
  4134.     }
  4135.  
  4136. static value_header_ptr sysprint_header_ptr(queue_head,function_name,evaluate)
  4137.   queue_node_ptr queue_head;
  4138.   char           *function_name;
  4139.   int            evaluate;
  4140.     {
  4141.       value_header_ptr result_header_ptr;
  4142.  
  4143.       if (queue_head != NULL)
  4144.         {
  4145.           fatal_error=TRUE;
  4146.           result_header_ptr=NULL;
  4147.           printf(
  4148.           "Fatal error:  extraneous argument supplied to function \"%s\" on\n",
  4149.            function_name);
  4150.           printf("     line %ld, column %ld.\n",source_line_num,
  4151.            source_column_num);
  4152.         }
  4153.       else
  4154.         if (evaluate)
  4155.           {
  4156.             result_header_ptr=new_dataset_header_ptr();
  4157.             if (! fatal_error)
  4158.               *((*result_header_ptr).value_ptr.dataset)=stdout;
  4159.           }
  4160.         else
  4161.           result_header_ptr=NULL;
  4162.       return(result_header_ptr);
  4163.     }
  4164.  
  4165. static value_header_ptr time_header_ptr(queue_head,function_name,evaluate)
  4166.   queue_node_ptr queue_head;
  4167.   char           *function_name;
  4168.   int            evaluate;
  4169.     {
  4170.       unsigned char    *char_ptr;
  4171.       char             date_and_time [26];
  4172.       long             elapsed_time;
  4173.       struct tm        *local_time;
  4174.       value_header_ptr result_header_ptr;
  4175.  
  4176.       if (queue_head != NULL)
  4177.         {
  4178.           fatal_error=TRUE;
  4179.           result_header_ptr=NULL;
  4180.           printf(
  4181.           "Fatal error:  extraneous argument supplied to function \"%s\" on\n",
  4182.            function_name);
  4183.           printf("     line %ld, column %ld.\n",source_line_num,
  4184.            source_column_num);
  4185.         }
  4186.       else
  4187.         if (evaluate)
  4188.           {
  4189.             result_header_ptr=new_string_header_ptr((unsigned) 9);
  4190.             if (! fatal_error)
  4191.               {
  4192.                 char_ptr=(*((*result_header_ptr).value_ptr.string)).value;
  4193.                 time(&elapsed_time);
  4194.                 local_time=localtime(&elapsed_time);
  4195.                 strcpy(&date_and_time[0],asctime(local_time));
  4196.                 *char_ptr=(unsigned char) date_and_time[11];
  4197.                 char_ptr++;
  4198.                 *char_ptr=(unsigned char) date_and_time[12];
  4199.                 char_ptr++;
  4200.                 *char_ptr=(unsigned char) date_and_time[14];
  4201.                 char_ptr++;
  4202.                 *char_ptr=(unsigned char) date_and_time[15];
  4203.                 char_ptr++;
  4204.                 *char_ptr=(unsigned char) date_and_time[17];
  4205.                 char_ptr++;
  4206.                 *char_ptr=(unsigned char) date_and_time[18];
  4207.                 char_ptr++;
  4208.                 *char_ptr=(unsigned char) '0';
  4209.                 char_ptr++;
  4210.                 *char_ptr=(unsigned char) '0';
  4211.                 char_ptr++;
  4212.                 *char_ptr=(unsigned char) '0';
  4213.                 char_ptr++;
  4214.                 *char_ptr=(unsigned char) '\0';
  4215.               }
  4216.           }
  4217.         else
  4218.           result_header_ptr=NULL;
  4219.       return(result_header_ptr);
  4220.     }
  4221.  
  4222. static value_header_ptr translate_header_ptr(queue_head,function_name,evaluate)
  4223.   queue_node_ptr queue_head;
  4224.   char           *function_name;
  4225.   int            evaluate;
  4226.     {
  4227.       unsigned         char_index_1;
  4228.       int              char_index_2;
  4229.       unsigned         char_index_3;
  4230.       unsigned char    *char_ptr_1;
  4231.       unsigned char    *char_ptr_2;
  4232.       unsigned char    *char_ptr_3;
  4233.       unsigned char    *char_ptr_4;
  4234.       unsigned char    *char_ptr_5;
  4235.       value_header_ptr result_header_ptr;
  4236.       unsigned         length_1;
  4237.       int              length_2;
  4238.       unsigned         length_3;
  4239.  
  4240.       if (queue_head == NULL)
  4241.         {
  4242.           fatal_error=TRUE;
  4243.           result_header_ptr=NULL;
  4244.           printf(
  4245.            "Fatal error:  argument to function \"%s\" is missing on\n",
  4246.            function_name);
  4247.           printf("     line %ld, column %ld.\n",source_line_num,
  4248.            source_column_num);
  4249.         }
  4250.       else
  4251.         if ((*queue_head).next == NULL)
  4252.           {
  4253.             fatal_error=TRUE;
  4254.              result_header_ptr=NULL;
  4255.             printf(
  4256.              "Fatal error:  argument to function \"%s\" is missing on\n",
  4257.              function_name);
  4258.             printf("     line %ld, column %ld.\n",source_line_num,
  4259.              source_column_num);
  4260.           }
  4261.         else
  4262.           if ((*((*queue_head).next)).next == NULL)
  4263.             if (evaluate)
  4264.               if ((*((*queue_head).argument_header_ptr)).type == 'S')
  4265.                 if ((*((*((*queue_head).next)).argument_header_ptr)).type
  4266.                  == 'S')
  4267.                   {
  4268.                     char_ptr_1
  4269.                      =(*((*((*queue_head).argument_header_ptr)).
  4270.                      value_ptr.string)).value;
  4271.                     length_1
  4272.                      =(*((*((*queue_head).argument_header_ptr)).
  4273.                      value_ptr.string)).length;
  4274.                     char_ptr_2=(*((*((*((*queue_head).next)).
  4275.                      argument_header_ptr)).value_ptr.string)).value;
  4276.                     length_2=(*((*((*((*queue_head).next)).
  4277.                      argument_header_ptr)).value_ptr.string)).length;
  4278.                     result_header_ptr=new_string_header_ptr((unsigned)
  4279.                      (*((*((*queue_head).argument_header_ptr)).
  4280.                      value_ptr.string)).length);
  4281.                     if (! fatal_error)
  4282.                       {
  4283.                         char_ptr_5
  4284.                          =(*((*result_header_ptr).value_ptr.string)).value;
  4285.                         char_index_1=(unsigned) 1;
  4286.                         while (char_index_1 <= length_1)
  4287.                           {
  4288.                             char_index_2=(int) *char_ptr_1;
  4289.                             if (char_index_2 < length_2)
  4290.                               *char_ptr_5=*(char_ptr_2+char_index_2);
  4291.                             else
  4292.                               *char_ptr_5=(unsigned char) ' ';
  4293.                             char_index_1++;
  4294.                             char_ptr_1++;
  4295.                             char_ptr_5++;
  4296.                           }
  4297.                       }
  4298.                   }
  4299.                 else
  4300.                   {
  4301.                     fatal_error=TRUE;
  4302.                     result_header_ptr=NULL;
  4303.                     printf(
  4304.         "Fatal error:  second argument to TRANSLATE is other than a string\n");
  4305.                     printf("     on line %ld, column %ld.\n",source_line_num,
  4306.                      source_column_num);
  4307.                   }
  4308.               else
  4309.                 {
  4310.                   fatal_error=TRUE;
  4311.                   result_header_ptr=NULL;
  4312.                   printf(
  4313.          "Fatal error:  first argument to TRANSLATE is other than a string\n");
  4314.                   printf("     on line %ld, column %ld.\n",source_line_num,
  4315.                    source_column_num);
  4316.                 }
  4317.             else
  4318.               result_header_ptr=NULL;
  4319.           else
  4320.             if ((*((*((*queue_head).next)).next)).next == NULL)
  4321.               if (evaluate)
  4322.                 if ((*((*queue_head).argument_header_ptr)).type == 'S')
  4323.                   if ((*((*((*queue_head).next)).argument_header_ptr)).type
  4324.                    == 'S')
  4325.                     if ((*((*((*((*queue_head).next)).next)).
  4326.                      argument_header_ptr)).type == 'S')
  4327.                       {
  4328.                         char_ptr_1
  4329.                          =(*((*((*queue_head).argument_header_ptr)).
  4330.                          value_ptr.string)).value;
  4331.                         length_1
  4332.                          =(unsigned) (*((*((*queue_head).argument_header_ptr)).
  4333.                          value_ptr.string)).length;
  4334.                         char_ptr_2=(*((*((*((*queue_head).next)).
  4335.                          argument_header_ptr)).value_ptr.string)).value;
  4336.                         length_2=(*((*((*((*queue_head).next)).
  4337.                          argument_header_ptr)).value_ptr.string)).length;
  4338.                         char_ptr_3=(*((*((*((*((*queue_head).next)).next)).
  4339.                          argument_header_ptr)).value_ptr.string)).value;
  4340.                         length_3
  4341.                          =(unsigned) (*((*((*((*((*queue_head).next)).next)).
  4342.                          argument_header_ptr)).value_ptr.string)).length;
  4343.                         result_header_ptr=new_string_header_ptr((unsigned)
  4344.                          (*((*((*queue_head).argument_header_ptr)).
  4345.                          value_ptr.string)).length);
  4346.                         if (! fatal_error)
  4347.                           {
  4348.                             char_ptr_5
  4349.                              =(*((*result_header_ptr).value_ptr.string)).value;
  4350.                             char_index_1=(unsigned) 1;
  4351.                             while (char_index_1 <= length_1)
  4352.                               {
  4353.                                 char_index_2=0;
  4354.                                 char_ptr_4=char_ptr_3;
  4355.                                 char_index_3=1;
  4356.                                 while ((char_index_3 <= length_3)
  4357.                                 &&     (*char_ptr_4 != *char_ptr_1))
  4358.                                   {
  4359.                                     char_ptr_4++;
  4360.                                     char_index_2++;
  4361.                                     char_index_3++;
  4362.                                   }
  4363.                                 if (char_index_3 <= length_3)
  4364.                                   {
  4365.                                     if ((long) char_index_2 >= length_2)
  4366.                                       *char_ptr_5=(unsigned char) ' ';
  4367.                                     else
  4368.                                       *char_ptr_5=*(char_ptr_2+char_index_2);
  4369.                                   }
  4370.                                 else
  4371.                                   *char_ptr_5=*char_ptr_1;
  4372.                                 char_ptr_1++;
  4373.                                 char_ptr_5++;
  4374.                                 char_index_1++;
  4375.                               }
  4376.                             *char_ptr_5=(unsigned char) '\0';
  4377.                           }
  4378.                       }
  4379.                     else
  4380.                       {
  4381.                         fatal_error=TRUE;
  4382.                         result_header_ptr=NULL;
  4383.                         printf(
  4384.          "Fatal error:  third argument to TRANSLATE is other than a string\n");
  4385.                         printf("     on line %ld, column %ld.\n",
  4386.                          source_line_num,source_column_num);
  4387.                       }
  4388.                   else
  4389.                     {
  4390.                       fatal_error=TRUE;
  4391.                       result_header_ptr=NULL;
  4392.                       printf(
  4393.         "Fatal error:  second argument to TRANSLATE is other than a string\n");
  4394.                       printf("     on line %ld, column %ld.\n",source_line_num,
  4395.                        source_column_num);
  4396.                     }
  4397.                 else
  4398.                   {
  4399.                     fatal_error=TRUE;
  4400.                     result_header_ptr=NULL;
  4401.                     printf(
  4402.          "Fatal error:  first argument to TRANSLATE is other than a string\n");
  4403.                     printf("     on line %ld, column %ld.\n",source_line_num,
  4404.                      source_column_num);
  4405.                   }
  4406.               else
  4407.                 result_header_ptr=NULL;
  4408.             else
  4409.               {
  4410.                 fatal_error=TRUE;
  4411.                 result_header_ptr=NULL;
  4412.                 printf(
  4413.           "Fatal error:  extraneous argument supplied to function \"%s\" on\n",
  4414.                  function_name);
  4415.                 printf("     line %ld, column %ld.\n",source_line_num,
  4416.                  source_column_num);
  4417.               }
  4418.       return(result_header_ptr);
  4419.     }
  4420.  
  4421. static value_header_ptr true_header_ptr(queue_head,function_name,evaluate)
  4422.   queue_node_ptr queue_head;
  4423.   char           *function_name;
  4424.   int            evaluate;
  4425.     {
  4426.       value_header_ptr result_header_ptr;
  4427.  
  4428.       if (queue_head != NULL)
  4429.         {
  4430.           fatal_error=TRUE;
  4431.           result_header_ptr=NULL;
  4432.           printf(
  4433.           "Fatal error:  extraneous argument supplied to function \"%s\" on\n",
  4434.            function_name);
  4435.           printf("     line %ld, column %ld.\n",source_line_num,
  4436.            source_column_num);
  4437.         }
  4438.       else
  4439.         if (evaluate)
  4440.           {
  4441.             result_header_ptr=new_boolean_header_ptr();
  4442.             if (! fatal_error)
  4443.               *((*result_header_ptr).value_ptr.boolean)=TRUE;
  4444.           }
  4445.         else
  4446.           result_header_ptr=NULL;
  4447.       return(result_header_ptr);
  4448.     }
  4449.  
  4450. static value_header_ptr trunc_header_ptr(queue_head,function_name,evaluate)
  4451.   queue_node_ptr queue_head;
  4452.   char           *function_name;
  4453.   int            evaluate;
  4454.     {
  4455.       value_header_ptr result_header_ptr;
  4456.       int              status;
  4457.       double           tem_real_1;
  4458.       double           tem_real_2;
  4459.  
  4460.       if (queue_head == NULL)
  4461.         {
  4462.           fatal_error=TRUE;
  4463.           result_header_ptr=NULL;
  4464.           printf(
  4465.           "Fatal error:  argument to function \"%s\" is missing on\n",
  4466.            function_name);
  4467.           printf("     line %ld, column %ld.\n",source_line_num,
  4468.            source_column_num);
  4469.         }
  4470.       else
  4471.         if ((*queue_head).next == NULL)
  4472.           if (evaluate)
  4473.             if ((*((*queue_head).argument_header_ptr)).type == 'I')
  4474.               {
  4475.                 result_header_ptr=new_integer_header_ptr();
  4476.                 if (! fatal_error)
  4477.                   *((*result_header_ptr).value_ptr.integer)
  4478.                    =*((*((*queue_head).argument_header_ptr)).
  4479.                    value_ptr.integer);
  4480.               }
  4481.             else
  4482.               if ((*((*queue_head).argument_header_ptr)).type == 'R')
  4483.                 {
  4484.                   tem_real_1=*((*((*queue_head).argument_header_ptr)).
  4485.                    value_ptr.real);
  4486.                   if (tem_real_1 == 0.0)
  4487.                     {
  4488.                       result_header_ptr=new_integer_header_ptr();
  4489.                       if (! fatal_error)
  4490.                         *((*result_header_ptr).value_ptr.integer)=(long) 0;
  4491.                     }
  4492.                   else
  4493.                     {
  4494.                       tem_real_2=log(fabs(tem_real_1))/log(2.0);
  4495.                       if (tem_real_2 >= 31.0)
  4496.                         {
  4497.                           fatal_error=TRUE;
  4498.                           result_header_ptr=NULL;
  4499.                           printf(
  4500.                    "Fatal error:  magnitude of argument to TRUNC too large\n");
  4501.                           printf("     on line %ld, column %ld.\n",
  4502.                            source_line_num,source_column_num);
  4503.                         }
  4504.                       else
  4505.                         {
  4506.                           result_header_ptr=new_integer_header_ptr();
  4507.                           if (! fatal_error)
  4508.                             *((*result_header_ptr).value_ptr.integer)
  4509.                              =(long) tem_real_1;
  4510.                         }
  4511.                     }
  4512.                 }
  4513.               else
  4514.                 if ((*((*queue_head).argument_header_ptr)).type == 'B')
  4515.                   {
  4516.                     result_header_ptr=new_integer_header_ptr();
  4517.                     if (! fatal_error)
  4518.                       {
  4519.                         if (*((*((*queue_head).argument_header_ptr)).
  4520.                          value_ptr.boolean))
  4521.                           *((*result_header_ptr).value_ptr.integer)=1;
  4522.                         else
  4523.                           *((*result_header_ptr).value_ptr.integer)=0;
  4524.                       }
  4525.                   }
  4526.                 else
  4527.                   if ((*((*queue_head).argument_header_ptr)).type == 'S')
  4528.                     {
  4529.                       result_header_ptr=new_integer_header_ptr();
  4530.                       if (! fatal_error)
  4531.                         {
  4532.                           status=sscanf((char *)
  4533.                            (*((*((*queue_head).argument_header_ptr)).
  4534.                            value_ptr.string)).value,"%I",
  4535.                            (*result_header_ptr).value_ptr.integer);
  4536.                           if ((status == EOF) || (status == 0))
  4537.                             {
  4538.                               fatal_error=TRUE;
  4539.                               free_value(result_header_ptr);
  4540.                               result_header_ptr=NULL;
  4541.                               printf(
  4542.                    "Fatal error:  argument to TRUNC cannot be converted on\n");
  4543.                               printf("     line %ld, column %ld.\n",
  4544.                                source_line_num,source_column_num);
  4545.                             }
  4546.                         }
  4547.                     }
  4548.                   else
  4549.                     {
  4550.                       fatal_error=TRUE;
  4551.                       result_header_ptr=NULL;
  4552.                       printf(
  4553.  "Fatal error:  argument to TRUNC is other than Boolean, number, or string\n");
  4554.                       printf("     on line %ld, column %ld.\n",
  4555.                        source_line_num,source_column_num);
  4556.                     }
  4557.           else
  4558.             result_header_ptr=NULL;
  4559.         else
  4560.           {
  4561.             fatal_error=TRUE;
  4562.             result_header_ptr=NULL;
  4563.             printf(
  4564.           "Fatal error:  extraneous argument supplied to function \"%s\" on\n",
  4565.              function_name);
  4566.             printf("     line %ld, column %ld.\n",source_line_num,
  4567.              source_column_num);
  4568.           }
  4569.       return(result_header_ptr);
  4570.     }
  4571.  
  4572. static value_header_ptr upper_header_ptr(queue_head,function_name,evaluate)
  4573.   queue_node_ptr queue_head;
  4574.   char           *function_name;
  4575.   int            evaluate;
  4576.     {
  4577.       register int     char_index;
  4578.       unsigned char    *char_ptr;
  4579.       value_header_ptr result_header_ptr;
  4580.       int              string_length;
  4581.  
  4582.       if (queue_head == NULL)
  4583.         {
  4584.           fatal_error=TRUE;
  4585.           result_header_ptr=NULL;
  4586.           printf(
  4587.           "Fatal error:  argument to function \"%s\" is missing on\n",
  4588.            function_name);
  4589.           printf("     line %ld, column %ld.\n",source_line_num,
  4590.            source_column_num);
  4591.         }
  4592.       else
  4593.         if ((*queue_head).next == NULL)
  4594.           if (evaluate)
  4595.             if ((*((*queue_head).argument_header_ptr)).type == 'S')
  4596.               {
  4597.                 result_header_ptr=new_string_header_ptr((unsigned)
  4598.                  (*((*((*queue_head).argument_header_ptr)).value_ptr.string)).
  4599.                  length);
  4600.                 if (! fatal_error)
  4601.                   {
  4602.                     pli_strcpy((*result_header_ptr).value_ptr.string,
  4603.                      (*((*queue_head).argument_header_ptr)).value_ptr.string);
  4604.                     char_ptr=(*((*result_header_ptr).value_ptr.string)).value;
  4605.                     string_length
  4606.                      =(*((*result_header_ptr).value_ptr.string)).length;
  4607.                     for (char_index=0; char_index < string_length;
  4608.                      char_index++)
  4609.                       {
  4610.                         *char_ptr=(unsigned char) toupper((int) *char_ptr);
  4611.                         char_ptr++;
  4612.                       }
  4613.                   }
  4614.               }
  4615.             else
  4616.               {
  4617.                 fatal_error=TRUE;
  4618.                 result_header_ptr=NULL;
  4619.                 printf(
  4620.                  "Fatal error:  argument to UPPER is other than a string\n");
  4621.                 printf("     on line %ld, column %ld.\n",source_line_num,
  4622.                  source_column_num);
  4623.               }
  4624.           else
  4625.             result_header_ptr=NULL;
  4626.         else
  4627.           {
  4628.             fatal_error=TRUE;
  4629.             result_header_ptr=NULL;
  4630.             printf(
  4631.           "Fatal error:  extraneous argument supplied to function \"%s\" on\n",
  4632.              function_name);
  4633.             printf("     line %ld, column %ld.\n",source_line_num,
  4634.              source_column_num);
  4635.           }
  4636.       return(result_header_ptr);
  4637.     }
  4638.  
  4639. static value_header_ptr verify_header_ptr(queue_head,function_name,evaluate)
  4640.   queue_node_ptr queue_head;
  4641.   char           *function_name;
  4642.   int            evaluate;
  4643.     {
  4644.       long             char_index;
  4645.       int              char_okay;
  4646.       unsigned char    *char_ptr;
  4647.       value_header_ptr result_header_ptr;
  4648.       unsigned         rule_index;
  4649.       unsigned         rule_length;
  4650.       unsigned char    *rule_ptr;
  4651.       long             string_length;
  4652.  
  4653.       if (queue_head == NULL)
  4654.         {
  4655.           fatal_error=TRUE;
  4656.           result_header_ptr=NULL;
  4657.           printf(
  4658.           "Fatal error:  argument to function \"%s\" is missing on\n",
  4659.            function_name);
  4660.           printf("     line %ld, column %ld.\n",source_line_num,
  4661.            source_column_num);
  4662.         }
  4663.       else
  4664.         if ((*queue_head).next == NULL)
  4665.           {
  4666.             fatal_error=TRUE;
  4667.             result_header_ptr=NULL;
  4668.             printf(
  4669.              "Fatal error:  argument to function \"%s\" is missing on\n",
  4670.              function_name);
  4671.             printf("     line %ld, column %ld.\n",source_line_num,
  4672.              source_column_num);
  4673.           }
  4674.         else
  4675.           if ((*((*queue_head).next)).next == NULL)
  4676.             if (evaluate)
  4677.               if ((*((*queue_head).argument_header_ptr)).type == 'S')
  4678.                 if ((*((*((*queue_head).next)).argument_header_ptr)).type
  4679.                  == 'S')
  4680.                   {
  4681.                     result_header_ptr=new_integer_header_ptr();
  4682.                     if (! fatal_error)
  4683.                       {
  4684.                         char_ptr=(*((*((*queue_head).argument_header_ptr)).
  4685.                          value_ptr.string)).value;
  4686.                         string_length
  4687.                          =(long) (*((*((*queue_head).argument_header_ptr)).
  4688.                          value_ptr.string)).length;
  4689.                         char_index=(long) 1;
  4690.                         char_okay=TRUE;
  4691.                         while ((char_index <= string_length)
  4692.                         &&     (char_okay))
  4693.                           {
  4694.                             char_okay=FALSE;
  4695.                             rule_ptr
  4696.                              =(*((*((*((*queue_head).next)).
  4697.                              argument_header_ptr)).value_ptr.string)).value;
  4698.                             rule_length
  4699.                              =(unsigned) (*((*((*((*queue_head).next)).
  4700.                              argument_header_ptr)).value_ptr.string)).length;
  4701.                             rule_index=(unsigned) 1;
  4702.                             while ((! char_okay)
  4703.                             &&     (rule_index <= rule_length))
  4704.                               if (*rule_ptr == *char_ptr)
  4705.                                 char_okay=TRUE;
  4706.                               else
  4707.                                 {
  4708.                                   rule_ptr++;
  4709.                                   rule_index++;
  4710.                                 }
  4711.                             if (char_okay)
  4712.                               {
  4713.                                 char_ptr++;
  4714.                                 char_index++;
  4715.                               }
  4716.                           }
  4717.                         if (char_okay)
  4718.                           *((*result_header_ptr).value_ptr.integer)=(long) 0;
  4719.                         else
  4720.                           *((*result_header_ptr).value_ptr.integer)
  4721.                            =char_index;
  4722.                       }
  4723.                   }
  4724.                 else
  4725.                   {
  4726.                     fatal_error=TRUE;
  4727.                     result_header_ptr=NULL;
  4728.                     printf(
  4729.            "Fatal error:  second argument to VERIFY is other than a string\n");
  4730.                     printf("     on line %ld, column %ld.\n",source_line_num,
  4731.                      source_column_num);
  4732.                   }
  4733.               else
  4734.                 {
  4735.                   fatal_error=TRUE;
  4736.                   result_header_ptr=NULL;
  4737.                   printf(
  4738.             "Fatal error:  first argument to VERIFY is other than a string\n");
  4739.                   printf("     on line %ld, column %ld.\n",source_line_num,
  4740.                    source_column_num);
  4741.                 }
  4742.             else
  4743.               result_header_ptr=NULL;
  4744.           else
  4745.             {
  4746.               fatal_error=TRUE;
  4747.               result_header_ptr=NULL;
  4748.               printf(
  4749.           "Fatal error:  extraneous argument supplied to function \"%s\" on\n",
  4750.                function_name);
  4751.               printf("     line %ld, column %ld.\n",source_line_num,
  4752.                source_column_num);
  4753.             }
  4754.       return(result_header_ptr);
  4755.     }
  4756.  
  4757. static value_header_ptr function_header_ptr(evaluate)
  4758.   int evaluate;
  4759.     {
  4760.       queue_node_ptr   new_queue_head;
  4761.       queue_node_ptr   new_queue_tail;
  4762.       queue_node_ptr   queue_head;
  4763.       queue_node_ptr   queue_tail;
  4764.       value_header_ptr result_header_ptr;
  4765.       char             function_name [256];
  4766.  
  4767.       get_token();
  4768.       strcpy(function_name,source_token);
  4769.       queue_head=NULL;
  4770.       queue_tail=NULL;
  4771.       if (source_char == '(')
  4772.         {
  4773.           get_token();
  4774.           if ((queue_head=(queue_node_ptr)
  4775.            malloc((unsigned) sizeof(struct queue_node)))
  4776.            == NULL)
  4777.             {
  4778.               fatal_error=TRUE;
  4779.               result_header_ptr=NULL;
  4780.               printf("Fatal error:  out of memory at line %ld, column %ld.\n",
  4781.                source_line_num,source_column_num);
  4782.             }
  4783.           else
  4784.             {
  4785.               queue_tail=queue_head;
  4786.               (*queue_head).next=NULL;
  4787.               (*queue_head).argument_header_ptr
  4788.                =interpret_expression(evaluate);
  4789.             }
  4790.           if (! fatal_error)
  4791.             get_token();
  4792.           while ((! fatal_error)
  4793.           &&     (! source_eof)
  4794.           &&     (source_token[0] != ')'))
  4795.             {
  4796.               if ((new_queue_tail=(queue_node_ptr)
  4797.                malloc((unsigned) sizeof(struct queue_node)))
  4798.                == NULL)
  4799.                 {
  4800.                   fatal_error=TRUE;
  4801.                   result_header_ptr=NULL;
  4802.                   printf(
  4803.                    "Fatal error:  out of memory at line %ld, column %ld.\n",
  4804.                    source_line_num,source_column_num);
  4805.                 }
  4806.               else
  4807.                 {
  4808.                   (*new_queue_tail).next=NULL;
  4809.                   (*queue_tail).next=new_queue_tail;
  4810.                   queue_tail=new_queue_tail;
  4811.                   (*new_queue_tail).argument_header_ptr
  4812.                    =interpret_expression(evaluate);
  4813.                 }
  4814.               if (! fatal_error)
  4815.                 get_token();
  4816.             }
  4817.           if (! fatal_error)
  4818.             {
  4819.               if (source_token[0] != ')')
  4820.                 {
  4821.                   fatal_error=TRUE;
  4822.                   result_header_ptr=NULL;
  4823.                   printf(
  4824.    "Fatal error:  file ends before arguments to function \"%s\" completed.\n",
  4825.                    function_name);
  4826.                 }
  4827.             }
  4828.         }
  4829.       if (! fatal_error)
  4830.         {
  4831.           result_header_ptr
  4832.            =variable_header_ptr(function_name,evaluate,queue_head);
  4833.           if (! fatal_error)
  4834.             {
  4835.               if (result_header_ptr == NULL)
  4836.                 {
  4837.                   if      (strcmp(function_name,"ABS") == 0)
  4838.                     result_header_ptr
  4839.                      =abs_header_ptr(queue_head,function_name,evaluate);
  4840.                   else if (strcmp(function_name,"ATAN") == 0)
  4841.                     result_header_ptr
  4842.                      =atan_header_ptr(queue_head,function_name,evaluate);
  4843.                   else if (strcmp(function_name,"CHAR") == 0)
  4844.                     result_header_ptr
  4845.                      =char_header_ptr(queue_head,function_name,evaluate);
  4846.                   else if (strcmp(function_name,"COS") == 0)
  4847.                     result_header_ptr
  4848.                      =cos_header_ptr(queue_head,function_name,evaluate);
  4849.                   else if (strcmp(function_name,"DATE") == 0)
  4850.                     result_header_ptr
  4851.                      =date_header_ptr(queue_head,function_name,evaluate);
  4852.                   else if (strcmp(function_name,"ENDFILE") == 0)
  4853.                     result_header_ptr
  4854.                      =endfile_header_ptr(queue_head,function_name,evaluate);
  4855.                   else if (strcmp(function_name,"EXEC") == 0)
  4856.                     result_header_ptr
  4857.                      =exec_header_ptr(queue_head,function_name,evaluate);
  4858.                   else if (strcmp(function_name,"EXP") == 0)
  4859.                     result_header_ptr
  4860.                      =exp_header_ptr(queue_head,function_name,evaluate);
  4861.                   else if (strcmp(function_name,"FALSE") == 0)
  4862.                     result_header_ptr
  4863.                      =false_header_ptr(queue_head,function_name,evaluate);
  4864.                   else if (strcmp(function_name,"FLOAT") == 0)
  4865.                     result_header_ptr
  4866.                      =float_header_ptr(queue_head,function_name,evaluate);
  4867.                   else if (strcmp(function_name,"GETCHAR") == 0)
  4868.                     result_header_ptr
  4869.                      =getchar_header_ptr(queue_head,function_name,evaluate);
  4870.                   else if (strcmp(function_name,"GETINT") == 0)
  4871.                     result_header_ptr
  4872.                      =getint_header_ptr(queue_head,function_name,evaluate);
  4873.                   else if (strcmp(function_name,"GETREAL") == 0)
  4874.                     result_header_ptr
  4875.                      =getreal_header_ptr(queue_head,function_name,evaluate);
  4876.                   else if (strcmp(function_name,"GETSTRING") == 0)
  4877.                     result_header_ptr
  4878.                      =getstring_header_ptr(queue_head,function_name,evaluate);
  4879.                   else if (strcmp(function_name,"INDEX") == 0)
  4880.                     result_header_ptr
  4881.                      =index_header_ptr(queue_head,function_name,evaluate);
  4882.                   else if (strcmp(function_name,"LENGTH") == 0)
  4883.                     result_header_ptr
  4884.                      =length_header_ptr(queue_head,function_name,evaluate);
  4885.                   else if (strcmp(function_name,"LINENO") == 0)
  4886.                     result_header_ptr
  4887.                      =lineno_header_ptr(queue_head,function_name,evaluate);
  4888.                   else if (strcmp(function_name,"LOG") == 0)
  4889.                     result_header_ptr
  4890.                      =log_header_ptr(queue_head,function_name,evaluate);
  4891.                   else if (strcmp(function_name,"MOD") == 0)
  4892.                     result_header_ptr
  4893.                      =mod_header_ptr(queue_head,function_name,evaluate);
  4894.                   else if (strcmp(function_name,"OPEN") == 0)
  4895.                     result_header_ptr
  4896.                      =open_header_ptr(queue_head,function_name,evaluate);
  4897.                   else if (strcmp(function_name,"ORD") == 0)
  4898.                     result_header_ptr
  4899.                      =ord_header_ptr(queue_head,function_name,evaluate);
  4900.                   else if (strcmp(function_name,"PI") == 0)
  4901.                     result_header_ptr
  4902.                      =pi_header_ptr(queue_head,function_name,evaluate);
  4903.                   else if (strcmp(function_name,"PLIRETV") == 0)
  4904.                     result_header_ptr
  4905.                      =pliretv_header_ptr(queue_head,function_name,evaluate);
  4906.                   else if (strcmp(function_name,"REPEAT") == 0)
  4907.                     result_header_ptr
  4908.                      =repeat_header_ptr(queue_head,function_name,evaluate);
  4909.                   else if (strcmp(function_name,"SIN") == 0)
  4910.                     result_header_ptr
  4911.                      =sin_header_ptr(queue_head,function_name,evaluate);
  4912.                   else if (strcmp(function_name,"SQR") == 0)
  4913.                     result_header_ptr
  4914.                      =sqr_header_ptr(queue_head,function_name,evaluate);
  4915.                   else if (strcmp(function_name,"SQRT") == 0)
  4916.                     result_header_ptr
  4917.                      =sqrt_header_ptr(queue_head,function_name,evaluate);
  4918.                   else if (strcmp(function_name,"STR") == 0)
  4919.                     result_header_ptr
  4920.                      =str_header_ptr(queue_head,function_name,evaluate);
  4921.                   else if (strcmp(function_name,"SUBSTR") == 0)
  4922.                     result_header_ptr
  4923.                      =substr_header_ptr(queue_head,function_name,evaluate);
  4924.                   else if (strcmp(function_name,"SYSIN") == 0)
  4925.                     result_header_ptr
  4926.                      =sysin_header_ptr(queue_head,function_name,evaluate);
  4927.                   else if (strcmp(function_name,"SYSPRINT") == 0)
  4928.                     result_header_ptr
  4929.                      =sysprint_header_ptr(queue_head,function_name,evaluate);
  4930.                   else if (strcmp(function_name,"TIME") == 0)
  4931.                     result_header_ptr
  4932.                      =time_header_ptr(queue_head,function_name,evaluate);
  4933.                   else if (strcmp(function_name,"TRANSLATE") == 0)
  4934.                     result_header_ptr
  4935.                      =translate_header_ptr(queue_head,function_name,evaluate);
  4936.                   else if (strcmp(function_name,"TRUE") == 0)
  4937.                     result_header_ptr
  4938.                      =true_header_ptr(queue_head,function_name,evaluate);
  4939.                   else if (strcmp(function_name,"TRUNC") == 0)
  4940.                     result_header_ptr
  4941.                      =trunc_header_ptr(queue_head,function_name,evaluate);
  4942.                   else if (strcmp(function_name,"UPPER") == 0)
  4943.                     result_header_ptr
  4944.                      =upper_header_ptr(queue_head,function_name,evaluate);
  4945.                   else if (strcmp(function_name,"VERIFY") == 0)
  4946.                     result_header_ptr
  4947.                      =verify_header_ptr(queue_head,function_name,evaluate);
  4948.                   else
  4949.                     {
  4950.                       if (evaluate)
  4951.                         {
  4952.                           fatal_error=TRUE;
  4953.                           printf(
  4954.                  "Fatal error:  the function \"%s\" on line %ld, column %ld\n",
  4955.                            function_name,source_line_num,source_column_num);
  4956.                           printf("     is unknown.\n");
  4957.                         }
  4958.                     }
  4959.                }
  4960.             }
  4961.         }
  4962.       while (queue_head != NULL)
  4963.         {
  4964.           new_queue_head=(*queue_head).next;
  4965.           free_value((*queue_head).argument_header_ptr);
  4966.           free((char *) queue_head);
  4967.           queue_head=new_queue_head;
  4968.         }
  4969.       return(result_header_ptr);
  4970.     }
  4971.  
  4972. static value_header_ptr factor_header_ptr(evaluate)
  4973.   int evaluate;
  4974.     {
  4975.       value_header_ptr result_header_ptr;
  4976.  
  4977.       while ((source_char == ' ')
  4978.       &&     (! source_eof))
  4979.         get_source_char();
  4980.       if (source_eof)
  4981.         {
  4982.           fatal_error=TRUE;
  4983.           result_header_ptr=NULL;
  4984.           printf(
  4985.            "Fatal error:  end of file encountered where factor expected.\n");
  4986.         }
  4987.       else
  4988.         {
  4989.           switch (source_char)
  4990.             {
  4991.               case '(':
  4992.                 get_source_char();
  4993.                 result_header_ptr=interpret_expression(evaluate);
  4994.                 if (! fatal_error)
  4995.                   {
  4996.                     while ((source_char == ' ')
  4997.                     &&     (! source_eof))
  4998.                       get_source_char();
  4999.                     if (source_eof)
  5000.                       {
  5001.                         fatal_error=TRUE;
  5002.                         free_value(result_header_ptr);
  5003.                         result_header_ptr=NULL;
  5004.                         printf(
  5005.               "Fatal error:  end of file encountered where \"(\" expected.\n");
  5006.                       }
  5007.                     else
  5008.                       if (source_char == ')')
  5009.                         get_source_char();
  5010.                       else
  5011.                         {
  5012.                           fatal_error=TRUE;
  5013.                           free_value(result_header_ptr);
  5014.                           result_header_ptr=NULL;
  5015.                           printf(
  5016.    "Fatal error:  expression not followed by \"(\" on line %ld, column %ld.\n",
  5017.                            source_line_num,source_column_num);
  5018.                         }
  5019.                   }
  5020.                 break;
  5021.               case '!':
  5022.                 get_source_char();
  5023.                 result_header_ptr=factor_header_ptr(evaluate);
  5024.                 if (! fatal_error)
  5025.                   {
  5026.                     if (evaluate)
  5027.                       if ((*result_header_ptr).type == 'B')
  5028.                         *((*result_header_ptr).value_ptr.boolean)
  5029.                          =! (*((*result_header_ptr).value_ptr.boolean));
  5030.                       else
  5031.                         {
  5032.                           fatal_error=TRUE;
  5033.                           free_value(result_header_ptr);
  5034.                           result_header_ptr=NULL;
  5035.                           printf(
  5036.        "Fatal error:  other than a boolean negated at line %ld, column %ld.\n",
  5037.                            source_line_num,source_column_num);
  5038.                         }
  5039.                     else
  5040.                       result_header_ptr=NULL;
  5041.                   }
  5042.                 break;
  5043.               case '\'':
  5044.                 result_header_ptr=string_header_ptr(evaluate);
  5045.                 break;
  5046.               case '0':
  5047.               case '1':
  5048.               case '2':
  5049.               case '3':
  5050.               case '4':
  5051.               case '5':
  5052.               case '6':
  5053.               case '7':
  5054.               case '8':
  5055.               case '9':
  5056.                 result_header_ptr=unsigned_number_header_ptr(evaluate);
  5057.                 break;
  5058.               default:
  5059.                result_header_ptr=function_header_ptr(evaluate);
  5060.                break;
  5061.             }
  5062.         }
  5063.       return(result_header_ptr);
  5064.     }
  5065.  
  5066. static value_header_ptr and_factors(left_header_ptr,right_header_ptr)
  5067.   value_header_ptr left_header_ptr;
  5068.   value_header_ptr right_header_ptr;
  5069.     {
  5070.       value_header_ptr result_header_ptr;
  5071.  
  5072.       if (((*left_header_ptr).type == 'B')
  5073.       &&  ((*right_header_ptr).type == 'B'))
  5074.         {
  5075.           result_header_ptr=new_boolean_header_ptr();
  5076.           if (! fatal_error)
  5077.             *((*result_header_ptr).value_ptr.boolean)
  5078.              =(*((*left_header_ptr).value_ptr.boolean))
  5079.              && (*((*right_header_ptr).value_ptr.boolean));
  5080.         }
  5081.       else
  5082.         {
  5083.           fatal_error=TRUE;
  5084.           result_header_ptr=NULL;
  5085.           printf(
  5086.            "Fatal error:  attempt to \"and\" other than two booleans\n");
  5087.           printf(
  5088.            "at line %ld, column %ld.\n",source_line_num,source_column_num);
  5089.         }
  5090.       return(result_header_ptr);
  5091.     }
  5092.  
  5093. static value_header_ptr divide_factors(left_header_ptr,right_header_ptr)
  5094.   value_header_ptr left_header_ptr;
  5095.   value_header_ptr right_header_ptr;
  5096.     {
  5097.       double           left_value;
  5098.       value_header_ptr result_header_ptr;
  5099.       double           right_value;
  5100.       double           tem_real;
  5101.  
  5102.       if (((*left_header_ptr).type == 'I')
  5103.       &&  ((*right_header_ptr).type == 'I'))
  5104.         {
  5105.           if (*((*right_header_ptr).value_ptr.integer) == (long) 0)
  5106.             {
  5107.               fatal_error=TRUE;
  5108.               result_header_ptr=NULL;
  5109.               printf(
  5110.          "Fatal error:  division by zero attempted at line %ld, column %ld.\n",
  5111.                source_line_num,source_column_num);
  5112.             }
  5113.           else
  5114.             {
  5115.               result_header_ptr=new_integer_header_ptr();
  5116.               if (! fatal_error)
  5117.                 {
  5118.                   *((*result_header_ptr).value_ptr.integer)
  5119.                    =(*((*left_header_ptr).value_ptr.integer))
  5120.                    /(*((*right_header_ptr).value_ptr.integer));
  5121.                 }
  5122.             }
  5123.         }
  5124.       else
  5125.         if (((*left_header_ptr).type == 'R')
  5126.         &&  ((*right_header_ptr).type == 'R'))
  5127.           {
  5128.             if (*((*right_header_ptr).value_ptr.real) == 0.0)
  5129.               {
  5130.                 fatal_error=TRUE;
  5131.                 result_header_ptr=NULL;
  5132.                 printf(
  5133.          "Fatal error:  division by zero attempted at line %ld, column %ld.\n",
  5134.                  source_line_num,source_column_num);
  5135.               }
  5136.             else
  5137.               {
  5138.                 result_header_ptr=new_real_header_ptr();
  5139.                 if (! fatal_error)
  5140.                   {
  5141.                     left_value=*((*left_header_ptr).value_ptr.real);
  5142.                     right_value=*((*right_header_ptr).value_ptr.real);
  5143.                     if (left_value == 0.0)
  5144.                       tem_real=0.0;
  5145.                     else
  5146.                       tem_real
  5147.                        =(log(fabs(left_value))-log(fabs(right_value)))
  5148.                        /log(10.0);
  5149.                     if (tem_real < -37.0)
  5150.                       *((*result_header_ptr).value_ptr.real)=0.0;
  5151.                     else
  5152.                       if (tem_real > 37.0)
  5153.                         {
  5154.                           fatal_error=TRUE;
  5155.                           free_value(result_header_ptr);
  5156.                           result_header_ptr=NULL;
  5157.                           printf(
  5158.       "Fatal error:  overflow detected in division at line %ld, column %ld.\n",
  5159.                            source_line_num,source_column_num);
  5160.                         }
  5161.                       else
  5162.                         *((*result_header_ptr).value_ptr.real)
  5163.                          =left_value/right_value;
  5164.                   }
  5165.               }
  5166.           }
  5167.         else
  5168.           if (((*left_header_ptr).type == 'I')
  5169.           &&  ((*right_header_ptr).type == 'R'))
  5170.             {
  5171.               if (*((*right_header_ptr).value_ptr.real) == 0.0)
  5172.                 {
  5173.                   fatal_error=TRUE;
  5174.                   result_header_ptr=NULL;
  5175.                   printf(
  5176.          "Fatal error:  division by zero attempted at line %ld, column %ld.\n",
  5177.                    source_line_num,source_column_num);
  5178.                 }
  5179.               else
  5180.                 {
  5181.                   result_header_ptr=new_real_header_ptr();
  5182.                   if (! fatal_error)
  5183.                     {
  5184.                       left_value
  5185.                        =(float) *((*left_header_ptr).value_ptr.integer);
  5186.                       right_value=*((*right_header_ptr).value_ptr.real);
  5187.                       if (left_value == 0.0)
  5188.                         tem_real=0.0;
  5189.                       else
  5190.                         tem_real
  5191.                          =(log(fabs(left_value))-log(fabs(right_value)))
  5192.                          /log(10.0);
  5193.                       if (tem_real < -37.0)
  5194.                         *((*result_header_ptr).value_ptr.real)=0.0;
  5195.                       else
  5196.                         if (tem_real > 37.0)
  5197.                           {
  5198.                             fatal_error=TRUE;
  5199.                             free_value(result_header_ptr);
  5200.                             result_header_ptr=NULL;
  5201.                             printf(
  5202.       "Fatal error:  overflow detected in division at line %ld, column %ld.\n",
  5203.                              source_line_num,source_column_num);
  5204.                           }
  5205.                         else
  5206.                           *((*result_header_ptr).value_ptr.real)
  5207.                            =left_value/right_value;
  5208.                     }
  5209.                 }
  5210.             }
  5211.           else
  5212.             if (((*left_header_ptr).type == 'R')
  5213.             &&  ((*right_header_ptr).type == 'I'))
  5214.               {
  5215.                 if (*((*right_header_ptr).value_ptr.integer) == 0)
  5216.                   {
  5217.                     fatal_error=TRUE;
  5218.                     result_header_ptr=NULL;
  5219.                     printf(
  5220.          "Fatal error:  division by zero attempted at line %ld, column %ld.\n",
  5221.                      source_line_num,source_column_num);
  5222.                   }
  5223.                 else
  5224.                   {
  5225.                     result_header_ptr=new_real_header_ptr();
  5226.                     if (! fatal_error)
  5227.                       {
  5228.                         left_value=*((*left_header_ptr).value_ptr.real);
  5229.                         right_value
  5230.                          =(float) *((*right_header_ptr).value_ptr.integer);
  5231.                         if (left_value == 0.0)
  5232.                           tem_real=0.0;
  5233.                         else
  5234.                           tem_real
  5235.                            =(log(fabs(left_value))-log(fabs(right_value)))
  5236.                            /log(10.0);
  5237.                         if (tem_real < -37.0)
  5238.                           *((*result_header_ptr).value_ptr.real)=0.0;
  5239.                         else
  5240.                           if (tem_real > 37.0)
  5241.                             {
  5242.                               fatal_error=TRUE;
  5243.                               free_value(result_header_ptr);
  5244.                               result_header_ptr=NULL;
  5245.                               printf(
  5246.       "Fatal error:  overflow detected in division at line %ld, column %ld.\n",
  5247.                                source_line_num,source_column_num);
  5248.                             }
  5249.                           else
  5250.                             *((*result_header_ptr).value_ptr.real)
  5251.                              =left_value/right_value;
  5252.                       }
  5253.                   }
  5254.               }
  5255.             else
  5256.               {
  5257.                 fatal_error=TRUE;
  5258.                 result_header_ptr=NULL;
  5259.                 printf(
  5260.                 "Fatal error:  attempt to divide other than two numbers at\n");
  5261.                 printf(
  5262.                  "line %ld, column %ld.\n",source_line_num,source_column_num);
  5263.               }
  5264.       return(result_header_ptr);
  5265.     }
  5266.  
  5267. static value_header_ptr multiply_factors(left_header_ptr,right_header_ptr)
  5268.   value_header_ptr left_header_ptr;
  5269.   value_header_ptr right_header_ptr;
  5270.     {
  5271.       long             left_integer_value;
  5272.       double           left_real_value;
  5273.       value_header_ptr result_header_ptr;
  5274.       long             right_integer_value;
  5275.       double           right_real_value;
  5276.       double           tem_real;
  5277.  
  5278.       if (((*left_header_ptr).type == 'I')
  5279.       &&  ((*right_header_ptr).type == 'I'))
  5280.         {
  5281.           result_header_ptr=new_integer_header_ptr();
  5282.           if (! fatal_error)
  5283.             {
  5284.               left_integer_value=*((*left_header_ptr).value_ptr.integer);
  5285.               right_integer_value=*((*right_header_ptr).value_ptr.integer);
  5286.               if ((left_integer_value == 0) || (right_integer_value == 0))
  5287.                 tem_real=0.0;
  5288.               else
  5289.                 {
  5290.                   left_real_value=(float) left_integer_value;
  5291.                   right_real_value=(float) right_integer_value;
  5292.                   tem_real
  5293.                    =(log(fabs(left_real_value))+log(fabs(right_real_value)))
  5294.                    /log(2.0);
  5295.                 }
  5296.               if (tem_real >= 31.0)
  5297.                 {
  5298.                   fatal_error=TRUE;
  5299.                   free_value(result_header_ptr);
  5300.                   result_header_ptr=NULL;
  5301.                   printf(
  5302. "Fatal error:  overflow detected in multiplication at line %ld, column %ld.\n",
  5303.                    source_line_num,source_column_num);
  5304.                 }
  5305.               else
  5306.                 *((*result_header_ptr).value_ptr.integer)
  5307.                  =left_integer_value*right_integer_value;
  5308.             }
  5309.         }
  5310.       else
  5311.         if (((*left_header_ptr).type == 'R')
  5312.         &&  ((*right_header_ptr).type == 'R'))
  5313.           {
  5314.             result_header_ptr=new_real_header_ptr();
  5315.             if (! fatal_error)
  5316.               {
  5317.                 left_real_value=*((*left_header_ptr).value_ptr.real);
  5318.                 right_real_value=*((*right_header_ptr).value_ptr.real);
  5319.                 if ((left_real_value == 0.0) || (right_real_value == 0.0))
  5320.                   tem_real=0.0;
  5321.                 else
  5322.                   tem_real
  5323.                    =(log(fabs(left_real_value))+log(fabs(right_real_value)))
  5324.                    /log(10.0);
  5325.                 if (tem_real < -37.0)
  5326.                   *((*result_header_ptr).value_ptr.real)=0.0;
  5327.                 else
  5328.                   if (tem_real > 37.0)
  5329.                     {
  5330.                       fatal_error=TRUE;
  5331.                       free_value(result_header_ptr);
  5332.                       result_header_ptr=NULL;
  5333.                       printf(
  5334. "Fatal error:  overflow detected in multiplication at line %ld, column %ld.\n",
  5335.                        source_line_num,source_column_num);
  5336.                     }
  5337.                   else
  5338.                     *((*result_header_ptr).value_ptr.real)
  5339.                      =left_real_value*right_real_value;
  5340.               }
  5341.           }
  5342.         else
  5343.           if (((*left_header_ptr).type == 'I')
  5344.           &&  ((*right_header_ptr).type == 'R'))
  5345.             {
  5346.               result_header_ptr=new_real_header_ptr();
  5347.               if (! fatal_error)
  5348.                 {
  5349.                   left_real_value
  5350.                    =(float) *((*left_header_ptr).value_ptr.integer);
  5351.                   right_real_value=*((*right_header_ptr).value_ptr.real);
  5352.                   if ((left_real_value == 0.0) || (right_real_value == 0.0))
  5353.                     tem_real=0.0;
  5354.                   else
  5355.                     tem_real
  5356.                      =(log(fabs(left_real_value))+log(fabs(right_real_value)))
  5357.                      /log(10.0);
  5358.                   if (tem_real < -37.0)
  5359.                     *((*result_header_ptr).value_ptr.real)=0.0;
  5360.                   else
  5361.                     if (tem_real > 37.0)
  5362.                       {
  5363.                         fatal_error=TRUE;
  5364.                         free_value(result_header_ptr);
  5365.                         result_header_ptr=NULL;
  5366.                         printf(
  5367. "Fatal error:  overflow detected in multiplication at line %ld, column %ld.\n",
  5368.                          source_line_num,source_column_num);
  5369.                       }
  5370.                     else
  5371.                       *((*result_header_ptr).value_ptr.real)
  5372.                        =left_real_value*right_real_value;
  5373.                 }
  5374.             }
  5375.           else
  5376.             if (((*left_header_ptr).type == 'R')
  5377.             &&  ((*right_header_ptr).type == 'I'))
  5378.               {
  5379.                 result_header_ptr=new_real_header_ptr();
  5380.                 if (! fatal_error)
  5381.                   {
  5382.                     left_real_value=*((*left_header_ptr).value_ptr.real);
  5383.                     right_real_value
  5384.                      =(float) *((*right_header_ptr).value_ptr.integer);
  5385.                     if ((left_real_value == 0.0) || (right_real_value == 0.0))
  5386.                       tem_real=0.0;
  5387.                     else
  5388.                       tem_real
  5389.                        =(log(fabs(left_real_value))
  5390.                        +log(fabs(right_real_value)))
  5391.                        /log(10.0);
  5392.                     if (tem_real < -37.0)
  5393.                       *((*result_header_ptr).value_ptr.real)=0.0;
  5394.                     else
  5395.                       if (tem_real > 37.0)
  5396.                         {
  5397.                           fatal_error=TRUE;
  5398.                           free_value(result_header_ptr);
  5399.                           result_header_ptr=NULL;
  5400.                           printf(
  5401. "Fatal error:  overflow detected in multiplication at line %ld, column %ld.\n",
  5402.                            source_line_num,source_column_num);
  5403.                         }
  5404.                       else
  5405.                         *((*result_header_ptr).value_ptr.real)
  5406.                          =left_real_value*right_real_value;
  5407.                   }
  5408.               }
  5409.             else
  5410.               {
  5411.                 fatal_error=TRUE;
  5412.                 result_header_ptr=NULL;
  5413.                 printf(
  5414.               "Fatal error:  attempt to multiply other than two numbers at\n");
  5415.                 printf(
  5416.                  "line %ld, column %ld.\n",source_line_num,source_column_num);
  5417.               }
  5418.       return(result_header_ptr);
  5419.     }
  5420.  
  5421. static void get_factor_operator(operator)
  5422.   char *operator;
  5423.     {
  5424.       while ((source_char == ' ')
  5425.       &&     (! source_eof))
  5426.         get_source_char();
  5427.       switch (source_char)
  5428.         {
  5429.           case '*':
  5430.             *operator=source_char;
  5431.             get_source_char();
  5432.             break;
  5433.           case '/':
  5434.             *operator=source_char;
  5435.             get_source_char();
  5436.             break;
  5437.           case '&':
  5438.             *operator=source_char;
  5439.             get_source_char();
  5440.             break;
  5441.           default:
  5442.             *operator='\0';
  5443.             break;
  5444.         }
  5445.       return;
  5446.     }
  5447.  
  5448. static value_header_ptr term_header_ptr(evaluate)
  5449.   int evaluate;
  5450.     {
  5451.       value_header_ptr left_header_ptr;
  5452.       char             operator;
  5453.       int              operator_found;
  5454.       value_header_ptr result_header_ptr;
  5455.       value_header_ptr right_header_ptr;
  5456.  
  5457.       while ((source_char == ' ')
  5458.       &&     (! source_eof))
  5459.         get_source_char();
  5460.       if (source_char == ' ')
  5461.         {
  5462.           fatal_error=TRUE;
  5463.           result_header_ptr=NULL;
  5464.           printf(
  5465.            "Fatal error:  end of file encountered where term expected.\n");
  5466.         }
  5467.       else
  5468.         {
  5469.           result_header_ptr=factor_header_ptr(evaluate);
  5470.           operator_found=TRUE;
  5471.           while ((! fatal_error)
  5472.           &&     (operator_found))
  5473.             {
  5474.               get_factor_operator(&operator);
  5475.               if ((operator != '*')
  5476.               &&  (operator != '/')
  5477.               &&  (operator != '&'))
  5478.                  operator_found=FALSE;
  5479.               else
  5480.                 {
  5481.                   right_header_ptr=factor_header_ptr(evaluate);
  5482.                   if (fatal_error)
  5483.                     {
  5484.                       free_value(result_header_ptr);
  5485.                       result_header_ptr=NULL;
  5486.                     }
  5487.                   else
  5488.                     {
  5489.                       left_header_ptr=result_header_ptr;
  5490.                       if (evaluate)
  5491.                         {
  5492.                           switch (operator)
  5493.                             {
  5494.                               case '*':
  5495.                                 result_header_ptr=multiply_factors(
  5496.                                  left_header_ptr,right_header_ptr);
  5497.                                 break;
  5498.                               case '/':
  5499.                                 result_header_ptr=divide_factors(
  5500.                                  left_header_ptr,right_header_ptr);
  5501.                                 break;
  5502.                               default:
  5503.                                 result_header_ptr=and_factors(
  5504.                                  left_header_ptr,right_header_ptr);
  5505.                                 break;
  5506.                             }
  5507.                           free_value(left_header_ptr);
  5508.                           free_value(right_header_ptr);
  5509.                         }
  5510.                       else
  5511.                         result_header_ptr=NULL;
  5512.                     }
  5513.                 }
  5514.             }
  5515.         }
  5516.       return(result_header_ptr);
  5517.     }
  5518.  
  5519. static value_header_ptr concatenate_terms(left_header_ptr,right_header_ptr)
  5520.   value_header_ptr left_header_ptr;
  5521.   value_header_ptr right_header_ptr;
  5522.     {
  5523.       register int     char_index;
  5524.       unsigned char    *char_ptr;
  5525.       unsigned char    *result_char_ptr;
  5526.       value_header_ptr result_header_ptr;
  5527.       unsigned         string_length;
  5528.  
  5529.       if (((*left_header_ptr).type == 'S')
  5530.       &&  ((*right_header_ptr).type == 'S'))
  5531.         {
  5532.           result_header_ptr=new_string_header_ptr((unsigned)
  5533.            (*((*left_header_ptr).value_ptr.string)).length
  5534.            +(unsigned) (*((*right_header_ptr).value_ptr.string)).length);
  5535.           if (! fatal_error)
  5536.             {
  5537.               result_char_ptr=(*((*result_header_ptr).value_ptr.string)).value;
  5538.               char_ptr=(*((*left_header_ptr).value_ptr.string)).value;
  5539.               string_length=(*((*left_header_ptr).value_ptr.string)).length;
  5540.               for (char_index=0; char_index < string_length; char_index++)
  5541.                 {
  5542.                   *result_char_ptr=*char_ptr;
  5543.                   result_char_ptr++;
  5544.                   char_ptr++;
  5545.                 }
  5546.               char_ptr=(*((*right_header_ptr).value_ptr.string)).value;
  5547.               string_length=(*((*right_header_ptr).value_ptr.string)).length;
  5548.               for (char_index=0; char_index < string_length; char_index++)
  5549.                 {
  5550.                   *result_char_ptr=*char_ptr;
  5551.                   result_char_ptr++;
  5552.                   char_ptr++;
  5553.                 }
  5554.               *result_char_ptr=(unsigned char) '\0';
  5555.             }
  5556.         }
  5557.       else
  5558.         {
  5559.           fatal_error=TRUE;
  5560.           result_header_ptr=NULL;
  5561.           printf(
  5562.            "Fatal error:  attempt to concatenate other than two strings\n");
  5563.           printf(
  5564.            "at line %ld, column %ld.\n",source_line_num,source_column_num);
  5565.         }
  5566.       return(result_header_ptr);
  5567.     }
  5568.  
  5569. static value_header_ptr add_terms(left_header_ptr,right_header_ptr)
  5570.   value_header_ptr left_header_ptr;
  5571.   value_header_ptr right_header_ptr;
  5572.     {
  5573.       long             left_integer_value;
  5574.       double           left_real_value;
  5575.       value_header_ptr result_header_ptr;
  5576.       long             right_integer_value;
  5577.       double           right_real_value;
  5578.  
  5579.       if (((*left_header_ptr).type == 'I')
  5580.       &&  ((*right_header_ptr).type == 'I'))
  5581.         {
  5582.           result_header_ptr=new_integer_header_ptr();
  5583.           if (! fatal_error)
  5584.             {
  5585.               left_integer_value=*((*left_header_ptr).value_ptr.integer);
  5586.               right_integer_value=*((*right_header_ptr).value_ptr.integer);
  5587.               if ((left_integer_value > 0) && (right_integer_value > 0))
  5588.                 if (left_integer_value
  5589.                  > ((long) 0x7fffffff - right_integer_value))
  5590.                   {
  5591.                     fatal_error=TRUE;
  5592.                     free_value(result_header_ptr);
  5593.                     result_header_ptr=NULL;
  5594.                     printf(
  5595.       "Fatal error:  overflow detected in addition at line %ld, column %ld.\n",
  5596.                      source_line_num,source_column_num);
  5597.                   }
  5598.                 else
  5599.                   *((*result_header_ptr).value_ptr.integer)
  5600.                    =left_integer_value+right_integer_value;
  5601.               else
  5602.                 if ((left_integer_value < 0) && (right_integer_value < 0))
  5603.                   if (left_integer_value
  5604.                    < (-((long) 0x7fffffff) - right_integer_value))
  5605.                     {
  5606.                       fatal_error=TRUE;
  5607.                       free_value(result_header_ptr);
  5608.                       result_header_ptr=NULL;
  5609.                       printf(
  5610.       "Fatal error:  overflow detected in addition at line %ld, column %ld.\n",
  5611.                        source_line_num,source_column_num);
  5612.                     }
  5613.                   else
  5614.                     *((*result_header_ptr).value_ptr.integer)
  5615.                      =left_integer_value+right_integer_value;
  5616.                 else
  5617.                   *((*result_header_ptr).value_ptr.integer)
  5618.                    =left_integer_value+right_integer_value;
  5619.             }
  5620.         }
  5621.       else
  5622.         if (((*left_header_ptr).type == 'R')
  5623.         &&  ((*right_header_ptr).type == 'R'))
  5624.           {
  5625.             result_header_ptr=new_real_header_ptr();
  5626.             if (! fatal_error)
  5627.               {
  5628.                 left_real_value=*((*left_header_ptr).value_ptr.real);
  5629.                 right_real_value=*((*right_header_ptr).value_ptr.real);
  5630.                 if ((left_real_value > 0.0) && (right_real_value > 0.0))
  5631.                   if (left_real_value > (1.0E37 - right_real_value))
  5632.                     {
  5633.                       fatal_error=TRUE;
  5634.                       free_value(result_header_ptr);
  5635.                       result_header_ptr=NULL;
  5636.                       printf(
  5637.       "Fatal error:  overflow detected in addition at line %ld, column %ld.\n",
  5638.                        source_line_num,source_column_num);
  5639.                     }
  5640.                   else
  5641.                     *((*result_header_ptr).value_ptr.real)
  5642.                      =left_real_value+right_real_value;
  5643.                 else
  5644.                   if ((left_real_value < 0.0) && (right_real_value < 0.0))
  5645.                     if (left_real_value < (-1.0E37 - right_real_value))
  5646.                       {
  5647.                         fatal_error=TRUE;
  5648.                         free_value(result_header_ptr);
  5649.                         result_header_ptr=NULL;
  5650.                         printf(
  5651.       "Fatal error:  overflow detected in addition at line %ld, column %ld.\n",
  5652.                          source_line_num,source_column_num);
  5653.                       }
  5654.                     else
  5655.                       *((*result_header_ptr).value_ptr.real)
  5656.                        =left_real_value+right_real_value;
  5657.                   else
  5658.                     *((*result_header_ptr).value_ptr.real)
  5659.                      =left_real_value+right_real_value;
  5660.               }
  5661.           }
  5662.         else
  5663.           if (((*left_header_ptr).type == 'I')
  5664.           &&  ((*right_header_ptr).type == 'R'))
  5665.             {
  5666.               result_header_ptr=new_real_header_ptr();
  5667.               if (! fatal_error)
  5668.                 {
  5669.                   left_real_value=(double)
  5670.                    *((*left_header_ptr).value_ptr.integer);
  5671.                   right_real_value=*((*right_header_ptr).value_ptr.real);
  5672.                   if ((left_real_value > 0.0) && (right_real_value > 0.0))
  5673.                     if (left_real_value > (1.0E37 - right_real_value))
  5674.                       {
  5675.                         fatal_error=TRUE;
  5676.                         free_value(result_header_ptr);
  5677.                         result_header_ptr=NULL;
  5678.                         printf(
  5679.       "Fatal error:  overflow detected in addition at line %ld, column %ld.\n",
  5680.                          source_line_num,source_column_num);
  5681.                       }
  5682.                     else
  5683.                       *((*result_header_ptr).value_ptr.real)
  5684.                        =left_real_value+right_real_value;
  5685.                   else
  5686.                     if ((left_real_value < 0.0) && (right_real_value < 0.0))
  5687.                       if (left_real_value < (-1.0E37 - right_real_value))
  5688.                         {
  5689.                           fatal_error=TRUE;
  5690.                           free_value(result_header_ptr);
  5691.                           result_header_ptr=NULL;
  5692.                           printf(
  5693.       "Fatal error:  overflow detected in addition at line %ld, column %ld.\n",
  5694.                            source_line_num,source_column_num);
  5695.                         }
  5696.                       else
  5697.                         *((*result_header_ptr).value_ptr.real)
  5698.                          =left_real_value+right_real_value;
  5699.                    else
  5700.                      *((*result_header_ptr).value_ptr.real)
  5701.                       =left_real_value+right_real_value;
  5702.                 }
  5703.             }
  5704.           else
  5705.             if (((*left_header_ptr).type == 'R')
  5706.             &&  ((*right_header_ptr).type == 'I'))
  5707.               {
  5708.                 result_header_ptr=new_real_header_ptr();
  5709.                 if (! fatal_error)
  5710.                   {
  5711.                     left_real_value=*((*left_header_ptr).value_ptr.real);
  5712.                     right_real_value=*((*right_header_ptr).value_ptr.real);
  5713.                     if ((left_real_value > 0.0)
  5714.                     && (right_real_value > 0.0))
  5715.                       if (left_real_value > (1.0E37 - right_real_value))
  5716.                         {
  5717.                           fatal_error=TRUE;
  5718.                           free_value(result_header_ptr);
  5719.                           result_header_ptr=NULL;
  5720.                           printf(
  5721.       "Fatal error:  overflow detected in addition at line %ld, column %ld.\n",
  5722.                            source_line_num,source_column_num);
  5723.                         }
  5724.                       else
  5725.                         *((*result_header_ptr).value_ptr.real)
  5726.                          =left_real_value+right_real_value;
  5727.                     else
  5728.                       if ((left_real_value < 0.0)
  5729.                       &&  (right_real_value < 0.0))
  5730.                         if (left_real_value < (-1.0E37 - right_real_value))
  5731.                           {
  5732.                             fatal_error=TRUE;
  5733.                             free_value(result_header_ptr);
  5734.                             result_header_ptr=NULL;
  5735.                             printf(
  5736.       "Fatal error:  overflow detected in addition at line %ld, column %ld.\n",
  5737.                              source_line_num,source_column_num);
  5738.                           }
  5739.                         else
  5740.                           *((*result_header_ptr).value_ptr.real)
  5741.                            =left_real_value+right_real_value;
  5742.                       else
  5743.                         *((*result_header_ptr).value_ptr.real)
  5744.                          =left_real_value+right_real_value;
  5745.                   }
  5746.               }
  5747.             else
  5748.               {
  5749.                 fatal_error=TRUE;
  5750.                 result_header_ptr=NULL;
  5751.                 printf(
  5752.                  "Fatal error:  attempt to add other than two numbers at\n");
  5753.                 printf(
  5754.                  "line %ld, column %ld.\n",source_line_num,source_column_num);
  5755.               }
  5756.       return(result_header_ptr);
  5757.     }
  5758.  
  5759. static value_header_ptr subtract_terms(left_header_ptr,right_header_ptr)
  5760.   value_header_ptr left_header_ptr;
  5761.   value_header_ptr right_header_ptr;
  5762.     {
  5763.       long             left_integer_value;
  5764.       double           left_real_value;
  5765.       value_header_ptr result_header_ptr;
  5766.       long             right_integer_value;
  5767.       double           right_real_value;
  5768.  
  5769.       if (((*left_header_ptr).type == 'I')
  5770.       &&  ((*right_header_ptr).type == 'I'))
  5771.         {
  5772.           result_header_ptr=new_integer_header_ptr();
  5773.           if (! fatal_error)
  5774.             {
  5775.               left_integer_value=*((*left_header_ptr).value_ptr.integer);
  5776.               right_integer_value=*((*right_header_ptr).value_ptr.integer);
  5777.               if ((left_integer_value < 0) && (right_integer_value > 0))
  5778.                 if (left_integer_value
  5779.                  < (right_integer_value-((long) 0x7fffffff)))
  5780.                   {
  5781.                     fatal_error=TRUE;
  5782.                     free_value(result_header_ptr);
  5783.                     result_header_ptr=NULL;
  5784.                     printf(
  5785.       "Fatal error:  overflow detected in addition at line %ld, column %ld.\n",
  5786.                      source_line_num,source_column_num);
  5787.                   }
  5788.                 else
  5789.                   *((*result_header_ptr).value_ptr.integer)
  5790.                    =left_integer_value-right_integer_value;
  5791.               else
  5792.                 if ((left_integer_value > 0) && (right_integer_value < 0))
  5793.                   if (left_integer_value
  5794.                    > (right_integer_value+(long) 0x7fffffff))
  5795.                     {
  5796.                       fatal_error=TRUE;
  5797.                       free_value(result_header_ptr);
  5798.                       result_header_ptr=NULL;
  5799.                       printf(
  5800.       "Fatal error:  overflow detected in addition at line %ld, column %ld.\n",
  5801.                        source_line_num,source_column_num);
  5802.                     }
  5803.                   else
  5804.                     *((*result_header_ptr).value_ptr.integer)
  5805.                      =left_integer_value-right_integer_value;
  5806.                 else
  5807.                   *((*result_header_ptr).value_ptr.integer)
  5808.                    =left_integer_value-right_integer_value;
  5809.             }
  5810.         }
  5811.       else
  5812.         if (((*left_header_ptr).type == 'R')
  5813.         &&  ((*right_header_ptr).type == 'R'))
  5814.           {
  5815.             result_header_ptr=new_real_header_ptr();
  5816.             if (! fatal_error)
  5817.               {
  5818.                 left_real_value=*((*left_header_ptr).value_ptr.real);
  5819.                 right_real_value=*((*right_header_ptr).value_ptr.real);
  5820.                 if ((left_real_value < 0.0) && (right_real_value > 0.0))
  5821.                   if (left_real_value < (right_real_value-1.0E37))
  5822.                     {
  5823.                       fatal_error=TRUE;
  5824.                       free_value(result_header_ptr);
  5825.                       result_header_ptr=NULL;
  5826.                       printf(
  5827.       "Fatal error:  overflow detected in addition at line %ld, column %ld.\n",
  5828.                        source_line_num,source_column_num);
  5829.                     }
  5830.                   else
  5831.                     *((*result_header_ptr).value_ptr.real)
  5832.                      =left_real_value-right_real_value;
  5833.                 else
  5834.                   if ((left_real_value > 0.0) && (right_real_value < 0.0))
  5835.                     if (left_real_value > (right_real_value+1.0E37))
  5836.                       {
  5837.                         fatal_error=TRUE;
  5838.                         free_value(result_header_ptr);
  5839.                         result_header_ptr=NULL;
  5840.                         printf(
  5841.       "Fatal error:  overflow detected in addition at line %ld, column %ld.\n",
  5842.                          source_line_num,source_column_num);
  5843.                       }
  5844.                     else
  5845.                       *((*result_header_ptr).value_ptr.real)
  5846.                        =left_real_value-right_real_value;
  5847.                   else
  5848.                     *((*result_header_ptr).value_ptr.real)
  5849.                      =left_real_value-right_real_value;
  5850.               }
  5851.           }
  5852.         else
  5853.           if (((*left_header_ptr).type == 'I')
  5854.           &&  ((*right_header_ptr).type == 'R'))
  5855.             {
  5856.               result_header_ptr=new_real_header_ptr();
  5857.               if (! fatal_error)
  5858.                 {
  5859.                   left_real_value=(double)
  5860.                    *((*left_header_ptr).value_ptr.integer);
  5861.                   right_real_value=*((*right_header_ptr).value_ptr.real);
  5862.                   if ((left_real_value < 0.0) && (right_real_value > 0.0))
  5863.                     if (left_real_value < (right_real_value-1.0E37))
  5864.                       {
  5865.                         fatal_error=TRUE;
  5866.                         free_value(result_header_ptr);
  5867.                         result_header_ptr=NULL;
  5868.                         printf(
  5869.       "Fatal error:  overflow detected in addition at line %ld, column %ld.\n",
  5870.                          source_line_num,source_column_num);
  5871.                       }
  5872.                     else
  5873.                       *((*result_header_ptr).value_ptr.real)
  5874.                        =left_real_value-right_real_value;
  5875.                   else
  5876.                     if ((left_real_value > 0.0) && (right_real_value < 0.0))
  5877.                       if (left_real_value > (right_real_value+1.0E37))
  5878.                         {
  5879.                           fatal_error=TRUE;
  5880.                           free_value(result_header_ptr);
  5881.                           result_header_ptr=NULL;
  5882.                           printf(
  5883.       "Fatal error:  overflow detected in addition at line %ld, column %ld.\n",
  5884.                            source_line_num,source_column_num);
  5885.                         }
  5886.                       else
  5887.                         *((*result_header_ptr).value_ptr.real)
  5888.                          =left_real_value-right_real_value;
  5889.                    else
  5890.                      *((*result_header_ptr).value_ptr.real)
  5891.                       =left_real_value-right_real_value;
  5892.                 }
  5893.             }
  5894.           else
  5895.             if (((*left_header_ptr).type == 'R')
  5896.             &&  ((*right_header_ptr).type == 'I'))
  5897.               {
  5898.                 result_header_ptr=new_real_header_ptr();
  5899.                 if (! fatal_error)
  5900.                   {
  5901.                     left_real_value=*((*left_header_ptr).value_ptr.real);
  5902.                     right_real_value=*((*right_header_ptr).value_ptr.real);
  5903.                     if ((left_real_value < 0.0)
  5904.                     && (right_real_value > 0.0))
  5905.                       if (left_real_value < (right_real_value-1.0E37))
  5906.                         {
  5907.                           fatal_error=TRUE;
  5908.                           free_value(result_header_ptr);
  5909.                           result_header_ptr=NULL;
  5910.                           printf(
  5911.       "Fatal error:  overflow detected in addition at line %ld, column %ld.\n",
  5912.                            source_line_num,source_column_num);
  5913.                         }
  5914.                       else
  5915.                         *((*result_header_ptr).value_ptr.real)
  5916.                          =left_real_value-right_real_value;
  5917.                     else
  5918.                       if ((left_real_value > 0.0)
  5919.                       &&  (right_real_value < 0.0))
  5920.                         if (left_real_value > (right_real_value+1.0E37))
  5921.                           {
  5922.                             fatal_error=TRUE;
  5923.                             free_value(result_header_ptr);
  5924.                             result_header_ptr=NULL;
  5925.                             printf(
  5926.       "Fatal error:  overflow detected in addition at line %ld, column %ld.\n",
  5927.                              source_line_num,source_column_num);
  5928.                           }
  5929.                         else
  5930.                           *((*result_header_ptr).value_ptr.real)
  5931.                            =left_real_value-right_real_value;
  5932.                       else
  5933.                         *((*result_header_ptr).value_ptr.real)
  5934.                          =left_real_value-right_real_value;
  5935.                   }
  5936.               }
  5937.             else
  5938.               {
  5939.                 fatal_error=TRUE;
  5940.                 result_header_ptr=NULL;
  5941.                 printf(
  5942.                  "Fatal error:  attempt to add other than two numbers at\n");
  5943.                 printf(
  5944.                  "line %ld, column %ld.\n",source_line_num,source_column_num);
  5945.               }
  5946.       return(result_header_ptr);
  5947.     }
  5948.  
  5949. static value_header_ptr or_terms(left_header_ptr,right_header_ptr)
  5950.   value_header_ptr left_header_ptr;
  5951.   value_header_ptr right_header_ptr;
  5952.     {
  5953.       value_header_ptr result_header_ptr;
  5954.  
  5955.       if (((*left_header_ptr).type == 'B')
  5956.       &&  ((*right_header_ptr).type == 'B'))
  5957.         {
  5958.           result_header_ptr=new_boolean_header_ptr();
  5959.           if (! fatal_error)
  5960.             *((*result_header_ptr).value_ptr.boolean)
  5961.              =(*((*left_header_ptr).value_ptr.boolean))
  5962.              || (*((*right_header_ptr).value_ptr.boolean));
  5963.         }
  5964.       else
  5965.         {
  5966.           fatal_error=TRUE;
  5967.           result_header_ptr=NULL;
  5968.           printf(
  5969.            "Fatal error:  attempt to \"or\" other than two booleans\n");
  5970.           printf(
  5971.            "at line %ld, column %ld.\n",source_line_num,source_column_num);
  5972.         }
  5973.       return(result_header_ptr);
  5974.     }
  5975.  
  5976. static void get_term_operator(operator)
  5977.   char *operator;
  5978.     {
  5979.       while ((source_char == ' ')
  5980.       &&     (! source_eof))
  5981.         get_source_char();
  5982.       switch (source_char)
  5983.         {
  5984.           case '+':
  5985.             operator[0]=source_char;
  5986.             operator[1]='\0';
  5987.             get_source_char();
  5988.             break;
  5989.           case '-':
  5990.             operator[0]=source_char;
  5991.             operator[1]='\0';
  5992.             get_source_char();
  5993.             break;
  5994.           case '|':
  5995.             operator[0]=source_char;
  5996.             operator[1]='\0';
  5997.             get_source_char();
  5998.             if (source_char == '|')
  5999.               {
  6000.                 operator[1]='|';
  6001.                 operator[2]='\0';
  6002.                 get_source_char();
  6003.               }
  6004.             break;
  6005.           default:
  6006.             operator[0]='\0';
  6007.             break;
  6008.         }
  6009.       return;
  6010.     }
  6011.  
  6012. static value_header_ptr simple_expression_header_ptr(evaluate)
  6013.   int evaluate;
  6014.     {
  6015.       char             leading_sign;
  6016.       value_header_ptr left_header_ptr;
  6017.       char             operator [3];
  6018.       int              operator_found;
  6019.       value_header_ptr result_header_ptr;
  6020.       value_header_ptr right_header_ptr;
  6021.  
  6022.       while ((source_char == ' ')
  6023.       &&     (! source_eof))
  6024.         get_source_char();
  6025.       if (source_char == ' ')
  6026.         {
  6027.           fatal_error=TRUE;
  6028.           result_header_ptr=NULL;
  6029.           printf(
  6030.   "Fatal error:  end of file encountered where simple expression expected.\n");
  6031.         }
  6032.       else
  6033.         {
  6034.           leading_sign=' ';
  6035.           if ((source_char == '+') || (source_char == '-'))
  6036.             {
  6037.               leading_sign=source_char;
  6038.               get_source_char();
  6039.             }
  6040.           result_header_ptr=term_header_ptr(evaluate);
  6041.           if (! fatal_error)
  6042.             {
  6043.               if ((evaluate) && (leading_sign != ' '))
  6044.                 switch ((*result_header_ptr).type)
  6045.                   {
  6046.                     case 'I':
  6047.                       if (leading_sign == '-')
  6048.                         *((*result_header_ptr).value_ptr.integer)
  6049.                          =-(*((*result_header_ptr).value_ptr.integer));
  6050.                       break;
  6051.                     case 'R':
  6052.                       if (leading_sign == '-')
  6053.                         *((*result_header_ptr).value_ptr.real)
  6054.                          =-(*((*result_header_ptr).value_ptr.real));
  6055.                       break;
  6056.                     default:
  6057.                       fatal_error=TRUE;
  6058.                       free_value(result_header_ptr);
  6059.                       result_header_ptr=NULL;
  6060.                       printf(
  6061.                        "Fatal error:  sign applied to other than number at ");
  6062.                       printf(
  6063.                        "line %ld, column %ld.\n",
  6064.                        source_line_num,source_column_num);
  6065.                       break;
  6066.                   }
  6067.               operator_found=TRUE;
  6068.               while ((! fatal_error)
  6069.               &&     (operator_found))
  6070.                 {
  6071.                   get_term_operator(operator);
  6072.                   if ((strcmp(operator,"||") != 0)
  6073.                   &&  (strcmp(operator,"|") != 0)
  6074.                   &&  (strcmp(operator,"+") != 0)
  6075.                   &&  (strcmp(operator,"-") != 0))
  6076.                     operator_found=FALSE;
  6077.                   else
  6078.                     {
  6079.                       right_header_ptr=term_header_ptr(evaluate);
  6080.                       if (fatal_error)
  6081.                         {
  6082.                           free_value(result_header_ptr);
  6083.                           result_header_ptr=NULL;
  6084.                         }
  6085.                       else
  6086.                         {
  6087.                           left_header_ptr=result_header_ptr;
  6088.                           if (evaluate)
  6089.                             {
  6090.                               if (strcmp(operator,"||") == 0)
  6091.                                 result_header_ptr=concatenate_terms(
  6092.                                  left_header_ptr,right_header_ptr);
  6093.                               else
  6094.                                 switch (operator[0])
  6095.                                   {
  6096.                                     case '+':
  6097.                                       result_header_ptr=add_terms(
  6098.                                        left_header_ptr,right_header_ptr);
  6099.                                       break;
  6100.                                     case '-':
  6101.                                       result_header_ptr=subtract_terms(
  6102.                                        left_header_ptr,right_header_ptr);
  6103.                                       break;
  6104.                                     default:
  6105.                                       result_header_ptr=or_terms(
  6106.                                        left_header_ptr,right_header_ptr);
  6107.                                       break;
  6108.                                   }
  6109.                               free_value(left_header_ptr);
  6110.                               free_value(right_header_ptr);
  6111.                             }
  6112.                           else
  6113.                             result_header_ptr=NULL;
  6114.                         }
  6115.                     }
  6116.                 }
  6117.             }
  6118.         }
  6119.       return(result_header_ptr);
  6120.     }
  6121.  
  6122. static value_header_ptr boolean_comparison(left_header_ptr,operator,
  6123.  right_header_ptr)
  6124.   value_header_ptr left_header_ptr;
  6125.   char             *operator;
  6126.   value_header_ptr right_header_ptr;
  6127.     {
  6128.       value_header_ptr result_header_ptr;
  6129.  
  6130.       if (strcmp(operator,"!=") == 0)
  6131.         {
  6132.           result_header_ptr=new_boolean_header_ptr();
  6133.           if (! fatal_error)
  6134.             {
  6135.               if (*((*left_header_ptr).value_ptr.boolean)
  6136.                != *((*right_header_ptr).value_ptr.boolean))
  6137.                 *((*result_header_ptr).value_ptr.boolean)=TRUE;
  6138.               else
  6139.                 *((*result_header_ptr).value_ptr.boolean)=FALSE;
  6140.             }
  6141.         }
  6142.       else
  6143.         if (strcmp(operator,"=") == 0)
  6144.           {
  6145.             result_header_ptr=new_boolean_header_ptr();
  6146.             if (! fatal_error)
  6147.               {
  6148.                 if (*((*left_header_ptr).value_ptr.boolean)
  6149.                  == *((*right_header_ptr).value_ptr.boolean))
  6150.                   *((*result_header_ptr).value_ptr.boolean)=TRUE;
  6151.                 else
  6152.                   *((*result_header_ptr).value_ptr.boolean)=FALSE;
  6153.               }
  6154.           }
  6155.         else
  6156.           {
  6157.             fatal_error=TRUE;
  6158.             result_header_ptr=NULL;
  6159.             printf("Fatal error:  \"%s\" used to compare booleans at ",
  6160.              operator);
  6161.             printf("line %ld, column %ld.\n",
  6162.              source_line_num,source_column_num);
  6163.           }
  6164.       return(result_header_ptr);
  6165.     }
  6166.  
  6167. static value_header_ptr dataset_comparison(left_header_ptr,operator,
  6168.  right_header_ptr)
  6169.   value_header_ptr left_header_ptr;
  6170.   char             *operator;
  6171.   value_header_ptr right_header_ptr;
  6172.     {
  6173.       value_header_ptr result_header_ptr;
  6174.  
  6175.       if (strcmp(operator,"!=") == 0)
  6176.         {
  6177.           result_header_ptr=new_boolean_header_ptr();
  6178.           if (! fatal_error)
  6179.             {
  6180.               if (*((*left_header_ptr).value_ptr.dataset)
  6181.                != *((*right_header_ptr).value_ptr.dataset))
  6182.                 *((*result_header_ptr).value_ptr.boolean)=TRUE;
  6183.               else
  6184.                 *((*result_header_ptr).value_ptr.boolean)=FALSE;
  6185.             }
  6186.         }
  6187.       else
  6188.         if (strcmp(operator,"=") == 0)
  6189.           {
  6190.             result_header_ptr=new_boolean_header_ptr();
  6191.             if (! fatal_error)
  6192.               {
  6193.                 if (*((*left_header_ptr).value_ptr.dataset)
  6194.                  == *((*right_header_ptr).value_ptr.dataset))
  6195.                   *((*result_header_ptr).value_ptr.boolean)=TRUE;
  6196.                 else
  6197.                   *((*result_header_ptr).value_ptr.boolean)=FALSE;
  6198.               }
  6199.           }
  6200.         else
  6201.           {
  6202.             fatal_error=TRUE;
  6203.             result_header_ptr=NULL;
  6204.             printf("Fatal error:  \"%s\" used to compare file pointers at ",
  6205.              operator);
  6206.             printf("line %ld, column %ld.\n",
  6207.              source_line_num,source_column_num);
  6208.           }
  6209.       return(result_header_ptr);
  6210.     }
  6211.  
  6212. static value_header_ptr integer_comparison(left_header_ptr,operator,
  6213.  right_header_ptr)
  6214.   value_header_ptr left_header_ptr;
  6215.   char             *operator;
  6216.   value_header_ptr right_header_ptr;
  6217.     {
  6218.       value_header_ptr result_header_ptr;
  6219.  
  6220.       result_header_ptr=new_boolean_header_ptr();
  6221.       if (! fatal_error)
  6222.         {
  6223.           if (strcmp(operator,"<=") == 0)
  6224.             if (*((*left_header_ptr).value_ptr.integer)
  6225.              <= *((*right_header_ptr).value_ptr.integer))
  6226.               *((*result_header_ptr).value_ptr.boolean)=TRUE;
  6227.             else
  6228.               *((*result_header_ptr).value_ptr.boolean)=FALSE;
  6229.           else
  6230.             if (strcmp(operator,">=") == 0)
  6231.               if (*((*left_header_ptr).value_ptr.integer)
  6232.                >= *((*right_header_ptr).value_ptr.integer))
  6233.                 *((*result_header_ptr).value_ptr.boolean)=TRUE;
  6234.               else
  6235.                 *((*result_header_ptr).value_ptr.boolean)=FALSE;
  6236.             else
  6237.               if (strcmp(operator,"!=") == 0)
  6238.                 if (*((*left_header_ptr).value_ptr.integer)
  6239.                  != *((*right_header_ptr).value_ptr.integer))
  6240.                   *((*result_header_ptr).value_ptr.boolean)=TRUE;
  6241.                 else
  6242.                   *((*result_header_ptr).value_ptr.boolean)=FALSE;
  6243.               else
  6244.                 if (strcmp(operator,">") == 0)
  6245.                   if (*((*left_header_ptr).value_ptr.integer)
  6246.                    > *((*right_header_ptr).value_ptr.integer))
  6247.                     *((*result_header_ptr).value_ptr.boolean)=TRUE;
  6248.                   else
  6249.                     *((*result_header_ptr).value_ptr.boolean)=FALSE;
  6250.                 else
  6251.                   if (strcmp(operator,"<") == 0)
  6252.                     if (*((*left_header_ptr).value_ptr.integer)
  6253.                      < *((*right_header_ptr).value_ptr.integer))
  6254.                       *((*result_header_ptr).value_ptr.boolean)=TRUE;
  6255.                     else
  6256.                       *((*result_header_ptr).value_ptr.boolean)=FALSE;
  6257.                   else
  6258.                     if (*((*left_header_ptr).value_ptr.integer)
  6259.                      == *((*right_header_ptr).value_ptr.integer))
  6260.                       *((*result_header_ptr).value_ptr.boolean)=TRUE;
  6261.                     else
  6262.                       *((*result_header_ptr).value_ptr.boolean)=FALSE;
  6263.         }
  6264.       return(result_header_ptr);
  6265.     }
  6266.  
  6267.  
  6268. static value_header_ptr real_comparison(left_header_ptr,operator,
  6269.  right_header_ptr)
  6270.   value_header_ptr left_header_ptr;
  6271.   char             *operator;
  6272.   value_header_ptr right_header_ptr;
  6273.     {
  6274.       value_header_ptr result_header_ptr;
  6275.  
  6276.       result_header_ptr=new_boolean_header_ptr();
  6277.       if (! fatal_error)
  6278.         {
  6279.           if (strcmp(operator,"<=") == 0)
  6280.             if (*((*left_header_ptr).value_ptr.real)
  6281.              <= *((*right_header_ptr).value_ptr.real))
  6282.               *((*result_header_ptr).value_ptr.boolean)=TRUE;
  6283.             else
  6284.               *((*result_header_ptr).value_ptr.boolean)=FALSE;
  6285.           else
  6286.             if (strcmp(operator,">=") == 0)
  6287.               if (*((*left_header_ptr).value_ptr.real)
  6288.                >= *((*right_header_ptr).value_ptr.real))
  6289.                 *((*result_header_ptr).value_ptr.boolean)=TRUE;
  6290.               else
  6291.                 *((*result_header_ptr).value_ptr.boolean)=FALSE;
  6292.             else
  6293.               if (strcmp(operator,"!=") == 0)
  6294.                 if (*((*left_header_ptr).value_ptr.real)
  6295.                  != *((*right_header_ptr).value_ptr.real))
  6296.                   *((*result_header_ptr).value_ptr.boolean)=TRUE;
  6297.                 else
  6298.                   *((*result_header_ptr).value_ptr.boolean)=FALSE;
  6299.               else
  6300.                 if (strcmp(operator,">") == 0)
  6301.                   if (*((*left_header_ptr).value_ptr.real)
  6302.                    > *((*right_header_ptr).value_ptr.real))
  6303.                     *((*result_header_ptr).value_ptr.boolean)=TRUE;
  6304.                   else
  6305.                     *((*result_header_ptr).value_ptr.boolean)=FALSE;
  6306.                 else
  6307.                   if (strcmp(operator,"<") == 0)
  6308.                     if (*((*left_header_ptr).value_ptr.real)
  6309.                      < *((*right_header_ptr).value_ptr.real))
  6310.                       *((*result_header_ptr).value_ptr.boolean)=TRUE;
  6311.                     else
  6312.                       *((*result_header_ptr).value_ptr.boolean)=FALSE;
  6313.                   else
  6314.                     if (*((*left_header_ptr).value_ptr.real)
  6315.                      == *((*right_header_ptr).value_ptr.real))
  6316.                       *((*result_header_ptr).value_ptr.boolean)=TRUE;
  6317.                     else
  6318.                       *((*result_header_ptr).value_ptr.boolean)=FALSE;
  6319.         }
  6320.       return(result_header_ptr);
  6321.     }
  6322.  
  6323.  
  6324. static value_header_ptr string_comparison(left_header_ptr,operator,
  6325.  right_header_ptr)
  6326.   value_header_ptr left_header_ptr;
  6327.   char             *operator;
  6328.   value_header_ptr right_header_ptr;
  6329.     {
  6330.       value_header_ptr result_header_ptr;
  6331.  
  6332.       result_header_ptr=new_boolean_header_ptr();
  6333.       if (! fatal_error)
  6334.         {
  6335.           if (strcmp(operator,"<=") == 0)
  6336.             if (pli_strcmp((*left_header_ptr).value_ptr.string,
  6337.              (*right_header_ptr).value_ptr.string) <= 0)
  6338.               *((*result_header_ptr).value_ptr.boolean)=TRUE;
  6339.             else
  6340.               *((*result_header_ptr).value_ptr.boolean)=FALSE;
  6341.           else
  6342.             if (strcmp(operator,">=") == 0)
  6343.               if (pli_strcmp((*left_header_ptr).value_ptr.string,
  6344.                 (*right_header_ptr).value_ptr.string) >= 0)
  6345.                 *((*result_header_ptr).value_ptr.boolean)=TRUE;
  6346.               else
  6347.                 *((*result_header_ptr).value_ptr.boolean)=FALSE;
  6348.             else
  6349.               if (strcmp(operator,"!=") == 0)
  6350.                 if (pli_strcmp((*left_header_ptr).value_ptr.string,
  6351.                  (*right_header_ptr).value_ptr.string) != 0)
  6352.                   *((*result_header_ptr).value_ptr.boolean)=TRUE;
  6353.                 else
  6354.                   *((*result_header_ptr).value_ptr.boolean)=FALSE;
  6355.               else
  6356.                 if (strcmp(operator,"<") == 0)
  6357.                   if (pli_strcmp((*left_header_ptr).value_ptr.string,
  6358.                    (*right_header_ptr).value_ptr.string) < 0)
  6359.                     *((*result_header_ptr).value_ptr.boolean)=TRUE;
  6360.                   else
  6361.                     *((*result_header_ptr).value_ptr.boolean)=FALSE;
  6362.                 else
  6363.                   if (strcmp(operator,">") == 0)
  6364.                     if (pli_strcmp((*left_header_ptr).value_ptr.string,
  6365.                      (*right_header_ptr).value_ptr.string) > 0)
  6366.                       *((*result_header_ptr).value_ptr.boolean)=TRUE;
  6367.                     else
  6368.                       *((*result_header_ptr).value_ptr.boolean)=FALSE;
  6369.                   else
  6370.                     if (pli_strcmp((*left_header_ptr).value_ptr.string,
  6371.                      (*right_header_ptr).value_ptr.string) == 0)
  6372.                       *((*result_header_ptr).value_ptr.boolean)=TRUE;
  6373.                     else
  6374.                       *((*result_header_ptr).value_ptr.boolean)=FALSE;
  6375.         }
  6376.       return(result_header_ptr);
  6377.     }
  6378.  
  6379. static void get_comparison_operator(operator)
  6380.   char *operator;
  6381.     {
  6382.       while ((source_char == ' ')
  6383.       &&     (! source_eof))
  6384.         get_source_char();
  6385.       switch (source_char)
  6386.         {
  6387.           case '=':
  6388.             operator[0]=source_char;
  6389.             operator[1]='\0';
  6390.             get_source_char();
  6391.             break;
  6392.           case '<':
  6393.             operator[0]=source_char;
  6394.             operator[1]='\0';
  6395.             get_source_char();
  6396.             if (source_char == '=')
  6397.               {
  6398.                 operator[1]='=';
  6399.                 operator[2]='\0';
  6400.                 get_source_char();
  6401.               }
  6402.             break;
  6403.           case '!':
  6404.             operator[0]=source_char;
  6405.             operator[1]='\0';
  6406.             get_source_char();
  6407.             if (source_char == '=')
  6408.               {
  6409.                 operator[1]='=';
  6410.                 operator[2]='\0';
  6411.                 get_source_char();
  6412.               }
  6413.             break;
  6414.           case '>':
  6415.             operator[0]=source_char;
  6416.             operator[1]='\0';
  6417.             get_source_char();
  6418.             if (source_char == '=')
  6419.               {
  6420.                 operator[1]='=';
  6421.                 operator[2]='\0';
  6422.                 get_source_char();
  6423.               }
  6424.             break;
  6425.           default:
  6426.             operator[0]='\0';
  6427.             break;
  6428.         }
  6429.       return;
  6430.     }
  6431.  
  6432. static value_header_ptr interpret_expression(evaluate)
  6433.   int evaluate;
  6434.     {
  6435.       value_header_ptr left_header_ptr;
  6436.       char             operator [3];
  6437.       value_header_ptr result_header_ptr;
  6438.       value_header_ptr right_header_ptr;
  6439.       double           tem_real_1;
  6440.  
  6441.       left_header_ptr=simple_expression_header_ptr(evaluate);
  6442.       if (fatal_error)
  6443.         result_header_ptr=NULL;
  6444.       else
  6445.         {
  6446.           get_comparison_operator(operator);
  6447.           if ((strcmp(operator,"<=") != 0)
  6448.           &&  (strcmp(operator,">=") != 0)
  6449.           &&  (strcmp(operator,"!=") != 0)
  6450.           &&  (strcmp(operator,"<") != 0)
  6451.           &&  (strcmp(operator,">") != 0)
  6452.           &&  (strcmp(operator,"=") != 0))
  6453.              result_header_ptr=left_header_ptr;
  6454.           else
  6455.             {
  6456.               right_header_ptr=simple_expression_header_ptr(evaluate);
  6457.               if (fatal_error)
  6458.                 {
  6459.                   free_value(left_header_ptr);
  6460.                   result_header_ptr=NULL;
  6461.                 }
  6462.               else
  6463.                 {
  6464.                   if (evaluate)
  6465.                     {
  6466.                       if ((*left_header_ptr).type
  6467.                        == (*right_header_ptr).type)
  6468.                         switch ((*left_header_ptr).type)
  6469.                           {
  6470.                             case 'B':
  6471.                               result_header_ptr=boolean_comparison(
  6472.                                left_header_ptr,operator,
  6473.                                right_header_ptr);
  6474.                               break;
  6475.                             case 'D':
  6476.                               result_header_ptr=dataset_comparison(
  6477.                                left_header_ptr,operator,
  6478.                                right_header_ptr);
  6479.                               break;
  6480.                             case 'I':
  6481.                               result_header_ptr=integer_comparison(
  6482.                                left_header_ptr,operator,
  6483.                                right_header_ptr);
  6484.                               break;
  6485.                             case 'R':
  6486.                               result_header_ptr=real_comparison(
  6487.                                left_header_ptr,operator,
  6488.                                right_header_ptr);
  6489.                               break;
  6490.                             default:
  6491.                               result_header_ptr=string_comparison(
  6492.                                left_header_ptr,operator,
  6493.                                right_header_ptr);
  6494.                               break;
  6495.                           }
  6496.                       else
  6497.                         if (((*left_header_ptr).type == 'I')
  6498.                         &&  ((*right_header_ptr).type == 'R'))
  6499.                           {
  6500.                             tem_real_1=(double)
  6501.                              *((*left_header_ptr).value_ptr.integer);
  6502.                             free((char *)
  6503.                              (*left_header_ptr).value_ptr.integer);
  6504.                             if (((*left_header_ptr).value_ptr.real
  6505.                              =(double *)
  6506.                              malloc((unsigned) sizeof(double))) == NULL)
  6507.                               {
  6508.                                 fatal_error=TRUE;
  6509.                                 result_header_ptr=NULL;
  6510.                                 printf("Fatal error:  out of memory at ");
  6511.                                 printf("line %ld, column %ld.\n",
  6512.                                  source_line_num,source_column_num);
  6513.                                 free((char *) left_header_ptr);
  6514.                                 free_value(right_header_ptr);
  6515.                               }
  6516.                             else
  6517.                               {
  6518.                                 *((*left_header_ptr).value_ptr.real)
  6519.                                  =tem_real_1;
  6520.                                 (*left_header_ptr).type='R';
  6521.                                 result_header_ptr=real_comparison(
  6522.                                  left_header_ptr,operator,
  6523.                                  right_header_ptr);
  6524.                               }
  6525.                           }
  6526.                         else
  6527.                           if (((*left_header_ptr).type == 'R')
  6528.                           &&  ((*right_header_ptr).type == 'I'))
  6529.                             {
  6530.                               tem_real_1=(double)
  6531.                                *((*right_header_ptr).value_ptr.integer);
  6532.                               free((char *)
  6533.                                (*right_header_ptr).value_ptr.integer);
  6534.                               if (((*right_header_ptr).value_ptr.real
  6535.                                =(double *)
  6536.                                malloc((unsigned) sizeof(double))) == NULL)
  6537.                                 {
  6538.                                   fatal_error=TRUE;
  6539.                                   result_header_ptr=NULL;
  6540.                                   printf("Fatal error:  out of memory ");
  6541.                                   printf("at line %ld, column %ld.\n",
  6542.                                    source_line_num,source_column_num);
  6543.                                   free((char *) right_header_ptr);
  6544.                                   free_value(left_header_ptr);
  6545.                                 }
  6546.                               else
  6547.                                 {
  6548.                                   *((*right_header_ptr).value_ptr.real)
  6549.                                    =tem_real_1;
  6550.                                   (*right_header_ptr).type='R';
  6551.                                   result_header_ptr=real_comparison(
  6552.                                    left_header_ptr,operator,
  6553.                                    right_header_ptr);
  6554.                                 }
  6555.                             }
  6556.                           else
  6557.                             {
  6558.                               fatal_error=TRUE;
  6559.                               result_header_ptr=NULL;
  6560.                               printf("Fatal error:  comparands differ ");
  6561.                               printf("in type at line %ld, column %ld.\n",
  6562.                                source_line_num,source_column_num);
  6563.                               free_value(left_header_ptr);
  6564.                               free_value(right_header_ptr);
  6565.                             }
  6566.                       if (! fatal_error)
  6567.                         {
  6568.                           free_value(left_header_ptr);
  6569.                           free_value(right_header_ptr);
  6570.                         }
  6571.                     }
  6572.                   else
  6573.                     result_header_ptr=NULL;
  6574.                 }
  6575.             }
  6576.         }
  6577.       return(result_header_ptr);
  6578.     }
  6579.  
  6580. static void interpret_do(evaluate)
  6581.   int evaluate;
  6582.     {
  6583.       int              condition_is_true;
  6584.       value_header_ptr expression_header_ptr;
  6585.       char             while_char;
  6586.       long             while_column_num;
  6587.       int              while_eof;
  6588.       long             while_page_num;
  6589.       int              while_page_index;
  6590.       long             while_line_num;
  6591.  
  6592.       get_token();
  6593.       if (source_token[0] == ';')
  6594.         {
  6595.           do
  6596.             {
  6597.               get_token();
  6598.               if (source_token[0] == ' ')
  6599.                 {
  6600.                   fatal_error=TRUE;
  6601.                   printf("Fatal error:  file ends before \"END;\" ");
  6602.                   printf("corresponding to \"DO;\".\n");
  6603.                 }
  6604.               else
  6605.                 {
  6606.                   if (strcmp(source_token,"END") != 0)
  6607.                     interpret_statement(evaluate);
  6608.                 }
  6609.             }
  6610.           while ((strcmp(source_token,"END") != 0)
  6611.           &&     (! fatal_error));
  6612.           if (! fatal_error)
  6613.             {
  6614.               get_token();
  6615.               if (source_token[0] == ' ')
  6616.                 {
  6617.                   fatal_error=TRUE;
  6618.                   printf("Fatal error:  file ends where \";\" of \"END;\" ");
  6619.                   printf("expected.\n");
  6620.                 }
  6621.               else
  6622.                 {
  6623.                   if (source_token[0] != ';')
  6624.                     {
  6625.                       fatal_error=TRUE;
  6626.                       printf(
  6627.                      "Fatal error:  \";\" expected at line %ld, column %ld.\n",
  6628.                        source_line_num,source_column_num);
  6629.                     }
  6630.                 }
  6631.             }
  6632.         }
  6633.       else
  6634.         if (strcmp(source_token,"WHILE") == 0)
  6635.           {
  6636.             get_token();
  6637.             if (source_token[0] == ' ')
  6638.               {
  6639.                 fatal_error=TRUE;
  6640.                 printf(
  6641.            "Fatal error:  file ends where \"(\" of \"DO WHILE(\" expected.\n");
  6642.               }
  6643.             else
  6644.               if (source_token[0] == '(')
  6645.                 {
  6646.                   while_page_index=page_index;
  6647.                   while_page_num=page_num;
  6648.                   while_char=source_char;
  6649.                   while_column_num=source_column_num;
  6650.                   while_eof=source_eof;
  6651.                   while_line_num=source_line_num;
  6652.                   do
  6653.                     {
  6654.                       if (while_page_num != page_num)
  6655.                         {
  6656.                           source_index=while_page_num;
  6657.                           source_index*=(long) page_size;
  6658.                           fseek(source_file,source_index,SEEK_SET);
  6659.                           fread(&page[0],1,page_size,source_file);
  6660.                         }
  6661.                       page_num=while_page_num;
  6662.                       page_index=while_page_index;
  6663.                       source_char=while_char;
  6664.                       source_column_num=while_column_num;
  6665.                       source_eof=while_eof;
  6666.                       source_line_num=while_line_num;
  6667.                       expression_header_ptr=interpret_expression(evaluate);
  6668.                       if (! fatal_error)
  6669.                         {
  6670.                           if ((! evaluate)
  6671.                           ||  ((*expression_header_ptr).type == 'B'))
  6672.                             {
  6673.                               get_token();
  6674.                               if (source_token[0] == ')')
  6675.                                 {
  6676.                                   get_token();
  6677.                                   if (source_token[0] == ';')
  6678.                                     {
  6679.                                       if (evaluate)
  6680.                                         condition_is_true
  6681.                                =*((*expression_header_ptr).value_ptr.boolean);
  6682.                                       else
  6683.                                         condition_is_true=FALSE;
  6684.                                       do
  6685.                                         {
  6686.                                           get_token();
  6687.                                           if (source_token[0] == ' ')
  6688.                                             {
  6689.                                               fatal_error=TRUE;
  6690.                                               printf(
  6691.                                    "Fatal error:  file ends before \"END;\" ");
  6692.                                               printf(
  6693.                                    "corresponding to \"DO WHILE();\".\n");
  6694.                                             }
  6695.                                           else
  6696.                                             {
  6697.                                               if (strcmp(source_token,"END")
  6698.                                                != 0)
  6699.                                                 interpret_statement(
  6700.                                                  evaluate && condition_is_true);
  6701.                                             }
  6702.                                         }
  6703.                                       while ((strcmp(source_token,"END") != 0)
  6704.                                       &&     (! fatal_error));
  6705.                                     }
  6706.                                   else
  6707.                                     if (source_token[0] == ' ')
  6708.                                       {
  6709.                                         fatal_error=TRUE;
  6710.                                         printf(
  6711.                  "Fatal error:  file ends before \";\" of \"DO WHILE();\".\n");
  6712.                                       }
  6713.                                     else
  6714.                                       {
  6715.                                         fatal_error=TRUE;
  6716.                                         printf(
  6717.   "Fatal error:  \";\" of \"DO WHILE();\" expected at line %ld, column %ld.\n",
  6718.                                          source_line_num,source_column_num);
  6719.                                       }
  6720.                                 }
  6721.                               else
  6722.                                 if (source_token[0] == ' ')
  6723.                                   {
  6724.                                     fatal_error=TRUE;
  6725.                                     printf(
  6726.                    "Fatal error:  file ends before \")\" of \"DO WHILE()\".\n");
  6727.                                   }
  6728.                                 else
  6729.                                   {
  6730.                                     fatal_error=TRUE;
  6731.                                     printf(
  6732.    "Fatal error:  \")\" of \"DO WHILE()\" expected at line %ld, column %ld.\n",
  6733.                                      source_line_num,source_column_num);
  6734.                                   }
  6735.                             }
  6736.                           else
  6737.                             {
  6738.                               fatal_error=TRUE;
  6739.                               printf(
  6740.               "Fatal error:  the expression preceding column %ld on line %d\n",
  6741.                                source_column_num,source_line_num);
  6742.                               printf(
  6743.               "     should be Boolean but isn\'t.\n");
  6744.                             }
  6745.                           free_value(expression_header_ptr);
  6746.                         }
  6747.                       if (! fatal_error)
  6748.                         {
  6749.                           get_token();
  6750.                           if (source_token[0] == ' ')
  6751.                             {
  6752.                               fatal_error=TRUE;
  6753.                               printf("Fatal error:  file ends where \";\" ");
  6754.                               printf("of \"END;\" expected.\n");
  6755.                             }
  6756.                           else
  6757.                             {
  6758.                               if (source_token[0] != ';')
  6759.                                 {
  6760.                                   fatal_error=TRUE;
  6761.                                   printf(
  6762.                      "Fatal error:  \";\" expected at line %ld, column %ld.\n",
  6763.                                    source_line_num,source_column_num);
  6764.                                 }
  6765.                             }
  6766.                         }
  6767.                     }
  6768.                   while((! fatal_error)
  6769.                   &&    (evaluate)
  6770.                   &&    (condition_is_true));
  6771.                 }
  6772.               else
  6773.                 {
  6774.                   fatal_error=TRUE;
  6775.                   printf(
  6776.                   "\"(\" of \"DO WHILE(\" expected at line %ld, column %ld.\n",
  6777.                    source_line_num,source_column_num);
  6778.                 }
  6779.           }
  6780.         else
  6781.           if (source_token[0] == ' ')
  6782.             {
  6783.               fatal_error=TRUE;
  6784.               printf(
  6785.                "Fatal error:  file ends before \"DO\" statement completed.\n");
  6786.             }
  6787.           else
  6788.             {
  6789.               fatal_error=TRUE;
  6790.               printf(
  6791.         "Fatal error:  \";\" or \"WHILE\" expected at line %ld, column %ld.\n",
  6792.                source_line_num,source_column_num);
  6793.             }
  6794.       return;
  6795.     }
  6796.  
  6797. static void interpret_if(evaluate)
  6798.   int evaluate;
  6799.     {
  6800.       char             else_char;
  6801.       long             else_column_num;
  6802.       int              else_eof;
  6803.       long             else_line_num;
  6804.       int              else_page_index;
  6805.       long             else_page_num;
  6806.       char             else_token [256];
  6807.       value_header_ptr expression_header_ptr;
  6808.  
  6809.       expression_header_ptr=interpret_expression(evaluate);
  6810.       if (! fatal_error)
  6811.         {
  6812.           if ((! evaluate)
  6813.           ||  ((*expression_header_ptr).type == 'B'))
  6814.             {
  6815.               get_token();
  6816.               if (strcmp(source_token,"THEN") == 0)
  6817.                 {
  6818.                   get_token();
  6819.                   if (evaluate)
  6820.                     if (*((*expression_header_ptr).value_ptr.boolean))
  6821.                       interpret_statement(TRUE);
  6822.                     else
  6823.                       interpret_statement(FALSE);
  6824.                   else
  6825.                     interpret_statement(FALSE);
  6826.                   else_char=source_char;
  6827.                   else_column_num=source_column_num;
  6828.                   else_eof=source_eof;
  6829.                   else_page_index=page_index;
  6830.                   else_page_num=page_num;
  6831.                   else_line_num=source_line_num;
  6832.                   strcpy(else_token,source_token);
  6833.                   get_token();
  6834.                   if (strcmp(source_token,"ELSE") == 0)
  6835.                     {
  6836.                       get_token();
  6837.                       if (evaluate)
  6838.                         if (*((*expression_header_ptr).value_ptr.boolean))
  6839.                           interpret_statement(FALSE);
  6840.                         else
  6841.                           interpret_statement(TRUE);
  6842.                       else
  6843.                         interpret_statement(FALSE);
  6844.                     }
  6845.                   else
  6846.                     {
  6847.                       if (else_page_num != page_num)
  6848.                         {
  6849.                           source_index=else_page_num;
  6850.                           source_index*=(long) page_size;
  6851.                           fseek(source_file,source_index,SEEK_SET);
  6852.                           fread(&page[0],1,page_size,source_file);
  6853.                         }
  6854.                       page_num=else_page_num;
  6855.                       page_index=else_page_index;
  6856.                       source_char=else_char;
  6857.                       source_column_num=else_column_num;
  6858.                       source_eof=else_eof;
  6859.                       source_line_num=else_line_num;
  6860.                       strcpy(source_token,else_token);
  6861.                     }
  6862.                 }
  6863.               else
  6864.                 if (source_token[0] == ' ')
  6865.                   {
  6866.                     fatal_error=TRUE;
  6867.                     printf(
  6868.                      "Fatal error:  file ends where \"THEN\" expected.\n");
  6869.                   }
  6870.                 else
  6871.                   {
  6872.                     fatal_error=TRUE;
  6873.                     printf(
  6874.                   "Fatal error:  \"THEN\" expected at line %ld, column %ld.\n",
  6875.                      source_line_num,source_column_num);
  6876.                   }
  6877.             }
  6878.           else
  6879.             {
  6880.               fatal_error=TRUE;
  6881.               printf(
  6882.              "Fatal error:  the expression preceding column %ld on line %ld\n",
  6883.                source_column_num,source_line_num);
  6884.               printf(
  6885.                "     is not a Boolean expression.\n");
  6886.             }
  6887.           free_value(expression_header_ptr);
  6888.         }
  6889.       return;
  6890.     }
  6891.  
  6892. static void interpret_assignment(evaluate,queue_head)
  6893.   int            evaluate;
  6894.   queue_node_ptr queue_head;
  6895.     {
  6896.       int              comparison;
  6897.       value_header_ptr expression_header_ptr;
  6898.       int              finished;
  6899.       queue_node_ptr   new_queue_copy;
  6900.       variable_ptr     new_variable_ptr;
  6901.       variable_ptr     old_variable_ptr;
  6902.       queue_node_ptr   queue_copy;
  6903.  
  6904.       expression_header_ptr=interpret_expression(evaluate);
  6905.       if (! fatal_error)
  6906.         {
  6907.           if (evaluate)
  6908.             {
  6909.               if (variable_head == NULL)
  6910.                 if ((variable_head=(struct variable *)
  6911.                  malloc((unsigned) sizeof(struct variable))) == NULL)
  6912.                   {
  6913.                     fatal_error=TRUE;
  6914.                     printf("Fatal error:  out of memory at ");
  6915.                     printf("line %ld, column %ld.\n",
  6916.                      source_line_num,source_column_num);
  6917.                   }
  6918.                 else
  6919.                   if (((*variable_head).name
  6920.                    =malloc((unsigned) (1+strlen(identifier)))) == NULL)
  6921.                     {
  6922.                       fatal_error=TRUE;
  6923.                       printf("Fatal error:  out of memory at ");
  6924.                       printf("line %ld, column %ld.\n",
  6925.                        source_line_num,source_column_num);
  6926.                       free((char *) variable_head);
  6927.                       variable_head=NULL;
  6928.                     }
  6929.                   else
  6930.                     {
  6931.                       strcpy((*variable_head).name,identifier);
  6932.                       (*variable_head).subscripts=copy_of_queue(queue_head);
  6933.                       if (! fatal_error)
  6934.                         (*variable_head).variable_value_header_ptr
  6935.                          =copy_of_arguments(expression_header_ptr);
  6936.                       if (fatal_error)
  6937.                         {
  6938.                           free((*variable_head).name);
  6939.                           free((char *) variable_head);
  6940.                           variable_head=NULL;
  6941.                         }
  6942.                       else
  6943.                         {
  6944.                           (*variable_head).predecessor_ptr=NULL;
  6945.                           (*variable_head).smaller_successor_ptr=NULL;
  6946.                           (*variable_head).larger_successor_ptr=NULL;
  6947.                         }
  6948.                     }
  6949.               else
  6950.                 {
  6951.                   old_variable_ptr=variable_head;
  6952.                   finished=FALSE;
  6953.                   queue_copy=copy_of_queue(queue_head);
  6954.                   do
  6955.                     {
  6956.                       comparison=variable_comparison(identifier,queue_copy,
  6957.                        (*old_variable_ptr).name,
  6958.                        (*old_variable_ptr).subscripts);
  6959.                       if (comparison < 0)
  6960.                         if ((*old_variable_ptr).smaller_successor_ptr == NULL)
  6961.                           {
  6962.                             if ((new_variable_ptr=(struct variable *)
  6963.                              malloc((unsigned) sizeof(struct variable)))
  6964.                              == NULL)
  6965.                               {
  6966.                                 fatal_error=TRUE;
  6967.                                 printf("Fatal error:  out of memory at ");
  6968.                                 printf("line %ld, column %ld.\n",
  6969.                                 source_line_num,source_column_num);
  6970.                               }
  6971.                             else
  6972.                               if (((*new_variable_ptr).name
  6973.                                =malloc((unsigned) (1+strlen(identifier))))
  6974.                                == NULL)
  6975.                                 {
  6976.                                   fatal_error=TRUE;
  6977.                                   printf("Fatal error:  out of memory at ");
  6978.                                   printf("line %ld, column %ld.\n",
  6979.                                    source_line_num,source_column_num);
  6980.                                   free((char *) variable_head);
  6981.                                   variable_head=NULL;
  6982.                                 }
  6983.                               else
  6984.                                 {
  6985.                                   strcpy((*new_variable_ptr).name,identifier);
  6986.                                   (*new_variable_ptr).subscripts=queue_copy;
  6987.                                   if (! fatal_error)
  6988.                                     (*new_variable_ptr).
  6989.                                      variable_value_header_ptr
  6990.                                      =copy_of_arguments(expression_header_ptr);
  6991.                                   if (fatal_error)
  6992.                                     {
  6993.                                       free((*new_variable_ptr).name);
  6994.                                       free((char *) new_variable_ptr);
  6995.                                       new_variable_ptr=NULL;
  6996.                                     }
  6997.                                   else
  6998.                                     {
  6999.                                       (*new_variable_ptr).predecessor_ptr
  7000.                                        =old_variable_ptr;
  7001.                                       (*new_variable_ptr).
  7002.                                        smaller_successor_ptr=NULL;
  7003.                                       (*new_variable_ptr).
  7004.                                        larger_successor_ptr=NULL;
  7005.                                       (*old_variable_ptr).
  7006.                                        smaller_successor_ptr
  7007.                                        =new_variable_ptr;
  7008.                                     }
  7009.                                 }
  7010.                             finished=TRUE;
  7011.                           }
  7012.                         else
  7013.                           old_variable_ptr
  7014.                            =(*old_variable_ptr).smaller_successor_ptr;
  7015.                       else
  7016.                         if (comparison > 0)
  7017.                           if ((*old_variable_ptr).larger_successor_ptr
  7018.                            == NULL)
  7019.                             {
  7020.                               if ((new_variable_ptr=(struct variable *)
  7021.                                malloc((unsigned) sizeof(struct variable)))
  7022.                                == NULL)
  7023.                                 {
  7024.                                   fatal_error=TRUE;
  7025.                                   printf("Fatal error:  out of memory at ");
  7026.                                   printf("line %ld, column %ld.\n",
  7027.                                   source_line_num,source_column_num);
  7028.                                 }
  7029.                               else
  7030.                                 if (((*new_variable_ptr).name
  7031.                                  =malloc((unsigned) (1+strlen(identifier))))
  7032.                                  == NULL)
  7033.                                   {
  7034.                                     fatal_error=TRUE;
  7035.                                     printf("Fatal error:  out of memory at ");
  7036.                                     printf("line %ld, column %ld.\n",
  7037.                                      source_line_num,source_column_num);
  7038.                                     free((char *) variable_head);
  7039.                                     variable_head=NULL;
  7040.                                   }
  7041.                                 else
  7042.                                   {
  7043.                                     strcpy((*new_variable_ptr).name,
  7044.                                      identifier);
  7045.                                     (*new_variable_ptr).subscripts=queue_copy;
  7046.                                     if (! fatal_error)
  7047.                                       (*new_variable_ptr).
  7048.                                        variable_value_header_ptr
  7049.                                        =copy_of_arguments(
  7050.                                        expression_header_ptr);
  7051.                                     if (fatal_error)
  7052.                                       {
  7053.                                         free((*new_variable_ptr).name);
  7054.                                         free((char *) new_variable_ptr);
  7055.                                         new_variable_ptr=NULL;
  7056.                                       }
  7057.                                     else
  7058.                                       {
  7059.                                         (*new_variable_ptr).predecessor_ptr
  7060.                                          =old_variable_ptr;
  7061.                                         (*new_variable_ptr).
  7062.                                          smaller_successor_ptr=NULL;
  7063.                                         (*new_variable_ptr).
  7064.                                          larger_successor_ptr=NULL;
  7065.                                         (*old_variable_ptr).
  7066.                                          larger_successor_ptr
  7067.                                          =new_variable_ptr;
  7068.                                       }
  7069.                                   }
  7070.                               finished=TRUE;
  7071.                             }
  7072.                           else
  7073.                             old_variable_ptr
  7074.                              =(*old_variable_ptr).larger_successor_ptr;
  7075.                         else
  7076.                           {
  7077.                             finished=TRUE;
  7078.                             while (queue_copy != NULL)
  7079.                               {
  7080.                                 new_queue_copy=(*queue_copy).next;
  7081.                                 free_value((*queue_copy).argument_header_ptr);
  7082.                                 free((char *) queue_copy);
  7083.                                 queue_copy=new_queue_copy;
  7084.                               }
  7085.                             free_value(
  7086.                              (*old_variable_ptr).variable_value_header_ptr);
  7087.                             (*old_variable_ptr).variable_value_header_ptr
  7088.                              =copy_of_arguments(expression_header_ptr);
  7089.                           }
  7090.                     }
  7091.                   while (! finished);
  7092.                 }
  7093.               free_value(expression_header_ptr);
  7094.             }
  7095.         }
  7096.       if (! fatal_error)
  7097.         {
  7098.           get_token();
  7099.           if (source_token[0] == ' ')
  7100.             {
  7101.               fatal_error=TRUE;
  7102.               printf(
  7103.                "Fatal error:  file ends where \";\" expected.\n");
  7104.             }
  7105.           else
  7106.             {
  7107.               if (source_token[0] != ';')
  7108.                 {
  7109.                   fatal_error=TRUE;
  7110.                   printf(
  7111.                    "Fatal error:  \";\" expected at line %ld, column %ld.\n",
  7112.                    source_line_num,source_column_num);
  7113.                 }
  7114.             }
  7115.         }
  7116.     }
  7117.  
  7118. static void perform_close(evaluate,queue_head)
  7119.   int            evaluate;
  7120.   queue_node_ptr queue_head;
  7121.     {
  7122.       if (queue_head == NULL)
  7123.         {
  7124.           if (evaluate)
  7125.             fclose(stdin);
  7126.         }
  7127.       else
  7128.         if ((*queue_head).next == NULL)
  7129.           {
  7130.             if (evaluate)
  7131.               {
  7132.                 if ((*((*queue_head).argument_header_ptr)).type == 'D')
  7133.                   fclose(
  7134.                    *((*((*queue_head).argument_header_ptr)).value_ptr.dataset));
  7135.                 else
  7136.                   {
  7137.                     fatal_error=TRUE;
  7138.                     printf(
  7139.                  "Fatal error:  argument to CLOSE is not a file pointer on\n");
  7140.                     printf("     line %ld, column %ld.\n",
  7141.                      source_line_num,source_column_num);
  7142.                   }
  7143.               }
  7144.           }
  7145.         else
  7146.           {
  7147.             fatal_error=TRUE;
  7148.             printf(
  7149.              "Fatal error:  extraneous arguments supplied to CLOSE on\n");
  7150.             printf("     line %ld, column %ld.\n",
  7151.              source_line_num,source_column_num);
  7152.           }
  7153.       return;
  7154.     }
  7155.  
  7156. static void perform_clrscr(evaluate,queue_head)
  7157.   int            evaluate;
  7158.   queue_node_ptr queue_head;
  7159.     {
  7160. #ifdef INCL_BASE
  7161.       unsigned char fill [2];
  7162.       VIOMODEINFO   video_mode_info;
  7163. #else
  7164.       union REGS inreg;
  7165.       union REGS outreg;
  7166. #endif
  7167.  
  7168.       if (queue_head == NULL)
  7169.         {
  7170.           if (evaluate)
  7171.             {
  7172. #ifdef INCL_BASE
  7173.               video_mode_info.cb=(unsigned int) 12;
  7174.               VioGetMode(&video_mode_info,(HVIO) 0);
  7175.               fill[0]=(unsigned char) ' ';
  7176.               fill[1]=(unsigned char) 7;
  7177.               VioScrollUp((USHORT) 0,(USHORT) 0,
  7178.                (USHORT) (video_mode_info.row-1),
  7179.                (USHORT) (video_mode_info.col-1),
  7180.                (USHORT) 0xffff,(PBYTE) &fill[0],(HVIO) 0);
  7181.               VioSetCurPos((USHORT) 0,(USHORT) 0,(HVIO) 0);
  7182.  #else
  7183.               inreg.h.ah=(unsigned char) 15;
  7184.               int86(16,&inreg,&outreg);
  7185.               inreg.h.ah=(unsigned char) 0;
  7186.               inreg.h.al=outreg.h.al;
  7187.               int86(16,&inreg,&outreg);
  7188.  #endif
  7189.             }
  7190.         }
  7191.       else
  7192.         {
  7193.           fatal_error=TRUE;
  7194.           printf(
  7195.            "Fatal error:  extraneous arguments supplied to CLOSE on\n");
  7196.           printf("     line %ld, column %ld.\n",
  7197.            source_line_num,source_column_num);
  7198.         }
  7199.       return;
  7200.     }
  7201.  
  7202. static void perform_pliretc(evaluate,queue_head)
  7203.   int            evaluate;
  7204.   queue_node_ptr queue_head;
  7205.     {
  7206.       if (queue_head == NULL)
  7207.         {
  7208.           fatal_error=TRUE;
  7209.           printf(
  7210.            "Fatal error:  argument not supplied to PLIRETC on\n");
  7211.           printf("     line %ld, column %ld.\n",
  7212.            source_line_num,source_column_num);
  7213.         }
  7214.       else
  7215.         if ((*queue_head).next == NULL)
  7216.           {
  7217.             if (evaluate)
  7218.               {
  7219.                 if ((*((*queue_head).argument_header_ptr)).type == 'I')
  7220.                   if ((*((*((*queue_head).argument_header_ptr)).value_ptr.
  7221.                    integer) > (long) 999)
  7222.                   ||  (*((*((*queue_head).argument_header_ptr)).value_ptr.
  7223.                    integer) < (long) 0))
  7224.                     return_code=999;
  7225.                   else
  7226.                     return_code=(int)
  7227.                      *((*((*queue_head).argument_header_ptr)).value_ptr.
  7228.                      integer);
  7229.                 else
  7230.                   {
  7231.                     fatal_error=TRUE;
  7232.                     printf(
  7233.                    "Fatal error:  argument to PLIRETC is not an integer on\n");
  7234.                     printf("     line %ld, column %ld.\n",
  7235.                      source_line_num,source_column_num);
  7236.                   }
  7237.               }
  7238.           }
  7239.         else
  7240.           {
  7241.             fatal_error=TRUE;
  7242.             printf(
  7243.              "Fatal error:  extraneous arguments supplied to PLIRETC on\n");
  7244.             printf("     line %ld, column %ld.\n",
  7245.              source_line_num,source_column_num);
  7246.           }
  7247.       return;
  7248.     }
  7249.  
  7250. static void perform_print(evaluate,queue_head)
  7251.   int            evaluate;
  7252.   queue_node_ptr queue_head;
  7253.     {
  7254.       register int  char_index;
  7255.       unsigned char *char_ptr;
  7256.       FILE          *file;
  7257.       int           string_length;
  7258.  
  7259.       if (queue_head == NULL)
  7260.         {
  7261.           fatal_error=TRUE;
  7262.           printf(
  7263.            "Fatal error:  first parameter to PRINT is missing on\n");
  7264.           printf(
  7265.            "     line %ld, column %ld.\n",source_line_num,
  7266.            source_column_num);
  7267.         }
  7268.       else
  7269.         {
  7270.           if (evaluate)
  7271.             {
  7272.               if ((*((*queue_head).argument_header_ptr)).type == 'D')
  7273.                 {
  7274.                   file=
  7275.                    *((*((*queue_head).argument_header_ptr)).value_ptr.dataset);
  7276.                   queue_head=(*queue_head).next;
  7277.                   while (queue_head != NULL)
  7278.                     {
  7279.                       switch ((*((*queue_head).argument_header_ptr)).type)
  7280.                         {
  7281.                           case 'B':
  7282.                             if (*((*((*queue_head).argument_header_ptr)).
  7283.                              value_ptr.boolean))
  7284.                               fprintf(file,"TRUE");
  7285.                             else
  7286.                               fprintf(file,"FALSE");
  7287.                             break;
  7288.                           case 'D':
  7289.                             fprintf(file,"%p",(char far *)
  7290.                              *((*((*queue_head).argument_header_ptr)).
  7291.                              value_ptr.dataset));
  7292.                             break;
  7293.                           case 'I':
  7294.                             fprintf(file,"%ld",
  7295.                              *((*((*queue_head).argument_header_ptr)).
  7296.                              value_ptr.integer));
  7297.                             break;
  7298.                           case 'R':
  7299.                             fprintf(file,"%lG",
  7300.                              *((*((*queue_head).argument_header_ptr)).
  7301.                              value_ptr.real));
  7302.                             break;
  7303.                           default:
  7304.                             char_ptr=(*((*((*queue_head).argument_header_ptr)).
  7305.                              value_ptr.string)).value;
  7306.                             string_length
  7307.                              =(*((*((*queue_head).argument_header_ptr)).
  7308.                              value_ptr.string)).length;
  7309.                             for (char_index=0; char_index < string_length;
  7310.                              char_index++)
  7311.                               {
  7312.                                 fputc((int) *char_ptr,file);
  7313.                                 char_ptr++;
  7314.                               }
  7315.                             break;
  7316.                         }
  7317.                       queue_head=(*queue_head).next;
  7318.                     }
  7319.                 }
  7320.               else
  7321.                 {
  7322.                   fatal_error=TRUE;
  7323.                   printf(
  7324.           "Fatal error:  first parameter to PRINT is not a file pointer on\n");
  7325.                   printf(
  7326.                    "     line %ld, column %ld.\n",source_line_num,
  7327.                    source_column_num);
  7328.                 }
  7329.             }
  7330.         }
  7331.       return;
  7332.     }
  7333.  
  7334. static void perform_putcrlf(evaluate,queue_head)
  7335.   int            evaluate;
  7336.   queue_node_ptr queue_head;
  7337.     {
  7338.       if (queue_head == NULL)
  7339.         {
  7340.           if (evaluate)
  7341.             printf("\n");
  7342.         }
  7343.       else
  7344.         if ((*queue_head).next == NULL)
  7345.           {
  7346.             if (evaluate)
  7347.               {
  7348.                 if ((*((*queue_head).argument_header_ptr)).type == 'D')
  7349.                   fprintf(
  7350.                    *((*((*queue_head).argument_header_ptr)).value_ptr.dataset),
  7351.                    "\n");
  7352.                 else
  7353.                   {
  7354.                     fatal_error=TRUE;
  7355.                     printf(
  7356.                "Fatal error:  argument to PUTCRLF is not a file pointer on\n");
  7357.                     printf("     line %ld, column %ld.\n",
  7358.                      source_line_num,source_column_num);
  7359.                   }
  7360.               }
  7361.           }
  7362.         else
  7363.           {
  7364.             fatal_error=TRUE;
  7365.             printf(
  7366.              "Fatal error:  extraneous arguments supplied to PUTCRLF on\n");
  7367.             printf("     line %ld, column %ld.\n",
  7368.              source_line_num,source_column_num);
  7369.           }
  7370.       return;
  7371.     }
  7372.  
  7373. static void perform_troff(evaluate,queue_head)
  7374.   int            evaluate;
  7375.   queue_node_ptr queue_head;
  7376.     {
  7377.       if (queue_head == NULL)
  7378.         {
  7379.           if (evaluate)
  7380.             trace=FALSE;
  7381.         }
  7382.       else
  7383.         {
  7384.           fatal_error=TRUE;
  7385.           printf(
  7386.            "Fatal error:  extraneous arguments supplied to TROFF on\n");
  7387.           printf("     line %ld, column %ld.\n",
  7388.            source_line_num,source_column_num);
  7389.         }
  7390.       return;
  7391.     }
  7392.  
  7393. static void perform_tron(evaluate,queue_head)
  7394.   int            evaluate;
  7395.   queue_node_ptr queue_head;
  7396.     {
  7397.       if (queue_head == NULL)
  7398.         {
  7399.           if (evaluate)
  7400.             trace=TRUE;
  7401.         }
  7402.       else
  7403.         {
  7404.           fatal_error=TRUE;
  7405.           printf(
  7406.            "Fatal error:  extraneous arguments supplied to TRON on\n");
  7407.           printf("     line %ld, column %ld.\n",
  7408.            source_line_num,source_column_num);
  7409.         }
  7410.       return;
  7411.     }
  7412.  
  7413. static void interpret_procedure(evaluate,queue_head)
  7414.   int            evaluate;
  7415.   queue_node_ptr queue_head;
  7416.     {
  7417.       if      (strcmp(identifier,"CLOSE") == 0)
  7418.         perform_close(evaluate,queue_head);
  7419.       else if (strcmp(identifier,"CLRSCR") == 0)
  7420.         perform_clrscr(evaluate,queue_head);
  7421.       else if (strcmp(identifier,"PLIRETC") == 0)
  7422.         perform_pliretc(evaluate,queue_head);
  7423.       else if (strcmp(identifier,"PRINT") == 0)
  7424.         perform_print(evaluate,queue_head);
  7425.       else if (strcmp(identifier,"PUTCRLF") == 0)
  7426.         perform_putcrlf(evaluate,queue_head);
  7427.       else if (strcmp(identifier,"TROFF") == 0)
  7428.         perform_troff(evaluate,queue_head);
  7429.       else if (strcmp(identifier,"TRON") == 0)
  7430.         perform_tron(evaluate,queue_head);
  7431.       else
  7432.         {
  7433.           fatal_error=TRUE;
  7434.           printf(
  7435.            "Fatal error:  unrecognized procedure \"%s\" at ",
  7436.            identifier);
  7437.           printf(
  7438.            "line %ld, column %ld.\n",source_line_num,
  7439.            source_column_num);
  7440.         }
  7441.       return;
  7442.     }
  7443.  
  7444. static void interpret_statement(evaluate)
  7445.   int evaluate;
  7446.     {
  7447.       queue_node_ptr new_queue_head;
  7448.       queue_node_ptr new_queue_tail;
  7449.       queue_node_ptr queue_head;
  7450.       queue_node_ptr queue_tail;
  7451.  
  7452.       if ((evaluate) && (trace))
  7453.         printf("[%ld]",source_line_num);
  7454.       if (source_token[0] == ' ')
  7455.         {
  7456.           fatal_error=TRUE;
  7457.           printf("Fatal error:  end of file encountered where statement ");
  7458.           printf("expected.\n");
  7459.         }
  7460.       else
  7461.         if (strcmp(source_token,"DO") == 0)
  7462.           interpret_do(evaluate);
  7463.         else
  7464.           if (strcmp(source_token,"IF") == 0)
  7465.             interpret_if(evaluate);
  7466.           else
  7467.             {
  7468.               if (strcmp(source_token,";") != 0)
  7469.                 {
  7470.                   if (isalpha((int) source_token[0]))
  7471.                     {
  7472.                       queue_tail=NULL;
  7473.                       queue_head=NULL;
  7474.                       strcpy(identifier,source_token);
  7475.                       get_token();
  7476.                       if (source_token[0] == '(')
  7477.                         {
  7478.                           if ((queue_head=(queue_node_ptr)
  7479.                            malloc((unsigned) sizeof(struct queue_node)))
  7480.                            == NULL)
  7481.                             {
  7482.                               fatal_error=TRUE;
  7483.                               printf(
  7484.                       "Fatal error:  out of memory at line %ld, column %ld.\n",
  7485.                                source_line_num,source_column_num);
  7486.                             }
  7487.                           else
  7488.                             {
  7489.                               queue_tail=queue_head;
  7490.                               (*queue_head).next=NULL;
  7491.                               (*queue_head).argument_header_ptr
  7492.                                =interpret_expression(evaluate);
  7493.                             }
  7494.                           if (! fatal_error)
  7495.                             get_token();
  7496.                           while ((! fatal_error)
  7497.                           &&     (! source_eof)
  7498.                           &&     (source_token[0] != ')'))
  7499.                             {
  7500.                               if ((new_queue_tail=(queue_node_ptr)
  7501.                                malloc((unsigned) sizeof(struct queue_node)))
  7502.                                == NULL)
  7503.                                 {
  7504.                                   fatal_error=TRUE;
  7505.                                   printf(
  7506.                       "Fatal error:  out of memory at line %ld, column %ld.\n",
  7507.                                    source_line_num,source_column_num);
  7508.                                 }
  7509.                               else
  7510.                                 {
  7511.                                   (*new_queue_tail).next=NULL;
  7512.                                   (*queue_tail).next=new_queue_tail;
  7513.                                   queue_tail=new_queue_tail;
  7514.                                   (*new_queue_tail).argument_header_ptr
  7515.                                    =interpret_expression(evaluate);
  7516.                                 }
  7517.                               if (! fatal_error)
  7518.                                 get_token();
  7519.                             }
  7520.                           if (! fatal_error)
  7521.                             {
  7522.                               if (source_token [0] == ')')
  7523.                                 get_token();
  7524.                             }
  7525.                         }
  7526.                       if (! fatal_error)
  7527.                         {
  7528.                           if (source_token[0] == '=')
  7529.                             interpret_assignment(evaluate,queue_head);
  7530.                           else
  7531.                             if (source_token[0] == ';')
  7532.                               interpret_procedure(evaluate,queue_head);
  7533.                             else
  7534.                               if (source_token[0] == ' ')
  7535.                                 {
  7536.                                   fatal_error=TRUE;
  7537.                                   printf(
  7538.                    "Fatal error:  file ends where \"=\" or \";\" expected.\n");
  7539.                                 }
  7540.                               else
  7541.                                 {
  7542.                                   fatal_error=TRUE;
  7543.                                   printf(
  7544.                        "Fatal error:  \"=\", or \";\" expected at line %ld,\n",
  7545.                                    source_line_num);
  7546.                                   printf(
  7547.                                    "     column %ld.\n",source_column_num);
  7548.                                 }
  7549.                         }
  7550.                       while (queue_head != NULL)
  7551.                         {
  7552.                           new_queue_head=(*queue_head).next;
  7553.                           free_value((*queue_head).argument_header_ptr);
  7554.                           free((char *) queue_head);
  7555.                           queue_head=new_queue_head;
  7556.                         }
  7557.                     }
  7558.                   else
  7559.                     if (source_token[0] == ' ')
  7560.                       {
  7561.                         fatal_error=TRUE;
  7562.                         printf(
  7563.           "Fatal error:  end of file encountered where statement expected.\n");
  7564.                       }
  7565.                     else
  7566.                       {
  7567.                         fatal_error=TRUE;
  7568.                         printf("Fatal error:  expected statement at ");
  7569.                         printf("     line %ld, column %ld.\n",source_line_num,
  7570.                          source_column_num);
  7571.                       }
  7572.                 }
  7573.             }
  7574.       return;
  7575.     }
  7576.