regina/arxfuncs.c

   1 /*
   2  *  ARexx functions for regina
   3  *  Copyright © 2002, Staf Verhaegen
   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 /* This files contains functions that are implemented in ARexx
  21  * but that are not standard REXX functions. This file contains
  22  * the functions that can be used on all platforms. amifuncs.c
  23  * contains the ARexx functions that are only usable on the
  24  * amiga platform or compatibles. (not implemented yet)
  25  */
  26 #ifndef _GNU_SOURCE
  27 # define _GNU_SOURCE
  28 #endif
  29 #include "rexx.h"
  30 #include <stdio.h>
  31 #include <stdlib.h>
  32 #include <limits.h>
  33 #if !defined(__WINS__) && !defined(__EPOC32__)
  34 # include <float.h>
  35 #else
  36 # define DBL_EPSILON 2.2204460492503131e-016
  37 #endif
  38 #include <assert.h>
  39 #ifdef HAVE_UNISTD_H
  40 # include <unistd.h>
  41 #endif
  42
  43 staticstreng(_fname, "F");
  44 staticstreng(_fstem, "FI.F");
  45
  46 #if defined(_AMIGA) || defined(__AROS__)
  47 # include <exec/memory.h>
  48 # include <proto/exec.h>
  49 #endif
  50
  51 typedef struct _arexx_tsd_t {
  52   proclevel amilevel;
  53 #ifdef rx_64u
  54   rx_64u a,Xn,c;
  55 #else
  56   unsigned long ah,al,Xnh,Xnl,c;
  57 #endif
  58 } arexx_tsd_t;
  59
  60 #if !defined( HAVE_DIV )
  61 typedef struct _div_t
  62 {
  63    int quot;
  64    int rem;
  65 } div_t;
  66
  67 typedef struct _ldiv_t
  68 {
  69    long quot;
  70    long rem;
  71 } ldiv_t;
  72
  73 div_t div(int x,int y)
  74 {
  75   div_t result;
  76   result.quot = x / y;
  77   result.rem = x % y;
  78   return result;
  79 }
  80
  81 ldiv_t ldiv(long x,long y)
  82 {
  83   ldiv_t result;
  84   result.quot = x / y;
  85   result.rem = x % y;
  86   return result;
  87 }
  88 #endif
  89
  90 /*
  91  * Init thread data for arexx functions.
  92  */
  93 int init_arexxf( tsd_t *TSD )
  94 {
  95    arexx_tsd_t *at;
  96
  97    if ( TSD->arx_tsd != NULL )
  98       return 1;
  99
 100    if ( ( TSD->arx_tsd = MallocTSD( sizeof( arexx_tsd_t ) ) ) == NULL )
 101       return 0;
 102    at = (arexx_tsd_t *)TSD->arx_tsd;
 103    memset( at, 0, sizeof( arexx_tsd_t ) );
 104
 105 /* glibc's starting value is 0 for the whole Xn, we use a seed of 0x1234ABCD */
 106 #ifdef rx_64u
 107    at->a  = rx_mk64u( 0x0005DEECE66D );
 108    at->Xn = rx_mk64u( 0x1234ABCD330E );
 109    at->c  = 0xB;
 110 #else
 111    at->ah  = 0x5;
 112    at->al  = 0xDEECE66Dul;
 113    at->Xnh = 0x1234;
 114    at->Xnl = 0xABCD330Eul;
 115    at->c   = 0xB;
 116 #endif
 117    return 1;
 118 }
 119
 120 /*
 121  * The implementation of srand48 and drand48 with fixed values in a thread safe
 122  * manner.
 123  *
 124  * We have to produce a value in the interval [0,1[  (zero until one but
 125  * without one) from a 48 bit unsigned integer. This is done by a division by
 126  * the maximum value corrected by small double. This small double is computed
 127  * from the constant DBL_EPSILON.
 128  *
 129  *                           / a) 1+e > 1 and e > 0
 130  * DBL_EPSILON = e with both
 131  *                           \ b) there is no number e', e' < e
 132  *
 133  * We increase the divisor of 2**48-1 by (2**48-1)*DBL_EPSILON and have
 134  * the wanted final divisor. That is with 2**48 - 1 = 281474976710655
 135  */
 136 #define twoE48m1 281474976710655.0
 137 #define divisor ( twoE48m1 * ( 1.0 + DBL_EPSILON ) )
 138
 139 #ifdef rx_64u
 140 /*
 141  * srand48 sets the upper 32 bit of Xn. The lower 16 bit are set to 330E.
 142  */
 143 static void rx_srand48( const tsd_t *TSD, unsigned long ul )
 144 {
 145    arexx_tsd_t *at = (arexx_tsd_t *)TSD->arx_tsd;
 146    rx_64u ull;
 147
 148    ull = ul & 0xFFFFFFFF;
 149    ull <<= 16;
 150    at->Xn = ull | 0x330E;
 151 }
 152
 153 /*
 154  * Compute X(n+1) = a * X(n) + c
 155  */
 156 static double rng( arexx_tsd_t *at )
 157 {
 158    rx_64u Xn1;
 159
 160    Xn1 = at->a * at->Xn + at->c;
 161    at->Xn = Xn1 & rx_mk64u( 0xFFFFFFFFFFFF );
 162
 163 # ifdef _MSC_VER
 164    return (double) (signed __int64) at->Xn;
 165 # else
 166    return (double) at->Xn;
 167 # endif
 168 }
 169 #else
 170 static void rx_srand48( const tsd_t *TSD, unsigned long ul )
 171 {
 172    arexx_tsd_t *at = TSD->arx_tsd;
 173
 174    at->Xnh = ( ul >> 16 ) & 0xFFFF;
 175    at->Xnl = ( ( ul & 0xFFFF ) << 16 ) | 0x330E;
 176 }
 177
 178 static double rng( arexx_tsd_t *at )
 179 {
 180    double retval;
 181    unsigned long Xn1h,Xn1l;
 182    unsigned long h,al,ah,bl,bh;
 183    /*
 184     * Doing 64 bit multiplication and addition by hand.
 185     *
 186     * be H = 2*32.
 187     * be A = ah*H + al, with ah<H and al<H
 188     * be B = bh*H + bl, with bh<H and bl<H
 189     *
 190     * then we can compute A*B as:
 191     *
 192     * (ah*H+al)*(bh*H+bl) = ah*bh*H*H +
 193     *                       ah*bl*H +
 194     *                       bh*al*H +
 195     *                       al*bl
 196     *
 197     * We have to add an additional term c, c small and we operate modulo
 198     * 2**48-1. This keeps life simple because we may throw away the
 199     * term ah*bh*H*H because the number is greater as 2**48 without rest.
 200     *
 201     * Furthermore we don't have to bother about carries in the multiplication
 202     * and addition of ah*bl*H and al*bh*H. Finally the term c is so small that
 203     * al*bl+c won't have any further carrying operation.
 204     *
 205     * Indeed, because we want the lower 16 bit part of ah*bl+bh*al, we can
 206     * compute as usual, add the carry of al*bl+c and that's it.
 207     *
 208     * There is just one lack:
 209     * We need everything of al*bl. So we have to compute as above but with
 210     * 16 bit unsigneds to let the product be littler than 2**32.
 211     *
 212     * Perfrom this 16 bit operations first.
 213     */
 214
 215    al = at->al & 0xFFFF;
 216    ah = at->al >> 16;
 217    bl = at->Xnl & 0xFFFF;
 218    bh = at->Xnl >> 16;
 219
 220    h = al * bl + at->c;
 221    Xn1l = h & 0xFFFF; /* done lower 16 bit */
 222
 223    /*
 224     * Process the *H, H=16 part. Every overflow in addition will be in the
 225     * 48 bit counted from 0, so the final modulo will cut it. Therefore
 226     * we are allowed to ignore every overflow.
 227     */
 228    h >>= 16;
 229    h += al * bh + ah * bl;
 230    Xn1l |= (h << 16) & 0xFFFF0000; /* done middle 16 bit */
 231
 232    Xn1h = h >> 16;
 233    Xn1h += ah * bh;
 234
 235    /*
 236     * Now do the ah*bl*H + bh*al+H for the outer 32 bit operation.
 237     */
 238    Xn1h += at->ah * at->Xnl + at->al * at->Xnh;
 239    at->Xnh = Xn1h & 0xFFFF;
 240    at->Xnl = Xn1l;
 241
 242    retval = at->Xnh;
 243    retval *= 4294967296.0l;
 244    retval += at->Xnl;
 245
 246    return retval;
 247 }
 248 #endif
 249
 250 /*
 251  * Map a random value computed by rng of the range [0,2**48[ to the
 252  * range [0,1[
 253  */
 254 static double rx_drand48( const tsd_t *TSD )
 255 {
 256    arexx_tsd_t *at = (arexx_tsd_t *)TSD->arx_tsd;
 257    double big;
 258
 259    big = (double) rng( at );
 260
 261    return (double) big / divisor;
 262 }
 263
 264 /*
 265  * Support functions for the ARexx IO functions
 266  */
 267 /* setamilevel will change the environment to the variables used for open files */
 268 static proclevel setamilevel( tsd_t *TSD )
 269 {
 270   arexx_tsd_t *atsd = (arexx_tsd_t *)TSD->arx_tsd;
 271   proclevel oldlevel = TSD->currlevel;
 272
 273   if (atsd->amilevel!=NULL)
 274     TSD->currlevel = atsd->amilevel;
 275   else
 276   {
 277     char txt[20];
 278
 279     atsd->amilevel = newlevel( TSD, NULL );
 280
 281     TSD->currlevel = atsd->amilevel;
 282
 283     setvalue( TSD, _fname, Str_cre_TSD( TSD, "STDIN" ), -1 );
 284     sprintf( txt, "%p", stdin );
 285     setvalue( TSD, _fstem, Str_cre_TSD( TSD, txt ), -1 );
 286
 287     setvalue( TSD, _fname, Str_cre_TSD( TSD, "STDOUT" ), -1 );
 288     sprintf( txt, "%p", stdout );
 289     setvalue( TSD, _fstem, Str_cre_TSD( TSD, txt ), -1 );
 290
 291     setvalue( TSD, _fname, Str_cre_TSD( TSD, "STDERR" ), -1 );
 292     sprintf( txt, "%p", stderr );
 293     setvalue( TSD, _fstem, Str_cre_TSD( TSD, txt ), -1 );
 294   }
 295
 296   return oldlevel;
 297 }
 298
 299
 300 /* getfile will return the FILE pointer of given name */
 301 static FILE *getfile( tsd_t *TSD, const streng *name )
 302 {
 303   proclevel oldlevel = setamilevel( TSD );
 304   const streng *s;
 305   char *txt;
 306   FILE *file=NULL;
 307
 308   setvalue( TSD, _fname, Str_dup_TSD( TSD, name ), -1 );
 309   if ( isvariable( TSD, _fstem ) )
 310   {
 311     s = getvalue( TSD, _fstem, -1 );
 312     txt = str_of( TSD, s );
 313     sscanf( txt, "%p", &file );
 314     FreeTSD( txt );
 315   }
 316
 317   TSD->currlevel = oldlevel;
 318
 319   return file;
 320 }
 321
 322
 323 /* getfilenames will return a list of all opened files */
 324 static streng *getfilenames( tsd_t *TSD, const streng *sep )
 325 {
 326   proclevel oldlevel = setamilevel( TSD );
 327   streng *retval = NULL, *tmpstr;
 328   int first = 1;
 329   variableptr var;
 330
 331   get_next_variable( TSD, 1 );
 332   for ( var = get_next_variable( TSD, 0);
 333        var != NULL;
 334        var = get_next_variable( TSD, 0) )
 335   {
 336     while ( var != NULL && var->realbox != NULL )
 337       var = var->realbox;
 338
 339     if ( var != NULL && ( (var->flag & (VFLAG_STR | VFLAG_NUM)) || var->stem ) )
 340     {
 341       if ( first )
 342       {
 343         retval = Str_dup_TSD( TSD, var->name );
 344         first = 0;
 345       }
 346       else
 347       {
 348         tmpstr = Str_cat_TSD( TSD, retval, sep );
 349         if ( tmpstr != retval )
 350         {
 351           Free_string_TSD( TSD, retval );
 352           retval = tmpstr;
 353         }
 354         tmpstr = Str_cat_TSD( TSD, retval, var->name );
 355         if ( tmpstr != retval )
 356         {
 357           Free_string_TSD( TSD, retval );
 358           retval = tmpstr;
 359         }
 360       }
 361     }
 362   }
 363
 364   TSD->currlevel = oldlevel;
 365
 366   /* If no variable present return NULL string */
 367   if (first)
 368     retval = nullstringptr();
 369
 370   return retval;
 371 }
 372
 373 /* addfile: store the FILE pointer in a given name */
 374 static void addfile( tsd_t *TSD, const streng *name, FILE *file )
 375 {
 376   proclevel oldlevel = setamilevel( TSD );
 377   char txt[20];
 378   streng *s;
 379
 380   sprintf( txt, "%p", (void *)file );
 381   s = Str_cre_TSD( TSD, txt );
 382   setvalue( TSD, _fname, Str_dup_TSD( TSD, name ), -1 );
 383   setvalue( TSD, _fstem, s, -1 );
 384
 385   TSD->currlevel = oldlevel;
 386 }
 387
 388
 389 /* rmfile: remove a given of open files list */
 390 static void rmfile( tsd_t *TSD, const streng *name )
 391 {
 392   arexx_tsd_t *atsd = (arexx_tsd_t *)TSD->arx_tsd;
 393   proclevel oldlevel = setamilevel( TSD );
 394
 395   TSD->currlevel = atsd->amilevel;
 396
 397   drop_var( TSD, name );
 398
 399   TSD->currlevel = oldlevel;
 400 }
 401
 402
 403
 404 /*
 405  * Implementation of the ARexx IO functions
 406  * See general documentation for more information
 407  * Functions implemented: OPEN, CLOSE, READCH, READLN, WRITECH, WRITELN, EOF, SEEK
 408  */
 409 streng *arexx_open( tsd_t *TSD, cparamboxptr parm1 )
 410 {
 411   cparamboxptr parm2, parm3;
 412   char *filename;
 413   FILE *file;
 414   int mode;
 415   static const char* modestrings[] = {
 416     "w",
 417     "r+",
 418     "a"
 419   };
 420
 421   checkparam( parm1, 2, 3, "OPEN" );
 422   parm2 = parm1->next;
 423   parm3 = parm2->next;
 424
 425   file = getfile( TSD, parm1->value );
 426   if ( file!=NULL )
 427   {
 428     return int_to_streng( TSD, 0 );
 429   }
 430
 431   filename = str_of( TSD, parm2->value );
 432
 433   if ( parm3==NULL
 434        || parm3->value==NULL
 435        || parm3->value->len==0 )
 436     mode=0;
 437   else switch( getoptionchar( TSD, parm3->value, "OPEN", 3, "", "WRA" ) )
 438   {
 439     case 'W':
 440       mode=0;
 441       break;
 442
 443     case 'R':
 444       mode=1;
 445       break;
 446
 447     case 'A':
 448       mode=2;
 449       break;
 450
 451     default:
 452       mode=0;
 453       assert(0);
 454       break;
 455   }
 456
 457   file = fopen( filename, modestrings[mode] );
 458   FreeTSD( filename );
 459
 460   if ( file==NULL )
 461   {
 462     return int_to_streng( TSD, 0 );
 463   }
 464
 465   addfile( TSD, parm1->value, file );
 466   return int_to_streng( TSD, 1);
 467 }
 468
 469
 470 streng *arexx_close( tsd_t *TSD, cparamboxptr parm1 )
 471 {
 472   FILE *file;
 473
 474   checkparam( parm1, 1, 1, "CLOSE" );
 475
 476   file = getfile( TSD, parm1->value );
 477   if ( file==NULL )
 478     return int_to_streng( TSD, 0 );
 479
 480   fclose( file );
 481   rmfile( TSD, parm1->value );
 482
 483   return int_to_streng( TSD, 1 );
 484 }
 485
 486
 487 streng *arexx_writech( tsd_t *TSD, cparamboxptr parm1 )
 488 {
 489   cparamboxptr parm2;
 490   char *txt;
 491   FILE *file;
 492   int count;
 493
 494   checkparam( parm1, 2, 2, "WRITECH" );
 495   parm2 = parm1->next;
 496
 497   file = getfile( TSD, parm1->value );
 498   if ( file==NULL )
 499     exiterror( ERR_INCORRECT_CALL, 27, "WRITECH", tmpstr_of( TSD, parm1->value ));
 500
 501   txt = str_of( TSD, parm2->value );
 502   count = fprintf( file, "%s", txt );
 503   FreeTSD( txt );
 504
 505   return int_to_streng( TSD, count );
 506 }
 507
 508
 509 streng *arexx_writeln( tsd_t *TSD, cparamboxptr parm1 )
 510 {
 511   cparamboxptr parm2;
 512   char *txt;
 513   FILE *file;
 514   int count;
 515
 516   checkparam( parm1, 2, 2, "WRITELN" );
 517   parm2 = parm1->next;
 518
 519   file = getfile( TSD, parm1->value );
 520   if ( file==NULL )
 521     exiterror( ERR_INCORRECT_CALL, 27, "WRITELN", tmpstr_of( TSD, parm1->value ) );
 522
 523   txt = str_of( TSD, parm2->value );
 524   count = fprintf(file, "%s\n", txt);
 525   FreeTSD( txt );
 526
 527   return int_to_streng( TSD, count );
 528 }
 529
 530
 531 streng *arexx_seek( tsd_t *TSD, cparamboxptr parm1 )
 532 {
 533   cparamboxptr parm2, parm3;
 534   FILE *file;
 535   int pos, error, wench;
 536   long offset;
 537
 538   checkparam( parm1, 2, 3, "SEEK" );
 539   parm2 = parm1->next;
 540   parm3 = parm2->next;
 541
 542   file = getfile( TSD, parm1->value );
 543   if ( file==NULL )
 544     exiterror( ERR_INCORRECT_CALL, 27, "SEEK", tmpstr_of( TSD, parm1->value ) );
 545
 546   offset = streng_to_int( TSD, parm2->value, &error );
 547   if (error)
 548     exiterror( ERR_INCORRECT_CALL, 11, "SEEK", 2, tmpstr_of( TSD, parm2->value ) );
 549
 550   if ( parm3==NULL
 551        || parm3->value==NULL
 552        || parm3->value->len == 0 )
 553     wench = SEEK_CUR;
 554   else switch( getoptionchar( TSD, parm3->value, "SEEK", 3, "", "CBE" ) )
 555   {
 556     case 'C':
 557       wench = SEEK_CUR;
 558       break;
 559
 560     case 'B':
 561       wench = SEEK_SET;
 562       break;
 563
 564     case 'E':
 565       wench = SEEK_END;
 566       break;
 567
 568     default:
 569       wench = SEEK_CUR;
 570       assert(0);
 571       break;
 572   }
 573
 574   pos = fseek( file, offset, wench );
 575   return int_to_streng( TSD, pos );
 576 }
 577
 578
 579 streng *arexx_readch( tsd_t *TSD, cparamboxptr parm1 )
 580 {
 581   cparamboxptr parm2;
 582   FILE *file;
 583
 584   checkparam( parm1, 1, 2, "READCH");
 585   parm2 = parm1->next;
 586
 587   file = getfile( TSD, parm1->value );
 588   if ( file==NULL )
 589     exiterror( ERR_INCORRECT_CALL, 27, "READCH", tmpstr_of( TSD, parm1->value ) );
 590
 591   if ( parm2==NULL )
 592   {
 593     char buffer[2] = { 0, 0 };
 594
 595     buffer[0] = (char)getc( file );
 596
 597     return Str_cre_TSD( TSD, buffer );
 598   }
 599   else
 600   {
 601     int count, error;
 602     streng *ret;
 603
 604     count = streng_to_int( TSD, parm2->value, &error );
 605
 606     if ( error )
 607       exiterror( ERR_INCORRECT_CALL, 11, "READCH", 2, tmpstr_of( TSD, parm2->value ) );
 608     if ( count<=0 )
 609       exiterror( ERR_INCORRECT_CALL, 14, "READCH", 2, tmpstr_of( TSD, parm2->value ) );
 610
 611     ret = Str_makeTSD( count );
 612
 613     count = fread( ret->value, 1, count, file );
 614     if ( count == -1 )
 615     {
 616        /*
 617         * Fixme: What shall happen in this case?
 618         *        Setting count to 0 seems a little bit weak for me but better
 619         *        than doing more strange things. FGC
 620         */
 621        count = 0;
 622     }
 623     Str_len( ret ) = count;
 624
 625     return ret;
 626   }
 627 }
 628
 629
 630 streng *arexx_readln( tsd_t *TSD, cparamboxptr parm )
 631 {
 632   FILE *file;
 633   char buffer[1001];
 634
 635   checkparam( parm, 1, 1, "READLN");
 636
 637   file = getfile( TSD, parm->value );
 638   if ( file==NULL )
 639     exiterror( ERR_INCORRECT_CALL, 27, "READLN", tmpstr_of( TSD, parm->value ) );
 640
 641   fgets( buffer, 1001, file );
 642   if ( buffer[strlen(buffer)-1]=='\n' )
 643     buffer[strlen(buffer)-1]=0;
 644
 645   return Str_cre_TSD( TSD, buffer );
 646 }
 647
 648
 649 streng *arexx_eof( tsd_t *TSD, cparamboxptr parm )
 650 {
 651   FILE *file;
 652
 653   checkparam( parm, 1, 1, "EOF" );
 654
 655   file = getfile( TSD, parm->value );
 656   if ( file==NULL )
 657     exiterror( ERR_INCORRECT_CALL, 27, "EOF", tmpstr_of( TSD, parm->value ) );
 658
 659   return int_to_streng( TSD, feof( file )!=0 );
 660 }
 661
 662
 663 /*
 664  * Implementation of the additional conversion functions from ARexx
 665  * Functions: B2C, C2B
 666  */
 667 streng *arexx_b2c( tsd_t *TSD, cparamboxptr parm )
 668 {
 669   parambox parm2;
 670   streng *ret;
 671
 672   checkparam( parm, 1, 1, "B2C" );
 673
 674   parm2.next = NULL;
 675   parm2.value = std_b2x( TSD, parm );
 676
 677   ret = std_x2c( TSD, &parm2 );
 678   Free_string_TSD( TSD, parm2.value );
 679
 680   return ret;
 681 }
 682
 683
 684 streng *arexx_c2b( tsd_t *TSD, cparamboxptr parm )
 685 {
 686   parambox parm2;
 687   streng *ret;
 688
 689   checkparam( parm, 1, 1, "B2C" );
 690
 691   parm2.next = NULL;
 692   parm2.value = std_c2x( TSD, parm );
 693
 694   ret = std_x2b( TSD, &parm2 );
 695   Free_string_TSD( TSD, parm2.value );
 696
 697   return ret;
 698 }
 699
 700
 701 /*
 702  * Implementation of the bitwise function from ARexx
 703  * Functions: BITCHG, BITCLR, BITSET, BITTST, BITCOMP
 704  */
 705 streng *arexx_bitchg( tsd_t *TSD, cparamboxptr parm1 )
 706 {
 707   cparamboxptr parm2;
 708   streng *ret;
 709   int bit, error, byte;
 710   div_t dt;
 711
 712   checkparam( parm1, 2, 2, "BITCHG" );
 713   parm2 = parm1->next;
 714
 715   bit = streng_to_int( TSD, parm2->value, &error );
 716   if ( error )
 717     exiterror( ERR_INCORRECT_CALL, 11, "BITCHG", 2, tmpstr_of( TSD, parm2->value ) );
 718   if ( bit<0 )
 719     exiterror( ERR_INCORRECT_CALL, 13, "BITCHG", 2, tmpstr_of( TSD, parm2->value ) );
 720
 721   dt = div( bit, 8 );
 722
 723   byte = parm1->value->len-dt.quot-1;
 724   if ( byte<0 )
 725     exiterror( ERR_INCORRECT_CALL, 0 );
 726
 727   ret = Str_dup_TSD( TSD, parm1->value );
 728   ret->value[byte]^=(char)(1<<dt.rem);
 729   return ret;
 730 }
 731
 732
 733 streng *arexx_bitclr( tsd_t *TSD, cparamboxptr parm1 )
 734 {
 735   cparamboxptr parm2;
 736   streng *ret;
 737   int bit, error, byte;
 738   div_t dt;
 739
 740   checkparam( parm1, 2, 2, "BITCLR" );
 741   parm2 = parm1->next;
 742
 743   bit = streng_to_int( TSD, parm2->value, &error );
 744   if ( error )
 745     exiterror( ERR_INCORRECT_CALL, 11, "BITCLR", 2, tmpstr_of( TSD, parm2->value ) );
 746   if ( bit<0 )
 747     exiterror( ERR_INCORRECT_CALL, 13, "BITCLR", 2, tmpstr_of( TSD, parm2->value ) );
 748
 749   dt = div( bit, 8 );
 750
 751   byte = parm1->value->len-dt.quot-1;
 752   if ( byte<0 )
 753     exiterror( ERR_INCORRECT_CALL, 0 );
 754
 755   ret = Str_dup_TSD( TSD, parm1->value );
 756   ret->value[byte]&=~(char)(1<<dt.rem);
 757   return ret;
 758 }
 759
 760
 761 streng *arexx_bitset( tsd_t *TSD, cparamboxptr parm1 )
 762 {
 763   cparamboxptr parm2;
 764   streng *ret;
 765   int bit, error, byte;
 766   div_t dt;
 767
 768   checkparam( parm1, 2, 2, "BITSET" );
 769   parm2 = parm1->next;
 770
 771   bit = streng_to_int( TSD, parm2->value, &error );
 772   if ( error )
 773     exiterror( ERR_INCORRECT_CALL, 11, "BITSET", 2, tmpstr_of( TSD, parm2->value ) );
 774   if ( bit<0 )
 775     exiterror( ERR_INCORRECT_CALL, 13, "BITSET", 2, tmpstr_of( TSD, parm2->value ) );
 776
 777   dt = div( bit, 8 );
 778
 779   byte = parm1->value->len-dt.quot-1;
 780   if ( byte<0 )
 781     exiterror( ERR_INCORRECT_CALL, 0 );
 782
 783   ret = Str_dup_TSD( TSD, parm1->value );
 784   ret->value[byte]|=(char)(1<<dt.rem);
 785   return ret;
 786 }
 787
 788
 789 streng *arexx_bittst( tsd_t *TSD, cparamboxptr parm1 )
 790 {
 791   cparamboxptr parm2;
 792   streng *ret;
 793   int bit, error, byte;
 794   div_t dt;
 795
 796   checkparam( parm1, 2, 2, "BITTST" );
 797   parm2 = parm1->next;
 798
 799   bit = streng_to_int( TSD, parm2->value, &error );
 800   if ( error )
 801     exiterror( ERR_INCORRECT_CALL, 11, "BITTST", 2, tmpstr_of( TSD, parm2->value ) );
 802   if ( bit<0 )
 803     exiterror( ERR_INCORRECT_CALL, 13, "BITTST", 2, tmpstr_of( TSD, parm2->value ) );
 804
 805   dt = div( bit, 8 );
 806
 807   byte = parm1->value->len-dt.quot-1;
 808   if ( byte<0 )
 809     exiterror( ERR_INCORRECT_CALL, 0 );
 810
 811   ret = int_to_streng( TSD, (parm1->value->value[byte] & (char)(1<<dt.rem))!=0 );
 812   return ret;
 813 }
 814
 815
 816 /* Help function for arexx_bitcomp */
 817 static int firstbit(char c)
 818 {
 819   int i;
 820   assert(c!=0);
 821
 822   for ( i=0; i<8; i++)
 823   {
 824     if (c & 1)
 825       return i;
 826     else
 827       c = (char)(c >> 1);
 828   }
 829
 830   return 8;
 831 }
 832
 833 /* This ARexx function has very weird usage of the pad byte,
 834  * the shortest string is padded on the left with this byte
 835  */
 836 streng *arexx_bitcomp( tsd_t *TSD, cparamboxptr parm1 )
 837 {
 838   cparamboxptr parm2, parm3;
 839   const streng *s1, *s2;
 840   const char *cp1, *cp2;
 841   char pad;
 842   int i;
 843
 844   checkparam( parm1, 2, 3, "BITCOMP" );
 845   parm2 = parm1->next;
 846
 847   /* Make s2 always shorter or equal to s1 */
 848   if ( parm1->value->len < parm2->value->len )
 849   {
 850     s1 = parm2->value;
 851     s2 = parm1->value;
 852   } else {
 853     s1 = parm1->value;
 854     s2 = parm2->value;
 855   }
 856
 857   for ( cp1=s1->value+s1->len-1, cp2=s2->value+s2->len-1, i=0;
 858        cp2 >= s2->value;
 859        cp1--, cp2--, i++ )
 860   {
 861     if ( *cp1 != *cp2 )
 862       return int_to_streng( TSD, i*8 + firstbit( ( char ) ( *cp1 ^ *cp2 ) ) );
 863   }
 864
 865   parm3 = parm2->next;
 866   if ( parm3==NULL || parm3->value==NULL || parm3->value->len==0 )
 867     pad = 0;
 868   else
 869     pad = parm3->value->value[0];
 870
 871   for ( ;
 872   cp1 >= s1->value;
 873   cp1--, i++ )
 874   {
 875     if ( *cp1 != pad )
 876       return int_to_streng( TSD, i*8 + firstbit( ( char ) ( *cp1 ^ pad ) ) );
 877   }
 878
 879   return int_to_streng( TSD, -1 );
 880 }
 881
 882
 883 /*
 884  * Some more misc. ARexx functions
 885  * Functions: COMPRESS, HASH, RANDU, TRIM, UPPER
 886  */
 887 streng *arexx_hash( tsd_t *TSD, cparamboxptr parm1 )
 888 {
 889   unsigned char *uc;
 890   int i, sum=0;
 891
 892   checkparam( parm1, 1, 1, "HASH" );
 893
 894   uc = (unsigned char *)parm1->value->value;
 895   for ( i=0; i<parm1->value->len; i++)
 896   {
 897     sum = (sum + uc[i]) & 255;
 898   }
 899
 900   return int_to_streng( TSD, sum );
 901 }
 902
 903
 904 streng *arexx_compress( tsd_t *TSD, cparamboxptr parm1 )
 905 {
 906   const char *match;
 907   int i, start;
 908   streng *ret;
 909
 910   checkparam( parm1, 1, 2, "COMPRESS" );
 911
 912   match = ( parm1->next!=NULL ) ? str_of( TSD, parm1->next->value ) : " ";
 913
 914   ret = Str_dup_TSD( TSD, parm1->value );
 915   for ( i=start=0; i<ret->len; i++ )
 916   {
 917     /* Copy char if not found */
 918     if ( strchr( match, ret->value[i] )==NULL )
 919     {
 920       ret->value[start] = ret->value[i];
 921       start++;
 922     }
 923   }
 924   ret->len = start;
 925
 926   if ( parm1->next!=NULL )
 927     FreeTSD( (char *)match );
 928
 929   return ret;
 930 }
 931
 932
 933 static const streng T_str = { 1, 1, { .value = "T" } };
 934 static const parambox T_parm = { NULL, 0, (streng *)&T_str };
 935
 936 streng *arexx_trim( tsd_t *TSD, cparamboxptr parm1 )
 937 {
 938   parambox parm;
 939
 940   checkparam( parm1, 1, 1, "TRIM" );
 941
 942   parm = *parm1;
 943   parm.next = (paramboxptr)&T_parm;
 944
 945   return std_strip( TSD, &parm );
 946 }
 947
 948
 949 streng *arexx_upper( tsd_t *TSD, cparamboxptr parms )
 950 {
 951    int rlength=0, length=0, start=1, i=0 ;
 952    int changecount;
 953    char padch=' ' ;
 954    streng *str=NULL, *ptr=NULL ;
 955    paramboxptr bptr=NULL ;
 956
 957    /*
 958     * Check that we have between 1 and 4 args
 959     * ( str [,start[,length[,pad]]] )
 960     */
 961    checkparam(  parms,  1,  4 , "UPPER" ) ;
 962    str = parms->value ;
 963    rlength = Str_len( str ) ;
 964    /*
 965     * Get starting position, if supplied...
 966     */
 967    if ( parms->next != NULL
 968    &&   parms->next->value )
 969       start = atopos( TSD, parms->next->value, "UPPER", 2 ) ;
 970    /*
 971     * Get length, if supplied...
 972     */
 973    if ( parms->next != NULL
 974    && ( (bptr = parms->next->next) != NULL )
 975    && ( parms->next->next->value ) )
 976       length = atozpos( TSD, parms->next->next->value, "UPPER", 3 ) ;
 977    else
 978       length = ( rlength >= start ) ? rlength - start + 1 : 0;
 979    /*
 980     * Get pad character, if supplied...
 981     */
 982    if ( (bptr )
 983    && ( bptr->next )
 984    && ( bptr->next->value ) )
 985       padch = getonechar( TSD, parms->next->next->next->value, "UPPER", 4) ;
 986    /*
 987     * Create our new starting; duplicate of input string
 988     */
 989    ptr = Str_makeTSD( length );
 990    memcpy( Str_val( ptr ), Str_val( str ), Str_len( str ) );
 991    /*
 992     * Determine where to start changing case...
 993     */
 994    i = ((rlength>=start)?start-1:rlength) ;
 995    /*
 996     * Determine how many characters to change case...
 997     */
 998    changecount = length > rlength ? rlength : length;
 999    /*
1000     * Change them
1001     */
1002    mem_upper( &ptr->value[i], changecount );
1003    /*
1004     * Append pad characters if required...
1005     */
1006    if (changecount < length)
1007       memset(&ptr->value[changecount], padch, length - changecount);
1008    /*
1009     * Determine length of return string...
1010     */
1011    ptr->len = (length > rlength) ? length : rlength ;
1012    return ptr ;
1013 }
1014
1015
1016 streng *arexx_randu( tsd_t *TSD, cparamboxptr parm1 )
1017 {
1018    int error, seed;
1019    char text[30];
1020    streng *s, *retval;
1021
1022    checkparam( parm1, 0, 1, "RANDU" );
1023
1024    if ( ( parm1 != NULL ) && ( parm1->value != NULL ) )
1025    {
1026       seed = streng_to_int( TSD, parm1->value, &error );
1027       if ( error )
1028          exiterror( ERR_INCORRECT_CALL, 11, "RANDU", 1, tmpstr_of( TSD, parm1->value ) );
1029
1030       rx_srand48( TSD, seed );
1031    }
1032
1033    sprintf( text, "%.20f", rx_drand48( TSD ) );
1034    s = Str_cre_TSD( TSD, text );
1035    retval = str_format( TSD, s, -1, -1, -1, -1 );
1036    FreeTSD( s );
1037
1038    return retval;
1039 }
1040
1041
1042 /*
1043  * Two memory allocation/deallocation functions: getspace and freespace
1044  */
1045 streng *arexx_getspace( tsd_t *TSD, cparamboxptr parm1 )
1046 {
1047    int length, error;
1048    void *ptr;
1049
1050    checkparam( parm1, 1, 1, "GETSPACE" );
1051
1052    length = streng_to_int( TSD, parm1->value, &error);
1053    if ( error )
1054       exiterror( ERR_INCORRECT_CALL, 11, "GETSPACE", 1, tmpstr_of( TSD, parm1->value ) );
1055    if ( length<=0 )
1056       exiterror( ERR_INCORRECT_CALL, 14, "GETSPACE", 1, tmpstr_of( TSD, parm1->value ) );
1057
1058    ptr = Malloc_TSD( TSD, length );
1059    memset( ptr, 0, length );
1060    if ( ptr == NULL )
1061       exiterror( ERR_STORAGE_EXHAUSTED, 0 );
1062
1063    return Str_ncre_TSD( TSD, (char *)&ptr, sizeof(void *) );
1064 }
1065
1066
1067 streng *arexx_freespace( tsd_t *TSD, cparamboxptr parm1 )
1068 {
1069    /*
1070     * For backwards compatibility there may be two arguments
1071     * But the second argument is ignored in regina
1072     */
1073    checkparam( parm1, 0, 2, "FREESPACE" );
1074
1075    if ( parm1 == NULL || parm1->value == NULL || parm1->value->len == 0 )
1076 #if defined(_AMIGA) || defined(__AROS__)
1077       return int_to_streng( TSD, AvailMem( MEMF_ANY ) );
1078 #else
1079       return int_to_streng( TSD, -1 );
1080 #endif
1081
1082    if ( parm1->value->len != sizeof(void *) )
1083       exiterror( ERR_INCORRECT_CALL, 0 );
1084
1085    Free_TSD( TSD, *(parm1->value->ptr) );
1086
1087    return nullstringptr();
1088 }
1089
1090
1091
1092
1093 /*
1094  * ARexx memory <-> string conversion routines: IMPORT, EXPORT, STORAGE
1095  */
1096 streng *arexx_import( tsd_t *TSD, cparamboxptr parm1 )
1097 {
1098   void *memptr;
1099   cparamboxptr parm2;
1100   int len, error;
1101
1102   checkparam( parm1, 1, 2, "IMPORT" );
1103
1104   if ( parm1->value->len != sizeof(void *) )
1105     exiterror( ERR_INCORRECT_CALL, 0 );
1106
1107   memptr = *(parm1->value->ptr);
1108
1109   parm2 = parm1->next;
1110   if ( parm2 == NULL || parm2->value == NULL || parm2->value->len == 0 )
1111     len = strlen((char *)memptr);
1112   else
1113   {
1114     len = streng_to_int( TSD, parm2->value, &error );
1115     if ( error )
1116       exiterror( ERR_INCORRECT_CALL, 11, "IMPORT", 2, tmpstr_of( TSD, parm2->value ) );
1117     if ( len<=0 )
1118       exiterror( ERR_INCORRECT_CALL, 14, "IMPORT", 2, tmpstr_of( TSD, parm2->value ) );
1119   }
1120
1121   return Str_ncre_TSD( TSD, (const char *)memptr, len );
1122 }
1123
1124
1125 streng *arexx_export( tsd_t *TSD, cparamboxptr parm1 )
1126 {
1127   void *memptr;
1128   cparamboxptr parm2 = NULL, parm3 = NULL, parm4 = NULL;
1129   int len, error;
1130   char fill;
1131   streng *src;
1132
1133   checkparam( parm1, 1, 4, "EXPORT" );
1134
1135   if ( parm1->value == NULL || parm1->value->len == 0 )
1136     exiterror( ERR_INCORRECT_CALL, 21, "EXPORT", 1 );
1137   memptr = *(parm1->value->ptr);
1138
1139   parm2 = parm1->next;
1140   if ( parm2 != NULL )
1141     parm3 = parm2->next;
1142   if ( parm3 != NULL )
1143     parm4 = parm3->next;
1144
1145   if ( parm2 == NULL || parm2->value == NULL || parm2->value->len == 0 )
1146     src = nullstringptr();
1147   else
1148     src = Str_dup_TSD( TSD, parm2->value );
1149
1150   if ( parm3 == NULL || parm3->value == NULL || parm3->value->len == 0 )
1151     len = src->len;
1152   else
1153   {
1154     len = streng_to_int( TSD, parm3->value, &error );
1155     if ( error )
1156       exiterror( ERR_INCORRECT_CALL, 11, "EXPORT", 3, tmpstr_of( TSD, parm3->value ) );
1157     if ( len<0 )
1158       exiterror( ERR_INCORRECT_CALL, 13, "EXPORT", 3, tmpstr_of( TSD, parm3->value ) );
1159   }
1160
1161   if ( parm4 == NULL || parm4->value == NULL || parm4->value->len == 0 )
1162     fill = 0;
1163   else
1164     fill = parm4->value->value[0];
1165
1166   if (len > src->len)
1167   {
1168     memcpy( memptr, src->value, src->len );
1169     memset( ((char *)memptr)+src->len, fill, len - src->len );
1170   }
1171   else
1172     memcpy( memptr, src->value, len );
1173
1174   Free_string_TSD( TSD, src );
1175
1176   return int_to_streng( TSD, len );
1177 }
1178
1179
1180 streng *arexx_storage( tsd_t *TSD, cparamboxptr parm1 )
1181 {
1182   void *memptr;
1183   cparamboxptr parm2 = NULL, parm3 = NULL, parm4 = NULL;
1184   int len, error;
1185   char fill;
1186   streng *src, *retval;
1187
1188   checkparam( parm1, 0, 4, "STORAGE" );
1189
1190   if ( parm1 == NULL || parm1->value == NULL )
1191     return arexx_freespace( TSD, NULL );
1192
1193   if ( TSD->restricted )
1194     exiterror( ERR_RESTRICTED, 1, "STORAGE" )  ;
1195
1196   if ( parm1->value == NULL || parm1->value->len == 0 )
1197     exiterror( ERR_INCORRECT_CALL, 21, "STORAGE", 1 );
1198   memptr = *(parm1->value->ptr);
1199
1200   parm2 = parm1->next;
1201   if ( parm2 != NULL )
1202     parm3 = parm2->next;
1203   if ( parm3 != NULL )
1204     parm4 = parm3->next;
1205
1206   if ( parm2 == NULL || parm2->value == NULL || parm2->value->len == 0 )
1207     src = nullstringptr();
1208   else
1209     src = Str_dup_TSD( TSD, parm2->value );
1210
1211   if ( parm3 == NULL || parm3->value == NULL || parm3->value->len == 0 )
1212     len = src->len;
1213   else
1214   {
1215     len = streng_to_int( TSD, parm3->value, &error );
1216     if ( error )
1217       exiterror( ERR_INCORRECT_CALL, 11, "STORAGE", 3, tmpstr_of( TSD, parm3->value ) );
1218     if ( len<0 )
1219       exiterror( ERR_INCORRECT_CALL, 13, "STORAGE", 3, tmpstr_of( TSD, parm3->value ) );
1220   }
1221
1222   if ( parm4 == NULL || parm4->value == NULL || parm4->value->len == 0 )
1223     fill = 0;
1224   else
1225     fill = parm4->value->value[0];
1226
1227   retval = Str_ncre_TSD( TSD, (const char *)memptr, len );
1228
1229   if (len > src->len)
1230   {
1231     memcpy( memptr, src->value, src->len );
1232     memset( ((char *)memptr)+src->len, fill, len - src->len );
1233   }
1234   else
1235     memcpy( memptr, src->value, len );
1236
1237   Free_string_TSD( TSD, src );
1238
1239   return retval;
1240 }
1241
1242
1243
1244 /*
1245  * SHOW a function the names available in different resource lists
1246  */
1247 streng *arexx_show( tsd_t *TSD, cparamboxptr parm1 )
1248 {
1249    cparamboxptr parm2 = NULL, parm3 = NULL;
1250    streng *name = NULL, *sep, *retval;
1251
1252    checkparam( parm1, 1, 3, "SHOW" );
1253    parm2 = parm1->next;
1254    if ( parm2 != NULL )
1255       parm3 = parm2->next;
1256
1257    if ( parm2 != NULL && parm2->value != NULL && parm2->value->len != 0 )
1258       name = parm2->value;
1259
1260    if ( parm3 == NULL || parm3->value == NULL || parm3->value->len == 0 )
1261       sep = Str_cre_TSD( TSD, " " );
1262    else
1263       sep = Str_dup_TSD( TSD, parm3->value );
1264
1265    switch( getoptionchar( TSD, parm1->value, "SHOW", 1, "", "F" ) )
1266    {
1267       case 'F':
1268          if ( name == NULL )
1269             retval = getfilenames( TSD, sep );
1270          else
1271          {
1272             FILE *f = getfile( TSD, name );
1273             retval = int_to_streng( TSD, f != NULL );
1274          }
1275          break;
1276
1277       default:           /* We got an error in getoptionchar */
1278          retval = NULL;
1279
1280    }
1281    Free_string_TSD( TSD, sep );
1282
1283    return retval;
1284 }