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;
}
