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