regina/macros.c

   1 #ifndef lint
   2 static char *RCSid = "$Id$";
   3 #endif
   4
   5 /*
   6  *  The Regina Rexx Interpreter
   7  *  Copyright (C) 1993-1994  Anders Christensen <anders@pvv.unit.no>
   8  *
   9  *  This library is free software; you can redistribute it and/or
  10  *  modify it under the terms of the GNU Library General Public
  11  *  License as published by the Free Software Foundation; either
  12  *  version 2 of the License, or (at your option) any later version.
  13  *
  14  *  This library is distributed in the hope that it will be useful,
  15  *  but WITHOUT ANY WARRANTY; without even the implied warranty of
  16  *  MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
  17  *  Library General Public License for more details.
  18  *
  19  *  You should have received a copy of the GNU Library General Public
  20  *  License along with this library; if not, write to the Free
  21  *  Software Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA.
  22  */
  23
  24 #include "rexx.h"
  25 #include "rxiface.h"
  26
  27 #include <stdio.h>
  28 #include <ctype.h>
  29 #include <setjmp.h>
  30 #include <string.h>
  31 #include <assert.h>
  32
  33
  34 void killsystem( tsd_t *TSD, sysinfo systm )
  35 {
  36    if ( systm->environment )
  37    {
  38       Free_stringTSD( systm->environment ) ;
  39       systm->environment = NULL;
  40    }
  41
  42    if ( systm->called_as )
  43    {
  44       Free_stringTSD( systm->called_as ) ;
  45       systm->called_as = NULL;
  46    }
  47
  48    if (systm->input_file )
  49    {
  50       Free_stringTSD( systm->input_file ) ;
  51       systm->input_file = NULL;
  52    }
  53
  54    if (systm->input_fp )
  55    {
  56       fclose( systm->input_fp ) ;
  57       systm->input_fp = NULL;
  58    }
  59
  60    DestroyInternalParsingTree( TSD, &systm->tree ) ;
  61
  62    if (systm->currlevel0)
  63      {
  64       removelevel( TSD, systm->currlevel0 ) ;
  65       systm->currlevel0 = NULL;
  66      }
  67
  68    if (systm->panic)
  69    {
  70       FreeTSD( systm->panic ) ;
  71       systm->panic = NULL;
  72    }
  73
  74    if ( systm->result)
  75    {
  76       Free_stringTSD( systm->result ) ;
  77       systm->result = NULL;
  78    }
  79
  80    if (systm->callstack)
  81    {
  82       FreeTSD( systm->callstack ) ;
  83       systm->callstack = NULL;
  84    }
  85
  86    FreeTSD( systm ) ;
  87 }
  88
  89 streng *do_instore( tsd_t *TSD, const streng *name, paramboxptr args,
  90                     const streng *envir, int *RetCode, int hooks,
  91                     const void *instore, unsigned long instore_length,
  92                     const char *instore_source,
  93                     unsigned long instore_source_length,
  94                     const internal_parser_type *ipt,
  95                     int ctype )
  96 {
  97    sysinfobox *newsystem=NULL, *tmpsys=NULL ;
  98    streng *ptr=NULL ;
  99    jmp_buf *jbuf=NULL ;
 100    unsigned InterpreterStatus[IPRT_BUFSIZE];
 101
 102    if (RetCode)
 103       *RetCode = 0 ;
 104
 105    SaveInterpreterStatus(TSD,InterpreterStatus);
 106    TSD->instore_is_errorfree = 0 ;
 107    jbuf = MallocTSD( sizeof(jmp_buf) ) ;
 108    assert(!TSD->in_protected);
 109    if (setjmp(*jbuf))
 110    {
 111       ptr = TSD->systeminfo->result ;
 112       TSD->systeminfo->result = NULL ;
 113       if (!TSD->instore_is_errorfree && RetCode)
 114          *RetCode = -1 ;
 115    }
 116    else
 117    {
 118       nodeptr savecurrentnode = TSD->currentnode; /* pgb */
 119
 120       TSD->currentnode = NULL ;
 121
 122       newsystem = creat_sysinfo( TSD, Str_dupTSD(envir)) ;
 123       newsystem->previous = TSD->systeminfo ;
 124       TSD->systeminfo->currlevel0 = TSD->currlevel ;
 125
 126       TSD->currlevel = NULL ;
 127       TSD->systeminfo = newsystem ;
 128       TSD->systeminfo->hooks = hooks ;
 129       TSD->systeminfo->panic = jbuf ;
 130       TSD->systeminfo->invoked = ctype ;
 131       TSD->systeminfo->called_as = Str_dupTSD( name ) ;
 132       TSD->systeminfo->input_file = Str_dupstrTSD( name ) ;
 133       TSD->systeminfo->currlevel0 = TSD->currlevel = newlevel( TSD, NULL ) ;
 134
 135       TSD->systeminfo->trace_override = newsystem->previous->trace_override;
 136
 137       TSD->currlevel->args = args ;
 138
 139       if (ipt)
 140          TSD->systeminfo->tree = *ipt;
 141       else if (IsValidTin(instore, instore_length))
 142          TSD->systeminfo->tree = ExpandTinnedTree(TSD, instore, instore_length,
 143                                                   instore_source,
 144                                                   instore_source_length);
 145       else
 146       {
 147          memset(&TSD->systeminfo->tree, 0, sizeof(TSD->systeminfo->tree));
 148       }
 149       if (TSD->systeminfo->hooks & HOOK_MASK(HOOK_INIT))
 150          hookup( TSD, HOOK_INIT ) ;
 151
 152       if (TSD->systeminfo->tree.root)
 153          ptr = interpret( TSD, TSD->systeminfo->tree.root ) ;
 154       else
 155          ptr = NULL ;
 156       TSD->currentnode = savecurrentnode; /* pgb */
 157
 158    }
 159    if (TSD->systeminfo->hooks & HOOK_MASK(HOOK_TERMIN))
 160       hookup( TSD, HOOK_TERMIN ) ;
 161
 162    tmpsys = TSD->systeminfo ;
 163    TSD->systeminfo = TSD->systeminfo->previous ;
 164    TSD->currlevel = TSD->systeminfo->currlevel0 ;
 165    TSD->trace_stat = TSD->currlevel->tracestat ;
 166
 167    tmpsys->currlevel0->args = NULL ;
 168    killsystem( TSD, tmpsys ) ;
 169
 170    RestoreInterpreterStatus(TSD,InterpreterStatus);
 171    /* Oops, we really ought to handle function-did-not-return-data */
 172    return (ptr) ? ptr : nullstringptr()  ;
 173 }
 174
 175 streng *execute_external( tsd_t *TSD, const streng *command, paramboxptr args,
 176                           const streng *envir, int *RetCode, int hooks, int ctype )
 177 {
 178    sysinfobox *newsystem=NULL, *tmpsys=NULL ;
 179    char name[1024] ;
 180    streng *ptr=NULL ;
 181    const char *cptr=NULL, *eptr=NULL, *start=NULL, *stop=NULL ;
 182    char path[1024] ;
 183    FILE *fptr=NULL ;
 184    jmp_buf *jbuf=NULL ;
 185    internal_parser_type parsing;
 186    volatile proclevel oldlevel; /* volatile needed at least for GCC 2.7.2 */
 187    unsigned InterpreterStatus[IPRT_BUFSIZE];
 188    nodeptr savecurrentnode = TSD->currentnode; /* pgb */
 189
 190    if (RetCode)
 191       *RetCode = 0 ;
 192
 193    SaveInterpreterStatus(TSD,InterpreterStatus);
 194    fptr = NULL ;
 195    jbuf = MallocTSD( sizeof(jmp_buf) ) ;
 196    TSD->instore_is_errorfree = 0 ;
 197
 198    assert(!TSD->in_protected);
 199    if (setjmp(*jbuf))
 200    {
 201 /*      if (fptr != stdin)
 202          fclose(fptr) ;
 203 */
 204       ptr = TSD->systeminfo->result ;
 205       TSD->systeminfo->result = NULL ;
 206       if (!TSD->instore_is_errorfree && RetCode)
 207          *RetCode = -1 ;
 208    }
 209    else
 210    {
 211       /* FGC: Check length first to avoid  */
 212       /*      access of invalid buffer     */
 213       if ( ( command->len == 7 )
 214       && ( memcmp("<stdin>",command->value,command->len) == 0 ) )
 215       {
 216          fptr = stdin;
 217          strcpy(name,command->value);
 218       }
 219       else
 220       {
 221          cptr = command->value ;
 222          eptr = cptr + command->len ;
 223
 224          for (start=cptr; start<eptr && isspace(*start); start++) ;
 225          for (stop=eptr-1;stop>start && isspace(*stop);  stop--) ;
 226
 227          memcpy( path, start, (stop-start)+1 ) ;
 228          *(path+(stop-start)+1) = 0x00 ;
 229          get_external_routine( TSD, "REGINA_MACROS", path, &fptr, name, 1 );
 230          if (!fptr)
 231          {
 232             get_external_routine( TSD, "PATH", path, &fptr, name, 1 );
 233             if (!fptr)
 234             {
 235                FreeTSD( jbuf ) ;
 236                if ( get_options_flag( TSD->currlevel, EXT_STRICT_ANSI ) )
 237                {
 238                   /*
 239                    * If we can't find the external routine, we should exiterror()
 240                    * with 43.1 - as per ANSI
 241                    */
 242                   exiterror( ERR_ROUTINE_NOT_FOUND, 1, path );
 243                }
 244                else
 245                {
 246                   /*
 247                    * The only time this function is called with a non-NULL
 248                    * RetCode is from client.c, when an external routine
 249                    * is being executed via the SAA interface. In this case
 250                    * the error returned is the only thing we should do;
 251                    * we certainly should NOT be writing anything to stdout
 252                    * or stderr!
 253                    */
 254                   if (RetCode)
 255                   {
 256                      *RetCode = -ERR_PROG_UNREADABLE;
 257                   }
 258 #if 0
 259                   if (RetCode)
 260                   {
 261                      *RetCode = -ERR_PROG_UNREADABLE;
 262                      if ( get_options_flag( TSD->currlevel, EXT_STDOUT_FOR_STDERR ) )
 263                      {
 264                         fprintf(stdout,"REXX: Error %d: %s: \"%s\"\n",
 265                              ERR_ROUTINE_NOT_FOUND,
 266                              errortext( TSD, ERR_ROUTINE_NOT_FOUND, 0, 0, &is_fmt ), path );
 267                         /* JH 19991105 the variable name was not set by
 268                            get_external_routine() when file is not found. */
 269                         fflush( stdout );
 270                      }
 271                      else
 272                         fprintf(stderr,"REXX: Error %d: %s: \"%s\"\n",
 273                              ERR_ROUTINE_NOT_FOUND,
 274                              errortext( TSD, ERR_ROUTINE_NOT_FOUND, 0, 0, &is_fmt ), path );
 275                      /* JH 19991105 the variable name was not set by
 276                         get_external_routine() when file is not found. */
 277                   }
 278 #endif
 279                   return NULL ;
 280                }
 281             }
 282          }
 283       }
 284
 285       newsystem = creat_sysinfo( TSD, Str_dupTSD(envir)) ;
 286       newsystem->previous = TSD->systeminfo ;
 287       /* FGC: NOTE: I found that currlevel has changed outside between calls
 288        *            to this function. I really don't know, if this should
 289        *            happen. A typical change of currlevel is done in interpret.
 290        *            Maybe, in interpret is an error caused by an illegal
 291        *            "postrecursed" re-interpret. Somebody with a higher view of
 292        *            the code as mine should check the code there.
 293        *            I detected the error in THE using regina while calling
 294        *            macros in macros called by THE in a macro.
 295        *            (confusing, hmm? :-(  )
 296        */
 297       oldlevel = TSD->currlevel;
 298
 299       TSD->currlevel = NULL ;
 300       TSD->systeminfo = newsystem ;
 301       TSD->systeminfo->hooks = hooks ;
 302       TSD->systeminfo->invoked = ctype ;
 303       TSD->systeminfo->panic = jbuf ;
 304       TSD->systeminfo->called_as = Str_dupTSD( command ) ;
 305       TSD->systeminfo->input_file = Str_crestrTSD( name ) ;
 306       TSD->systeminfo->currlevel0 = TSD->currlevel = newlevel( TSD, NULL ) ;
 307
 308       savecurrentnode = TSD->currentnode; /* pgb */
 309
 310       TSD->currlevel->args = args ;
 311       TSD->currentnode = NULL ;
 312
 313       fetch_file( TSD, fptr, &parsing );
 314       if (fptr != stdin)
 315          fclose(fptr) ;
 316       if (parsing.result == 0)
 317       {
 318          TSD->systeminfo->tree = parsing ;
 319          treadit( TSD->systeminfo->tree.root ) ;
 320          if (TSD->systeminfo->hooks & HOOK_MASK(HOOK_INIT))
 321             hookup( TSD, HOOK_INIT ) ;
 322
 323          ptr = interpret( TSD, TSD->systeminfo->tree.root ) ;
 324          TSD->currentnode = savecurrentnode; /* pgb */
 325       }
 326       else
 327       {
 328          TSD->currentnode = savecurrentnode; /* pgb */
 329          ptr = NULL ;
 330          exiterror( ERR_YACC_SYNTAX, 1, parsing.tline ) ;
 331       }
 332    }
 333    if (TSD->systeminfo->hooks & HOOK_MASK(HOOK_TERMIN))
 334       hookup( TSD, HOOK_TERMIN ) ;
 335
 336 /*
 337    if (must_pop)
 338       popcallstack( -1 ) ;
 339 */
 340    tmpsys = TSD->systeminfo ;
 341    TSD->systeminfo = TSD->systeminfo->previous ;
 342    TSD->currlevel = oldlevel;
 343    TSD->trace_stat = TSD->currlevel->tracestat ;
 344
 345    tmpsys->currlevel0->args = NULL ;
 346    killsystem( TSD, tmpsys ) ;
 347
 348    RestoreInterpreterStatus(TSD,InterpreterStatus);
 349    /* Oops, we really ought to handle function-did-not-return-data */
 350    return (ptr) ? ptr : nullstringptr()  ;
 351 }
 352
 353
 354 internal_parser_type enter_macro( tsd_t *TSD, const streng *source,
 355                                   streng *name, void **ept,
 356                                   unsigned long *extlength)
 357 {
 358    internal_parser_type parsing;
 359
 360    fetch_string( TSD, source, &parsing );
 361    if (parsing.result != 0)
 362    {
 363       exiterror( ERR_YACC_SYNTAX, 1, parsing.tline ) ;
 364       return(parsing);
 365    }
 366    if (ept && extlength)
 367       *ept = TinTree( TSD, &parsing, extlength ) ;
 368    name = name; /* keep compiler happy */
 369
 370    return( parsing );
 371 }
 372
 373 /*
 374  * Takes as input a pointer to a parameter structure, and counts the
 375  * number of parameters in it, and return that value. The counting
 376  * can be performed in two different manners, either soft or hard.
 377  * Soft means that "trailing" ommitted parameters are ignored, hard
 378  * means that all parameters are counted. (When counting hard, all
 379  * routines stared from Rexx has at least one parameter: the one that
 380  * was ommitted. However, when started from C by SAA API, functions
 381  * can be started with zero parameters.)
 382  */
 383 int count_params( cparamboxptr ptr, int soft )
 384 {
 385    int scnt=0, hcnt=0 ;
 386
 387    assert( PARAM_TYPE_SOFT && !PARAM_TYPE_HARD ) ;
 388
 389    for (hcnt=scnt=0; ptr; ptr=ptr->next, hcnt++)
 390       if (soft && ptr->value)
 391          scnt = hcnt ;
 392
 393    return ((soft) ? scnt : hcnt ) ;
 394
 395 }
 396
 397
 398 /*
 399  * Takes a pointer to an argument structure as input, together with an
 400  * integer. Returns the parameter numbered by the number, or NULL if
 401  * either that parameter is omitted or otherwise non-existing.
 402  */
 403 streng *get_parameter( paramboxptr ptr, int number )
 404 {
 405    assert( number>0 ) ;
 406    for (; ptr && (--number!=0); ptr=ptr->next) ;
 407
 408    return ((ptr && ptr->value) ? ptr->value : NULL ) ;
 409 }