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