void ArraySet::AppendItemsReverse( ID_TYPE* pArray, vuint32 inCount ) { ID_TYPE* pNext = pArray; if( mpFinish + inCount >= mpStorageEnd ) // must be free place { ID_TYPE NewSize = (mpStorageEnd - mpStart) ? ID_TYPE( 2 * (mpStorageEnd - mpStart) ) : ID_TYPE( 100 ); Resize( NewSize ); } while( inCount-- ) *mpFinish++ = *pNext--; mIsSorted = false; }
void ArraySet::AppendSorted_321( ID_TYPE* inLeftFixedPtr, ID_TYPE* inRightDecrementedPtr ) { ID_TYPE ItemsToAppend = ID_TYPE(inRightDecrementedPtr - inLeftFixedPtr); ID_TYPE ItemsFree = ID_TYPE(mpStorageEnd - mpFinish); if( ItemsToAppend > ItemsFree ) // there is no place, reallocate. { // we have // we need more of that ID_TYPE NewSize = ID_TYPE((mpStorageEnd - mpStart) + (ItemsToAppend - ItemsFree)); Resize( NewSize ); } // COPY data: while( inLeftFixedPtr < inRightDecrementedPtr ) { #if 0 // TODO FIXME. RZ 215-03-03 I have try to add this check, but it is not such simple... Oops // PROBLEM is that we appending SORTED items, but ArraySet can be not sorted itself, so we cannot just compare. // // If we will try do this only if ArraySet is sorted it will work, but another PROBLEM. // I see that Empty ArraySet must have mIsSorted = true. Why not? Now it is false. // So this check will not work anyway if we starting AppendSorted() into empty ArraySet. Ops. // // And when it have one item it is still sorted. // But when we appending OTHER itmes using OTHER not AppendSorted_ algs, then may be // we can check if array is still sorted... #if _FBL_CHECK // in DEBUG MODE, we checking that the next value to append is bigger of prev. if( mIsSorted && mpFinish > mpStart ) // if we have at least one item in ArraySet { FBL_CHECK( *(mpFinish - 1) < *inRightDecrementedPtr ); } #endif // _FBL_CHECK #endif // 0 *mpFinish++ = *inRightDecrementedPtr--; } FBL_CHECK( mpFinish <= mpStorageEnd ); }
void ArraySet::AppendSorted_123( ID_TYPE* inLeftIncrementedPtr, ID_TYPE* inRightFixedPtr ) { ID_TYPE ItemsToAppend = ID_TYPE(inRightFixedPtr - inLeftIncrementedPtr); ID_TYPE ItemsFree = ID_TYPE(mpStorageEnd - mpFinish); if( ItemsToAppend > ItemsFree ) // there is no place, reallocate. { // we have // we need more of that ID_TYPE NewSize = ID_TYPE((mpStorageEnd - mpStart) + (ItemsToAppend - ItemsFree)); Resize( NewSize ); } // COPY data: memcpy( mpFinish, inLeftIncrementedPtr, ItemsToAppend ); // correct pointers of this ArraySet. mpFinish += ItemsToAppend; FBL_CHECK( mpFinish <= mpStorageEnd ); }
expv compile_intrinsic_call(ID id, expv args) { intrinsic_entry *ep = NULL; int found = 0; int nArgs = 0; int nIntrArgs = 0; int i; expv ret = NULL; expv a = NULL; TYPE_DESC tp = NULL, ftp; list lp; INTR_OPS iOps = INTR_END; const char *iName = NULL; expv kindV = NULL; int typeNotMatch = 0; int isVarArgs = 0; EXT_ID extid; if (SYM_TYPE(ID_SYM(id)) != S_INTR) { //fatal("%s: not intrinsic symbol", __func__); // declarea as intrinsic but not defined in the intrinc table SYM_TYPE(ID_SYM(id)) = S_INTR; if (args == NULL) { args = list0(LIST); } if (ID_TYPE(id) == NULL) implicit_declaration(id); tp = ID_TYPE(id); //tp = BASIC_TYPE_DESC(TYPE_SUBR); expv symV = expv_sym_term(F_FUNC, NULL, ID_SYM(id)); ftp = function_type(tp); TYPE_SET_INTRINSIC(ftp); extid = new_external_id_for_external_decl(ID_SYM(id), ftp); ID_TYPE(id) = ftp; PROC_EXT_ID(id) = extid; if (TYPE_IS_EXTERNAL(tp)){ ID_STORAGE(id) = STG_EXT; } else{ EXT_PROC_CLASS(extid) = EP_INTRINSIC; } ret = expv_cons(FUNCTION_CALL, tp, symV, args); return ret; } ep = &(intrinsic_table[SYM_VAL(ID_SYM(id))]); iOps = INTR_OP(ep); iName = ID_NAME(id); /* Count a number of argument, first. */ nArgs = 0; if (args == NULL) { args = list0(LIST); } FOR_ITEMS_IN_LIST(lp, args) { nArgs++; } /* Search an intrinsic by checking argument types. */ found = 0; for (; ((INTR_OP(ep) == iOps) && ((strcasecmp(iName, INTR_NAME(ep)) == 0) || !(isValidString(INTR_NAME(ep))))); ep++) { kindV = NULL; typeNotMatch = 0; isVarArgs = 0; /* Check a number of arguments. */ if (INTR_N_ARGS(ep) < 0 || INTR_N_ARGS(ep) == nArgs) { /* varriable args or no kind arg. */ if (INTR_N_ARGS(ep) < 0) { isVarArgs = 1; } nIntrArgs = nArgs; } else if (INTR_HAS_KIND_ARG(ep) && ((INTR_N_ARGS(ep) + 1) == nArgs)) { /* could be intrinsic call with kind arg. */ expv lastV = expr_list_get_n(args, nArgs - 1); if (lastV == NULL) { return NULL; /* error recovery */ } if (EXPV_KW_IS_KIND(lastV)) { goto gotKind; } tp = EXPV_TYPE(lastV); if (!(isValidType(tp))) { return NULL; /* error recovery */ } if (TYPE_BASIC_TYPE(tp) != TYPE_INT) { /* kind arg must be integer type. */ continue; } gotKind: nIntrArgs = INTR_N_ARGS(ep); kindV = lastV; } else { continue; } /* The number of arguments matchs. Then check types. */ for (i = 0; i < nIntrArgs; i++) { a = expr_list_get_n(args, i); if (a == NULL) { return NULL; /* error recovery */ } tp = EXPV_TYPE(a); if (!(isValidType(tp))) { //return NULL; /* error recovery */ continue; } if (compare_intrinsic_arg_type(a, tp, ((isVarArgs == 0) ? INTR_ARG_TYPE(ep)[i] : INTR_ARG_TYPE(ep)[0])) != 0) { /* Type mismatch. */ typeNotMatch = 1; break; } } if (typeNotMatch == 1) { continue; } else { found = 1; break; } } if (found == 1) { /* Yes we found an intrinsic to use. */ SYMBOL sp = NULL; expv symV = NULL; /* Then we have to determine return type. */ if (INTR_RETURN_TYPE(ep) != INTR_TYPE_NONE) { tp = get_intrinsic_return_type(ep, args, kindV); if (!(isValidType(tp))) { //fatal("%s: can't determine return type.", __func__); //return NULL; tp = BASIC_TYPE_DESC(TYPE_GNUMERIC_ALL); } } else { tp = BASIC_TYPE_DESC(TYPE_SUBR); } /* Finally find symbol for the intrinsic and make it expv. */ sp = find_symbol((char *)iName); if (sp == NULL) { fatal("%s: symbol '%s' is not created??", __func__, INTR_NAME(ep)); /* not reached */ return NULL; } symV = expv_sym_term(F_FUNC, NULL, sp); if (symV == NULL) { fatal("%s: symbol expv creation failure.", __func__); /* not reached */ return NULL; } ftp = function_type(tp); TYPE_SET_INTRINSIC(ftp); /* set external id for functionType's type ID. * dont call declare_external_id() */ extid = new_external_id_for_external_decl(ID_SYM(id), ftp); ID_TYPE(id) = ftp; PROC_EXT_ID(id) = extid; if(TYPE_IS_EXTERNAL(tp)){ ID_STORAGE(id) = STG_EXT; }else{ EXT_PROC_CLASS(extid) = EP_INTRINSIC; } ret = expv_cons(FUNCTION_CALL, tp, symV, args); } if (ret == NULL) { error_at_node((expr)args, "argument(s) mismatch for an intrinsic '%s()'.", iName); } return ret; }
/* * Returns like strcmp(). */ static int compare_intrinsic_arg_type(expv arg, TYPE_DESC tp, INTR_DATA_TYPE iType) { BASIC_DATA_TYPE bType; int ret = 1; int isArray = 0; if(IS_GNUMERIC_ALL(tp)) return 0; if (IS_ARRAY_TYPE(tp)) { while (IS_ARRAY_TYPE(tp)) { tp = TYPE_REF(tp); } isArray = 1; } bType = TYPE_BASIC_TYPE(tp); if (isArray == 1) { switch (iType) { case INTR_TYPE_ANY_ARRAY: { ret = 0; break; } case INTR_TYPE_INT_ARRAY: { if (bType == TYPE_INT || bType == TYPE_GNUMERIC || bType == TYPE_GNUMERIC_ALL) { ret = 0; } break; } case INTR_TYPE_REAL_ARRAY: { if (bType == TYPE_REAL || bType == TYPE_GNUMERIC || bType == TYPE_GNUMERIC_ALL) { ret = 0; } break; } case INTR_TYPE_DREAL_ARRAY: { if (type_is_possible_dreal(tp) || bType == TYPE_GNUMERIC || bType == TYPE_GNUMERIC_ALL) { ret = 0; } break; } case INTR_TYPE_ALL_REAL_ARRAY: { if (bType == TYPE_REAL || bType == TYPE_DREAL || bType == TYPE_GNUMERIC || bType == TYPE_GNUMERIC_ALL) { ret = 0; } break; } case INTR_TYPE_ALL_COMPLEX_ARRAY: case INTR_TYPE_COMPLEX_ARRAY: { if (bType == TYPE_COMPLEX || bType == TYPE_DCOMPLEX || bType == TYPE_GNUMERIC_ALL) { ret = 0; } break; } case INTR_TYPE_CHAR_ARRAY: { if (bType == TYPE_CHAR) { ret = 0; } break; } case INTR_TYPE_LOGICAL_ARRAY: { if (bType == TYPE_LOGICAL) { ret = 0; } break; } case INTR_TYPE_NUMERICS_ARRAY: { if (bType == TYPE_INT || bType == TYPE_REAL || bType == TYPE_DREAL || bType == TYPE_GNUMERIC || bType == TYPE_GNUMERIC_ALL) { ret = 0; } break; } case INTR_TYPE_ALL_NUMERICS_ARRAY: { if (bType == TYPE_INT || bType == TYPE_REAL || bType == TYPE_DREAL || bType == TYPE_GNUMERIC || bType == TYPE_COMPLEX || bType == TYPE_DCOMPLEX || bType == TYPE_GNUMERIC_ALL) { ret = 0; } break; } case INTR_TYPE_ANY_ARRAY_ALLOCATABLE: { if (TYPE_IS_ALLOCATABLE(tp)) { ret = 0; } break; } default: { goto DoCompareBasic; } } } else { DoCompareBasic: switch (iType) { case INTR_TYPE_ANY: { ret = 0; break; } case INTR_TYPE_INT: { if (bType == TYPE_INT || bType == TYPE_GNUMERIC || bType == TYPE_GNUMERIC_ALL) { ret = 0; } break; } case INTR_TYPE_REAL: { if (bType == TYPE_REAL || bType == TYPE_GNUMERIC || bType == TYPE_GNUMERIC_ALL) { ret = 0; } break; } case INTR_TYPE_DREAL: { if (type_is_possible_dreal(tp) || bType == TYPE_GNUMERIC || bType == TYPE_GNUMERIC_ALL) { ret = 0; } break; } case INTR_TYPE_ALL_REAL: { if (bType == TYPE_REAL || bType == TYPE_DREAL || bType == TYPE_GNUMERIC || bType == TYPE_GNUMERIC_ALL) { ret = 0; } break; } case INTR_TYPE_ALL_COMPLEX: case INTR_TYPE_COMPLEX: { if (bType == TYPE_COMPLEX || bType == TYPE_DCOMPLEX || bType == TYPE_GNUMERIC_ALL) { ret = 0; } break; } case INTR_TYPE_DCOMPLEX: { if (bType == TYPE_DCOMPLEX || bType == TYPE_GNUMERIC || bType == TYPE_GNUMERIC_ALL) { ret = 0; } break; } case INTR_TYPE_CHAR: { if (bType == TYPE_CHAR) { ret = 0; } break; } case INTR_TYPE_LOGICAL: { if (bType == TYPE_LOGICAL) { ret = 0; } break; } case INTR_TYPE_NUMERICS: { if (bType == TYPE_INT || bType == TYPE_REAL || bType == TYPE_DREAL || bType == TYPE_GNUMERIC) { ret = 0; } break; } case INTR_TYPE_ALL_NUMERICS: { if (bType == TYPE_INT || bType == TYPE_REAL || bType == TYPE_DREAL || bType == TYPE_GNUMERIC || bType == TYPE_COMPLEX || bType == TYPE_DCOMPLEX || bType == TYPE_GNUMERIC_ALL) { ret = 0; } break; } case INTR_TYPE_POINTER: case INTR_TYPE_TARGET: case INTR_TYPE_ANY_OPTIONAL: { ID id; TYPE_DESC argtp = NULL; switch(EXPV_CODE(arg)) { case(F_VAR): { id = find_ident(EXPV_NAME(arg)); if(id == NULL) break; argtp = ID_TYPE(id); } break; case(F95_MEMBER_REF): { if(iType != INTR_TYPE_ANY_OPTIONAL) argtp = EXPV_TYPE(arg); } break; default: { break; } } if(argtp == NULL) break; if(iType == INTR_TYPE_POINTER) { if(TYPE_IS_POINTER(argtp) == FALSE) break; } else if(iType == INTR_TYPE_TARGET) { if(TYPE_IS_TARGET(argtp) == FALSE) break; } else { if(TYPE_IS_OPTIONAL(argtp) == FALSE) break; } ret = 0; break; } default: { break; } } } return ret; }