Annotation of rpl/src/rplexternals.h, revision 1.76

1.1       bertrand    1: /*
                      2: ================================================================================
1.73      bertrand    3:   RPL/2 (R) version 4.1.27
1.72      bertrand    4:   Copyright (C) 1989-2017 Dr. BERTRAND Joël
1.1       bertrand    5: 
                      6:   This file is part of RPL/2.
                      7: 
                      8:   RPL/2 is free software; you can redistribute it and/or modify it
                      9:   under the terms of the CeCILL V2 License as published by the french
                     10:   CEA, CNRS and INRIA.
                     11:  
                     12:   RPL/2 is distributed in the hope that it will be useful, but WITHOUT
                     13:   ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or
                     14:   FITNESS FOR A PARTICULAR PURPOSE.  See the CeCILL V2 License
                     15:   for more details.
                     16:  
                     17:   You should have received a copy of the CeCILL License
                     18:   along with RPL/2. If not, write to info@cecill.info.
                     19: ================================================================================
                     20: */
                     21: 
                     22: 
                     23: #ifndef INCLUSION_RPLARGS
                     24: #  define INCLUSION_RPLARGS
                     25: 
                     26: /*
                     27: ================================================================================
                     28:   INCLUSIONS
                     29: ================================================================================
                     30: */
                     31: 
1.74      bertrand   32: // Si TYPE_DECLARATION est défini, toutes les structures internes du RPL/2
                     33: // sont exposés pour travailler sur des nouveaux types de données.
                     34: #  ifndef TYPE_DECLARATION
                     35: #      define RPLARGS
                     36: #      define struct_processus void
                     37: #  endif
                     38: 
1.1       bertrand   39: #  include "rpl.h"
                     40: 
                     41: /*
                     42: ================================================================================
                     43:   MACROS SPECIFIQUES
                     44: ================================================================================
                     45: */
                     46: 
1.52      bertrand   47: #define __RPL__ struct_rpl_arguments *rpl_arguments; \
                     48:    rpl_arguments = &__static_rpl_arguments;
                     49: 
1.47      bertrand   50: #define __CATCH_SYSTEM_ERROR__ \
                     51:        do { if (((*rpl_arguments).erreur != 0) && \
                     52:                ((*rpl_arguments).type_erreur == 'S')) \
                     53:            return 0; } while(0)
                     54: #define leave do { return(0); } while(0)
1.74      bertrand   55: #define _allocation(a) librpl_allocation((*rpl_arguments).s_etat_processus, a)
                     56: #define _copie_objet(a, b) librpl_copie_objet( \
1.8       bertrand   57:            (*rpl_arguments).s_etat_processus, a, b)
1.74      bertrand   58: #define _liberation(a) librpl_liberation((*rpl_arguments).s_etat_processus, a)
1.1       bertrand   59: 
1.52      bertrand   60: #ifdef __RPLC_MAIN
                     61:    struct_rpl_arguments __static_rpl_arguments;
                     62: #  define global
                     63: #  define initialize(a, b) a = b
1.58      bertrand   64: #  define declarePersistantObject(rpl_object) declareObject(rpl_object)
1.52      bertrand   65: #else
                     66:    extern struct_rpl_arguments __static_rpl_arguments;
                     67: #  define global extern
                     68: #  define initialize(a, b) a;
1.58      bertrand   69: #  define declarePersistantObject(rpl_object) extern struct_objet *rpl_object
1.52      bertrand   70: #endif
                     71: 
                     72: #define    empty int
                     73: 
1.1       bertrand   74: /*
                     75: --------------------------------------------------------------------------------
1.74      bertrand   76:   Gestion des objets
                     77: --------------------------------------------------------------------------------
                     78: */
                     79: 
                     80: // new, dup, drop, disp, parse
                     81: // __type_new(struct_rpl_arguments *rpl_arguments)
                     82: #define declareTypeExtension(fct) \
1.75      bertrand   83:        int __type_##fct(struct_processus *s_etat_processus, void **arg) { \
                     84:            char *rptr, *ptr, *iptr; \
                     85:            rptr = (char *) ((*s_etat_processus).definitions_chainees + \
                     86:                    (*s_etat_processus).position_courante); \
1.74      bertrand   87:            ptr = rptr; \
1.75      bertrand   88:            iptr = (char *) (*s_etat_processus).instruction_courante; \
                     89:            if ((ptr != rptr) && (iptr)) goto __parse_error;
1.74      bertrand   90: #define parseError { goto __parse_error; } while(0)
1.75      bertrand   91: #define typeError { return(0); } while(0)
1.76    ! bertrand   92: #define typeSuccess { return(1); } while(0)
1.75      bertrand   93: #define typeFound(a) { return(a); } while(0)
1.74      bertrand   94: #define endTypeExtension __parse_error: return(0); }
                     95: #define sizeOfParse    (rptr - ptr)
1.76    ! bertrand   96: #define searchType(...) { recherche_type(s_etat_processus); \
1.75      bertrand   97:            if (((*s_etat_processus).erreur_execution != d_ex) || \
                     98:                    ((*s_etat_processus).erreur_systeme != d_es)) \
1.76    ! bertrand   99:                { __VA_ARGS__; return(0); } } while(0)
1.74      bertrand  100: 
                    101: /*
                    102: --------------------------------------------------------------------------------
1.1       bertrand  103:   Types
                    104: --------------------------------------------------------------------------------
                    105: */
                    106: 
1.58      bertrand  107: #define declareObject(rpl_object) struct_objet *rpl_object = NULL
1.1       bertrand  108: #define declareInteger(integer) integer8 integer
                    109: #define declareReal(real) real8 real
                    110: #define declareComplex(complex) complex16 complex
                    111: #define declareDaisyChain(daisyChain) struct_liste_chainee *daisyChain = NULL
                    112: 
1.47      bertrand  113: #define getDaisyChainFromList(list, daisyChain)    \
                    114:    __CATCH_SYSTEM_ERROR__; \
                    115:    do { \
1.1       bertrand  116:    typeof(list) __list = list; \
                    117:    daisyChain = NULL; \
                    118:    ifIsList(__list) { daisyChain = (*__list).objet; } \
                    119:    else executionError("Type mistmatch error"); } while(0)
                    120: 
                    121: #define fetchElementFromDaisyChain(daisyChain) \
1.47      bertrand  122:    ({ __CATCH_SYSTEM_ERROR__; typeof(daisyChain) __daisyChain = daisyChain; \
1.1       bertrand  123:    if (__daisyChain == NULL) executionError("End of daisy chain"); \
                    124:    (__daisyChain == NULL) ? NULL : (*__daisyChain).donnee; })
                    125: 
                    126: #define replaceElementIntoDaisyChain(daisyChain, element) \
1.47      bertrand  127:    __CATCH_SYSTEM_ERROR__; \
1.1       bertrand  128:    do { typeof(daisyChain) __daisyChain = daisyChain; \
                    129:    if (__daisyChain == NULL) executionError("Nullified daisy chain"); \
1.45      bertrand  130:    freeObject((*__daisyChain).donnee); \
1.1       bertrand  131:    (*__daisyChain).donnee = element; } while(0)
                    132: 
                    133: #define nextElementOfDaisyChain(daisyChain) \
1.47      bertrand  134:    ({ __CATCH_SYSTEM_ERROR__; typeof(daisyChain) __daisyChain = daisyChain; \
1.1       bertrand  135:    if (__daisyChain == NULL) executionError("End of daisy chain"); \
                    136:    (__daisyChain == NULL) ? NULL : (*__daisyChain).suivant; })
                    137:    
                    138: #define null NULL
1.47      bertrand  139: #define nullify(ptr) __CATCH_SYSTEM_ERROR__; do { ptr = NULL; } while(0)
1.1       bertrand  140: #define nullified(ptr) ((ptr) == NULL)
                    141: 
                    142: #define postIncr(x) (x++)
                    143: #define preIncr(x) (++x)
                    144: #define postDecr(x) (x--)
                    145: #define preDecr(x) (--x)
                    146: 
                    147: #define eq ==
                    148: #define ne !=
                    149: #define ge >=
                    150: #define gt >
                    151: #define le <=
                    152: #define lt <
                    153: #define not !
                    154: #define and &&
                    155: #define or ||
                    156: #define false 0
                    157: #define true -1
                    158: 
                    159: #define setFalse(a) a = false
                    160: #define setTrue(a) a = true
                    161: 
                    162: #define logical int
                    163: #define string char *
                    164: #define integer int
                    165: 
                    166: #define declareStructure typedef struct {
                    167: #define declareUnion typedef union {
                    168: #define as(name) } name;
                    169: 
                    170: #define target(a) (*a)
                    171: #define address(a) (&a)
                    172: 
1.65      bertrand  173: #define subroutine(name) int name()
1.47      bertrand  174: #define beginGroup { __CATCH_SYSTEM_ERROR__;
                    175: #define endGroup __CATCH_SYSTEM_ERROR__; }
1.46      bertrand  176: #define beginMacro do beginGroup
1.1       bertrand  177: #define endMacro endGroup while(0)
1.58      bertrand  178: #define stopRequest ({ __CATCH_SYSTEM_ERROR__; \
                    179:        test_arret((*rpl_arguments).s_etat_processus); })
1.1       bertrand  180: 
                    181: /*
                    182: --------------------------------------------------------------------------------
1.44      bertrand  183:   Signaux
                    184: --------------------------------------------------------------------------------*/
                    185: 
                    186: #define blockSignals \
1.47      bertrand  187:    { __CATCH_SYSTEM_ERROR__; sigset_t set, oldset; sigfillset(&set); \
1.44      bertrand  188:    pthread_sigmask(SIG_BLOCK, &set, &oldset);
                    189: #define unblockSignals \
1.47      bertrand  190:    pthread_sigmask(SIG_SETMASK, &oldset, NULL); __CATCH_SYSTEM_ERROR__; }
1.44      bertrand  191: 
                    192: /*
                    193: --------------------------------------------------------------------------------
1.1       bertrand  194:   Constructeurs
                    195: --------------------------------------------------------------------------------
                    196: */
                    197: 
1.31      bertrand  198: #define DISABLE_SET_BUT_NOT_USED_WARNING(a) if (&a != ((&a) + 1));
                    199: 
1.1       bertrand  200: #define HEADER \
                    201:    int             __constante; \
                    202:    logical1        __evaluation; \
                    203:    logical1        __validation_instruction = d_faux; \
                    204:    logical1        __presence_aide = d_faux; \
                    205:    logical1        __presence_validation = d_faux; \
                    206:    unsigned char   __indice_bit; \
                    207:    unsigned char   __indice_bloc; \
                    208:    unsigned char   __taille_bloc; \
                    209:    unsigned char   __type; \
                    210:    t_8_bits        __masque; \
                    211:    { \
                    212:        (*rpl_arguments).instruction_valide = 'Y'; \
                    213:        (*rpl_arguments).erreur = 0; \
                    214:        __constante = 0; \
1.31      bertrand  215:        __evaluation = d_faux; \
                    216:        DISABLE_SET_BUT_NOT_USED_WARNING(__evaluation); \
                    217:        DISABLE_SET_BUT_NOT_USED_WARNING(__type); \
                    218:        DISABLE_SET_BUT_NOT_USED_WARNING(__indice_bit); \
                    219:        DISABLE_SET_BUT_NOT_USED_WARNING(__indice_bloc); \
                    220:        DISABLE_SET_BUT_NOT_USED_WARNING(__taille_bloc); \
                    221:        DISABLE_SET_BUT_NOT_USED_WARNING(__masque);
1.1       bertrand  222: 
                    223: #define FUNCTION \
1.47      bertrand  224:    if (__validation_instruction == d_vrai) return 0; \
1.1       bertrand  225:    if (__presence_aide == d_faux) \
                    226:    { \
                    227:        systemError("Help string not defined"); \
                    228:    } \
                    229:    else if (__presence_validation == d_faux) \
                    230:    { \
                    231:        systemError("Number of arguments not defined"); \
                    232:    } \
                    233:    __indice_bit = 0; \
                    234:    __indice_bloc = 0; \
                    235:    __taille_bloc = 0; \
                    236:    __type = 0; \
                    237:    __masque = 0; \
                    238:    {
                    239: 
                    240: #define END \
                    241:        strcpy((char *) __function_name, ""); \
                    242:        if (__constante != 0) \
                    243:            systemError("Constant definition error"); \
1.47      bertrand  244:        __CATCH_SYSTEM_ERROR__; \
1.1       bertrand  245:    } } \
1.47      bertrand  246:    leave;
1.1       bertrand  247: 
                    248: /*
                    249: --------------------------------------------------------------------------------
1.45      bertrand  250:   Destruction d'un objet
                    251: --------------------------------------------------------------------------------
                    252: */
                    253: 
1.58      bertrand  254: #define freeObject(rpl_object) \
1.47      bertrand  255:    __CATCH_SYSTEM_ERROR__; \
1.46      bertrand  256:    do { \
1.58      bertrand  257:        if (rpl_object == NULL) \
1.45      bertrand  258:            systemError("Nullified object"); \
1.74      bertrand  259:        _liberation(rpl_object); \
1.58      bertrand  260:        rpl_object = NULL; \
1.45      bertrand  261:    } while(0)
                    262: 
                    263: /*
                    264: --------------------------------------------------------------------------------
                    265:   Copie d'un objet
                    266: --------------------------------------------------------------------------------
                    267: */
                    268: 
1.58      bertrand  269: #define dupObject(rpl_object) \
1.47      bertrand  270:    __CATCH_SYSTEM_ERROR__; \
1.74      bertrand  271:    do { if (_copie_objet(rpl_object, 'P') != rpl_object) \
1.45      bertrand  272:        systemError("Memory allocation error"); } while(0)
                    273: 
                    274: /*
                    275: --------------------------------------------------------------------------------
                    276:   Déclaration des fonctions internes
                    277: --------------------------------------------------------------------------------
                    278: */
                    279: 
1.74      bertrand  280: #define CONCAT(a, b) __RPL_CONCAT(a, b)
                    281: #define __RPL_CONCAT(a, b) a##b
1.51      bertrand  282: #define FIRST(...) FIRST_HELPER(__VA_ARGS__, throwaway)
                    283: #define FIRST_HELPER(first, ...) first
                    284: #define REST(...) REST_HELPER(NUM(__VA_ARGS__), __VA_ARGS__)
                    285: #define REST_HELPER(qty, ...) REST_HELPER2(qty, __VA_ARGS__)
                    286: #define REST_HELPER2(qty, ...) REST_HELPER_##qty(__VA_ARGS__)
                    287: #define REST_HELPER_ONE(first)
                    288: #define REST_HELPER_TWOORMORE(first, ...) , __VA_ARGS__
                    289: #define NUM(...) \
                    290:        SELECT_10TH(__VA_ARGS__, TWOORMORE, TWOORMORE, TWOORMORE, TWOORMORE,\
                    291:        TWOORMORE, TWOORMORE, TWOORMORE, TWOORMORE, ONE, throwaway)
                    292: #define SELECT_10TH(a1, a2, a3, a4, a5, a6, a7, a8, a9, a10, ...) a10
                    293: 
                    294: #define declareInternalFunction(type, ...) \
                    295:    type CONCAT(__internal_, FIRST(__VA_ARGS__)) \
                    296:            (struct_rpl_arguments *rpl_arguments REST(__VA_ARGS__)) { \
                    297:    type __internal_return; __internal_return = 0; int __type; \
                    298:    DISABLE_SET_BUT_NOT_USED_WARNING(__type);
                    299: 
                    300: #define endInternalFunction return(__internal_return); }
                    301: 
                    302: #define useInternalFunction(type, ...) \
                    303:    type CONCAT(__internal_, FIRST(__VA_ARGS__)) \
                    304:            (struct_rpl_arguments *rpl_arguments REST(__VA_ARGS__))
1.45      bertrand  305: 
1.51      bertrand  306: #define callInternalFunction(...) \
                    307:    CONCAT(__internal_, FIRST(__VA_ARGS__))(rpl_arguments REST(__VA_ARGS__))
1.45      bertrand  308: 
                    309: /*
                    310: --------------------------------------------------------------------------------
1.47      bertrand  311:   Déclaration des fonctions C
                    312: --------------------------------------------------------------------------------
                    313: */
                    314: 
                    315: #define declareCFunction(type, name, ...) \
1.51      bertrand  316:        type name(__VA_ARGS__) { __RPL__ type __c_return;
                    317: #define endCFunction return(__c_return); }
1.47      bertrand  318: 
1.52      bertrand  319: #define useCFunction(type, name, ...) type name(__VA_ARGS__)
                    320: 
1.47      bertrand  321: /*
                    322: --------------------------------------------------------------------------------
1.1       bertrand  323:   Déclaration des fonctions externes
                    324: --------------------------------------------------------------------------------
                    325: */
                    326: 
                    327: #define declareExternalFunction(name) \
1.47      bertrand  328:    int __external_##name(struct_rpl_arguments *rpl_arguments) { \
1.45      bertrand  329:    char __function_name[] = "__external_"#name; \
                    330:    __static_rpl_arguments = (*rpl_arguments);
1.1       bertrand  331: 
                    332: #define useExternalFunction(function) \
1.47      bertrand  333:    int __external_##function(struct_rpl_arguments *rpl_arguments)
1.1       bertrand  334: 
                    335: #define libraryName(name) char __library_name[] = #name;
                    336: 
1.47      bertrand  337: #define __onLoading int __runOnLoading(struct_rpl_arguments *rpl_arguments)
                    338: #define __onClosing int __runOnClosing(struct_rpl_arguments *rpl_arguments)
1.1       bertrand  339: #define declareSubroutine(when) __##when { \
                    340:    char __function_name[] = #when; \
1.45      bertrand  341:    __static_rpl_arguments = (*rpl_arguments); \
1.1       bertrand  342:    HEADER \
                    343:        declareHelpString(""); \
                    344:        numberOfArguments(0); \
                    345:    FUNCTION
                    346: #define endSubroutine END }
                    347: 
1.47      bertrand  348: #define notice(s, ...) __CATCH_SYSTEM_ERROR__; \
                    349:        do { ufprintf(s, __VA_ARGS__); fflush(s); } while(0)
                    350: #define logger(...) __CATCH_SYSTEM_ERROR__; \
                    351:        do { syslog(LOG_NOTICE, __VA_ARGS__); } while(0) 
1.1       bertrand  352: 
                    353: #define exportExternalFunctions(...) \
1.47      bertrand  354:    char **__external_symbols(struct_rpl_arguments *rpl_arguments, \
                    355:            integer8 *nb_symbols, \
1.10      bertrand  356:            const char *version) { \
1.1       bertrand  357:        char arguments[] = #__VA_ARGS__; \
                    358:        char **tableau; \
                    359:        char *ptr1, *ptr2; \
                    360:        int drapeau; \
                    361:        unsigned long i; \
1.65      bertrand  362:        struct_processus *s_etat_processus; \
                    363:        s_etat_processus = (*rpl_arguments).s_etat_processus; \
1.10      bertrand  364:        if (strcmp(version, _d_version_rpl) != 0) \
                    365:        { \
1.15      bertrand  366:            notice(stdout, "Versions mismatch : library %s, expected %s\n", \
                    367:                    _d_version_rpl, version); \
1.10      bertrand  368:            (*nb_symbols) = -1; return(NULL); \
                    369:        } \
1.1       bertrand  370:        (*nb_symbols) = 0; ptr1 = arguments; drapeau = 0; \
                    371:        while((*ptr1) != 0) \
                    372:        { \
                    373:            if (((*ptr1) != ',') && ((*ptr1) != ' ')) drapeau = -1; \
                    374:            ptr1++; \
                    375:        } \
                    376:        if (drapeau == 0) return(NULL); \
                    377:        ptr1 = arguments; (*nb_symbols) = 1; \
                    378:        while((*ptr1) != 0) if ((*ptr1++) == ',') (*nb_symbols)++; \
                    379:        if ((tableau = malloc((*nb_symbols) * sizeof(char *))) == NULL) \
                    380:            return(NULL); \
                    381:        ptr2 = arguments; i = 0; \
                    382:        while(*ptr2 != 0) \
                    383:        { \
                    384:            while(((*ptr2) == ' ') || ((*ptr2) == ',')) ptr2++; \
                    385:            ptr1 = ptr2; \
                    386:            while(((*ptr2) != 0) && ((*ptr2) != ',') && ((*ptr2) != ' ')) \
                    387:                    ptr2++; \
                    388:            if ((tableau[i] = malloc((ptr2 + 2 + \
                    389:                    strlen(__library_name) - ptr1) * \
                    390:                    sizeof(unsigned char))) == NULL) \
                    391:                return(NULL); \
                    392:            sprintf(tableau[i], "%s$", __library_name); \
                    393:            strncat(&tableau[i][strlen(tableau[i])], ptr1, ptr2 - ptr1); \
                    394:            i++; \
                    395:            if ((*ptr2) != 0) \
                    396:            { \
                    397:                while((*ptr2) == ' ') ptr2++; \
                    398:                if ((*ptr2) == ',') ptr2++; \
                    399:            } \
                    400:        } \
                    401:        (*nb_symbols) = i; \
                    402:        return(tableau); \
                    403:    }
                    404: 
1.47      bertrand  405: #define endExternalFunction leave; }
1.1       bertrand  406: 
1.46      bertrand  407: #define callExternalFunction(function) do { \
1.47      bertrand  408:    __CATCH_SYSTEM_ERROR__; \
1.1       bertrand  409:    __taille_bloc = sizeof(t_8_bits) * 8; \
                    410:    __indice_bloc = (35 - 1) / __taille_bloc; \
                    411:    __indice_bit = (35 - 1) % __taille_bloc; \
                    412:    __masque = ((t_8_bits) 1) << (__taille_bloc - __indice_bit - 1); \
                    413:    __evaluation = ((*rpl_arguments).drapeaux_etat[__indice_bloc] & __masque) \
                    414:            ? d_vrai : d_faux; \
                    415:    __masque = ~(((t_8_bits) 1) << (__taille_bloc - __indice_bit - 1)); \
                    416:    (*rpl_arguments).drapeaux_etat[__indice_bloc] &= __masque; \
                    417:    __external_##function(rpl_arguments); \
                    418:    if (__evaluation == d_vrai) \
                    419:    { \
                    420:        __masque = ((t_8_bits) 1) << (__taille_bloc - __indice_bit - 1); \
                    421:        (*rpl_arguments).drapeaux_etat[__indice_bloc] |= __masque; \
                    422:    } \
                    423:    else \
                    424:    { \
                    425:        __masque = ~(((t_8_bits) 1) << (__taille_bloc - __indice_bit - 1)); \
                    426:        (*rpl_arguments).drapeaux_etat[__indice_bloc] &= __masque; \
                    427:    } } while(0)
                    428: 
                    429: /*
                    430: --------------------------------------------------------------------------------
                    431:   Macros spécifiques à l'en-tête
                    432: --------------------------------------------------------------------------------
                    433: */
                    434: 
1.46      bertrand  435: #define declareHelpString(h) do { \
1.1       bertrand  436:    __presence_aide = d_vrai; \
                    437:    if ((*rpl_arguments).affichage_arguments == 'Y') \
                    438:    { \
                    439:        uprintf("%s\n", h); \
1.47      bertrand  440:        return 0; \
1.1       bertrand  441:    } } while(0)
                    442: 
1.46      bertrand  443: #define declareSymbolicConstant do { \
1.1       bertrand  444:    numberOfArguments(0); \
                    445:    (*rpl_arguments).constante_symbolique = 'Y'; \
                    446:    __constante++; } while(0)
                    447: 
1.46      bertrand  448: #define numberOfArguments(n) do { \
1.1       bertrand  449:    __presence_validation = d_vrai; \
                    450:    if ((*rpl_arguments).test_instruction == 'Y') \
                    451:    { \
                    452:        if (n < 0) \
                    453:            systemError("Number of arguments must be positive or null"); \
                    454:        (*rpl_arguments).nombre_arguments = n; \
                    455:        __validation_instruction = d_vrai; \
                    456:    } \
                    457:    else \
                    458:    { \
                    459:        __taille_bloc = sizeof(t_8_bits) * 8; \
                    460:        __indice_bloc = (31 - 1) / __taille_bloc; \
                    461:        __indice_bit = (31 - 1) % __taille_bloc; \
                    462:        __masque = ((t_8_bits) 1) << (__taille_bloc - __indice_bit - 1); \
                    463:        if (((*rpl_arguments).drapeaux_etat[__indice_bloc] & __masque) != 0) \
                    464:        { \
                    465:            (*rpl_arguments).l_base_pile_last = \
                    466:                    sauvegarde_arguments(rpl_arguments, n); \
                    467:        } \
                    468:    } } while(0)
                    469: 
                    470: /*
                    471: --------------------------------------------------------------------------------
                    472:   Gestion des boucles
                    473: --------------------------------------------------------------------------------
                    474: */
                    475: 
                    476: #define loop(b, e, s) for(b; e; s) {
1.47      bertrand  477: #define endLoop __CATCH_SYSTEM_ERROR__; }
1.1       bertrand  478: 
                    479: #define repeatWhile(c) while(c) {
1.47      bertrand  480: #define endWhile __CATCH_SYSTEM_ERROR__; }
1.1       bertrand  481: 
                    482: #define doUntil do {
1.47      bertrand  483: #define repeatUntil(c) __CATCH_SYSTEM_ERROR__; } while(!(c));
1.1       bertrand  484: 
                    485: #define select(s) switch(s) {
1.47      bertrand  486: #define endSelect __CATCH_SYSTEM_ERROR__; }
1.1       bertrand  487: #define nonExclusiveCase(c) case c: {
1.47      bertrand  488: #define endNonExclusiveCase __CATCH_SYSTEM_ERROR__; }
1.1       bertrand  489: #define exclusiveCase(c) case c: {
1.47      bertrand  490: #define endExclusiveCase break; __CATCH_SYSTEM_ERROR__; }
1.1       bertrand  491: #define defaultCase default:
1.47      bertrand  492: #define endDefaultCase break; __CATCH_SYSTEM_ERROR__; }
1.1       bertrand  493: 
                    494: /*
                    495: --------------------------------------------------------------------------------
                    496:   Gestion des erreurs
                    497: --------------------------------------------------------------------------------
                    498: */
                    499: 
1.46      bertrand  500: #define returnOnError(...) do { \
1.1       bertrand  501:    if ((*rpl_arguments).erreur != 0) \
                    502:    { \
                    503:        __VA_ARGS__; \
1.47      bertrand  504:        return 0; \
1.1       bertrand  505:    } } while(0)
                    506: 
1.46      bertrand  507: #define systemError(message) do { \
1.1       bertrand  508:    (*rpl_arguments).erreur = __LINE__; \
                    509:    (*rpl_arguments).type_erreur = 'S'; \
                    510:    (*rpl_arguments).message_erreur = (unsigned char *) message; \
1.47      bertrand  511:    return 0; } while(0)
1.1       bertrand  512: 
1.46      bertrand  513: #define executionError(message) do { \
1.1       bertrand  514:    (*rpl_arguments).erreur = __LINE__; \
                    515:    (*rpl_arguments).type_erreur = 'E'; \
                    516:    (*rpl_arguments).message_erreur = (unsigned char *) message; } while(0)
                    517: 
1.46      bertrand  518: #define onSystemError(...) do { \
1.47      bertrand  519:    if (((*rpl_arguments).erreur != 0) && \
                    520:            ((*rpl_arguments).type_erreur == 'S')) \
1.45      bertrand  521:    { \
                    522:        blockSignals; \
                    523:            kill(getpid(), SIGTERM); \
                    524:        unblockSignals; \
1.47      bertrand  525:        __VA_ARGS__; \
1.45      bertrand  526:    } } while(0)
                    527: 
1.1       bertrand  528: #define onError(...) \
1.47      bertrand  529:    __CATCH_SYSTEM_ERROR__; \
1.1       bertrand  530:    do { if (((*rpl_arguments).type_erreur == 'E') && \
                    531:            ((*rpl_arguments).erreur != 0)) { __VA_ARGS__; \
                    532:            (*rpl_arguments).erreur = 0; } } while(0)
                    533: 
                    534: #define onExecution(...) \
1.47      bertrand  535:    __CATCH_SYSTEM_ERROR__; \
1.1       bertrand  536:    do { if (((*rpl_arguments).type_erreur == 'E') && \
                    537:            ((*rpl_arguments).erreur == 0)) { __VA_ARGS__; } } while(0)
                    538: 
                    539: /*
                    540: --------------------------------------------------------------------------------
                    541:   Gestion de la pile opérationnelle
                    542: --------------------------------------------------------------------------------
                    543: */
                    544: 
1.58      bertrand  545: #define pushOnStack(rpl_object) do { \
1.47      bertrand  546:    __CATCH_SYSTEM_ERROR__; \
1.1       bertrand  547:    if (((*rpl_arguments).l_base_pile = \
1.58      bertrand  548:            empilement_pile_operationnelle(rpl_arguments, rpl_object)) \
                    549:                    == NULL) \
1.1       bertrand  550:        systemError("Memory allocation error"); \
1.58      bertrand  551:    if ((*rpl_object).nombre_occurrences == 1) rpl_object = NULL; } while(0)
1.1       bertrand  552: 
1.58      bertrand  553: #define pullFromStack(rpl_object, ...) do { \
1.47      bertrand  554:    __CATCH_SYSTEM_ERROR__; \
1.1       bertrand  555:    (*rpl_arguments).l_base_pile = \
1.58      bertrand  556:            depilement_pile_operationnelle(rpl_arguments, &rpl_object); \
                    557:    if (rpl_object == NULL) \
1.1       bertrand  558:    { \
                    559:        executionError("Too few arguments"); \
                    560:    } \
                    561:    else \
                    562:    { \
                    563:        if (strlen(#__VA_ARGS__) == 0) \
                    564:        { \
                    565:            systemError("Undefined type"); \
                    566:        } \
                    567:        else \
                    568:        { \
                    569:            __type = 0; \
                    570:            if (strstr(#__VA_ARGS__, "integer") != NULL) \
1.58      bertrand  571:                if ((*rpl_object).type == INT) __type = 1; \
1.1       bertrand  572:            if (strstr(#__VA_ARGS__, "real") != NULL) \
1.58      bertrand  573:                if ((*rpl_object).type == REL) __type = 1; \
1.1       bertrand  574:            if (strstr(#__VA_ARGS__, "complex") != NULL) \
1.58      bertrand  575:                if ((*rpl_object).type == CPL) __type = 1; \
1.1       bertrand  576:            if (strstr(#__VA_ARGS__, "string") != NULL) \
1.58      bertrand  577:                if ((*rpl_object).type == CHN) __type = 1; \
1.1       bertrand  578:            if (strstr(#__VA_ARGS__, "list") != NULL) \
1.58      bertrand  579:                if ((*rpl_object).type == LST) __type = 1; \
1.1       bertrand  580:            if (strstr(#__VA_ARGS__, "unknown") != NULL) \
                    581:                __type = 1; \
                    582:            if (__type == 0) \
                    583:            { \
                    584:                executionError("Type not allowed"); \
                    585:            } \
                    586:        } \
                    587:    } } while(0)
                    588: 
                    589: /*
                    590: --------------------------------------------------------------------------------
                    591:   Gestion des objets
                    592: --------------------------------------------------------------------------------
                    593: */
                    594: 
                    595: #define then {
1.47      bertrand  596: #define endIf __CATCH_SYSTEM_ERROR__; }
                    597: #define elseIf __CATCH_SYSTEM_ERROR__; } else if
                    598: #define orElse __CATCH_SYSTEM_ERROR__; } else {
1.1       bertrand  599: 
                    600: // Constantes symboliques
                    601: 
1.58      bertrand  602: #define createSymbolicConstant(rpl_object, type, value) do { \
1.65      bertrand  603:    struct_processus *s_etat_processus; \
                    604:    s_etat_processus = (*rpl_arguments).s_etat_processus; \
1.1       bertrand  605:    if ((strcmp(#type, "integer") != 0) && (strcmp(#type, "real") != 0)) \
                    606:        systemError("Type not allowed for symbolic constant"); \
                    607:    __taille_bloc = sizeof(t_8_bits) * 8; \
                    608:    __indice_bloc = (35 - 1) / __taille_bloc; \
                    609:    __indice_bit = (35 - 1) % __taille_bloc; \
                    610:    __masque = ((t_8_bits) 1) << (__taille_bloc - __indice_bit - 1); \
                    611:    if (((*rpl_arguments).drapeaux_etat[__indice_bloc] & __masque) != 0) \
                    612:    { \
1.58      bertrand  613:        createNameObject(rpl_object); \
1.47      bertrand  614:        __CATCH_SYSTEM_ERROR__; \
1.1       bertrand  615:        { \
                    616:            char *__constant_name; \
                    617:            if ((__constant_name = malloc((strlen(__library_name) + \
                    618:                    strlen(__function_name) - 9) * sizeof(char))) == NULL) \
                    619:                systemError("Memory allocation error"); \
                    620:            sprintf(__constant_name, "%s$%s", __library_name, \
                    621:                    &(__function_name[11])); \
1.58      bertrand  622:            setName(rpl_object, __constant_name); \
1.1       bertrand  623:            free(__constant_name); \
                    624:        } \
                    625:    } \
                    626:    else \
                    627:    { \
                    628:        if (strcmp(#type, "integer") == 0) \
                    629:        { \
1.58      bertrand  630:            createIntegerObject(rpl_object); \
1.47      bertrand  631:            __CATCH_SYSTEM_ERROR__; \
1.58      bertrand  632:            setInteger(rpl_object, value); \
1.1       bertrand  633:        } \
                    634:        else if (strcmp(#type, "real") == 0) \
                    635:        { \
1.58      bertrand  636:            createRealObject(rpl_object); \
1.47      bertrand  637:            __CATCH_SYSTEM_ERROR__; \
1.58      bertrand  638:            setReal(rpl_object, value); \
1.1       bertrand  639:        } \
                    640:    } \
1.47      bertrand  641:    __CATCH_SYSTEM_ERROR__; \
1.1       bertrand  642:    __constante--; } while(0)
                    643: 
1.58      bertrand  644: #define createSymbolicComplexConstant(rpl_object, rp, ip) do { \
1.65      bertrand  645:    struct_processus *s_etat_processus; \
                    646:    s_etat_processus = (*rpl_arguments).s_etat_processus; \
1.1       bertrand  647:    __taille_bloc = sizeof(t_8_bits) * 8; \
                    648:    __indice_bloc = (35 - 1) / __taille_bloc; \
                    649:    __indice_bit = (35 - 1) % __taille_bloc; \
                    650:    __masque = ((t_8_bits) 1) << (__taille_bloc - __indice_bit - 1); \
                    651:    if (((*rpl_arguments).drapeaux_etat[__indice_bloc] & __masque) != 0) \
                    652:    { \
1.58      bertrand  653:        createNameObject(rpl_object); \
1.47      bertrand  654:        __CATCH_SYSTEM_ERROR__; \
1.1       bertrand  655:        { \
                    656:            char *__constant_name; \
                    657:            if ((__constant_name = malloc((strlen(__library_name) + \
                    658:                    strlen(__function_name) + 2) * sizeof(char))) == NULL) \
                    659:                systemError("Memory allocation error"); \
                    660:            sprintf(__constant_name, "%s$%s", __library_name, \
                    661:                    __function_name); \
1.58      bertrand  662:            setName(rpl_object, __constant_name); \
1.1       bertrand  663:            free(__constant_name); \
                    664:        } \
                    665:    } \
                    666:    else \
                    667:    { \
1.58      bertrand  668:        createComplexObject(rpl_object); \
1.47      bertrand  669:        __CATCH_SYSTEM_ERROR__; \
1.58      bertrand  670:        setComplex(rpl_object, rp, im); \
1.1       bertrand  671:    } \
1.47      bertrand  672:    __CATCH_SYSTEM_ERROR__; \
1.1       bertrand  673:    __constante--; } while(0)
                    674: 
                    675: // Integer
                    676: 
1.58      bertrand  677: #define setInteger(rpl_object, value) do { \
                    678:    ifIsInteger(rpl_object) \
1.1       bertrand  679:    { \
1.58      bertrand  680:        if ((*rpl_object).nombre_occurrences > 1) \
1.1       bertrand  681:        { \
1.58      bertrand  682:            struct_objet *__tmp_rpl_object; \
1.74      bertrand  683:            if ((__tmp_rpl_object = _copie_objet(rpl_object, 'O')) == NULL) \
1.1       bertrand  684:                systemError("Memory allocation error"); \
1.74      bertrand  685:            _liberation(rpl_object); \
1.58      bertrand  686:            rpl_object = __tmp_rpl_object; \
1.1       bertrand  687:        } \
1.58      bertrand  688:        (*((integer8 *) (*rpl_object).objet)) = (integer8) value; \
1.1       bertrand  689:    } \
                    690:    else executionError("Type mistmatch error"); } while(0)
                    691: 
1.58      bertrand  692: #define isInteger(rpl_object) \
                    693:    ((*rpl_object).type == INT)
1.1       bertrand  694: 
1.58      bertrand  695: #define ifIsInteger(rpl_object) if (isInteger(rpl_object))
                    696: #define elseIfIsInteger(rpl_object) } else ifIsInteger(rpl_object)
1.1       bertrand  697: 
1.58      bertrand  698: #define getInteger(rpl_object, value) do { \
1.1       bertrand  699:    value = 0; \
1.58      bertrand  700:    ifIsInteger(rpl_object) value = (*((integer8 *) (*rpl_object).objet)); \
1.1       bertrand  701:    else executionError("Type mismatch error"); } while(0)
                    702: 
1.58      bertrand  703: #define createIntegerObject(rpl_object) do { \
                    704:    if (rpl_object != NULL) \
1.1       bertrand  705:        systemError("Reallocated object"); \
1.74      bertrand  706:    if ((rpl_object = _allocation(INT)) == NULL) \
1.1       bertrand  707:        systemError("Memory allocation error"); \
1.58      bertrand  708:    setInteger(rpl_object, 0); } while(0)
1.1       bertrand  709: 
                    710: // Real
                    711: 
1.58      bertrand  712: #define setReal(rpl_object, value) do { \
                    713:    ifIsReal(rpl_object) \
1.1       bertrand  714:    { \
1.58      bertrand  715:        if ((*rpl_object).nombre_occurrences > 1) \
1.1       bertrand  716:        { \
1.58      bertrand  717:            struct_objet *__tmp_rpl_object; \
1.74      bertrand  718:            if ((__tmp_rpl_object = _copie_objet(rpl_object, 'O')) == NULL) \
1.1       bertrand  719:                systemError("Memory allocation error"); \
1.74      bertrand  720:            _liberation(rpl_object); \
1.58      bertrand  721:            rpl_object = __tmp_rpl_object; \
1.1       bertrand  722:        } \
1.58      bertrand  723:        (*((real8 *) (*rpl_object).objet)) = (real8) value; \
1.1       bertrand  724:    } \
                    725:    else executionError("Type mistmatch error"); } while(0)
                    726: 
1.58      bertrand  727: #define isReal(rpl_object) \
                    728:    ((*rpl_object).type == REL)
1.1       bertrand  729: 
1.58      bertrand  730: #define ifIsReal(rpl_object) if (isReal(rpl_object))
                    731: #define elseIfIsReal(rpl_object) } else ifIsReal(rpl_object)
1.1       bertrand  732: 
1.58      bertrand  733: #define getReal(rpl_object, value) do { \
1.1       bertrand  734:    value = 0; \
1.58      bertrand  735:    ifIsReal(rpl_object) value = (*((real8 *) (*rpl_object).objet)); \
1.1       bertrand  736:    else executionError("Type mismatch error"); } while(0)
                    737: 
1.58      bertrand  738: #define createRealObject(rpl_object) do { \
                    739:    if (rpl_object != NULL) \
1.1       bertrand  740:        systemError("Reallocated object"); \
1.74      bertrand  741:    if ((rpl_object = _allocation(REL)) == NULL) \
1.1       bertrand  742:        systemError("Memory allocation error"); \
1.58      bertrand  743:    setReal(rpl_object, 0); } while(0)
1.1       bertrand  744: 
                    745: // Complex
                    746: 
1.58      bertrand  747: #define setComplex(rpl_object, rp, ip) do { \
1.1       bertrand  748:    typeof(rp) __rp = rp; \
                    749:    typeof(ip) __ip = ip; \
1.58      bertrand  750:    ifIsComplex(rpl_object) \
1.1       bertrand  751:    { \
1.58      bertrand  752:        if ((*rpl_object).nombre_occurrences > 1) \
1.1       bertrand  753:        { \
1.58      bertrand  754:            struct_objet *__tmp_rpl_object; \
1.74      bertrand  755:            if ((__tmp_rpl_object = _copie_objet(rpl_object, 'O')) == NULL) \
1.1       bertrand  756:                systemError("Memory allocation error"); \
1.74      bertrand  757:            _liberation(rpl_object); \
1.58      bertrand  758:            rpl_object = __tmp_rpl_object; \
1.1       bertrand  759:        } \
1.58      bertrand  760:        setRealPartOfComplex(rpl_object, __rp); \
                    761:        setImaginaryPartOfComplex(rpl_object, __ip); \
1.1       bertrand  762:    } \
                    763:    else executionError("Type mismatch error"); } while(0)
                    764: 
1.58      bertrand  765: #define setRealPartOfComplex(rpl_object, value) do { \
                    766:    if ((*rpl_object).nombre_occurrences > 1) \
1.1       bertrand  767:    { \
1.58      bertrand  768:        struct_objet *__tmp_rpl_object; \
1.74      bertrand  769:        if ((__tmp_rpl_object = _copie_objet(rpl_object, 'O')) == NULL) \
1.1       bertrand  770:            systemError("Memory allocation error"); \
1.74      bertrand  771:        _liberation(rpl_object); \
1.58      bertrand  772:        rpl_object = __tmp_rpl_object; \
1.1       bertrand  773:    } \
1.58      bertrand  774:    ifIsComplex(rpl_object) (*((complex16 *) (*rpl_object).objet)) \
                    775:            .partie_reelle = value; \
1.1       bertrand  776:    else executionError("Type mismatch error"); } while(0)
                    777: 
1.58      bertrand  778: #define setImaginaryPartOfComplex(rpl_object, value) do { \
                    779:    if ((*rpl_object).nombre_occurrences > 1) \
1.1       bertrand  780:    { \
1.58      bertrand  781:        struct_objet *__tmp_rpl_object; \
1.74      bertrand  782:        if ((__tmp_rpl_object = _copie_objet(rpl_object, 'O')) == NULL) \
1.1       bertrand  783:            systemError("Memory allocation error"); \
1.74      bertrand  784:        _liberation(rpl_object); \
1.58      bertrand  785:        rpl_object = __tmp_rpl_object; \
1.1       bertrand  786:    } \
1.58      bertrand  787:    (*((complex16 *) (*rpl_object).objet)).partie_imaginaire = value; \
1.1       bertrand  788:    else executionError("Type mismatch error"); } while(0)
                    789: 
1.58      bertrand  790: #define getRealPartOfComplex(rpl_object, value) \
                    791:    value = (*((complex16 *) (*rpl_object).objet)).partie_reelle
1.1       bertrand  792: 
1.58      bertrand  793: #define getImaginaryPartOfComplex(rpl_object, value) \
                    794:    value = (*((complex16 *) (*rpl_object).objet)).partie_imaginaire
1.1       bertrand  795: 
1.58      bertrand  796: #define isComplex(rpl_object) \
                    797:    ((*rpl_object).type == CPL)
1.1       bertrand  798: 
1.58      bertrand  799: #define ifIsComplex(rpl_object) if (isComplex(rpl_object))
                    800: #define elseIfIsComplex(rpl_object) } else ifIsComplex(rpl_object)
1.1       bertrand  801: 
1.58      bertrand  802: #define getComplex(rpl_object, value) do { \
1.1       bertrand  803:    value.partie_reelle = 0; \
                    804:    value.partie_imaginaire = 0; \
1.58      bertrand  805:    ifIsComplex(rpl_object) value = (*((complex16 *) (*rpl_object).objet)); \
1.1       bertrand  806:    else systemError("Not a complex"); } while(0)
                    807: 
1.58      bertrand  808: #define createComplexObject(rpl_object) do { \
                    809:    if (rpl_object != NULL) \
1.1       bertrand  810:        systemError("Reallocated object"); \
1.74      bertrand  811:    if ((rpl_object = _allocation(CPL)) == NULL) \
1.1       bertrand  812:        systemError("Memory allocation error"); \
1.58      bertrand  813:    setComplex(rpl_object, 0, 0); } while(0)
1.1       bertrand  814: 
                    815: // Generalized vectors
                    816: 
1.58      bertrand  817: #define createVectorObject(rpl_object, size, otype, structure, cat) do { \
1.1       bertrand  818:    integer8 i; \
1.65      bertrand  819:    struct_processus *s_etat_processus; \
                    820:    s_etat_processus = (*rpl_arguments).s_etat_processus; \
1.58      bertrand  821:    if (rpl_object != NULL) \
1.1       bertrand  822:        systemError("Reallocated object"); \
1.74      bertrand  823:    if ((rpl_object = _allocation(cat)) == NULL) \
1.1       bertrand  824:        systemError("Memory allocation error"); \
1.58      bertrand  825:    (*((structure *) (*rpl_object).objet)).taille = size; \
                    826:    if (((*((structure *) (*rpl_object).objet)).tableau = \
1.1       bertrand  827:            malloc(size * sizeof(otype))) == NULL) \
                    828:        systemError("Memory allocation error"); \
                    829:    if (cat != VCX) \
                    830:    { \
                    831:        if (cat == VIN) \
1.58      bertrand  832:            (*((structure *) (*rpl_object).objet)).type = 'I'; \
1.1       bertrand  833:        else \
1.58      bertrand  834:            (*((structure *) (*rpl_object).objet)).type = 'R'; \
                    835:        for(i = 0; i < size; ((otype *) (*((structure *) (*rpl_object).objet)) \
1.1       bertrand  836:                .tableau)[i++] = (otype) 0); \
                    837:    } \
                    838:    else \
                    839:    { \
1.58      bertrand  840:        (*((structure *) (*rpl_object).objet)).type = 'C'; \
1.1       bertrand  841:        for(i = 0; i < size; i++) \
                    842:        { \
1.58      bertrand  843:            ((complex16 *) (*((structure *) (*rpl_object).objet)).tableau)[i] \
1.1       bertrand  844:                    .partie_reelle = 0; \
1.58      bertrand  845:            ((complex16 *) (*((structure *) (*rpl_object).objet)).tableau)[i] \
1.1       bertrand  846:                    .partie_imaginaire = 0; \
                    847:        } \
                    848:    } } while(0)
                    849: 
                    850: // Integer vector
                    851: 
1.58      bertrand  852: #define setIntegerIntoVector(rpl_object, value, position) do { \
1.1       bertrand  853:    typeof(position) __position = position; \
1.58      bertrand  854:    ifIsIntegerVector(rpl_object) \
1.1       bertrand  855:    { \
1.58      bertrand  856:        if ((*rpl_object).nombre_occurrences > 1) \
1.1       bertrand  857:        { \
1.58      bertrand  858:            struct_objet *__tmp_rpl_object; \
1.74      bertrand  859:            if ((__tmp_rpl_object = _copie_objet(rpl_object, 'O')) == NULL) \
1.1       bertrand  860:                systemError("Memory allocation error"); \
1.74      bertrand  861:            _liberation(rpl_object); \
1.58      bertrand  862:            rpl_object = __tmp_rpl_object; \
1.1       bertrand  863:        } \
                    864:        __position--; \
                    865:        if ((__position < 0) || (__position >= (*((struct_vecteur *) \
1.58      bertrand  866:                (*rpl_object).objet)).taille)) \
1.1       bertrand  867:            { executionError("Element out of range"); } \
                    868:        else \
1.58      bertrand  869:            ((integer8 *) (*((struct_vecteur *) (*rpl_object).objet)).tableau) \
1.1       bertrand  870:                    [__position] = (integer8) value; \
                    871:    } \
                    872:    else executionError("Type mistmatch error"); } while(0)
                    873: 
1.58      bertrand  874: #define isIntegerVector(rpl_object) \
                    875:    ((*rpl_object).type == VIN)
1.1       bertrand  876: 
1.58      bertrand  877: #define ifIsIntegerVector(rpl_object) if (isIntegerVector(rpl_object))
                    878: #define elseIfIsIntegerVector(rpl_object) } else ifIsIntegerVector(rpl_object)
1.1       bertrand  879: 
1.58      bertrand  880: #define getIntegerFromVector(rpl_object, value, position) do { \
1.1       bertrand  881:    typeof(position) __position = position; \
                    882:    value = 0; \
1.58      bertrand  883:    ifIsIntegerVector(rpl_object) \
1.1       bertrand  884:    { \
                    885:        __position--; \
                    886:        if ((__position < 0) || (__position >= (*((struct_vecteur *) \
1.58      bertrand  887:                (*rpl_object).objet)).taille)) \
1.1       bertrand  888:            executionError("Element out of range"); \
                    889:        else \
1.58      bertrand  890:            value = ((integer8 *) (*((struct_vecteur *) (*rpl_object).objet)) \
1.1       bertrand  891:                .tableau)[__position]; \
                    892:    } \
                    893:    else executionError("Type mismatch error"); } while(0)
                    894: 
1.58      bertrand  895: #define createIntegerVectorObject(rpl_object, size) \
                    896:    createVectorObject(rpl_object, size, integer8, struct_vecteur, VIN)
1.1       bertrand  897: 
                    898: // Real vector
                    899: 
1.58      bertrand  900: #define setRealIntoVector(rpl_object, value, position) do { \
1.1       bertrand  901:    typeof(position) __position = position; \
1.58      bertrand  902:    ifIsRealVector(rpl_object) \
1.1       bertrand  903:    { \
1.58      bertrand  904:        if ((*rpl_object).nombre_occurrences > 1) \
1.1       bertrand  905:        { \
1.58      bertrand  906:            struct_objet *__tmp_rpl_object; \
1.74      bertrand  907:            if ((__tmp_rpl_object = _copie_objet(rpl_object, 'O')) == NULL) \
1.1       bertrand  908:                systemError("Memory allocation error"); \
1.74      bertrand  909:            _liberation(rpl_object); \
1.58      bertrand  910:            rpl_object = __tmp_rpl_object; \
1.1       bertrand  911:        } \
                    912:        __position--; \
                    913:        if ((__position < 0) || (__position >= (*((struct_vecteur *) \
1.58      bertrand  914:                (*rpl_object).objet)).taille)) \
1.1       bertrand  915:            { executionError("Element out of range"); } \
                    916:        else \
1.58      bertrand  917:            ((real8 *) (*((struct_vecteur *) (*rpl_object).objet)).tableau) \
1.1       bertrand  918:                    [__position] = (real8) value; \
                    919:    } \
                    920:    else executionError("Type mistmatch error"); } while(0)
                    921: 
1.58      bertrand  922: #define isRealVector(rpl_object) \
                    923:    ((*rpl_object).type == VRL)
1.1       bertrand  924: 
1.58      bertrand  925: #define ifIsRealVector(rpl_object) if (isRealVector(rpl_object))
                    926: #define elseIfIsRealVector(rpl_object) } else ifIsRealVector(rpl_object)
1.1       bertrand  927: 
1.58      bertrand  928: #define getRealFromVector(rpl_object, value, position) do { \
1.1       bertrand  929:    typeof(position) __position = position; \
                    930:    value = 0; \
1.58      bertrand  931:    ifIsRealVector(rpl_object) \
1.1       bertrand  932:    { \
                    933:        __position--; \
                    934:        if ((__position < 0) || (__position >= (*((struct_vecteur *) \
1.58      bertrand  935:                (*rpl_object).objet)).taille)) \
1.1       bertrand  936:            executionError("Element out of range"); \
1.58      bertrand  937:        value = ((real8 *) (*((struct_vecteur *) (*rpl_object).objet)) \
                    938:                .tableau)[__position]; \
1.1       bertrand  939:    } \
                    940:    else executionError("Type mismatch error"); } while(0)
                    941: 
1.58      bertrand  942: #define createRealVectorObject(rpl_object, size) \
1.65      bertrand  943:    createVectorObject(rpl_object, size, real8, struct_vecteur, VRL)
1.1       bertrand  944: 
                    945: // A FIXER
                    946: 
                    947: #define createComplexVectorObject
                    948: 
                    949: #define createIntegerMatrixObject
                    950: 
                    951: #define createRealMatrixObject
                    952: 
                    953: #define createComplexMatrixObject
                    954: 
                    955: // Binary integer
                    956: 
1.58      bertrand  957: #define setBinaryInteger(rpl_object, value) do { \
                    958:    ifIsBinaryInteger(rpl_object) \
1.1       bertrand  959:    { \
1.58      bertrand  960:        if ((*rpl_object).nombre_occurrences > 1) \
1.1       bertrand  961:        { \
1.58      bertrand  962:            struct_objet *__tmp_rpl_object; \
1.74      bertrand  963:            if ((__tmp_rpl_object = _copie_objet(rpl_object, 'O')) == NULL) \
1.1       bertrand  964:                systemError("Memory allocation error"); \
1.74      bertrand  965:            _liberation(rpl_object); \
1.58      bertrand  966:            rpl_object = __tmp_rpl_object; \
1.1       bertrand  967:        } \
1.58      bertrand  968:        (*((integer8 *) (*rpl_object).objet)) = (integer8) value; \
1.1       bertrand  969:    } \
                    970:    else executionError("Type mistmatch error"); } while(0)
                    971: 
1.58      bertrand  972: #define isBinaryInteger(rpl_object) \
                    973:    ((*rpl_object).type == BIN)
1.1       bertrand  974: 
1.58      bertrand  975: #define ifIsBinaryInteger(rpl_object) if (isBinaryInteger(rpl_object))
                    976: #define elseIfIsBinaryInteger(rpl_object) } else ifIsBinaryInteger(rpl_object)
1.1       bertrand  977: 
1.58      bertrand  978: #define getBinaryInteger(rpl_object, value) do { \
1.1       bertrand  979:    value = 0; \
1.58      bertrand  980:    ifIsBinaryInteger(rpl_object) value = \
                    981:            (*((integer8 *) (*rpl_object).objet)); \
1.1       bertrand  982:    else executionError("Type mismatch error"); } while(0)
                    983: 
1.58      bertrand  984: #define createBinaryIntegerObject(rpl_object) do { \
                    985:    if (rpl_object != NULL) \
1.1       bertrand  986:        systemError("Reallocated object"); \
1.74      bertrand  987:    if ((rpl_object = _allocation(BIN)) == NULL) \
1.1       bertrand  988:        systemError("Memory allocation error"); \
1.58      bertrand  989:    setBinaryInteger(rpl_object, 0); } while(0)
1.1       bertrand  990: 
                    991: // Name
                    992: 
1.58      bertrand  993: #define isName(rpl_object) \
                    994:    ((*rpl_object).type == NOM)
1.1       bertrand  995: 
1.58      bertrand  996: #define ifIsName(rpl_object) if (isName(rpl_object))
                    997: #define elseIfIsName(rpl_object)  } else if (isName(rpl_object))
1.1       bertrand  998: 
1.58      bertrand  999: #define setName(rpl_object, value) do { \
1.65      bertrand 1000:    struct_processus *s_etat_processus; \
                   1001:    s_etat_processus = (*rpl_arguments).s_etat_processus; \
1.58      bertrand 1002:    ifIsName(rpl_object) \
1.1       bertrand 1003:    { \
1.58      bertrand 1004:        if ((*rpl_object).nombre_occurrences > 1) \
1.1       bertrand 1005:        { \
1.58      bertrand 1006:            struct_objet *__tmp_rpl_object; \
1.74      bertrand 1007:            if ((__tmp_rpl_object = _copie_objet(rpl_object, 'O')) == NULL) \
1.1       bertrand 1008:                systemError("Memory allocation error"); \
1.74      bertrand 1009:            _liberation(rpl_object); \
1.58      bertrand 1010:            rpl_object = __tmp_rpl_object; \
1.1       bertrand 1011:        } \
1.58      bertrand 1012:        free((*((struct_nom *) (*rpl_object).objet)).nom); \
                   1013:        (*((struct_nom *) (*rpl_object).objet)).symbole = d_faux; \
                   1014:        if (((*((struct_nom *) (*rpl_object).objet)).nom = malloc( \
1.1       bertrand 1015:                (strlen(value) + 1) * sizeof(unsigned char))) == NULL) \
                   1016:            systemError("Memory allocation error"); \
1.58      bertrand 1017:        strcpy((char *) (*((struct_nom *) (*rpl_object).objet)).nom, \
1.1       bertrand 1018:                (char *) value); \
                   1019:    } \
                   1020:    else executionError("Type mistmatch error"); } while(0)
                   1021: 
1.59      bertrand 1022: #define setSymbolicName(rpl_object, value) do { \
                   1023:    setName(rpl_object, value); \
                   1024:    (*((struct_nom *) (*rpl_object).objet)).symbole = d_vrai; } while(0)
                   1025: 
1.58      bertrand 1026: #define createNameObject(rpl_object) do { \
1.65      bertrand 1027:    struct_processus *s_etat_processus; \
                   1028:    s_etat_processus = (*rpl_arguments).s_etat_processus; \
1.58      bertrand 1029:    if (rpl_object != NULL) \
1.1       bertrand 1030:        systemError("Reallocated object"); \
1.74      bertrand 1031:    if ((rpl_object = _allocation(NOM)) == NULL) \
1.1       bertrand 1032:        systemError("Memory allocation error"); \
1.58      bertrand 1033:    (*((struct_nom *) (*rpl_object).objet)).symbole = d_faux; \
                   1034:    if (((*((struct_nom *) (*rpl_object).objet)).nom = malloc( \
1.1       bertrand 1035:            sizeof(unsigned char))) == NULL) \
                   1036:        systemError("Memory allocation error"); \
1.58      bertrand 1037:    strcpy((char *) (*((struct_nom *) (*rpl_object).objet)).nom, ""); } while(0)
1.1       bertrand 1038: 
                   1039: // String
                   1040: 
1.58      bertrand 1041: #define isString(rpl_object) \
                   1042:    ((*rpl_object).type == CHN)
1.1       bertrand 1043: 
1.58      bertrand 1044: #define ifIsString(rpl_object) if (isString(rpl_object))
                   1045: #define elseIfIsString(rpl_object) else if (isString(rpl_object))
1.1       bertrand 1046: 
1.58      bertrand 1047: #define setString(rpl_object, string) do { \
1.65      bertrand 1048:    struct_processus *s_etat_processus; \
                   1049:    s_etat_processus = (*rpl_arguments).s_etat_processus; \
1.58      bertrand 1050:    ifIsString(rpl_object) \
1.1       bertrand 1051:    { \
1.48      bertrand 1052:        if (string == NULL) executionError("Nullified string"); else \
1.1       bertrand 1053:        { \
1.58      bertrand 1054:            if ((*rpl_object).nombre_occurrences > 1) \
1.48      bertrand 1055:            { \
1.58      bertrand 1056:                struct_objet *__tmp_rpl_object; \
1.74      bertrand 1057:                if ((__tmp_rpl_object = _copie_objet(rpl_object, 'O')) \
                   1058:                        == NULL) \
1.48      bertrand 1059:                    systemError("Memory allocation error"); \
1.74      bertrand 1060:                _liberation(rpl_object); \
1.58      bertrand 1061:                rpl_object = __tmp_rpl_object; \
1.48      bertrand 1062:            } \
1.58      bertrand 1063:            free((unsigned char *) (*rpl_object).objet); \
                   1064:            if (((*rpl_object).objet = malloc((strlen(string) + 1) * \
1.48      bertrand 1065:                    sizeof(unsigned char))) == NULL) \
1.1       bertrand 1066:                systemError("Memory allocation error"); \
1.58      bertrand 1067:            strcpy((char *) (*rpl_object).objet, string); \
1.1       bertrand 1068:        } \
                   1069:    } \
                   1070:    else executionError("Type mistmatch error"); } while(0)
                   1071: 
1.58      bertrand 1072: #define getString(rpl_object, string) do { \
1.1       bertrand 1073:    string = NULL; \
1.58      bertrand 1074:    ifIsString(rpl_object) string = (char *) (*rpl_object).objet; \
1.1       bertrand 1075:    else executionError("Type mismatch error"); } while(0)
                   1076: 
1.58      bertrand 1077: #define createStringObject(rpl_object) do { \
1.65      bertrand 1078:    struct_processus *s_etat_processus; \
                   1079:    s_etat_processus = (*rpl_arguments).s_etat_processus; \
1.58      bertrand 1080:    if (rpl_object != NULL) \
1.1       bertrand 1081:        systemError("Reallocated object"); \
1.74      bertrand 1082:    if ((rpl_object = _allocation(CHN)) == NULL) \
1.1       bertrand 1083:        systemError("Memory allocation error"); \
1.58      bertrand 1084:    if (((*rpl_object).objet = malloc(sizeof(unsigned char))) == NULL) \
1.1       bertrand 1085:        systemError("Memory allocation error"); \
1.58      bertrand 1086:    strcpy((char *) (*rpl_object).objet, ""); } while(0)
1.1       bertrand 1087: 
                   1088: // List
                   1089: 
1.58      bertrand 1090: #define isList(rpl_object) \
                   1091:    ((*rpl_object).type == LST)
1.1       bertrand 1092: 
1.58      bertrand 1093: #define ifIsList(rpl_object) if (isList(rpl_object))
                   1094: #define elseIfIsList(rpl_object) else if (isList(rpl_object))
1.1       bertrand 1095: 
1.58      bertrand 1096: #define createListObject(rpl_object) do { \
                   1097:    if (rpl_object != NULL) \
1.1       bertrand 1098:        systemError("Reallocated object"); \
1.74      bertrand 1099:    if ((rpl_object = _allocation(LST)) == NULL) \
1.1       bertrand 1100:        systemError("Memory allocation error"); \
1.58      bertrand 1101:    (*rpl_object).objet = NULL; } while(0)
1.1       bertrand 1102: 
1.58      bertrand 1103: #define addObjectToList(list, rpl_object) do { \
1.65      bertrand 1104:    struct_processus *s_etat_processus; \
                   1105:    s_etat_processus = (*rpl_arguments).s_etat_processus; \
1.1       bertrand 1106:    ifIsList(list) \
                   1107:    { \
1.58      bertrand 1108:        struct_objet *__tmp_rpl_object; \
1.74      bertrand 1109:        if ((__tmp_rpl_object = _copie_objet(list, 'N')) == NULL) \
1.1       bertrand 1110:            systemError("Memory allocation error"); \
1.74      bertrand 1111:        _liberation(list); \
1.58      bertrand 1112:        list = __tmp_rpl_object; \
1.1       bertrand 1113:        if ((*list).objet == NULL) \
                   1114:        { \
                   1115:            if (((*list).objet = malloc(sizeof(struct_liste_chainee))) \
                   1116:                    == NULL) \
                   1117:                systemError("Memory allocation error"); \
                   1118:            (*((struct_liste_chainee *) (*list).objet)).suivant = NULL; \
1.58      bertrand 1119:            (*((struct_liste_chainee *) (*list).objet)).donnee = rpl_object; \
1.1       bertrand 1120:        } \
                   1121:        else \
                   1122:        { \
                   1123:            struct_liste_chainee    *l_element_courant; \
                   1124:            l_element_courant = (*list).objet; \
                   1125:            while((*l_element_courant).suivant != NULL) \
                   1126:                l_element_courant = (*l_element_courant).suivant; \
                   1127:            if (((*l_element_courant).suivant = \
                   1128:                    malloc(sizeof(struct_liste_chainee))) == NULL) \
                   1129:                systemError("Memory allocation error"); \
                   1130:            l_element_courant = (*l_element_courant).suivant; \
                   1131:            (*l_element_courant).suivant = NULL; \
1.58      bertrand 1132:            (*l_element_courant).donnee = rpl_object; \
1.1       bertrand 1133:        } \
1.58      bertrand 1134:        rpl_object = NULL; \
1.1       bertrand 1135:    } \
                   1136:    else executionError("Type mistmatch error"); } while(0)
                   1137: 
1.58      bertrand 1138: #define insertObjectIntoList(list, rpl_object) do { \
1.65      bertrand 1139:    struct_processus *s_etat_processus; \
                   1140:    s_etat_processus = (*rpl_arguments).s_etat_processus; \
1.1       bertrand 1141:    ifIsList(list) \
                   1142:    { \
1.58      bertrand 1143:        struct_objet *__tmp_rpl_object; \
1.74      bertrand 1144:        if ((__tmp_rpl_object = _copie_objet(list, 'N')) == NULL) \
1.1       bertrand 1145:            systemError("Memory allocation error"); \
1.74      bertrand 1146:        _liberation(list); \
1.58      bertrand 1147:        list = __tmp_rpl_object; \
1.1       bertrand 1148:        if ((*list).objet == NULL) \
                   1149:        { \
                   1150:            if (((*list).objet = malloc(sizeof(struct_liste_chainee))) \
                   1151:                    == NULL) \
                   1152:                systemError("Memory allocation error"); \
                   1153:            (*((struct_liste_chainee *) (*list).objet)).suivant = NULL; \
1.58      bertrand 1154:            (*((struct_liste_chainee *) (*list).objet)).donnee = rpl_object; \
1.1       bertrand 1155:        } \
                   1156:        else \
                   1157:        { \
                   1158:            struct_liste_chainee    *l_element_courant; \
                   1159:            if ((l_element_courant = \
                   1160:                    malloc(sizeof(struct_liste_chainee))) == NULL) \
                   1161:                systemError("Memory allocation error"); \
1.58      bertrand 1162:            (*l_element_courant).donnee = rpl_object; \
1.1       bertrand 1163:            (*l_element_courant).suivant = (*list).objet; \
                   1164:            (*list).objet = l_element_courant; \
                   1165:        } \
1.58      bertrand 1166:        rpl_object = NULL; \
1.1       bertrand 1167:    } \
                   1168:    else executionError("Type mistmatch error"); } while(0)
                   1169: 
1.58      bertrand 1170: #define removeObjectFromList(list, rpl_object) do { \
1.65      bertrand 1171:    struct_processus *s_etat_processus; \
                   1172:    s_etat_processus = (*rpl_arguments).s_etat_processus; \
1.1       bertrand 1173:    ifIsList(list) \
                   1174:    { \
1.50      bertrand 1175:        if ((*list).objet != NULL) \
1.1       bertrand 1176:        { \
1.50      bertrand 1177:            struct_liste_chainee    *__current; \
                   1178:            struct_liste_chainee    *__previous; \
                   1179:            __current = (*list).objet; \
                   1180:            __previous = NULL; \
1.58      bertrand 1181:            if ((*__current).donnee == rpl_object) \
1.50      bertrand 1182:            { \
                   1183:                (*list).objet = (*__current).suivant; \
                   1184:            } \
                   1185:            else \
                   1186:            { \
                   1187:                while(__current != NULL) \
                   1188:                { \
1.58      bertrand 1189:                    if ((*__current).donnee == rpl_object) \
1.50      bertrand 1190:                    { \
                   1191:                        (*__previous).suivant = (*__current).suivant; \
                   1192:                        break; \
                   1193:                    } \
                   1194:                    __previous = __current; \
                   1195:                    __current = (*__current).suivant; \
                   1196:                } \
                   1197:            } \
1.74      bertrand 1198:            _liberation((*__current).donnee); \
1.50      bertrand 1199:            free(__current); \
                   1200:        } \
1.1       bertrand 1201:    } \
                   1202:    else executionError("Type mistmatch error"); } while(0)
                   1203: 
1.58      bertrand 1204: #define getObjectFromList(list, position, rpl_object)
1.1       bertrand 1205: 
1.58      bertrand 1206: #define putObjectIntoList(list, position, rpl_object)
1.1       bertrand 1207: 
1.58      bertrand 1208: #define getListFromList(list, position1, position2, rpl_object)
1.1       bertrand 1209: 
1.46      bertrand 1210: #define listLength(list, length) do { \
1.1       bertrand 1211:    if (list == NULL) executionError("Nullified object"); \
                   1212:    if ((*list).type != LST) \
                   1213:            executionError("Type mistmatch error"); \
                   1214:    { \
                   1215:        struct_liste_chainee        *l_element_courant; \
                   1216:        length = 0; \
                   1217:        l_element_courant = (*list).objet; \
                   1218:        while(l_element_courant != NULL) \
                   1219:        { \
                   1220:            l_element_courant = (*l_element_courant).suivant; \
                   1221:            length++; \
                   1222:        } \
                   1223:    } } while(0)
                   1224: 
                   1225: /*
                   1226: --------------------------------------------------------------------------------
                   1227:   Allocation mémoire
                   1228: --------------------------------------------------------------------------------
                   1229: */
                   1230: 
                   1231: #define size(a) sizeof(a)
                   1232: 
                   1233: #define allocate(a) ({ void *ptr; \
1.65      bertrand 1234:    struct_processus *s_etat_processus; \
                   1235:    s_etat_processus = (*rpl_arguments).s_etat_processus; \
1.1       bertrand 1236:    if ((ptr = malloc(a)) == NULL) \
                   1237:            systemError("Memory allocation error"); ptr; })
                   1238: 
1.69      bertrand 1239: #define reallocate(a, s) ({ void *ptr; \
                   1240:    struct_processus *s_etat_processus; \
                   1241:    s_etat_processus = (*rpl_arguments).s_etat_processus; \
                   1242:    if ((ptr = realloc(a, s)) == NULL) \
                   1243:            systemError("Memory allocation error"); ptr; })
                   1244: 
1.65      bertrand 1245: #define deallocate(a) do { \
                   1246:    struct_processus *s_etat_processus; \
                   1247:    s_etat_processus = (*rpl_arguments).s_etat_processus; \
                   1248:    free(a); } while(0)
1.1       bertrand 1249: 
                   1250: /*
                   1251: --------------------------------------------------------------------------------
1.30      bertrand 1252:   Récupération des interruptions et des signaux
                   1253: --------------------------------------------------------------------------------
                   1254: */
                   1255: 
                   1256: #define pollSignalsAndInterrupts() \
1.47      bertrand 1257:    __CATCH_SYSTEM_ERROR__; \
1.46      bertrand 1258:    do { scrutation_injection((*rpl_arguments).s_etat_processus); } while(0)
1.30      bertrand 1259: 
                   1260: /*
                   1261: --------------------------------------------------------------------------------
1.1       bertrand 1262:   Exécution d'une fonction intrinsèque
                   1263: --------------------------------------------------------------------------------
                   1264: */
                   1265: 
1.46      bertrand 1266: #define intrinsic(function) do { \
1.1       bertrand 1267:    int __status; \
1.47      bertrand 1268:    __CATCH_SYSTEM_ERROR__; \
1.5       bertrand 1269:    __status = wrapper_instruction_intrinseque( \
                   1270:            instruction_##function, rpl_arguments); \
1.1       bertrand 1271:    if (__status == 1) executionError(#function); \
                   1272:    if (__status == 2) systemError(#function); \
                   1273:    } while(0)
                   1274: 
                   1275: #endif
                   1276: 
                   1277: // vim: ts=4

CVSweb interface <joel.bertrand@systella.fr>