regina/rexx.c

   1 /*
   2  *  The Regina Rexx Interpreter
   3  *  Copyright (C) 1992-1994  Anders Christensen <anders@pvv.unit.no>
   4  *
   5  *  This library is free software; you can redistribute it and/or
   6  *  modify it under the terms of the GNU Library General Public
   7  *  License as published by the Free Software Foundation; either
   8  *  version 2 of the License, or (at your option) any later version.
   9  *
  10  *  This library is distributed in the hope that it will be useful,
  11  *  but WITHOUT ANY WARRANTY; without even the implied warranty of
  12  *  MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
  13  *  Library General Public License for more details.
  14  *
  15  *  You should have received a copy of the GNU Library General Public
  16  *  License along with this library; if not, write to the Free
  17  *  Software Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA.
  18  */
  19
  20 /*
  21  * Bug in LCC complier wchar.h that incorrectly says it defines stat struct
  22  * but doesn't
  23  */
  24 #if defined(__LCC__)
  25 # include <sys/stat.h>
  26 #endif
  27
  28 #include "regina_c.h"
  29
  30 #if defined(WIN32) && defined(__IBMC__)
  31 #include <windows.h>
  32 #pragma warning(default: 4115 4201 4214)
  33 #else
  34 # ifdef RXLIB
  35 #  define APIENTRY
  36 #  if defined(__WATCOMC__) && defined(__NT__)
  37 #   undef APIENTRY
  38 #   include <windows.h>
  39 #  endif
  40 #  if defined(__MINGW32__) || defined(__LCC__)
  41 #   undef APIENTRY
  42 #   include <windows.h>
  43 #  endif
  44 #  if defined(WIN32) && defined(__BORLANDC__)
  45 #   undef APIENTRY
  46 #   include <windows.h>
  47 #  endif
  48
  49 #  if defined(_MSC_VER)
  50 #   undef APIENTRY
  51 #   if _MSC_VER >= 1100
  52 /* Stupid MSC can't compile own headers without warning at least in VC 5.0 */
  53 #    pragma warning(disable: 4115 4201 4214 4514)
  54 #   endif
  55 #   include <windows.h>
  56 #   if _MSC_VER >= 1100
  57 #    pragma warning(default: 4115 4201 4214)
  58 #   endif
  59 #  endif
  60 # else /* not RXLIB */
  61 #  if defined(__WATCOMC__) && defined(__NT__)
  62 #   include <windows.h>
  63 # endif
  64 #  if defined(__MINGW32__) || defined(__LCC__)
  65 #   include <windows.h>
  66 #  endif
  67 #  if defined(WIN32) && defined(__BORLANDC__)
  68 #   include <windows.h>
  69 #  endif
  70
  71 #  if defined(_MSC_VER) && !defined(__WINS__)
  72 #   if _MSC_VER >= 1100
  73 /* Stupid MSC can't compile own headers without warning at least in VC 5.0 */
  74 #    pragma warning(disable: 4115 4201 4214 4514)
  75 #   endif
  76 #   include <windows.h>
  77 #   if _MSC_VER >= 1100
  78 #    pragma warning(default: 4115 4201 4214)
  79 #   endif
  80 #  endif
  81 # endif
  82 #endif
  83
  84 #if defined(OS2) || defined(__EMX__)
  85 # if defined(__WATCOMC__) && defined(RXLIB)
  86 #  undef APIENTRY
  87 # elif defined(__INNOTEK_LIBC__)
  88 #  undef APIENTRY
  89 #  define APIENTRY _System
  90 # endif
  91 # define INCL_BASE
  92 # include <os2.h>
  93 # define DONT_TYPEDEF_PFN
  94 #endif
  95
  96 #include "rexx.h"
  97 #include <string.h>
  98 #include <stdio.h>
  99 #include <assert.h>
 100
 101 #ifdef VMS
 102 # include <stat.h>
 103 #elif defined(MAC)
 104 # include "mac.h"
 105 #else
 106 # include <sys/stat.h>
 107 #endif
 108
 109 #if defined(DJGPP) || defined(__EMX__) || defined(_MSC_VER) || (defined(__WATCOMC__) && !defined(__QNX__)) || defined(__EPOC32__)
 110 # include <fcntl.h>
 111 # if !defined(__WINS__) && !defined(__EPOC32__)
 112 #  include <io.h>
 113 # endif
 114 #endif
 115
 116 #ifdef HAVE_UNISTD_H
 117 # include <unistd.h>
 118 #endif
 119
 120 /*
 121  * Since development of Ultrix has ceased, and they never managed to
 122  * fix a few things, we want to define a few things, just in order
 123  * to kill a few warnings ...
 124  */
 125 #if defined(FIX_PROTOS) && defined(FIX_ALL_PROTOS) && defined(ultrix)
 126    int fstat( int fd, struct stat *buf ) ;
 127    int stat( char *path, struct stat *buf ) ;
 128 #endif
 129
 130
 131 /* Don't terminate the following lines by a semicolon */
 132 GLOBAL_PROTECTION_VAR(regina_globals)
 133
 134
 135 /*
 136  * Note: must match the settings of NUM_FORM_* in flags.h
 137  */
 138 const char *numeric_forms[] = { "SCIENTIFIC", "ENGINEERING" } ;
 139
 140 /*
 141  * Note: these must match the definitions of INVO_* in defs.h
 142  */
 143 const char *invo_strings[] = { "COMMAND", "FUNCTION", "SUBROUTINE" } ;
 144
 145 const char *argv0 = NULL;
 146
 147 /*
 148  * The following global is to store the TSD of the currently running
 149  * interpreter instance.
 150  * Each API call checks this variable, and if not NULL, this is used
 151  * as the TSD to use.
 152  * This enables multiple threads to run within the one interpreter instance.
 153  * Set by OPTIONS SINGLE_INTERPRETER
 154  */
 155 tsd_t *__regina_global_TSD = NULL;
 156
 157 static void usage( char * );
 158
 159 #ifdef TRACEMEM
 160 void marksubtree( nodeptr ptr )
 161 {
 162    unsigned i;
 163
 164    while ( ptr )
 165    {
 166       markmemory( ptr, TRC_TREENODE );
 167
 168       if ( ptr->name )
 169          markmemory( ptr->name, TRC_TREENODE );
 170
 171       for ( i = 0; i < sizeof( ptr->p ) / sizeof( ptr->p[0] ); i++ )
 172          marksubtree( ptr->p[i] );
 173
 174
 175       if ( ( ptr->type == X_STRING ) || ( ptr->type == X_CON_SYMBOL ) )
 176       {
 177          if ( ptr->u.number )
 178          {
 179             markmemory( ptr->u.number, TRC_TREENODE );
 180             markmemory( ptr->u.number->num, TRC_TREENODE );
 181          }
 182       }
 183       else if ( ptr->type == X_CEXPRLIST )
 184       {
 185          if ( ptr->u.strng )
 186             markmemory( ptr->u.strng, TRC_TREENODE );
 187       }
 188
 189       ptr = ptr->next;
 190    }
 191 }
 192 #endif /* TRACEMEM */
 193
 194
 195 /*
 196  * GetArgv0 tries to find the fully qualified filename of the current program.
 197  * It uses some ugly and system specific tricks and it may return NULL if
 198  * it can't find any useful value.
 199  * The argument should be argv[0] of main() and it may be returned.
 200  * This function must not be called from another as the sole one when starting
 201  * up.
 202  */
 203 static const char *GetArgv0(const char *argv0)
 204 {
 205 #ifdef WIN32
 206    char buf[512];
 207
 208    if (GetModuleFileName(NULL, buf, sizeof(buf)) != 0)
 209       return(strdup(buf)); /* never freed up */
 210 #elif defined(__QNX__) && defined(__WATCOMC__)
 211    char buffer[PATH_MAX];
 212    char *buf;
 213    if ( (buf = _cmdname(buffer) ) != NULL )
 214       return(strdup(buf)); /* never freed up */
 215 #elif defined(OS2)
 216    char buf[512];
 217    PPIB ppib;
 218
 219 # ifdef __EMX__
 220    if (_osmode == OS2_MODE)
 221    {
 222 # endif
 223       if (DosGetInfoBlocks(NULL, &ppib) == 0)
 224          if (DosQueryModuleName(ppib->pib_hmte, sizeof(buf), buf) == 0)
 225             return(strdup(buf));
 226 # ifdef __EMX__
 227    }
 228 # endif
 229 #endif
 230
 231 #ifdef HAVE_READLINK
 232    {
 233       /*
 234        * will work on Linux 2.1+
 235        */
 236       char buf[1024];
 237       int result;
 238       result = readlink("/proc/self/exe", buf, sizeof( buf ) );
 239       if ( ( result > 0 ) && ( result < (int) sizeof( buf ) ) && ( buf[0] != '[' ) )
 240       {
 241          buf[result] = '\0';
 242          return strdup( buf );
 243       }
 244    }
 245 #endif
 246    /* No specific code has found the right file name. Maybe, it's coded
 247     * in argv0. Check it, if it is an absolute path. Be absolutely sure
 248     * to detect it safely!
 249     */
 250    if (argv0 == NULL)
 251       return(NULL);
 252
 253    if (argv0[0] == '/') /* unix systems and some others */
 254       return(argv0);
 255
 256    if ((argv0[0] == '\\') && (argv0[1] == '\\')) /* MS and OS/2 UNC names */
 257       return(argv0);
 258
 259    if (rx_isalpha(argv0[0]) && (argv0[1] == ':') && (argv0[2] == '\\'))
 260       return(argv0); /* MS and OS/2 drive letter with path */
 261
 262    return(NULL); /* not a proven argv0 argument */
 263 }
 264
 265
 266 /*
 267  * setup_system sets up some basics which are needed to use parts of the
 268  * interpreter.
 269  * This is a common routine of rexx's or regina's main() and every
 270  * SAA function.
 271  * isclient should be set to 1 if called from the SAA interface, 0 otherwise.
 272  *
 273  * Note that you have to set TSD->currlevel->script_exit as fast as possible.
 274  * Otherwise you are at high risk that an error will stop the whole process,
 275  * which is fatal if an application uses us via SAA API.
 276  */
 277 void setup_system( tsd_t *TSD, int isclient )
 278 {
 279    TSD->stddump = stderr;
 280
 281    TSD->systeminfo = creat_sysinfo( TSD, Str_creTSD( "SYSTEM" ) );
 282
 283    TSD->systeminfo->currlevel0 = TSD->currlevel = newlevel( TSD, NULL );
 284    TSD->systeminfo->trace_override = 0;
 285    TSD->isclient = isclient;
 286 }
 287
 288 /*
 289  * check_args examines the arguments of the program and assigns the values
 290  * to the various structures.
 291  *
 292  * A process exit of 0 is required if 0 is returned. Otherwise the number
 293  * of processed args including the zeroth is returned.
 294  */
 295 static int check_args( tsd_t *TSD, int argc, char **argv,
 296                        int *compile_to_tokens, int *execute_from_tokens,
 297                        int *locale_set )
 298 {
 299    int i;
 300    char c, *arg;
 301
 302    for ( i = 1; i < argc; i++ )
 303    {
 304       arg = argv[i];
 305       if ( *arg == '-' )
 306       {
 307          arg++;
 308          while ( *arg )
 309          {
 310             c = *arg++;
 311             switch ( c )
 312             {
 313                case 'i':
 314                   starttrace( TSD );
 315                   set_trace_char( TSD, 'A' );
 316                   intertrace( TSD );
 317                   intertrace( TSD );
 318                   break;
 319
 320                case 'p':
 321 #if !defined(__WINS__) && !defined(__EPOC32__)
 322                   set_pause_at_exit();
 323 #endif
 324                   break;
 325
 326                case 'v':
 327                   fprintf( stderr, "%s\n", PARSE_VERSION_STRING );
 328                   /*
 329                    * Also display any staticall linked packages
 330                    */
 331 #if defined( DYNAMIC_STATIC )
 332                   static_list_packages();
 333 #endif
 334                   return 0;
 335
 336                case 'y':
 337 #ifndef NDEBUG
 338                   __reginadebug = 1;   /* yacc-debugging */
 339 #endif
 340                   break;
 341
 342                case 'r': /* safe-rexx */
 343                   TSD->restricted = 1;
 344                   break;
 345
 346                case 't':
 347                   if ( strlen( arg ) > 1 )
 348                   {
 349                      usage( argv[0] );
 350                      fprintf( stdout, "\n"
 351                                       "The passed switch `-t' allows just "
 352                                            "one additional character, Regina "
 353                                                                  "exits.\n" );
 354                      exit( 1 );
 355                   }
 356                   if ( *arg )
 357                      queue_trace_char( TSD, *arg );
 358                   else
 359                      queue_trace_char( TSD, 'A' );
 360                   arg += strlen( arg );
 361                   TSD->systeminfo->trace_override = 1;
 362                   break;
 363
 364                case 'd':
 365                   if ( *arg == 'm' )
 366                      TSD->listleakedmemory = 1;
 367                   arg += strlen( arg );
 368                   break;
 369
 370                case 'a': /* multiple args */
 371                   TSD->systeminfo->invoked = INVO_SUBROUTINE;
 372                   break;
 373
 374                case 'c': /* compile to tokenised file */
 375                   if ( *execute_from_tokens )
 376                   {
 377                      usage( argv[0] );
 378                      fprintf( stdout, "\n"
 379                                       "The flags `-c' and `-e' are mutually "
 380                                                "exclusive, Regina exits.\n" );
 381                      exit( 1 );
 382                   }
 383                   *compile_to_tokens = 1;
 384                   break;
 385
 386                case 'e': /* execute from tokenised file */
 387                   if ( *compile_to_tokens )
 388                   {
 389                      usage( argv[0] );
 390                      fprintf( stdout, "\n"
 391                                       "The flags `-c' and `-e' are mutually "
 392                                                "exclusive, Regina exits.\n" );
 393                      exit( 1 );
 394                   }
 395                   *execute_from_tokens = 1;
 396                   break;
 397
 398                case 'l': /* set locale information, accept empty string */
 399                   *locale_set = 1;
 400                   set_locale_info( arg );
 401                   arg += strlen( arg );
 402                   break;
 403
 404                case 'h': /* usage */
 405                case '?': /* usage */
 406                   usage( argv[0] );
 407                   return 0;
 408
 409                default:
 410                   usage( argv[0] );
 411                   fprintf( stdout, "\n"
 412                                    "The passed switch `-%c' is unknown, "
 413                                                         "Regina exits.\n", c );
 414                   exit( 1 );
 415             }
 416          }
 417          continue;
 418       }
 419
 420       return i;
 421    }
 422
 423    return argc;
 424 }
 425
 426 /*
 427  * just_compile does a compile step without execution of the assigned input
 428  * file (TSD->systeminfo's input_file) to the file named outputname.
 429  *
 430  * On exit everything has been done.
 431  */
 432 static void just_compile( tsd_t *TSD, char *outputname )
 433 {
 434    int len;
 435    streng *SrcStr;
 436    internal_parser_type ipt;
 437    void *instore_buf;
 438    unsigned long instore_length;
 439    FILE *outfp;
 440
 441    /*
 442     * Read the file
 443     */
 444    fseek( TSD->systeminfo->input_fp, 0, SEEK_END );
 445    len = (int) ftell( TSD->systeminfo->input_fp );
 446    rewind( TSD->systeminfo->input_fp );
 447
 448    SrcStr = Str_makeTSD( len );
 449    if ( fread( Str_val( SrcStr ), len, 1, TSD->systeminfo->input_fp ) != 1 )
 450       exiterror( ERR_PROG_UNREADABLE, 1, "Unable to read input file" );
 451    SrcStr->len = len;
 452
 453    /*
 454     * enter_macro() actually does the tokenising...
 455     */
 456    ipt = enter_macro( TSD, SrcStr, &instore_buf, &instore_length );
 457    (void)ipt; // FIXME: Should this be tested for success?
 458    fclose( TSD->systeminfo->input_fp );
 459
 460    outfp = fopen( outputname, "wb" );
 461    if ( outfp == NULL )
 462       exiterror( ERR_PROG_UNREADABLE, 1, "Unable to open output file for "
 463                                                                    "writing" );
 464    if ( instore_buf == NULL )
 465       exiterror( ERR_PROG_UNREADABLE, 1, "Error tokenising input file" );
 466    if ( fwrite( instore_buf, instore_length, 1, outfp ) != 1 )
 467       exiterror( ERR_PROG_UNREADABLE, 1, "Unable to write contents of output "
 468                                                                       "file" );
 469    fclose( outfp );
 470 }
 471
 472 /*
 473  * assign_args sets the current argument list to that one in argv. We count
 474  * from the next_arg element to to excluding argc.
 475  *
 476  * The value is put in TSD->currlevel->args which has to be preeassigned to
 477  * NULL.
 478  */
 479 static void assign_args( tsd_t *TSD, int argc, int next_arg, char **argv )
 480 {
 481    int i, len;
 482    streng *string;
 483    paramboxptr args, prev;
 484
 485    if ( next_arg >= argc )
 486       return;
 487
 488    if ( TSD->systeminfo->invoked == INVO_SUBROUTINE )
 489    {
 490       prev = NULL;
 491       for ( i = next_arg; i < argc; i++ )
 492       {
 493          args = (paramboxptr)MallocTSD( sizeof( parambox ) );
 494          memset( args, 0, sizeof( parambox ) );
 495
 496          if ( i == next_arg )
 497             TSD->currlevel->args = args;
 498          else
 499             prev->next = args;
 500          args->value = Str_cre_TSD( TSD, argv[i] );
 501          prev = args;
 502       }
 503
 504       return;
 505    }
 506
 507    for ( i = next_arg, len = 0; i < argc; i++ )
 508       len += strlen( argv[i] ) + 1; /* delimiter or terminator */
 509
 510    TSD->currlevel->args = (paramboxptr)MallocTSD( sizeof( parambox ) );
 511    if ( TSD->currlevel->args == NULL )
 512       exiterror( ERR_STORAGE_EXHAUSTED, 0 );
 513    args = TSD->currlevel->args;
 514    memset( args, 0, sizeof(parambox) );
 515    args->value = string = Str_makeTSD( len );
 516
 517    for ( i = next_arg; i < argc; i++ )
 518    {
 519       string = Str_catstrTSD( string, argv[i] );
 520       string->value[string->len++] = ' ';
 521    }
 522    if ( string && string->len )
 523       string->len--;
 524 }
 525
 526 /*
 527  * codeFromString translates string into a number and returns it. If this is
 528  * not possible, EXIT_SUCCESS is returned.
 529  */
 530 static int codeFromString( tsd_t *TSD, streng *string )
 531 {
 532    int error, rcode;
 533
 534    if ( string )
 535    {
 536       /* fixes bug 657345 */
 537       rcode = streng_to_int( TSD, string, &error );
 538       if ( error )
 539          rcode = EXIT_SUCCESS;
 540    }
 541    else
 542       rcode = EXIT_SUCCESS;
 543
 544    return rcode;
 545 }
 546
 547 /*
 548  * execute_tokenized executes a tokenized script that has already been assigned
 549  * as the input file.
 550  *
 551  * The arguments must have been assigned, too.
 552  *
 553  * The return value is the value that the main routine should return to the OS.
 554  */
 555 static int execute_tokenized( tsd_t *TSD )
 556 {
 557    void *TinnedTree;
 558    unsigned long TinnedTreeLen;
 559    streng *command;
 560    streng *result;
 561    streng *environment;
 562    int err,RetCode;
 563
 564    /*
 565     * Read the file into TinnedTree.
 566     */
 567    fseek( TSD->systeminfo->input_fp, 0, SEEK_END );
 568    TinnedTreeLen = ftell( TSD->systeminfo->input_fp );
 569    rewind( TSD->systeminfo->input_fp );
 570    TinnedTree = MallocTSD( TinnedTreeLen );
 571    if ( TinnedTree == NULL )
 572       exiterror( ERR_STORAGE_EXHAUSTED, 0 );
 573    if ( fread( TinnedTree, TinnedTreeLen, 1, TSD->systeminfo->input_fp ) != 1 )
 574       exiterror( ERR_PROG_UNREADABLE, 1, "Unable to read input file" );
 575    /*
 576     * Don't close the file because the plain text file remains open as well.
 577     * This inhibits the deletion or modification on most systems.
 578     */
 579
 580    /*
 581     * Check if the file being read is a valid tokenised file.
 582     */
 583    if ( !IsValidTin( (const external_parser_type *)TinnedTree, TinnedTreeLen ) )
 584       exiterror( ERR_PROG_UNREADABLE,
 585                  1,
 586                  "The supplied file is not a valid Regina tokenised file" );
 587
 588    /*
 589     * Set program file name and environment. The argument have been assigned
 590     * already.
 591     */
 592    command = Str_dupTSD( TSD->systeminfo->input_file );
 593
 594    /*
 595     * Changed after 3.3RC1: The environment is set to SYSTEM instead of
 596     * the externally bound (ENVIR_PIPE) "DEFAULT".
 597     */
 598    environment = Str_creTSD( "SYSTEM" );
 599
 600    flush_trace_chars( TSD );
 601
 602    /*
 603     * do_instore() actually does the execution...
 604     */
 605    result = do_instore( TSD, command, TSD->currlevel->args, environment,
 606                         &err,
 607                         0,
 608                         TinnedTree, TinnedTreeLen,
 609                         NULL, 0, /* source file contents */
 610                         NULL,
 611                         TSD->systeminfo->invoked );
 612
 613    FreeTSD( TinnedTree );
 614    Free_stringTSD( command );
 615    Free_stringTSD( environment );
 616
 617    if ( result )
 618    {
 619       RetCode = codeFromString( TSD, result );
 620       Free_stringTSD( result );
 621    }
 622    else
 623       RetCode = err;
 624
 625    return RetCode;
 626 }
 627
 628 /*
 629  * execute_file executes a plain text script that has already been assigned
 630  * as the input file.
 631  *
 632  * The arguments must have been assigned, too.
 633  *
 634  * The return value is the value that the main routine should return to the OS.
 635  */
 636 static int execute_file( tsd_t *TSD )
 637 {
 638    FILE *fptr = TSD->systeminfo->input_fp;
 639    internal_parser_type parsing;
 640    streng *string;
 641    int RetCode;
 642
 643    /*
 644     * From here we are interpreting...
 645     */
 646    fetch_file( TSD, fptr ? fptr : stdin, &parsing );
 647    if ( fptr )
 648       fclose( fptr );
 649    TSD->systeminfo->input_fp = NULL;
 650
 651    if ( parsing.result != 0 )
 652       exiterror( ERR_YACC_SYNTAX, 1, parsing.tline );
 653    else
 654       TSD->systeminfo->tree = parsing;
 655
 656 #if !defined(MINIMAL) && !defined(VMS) && !defined(DOS) && !defined(_MSC_VER) && !defined(__IBMC__) && !defined(MAC)
 657    if ( !fptr )
 658    {
 659       struct stat buffer;
 660       int rc;
 661
 662       rc = fstat( fileno( stdin ), &buffer );
 663       if ( ( rc == 0 ) && S_ISCHR( buffer.st_mode ) )
 664       {
 665          /*
 666           * FIXME. MH and FGC.
 667           * When does this happen. Add debugging code to determine this, because
 668           * after 2 glasses of rocket fuel it seems silly to have this code!
 669           * 13-5-2004.
 670           */
 671          printf( "  \b\b" );
 672          fflush( stdout );
 673          rewind( stdin );
 674       }
 675    }
 676 #endif
 677
 678    flush_trace_chars( TSD );
 679
 680    string = interpret( TSD, TSD->systeminfo->tree.root );
 681    RetCode = codeFromString( TSD, string );
 682    if ( string )
 683       Free_stringTSD( string );
 684
 685    return RetCode;
 686 }
 687
 688 #ifdef RXLIB
 689 # if defined(__LCC__)
 690 int __regina_faked_main(int argc,char *argv[])
 691 # else
 692 int APIENTRY __regina_faked_main(int argc,char *argv[])
 693 # endif
 694 # define CALL_MAIN __regina_faked_main
 695 #else
 696 int main(int argc,char *argv[])
 697 # define CALL_MAIN main
 698 #endif
 699 {
 700    tsd_t *TSD;
 701    int processed;
 702    int compile_to_tokens=0;
 703    int execute_from_tokens=0;
 704    int locale_set=0;
 705    int rcode;
 706    jmp_buf jbuf;
 707
 708 #ifdef MAC
 709    InitCursorCtl( nil );
 710 #endif
 711
 712    if ( argv0 == NULL )
 713       argv0 = GetArgv0( argv[0] );
 714
 715    TSD = GLOBAL_ENTRY_POINT();
 716
 717    setup_system( TSD, 0 );
 718
 719    if ( setjmp( jbuf ) )
 720    {
 721       /*
 722        * We may either be jumped normally after an EXIT instruction or after
 723        * an error. The first reason means normal continuation, the other
 724        * means that we have to do an immediate stop.
 725        */
 726       if ( !TSD->instore_is_errorfree )
 727       {
 728          if ( TSD->systeminfo->result )
 729             return atoi( TSD->systeminfo->result->value );
 730          return -1;
 731       }
 732       else
 733       {
 734          if ( TSD->systeminfo->result )
 735             rcode = codeFromString( TSD, TSD->systeminfo->result );
 736          else
 737             rcode = EXIT_SUCCESS;
 738       }
 739    }
 740    else
 741    {
 742       TSD->systeminfo->script_exit = &jbuf;
 743
 744       processed = check_args( TSD, argc, argv, &compile_to_tokens,
 745                               &execute_from_tokens, &locale_set );
 746
 747       if ( processed == 0 )
 748          return 0;
 749
 750       if ( !locale_set )
 751       {
 752          /*
 753           * Check for a comma separated default locale in REGINA_LANG.
 754           */
 755          char *ptr = getenv( "REGINA_LANG" );
 756          if ( ptr )
 757             ptr = strchr( ptr, ',' );
 758          if ( ptr )
 759             set_locale_info( ptr + 1 );
 760       }
 761
 762       if ( processed < argc )
 763       {
 764          TSD->systeminfo->input_file = get_external_routine( TSD,
 765                                 argv[processed], &TSD->systeminfo->input_fp );
 766          if ( !TSD->systeminfo->input_file )
 767          {
 768             TSD->systeminfo->input_file = Str_crestrTSD( argv[processed] );
 769             exiterror( ERR_PROG_UNREADABLE, 1, "Program was not found" );
 770          }
 771          processed++;
 772       }
 773       else
 774       {
 775          TSD->systeminfo->input_file = Str_crestrTSD( "<stdin>" );
 776          TSD->systeminfo->input_fp = NULL;
 777          if ( compile_to_tokens )
 778             exiterror( ERR_PROG_UNREADABLE, 1, "Too few arguments when "
 779                                 "tokenising. Usage: -c inputfile outputfile" );
 780          if ( execute_from_tokens )
 781             exiterror( ERR_PROG_UNREADABLE, 1, "Cannot run tokenised code "
 782                                                                "from stdin." );
 783       }
 784
 785
 786       /*
 787        * -c switch specified - tokenise the input file before mucking around
 788        * with parameters etc.
 789        */
 790       if ( compile_to_tokens )
 791       {
 792          if ( processed >= argc )
 793             exiterror( ERR_PROG_UNREADABLE, 1, "Too few arguments when "
 794                                 "tokenising. Usage: -c inputfile outputfile" );
 795          if ( processed + 1 < argc )
 796             exiterror( ERR_PROG_UNREADABLE, 1, "Too many arguments when "
 797                                 "tokenising. Usage: -c inputfile outputfile" );
 798
 799          just_compile( TSD, argv[processed] );
 800          return 0;
 801       }
 802
 803       /*
 804        * Under DJGPP setmode screws up Parse Pull and entering code
 805        * interactively :-(
 806        */
 807 #if defined(__EMX__) || (defined(_MSC_VER) && !defined(__WINS__)) || (defined(__WATCOMC__) && !defined(__QNX__))
 808       setmode( fileno( stdin ), O_BINARY );
 809       setmode( fileno( stdout ), O_BINARY );
 810       setmode( fileno( stderr ), O_BINARY );
 811 #endif
 812
 813       assign_args( TSD, argc, processed, argv );
 814       signal_setup( TSD );
 815
 816       /*
 817        * -e switch specified - execute from tokenised code
 818        */
 819       if ( execute_from_tokens )
 820          rcode = execute_tokenized( TSD );
 821       else
 822          rcode = execute_file( TSD );
 823    }
 824
 825 #if defined(DEBUG) || defined(TRACEMEM)
 826    /*
 827     * Now do the cleanup. We don't need in real life, but for a proper cleanup
 828     * and for debugging aid it is a good idea to track down the whole beast.
 829     */
 830    purge_stacks( TSD );
 831    purge_filetable( TSD );
 832 # if defined(FLISTS) && defined(NEW_FLISTS)
 833    free_flists();
 834 # endif
 835
 836 # ifdef DYNAMIC
 837    /*
 838     * Remove all external function package functions
 839     * and libraries. Only valid for the DYNAMIC library.
 840     */
 841    purge_library( TSD );
 842 # endif
 843
 844 # ifdef TRACEMEM
 845    if ( TSD->listleakedmemory )
 846       listleaked( TSD, MEMTRC_LEAKED );
 847 # endif
 848
 849    TSD->systeminfo->script_exit = NULL; /* cannot be freed, it's on the stack*/
 850    killsystem( TSD, TSD->systeminfo );
 851    TSD->systeminfo = NULL;
 852
 853    /*
 854     * Remove all memory allocated by the flists internal memory manager.
 855     */
 856 # ifdef FLISTS
 857    purge_flists( TSD );
 858 # endif
 859
 860 #endif /* DEBUG */
 861
 862    return rcode;
 863 }
 864
 865 /* reexecute_main is possibly called by one of the fork_exec routines.
 866  * This functions cleans up some stuff to reexecute without problems.
 867  * The most useful thing to be done here is freeing all used memory.
 868  * NOTE: usage is always the last thing you should try. Better use
 869  * spawn or exec to let a fresh interpreter do the work.
 870  */
 871 int __regina_reexecute_main(int argc, char **argv)
 872 {
 873    tsd_t *TSD;
 874
 875    TSD = __regina_get_tsd(); /* hopefully not multithreading! */
 876
 877    if (TSD != NULL) /* yes! I don't know what happens on forking */
 878    {                /* and active multi-threading                */
 879
 880       purge_stacks(TSD);    /* see main above for comments */
 881       purge_filetable(TSD);
 882 #ifdef DYNAMIC
 883       purge_library(TSD);
 884 #endif
 885 #if defined(FLISTS)
 886 # if defined(NEW_FLISTS)
 887       free_flists();
 888 # endif
 889       purge_flists(TSD);
 890 #endif
 891    }
 892
 893    return(CALL_MAIN(argc, argv));
 894 }
 895
 896 #ifdef TRACEMEM
 897 void mark_systeminfo( const tsd_t *TSD )
 898 {
 899    sysinfo sinfo=NULL ;
 900    labelbox *lptr=NULL ;
 901    lineboxptr llptr=NULL ;
 902
 903    for (sinfo=TSD->systeminfo; sinfo; sinfo=sinfo->previous)
 904    {
 905       markmemory(sinfo, TRC_SYSINFO) ;
 906       markmemory(sinfo->input_file, TRC_SYSINFO) ;
 907       markmemory(sinfo->environment, TRC_SYSINFO) ;
 908       markmemory(sinfo->callstack, TRC_SYSINFO) ;
 909
 910       markvariables( TSD, sinfo->currlevel0 ) ;
 911       marksource( sinfo->tree.first_source_line ) ;
 912       /* FGC, FIXME: rewrite this: marksubtree( sinfo->tree.root ) ; */
 913
 914       for (lptr=sinfo->tree.first_label; lptr; lptr=lptr->next )
 915       {
 916          markmemory( lptr, TRC_SYSINFO ) ;
 917       }
 918
 919       for (llptr=sinfo->tree.first_source_line; llptr; llptr=llptr->next )
 920       {
 921          markmemory( llptr, TRC_SYSINFO ) ;
 922          markmemory( llptr->line, TRC_SYSINFO ) ;
 923       }
 924    }
 925
 926    markmemory( TSD->mem_tsd, TRC_SYSINFO );
 927    markmemory( TSD->var_tsd, TRC_SYSINFO );
 928    markmemory( TSD->stk_tsd, TRC_SYSINFO );
 929    markmemory( TSD->fil_tsd, TRC_SYSINFO );
 930    markmemory( TSD->itp_tsd, TRC_SYSINFO );
 931    markmemory( TSD->tra_tsd, TRC_SYSINFO );
 932    markmemory( TSD->err_tsd, TRC_SYSINFO );
 933    if (TSD->vms_tsd )
 934       markmemory( TSD->vms_tsd, TRC_SYSINFO );
 935    markmemory( TSD->bui_tsd, TRC_SYSINFO );
 936    if (TSD->vmf_tsd )
 937       markmemory( TSD->vmf_tsd, TRC_SYSINFO );
 938    markmemory( TSD->lib_tsd, TRC_SYSINFO );
 939    if (TSD->rex_tsd )
 940       markmemory( TSD->rex_tsd, TRC_SYSINFO );
 941    markmemory( TSD->shl_tsd, TRC_SYSINFO );
 942    markmemory( TSD->mat_tsd, TRC_SYSINFO );
 943    if (TSD->cli_tsd )
 944       markmemory( TSD->cli_tsd, TRC_SYSINFO );
 945    markmemory( TSD->arx_tsd, TRC_SYSINFO );
 946    markmemory( TSD->mt_tsd, TRC_SYSINFO );
 947 }
 948 #endif
 949
 950
 951 sysinfobox *creat_sysinfo( const tsd_t *TSD, streng *envir )
 952 {
 953    sysinfobox *sinfo;
 954
 955    sinfo = (sysinfobox *)MallocTSD( sizeof(sysinfobox) );
 956    sinfo->environment = envir;
 957    sinfo->tracing = DEFAULT_TRACING;
 958    sinfo->interactive = DEFAULT_INT_TRACING;
 959    sinfo->previous = NULL;
 960    sinfo->invoked = INVO_COMMAND;
 961    sinfo->input_file = NULL;
 962    sinfo->input_fp = NULL;
 963    sinfo->script_exit = NULL ;
 964    sinfo->hooks = 0;
 965    sinfo->callstack = (nodeptr *)MallocTSD( sizeof( nodeptr ) * 10 );
 966    sinfo->result = NULL;
 967    sinfo->cstackcnt = 0;
 968    sinfo->cstackmax = 10;
 969    sinfo->trace_override = 0;
 970    sinfo->ctrlcounter = 0;
 971    memset( &sinfo->tree, 0, sizeof( sinfo->tree ) );
 972
 973    return sinfo;
 974 }
 975 /*
 976  * The following two functions are used to set and retrieve the value of
 977  * the global TSD
 978  */
 979 void setGlobalTSD( tsd_t *TSD)
 980 {
 981    __regina_global_TSD = TSD;
 982 }
 983
 984 tsd_t *getGlobalTSD( void )
 985 {
 986    return __regina_global_TSD;
 987 }
 988
 989 #if !defined(RXLIB) && !defined(VMS)
 990
 991 static void NoAPI( void )
 992 {
 993    fprintf (stderr, "Warning: SAA API not compiled into interpreter\n" ) ;
 994 }
 995
 996 int hookup( tsd_t *TSD, int dummy )
 997 {
 998    /* This should never happen, if we don't have support for SAA API,
 999     * Then we should never get a system exit!
1000     */
1001    assert( 0 ) ;
1002    dummy = dummy; /* keep compiler happy */
1003    TSD = TSD; /* keep compiler happy */
1004    return 1 ;  /* to keep compiler happy */
1005 }
1006 int hookup_input( tsd_t *TSD, int dummy1, streng **dummy2 )
1007 {
1008    /* This should never happen, if we don't have support for SAA API,
1009     * Then we should never get a system exit!
1010     */
1011    TSD = TSD; /* keep compiler happy */
1012    dummy1 = dummy1; /* keep compiler happy */
1013    dummy2 = dummy2; /* keep compiler happy */
1014    assert( 0 ) ;
1015    return 1 ;  /* to keep compiler happy */
1016 }
1017 int hookup_input_output( tsd_t *TSD, int dummy1, const streng *dummy2, streng **dummy3 )
1018 {
1019    /* This should never happen, if we don't have support for SAA API,
1020     * Then we should never get a system exit!
1021     */
1022    TSD = TSD; /* keep compiler happy */
1023    dummy1 = dummy1; /* keep compiler happy */
1024    dummy2 = dummy2; /* keep compiler happy */
1025    dummy3 = dummy3; /* keep compiler happy */
1026    assert( 0 ) ;
1027    return 1 ;  /* to keep compiler happy */
1028 }
1029 int hookup_output( tsd_t *TSD, int dummy1, const streng *dummy2 )
1030 {
1031    /* This should never happen, if we don't have support for SAA API,
1032     * Then we should never get a system exit!
1033     */
1034    assert( 0 ) ;
1035    dummy1 = dummy1; /* keep compiler happy */
1036    dummy2 = dummy2; /* keep compiler happy */
1037    TSD = TSD; /* keep compiler happy */
1038    return 1 ;  /* to keep compiler happy */
1039 }
1040 int hookup_output2( tsd_t *TSD, int dummy1, const streng *dummy2, const streng *dummy3 )
1041 {
1042    /* This should never happen, if we don't have support for SAA API,
1043     * Then we should never get a system exit!
1044     */
1045    assert( 0 ) ;
1046    dummy1 = dummy1; /* keep compiler happy */
1047    dummy2 = dummy2; /* keep compiler happy */
1048    dummy3 = dummy3; /* keep compiler happy */
1049    TSD = TSD; /* keep compiler happy */
1050    return 1 ;  /* to keep compiler happy */
1051 }
1052
1053 static void Exit( const tsd_t *TSD )
1054 {
1055    /*
1056     * cheat about the const, we go away anyway :-)
1057     */
1058    jump_interpreter_exit( ( tsd_t * ) TSD, 1 );
1059 }
1060
1061 streng *call_unknown_external( tsd_t *TSD, const streng *dummy1, cparamboxptr dummy2, char dummy3 )
1062 {
1063    NoAPI();
1064    dummy1 = dummy1; /* keep compiler happy */
1065    dummy2 = dummy2; /* keep compiler happy */
1066    dummy3 = dummy3; /* keep compiler happy */
1067    Exit( TSD ) ;
1068    return NULL;
1069 }
1070
1071 streng *call_known_external( tsd_t *TSD, const struct entry_point *dummy1, cparamboxptr dummy2, char dummy3 )
1072 {
1073    NoAPI();
1074    dummy1 = dummy1; /* keep compiler happy */
1075    dummy2 = dummy2; /* keep compiler happy */
1076    dummy3 = dummy3; /* keep compiler happy */
1077    Exit( TSD ) ;
1078    return NULL;
1079 }
1080
1081
1082 streng *SubCom( tsd_t *TSD, const streng *dummy1, const streng *dummy2, int *dummy3 )
1083 {
1084    NoAPI();
1085    dummy1 = dummy1; /* keep compiler happy */
1086    dummy2 = dummy2; /* keep compiler happy */
1087    dummy3 = dummy3; /* keep compiler happy */
1088    Exit( TSD ) ;
1089    return NULL;
1090 }
1091
1092 int IfcHaveFunctionExit(const tsd_t *TSD)
1093 {
1094    TSD = TSD; /* keep compiler happy */
1095    return(0);
1096 }
1097
1098 #endif
1099
1100 static void usage( char *argv0 )
1101 {
1102    fprintf( stdout, "\nRegina %s. All rights reserved.\n", PARSE_VERSION_STRING );
1103    fprintf( stdout,"Regina is distributed under the terms of the GNU Library Public License \n" );
1104    fprintf( stdout,"and comes with NO WARRANTY. See the file COPYING-LIB for details.\n" );
1105    fprintf( stdout,"\nTo run a Rexx program:\n" );
1106    fprintf( stdout,"%s [-h?vrt[ir]ap] program [arguments...]\n", argv0 );
1107    fprintf( stdout,"where:\n\n" );
1108    fprintf( stdout,"-h,-?                  show this message\n" );
1109    fprintf( stdout,"-v                     display Regina version and exit\n" );
1110    fprintf( stdout,"-r                     run Regina in \"safe\" mode\n" );
1111    fprintf( stdout,"-t[trace_char]         set TRACE any valid TRACE character - default A\n" );
1112    fprintf( stdout,"-a                     pass command line to Rexx program as separate arguments\n");
1113    fprintf( stdout,"-p                     pause after execution (Win32 only)\n");
1114    fprintf( stdout,"-l[locale]             use the system's default charset or a supplied one\n");
1115    fprintf( stdout,"\nTo tokenise a Rexx program:\n" );
1116    fprintf( stdout,"%s -c program(input) tokenisedfile(output)\n", argv0 );
1117    fprintf( stdout,"\nTo execute a tokenised file:\n" );
1118    fprintf( stdout,"%s -e tokenisedfile [arguments...]\n", argv0 );
1119    fprintf( stdout,"\nIf you intend using external functions (using RxFuncAdd) you need to run the \"regina\" executable\n" );
1120    fflush( stdout );
1121 }