regina/amifuncs.c

   1 /*
   2  *  Amiga REXX functions for regina
   3  *  Copyright © 2002-2011, 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 are only to be used on amiga or compatibles.
  23  * arxfuncs.c contains the ARexx functions that are usable on all
  24  * platforms.
  25  */
  26 #if defined(_AMIGA) || defined(__AROS__)
  27 #define AROS_ALMOST_COMPATIBLE
  28 #include "rexx.h"
  29 #include <stdio.h>
  30 #include <ctype.h>
  31 #include <stdlib.h>
  32 #include <assert.h>
  33
  34 #include "envir.h"
  35 #include <dos/dos.h>
  36 #include <exec/lists.h>
  37 #include <exec/ports.h>
  38 #include <exec/memory.h>
  39 #include <exec/execbase.h>
  40 #include <rexx/rxslib.h>
  41 #include <rexx/storage.h>
  42 #include <rexx/errors.h>
  43 #ifdef __AROS__
  44 #include <rexx/rexxcall.h>
  45 #endif
  46
  47 #include <proto/alib.h>
  48 #include <proto/dos.h>
  49 #include <proto/exec.h>
  50 #include <proto/rexxsyslib.h>
  51
  52 #include "rxiface.h"
  53
  54 #ifdef __AROS__
  55
  56 #define DEBUG 0
  57 #include <aros/debug.h>
  58
  59 #else
  60
  61 #define D(x)
  62
  63 #endif
  64
  65 #ifdef __AROS__
  66
  67 /* We can't use AROS_LC1NR, since 'offset'
  68  * is not constant.
  69  */
  70 #define CallRsrcFunc(libbase, offset, rsrc) \
  71    ({ \
  72       int _offset=abs(offset)/6; \
  73       AROS_LVO_CALL1NR(VOID, \
  74          AROS_LCA(struct RexxRsrc *, rsrc, A0), \
  75          struct Library *, libbase, _offset, rexxcall \
  76       ); \
  77   })
  78
  79 #elif defined(__MORPHOS__)
  80
  81 #include <ppcinline/macros.h>
  82
  83 #define CallRsrcFunc(libbase, offset, rsrc) \
  84    LP1NR((-offset), __rsrcfunc, struct RexxRsrc *, rsrc, a0, \
  85          struct Library *, libbase, 0, 0, 0, 0, 0, 0 \
  86    )
  87
  88 #else
  89
  90 #error define CallRsrcFunc
  91
  92 #endif
  93
  94 #ifdef __AROS__
  95
  96 #define RX_PRIVATETYPE IPTR
  97
  98 #else
  99
 100 #define rm_Private1 rm_TaskBlock
 101 #define rm_Private2 rm_LibBase
 102 #define RX_PRIVATETYPE APTR
 103
 104 #endif
 105
 106 #ifndef BNULL
 107 #define BNULL ((BPTR)NULL)
 108 #endif
 109
 110 #ifndef RXADDRSRC
 111 #define RXADDRSRC  0xF0000000 /* Will register a resource node to call the clean up function
 112                               * from when the rexx script finishes
 113                               * The rexx implementation is free to use the list node fields
 114                               * for their own purpose. */
 115 #define RXREMRSRC  0xF1000000 /* Will unregister an earlier registered resource node */
 116 #define RXCHECKMSG 0xF2000000 /* Check if private fields are from the Rexx interpreter */
 117 #define RXSETVAR   0xF3000000 /* Set a variable with a given to a given value */
 118 #define RXGETVAR   0xF4000000 /* Get the value of a variable with the given name */
 119 #endif
 120
 121 #ifdef __AROS__
 122 #define RX_RESULTTYPE IPTR
 123 #define RX_ARGTYPE IPTR
 124 #else
 125 #define RX_RESULTTYPE LONG
 126 #define RX_ARGTYPE STRPTR
 127 #endif
 128
 129 #if !defined(__GNUC__)
 130 #undef GetHead
 131 #define GetHead(_l)  \
 132     (((struct List *)_l)->lh_Head->ln_Succ ? ((struct List *)_l)->lh_Head : (struct Node *)0)
 133
 134 #undef GetSucc
 135 #define GetSucc(_n)  \
 136     (((struct Node *)_n)->ln_Succ->ln_Succ ? ((struct Node *)_n)->ln_Succ : (struct Node *)0)
 137 #endif
 138
 139 struct amiga_envir {
 140   struct envir envir;
 141   struct MsgPort *port;
 142 };
 143
 144 #define PTRS_SIZE 16
 145 typedef struct _amiga_tsd_t {
 146    struct amiga_envir portenvir;
 147    struct RxsLib *rexxsysbase;
 148    BPTR startlock;
 149    struct List resources; /* List to store resources to clean up at the end */
 150    struct MsgPort *listenport, *replyport;
 151    BYTE maintasksignal, subtasksignal;
 152    struct Task *parent, *child;
 153    UBYTE *value; /* Here a temporary argstring will be stored for RXGETVAR */
 154    void *ai;
 155    void *ptrs[PTRS_SIZE];
 156 } amiga_tsd_t;
 157
 158
 159 GLOBAL_PROTECTION_VAR(createtask)
 160 tsd_t *subtask_tsd;
 161
 162 #define RexxSysBase (((amiga_tsd_t *)TSD->ami_tsd)->rexxsysbase)
 163
 164 /* On AROS delete the allocated resources that are not recycled by the
 165  * normal C exit handling
 166  */
 167 void exit_amigaf( amiga_tsd_t *atsd )
 168 {
 169    struct RexxRsrc *rsrc;
 170
 171 #ifdef CallRsrcFunc
 172    ForeachNode( &atsd->resources, rsrc )
 173       CallRsrcFunc( rsrc->rr_Base, rsrc->rr_Func, rsrc );
 174 #else
 175 #warning Fix calling resources
 176 #endif
 177
 178    DeleteMsgPort( atsd->replyport );
 179    Signal( atsd->child, 1<<atsd->subtasksignal );
 180    if ( atsd->rexxsysbase != NULL )
 181       CloseLibrary( (struct Library *)atsd->rexxsysbase );
 182    UnLock( CurrentDir( atsd->startlock ) );
 183
 184    free(atsd);
 185 }
 186
 187 #ifndef RXLIB
 188 static void exit_amigaf_wrapper( void )
 189 {
 190     tsd_t *TSD = __regina_get_tsd();
 191     exit_amigaf( (amiga_tsd_t *)TSD->ami_tsd );
 192 }
 193 #endif
 194
 195 streng *createstreng( tsd_t *TSD, char *value, int length )
 196 {
 197    streng *retval;
 198
 199 #ifdef CHECK_MEMORY
 200    retval = TSD->MTMalloc( TSD, sizeof(streng) );
 201    if ( retval != NULL )
 202    {
 203       retval->value = TSD->MTMalloc( TSD, length );
 204       if ( retval->value == NULL )
 205       {
 206          TSD->MTFree( retval );
 207          retval = NULL;
 208       }
 209       else
 210          memcpy( retval->value, value, length );
 211    }
 212 #else
 213    retval = TSD->MTMalloc( TSD, sizeof(streng)-4*sizeof(char)+length );
 214    if ( retval != NULL )
 215       memcpy( retval->value, value, length );
 216 #endif
 217    retval->len = length;
 218    retval->max = length;
 219
 220    return retval;
 221 }
 222
 223 /* ReginaHandleMessages will be executed in a subtask and will be
 224  * able to handle messages send to it asynchronously
 225  */
 226 void ReginaHandleMessages(void)
 227 {
 228    tsd_t *TSD = subtask_tsd;
 229    amiga_tsd_t *atsd = (amiga_tsd_t *)TSD->ami_tsd;
 230    BOOL done;
 231    ULONG mask, signals;
 232    struct RexxMsg *msg;
 233    struct MsgPort *listenport;
 234
 235    listenport = CreateMsgPort();
 236    atsd->listenport = listenport;
 237    if ( listenport == NULL )
 238       atsd->child = NULL;
 239    else
 240       atsd->subtasksignal = AllocSignal( -1 );
 241    Signal( atsd->parent, 1<<atsd->maintasksignal );
 242
 243    mask = 1<<atsd->subtasksignal | 1<<atsd->listenport->mp_SigBit;
 244    done = listenport == NULL;
 245    while ( !done )
 246    {
 247       signals = Wait( mask );
 248
 249       done = (signals & 1<<atsd->subtasksignal) != 0;
 250
 251       while ( (msg = (struct RexxMsg *)GetMsg( atsd->listenport )) != NULL )
 252       {
 253          if ( IsRexxMsg( msg ) )
 254             switch ( msg->rm_Action & RXCODEMASK )
 255             {
 256             case RXADDRSRC:
 257                AddTail( &atsd->resources, (struct Node *)ARG0( msg ) );
 258                msg->rm_Result1 = RC_OK;
 259                break;
 260
 261             case RXREMRSRC:
 262                Remove( (struct Node *)ARG0( msg ) );
 263                msg->rm_Result1 = RC_OK;
 264                break;
 265
 266             case RXSETVAR:
 267                if ( ( msg->rm_Action & RXARGMASK ) != 2 )
 268                {
 269                   msg->rm_Result1 = RC_ERROR;
 270                   msg->rm_Result2 = (IPTR)ERR10_017;
 271                }
 272                else
 273                {
 274                   streng *name, *value;
 275
 276                   /* Using own allocation so I can get a NULL return value when allocation
 277                    * and not Exiterror is called
 278                    */
 279                   name = createstreng( TSD, (char *)msg->rm_Args[0], LengthArgstring( (UBYTE *)msg->rm_Args[0] ) );
 280                   value = createstreng( TSD, (UBYTE *)msg->rm_Args[1], LengthArgstring( (UBYTE *)msg->rm_Args[1] ) );
 281
 282                   if ( name == NULL || value == NULL )
 283                   {
 284                      if ( name != NULL ) Free_stringTSD( name );
 285                      if ( value != NULL ) Free_stringTSD( value );
 286                      msg->rm_Result1 = RC_ERROR;
 287                      msg->rm_Result2 = ERR10_003;
 288                   }
 289                   else
 290                   {
 291                      setvalue( TSD, name, value, -1 );
 292                      Free_stringTSD( name );
 293                      msg->rm_Result1 = RC_OK;
 294                      msg->rm_Result2 = (IPTR)NULL;
 295                   }
 296                }
 297                break;
 298
 299             case RXGETVAR:
 300                if ( ( msg->rm_Action & RXARGMASK ) != 1 )
 301                {
 302                   msg->rm_Result1 = RC_ERROR;
 303                   msg->rm_Result2 = (IPTR)ERR10_017;
 304                }
 305                else
 306                {
 307                   amiga_tsd_t *atsd = (amiga_tsd_t *)TSD->ami_tsd;
 308                   streng *name;
 309                   const streng *value;
 310
 311                   name = createstreng( TSD, (char *)msg->rm_Args[0], LengthArgstring( (UBYTE *)msg->rm_Args[0] ) );
 312                   if ( name == NULL )
 313                   {
 314                      msg->rm_Result1 = RC_ERROR;
 315                      msg->rm_Result2 = (IPTR)ERR10_003;
 316                   }
 317                   else
 318                   {
 319                      value = isvariable( TSD, name );
 320                      Free_stringTSD( name );
 321
 322                      if ( value != NULL )
 323                      {
 324                         if ( atsd->value != NULL) DeleteArgstring( (UBYTE *)atsd->value );
 325                         atsd->value = CreateArgstring( (STRPTR)value->value, value->len );
 326
 327                         msg->rm_Result1 = RC_OK;
 328                         msg->rm_Result2 = (IPTR)atsd->value;
 329                      }
 330                      else
 331                      {
 332                         msg->rm_Result1 = RC_ERROR;
 333                         msg->rm_Result2 = (IPTR)ERR10_039;
 334                      }
 335                   }
 336                }
 337                break;
 338
 339             default:
 340                msg->rm_Result1 = RC_ERROR;
 341                msg->rm_Result2 = ERR10_010;
 342                break;
 343             }
 344          ReplyMsg( (struct Message *)msg );
 345       }
 346    }
 347
 348    FreeSignal(atsd->subtasksignal);
 349    if ( listenport != NULL )
 350       DeletePort( listenport );
 351 }
 352
 353 /* Init amiga specific thread data, this function is called during initialisation
 354  * of the thread specific data
 355  */
 356 int init_amigaf ( tsd_t *TSD )
 357 {
 358    amiga_tsd_t *atsd = (amiga_tsd_t *)malloc( sizeof(amiga_tsd_t) );
 359    BPTR old;
 360    int i;
 361    environpart *ep;
 362
 363    if (atsd==NULL) return 0;
 364
 365    TSD->ami_tsd = (void *)atsd;
 366
 367    /* Initialization of amiga environ handling message ports.
 368     * This has to be kept up-to-date with changes made to
 369     * add_envir()/clear_environpart() in envir.c
 370     */
 371    atsd->portenvir.envir.e.name = NULL;
 372    atsd->portenvir.envir.type = ENVIR_AMIGA;
 373    ep = &atsd->portenvir.envir.e.input;
 374    ep->currnum = -1;
 375    ep->maxnum = -1;
 376    ep->hdls[2] = ep->hdls[1] = ep->hdls[0] = -1;
 377    ep->flags.isinput = 1;
 378    ep = &atsd->portenvir.envir.e.output;
 379    ep->currnum = -1;
 380    ep->maxnum = -1;
 381    ep->hdls[2] = ep->hdls[1] = ep->hdls[0] = -1;
 382    ep = &atsd->portenvir.envir.e.error;
 383    ep->currnum = -1;
 384    ep->maxnum = -1;
 385    ep->hdls[2] = ep->hdls[1] = ep->hdls[0] = -1;
 386    ep->flags.iserror = 1;
 387
 388    atsd->rexxsysbase = (struct RxsLib *)OpenLibrary( "rexxsyslib.library", 44 );
 389    if ( atsd->rexxsysbase == NULL )
 390       return 0;
 391    old = CurrentDir(BNULL);
 392    atsd->startlock = DupLock( old );
 393    CurrentDir(old);
 394 #ifndef RXLIB
 395    /* When in shared library, mt_amigalib.c will take care of cleaning up */
 396    if (atexit( exit_amigaf_wrapper ) == -1)
 397       return 0;
 398 #endif
 399    NewList( &atsd->resources );
 400    atsd->replyport = CreatePort( NULL, 0 );
 401    atsd->maintasksignal = AllocSignal( -1 );
 402    atsd->parent = FindTask( NULL );
 403
 404    atsd->value = NULL;
 405
 406    THREAD_PROTECT(createtask)
 407    subtask_tsd = TSD;
 408 #ifdef __MORPHOS__
 409    atsd->child = NewCreateTask( TASKTAG_NAME, "Regina Helper", TASKTAG_PC, (APTR)ReginaHandleMessages,
 410       TASKTAG_CODETYPE, CODETYPE_PPC, TAG_END
 411    );
 412 #else
 413    atsd->child = CreateTask( "Regina Helper", 0, (APTR)ReginaHandleMessages, 8192 );
 414 #endif
 415    if ( atsd->child != NULL )
 416       Wait(1<<atsd->maintasksignal);
 417    THREAD_UNPROTECT(createtask)
 418    FreeSignal(atsd->maintasksignal);
 419
 420    if ( atsd->child == NULL )
 421       return 0;
 422
 423    for(i = 0; i < PTRS_SIZE; i++)
 424       atsd->ptrs[i] = NULL;
 425
 426    return 1;
 427 }
 428
 429
 430 /*
 431  * Support function for exec lists
 432  */
 433 static streng *getlistnames( tsd_t *TSD, struct List *list, const streng *sep )
 434 {
 435    int first = 1;
 436    struct Node *ln;
 437    streng *retval, *tmpstr;
 438
 439    retval = Str_cre_TSD( TSD, "" );
 440    ForeachNode( list, ln )
 441    {
 442       if ( !first )
 443       {
 444          tmpstr = Str_cat_TSD( TSD, retval, sep );
 445          if ( tmpstr != retval )
 446          {
 447             Free_string_TSD( TSD, retval );
 448             retval = tmpstr;
 449          }
 450       }
 451       else
 452       {
 453          first = 0;
 454       }
 455       tmpstr = Str_catstr_TSD( TSD, retval, ln->ln_Name );
 456       if ( tmpstr != retval )
 457       {
 458          Free_string_TSD( TSD, retval );
 459          retval = tmpstr;
 460       }
 461    }
 462
 463    return retval;
 464 }
 465
 466
 467 /*
 468  * SHOW a function the names available in different resource lists
 469  */
 470 streng *amiga_show( tsd_t *TSD, cparamboxptr parm1 )
 471 {
 472    cparamboxptr parm2 = NULL, parm3 = NULL;
 473    streng *name = NULL, *sep, *retval = NULL;
 474
 475    checkparam( parm1, 1, 3, "SHOW" );
 476    parm2 = parm1->next;
 477    if ( parm2 != NULL )
 478       parm3 = parm2->next;
 479
 480    if ( parm2 != NULL && parm2->value != NULL && parm2->value->len != 0 )
 481       name = parm2->value;
 482
 483    if ( parm3 == NULL || parm3->value == NULL || parm3->value->len == 0 )
 484       sep = Str_cre_TSD( TSD, " " );
 485    else
 486       sep = Str_dup_TSD( TSD, parm3->value );
 487
 488    switch( getoptionchar( TSD, parm1->value, "SHOW", 1, "", "CFLP" ) )
 489    {
 490    case 'F':
 491       retval = arexx_show( TSD, parm1 );
 492       break;
 493
 494    case 'C':
 495       LockRexxBase( 0 );
 496       if ( name == NULL )
 497          retval = getlistnames( TSD, &RexxSysBase->rl_ClipList, sep );
 498       else
 499       {
 500          char *s = str_of( TSD, name );
 501          struct Node *ln = FindName( &RexxSysBase->rl_ClipList, s );
 502          retval = int_to_streng( TSD, ln != NULL );
 503          Free_TSD( TSD, s );
 504       }
 505       UnlockRexxBase( 0 );
 506       break;
 507
 508    case 'L':
 509       LockRexxBase( 0 );
 510       if ( name == NULL )
 511          retval = getlistnames( TSD, &RexxSysBase->rl_LibList, sep );
 512       else
 513       {
 514          char *s = str_of( TSD, name );
 515          struct Node *ln = FindName( &RexxSysBase->rl_LibList, s );
 516          retval = int_to_streng( TSD, ln != NULL );
 517          Free_TSD( TSD, s );
 518       }
 519       UnlockRexxBase( 0 );
 520       break;
 521
 522    case 'P':
 523       Forbid();
 524       if ( name == NULL )
 525          retval = getlistnames( TSD, &SysBase->PortList, sep );
 526       else
 527       {
 528          char *s = str_of( TSD, name );
 529          struct Node *ln = FindName( &SysBase->PortList, s );
 530          retval = int_to_streng( TSD, ln != NULL );
 531          Free_TSD( TSD, s );
 532       }
 533       Permit();
 534       break;
 535    }
 536    Free_string_TSD( TSD, sep );
 537
 538    return retval;
 539 }
 540
 541
 542 /* amiga_find_envir will try to find the port with the given and
 543  * create an envir function for that
 544  */
 545 struct envir *amiga_find_envir( const tsd_t *TSD, const streng *name )
 546 {
 547    amiga_tsd_t *atsd = (amiga_tsd_t *)TSD->ami_tsd;
 548    char *s;
 549    struct MsgPort *port;
 550
 551    s = str_of( TSD, name );
 552    port = FindPort( s );
 553    FreeTSD( s );
 554
 555    if (port == NULL)
 556       return NULL;
 557
 558    if ( atsd->portenvir.envir.e.name != NULL )
 559       Free_stringTSD( atsd->portenvir.envir.e.name );
 560
 561    atsd->portenvir.envir.e.name = Str_dupTSD( name );
 562    atsd->portenvir.port = port;
 563
 564    return (struct envir *)&(atsd->portenvir);
 565 }
 566
 567 /* createreginamessage will create a RexxMsg filled with the necessary fields
 568  * for regina specific things
 569  */
 570 struct RexxMsg *createreginamessage( const tsd_t *TSD )
 571 {
 572    amiga_tsd_t *atsd = (amiga_tsd_t *)TSD->ami_tsd;
 573    struct RexxMsg *msg;
 574
 575    msg = CreateRexxMsg( atsd->replyport, NULL, NULL );
 576    if ( msg != NULL )
 577    {
 578       msg->rm_Private1 = (RX_PRIVATETYPE)atsd->listenport;
 579       msg->rm_Private2 = (RX_PRIVATETYPE)TSD;
 580    }
 581    return msg;
 582 }
 583
 584 /* The function sendandwait will send a rexx message to a certain
 585  * port and wait till it returns. It the mean time also other
 586  * message (like variable can be handled
 587  * The replyport of the msg has to be atsd->listenport
 588  */
 589 void sendandwait( const tsd_t *TSD, struct MsgPort *port, struct RexxMsg *msg )
 590 {
 591    amiga_tsd_t *atsd = (amiga_tsd_t *)TSD->ami_tsd;
 592    struct RexxMsg *msg2;
 593
 594    PutMsg( port, (struct Message *)msg );
 595
 596    msg2 = NULL;
 597    while ( msg2 != msg )
 598    {
 599       WaitPort( atsd->replyport );
 600       msg2 = (struct RexxMsg *)GetMsg( atsd->replyport );
 601       if ( msg2 != msg )
 602          ReplyMsg( (struct Message *)msg2 );
 603    }
 604 }
 605
 606
 607
 608 streng *AmigaSubCom( const tsd_t *TSD, const streng *command, struct envir *envir, int *rc )
 609 {
 610    struct RexxMsg *msg;
 611    struct MsgPort *port = ((struct amiga_envir *)envir)->port;
 612    streng *retval = NULL;
 613
 614    D(bug("environment: %s\n", tmpstr_of( (tsd_t *)TSD, envir->e.name)));
 615
 616    msg = createreginamessage( TSD );
 617    /* Always ask for result, wether to set RESULT or not will be decided later */
 618    msg->rm_Action = RXCOMM | RXFF_RESULT;
 619    msg->rm_Args[0] = (RX_ARGTYPE)CreateArgstring( (STRPTR)command->value, command->len );
 620    fflush(stdout);
 621    msg->rm_Stdin = Input();
 622    msg->rm_Stdout = Output();
 623
 624    sendandwait( TSD, port, msg );
 625
 626    *rc = msg->rm_Result1;
 627    if (msg->rm_Result1 == 0)
 628    {
 629       if (msg->rm_Result2 == 0)
 630          retval = Str_crestrTSD( "" );
 631       else
 632       {
 633          retval = Str_ncre_TSD( TSD, (UBYTE *)msg->rm_Result2, LengthArgstring( (UBYTE *)msg->rm_Result2 ) );
 634          DeleteArgstring( (UBYTE *)msg->rm_Result2 );
 635       }
 636    }
 637    else
 638       retval = Str_crestrTSD( "" );
 639
 640    DeleteArgstring( (UBYTE *)msg->rm_Args[0]);
 641    DeleteRexxMsg( msg );
 642
 643    return retval;
 644 }
 645
 646
 647 /*
 648  * Here follows now the support function for ARexx style function hosts and libraries:
 649  * addlib and remlib.
 650  * Also here the try_func_amiga is defined which is called when a function is called
 651  * in an ARexx script.
 652  */
 653
 654 /* When addlib is called with two arguments the first argument is considered as a function
 655  * host name. When it is called with three or four arguments a function library is assumed
 656  */
 657 streng *amiga_addlib( tsd_t *TSD, cparamboxptr parm1 )
 658 {
 659    cparamboxptr parm2 = NULL, parm3 = NULL, parm4 = NULL;
 660    struct MsgPort *rexxport;
 661    struct RexxMsg *msg;
 662    int pri, offset, version, error, count;
 663    char *name;
 664    streng *retval;
 665
 666    checkparam( parm1, 2, 4, "ADDLIB" );
 667    parm2 = parm1->next;
 668    pri = streng_to_int( TSD, parm2->value, &error );
 669    if (error || abs(pri) > 100 )
 670       exiterror( ERR_INCORRECT_CALL, 11, "ADDLIB", 2, tmpstr_of( TSD, parm2->value ) );
 671
 672    parm3 = parm2->next;
 673    if ( parm3 != NULL && parm3->value != NULL && parm3->value->len == 0 )
 674       exiterror( ERR_INCORRECT_CALL, 21, "ADDLIB", 3 );
 675    if ( parm3 == NULL || parm3->value == NULL )
 676       offset = -30;
 677    else
 678    {
 679       offset = streng_to_int( TSD, parm3->value, &error );
 680       if ( error || offset >= 0 )
 681          exiterror( ERR_INCORRECT_CALL, 11, "ADDLIB", 3, tmpstr_of( TSD, parm3->value ) );
 682    }
 683
 684    if ( parm3 != NULL )
 685       parm4 = parm3->next;
 686    if ( parm4 == NULL || parm4->value == NULL || parm4->value->len == 0 )
 687       version = 0;
 688    else
 689    {
 690       version = streng_to_int( TSD, parm4->value, &error );
 691       if ( error )
 692          exiterror( ERR_INCORRECT_CALL, 11, "ADDLIB", 4, tmpstr_of( TSD, parm4->value ) );
 693       if ( version < 0 )
 694          exiterror( ERR_INCORRECT_CALL, 13, "ADDLIB", 4, tmpstr_of( TSD, parm4->value ) );
 695    }
 696
 697    name = str_of( TSD, parm1->value );
 698    msg = createreginamessage( TSD );
 699    if ( msg == NULL )
 700    {
 701       Free_TSD( TSD, name );
 702       exiterror( ERR_STORAGE_EXHAUSTED, 0 );
 703    }
 704    if ( parm3 == NULL || parm3->value == NULL || parm3->value->len == 0 )
 705    {
 706       msg->rm_Action = RXADDFH;
 707       msg->rm_Args[0] = (RX_ARGTYPE)name;
 708       msg->rm_Args[1] = (RX_ARGTYPE)pri;
 709       count = 2;
 710       if ( !FillRexxMsg( msg, 2, 1<<1 ) )
 711       {
 712          Free_TSD( TSD, name );
 713          DeleteRexxMsg( msg );
 714          exiterror( ERR_STORAGE_EXHAUSTED, 0 );
 715       }
 716    }
 717    else
 718    {
 719       msg->rm_Action = RXADDLIB;
 720       msg->rm_Args[0] = (RX_ARGTYPE)name;
 721       msg->rm_Args[1] = (RX_ARGTYPE)pri;
 722       msg->rm_Args[2] = (RX_ARGTYPE)offset;
 723       msg->rm_Args[3] = (RX_ARGTYPE)version;
 724       count = 4;
 725       if ( !FillRexxMsg( msg, 4, 1<<1 | 1<<2 | 1<<3 ) )
 726       {
 727          Free_TSD( TSD, name );
 728          DeleteRexxMsg( msg );
 729          exiterror( ERR_STORAGE_EXHAUSTED, 0 );
 730       }
 731    }
 732
 733    rexxport = FindPort( "REXX" );
 734    if (rexxport == NULL)
 735    {
 736       Free_TSD( TSD, name );
 737       DeleteRexxMsg( msg );
 738       exiterror( ERR_EXTERNAL_QUEUE, 0 );
 739    }
 740    sendandwait( TSD, rexxport, msg );
 741
 742    Free_TSD( TSD, name );
 743    ClearRexxMsg( msg, count );
 744
 745    retval = ( msg->rm_Result1 == 0 ) ? Str_cre_TSD( TSD, "1" ) : Str_cre_TSD( TSD, "0" );
 746
 747    DeleteRexxMsg( msg );
 748
 749    return retval;
 750 }
 751
 752 streng *amiga_remlib( tsd_t *TSD, cparamboxptr parm1 )
 753 {
 754    struct MsgPort *rexxport;
 755    struct RexxMsg *msg;
 756    streng *retval;
 757
 758    checkparam( parm1, 1, 1, "REMLIB" );
 759
 760    msg = createreginamessage( TSD );
 761    if ( msg == NULL )
 762       exiterror( ERR_STORAGE_EXHAUSTED, 0 );
 763
 764    msg->rm_Action = RXREMLIB;
 765    msg->rm_Args[0] = (RX_ARGTYPE)CreateArgstring( parm1->value->value, parm1->value->len );
 766
 767    rexxport = FindPort( "REXX" );
 768    if (rexxport == NULL )
 769    {
 770       DeleteArgstring( (UBYTE *)msg->rm_Args[0] );
 771       DeleteRexxMsg( msg );
 772       exiterror( ERR_EXTERNAL_QUEUE, 0 );
 773    }
 774    sendandwait( TSD, rexxport, msg );
 775
 776    retval = ( msg->rm_Result1 == 0 ) ? Str_cre_TSD( TSD, "1" ) : Str_cre_TSD( TSD, "0" );
 777
 778    DeleteArgstring( (UBYTE *)msg->rm_Args[0] );
 779    DeleteRexxMsg( msg );
 780
 781    return retval;
 782 }
 783
 784 streng *try_func_amiga( tsd_t *TSD, const streng *name, cparamboxptr parms, char called )
 785 {
 786    struct MsgPort *port;
 787    struct RexxMsg *msg;
 788    struct RexxRsrc *rsrc;
 789    struct Library *lib;
 790    ULONG result1;
 791    IPTR result2 = (IPTR)0;
 792    UBYTE *retstring;
 793    unsigned int parmcount;
 794    cparamboxptr parmit;
 795    streng *retval = NULL;
 796
 797    msg = createreginamessage( TSD );
 798    if ( msg == NULL )
 799       exiterror( ERR_STORAGE_EXHAUSTED, 0 );
 800
 801    msg->rm_Action = RXFUNC | RXFF_RESULT;
 802    msg->rm_Args[0] = (RX_ARGTYPE)CreateArgstring( (char *)name->value, name->len );
 803
 804    for (parmit = parms, parmcount = 0; parmit != NULL; parmit = parmit->next)
 805    {
 806       if ( parmit->value != NULL && parmit->value->len > 0 )
 807       {
 808          parmcount++;
 809          msg->rm_Args[parmcount] = (RX_ARGTYPE)CreateArgstring( parmit->value->value, parmit->value->len );
 810       }
 811    }
 812    msg->rm_Action |= parmcount;
 813    msg->rm_Stdin = Input( );
 814    msg->rm_Stdout = Output( );
 815
 816    LockRexxBase(0);
 817
 818    for (rsrc = (struct RexxRsrc *)GetHead(&RexxSysBase->rl_LibList), result1 = 1;
 819         rsrc != NULL && result1 == 1;
 820         rsrc = (struct RexxRsrc *)GetSucc(rsrc)
 821    )
 822    {
 823       switch (rsrc->rr_Node.ln_Type)
 824       {
 825 #ifdef __AROS__
 826       case RRT_LIB:
 827          lib = OpenLibrary(rsrc->rr_Node.ln_Name, rsrc->rr_Arg2);
 828          if (lib == NULL)
 829          {
 830             UnlockRexxBase(0);
 831             ClearRexxMsg( msg, parmcount + 1 );
 832             DeleteRexxMsg( msg );
 833             exiterror( ERR_EXTERNAL_QUEUE, 0 );
 834          }
 835          /* Can not pass &result2 directly because on systems where
 836           * sizeof(IPTR)>sizeof(UBYTE *) this goes wrong
 837           */
 838          result1 = RexxCallQueryLibFunc(msg, lib, rsrc->rr_Arg1, &retstring);
 839          CloseLibrary(lib);
 840          result2 = (IPTR)retstring;
 841          break;
 842 #endif
 843
 844       case RRT_HOST:
 845          port = FindPort(rsrc->rr_Node.ln_Name);
 846          if (port == NULL)
 847          {
 848             UnlockRexxBase(0);
 849             ClearRexxMsg( msg, parmcount + 1 );
 850             DeleteRexxMsg( msg );
 851             exiterror( ERR_EXTERNAL_QUEUE, 0 );
 852          }
 853          sendandwait( TSD, port, msg);
 854
 855          result1 = (ULONG)msg->rm_Result1;
 856          result2 = msg->rm_Result2;
 857
 858       default:
 859          assert(FALSE);
 860       }
 861    }
 862
 863    UnlockRexxBase(0);
 864    ClearRexxMsg( msg, parmcount + 1 );
 865    DeleteRexxMsg( msg );
 866
 867    if ( result1 == 0 )
 868    {
 869       if ( (UBYTE *)result2 == NULL )
 870          retval = nullstringptr();
 871       else
 872       {
 873          retval = Str_ncre_TSD( TSD, (const char *)result2, LengthArgstring( (UBYTE *)result2 ) );
 874          DeleteArgstring( (UBYTE *)result2 );
 875       }
 876    }
 877    else if ( result1 == 1 )
 878       retval = NULL;
 879    else
 880       exiterror( ERR_EXTERNAL_QUEUE, 0 );
 881
 882    return retval;
 883 }
 884
 885
 886
 887 /* The clip handling functions for AROS/amiga: setclip, getclip */
 888
 889 streng *amiga_setclip( tsd_t *TSD, cparamboxptr parm1 )
 890 {
 891    cparamboxptr parm2;
 892    struct MsgPort *rexxport;
 893    struct RexxMsg *msg;
 894    streng *retval;
 895
 896    checkparam( parm1, 1, 2, "SETCLIP" );
 897    parm2 = parm1->next;
 898
 899    msg = createreginamessage( TSD );
 900    if ( msg == NULL )
 901       exiterror( ERR_STORAGE_EXHAUSTED, 0 );
 902
 903    if ( parm2 == NULL || parm2->value == NULL || parm2->value->len == 0 )
 904    {
 905       msg->rm_Action = RXREMCON;
 906       msg->rm_Args[0] = (RX_ARGTYPE)str_of( TSD, parm1->value );
 907    }
 908    else
 909    {
 910       msg->rm_Action = RXADDCON;
 911       msg->rm_Args[0] = (RX_ARGTYPE)str_of( TSD, parm1->value );
 912       msg->rm_Args[1] = (RX_ARGTYPE)parm2->value->value;
 913       msg->rm_Args[2] = (RX_ARGTYPE)parm2->value->len;
 914    }
 915
 916    rexxport = FindPort( "REXX" );
 917    if ( rexxport == NULL )
 918    {
 919       Free_TSD( TSD, (void *)msg->rm_Args[0] );
 920       DeleteRexxMsg( msg );
 921       exiterror( ERR_EXTERNAL_QUEUE, 0 );
 922    }
 923    sendandwait( TSD, rexxport, msg );
 924
 925    Free_TSD( TSD, (void *)msg->rm_Args[0] );
 926
 927    retval = ( msg->rm_Result1 == 0 ) ? Str_cre_TSD( TSD, "1" ) : Str_cre_TSD( TSD, "0" );
 928    DeleteRexxMsg( msg );
 929
 930    return retval;
 931 }
 932
 933 streng *amiga_getclip( tsd_t *TSD, cparamboxptr parm1 )
 934 {
 935    struct RexxRsrc *rsrc;
 936    char *name;
 937
 938    checkparam( parm1, 1, 1, "GETCLIP" );
 939
 940    name = str_of( TSD, parm1->value );
 941
 942    LockRexxBase(0);
 943    rsrc = (struct RexxRsrc *)FindName( &RexxSysBase->rl_ClipList, name );
 944    UnlockRexxBase(0);
 945
 946    Free_TSD( TSD, name );
 947
 948    if ( rsrc == NULL )
 949       return nullstringptr();
 950    else
 951    {
 952       void *arg1 = (void *)rsrc->rr_Arg1;
 953       return Str_ncre_TSD( TSD, arg1, LengthArgstring( arg1 ) );
 954    }
 955 }
 956
 957 streng *amiga_pragma( tsd_t *TSD, cparamboxptr parm1 )
 958 {
 959    cparamboxptr parm2;
 960    streng *retval = NULL;
 961    static char buf[1024];
 962
 963    checkparam( parm1, 1, 2, "PRAGMA" );
 964    parm2 = parm1->next;
 965
 966    switch( getoptionchar( TSD, parm1->value, "PRAGMA", 1, "", "DPIS" ) )
 967    {
 968    case 'D':
 969       {
 970          BPTR lock = CurrentDir( BNULL );
 971
 972          NameFromLock( lock, buf, 1023 );
 973          CurrentDir( lock );
 974          retval = Str_cre_TSD( TSD, buf );
 975          if ( parm2 != NULL && parm2->value != NULL && parm2->value->len != 0 )
 976          {
 977             struct FileInfoBlock *fib;
 978             char *name = str_of( TSD, parm2->value );
 979
 980             lock = Lock( name, ACCESS_READ );
 981
 982             Free_TSD( TSD, name );
 983
 984             fib = AllocDosObject( DOS_FIB, NULL );
 985             if ( fib == NULL )
 986             {
 987                if ( lock != BNULL )
 988                   UnLock( lock );
 989                exiterror( ERR_STORAGE_EXHAUSTED, 0 );
 990             }
 991
 992             if ( lock != BNULL )
 993                Examine( lock, fib );
 994
 995             if ( lock == BNULL || fib->fib_DirEntryType <= 0 )
 996             {
 997                FreeDosObject( DOS_FIB, fib );
 998                Free_string_TSD( TSD, retval );
 999                retval = nullstringptr();
1000             }
1001             else
1002             {
1003                UnLock( CurrentDir( lock ) );
1004                FreeDosObject( DOS_FIB, fib );
1005             }
1006          }
1007       }
1008       break;
1009
1010    case 'P':
1011       {
1012          struct Task *task = FindTask( NULL );
1013          retval = int_to_streng( TSD, (int)task->tc_Node.ln_Pri );
1014          if ( parm2 != NULL && parm2->value != NULL && parm2->value->len != 0 )
1015          {
1016             int pri, error;
1017             pri = streng_to_int( TSD, parm2->value, &error );
1018             if ( error )
1019                exiterror( ERR_INCORRECT_CALL, 11, "PRAGMA", 2, tmpstr_of( TSD, parm2->value ) );
1020             if ( abs(pri) > 127 )
1021                exiterror( ERR_INCORRECT_CALL, 0 );
1022             SetTaskPri( task, pri );
1023          }
1024       }
1025       break;
1026
1027    case 'I':
1028       {
1029          char s[10];
1030          sprintf(s, "%8lx", (unsigned long)FindTask( NULL ) );
1031          if ( parm2 != NULL && parm2->value != NULL )
1032             exiterror( ERR_INCORRECT_CALL, 4, "PRAGMA", 1 );
1033          retval = Str_cre_TSD( TSD, s );
1034       }
1035       break;
1036
1037    case 'S':
1038       {
1039          struct Process *process = (struct Process *)FindTask( NULL );
1040          ULONG size = (ULONG)((char *)process->pr_Task.tc_SPUpper - (char *)process->pr_Task.tc_SPLower);
1041          retval = int_to_streng( TSD, size );
1042          /* FIXME: second argument ignored because stack size increase is not implemented
1043           */
1044       }
1045       break;
1046    }
1047
1048    return retval;
1049 }
1050
1051
1052 /* Support functions for os_amiga.c
1053    They are defined here so data can be stored in amiga_tsd_t, that is only
1054    defined in this file.
1055 */
1056 int __amiga_ptr2int(const tsd_t *TSD, void *ptr)
1057 {
1058    amiga_tsd_t *atsd = (amiga_tsd_t *)TSD->ami_tsd;
1059    int i;
1060
1061    for ( i = 0; i < PTRS_SIZE && atsd->ptrs[i] != NULL; i++ )
1062       /* NOP */;
1063
1064    if ( i == PTRS_SIZE )
1065       return -1;
1066    else
1067    {
1068       atsd->ptrs[i] = ptr;
1069       return i + 1;
1070    }
1071 }
1072
1073 void *__amiga_getptr(const tsd_t *TSD, int index)
1074 {
1075    amiga_tsd_t *atsd = (amiga_tsd_t *)TSD->ami_tsd;
1076
1077    return atsd->ptrs[index - 1];
1078 }
1079
1080 void __amiga_clearptr(const tsd_t *TSD, int index)
1081 {
1082    amiga_tsd_t *atsd = (amiga_tsd_t *)TSD->ami_tsd;
1083
1084    atsd->ptrs[index - 1] = NULL;
1085 }
1086 #endif