/* assert_not_equal(a,b) becomes:
*
* if ((a) == (b)) then
* write(_message,*) "-a- is equal to -b-"
* funit_passed_ = .false.
* return
* end if
*/
static int generate_assert_not_equal(struct Code *macro)
{
struct Code *a = macro->u.m.args, *b;
if (check_assert_args("assert_not_equal", macro, a, 2) != 2)
return -1;
b = a->next;
fputs("! assert_not_equal()\n", fout);
fputs(" if ((", fout);
PRINT_CODE(a);
fputs(") == (", fout);
PRINT_CODE(b);
fputs(")) then\n", fout);
fputs(" write(funit_message_,*) \"'",fout);
print_macro_arg(a);
fputs("' (\", ", fout);
PRINT_CODE(a);
fputs(", &\n\") is equal to '", fout);
print_macro_arg(b);
fputs("'\"\n", fout);
fputs(" funit_passed_ = .false.\n", fout);
fputs(" return\n", fout);
fputs(" end if", fout);
return 0;
}
// o+o+o+o+o+o+o+o+o+o+o+o+o+o+o+o+o+o+o+o+o+o+o+o+o+o+o+o+o+o+o+o
void
BRTKernelDef::print(std::ostream& out, int) const
{
char name[1024];
if (Project::gDebug) {
out << "/* BRTKernelDef:" ;
location.printLocation(out) ;
out << " */" << std::endl;
}
assert(FunctionName());
assert(FunctionName()->entry);
assert(FunctionName()->entry->scope);
/* If the symbol for the generated assembly code already
** exists, don't generate the assembly. This allows the user
** to hand generate the code.
*/
#define PRINT_CODE(a,b) \
sprintf (name, "__%s_%s", FunctionName()->name.c_str(), #b); \
if (!FunctionName()->entry->scope->Lookup(name)) { \
if (globals.target & TARGET_##a) { \
BRTKernelCode *var; \
var = decl->isReduce() ? new BRT##a##ReduceCode(*this) : \
new BRT##a##KernelCode(*this); \
out << *var << std::endl; \
delete var; \
} else { \
out << "static const char *__" \
<< *FunctionName() << "_" << #b << "= NULL;\n"; \
} \
}
PRINT_CODE(PS20, ps20);
PRINT_CODE(FP30, fp30);
PRINT_CODE(ARB, arb);
PRINT_CODE(CPU, cpu);
#undef PRINT_CODE
/*
* XXX I have no idea why this is here instead of in
* BRTCPUKernel::print(). It's CPU only and needs to be suppressed when
* the CPU target is suppressed. --Jeremy.
* The scatter functions need to be there whether or not the CPU target is repressed
* For the fallback requirement --Daniel
*/
if (decl->isReduce()) {
BRTCPUReduceCode crc(*this);
BRTScatterDef sd(*crc.fDef);
sd.print(out,0);
// this is needed for CPU fallback for scatter whether or not CPU is enabled
}
printStub(out);
}
/* assert_equal_with(a,b[,tol]) becomes:
*
* if (abs((a) - (b)) > TOLERANCE) then
* write(_message,*) "-a- is not within", TOLERANCE, "of -b-"
* funit_passed_ = .false.
* return
* end if
*/
static int generate_assert_equal_with(struct Code *macro)
{
struct Code *a = macro->u.m.args, *b;
double this_tolerance;
int num_args;
num_args = check_assert_args2("assert_equal_with", macro, a, 2, 3);
if (num_args < 2) {
return -1;
}
b = a->next;
if (num_args == 2) {
if (tolerance <= 0.0) {
fprintf(stderr, "near %s:%li: missing a tolerance argument or "
"a set-level default tolerance\n",
test_set_file_name, macro->lineno);
return -1;
}
this_tolerance = tolerance;
} else if (num_args == 3) {
this_tolerance = strtod(b->next->u.c.str, NULL);
if (this_tolerance <= 0.0) {
fprintf(stderr, "near %s:%li: in assert_array_equal(): parsed "
"a tolerance <= 0.0; you need to fix that\n",
test_set_file_name, macro->lineno);
return -1;
}
}
fprintf(fout, "! assert_equal_with(%s)\n", (num_args == 3) ? "tol" : "");
fputs(" if (abs((", fout);
PRINT_CODE(a);
fputs(") - (", fout);
PRINT_CODE(b);
fprintf(fout, ")) > %g) then\n", this_tolerance);
fputs(" write(funit_message_,*) \"'",fout);
print_macro_arg(a);
fputs("' (\", ", fout);
PRINT_CODE(a);
fprintf(fout, ", &\n\") is not within %g of '", this_tolerance);
print_macro_arg(b);
fputs("'\"\n", fout);
fputs(" funit_passed_ = .false.\n", fout);
fputs(" return\n", fout);
fputs(" end if", fout);
return 0;
}
static void print_array_size_check(struct Code *a, struct Code *b)
{
fputs(" if (size(", fout);
PRINT_CODE(a);
fputs(") /= size(", fout);
PRINT_CODE(b);
fputs(")) then\n", fout);
fputs(" write(funit_message_,*) \"'",fout);
print_macro_arg(a);
fputs("' and '", fout);
print_macro_arg(b);
fputs("' &\n &are not the same length:\", size(", fout);
PRINT_CODE(a);
fputs("), \"vs.\", size(", fout);
PRINT_CODE(b);
fputs(")\n", fout);
fputs(" funit_passed_ = .false.\n", fout);
fputs(" return\n", fout);
fputs(" end if\n", fout);
}
/* assert_array_equal(a,b) becomes:
*
* if (size(a) /= size(b)) then
* write(funit_message_,*) "-a- is length", size(a), &
* "which is not the same as -b- which is length", size(b)
* funit_passed_ = .false.
* return
* end if
* do funit_i_ = 1,size(a)
* if (a(funit_i_) /= b(funit_i_)) then
* write(funit_message_,*) "-a-(", funit_i_, ") is not equal to -b-(", &
* funit_i_, "): ", a(funit_i_), "vs", b(funit_i_)
* funit_passed_ = .false.
* return
* end if
* end do
*/
static int generate_assert_array_equal(struct Code *macro)
{
struct Code *a = macro->u.m.args, *b;
if (check_assert_args("assert_array_equal", macro, a, 2) != 2)
return -1;
b = a->next;
fputs("! assert_array_equal()\n", fout);
print_array_size_check(a, b);
// do loop
fputs(" do funit_i_ = 1,size(", fout);
PRINT_CODE(a);
fputs(")\n", fout);
fputs(" if (", fout);
PRINT_CODE(a);
fputs("(funit_i_) /= ", fout);
PRINT_CODE(b);
fputs("(funit_i_)) then\n", fout);
fputs(" write(funit_message_,*) \"", fout);
print_macro_arg(a);
fputs("(\", funit_i_, &\n \") is not equal to ", fout);
print_macro_arg(b);
fputs("(\", funit_i_, &\n \"): \", ", fout);
PRINT_CODE(a);
fputs("(funit_i_), \"vs\", ", fout);
PRINT_CODE(b);
fputs("(funit_i_)\n", fout);
fputs(" funit_passed_ = .false.\n", fout);
fputs(" return\n", fout);
fputs(" end if\n", fout);
fputs(" end do", fout);
return 0;
}
/* flunk(msg) becomes:
*
* write(funit_message_,*) -msg-
* funit_passed_ = .false.
* return
*/
static int generate_flunk(struct Code *macro)
{
struct Code *arg = macro->u.m.args;
if (check_assert_args("flunk", macro, arg, 1) != 1)
return -1;
fputs("! flunk()\n", fout);
fputs(" write(funit_message_,*) ", fout);
PRINT_CODE(arg);
fputs("\n", fout);
fputs(" funit_passed_ = .false.\n", fout);
fputs(" return\n", fout);
return 0;
}
static int generate_code(struct Code *code)
{
switch (code->type) {
case FORTRAN_CODE:
PRINT_CODE(code);
break;
case MACRO_CODE:
if (generate_assert(code))
return -1;
break;
default: // arg code
fprintf(stderr, "near %s:%li: bad code type %i in generate_code\n",
test_set_file_name, code->lineno, (int)code->type);
abort();
break;
}
if (code->next)
return generate_code(code->next);
return 0;
}
/* assert_false(expr) becomes:
*
* if (-expr-) then
* write(_message,*) "-expr-", "is true"
* funit_passed_ = .false.
* return
* end if
*/
static int generate_assert_false(struct Code *macro)
{
struct Code *arg = macro->u.m.args;
if (check_assert_args("assert_false", macro, arg, 1) != 1)
return -1;
fputs("! assert_false()\n", fout);
fputs(" if (", fout);
PRINT_CODE(arg);
fputs(") then\n", fout);
fputs(" write(funit_message_,*) \"'", fout);
print_macro_arg(arg);
fputs("' is true\"\n", fout);
fputs(" funit_passed_ = .false.\n", fout);
fputs(" return\n", fout);
fputs(" end if", fout);
return 0;
}
/* assert_array_equal_with(a,b[,tol]) becomes:
*
* if (size(a) /= size(b)) then
* write(_message,*) "-a- is length", size(a), &
* "which is not the same as -b- which is length", size(b)
* funit_passed_ = .false.
* return
* end if
* do funit_i_ = 1,size(a)
* if (abs(a(funit_i_) - b(funit_i_)) > TOLERANCE) then
* write(_message,*) "-a-(", funit_i_, ") is not within", TOLERANCE, &
* "of -b-(", funit_i_, "): ", a(funit_i_), "vs", b(funit_i_)
* funit_passed_ = .false.
* return
* end if
* end do
*/
static int generate_assert_array_equal_with(struct Code *macro)
{
struct Code *a = macro->u.m.args, *b;
float this_tolerance;
int num_args;
num_args = check_assert_args2("assert_array_equal", macro, a, 2, 3);
if (num_args < 2) {
return -1;
}
b = a->next;
if (num_args == 2) {
if (tolerance <= 0.0) {
fprintf(stderr, "near %s:%li: in assert_array_equal(): missing "
"a tolerance argument or a set-level default tolerance\n",
test_set_file_name, macro->lineno);
return -1;
}
this_tolerance = tolerance;
} else if (num_args == 3) {
this_tolerance = strtod(b->next->u.c.str, NULL);
if (this_tolerance <= 0.0) {
fprintf(stderr, "near %s:%li: in assert_array_equal(): parsed "
"a tolerance <= 0.0; you need to fix that\n",
test_set_file_name, macro->lineno);
return -1;
}
}
fprintf(fout, "! assert_array_equal_with(%s)\n",
(num_args == 3) ? "tol" : "");
// length check
print_array_size_check(a, b);
// do loop
fputs(" do funit_i_ = 1,size(", fout);
PRINT_CODE(a);
fputs(")\n", fout);
fputs(" if (abs(", fout);
PRINT_CODE(a);
fputs("(funit_i_) - ", fout);
PRINT_CODE(b);
fprintf(fout, "(funit_i_)) > %g) then\n", this_tolerance);
fputs(" write(funit_message_,*) \"", fout);
print_macro_arg(a);
fprintf(fout, "(\", funit_i_, &\n \") is not within %g of ",
this_tolerance);
print_macro_arg(b);
fputs("(\", funit_i_, &\n \"): \", ", fout);
PRINT_CODE(a);
fputs("(funit_i_), \"vs\", ", fout);
PRINT_CODE(b);
fputs("(funit_i_)\n", fout);
fputs(" funit_passed_ = .false.\n", fout);
fputs(" return\n", fout);
fputs(" end if\n", fout);
fputs(" end do", fout);
return 0;
}
