regina/r2perl.c

   1
   2
   3 #ifdef R2PERL
   4
   5 #include "rexx.h"
   6 #include "stdio.h"
   7
   8 static void indent(tsd_t *TSD)
   9 {
  10    int i ;
  11
  12    for (i=0; i<TSD->indentsize; i++)
  13       putchar( ' ' ) ;
  14 }
  15
  16
  17 static void tabin(tsd_t *TSD)
  18 {
  19    TSD->indentsize += 3 ;
  20 }
  21
  22
  23 static void tabout(tsd_t *TSD)
  24 {
  25    TSD->indentsize -= 3 ;
  26 }
  27
  28
  29 void preamble()
  30 {
  31    printf( "require \"r2perl.pl\" ;\n\n" ) ;
  32 }
  33
  34
  35 static void output( const char *cptr )
  36 {
  37     printf( "%s", cptr ) ;
  38 }
  39
  40
  41 static void outint( int num )
  42 {
  43     printf( "%d", num ) ;
  44 }
  45
  46
  47 static void outstr( const streng *str )
  48 {
  49    int i ;
  50
  51    for (i=0; i<str->len; i++)
  52       putchar( str->value[i] ) ;
  53 }
  54
  55 static void expression( nodeptr this )
  56 {
  57    nodeptr tptr ;
  58
  59    if (!this)
  60    {
  61       return ;
  62    }
  63
  64    switch (this->type)
  65    {
  66       case X_NULL:
  67          output( "\"\"" ) ;
  68          return ;
  69
  70       case X_GT:
  71       case X_LT:
  72       case X_EQUAL:
  73          output( "(" ) ;
  74          expression( this->p[0] ) ;
  75          switch (this->type)
  76          {
  77             case X_EQUAL: output( "==" ) ; break ;
  78             case X_GT: output( "==" ) ; break ;
  79             case X_LT: output( "==" ) ; break ;
  80          }
  81          expression( this->p[1] ) ;
  82          output( ")" ) ;
  83          break ;
  84
  85       case X_MODULUS:
  86       case X_DEVIDE:
  87       case X_MINUS:
  88       case X_PLUSS:
  89       case X_MULT:
  90          output( "(" ) ;
  91          expression( this->p[0] ) ;
  92
  93          switch (this->type)
  94          {
  95             case X_MODULUS: output( "%" ) ; break ;
  96             case X_DEVIDE: output( "/" ) ; break ;
  97             case X_MULT:  output( "*" ) ; break ;
  98             case X_MINUS: output( "-" ) ; break ;
  99             case X_PLUSS: output( "+" ) ; break ;
 100          }
 101          expression( this->p[1] ) ;
 102          output( ")" ) ;
 103          break ;
 104
 105       case X_IN_FUNC:
 106          output( "&" ) ;
 107          outstr( this->name ) ;
 108          output( "(" ) ;
 109          for (tptr=this->p[0]; tptr; tptr=tptr->p[1])
 110          {
 111             output( "(" ) ;
 112             expression( tptr->p[0] ) ;
 113             output( ")" ) ;
 114             if (tptr->p[1])
 115                output( "," ) ;
 116          }
 117          output( ")" ) ;
 118          break ;
 119
 120       case X_STRING:
 121       case X_CON_SYMBOL:
 122          output( "\"" ) ;
 123          outstr( this->name ) ;
 124          output( "\"" ) ;
 125          break ;
 126
 127       case X_SIM_SYMBOL:
 128          output( "$" ) ;
 129          outstr( this->name ) ;
 130          break ;
 131
 132       case X_CONCAT:
 133       case X_SPACE:
 134          expression( this->p[0] ) ;
 135          if (this->type == X_SPACE)
 136             output( ",\" \"," ) ;
 137          else
 138             output( "," ) ;
 139          expression( this->p[1] ) ;
 140          break ;
 141
 142       default:
 143          abort() ;
 144
 145    }
 146
 147    return ;
 148 }
 149
 150
 151
 152 void translate( tsd_t *TSD, nodeptr this )
 153 {
 154    int i ;
 155
 156 start_again:
 157
 158    if (!this)
 159       return ;
 160
 161    switch ( this->type )
 162    {
 163       case X_PROGRAM:
 164       case X_WHENS:
 165       case X_STATS:
 166       case X_OTHERWISE:
 167          translate( TSD, this->p[0] ) ;
 168          this = this->p[1] ;
 169          goto start_again ;
 170
 171
 172       case X_DO:
 173          indent(TSD) ;
 174          if ((!this->p[0]) && (!this->p[1]))
 175          {
 176             output( "{\n" ) ;
 177             tabin(TSD) ;
 178          }
 179          else if (this->p[0] && !this->p[0]->name)
 180          {
 181             output( "for ($loopcnt_" ) ;
 182             outint( TSD->loopcnt ) ;
 183             output( "=0; $loopcnt_" ) ;
 184             outint( TSD->loopcnt ) ;
 185             output( "<" ) ;
 186             expression( this->p[0]->p[1]->p[0] ) ;
 187             output( "; $loopcnt_" ) ;
 188             outint( TSD->loopcnt++ ) ;
 189             output( "++)\n" ) ;
 190             indent(TSD) ;
 191             output( "{\n" ) ;
 192             tabin(TSD) ;
 193          }
 194          else
 195          {
 196             output( "for ($" ) ;
 197             outstr( this->p[0]->name ) ;
 198             output( "=" ) ;
 199             expression( this->p[0]->p[0] ) ;
 200             output( "; " ) ;
 201
 202             for (i=1; i<4; i++)
 203             {
 204                if (this->p[0]->p[i] && this->p[0]->p[i]->type == X_DO_TO)
 205                {
 206                   output( "$" ) ;
 207                   outstr( this->p[0]->name ) ;
 208                   output( "<=" ) ;
 209                   expression( this->p[0]->p[i]->p[0] ) ;
 210                   break ;
 211                }
 212             }
 213             output( "; " ) ;
 214
 215             for (i=1; i<4; i++)
 216             {
 217                if (this->p[0]->p[i] && this->p[0]->p[i]->type == X_DO_BY)
 218                {
 219                   output( "$" ) ;
 220                   outstr( this->p[0]->name ) ;
 221                   output( "+=" ) ;
 222                   expression( this->p[0]->p[i]->p[0] ) ;
 223                   break ;
 224                }
 225             }
 226             output( ")\n" ) ;
 227             indent(TSD) ;
 228             output( "{\n" ) ;
 229             tabin(TSD) ;
 230          }
 231
 232          if (this->p[1] && this->p[1]->type == X_WHILE)
 233          {
 234             indent(TSD) ;
 235             output( "if (" ) ;
 236             expression( this->p[1]->p[0] ) ;
 237             output( ") break ;\n" ) ;
 238          }
 239
 240          translate( TSD, this->p[2] ) ;
 241
 242          if (this->p[1] && this->p[1]->type == X_UNTIL)
 243          {
 244             indent(TSD) ;
 245             output( "if (" ) ;
 246             expression( this->p[1]->p[0] ) ;
 247             output( ") break ;\n" ) ;
 248          }
 249
 250          tabout(TSD) ;
 251          indent(TSD) ;
 252          output( "}\n" ) ;
 253          break ;
 254
 255
 256        case X_IF:
 257          indent(TSD) ;
 258          output( "if (" ) ;
 259          expression( this->p[0] ) ;
 260          output( ")\n" ) ;
 261          indent(TSD) ;
 262          output( "{\n" ) ;
 263          tabin(TSD) ;
 264          translate( TSD, this->p[1] ) ;
 265          tabout(TSD) ;
 266          indent(TSD) ;
 267          output( "}\n" ) ;
 268          if ( this->p[2] )
 269          {
 270              indent(TSD) ;
 271              output( "else\n" ) ;
 272              indent(TSD) ;
 273              output( "{\n" ) ;
 274              tabin(TSD) ;
 275              translate( TSD, this->p[2] ) ;
 276              tabout(TSD) ;
 277              indent(TSD) ;
 278              output( "}\n" ) ;
 279          }
 280          break ;
 281
 282       case X_ASSIGN:
 283       {
 284          indent(TSD) ;
 285          output( "$" ) ;
 286          outstr( this->name ) ;
 287          output( " = " ) ;
 288          expression( this->p[0] ) ;
 289          output( " ;\n" ) ;
 290          break ;
 291       }
 292
 293 /*
 294       case X_IPRET:
 295       {
 296          output( "eval( " ) ;
 297          output( expression( this->p[0] ) ) ;
 298          output( " )\n" ) ;
 299          break ;
 300       }
 301
 302       case X_NO_OTHERWISE:
 303       {
 304          output( "else { die( "WHEN or OTHERWISE expected" ) ; }" ) ;
 305          break ;
 306       }
 307
 308       case X_SELECT:
 309       {
 310          first_when = 1 ;
 311       }
 312          nstack[nstackptr++] = this->next ;
 313          nstack[nstackptr++] = this->p[1] ;
 314          this = this->p[0] ;
 315          goto fakerecurse ;
 316
 317       case X_WHEN:
 318       {
 319          streng *tptr ;
 320
 321          if (str_true(TSD,tptr=evaluate(TSD,this->p[0])))
 322          {
 323             Free_stringTSD( tptr ) ;
 324             nstackptr-- ; / * kill the OTHERWISE on the stack * /
 325             this = this->p[1] ;
 326             goto fakerecurse ;
 327          }
 328          Free_stringTSD( tptr ) ;
 329          break ;
 330       }
 331 */
 332
 333       case X_SAY:
 334       {
 335          indent(TSD) ;
 336          output( "print " ) ;
 337          if (this->p[0])
 338          {
 339             expression( this->p[0] ) ;
 340             output( "," ) ;
 341          }
 342          output( "\"\\n\" ;\n" ) ;
 343          break ;
 344       }
 345
 346       case X_TRACE:
 347       {
 348          break ;
 349       }
 350
 351       case X_EXIT:
 352       {
 353          indent(TSD) ;
 354          output( "exit(" ) ;
 355          expression( this->p[0] ) ;
 356          output( " ) ;\n" ) ;
 357          break ;
 358       }
 359
 360       case X_COMMAND:
 361       {
 362          indent(TSD) ;
 363          output( "system(" ) ;
 364          expression( this->p[0] ) ;
 365          output( " ) ;\n" ) ;
 366       }
 367 /*
 368       case X_ADDR_N:   / * ADDRESS environment [expr] * /
 369       {
 370          streng *envir, *tmp, *rc ;
 371          int rc ;
 372
 373          envir = this->name ;
 374          if (this->p[0])
 375          {
 376             tmp = evaluate(TSD, this->p[0]);
 377             rc = perform(tmp, envir, this->lineno);
 378             Free_stringTSD( tmp ) ;
 379             setvalue( TSD, &RC_name, rc ) ;
 380          }
 381          else
 382          {
 383             Free_stringTSD( TSD->currlevel->prev_env ) ;
 384             TSD->currlevel->prev_env = TSD->currlevel->environment ;
 385             TSD->currlevel->environment = Str_dupTSD(envir) ;
 386          }
 387          break ;
 388       }
 389
 390
 391       case X_ADDR_V:   / * ADDRESS [VALUE] expr * /
 392       {
 393          streng *cptr ;
 394
 395          cptr = evaluate(TSD, this->p[0]) ;
 396          Free_stringTSD( TSD->currlevel->prev_env ) ;
 397          TSD->currlevel->prev_env = TSD->currlevel->environment ;
 398          TSD->currlevel->environment = cptr ;
 399          break ;
 400       }
 401
 402
 403       case X_ADDR_S:   / * ADDRESS * /
 404       {
 405          streng *tptr ;
 406
 407          tptr = TSD->currlevel->environment ;
 408          TSD->currlevel->environment = TSD->currlevel->prev_env ;
 409          TSD->currlevel->prev_env = tptr ;
 410          break ;
 411       }
 412
 413
 414       case X_DROP:
 415       {
 416          nodeptr nptr ;
 417          for (nptr=this->p[0]; nptr; nptr=nptr->p[0] )
 418             if (nptr->name)
 419                if (nptr->type == X_SIM_SYMBOL)
 420                   drop_var( TSD, nptr->name ) ;
 421                else if (nptr->type == X_IND_SYMBOL)
 422                {
 423                   int begin,end;
 424                   streng *name,*value = shortcut(TSD,nptr) ;
 425
 426                   /* Chop space separated words and drop them one by one */
 427                   for (end = 0;;)
 428                   {
 429                      begin = end; /* end of last word processed + 1 */
 430                      while ((begin < Str_len(value)) &&
 431                             isspace(value->value[begin]))
 432                         begin++;
 433                      if (begin == Str_len(value))
 434                         break;
 435                      end = begin + 1; /* find next separator */
 436                      while ((end < Str_len(value)) &&
 437                             !isspace(value->value[end]))
 438                         end++;
 439                      /* end now on space after word or past end of string */
 440
 441                      name = Str_makeTSD(end - begin);
 442                      name->len = end - begin;
 443                      memcpy(name->value, value->value + begin, Str_len(name));
 444
 445                      Str_upper(name);
 446
 447                      drop_var( TSD, name ) ;
 448                      Free_stringTSD( name ) ;
 449                   }
 450                }
 451          break ;
 452       }
 453
 454       case X_SIG_SET:
 455       case X_CALL_SET:
 456       {
 457          int type ;
 458          trap *traps = gettraps( TSD, TSD->currlevel ) ;
 459
 460          / * which kind of condition is this? * /
 461          type = identify_trap( this->p[1]->type ) ;
 462
 463          / * We always set this * /
 464          traps[type].invoked = (this->type == X_SIG_SET) ;
 465          traps[type].delayed = 0 ;
 466          traps[type].on_off = (this->p[0]->type == X_ON ) ;
 467
 468          / * set the name of the variable to work on * /
 469          FREE_IF_DEFINED( traps[type].name ) ;
 470          if (this->name)
 471             traps[type].name = Str_dupTSD( this->name ) ;
 472          else if (this->p[0]->type == X_ON)
 473             traps[type].name = Str_creTSD( signalnames[type] ) ;
 474
 475          break ;
 476       }
 477
 478       case X_SIG_VAL:
 479       case X_SIG_LAB:
 480       {
 481          streng *cptr ;
 482
 483          cptr = (this->name) ? Str_dupTSD(this->name) : evaluate( TSD, this->p[0] ) ;
 484          nstackptr = 0 ;
 485          for (;stackptr>0;stackptr--)
 486          {
 487             if (stack[stackptr-1].increment)
 488             {
 489                free_a_descr(TSD,stack[stackptr-1].increment) ;
 490                stack[stackptr-1].increment = NULL ;
 491             }
 492
 493             if (stack[stackptr-1].stopval)
 494             {
 495                free_a_descr(TSD, stack[stackptr-1].stopval) ;
 496                stack[stackptr-1].stopval = NULL ;
 497             }
 498          }
 499
 500          setvalue( TSD, var_sigl, int_to_streng( TSD, this->lineno )) ;
 501          entry = getlabel( TSD, cptr ) ;
 502
 503          if (!this->name)
 504             Free_stringTSD( cptr ) ;
 505
 506          if ((entry)==NULL) exiterror(16) ;
 507          this = entry->next ;
 508          goto fakerecurse ;
 509          break ;
 510       }
 511       case X_PROC:
 512          if (TSD->currlevel->varflag)
 513             exiterror( ERR_UNEXPECTED_PROC, 0 )  ;
 514
 515          for (ptr=this->p[0];(ptr);ptr=ptr->p[0])
 516          if (ptr->name)
 517             expose_var(TSD,ptr->name) ;
 518          else
 519             exiterror( ERR_INTERPRETER_FAILURE, 0 )  ;
 520
 521          expose_var(TSD,NULL) ;
 522          break ;
 523
 524       case X_CALL:
 525       {
 526          this->u.node = getlabel(TSD,this->name) ;
 527          this->type = (this->u.node) ? X_IS_INTERNAL : X_IS_BUILTIN ;
 528       }
 529
 530       case X_IS_INTERNAL:
 531       {
 532          paramboxptr targs ;
 533
 534          if ( this->u.node )
 535          {
 536             setvalue( TSD, var_sigl, int_to_streng( TSD, this->lineno )) ;
 537
 538             no_next_interactive = 1 ;
 539             targs = initplist( TSD, this ) ;
 540             oldlevel = TSD->currlevel ;
 541             TSD->currlevel = newlevel( TSD, TSD->currlevel ) ;
 542             TSD->currlevel->args = targs ;
 543             stackmark = pushcallstack( this ) ;
 544
 545             result = interpret( TSD, this->u.node ) ;
 546
 547             popcallstack( stackmark ) ;
 548             removelevel( TSD, TSD->currlevel ) ;
 549             TSD->currlevel = oldlevel ;
 550             TSD->currlevel->next = NULL ;
 551
 552             if (result)
 553                setvalue( TSD, RESULT_name, result ) ;
 554             else
 555                drop_var( TSD, RESULT_name ) ;
 556
 557             break ;
 558         }
 559      }
 560
 561      case X_IS_BUILTIN:
 562      {
 563         if (!(result = buildtinfunc( TSD, this )))
 564             exiterror( ERR_ROUTINE_NOT_FOUND, 0 )  ;
 565
 566         if (result)
 567            setvalue( TSD, RESULT_name, result ) ;
 568         else
 569            drop_var( TSD, RESULT_name ) ;
 570
 571         break ;
 572       }
 573
 574       case X_PARSE_ARG:
 575       case X_PARSE_ARG_U:
 576         args = TSD->currlevel->args->next ;
 577         (void)parseargtree( TSD, this, args, this->type!=X_PARSE_ARG ) ;
 578         break ;
 579
 580       case X_PARSE_U:
 581       case X_PARSE:
 582          source = NULL ;
 583          switch (this->p[0]->type) {
 584              case X_PARSE_VAR:
 585                 source = Str_dupTSD(shortcut( TSD, this->p[0] )) ;
 586 / *              source = Str_dupTSD(getvalue( TSD, this->p[0]->name, 1 )) ; * /
 587                 break ;
 588
 589              case X_PARSE_VAL:
 590                 source = evaluate(TSD, this->p[0]->p[0]);
 591                 break ;
 592
 593              case X_PARSE_PULL:
 594                 source = popline( TSD ) ;
 595                 break ;
 596
 597              case X_PARSE_VER:
 598                 source = Str_creTSD(PARSE_VERSION_STRING) ;
 599                 break ;
 600
 601              case X_PARSE_EXT:
 602                 source = readkbdline( TSD ) ;
 603                 break ;
 604
 605              case X_PARSE_SRC:
 606                 origfile = TSD->systeminfo->called_as ;
 607                 inpfile = TSD->systeminfo->input_file ;
 608                 source = Str_makeTSD(15+Str_len(origfile)+Str_len(inpfile)) ;
 609                 source->len = 0 ;
 610                 Str_catstrTSD(source,"UNIX COMMAND ") ;
 611                 Str_catTSD(source,inpfile) ;
 612                 Str_catstrTSD(source," ") ;
 613                 Str_catTSD(source,origfile) ;
 614                 break ;
 615              }
 616
 617         if (this->type==X_PARSE_U)
 618            (void)upcase(source) ;
 619
 620         doparse( TSD, source, this->p[1] ) ;
 621         Free_stringTSD( source ) ;
 622         break ;
 623 */
 624
 625       case X_PUSH:
 626         indent(TSD) ;
 627         output( "push( @rx_array, " ) ;
 628         expression( this->p[0] ) ;
 629         output( ") ;\n" ) ;
 630         break ;
 631
 632       case X_PULL:
 633         indent(TSD) ;
 634         output( "pop( @rx_array, " ) ;
 635         expression( this->p[0] ) ;
 636         output( ") ;\n" ) ;
 637         break ;
 638
 639       case X_QUEUE:
 640         indent(TSD) ;
 641         output( "unshift( @rx_array, " ) ;
 642         expression( this->p[0] ) ;
 643         output( ") ;\n" ) ;
 644         break ;
 645
 646       case X_RETURN:
 647       {
 648          indent(TSD) ;
 649          output( "return( " ) ;
 650          if (this->p[0])
 651             expression( this->p[0] ) ;
 652          else
 653             output( "\"\"" ) ;
 654          output( " ) ;\n" ) ;
 655          break ;
 656       }
 657
 658       case X_LEAVE:
 659       {
 660          if (this->name)
 661             output( "warn( \"symbolname ignored in LEAVE\n\") ;\n" ) ;
 662
 663          indent(TSD) ;
 664          output( "break ;\n" ) ;
 665          break ;
 666       }
 667
 668       case X_ITERATE:
 669       {
 670          if (this->name)
 671             output( "warn( \"symbolname ignored in ITERATE\n\") ;\n" ) ;
 672
 673          indent(TSD) ;
 674          output( "continue ;\n" ) ;
 675          break ;
 676       }
 677 /*
 678       case X_NUM_D:
 679       {
 680          streng *cptr = evaluate( TSD, this->p[0] ) ;
 681          TSD->currlevel->currnumsize = atopos( TSD, cptr ) ;
 682          Free_stringTSD( cptr ) ;
 683          break ;
 684       }
 685
 686       case X_NUM_FUZZ:
 687       {
 688          streng *cptr = evaluate( TSD, this->p[0] ) ;
 689          TSD->currlevel->numfuzz = atozpos( TSD, cptr ) ;
 690          Free_stringTSD( cptr ) ;
 691          break ;
 692       }
 693
 694       case X_NUM_F:
 695       {
 696          if (this->p[0]->type == X_NUM_SCI)
 697             TSD->currlevel->numform = NUM_FORM_SCI ;
 698          else if (this->p[0]->type == X_NUM_ENG)
 699             TSD->currlevel->numform = NUM_FORM_ENG ;
 700          else
 701              exiterror( ERR_INTERPRETER_FAILURE, 0 )  ;
 702          break ;
 703       }
 704
 705
 706       case X_LABEL:
 707       case X_NULL:
 708          break ;
 709 */
 710    }
 711
 712 }
 713
 714
 715
 716 #endif /* R2PERL */