static char rcsid[] = "$Id: F-compile-expr.c,v 1.91 2003/09/17 17:58:30 msato Exp $"; /* * $RWC_Release: Omni-1.6 $ * $RWC_Copyright: * Omni Compiler Software Version 1.5-1.6 * Copyright (C) 2002 PC Cluster Consortium * * This software is free software; you can redistribute it and/or modify * it under the terms of the GNU Lesser General Public License version * 2.1 published by the Free Software Foundation. * * Omni Compiler Software Version 1.0-1.4 * Copyright (C) 1999, 2000, 2001. * Tsukuba Research Center, Real World Computing Partnership, Japan. * * Please check the Copyright and License information in the files named * COPYRIGHT and LICENSE under the top directory of the Omni Compiler * Software release kit. * * * $ */ #include "F-front.h" #include static expv expv_set_temp _ANSI_ARGS_((TYPE_DESC tp, expv v)); static expv expv_str_cmp _ANSI_ARGS_((enum expr_code op, expv left,expv right)); static expv expv_arithmetic_complex_op _ANSI_ARGS_((enum expr_code op, TYPE_DESC tp, expv left, expv right)); #ifdef ENABLE_QREAL static expv expv_qreal_op _ANSI_ARGS_((enum expr_code op, TYPE_DESC tp, expv left, expv right)); #endif /* ENABLE_QREAL */ static int expv_char_len_max _ANSI_ARGS_((expv v)); struct replace_item replace_stack[MAX_REPLACE_ITEMS]; struct replace_item *replace_sp = replace_stack; /* * Convert expr terminal node to expv terminal node. */ expv compile_terminal_node(x) expr x; { expv ret = NULL; if (!(EXPR_CODE_IS_TERMINAL_OR_CONST(EXPR_CODE(x)))) { fatal("compile_terminal_node: not a terminal."); return NULL; } switch (EXPR_CODE(x)) { #ifdef ENABLE_QREAL case QREAL_CONSTANT: #endif /* ENABLE_QREAL */ case FLOAT_CONSTANT: case COMPLEX_CONSTANT: { ret = x; break; } case STRING_CONSTANT: { ret = expv_str_term(STRING_CONSTANT, type_char(strlen(EXPR_STR(x))), EXPR_STR(x)); break; } #ifdef HAS_INT64 case LONGLONG_CONSTANT: { ret = expv_longlong_term(LONGLONG_CONSTANT, type_LONGLONG, EXPR_LLINT_HIGH(x), EXPR_LLINT_LOW(x)); break; } #endif /* HAS_INT64 */ case F_FLOAT_CONSTANT: { ret = expv_float_term(FLOAT_CONSTANT, type_REAL,EXPR_FLOAT(x)); break; } case F_DOUBLE_CONSTANT: { ret = expv_float_term(FLOAT_CONSTANT, type_DREAL,EXPR_FLOAT(x)); break; } #ifdef ENABLE_QREAL case F_QREAL_CONSTANT: { ret = expv_qreal_term(QREAL_CONSTANT, type_QREAL, expv_str_term(STRING_CONSTANT, type_char(strlen(EXPR_QREAL_CONST(x))), EXPR_QREAL_CONST(x))); break; } #endif /* ENABLE_QREAL */ case F_TRUE_CONSTANT: { ret = expv_int_term(INT_CONSTANT, type_LOGICAL, 1); break; } case F_FALSE_CONSTANT: { ret = expv_int_term(INT_CONSTANT, type_LOGICAL, 0); break; } case INT_CONSTANT: { ret = expv_int_term(INT_CONSTANT, type_INT, EXPR_INT(x)); break; } case F_COMPLEX_CONSTANT: { /* * make this complex constant internal complex constant. */ expv re = NULL; expv im = NULL; TYPE_DESC tp = NULL; if (expr_is_constant(EXPR_ARG1(x)) == TRUE) { re = expr_constant_value(EXPR_ARG1(x), FALSE); } else { error("non constant expression (real) is in complex constant."); break; } if (expr_is_constant(EXPR_ARG2(x)) == TRUE) { im = expr_constant_value(EXPR_ARG2(x), FALSE); } else { error("non constant expression (imag) is in complex constant."); break; } if (re == NULL || im == NULL) { fatal("compile_terminal_node: can't create complex constant."); break; } else if ((!(IS_NUMERIC(EXPV_TYPE(re)))) || (!(IS_NUMERIC(EXPV_TYPE(im))))) { error("non numeric expression(s) is in complex constant."); break; } #ifdef ENABLE_QREAL if (TYPE_BASIC_TYPE(EXPV_TYPE(re)) == TYPE_QREAL) { re = expv_qreal_const_type_conversion(type_DREAL, re); } if (TYPE_BASIC_TYPE(EXPV_TYPE(im)) == TYPE_QREAL) { im = expv_qreal_const_type_conversion(type_DREAL, im); } #endif /* ENABLE_QREAL */ /* Last check before cons. */ if (expr_is_constant(re) == FALSE || !(EXPR_CODE_IS_TERMINAL_OR_CONST(EXPV_CODE(re)))) { error("about to create complex constant with non-constant (real)."); break; } if (expr_is_constant(im) == FALSE || !(EXPR_CODE_IS_TERMINAL_OR_CONST(EXPV_CODE(im)))) { error("about to create complex constant with non-constant (imag)."); break; } tp = max_type(EXPV_TYPE(re), EXPV_TYPE(im)); if (TYPE_BASIC_TYPE(tp) != TYPE_REAL || TYPE_BASIC_TYPE(tp) != TYPE_DREAL) { /* Use DREAL. */ tp = type_DREAL; } re = expv_reduce_conv_const(tp, re); im = expv_reduce_conv_const(tp, im); if (TYPE_BASIC_TYPE(tp) == TYPE_DREAL) { ret = expv_cons(COMPLEX_CONSTANT, type_DCOMPLEX, re, im); } else { ret = expv_cons(COMPLEX_CONSTANT, type_COMPLEX, re, im); } break; } case IDENT: { if (expr_is_param(x) == TRUE) { ret = expr_param_value(x); } else { ret = x; } break; } default: { ret = NULL; break; } } return ret; } /* evaluate expression */ expv compile_expression(x) expr x; { expr x1; expv left,right,v; TYPE_DESC lt,rt,tp; ID id = NULL; enum expr_code op; if (x == NULL) { return NULL; } #ifdef ENABLE_QREAL /* * Special care. If IDENT && CL_PARAM && TYPE_QREAL, this * parameter is already emited as DATA statement. Return * ID_CONST(id). */ if (EXPR_CODE(x) == IDENT && expr_is_param(x) == TRUE) { id = declare_ident(EXPR_SYM(x), CL_UNKNOWN); if (PARAM_QREAL(id) != NULL && TYPE_BASIC_TYPE(ID_TYPE(id)) == TYPE_QREAL) { return ID_CONST(id); } id = NULL; goto goFuther; } #endif /* ENABLE_QREAL */ /* * First, check the expression is a terminal node (include * F_COMPLEX_CONSTANT) or not. If so, just compile and return it. */ if (EXPR_CODE_IS_TERMINAL_OR_CONST(EXPR_CODE(x))) { expv ret = compile_terminal_node(x); if (ret == x) { goto goFuther; } else { return ret; } } /* * Secound, check the expression is a constant expression or not. * If it's a constant expression and type == (QREAL or COMPLEX), * MUST be folded to a constant terminal node at VERY * HERE. Because these expressions will be translated to runtime * calling sequence and it can't be folded after translation, * since it is NOT a constant expression any longer. */ if (doQCZFolding == TRUE) { TYPE_DESC eTp = expr_constant_type(x); if (eTp != NULL) { expv ret = NULL; switch (TYPE_BASIC_TYPE(eTp)) { case TYPE_COMPLEX: case TYPE_DCOMPLEX: { ret = expv_complex_const_reduce(x, eTp); break; } #ifdef ENABLE_QREAL case TYPE_QREAL: { ret = expv_qreal_const_reduce(x); break; } #endif /* ENABLE_QREAL */ default: { break; } } if (ret != NULL) { return ret; } } } /* * Third, just compile other expressions. */ goFuther: switch (EXPR_CODE(x)) { #ifdef ENABLE_QREAL case QREAL_CONSTANT: #endif /* ENABLE_QREAL */ case FLOAT_CONSTANT: case COMPLEX_CONSTANT: { return x; } case F_ARRAY_REF: { /* (F_ARRAY_REF name args) */ x1 = EXPR_ARG1(x); if (EXPR_CODE(x1) != IDENT) { fatal("compile_expression: array expr"); } id = declare_ident(EXPR_SYM(x1),CL_UNKNOWN); if (ID_CLASS(id) == CL_PROC || ID_CLASS(id) == CL_UNKNOWN) { if (ID_CLASS(id) == CL_PROC && IS_SUBR(ID_TYPE(id))) { error("function invocation of subroutine"); goto err; } return(compile_function_call(id,EXPR_ARG2(x))); } } /* fall through */ case IDENT: /* terminal */ case F_SUBSTR_REF: { return compile_lhs_expression(x); } /* arithmetic expression */ case F_PLUS_EXPR: op = PLUS_EXPR; goto arithmetic_binary_op; case F_MINUS_EXPR: op = MINUS_EXPR; goto arithmetic_binary_op; case F_MUL_EXPR: op = MUL_EXPR; goto arithmetic_binary_op; case F_DIV_EXPR: op = DIV_EXPR; goto arithmetic_binary_op; /* MOD ? */ arithmetic_binary_op: { left = compile_expression(EXPR_ARG1(x)); right = compile_expression(EXPR_ARG2(x)); if (left == NULL || right == NULL) { goto err; } lt = EXPV_TYPE(left); rt = EXPV_TYPE(right); if (!IS_NUMERIC(lt) || !IS_NUMERIC(rt)){ error("nonarithmetic operand of arithmetic operator"); goto err; } tp = max_type(lt, rt); if (IS_COMPLEX(tp)) { return expv_complex_op(op, tp, left, right); } #ifdef ENABLE_QREAL else if (TYPE_BASIC_TYPE(tp) == TYPE_QREAL) { return expv_qreal_op(op, tp, left, right); } #endif /* ENABLE_QREAL */ left = expv_type_conversion(tp,left); right = expv_type_conversion(tp,right); return expv_cons(op,tp,left,right); } case F_POWER_EXPR: { left = compile_expression(EXPR_ARG1(x)); right = compile_expression(EXPR_ARG2(x)); if (left == NULL || right == NULL) { goto err; } return expv_power_expr(left,right); } case F_UNARY_MINUS_EXPR: { v = compile_expression(EXPR_ARG1(x)); tp = EXPV_TYPE(v); if (!IS_NUMERIC(tp)) { error("nonarithmetic operand of negation"); goto err; } if (IS_COMPLEX(tp)) { return expv_complex_op(UNARY_MINUS_EXPR,tp,v,NULL); } #ifdef ENABLE_QREAL else if (TYPE_BASIC_TYPE(tp) == TYPE_QREAL) { return expv_qreal_op(UNARY_MINUS_EXPR, tp, v, NULL); } #endif /* ENABLE_QREAL */ return expv_cons(UNARY_MINUS_EXPR,tp,v,NULL); } /* relational operator */ case F_EQ_EXPR: op = LOG_EQ_EXPR; goto relational_binary_op; case F_NE_EXPR: op = LOG_NEQ_EXPR; goto relational_binary_op; case F_GT_EXPR: op = LOG_GT_EXPR; goto relational_binary_op; case F_GE_EXPR: op = LOG_GE_EXPR; goto relational_binary_op; case F_LT_EXPR: op = LOG_LT_EXPR; goto relational_binary_op; case F_LE_EXPR: op = LOG_LE_EXPR; goto relational_binary_op; relational_binary_op: { left = compile_expression(EXPR_ARG1(x)); right = compile_expression(EXPR_ARG2(x)); if (left == NULL || right == NULL) { goto err; } lt = EXPV_TYPE(left); rt = EXPV_TYPE(right); if (IS_CHAR(lt) || IS_CHAR(rt) || IS_LOGICAL(lt) || IS_LOGICAL(rt)) { if (TYPE_BASIC_TYPE(lt) != TYPE_BASIC_TYPE(rt)) { error("illegal comparison"); goto err; } } else if (IS_COMPLEX(lt) || IS_COMPLEX(rt)) { if (op != LOG_EQ_EXPR && op!= LOG_NEQ_EXPR) { error("order comparison of complex data"); goto err; } #ifdef ENABLE_QREAL } else if (TYPE_BASIC_TYPE(lt) == TYPE_QREAL || TYPE_BASIC_TYPE(rt) == TYPE_QREAL) { return expv_qreal_op(op, type_LOGICAL, left, right); #endif /* ENABLE_QREAL */ } else if (!IS_NUMERIC(lt) || !IS_NUMERIC(rt)) { error("comparison of nonarithmetic data"); goto err; } tp = max_type(lt, rt); left = expv_type_conversion(tp,left); right = expv_type_conversion(tp,right); if (IS_CHAR(tp)) { return expv_str_cmp(op,left,right); } else if (IS_COMPLEX(tp)) { return expv_complex_op(op,tp,left,right); } return expv_cons(op,type_LOGICAL,left,right); } /* logical operator */ case F_EQV_EXPR: op = LOG_EQ_EXPR; goto logical_binary_op; case F_NEQV_EXPR: op = LOG_NEQ_EXPR; goto logical_binary_op; case F_OR_EXPR: op = LOG_OR_EXPR; goto logical_binary_op; case F_AND_EXPR: op = LOG_AND_EXPR; goto logical_binary_op; logical_binary_op: { left = compile_expression(EXPR_ARG1(x)); right = compile_expression(EXPR_ARG2(x)); if (left == NULL || right == NULL) { goto err; } lt = EXPV_TYPE(left); rt = EXPV_TYPE(right); if (!IS_LOGICAL(lt) || !IS_LOGICAL(rt)) { error("nonlogical operand of logical operator"); goto err; } return expv_cons(op,type_LOGICAL,left,right); } case F_NOT_EXPR: { v = compile_expression(EXPR_ARG1(x)); tp = EXPV_TYPE(v); if (!IS_LOGICAL(tp)) { error("NOT of nonlogical"); goto err; } return expv_cons(LOG_NOT_EXPR,tp,v,NULL); } case F_CONCAT_EXPR: { left = compile_expression(EXPR_ARG1(x)); right = compile_expression(EXPR_ARG2(x)); if (left == NULL || right == NULL) { goto err; } lt = EXPV_TYPE(left); rt = EXPV_TYPE(right); if (!IS_CHAR(lt) || !IS_CHAR(rt)) { error("concatenation of nonchar data"); goto err; } return expv_cons(F_CONCAT_EXPR,type_CHAR,left,right); } case F_LABEL_REF: { error("label argument is not supported"); break; } default: { fatal("compile_expression: unknown code"); } } err: return NULL; } /* evaluate left-hand side expression */ /* x = ident * | (F_SUBSTR ident substring) * | (F_ARRAY_REF ident fun_arg_list) * | (F_SUBSTR (F_ARRAY_REF ident fun_arg_list) substring) */ expv compile_lhs_expression(x) expr x; { expr sub; expv v; expv lower = NULL; expv upper = NULL; TYPE_DESC tp; ID id; SYMBOL s; switch(EXPR_CODE(x)){ case F_SUBSTR_REF: /* return substring, (POINTER_REF (PLUS_EXPR str-exp start)) */ /* length information is stored in type info */ if((v = compile_lhs_expression(EXPR_ARG1(x))) == NULL) goto err; sub = EXPR_ARG2(x); if(EXPR_ARG1(sub) != NULL) lower = compile_expression(EXPR_ARG1(sub)); if(EXPR_ARG2(sub) != NULL) upper = compile_expression(EXPR_ARG2(sub)); if(!IS_CHAR(EXPV_TYPE(v))){ error("substring for non charater"); goto err; } /* (:), nothing to do */ if(EXPR_ARG1(sub) == NULL && EXPR_ARG2(sub) == NULL) return v; /* if lower is omitted, 1 */ if(EXPR_ARG1(sub) == NULL) lower = expv_constant_1; else if(lower == NULL) goto err; else if(!IS_INT(EXPV_TYPE(lower))){ error("value in substring is not integer"); goto err; } /* if upper is omitted, len of v */ if(EXPR_ARG2(sub) == NULL) upper = NULL; else if(upper == NULL) goto err; else if(!IS_INT(EXPV_TYPE(upper))){ error("value in substring is not integer"); goto err; } return expv_cons(F_SUBSTR_REF,type_CHAR, v,expv_cons(LIST,NULL,upper,lower)); case F_ARRAY_REF: /* (F_ARRAY_REF ident fun_arg_list) */ /* ident must be CL_VAR */ if(EXPR_CODE(EXPR_ARG1(x)) != IDENT) fatal("compile_lhs_expression; no ident in F_ARRAY_REF"); s = EXPR_SYM(EXPR_ARG1(x)); if((id = declare_variable(declare_ident(s,CL_UNKNOWN))) == NULL) goto err; tp = ID_TYPE(id); if(!IS_ARRAY_TYPE(tp)){ error("subscripts on scalar variable, '%s'",ID_NAME(id)); goto err; } if((v = compile_array_ref(id,EXPR_ARG2(x))) == NULL) goto err; return v; case IDENT: /* terminal */ /* if SCALAR variable, (POINTER_REF addr) */ /* if ARRAY variable, (*_ADDR ...) */ s = EXPR_SYM(x); id = declare_ident(s,CL_UNKNOWN); if(replace_stack != replace_sp){ /* in function statment call */ struct replace_item *rp = replace_sp; /* check if name is on the replace list? */ while(rp-- > replace_stack) if(rp->id == id) return rp->v; } if((ID_CLASS(id) == CL_PROC || ID_CLASS(id) == CL_ENTRY) && PROC_CLASS(id) == P_THISPROC){ if(PROC_RET_VAL(id)) return PROC_RET_VAL(id); else { error("illegal use of subroutine name"); goto err; } } if (ID_CLASS(id) == CL_PARAM) { if (EXPR_CODE(ID_CONST(id)) == COMPLEX_CONSTANT) { expv cV = ID_CONST(id); return expv_complex_op(F_COMPLEX_CONSTANT, EXPV_TYPE(cV), compile_expression(EXPR_ARG1(cV)), compile_expression(EXPR_ARG2(cV))); } else { return ID_CONST(id); } } if((id = declare_variable(id)) == NULL) goto err; if(IS_CHAR(ID_TYPE(id))) return ID_ADDR(id); if(IS_ELEMENT_TYPE(ID_TYPE(id))) return expv_cons(POINTER_REF,ID_TYPE(id),ID_ADDR(id),NULL); else { error("no subscripts for array, '%s'",ID_NAME(id)); goto err; } default: fatal("compile_lhs_expression: unknown code"); /* error ? */ } err: return NULL; } int expv_is_lvalue(expv v) { if (v == NULL) return FALSE; if (EXPV_IS_RVALUE(v) == TRUE) return FALSE; if (IS_CHAR(EXPV_TYPE(v))) return FALSE; if (EXPR_CODE(v) == POINTER_REF || EXPR_CODE(v) == ARRAY_REF) return TRUE; return FALSE; } int expv_is_str_lvalue(expv v) { if(!IS_CHAR(EXPV_TYPE(v))) return FALSE; if(EXPR_CODE(v) == F_SUBSTR_REF || EXPR_CODE(v) == LARRAY_ADDR || EXPR_CODE(v) == ARRAY_ADDR || EXPR_CODE(v) == FPARAM_ARRAY_ADDR || EXPR_CODE(v) == FCOMM_ARRAY_ADDR || EXPR_CODE(v) == PLUS_EXPR || EXPR_CODE(v) == ARRAY_AREF || EXPR_CODE(v) == POINTER_REF) return TRUE; return FALSE; } expv expv_type_conversion(tp,v) TYPE_DESC tp; expv v; { TYPE_DESC tq; expv tmp; tq = EXPV_TYPE(v); if (tq == NULL || tp == NULL) { error("can't get type."); return NULL; } if (tq == tp || TYPE_BASIC_TYPE(tp) == TYPE_BASIC_TYPE(tq)) { return v; } else if (IS_NUMERIC(tp) && IS_NUMERIC_CONST_V(v)) { expv newV = NULL; switch (TYPE_BASIC_TYPE(tq)) { #ifdef ENABLE_QREAL case TYPE_QREAL: #endif /* ENABLE_QREAL */ case TYPE_COMPLEX: case TYPE_DCOMPLEX: { newV = expr_constant_value(v, FALSE); break; } default: { newV = expv_reduce(v); break; } } if (newV == NULL) { newV = v; } return expv_reduce_conv_const(tp, newV); } else if (IS_NUMERIC(tp) && IS_NUMERIC(tq)) { if (IS_COMPLEX(tp) || IS_COMPLEX(tq)) { tmp = expv_complex_op(CAST_EXPR,tp,v,NULL); #ifdef ENABLE_QREAL } else if (TYPE_BASIC_TYPE(tp) == TYPE_QREAL || TYPE_BASIC_TYPE(tq) == TYPE_QREAL) { tmp = expv_qreal_type_conversion(tp, v); #endif /* ENABLE_QREAL */ } else { tmp = expv_cons(CAST_EXPR, tp, v, NULL); } return expv_reduce(tmp); } else { error("illegal type conversion"); return NULL; } } /* compile into integer constant */ expv compile_int_constant(expr x) { expv v; if((v = compile_expression(x)) == NULL) return NULL; if((v = expv_reduce(v)) == NULL) return NULL; if (EXPV_CODE(v) == INT_CONSTANT) { return v; #ifdef HAS_INT64 } else if (EXPV_CODE(v) == LONGLONG_CONSTANT) { return expv_reduce_conv_const(type_INT, v); #endif /* HAS_INT64 */ } else { error("integer constant is required"); return NULL; } } /* compile into integer constant */ expv compile_logical_expression(x) expr x; { expv v; if((v = compile_expression(x)) == NULL) return NULL; if(!IS_LOGICAL(EXPV_TYPE(v))){ error("logical expression is required"); return NULL; } return v; } expv genCallCheckNaN(numV) expv numV; { lineno_info *ln = current_line; char *fileName = ""; int lineNo = 0; expv argList = NULL; char *funcName = NULL; if (ln != NULL) { fileName = FILE_NAME(ln->file_id); lineNo = ln->ln_no; } argList = list4(LIST, numV, expv_str_term(STRING_CONSTANT, type_char(strlen(fileName)), strdup(fileName)), expv_int_term(INT_CONSTANT, type_INT, lineNo), expv_int_term(INT_CONSTANT, type_INT, (doCoreDumpWhenNaN == TRUE) ? 1 : 0)); if (TYPE_BASIC_TYPE(EXPV_TYPE(numV)) == TYPE_REAL) { funcName = "__checkNaN_real"; } else { funcName = "__checkNaN_dreal"; } return expv_call_runtime(funcName, NULL, argList); } expv expv_assignment(v1,v2) expv v1,v2; { TYPE_DESC lt,rt; expv retV = NULL; lt = EXPV_TYPE(v1); rt = EXPV_TYPE(v2); if (EXPV_IS_RVALUE(v1) == TRUE) { error("bad left hand side expression in assignment"); return NULL; } if (IS_NUMERIC(lt) && IS_NUMERIC(rt)) { #ifdef ENABLE_QREAL if (TYPE_BASIC_TYPE(lt) != TYPE_QREAL && TYPE_BASIC_TYPE(rt) != TYPE_QREAL) #endif /* ENABLE_QREAL */ v2 = expv_type_conversion(EXPV_TYPE(v1),v2); } else if (IS_CHAR(lt) && IS_CHAR(rt)) { return expv_str_assignment(v1,v2); } else if (!(IS_LOGICAL(lt) && IS_LOGICAL(rt))) { return NULL; } #ifdef ENABLE_QREAL if (TYPE_BASIC_TYPE(lt) == TYPE_QREAL || TYPE_BASIC_TYPE(rt) == TYPE_QREAL) { retV = expv_qreal_assignment(v1, v2); } else #endif /* ENABLE_QREAL */ if ((TYPE_BASIC_TYPE(lt) == TYPE_COMPLEX || TYPE_BASIC_TYPE(lt) == TYPE_DCOMPLEX) && (EXPV_CODE(v2) == COMPLEX_NODE || EXPV_CODE(v2) == COMPLEX_CONSTANT)) { TYPE_DESC cTp; expv realV, imgV; if (TYPE_BASIC_TYPE(lt) == TYPE_COMPLEX) { cTp = type_REAL; } else { cTp = type_DREAL; } realV = expv_reduce(expv_complex_real(cTp, v2)); imgV = expv_reduce(expv_complex_img(cTp, v2)); if (realV == NULL || imgV == NULL) { fatal("expv_assignment: complex real/img NULL??"); } #if 1 retV = list3(COMPOUND_STATEMENT, list0(ID_LIST), list0(LIST), list2(LIST, list1(EXPR_STATEMENT, expv_cons(ASSIGN_EXPR, NULL, expv_complex_real(cTp, v1), realV)), list1(EXPR_STATEMENT, expv_cons(ASSIGN_EXPR, NULL, expv_complex_img(cTp, v1), imgV)))); #else /* * not LIST, but COMMA_EXPR !! */ retV = list1(EXPR_STATEMENT, list2(COMMA_EXPR, expv_cons(ASSIGN_EXPR, NULL, expv_complex_real(cTp, v1), realV), expv_cons(ASSIGN_EXPR, NULL, expv_complex_img(cTp, v1), imgV))); #endif } else { retV = expv_cons(ASSIGN_EXPR,NULL,v1,v2); } if (doNaNCheck == TRUE && retV != NULL) { if (TYPE_BASIC_TYPE(EXPV_TYPE(v1)) == TYPE_REAL || TYPE_BASIC_TYPE(EXPV_TYPE(v1)) == TYPE_DREAL) { expv chkV = genCallCheckNaN(v1); if (chkV != NULL) { retV = list2(ASSIGN_EXPR_WITH_CHECK, retV, chkV); } } } return retV; } expv compile_array_ref(id,args) ID id; expr args; { int n; expr d,v,off; list lp; expv subs[MAX_DIM]; int err_flag; TYPE_DESC tp; tp = ID_TYPE(id); if(!IS_ARRAY_TYPE(tp)) fatal("compile_array_ref: not ARRAY_TYPE"); if(!TYPE_DIM_FIXED(tp)) fix_array_dimensions(tp); n = 0; err_flag = FALSE; FOR_ITEMS_IN_LIST(lp,args) { d = LIST_ITEM(lp); if((v = compile_expression(d)) == NULL){ err_flag = TRUE; continue; } if(!IS_INT(EXPV_TYPE(v))) { error_at_node(args,"subscript must be integer expression"); err_flag = TRUE; continue; } if(n >= MAX_DIM){ error_at_node(args,"too many subscripts"); return NULL; } subs[n++] = v; } if(err_flag) return NULL; if(TYPE_N_DIM(tp) != n){ error_at_node(args,"wrong number of subscript on '%s'",ID_NAME(id)); return NULL; } if(TYPE_ARRAY_SIZE(tp) > 0 && !is_char_type(tp)){ v = ID_ADDR(id); for(;;){ off = expv_cons(MINUS_EXPR,type_INT,subs[--n],TYPE_DIM_LOWER(tp)); tp = TYPE_REF(tp); v = expv_retype(pointer_type(tp),v); v = expv_cons(PLUS_EXPR,EXPV_TYPE(v),v,off); if(IS_ARRAY_TYPE(tp)) v = expv_cons(ARRAY_AREF,tp,v,NULL); else if(IS_CHAR(tp)){ /* not used */ break; } else { v = expv_cons(POINTER_REF,tp,v,NULL); break; } } } else { /* adjustable array */ v = NULL; for(;;){ off = expv_cons(MINUS_EXPR,type_INT,subs[--n],TYPE_DIM_LOWER(tp)); if(v == NULL) v = off; else v = expv_cons(PLUS_EXPR,type_INT, expv_cons(MUL_EXPR,type_INT,v,TYPE_DIM_SIZE(tp)), off); tp = TYPE_REF(tp); if(!IS_ARRAY_TYPE(tp)) break; } if(IS_CHAR(tp)){ if(TYPE_CHAR_LEN(tp) == CHAR_UNKNOWN_LEN){ /* scale with len argument */ v = expv_cons(MUL_EXPR,type_INT,v, expv_sym_term(PARAM_VAR,type_INT, char_len_param_name(ID_SYM(id)))); } else v = expv_cons(MUL_EXPR,type_INT,v, expv_int_term(INT_CONSTANT,type_INT, TYPE_CHAR_LEN(tp))); v = expv_cons(PLUS_EXPR,pointer_type(tp), expv_retype(pointer_type(tp),ID_ADDR(id)),v); } else { v = expv_cons(POINTER_REF,tp, expv_cons(PLUS_EXPR,pointer_type(tp),ID_ADDR(id),v), NULL); } } return expv_reduce(v); } expv compile_function_call(ID f_id, expr args) { expv v = NULL; expv a,t; /* declare as function */ if(declare_function(f_id,FALSE) == NULL) return NULL; switch(PROC_CLASS(f_id)){ case P_THISPROC: warning("recursive call"); /* check ENTRY cannot be called */ /* FALL THROUGH */ case P_EXTERNAL: if(ID_TYPE(f_id) == NULL){ error("attempt to use untyped function,'%s'",ID_NAME(f_id)); goto err; } a = compile_args(args,TRUE); if(IS_CHAR(ID_TYPE(f_id))){ t = allocate_temp(ID_TYPE(f_id)); list_cons(t,a); v = expv_cons(FUNCTION_CALL,ID_TYPE(f_id),ID_ADDR(f_id),a); output_expr_statement(expv_assignment(t,v)); v = t; } else { v = expv_cons(FUNCTION_CALL,ID_TYPE(f_id),ID_ADDR(f_id),a); } break; case P_INTRINSIC: { char *intrFuncName = SYM_NAME(ID_SYM(f_id)); if (strcmp(intrFuncName, "loc") == 0 && EXPR_CODE(EXPR_ARG1(args)) == IDENT) { expr vX = EXPR_ARG1(args); ID vId = declare_ident(EXPR_SYM(vX), CL_UNKNOWN); if (ID_CLASS(vId) == CL_UNKNOWN) { ID_CLASS(vId) = CL_VAR; } declare_variable(vId); if (IS_ARRAY_TYPE(ID_TYPE(vId)) == TRUE) { #if defined(ADDR_IS_64) && defined(HAS_INT64) v = expv_cons(CAST_EXPR, type_LONGLONG, ID_ADDR(vId), NULL); #else v = expv_cons(CAST_EXPR, type_INT, ID_ADDR(vId), NULL); #endif /* ADDR_IS_64 && HAS_INT64 */ } else { goto doNormal; } } else { doNormal: v = compile_intrinsic_call(f_id, compile_data_args(args)); } break; } case P_STFUNCT: v = statement_function_call(f_id,compile_args(args,FALSE)); break; default: fatal("compile_function_call: unknown proc_class %d",PROC_CLASS(f_id)); } return(v); err: return NULL; } expv compile_args(expr args,int flag) { list lp; expr a; expv v,arglist,char_len_arglist; ID id; if(args == NULL) return NULL; arglist = list0(LIST); char_len_arglist = NULL; FOR_ITEMS_IN_LIST(lp,args){ a = LIST_ITEM(lp); /* check function address */ if(EXPR_CODE(a) == IDENT){ id = declare_ident(EXPR_SYM(a),CL_UNKNOWN); switch(ID_CLASS(id)){ case CL_PROC: case CL_ENTRY: if(PROC_CLASS(id) == P_THISPROC){ if(PROC_RET_VAL(id)){ v = PROC_RET_VAL(id); goto next; } else { error("illegal use of subroutine name"); continue; } } else { if(declare_function(id,TRUE) == NULL) continue; v = ID_ADDR(id); } goto next; case CL_VAR: case CL_UNKNOWN: /* check variable name */ declare_variable(id); if(IS_ARRAY_TYPE(ID_TYPE(id)) || IS_CHAR(ID_TYPE(id))){ v = ID_ADDR(id); goto next; } break; case CL_PARAM: break; default: error("illegal argument"); continue; } } if((v = compile_expression(a)) == NULL) continue; if((v = expv_reduce(v)) == NULL) continue; next: if(flag && v != NULL && is_char_type(EXPV_TYPE(v))){ if(char_len_arglist == NULL) char_len_arglist = list0(LIST); char_len_arglist = list_put_last(char_len_arglist, expv_char_len(v)); } if(flag){ /* passing address */ #if 0 TYPE_DESC tp = EXPV_TYPE(v); if (!IS_ARRAY_TYPE(tp) && (TYPE_BASIC_TYPE(tp) != TYPE_COMPLEX && TYPE_BASIC_TYPE(tp) != TYPE_DCOMPLEX)) { v = expv_get_address(v); } #else v = expv_get_address(v); #endif } arglist = list_put_last(arglist,v); } if(char_len_arglist != NULL){ FOR_ITEMS_IN_LIST(lp,char_len_arglist) list_put_last(arglist,LIST_ITEM(lp)); } return arglist; } expv expv_get_address(expv v) { expv t; switch(EXPV_CODE(v)){ default: /* keep in memory */ if(IS_CHAR(EXPV_TYPE(v))){ if(EXPV_CODE(v) == PLUS_EXPR) break; /* address calculation */ t = allocate_temp_str(v); output_expr_statement(expv_str_assignment(t,v)); v = t; break; } t = allocate_temp(EXPV_TYPE(v)); if((v = expv_assignment(t,v)) == NULL) fatal("expv_get_address: assignment to temp"); output_expr_statement(v); v = t; /* fall through */ case POINTER_REF: v = EXPV_LEFT(v); break; case F_SUBSTR_REF: /* return start address */ return expv_cons(PLUS_EXPR,type_CHAR_POINTER, expv_get_address(EXPV_LEFT(v)), expv_cons(MINUS_EXPR,type_INT, EXPV_RIGHT((expv)EXPV_RIGHT(v)), expv_constant_1)); case VAR_ADDR: /* for BSS */ case ARRAY_ADDR: case FPARAM_VAR_ADDR: /* for argument */ case FPARAM_ARRAY_ADDR: case LVAR_ADDR: /* for local */ case LARRAY_ADDR: case FCOMM_VAR_ADDR: /* common */ case FCOMM_ARRAY_ADDR: case STRING_CONSTANT: case CRAY_POINTER_REF: case FUNC_ADDR: break; } return v; } expv compile_data_args(expr args) { list lp; expr a,v,arglist; if(args == NULL) return NULL; arglist = list0(LIST); FOR_ITEMS_IN_LIST(lp,args){ a = LIST_ITEM(lp); v = compile_expression(a); arglist = list_put_last(arglist,v); } return arglist; } /* stementment function call */ expv statement_function_call(f_id, arglist) ID f_id; expv arglist; { list arg_lp,param_lp; ID id; TYPE_DESC tp = NULL; expv v,t; struct replace_item *old_sp; if(PROC_STBODY(f_id) == NULL) return NULL; /* error */ if(ID_TYPE(f_id) == NULL){ error("attempt to use untyped statement function"); return NULL; } old_sp = replace_sp; /* save */ arg_lp = EXPV_LIST(arglist); param_lp = EXPV_LIST(PROC_ARGS(f_id)); /* copy actual arguments into temporaries */ while(arg_lp != NULL && param_lp != NULL){ v = LIST_ITEM(arg_lp); id = declare_ident(EXPR_SYM(LIST_ITEM(param_lp)),CL_UNKNOWN); tp = ID_TYPE(id); if(type_is_compatible(tp,EXPV_TYPE(v)) && (IS_CONSTANT(v) || EXPV_CODE(v) == POINTER_REF)){ /* can replace directly */; } else { t = allocate_temp(tp); if((v = expv_assignment(t,v)) == NULL) error("disagreement of argument types in statement function call"); output_expr_statement(v); v = t; } replace_sp->id = id; replace_sp->v = v; if(++replace_sp >= &replace_stack[MAX_REPLACE_ITEMS]) fatal("too nested statement function call"); arg_lp = LIST_NEXT(arg_lp); param_lp = LIST_NEXT(param_lp); } if(arg_lp != NULL || param_lp != NULL){ error("statement function definition and argument list differ"); goto err; } #if 0 if (tp == NULL) goto err; if((v = compile_expression(PROC_STBODY(f_id))) == NULL) goto err; if((v = expv_type_conversion(tp,v)) == NULL) goto err; #else if((v = compile_expression(PROC_STBODY(f_id))) == NULL) goto err; if (EXPV_TYPE(v) == NULL) { EXPV_TYPE(v) = ID_TYPE(f_id); } else { if ((v = expv_type_conversion(ID_TYPE(f_id), v)) == NULL) goto err; } #endif replace_sp = old_sp; /* restore */ return v; err: replace_sp = old_sp; /* restore */ return NULL; } expv expv_set_temp(TYPE_DESC tp,expv v) { expv t; t = allocate_temp(tp); output_expr_statement(expv_assignment(t,v)); return t; } static expv expv_const_power(l, r) expv l; expv r; { expv lV = expr_constant_value(l, FALSE); expv rV = expr_constant_value(r, FALSE); BASIC_DATA_TYPE lTyp = getBasicType(EXPV_TYPE(lV)); BASIC_DATA_TYPE rTyp = getBasicType(EXPV_TYPE(rV)); #ifdef HAS_INT64 /* * Fold to int. */ if (lTyp == TYPE_LONGLONG) { lV = expv_reduce_conv_const(type_INT, lV); lTyp = TYPE_INT; } if (rTyp == TYPE_LONGLONG) { rV = expv_reduce_conv_const(type_INT, rV); rTyp = TYPE_INT; } #endif /* HAS_INT64 */ switch (rTyp) { case TYPE_SHORT: case TYPE_INT: case TYPE_LOGICAL: { switch (lTyp) { case TYPE_SHORT: case TYPE_INT: case TYPE_LOGICAL: { switch (EXPV_INT_VALUE(rV)) { case 0: { return expv_constant_1; } case 1: { return lV; } default: { return expv_int_term(INT_CONSTANT, type_INT, power_ii(EXPV_INT_VALUE(lV), EXPV_INT_VALUE(rV))); } } } case TYPE_REAL: case TYPE_DREAL: { double val = 0.0; TYPE_DESC tp = (lTyp == TYPE_REAL) ? type_REAL : type_DREAL; switch (EXPV_INT_VALUE(rV)) { case 0: { val = 1.0; break; } case 1: { return lV; } default: { val = pow(EXPV_FLOAT_VALUE(lV), (double)EXPV_INT_VALUE(rV)); break; } } return expv_float_term(FLOAT_CONSTANT, tp, val); } case TYPE_COMPLEX: case TYPE_DCOMPLEX: { double re, im; TYPE_DESC tp = (lTyp == TYPE_COMPLEX) ? type_REAL : type_DREAL; expv ret = list0(COMPLEX_CONSTANT); switch (EXPV_INT_VALUE(rV)) { case 0: { re = 1.0; im = 0.0; break; } case 1: { return lV; } default: { doublecomplex z, zl; expv reV = expr_constant_value(EXPR_ARG1(lV), FALSE); expv imV = expr_constant_value(EXPR_ARG2(lV), FALSE); zl.r = EXPV_FLOAT_VALUE(reV); zl.i = EXPV_FLOAT_VALUE(imV); power_zi(&z, &zl, EXPV_INT_VALUE(rV)); tp = max_type(tp, EXPV_TYPE(reV)); re = z.r; im = z.i; break; } } ret = list_put_last(ret, expv_float_term(FLOAT_CONSTANT, tp, re)); ret = list_put_last(ret, expv_float_term(FLOAT_CONSTANT, tp, im)); EXPV_TYPE(ret) = (tp == type_REAL) ? type_COMPLEX : type_DCOMPLEX; return ret; } default: { return NULL; } } } case TYPE_REAL: case TYPE_DREAL: { double rVal = EXPV_FLOAT_VALUE(rV); switch (lTyp) { case TYPE_SHORT: case TYPE_INT: case TYPE_LOGICAL: { if (rVal == 0.0) { return expv_constant_1; } else if (rVal == 1.0) { return lV; } else { return expv_float_term(FLOAT_CONSTANT, (rTyp == TYPE_REAL) ? type_REAL : type_DREAL, pow((double)EXPV_INT_VALUE(lV), rVal)); } } case TYPE_REAL: case TYPE_DREAL: { TYPE_DESC tp = (lTyp == TYPE_REAL) ? type_REAL : type_DREAL; if (rVal == 0.0) { return expv_float_term(FLOAT_CONSTANT, tp, 1.0); } else if (rVal == 1.0) { return lV; } else { return expv_float_term(FLOAT_CONSTANT, tp, pow(EXPV_FLOAT_VALUE(lV), rVal)); } } case TYPE_COMPLEX: case TYPE_DCOMPLEX: { double re, im; TYPE_DESC tp = (lTyp == TYPE_COMPLEX) ? type_REAL : type_DREAL; expv ret = list0(COMPLEX_CONSTANT); if (rVal == 0.0) { re = 1.0; im = 0.0; } else if (rVal == 1.0) { return lV; } else { doublecomplex z, zl, zr; expv reV = expr_constant_value(EXPR_ARG1(lV), FALSE); expv imV = expr_constant_value(EXPR_ARG2(lV), FALSE); zl.r = EXPV_FLOAT_VALUE(reV); zl.i = EXPV_FLOAT_VALUE(imV); zr.r = rVal; zr.i = 0.0; power_zz(&z, &zl, &zr); tp = max_type(tp, EXPV_TYPE(reV)); re = z.r; im = z.i; } ret = list_put_last(ret, expv_float_term(FLOAT_CONSTANT, tp, re)); ret = list_put_last(ret, expv_float_term(FLOAT_CONSTANT, tp, im)); EXPV_TYPE(ret) = (tp == type_REAL) ? type_COMPLEX : type_DCOMPLEX; return ret; } default: { return NULL; } } } case TYPE_COMPLEX: case TYPE_DCOMPLEX: { doublecomplex zRVal, z, zLVal; expv rReV = expr_constant_value(EXPR_ARG1(rV), FALSE); expv rImV = expr_constant_value(EXPR_ARG2(rV), FALSE); expv ret = list0(COMPLEX_CONSTANT); TYPE_DESC tp = (rTyp == TYPE_COMPLEX) ? type_REAL : type_DREAL; zRVal.r = EXPV_FLOAT_VALUE(rReV); zRVal.i = EXPV_FLOAT_VALUE(rImV); switch (lTyp) { case TYPE_SHORT: case TYPE_INT: case TYPE_LOGICAL: { zLVal.r =(double)EXPV_INT_VALUE(lV); zLVal.i = 0.0; break; } case TYPE_REAL: case TYPE_DREAL: { zLVal.r = EXPV_FLOAT_VALUE(lV); zLVal.i = 0.0; tp = max_type(tp, EXPV_TYPE(lV)); break; } case TYPE_COMPLEX: case TYPE_DCOMPLEX: { TYPE_DESC cTp = max_type(EXPV_TYPE(lV), EXPV_TYPE(rV)); BASIC_DATA_TYPE bCTyp = getBasicType(cTp); expv lReV = expr_constant_value(EXPR_ARG1(lV), FALSE); expv lImV = expr_constant_value(EXPR_ARG2(lV), FALSE); zLVal.r = EXPV_FLOAT_VALUE(lReV); zLVal.i = EXPV_FLOAT_VALUE(lImV); tp = (bCTyp == TYPE_COMPLEX) ? type_REAL : type_DREAL; break; } default: { return NULL; } } power_zz(&z, &zLVal, &zRVal); ret = list_put_last(ret, expv_float_term(FLOAT_CONSTANT, tp, z.r)); ret = list_put_last(ret, expv_float_term(FLOAT_CONSTANT, tp, z.i)); EXPV_TYPE(ret) = (tp == type_REAL) ? type_COMPLEX : type_DCOMPLEX; return ret; } default: { return NULL; } } } #define POW_UNKNOWN 0 #define POW_CI 1 #define POW_CD 2 #define POW_IC 3 #define POW_DC 4 #define POW_ZI 5 #define POW_ZD 6 #define POW_IZ 7 #define POW_DZ 8 #define POW_CZ 9 #define POW_ZC 10 #define POW_CC 11 #define POW_ZZ 12 #define POW_TYP_MAX POW_ZZ static char *cplxPowRuntime[] = { NULL, "C_pow_ci", /* complex ** int */ "C_pow_cd", /* complex ** double */ "C_pow_ic", /* int ** complex */ "C_pow_dc", /* double ** complex */ "Z_pow_zi", /* dcomplex ** int */ "Z_pow_zd", /* dcomplex ** double */ "Z_pow_iz", /* int ** dcomplex */ "Z_pow_dz", /* double ** dcomplex */ "Z_pow_cz", /* complex ** dcomplex */ "Z_pow_zc", /* dcomplex ** complex */ "C_pow_cc", /* complex ** complex */ "Z_pow_zz", /* dcomplex ** dcomplex */ NULL }; static int getComplexPowerType(left, right, newLPtr, newRPtr) expv left; expv right; expv *newLPtr; expv *newRPtr; { TYPE_DESC lt = EXPV_TYPE(left); TYPE_DESC rt = EXPV_TYPE(right); BASIC_DATA_TYPE bLt = TYPE_BASIC_TYPE(lt); BASIC_DATA_TYPE bRt = TYPE_BASIC_TYPE(rt); expv newL = NULL; expv newR = NULL; /* * XXXX: FIXME * if bLt or bRt is TYPE_LONGLONG, treat it as TYPE_INT. */ int ret = POW_UNKNOWN; switch (bLt) { #ifdef HAS_INT64 case TYPE_LONGLONG: newL = expv_type_conversion(type_INT, left); /* through */ #endif /* HAS_INT64 */ case TYPE_SHORT: case TYPE_INT: case TYPE_LOGICAL: { switch (bRt) { case TYPE_COMPLEX: { ret = POW_IC; break; } case TYPE_DCOMPLEX: { ret = POW_IZ; break; } default: { break; } } break; } case TYPE_REAL: { newL = expv_type_conversion(type_DREAL, left); /* through */ } case TYPE_DREAL: { switch (bRt) { case TYPE_COMPLEX: { ret = POW_DC; break; } case TYPE_DCOMPLEX: { ret = POW_DZ; break; } default: { break; } } break; } case TYPE_COMPLEX: { switch (bRt) { #ifdef HAS_INT64 case TYPE_LONGLONG: { newR = expv_type_conversion(type_INT, right); /* through */ } #endif /* HAS_INT64 */ case TYPE_SHORT: case TYPE_INT: case TYPE_LOGICAL: { ret = POW_CI; break; } case TYPE_REAL: { newR = expv_type_conversion(type_DREAL, right); /* through */ } case TYPE_DREAL: { ret = POW_CD; break; } case TYPE_COMPLEX: { ret = POW_CC; break; } case TYPE_DCOMPLEX: { ret = POW_CZ; break; } default: { break; } } break; } case TYPE_DCOMPLEX: { switch (bRt) { #ifdef HAS_INT64 case TYPE_LONGLONG: { newR = expv_type_conversion(type_INT, right); /* through */ } #endif /* HAS_INT64 */ case TYPE_SHORT: case TYPE_INT: case TYPE_LOGICAL: { ret = POW_ZI; break; } case TYPE_REAL: { newR = expv_type_conversion(type_DREAL, right); /* through */ } case TYPE_DREAL: { ret = POW_ZD; break; } case TYPE_COMPLEX: { ret = POW_ZC; break; } case TYPE_DCOMPLEX: { ret = POW_ZZ; break; } default: { break; } } break; } default: { break; } } if (newR != NULL) { *newRPtr = newR; } else { *newRPtr = right; } if (newL != NULL) { *newLPtr = newL; } else { *newLPtr = left; } return ret; } static expv expv_complex_power(left, right) expv left; expv right; { TYPE_DESC lt = EXPV_TYPE(left); TYPE_DESC rt = EXPV_TYPE(right); TYPE_DESC tp = max_type(lt, rt); expv lVal = NULL; expv rVal = NULL; int powTyp; expv ret = NULL; char *func = NULL; if (TYPE_BASIC_TYPE(lt) == TYPE_COMPLEX || TYPE_BASIC_TYPE(lt) == TYPE_DCOMPLEX) { left = expv_complex_node_to_variable(left, lt); } if (TYPE_BASIC_TYPE(rt) == TYPE_COMPLEX || TYPE_BASIC_TYPE(rt) == TYPE_DCOMPLEX) { right = expv_complex_node_to_variable(right, rt); } powTyp = getComplexPowerType(left, right, &lVal, &rVal); if (powTyp == POW_UNKNOWN) { error("unknown complex power opration."); return NULL; } func = cplxPowRuntime[powTyp]; if (func == NULL) { error("unknown complex power opration, can't find proper runtime."); return NULL; } #ifdef I_wanna_this ret = expv_call_runtime(func, tp, list2(LIST, lVal, rVal)); #else ret = expv_set_temp(tp, expv_call_runtime(func, tp, list2(LIST, lVal, rVal))); #endif return ret; } #ifdef ENABLE_QREAL static expv expv_qreal_power(left, right) expv left; expv right; { TYPE_DESC rt = EXPV_TYPE(right); #if 0 TYPE_DESC lt = EXPV_TYPE(left); TYPE_DESC tp = max_type(lt, rt); #endif expv lVal = NULL; expv rVal = NULL; expv ret = NULL; expv callArgs = NULL; if (BASIC_IS_INT(TYPE_BASIC_TYPE(rt))) { lVal = left; #if (SIZEOF_UNSIGNED_LONG >= 8) rVal = expv_type_conversion(type_LONGLONG, right); #else rVal = expv_type_conversion(type_INT, right); #endif /* (SIZEOF_UNSIGNED_LONG >= 8) */ ret = allocate_temp(type_QREAL); callArgs = list3(LIST, expv_get_address(lVal), expv_get_address(rVal), expv_get_address(ret)); output_expr_statement(expv_call_runtime("_QRpow_qi", NULL, callArgs)); } else { error("raise to quad-real power is not supported yet."); } return ret; } #endif /* ENABLE_QREAL */ /* * power expression */ /* runtime library * pow_ii: INTEGER*INTGER -> INTEGER * pow_ri: REAL*INTGER -> DREAL * pow_di: DREAL*INTGER -> DREAL * pow_ci: COMPLEX**INTEGER -> COMPLEX * pow_dd: DREAL*DREAL -> DREAL * pow_hh, pow_zz, pow_zi, pow_qq is not used */ expv expv_power_expr(expv left,expv right) { TYPE_DESC lt,rt,tp, runTimeT; char *func = NULL; /* check constant expression */ left = expv_reduce(left); right = expv_reduce(right); lt = EXPV_TYPE(left); rt = EXPV_TYPE(right); if(!IS_NUMERIC(lt) || !IS_NUMERIC(rt)){ error("nonarithmetic operand of power operator"); return NULL; } #ifdef ENABLE_QREAL if (TYPE_BASIC_TYPE(lt) == TYPE_QREAL || TYPE_BASIC_TYPE(rt) == TYPE_QREAL) { return expv_qreal_power(left, right); } #endif /* ENABLE_QREAL */ if (expr_is_constant(left) && expr_is_constant(right)) { expv ret = expv_const_power(left, right); if (ret != NULL) { return ret; } } if (TYPE_BASIC_TYPE(rt) == TYPE_COMPLEX || TYPE_BASIC_TYPE(rt) == TYPE_DCOMPLEX || TYPE_BASIC_TYPE(lt) == TYPE_COMPLEX || TYPE_BASIC_TYPE(lt) == TYPE_DCOMPLEX) { return expv_complex_power(left, right); } if (EXPR_CODE(right) == INT_CONSTANT) { if (EXPV_INT_VALUE(right) == 0) { if (IS_INT(lt)) { return expv_constant_1; } else { return expv_reduce_conv_const(lt, expv_float_term(FLOAT_CONSTANT, lt, 1.0)); } } if(EXPV_INT_VALUE(right) == 1) return left; if(EXPR_CODE(left) == INT_CONSTANT){ return expv_int_term(INT_CONSTANT,type_INT, power_ii(EXPV_INT_VALUE(left), EXPV_INT_VALUE(right))); } if(EXPR_CODE(left) == FLOAT_CONSTANT){ return expv_float_term(FLOAT_CONSTANT,lt, power_di(EXPV_FLOAT_VALUE(left), EXPV_INT_VALUE(right))); } if(EXPV_INT_VALUE(right) == 2){ /* x**2 == x * x */ return expv_cons(MUL_EXPR,lt,left,left); } } runTimeT = tp = max_type(lt, rt); /* call runtime */ switch(TYPE_BASIC_TYPE(rt)){ case TYPE_SHORT: right = expv_set_temp(type_INT,right); goto doRightLong; #ifdef HAS_INT64 case TYPE_LONGLONG: right = expv_type_conversion(type_INT, right); #endif /* HAS_INT64 */ case TYPE_INT: doRightLong: switch(TYPE_BASIC_TYPE(lt)){ case TYPE_SHORT: left = expv_set_temp(type_INT,left); goto doLeftLong; #ifdef HAS_INT64 case TYPE_LONGLONG: left = expv_type_conversion(type_INT, left); #endif /* HAS_INT64 */ case TYPE_INT: doLeftLong: runTimeT = type_INT; /* specify return type explicitly. */ func = "pow_ii"; break; case TYPE_REAL: func = "pow_ri"; runTimeT = type_DREAL; break; case TYPE_DREAL: func = "pow_di"; runTimeT = type_DREAL; break; case TYPE_COMPLEX: case TYPE_DCOMPLEX: fatal("expv_power_expr: must not be here(left == complex)"); break; default: fatal("expv_power_expr: bad type (left)"); break; } break; case TYPE_REAL: right = expv_set_temp(type_DREAL,right); case TYPE_DREAL: if(TYPE_BASIC_TYPE(lt) != TYPE_DREAL){ left = expv_set_temp(type_DREAL,left); } runTimeT = type_DREAL; func = "pow_dd"; break; case TYPE_COMPLEX: case TYPE_DCOMPLEX: fatal("expv_power_expr: must not be here(right == complex)"); break; default: fatal("expv_power_expr: bad type (right)"); break; } if(EXPR_CODE(left) != POINTER_REF) left = expv_set_temp(EXPV_TYPE(left),left); if(EXPR_CODE(right) != POINTER_REF) right = expv_set_temp(EXPV_TYPE(right),right); if (runTimeT == tp) { return expv_call_runtime(func, runTimeT, list2(LIST,EXPV_LEFT(left),EXPV_LEFT(right))); } else { return expv_cons(CAST_EXPR, tp, expv_call_runtime(func, runTimeT, list2(LIST,EXPV_LEFT(left),EXPV_LEFT(right))), NULL); } } /* * string operator */ static expv expv_str_assignment_rec(expv dst, expv base, expv len, expv *off, expv src); static expv expv_str_subcopy(expv dst, expv dst_base, expv dst_len, expv off, expv src,expv src_base, expv src_len); expv expv_str_assignment(expv left,expv right) { expv args,base,len,off; if(left == NULL || right == NULL) return NULL; /* error recovery */ if(EXPR_CODE(left) != F_SUBSTR_REF && EXPR_CODE(right) != F_SUBSTR_REF && EXPR_CODE(right) != F_CONCAT_EXPR){ /* simple copy */ args = list4(LIST,left,right, expv_reduce(expv_char_len(left)), expv_reduce(expv_char_len(right))); return expv_call_runtime("_str_copy",NULL,args); } if(EXPR_CODE(left) == F_SUBSTR_REF){ base = expv_cons(MINUS_EXPR,type_INT, EXPV_RIGHT(EXPV_RIGHT(left)),expv_constant_1); len = expv_char_len(left); left = EXPV_LEFT(left); } else { base = expv_constant_0; len = expv_char_len(left); } off = expv_constant_0; output_expr_statement(expv_str_assignment_rec(left,base,len, &off,right)); /* fill the rest */ return expv_str_subcopy(left,base,len,off, expv_constant_0,expv_constant_0, expv_constant_0); } expv expv_str_assignment_rec(expv dst, expv base, expv len, expv *off, expv src) { expv src_base,src_len,v; switch(EXPR_CODE(src)){ case F_CONCAT_EXPR: output_expr_statement( expv_str_assignment_rec(dst,base,len,off,EXPV_LEFT(src))); return expv_str_assignment_rec(dst,base,len,off,EXPV_RIGHT(src)); case F_SUBSTR_REF: src_base = expv_cons(MINUS_EXPR,type_INT, EXPV_RIGHT(EXPV_RIGHT(src)),expv_constant_1); src_len = expv_char_len(src); src = EXPV_LEFT(src); break; default: src_base = expv_constant_0; src_len = expv_char_len(src); } v = expv_str_subcopy(dst,base,len,*off,src,src_base,src_len); *off = expv_cons(PLUS_EXPR,type_INT,*off,src_len); return v; } expv expv_str_subcopy(expv dst,expv dst_base,expv dst_len,expv dst_off, expv src,expv src_base,expv src_len) { expv a; a = list0(LIST); list_put_last(a,dst); list_put_last(a,expv_reduce(dst_base)); list_put_last(a,expv_reduce(dst_len)); list_put_last(a,expv_reduce(dst_off)); list_put_last(a,src); list_put_last(a,expv_reduce(src_base)); list_put_last(a,expv_reduce(src_len)); return expv_call_runtime("_str_subcopy",NULL,a); } expv allocate_temp_str(expv v) { int len; len = expv_char_len_max(v); if(len != CHAR_UNKNOWN_LEN) return allocate_temp(type_char(len)); else { error("string expression of indeterminate length"); return NULL; } } expv convertSubstrRefToPointerRef(org, lenVPtr) expv org; expv *lenVPtr; { expv new; expv tmp; if (EXPR_CODE(org) != F_SUBSTR_REF) { return org; } tmp = expv_reduce(compile_expression(org)); if (tmp == NULL) { return NULL; } new = expv_cons(PLUS_EXPR, EXPV_TYPE(tmp), EXPR_ARG1(tmp), expv_cons(MINUS_EXPR, type_INT, EXPR_ARG2(EXPR_ARG2(tmp)), expv_int_term(INT_CONSTANT, type_INT, 1))); new = expv_reduce(expv_cons(POINTER_REF, EXPV_TYPE(tmp), new, NULL)); new = expv_reduce(expv_get_address(new)); if (lenVPtr != NULL) { *lenVPtr = expv_reduce(expv_char_len(tmp)); if (*lenVPtr == NULL) { fatal("can't determine length of char expression??"); } } return new; } expv expv_char_len(expv v) { int len; expv upper,lower; TYPE_DESC tp; tp = EXPV_TYPE(v); while(IS_ARRAY_TYPE(tp)) tp = TYPE_REF(tp); if(!IS_CHAR(tp)) fatal("expv_char_len: not CHAR, array of CHAR"); switch(EXPR_CODE(v)){ case F_CONCAT_EXPR: return expv_cons(PLUS_EXPR,type_INT, expv_char_len(EXPV_LEFT(v)), expv_char_len(EXPV_RIGHT(v))); case F_SUBSTR_REF: lower = EXPV_RIGHT((expv)EXPV_RIGHT(v)); upper = EXPV_LEFT((expv)EXPV_RIGHT(v)); if(upper == NULL) upper = expv_char_len(EXPV_LEFT(v)); return expv_cons(PLUS_EXPR,type_INT, expv_cons(MINUS_EXPR,type_INT,upper,lower), expv_constant_1); default: { break; } } len = TYPE_CHAR_LEN(tp); if(len == CHAR_UNKNOWN_LEN){ /* this must be character*(*) */ if(EXPV_CODE(v) == PLUS_EXPR){ /* array case, then take base */ v = EXPV_LEFT(v); } if (EXPR_CODE(v) != FPARAM_VAR_ADDR && EXPR_CODE(v) != FPARAM_ARRAY_ADDR){ error("unknown charactor length"); } return expv_sym_term(PARAM_VAR,type_INT, char_len_param_name(EXPV_NAME(v))); } else return expv_int_term(INT_CONSTANT,type_INT,len); } /* return maximum number of string length */ static int expv_char_len_max(expv v) { int len,len1,len2; expv upper,lower; TYPE_DESC tp; tp = EXPV_TYPE(v); while(IS_ARRAY_TYPE(tp)) tp = TYPE_REF(tp); if(!IS_CHAR(tp)) fatal("expv_char_len_max: not CHAR, array of CHAR"); switch(EXPR_CODE(v)){ case F_CONCAT_EXPR: len1 = expv_char_len_max(EXPV_LEFT(v)); len2 = expv_char_len_max(EXPV_RIGHT(v)); if(len1 == CHAR_UNKNOWN_LEN || len2 == CHAR_UNKNOWN_LEN) return CHAR_UNKNOWN_LEN; else return len1+len2; case F_SUBSTR_REF: lower = EXPV_RIGHT((expv)EXPV_RIGHT(v)); upper = EXPV_LEFT((expv)EXPV_RIGHT(v)); if(upper == NULL) upper = expv_char_len(EXPV_LEFT(v)); v = expv_cons(PLUS_EXPR,type_INT, expv_cons(MINUS_EXPR,type_INT,upper,lower), expv_constant_1); v = expv_reduce(v); if (EXPV_CODE(v) == INT_CONSTANT) return EXPV_INT_VALUE(v); #ifdef HAS_INT64 if (EXPV_CODE(v) == LONGLONG_CONSTANT){ len = (int)EXPV_INT64_VALUE(v); return len; } #endif /* HAS_INT64 */ default: /* otherwise, return maximum */ return TYPE_CHAR_LEN(tp); } } expv expv_str_cmp(enum expr_code op, expv left,expv right) { expv v,lv,rv; lv = expv_get_address(left); rv = expv_get_address(right); if(lv == NULL || rv == NULL) return NULL; v = expv_call_runtime("s_cmp",type_INT, list4(LIST,lv,rv, expv_char_len(left),expv_char_len(right))); return expv_cons(op,type_LOGICAL,v,expv_constant_0); } #ifdef ENABLE_QREAL static expv expv_qreal_op(op, tp, left, right) enum expr_code op; TYPE_DESC tp; expv left; expv right; { expv nL = left; expv nR = right; expv ret = NULL; expv callArgs = NULL; if (left != NULL && TYPE_BASIC_TYPE(EXPV_TYPE(left)) != TYPE_QREAL) { nL = expv_type_conversion(type_QREAL, left); } if (right != NULL && TYPE_BASIC_TYPE(EXPV_TYPE(right)) != TYPE_QREAL) { nR = expv_type_conversion(type_QREAL, right); } switch (op) { case UNARY_MINUS_EXPR: { ret = allocate_temp(tp); callArgs = list2(LIST, expv_get_address(nL), expv_get_address(ret)); output_expr_statement(expv_call_runtime("_QRneg", NULL, callArgs)); break; } case PLUS_EXPR: case MINUS_EXPR: case MUL_EXPR: case DIV_EXPR: { char *runTime = NULL; ret = allocate_temp(tp); callArgs = list3(LIST, expv_get_address(nL), expv_get_address(nR), expv_get_address(ret)); switch (op) { case PLUS_EXPR: runTime = "_QRadd"; break; case MINUS_EXPR: runTime = "_QRsub"; break; case MUL_EXPR: runTime = "_QRmul"; break; case DIV_EXPR: runTime = "_QRdiv"; break; default: runTime = NULL; } if (runTime == NULL) { error("unknown quad-real binary op."); return NULL; } output_expr_statement(expv_call_runtime(runTime, NULL, callArgs)); break; } case LOG_EQ_EXPR: case LOG_NEQ_EXPR: case LOG_GT_EXPR: case LOG_GE_EXPR: case LOG_LT_EXPR: case LOG_LE_EXPR: { callArgs = list2(LIST, expv_get_address(nL), expv_get_address(nR)); ret = expv_cons(op, type_LOGICAL, expv_call_runtime("_QRcmp", type_LOGICAL, callArgs), expv_int_term(INT_CONSTANT, type_INT, 0)); break; } default: { error("unknown quad-real op."); return NULL; } } return ret; } #endif /* ENABLE_QREAL */ expv expv_c_cons(left, right, doInline) expv left; expv right; int doInline; { expv newC; if (TYPE_BASIC_TYPE(EXPV_TYPE(left)) != TYPE_REAL) { left = expv_type_conversion(type_REAL, left); } if (TYPE_BASIC_TYPE(EXPV_TYPE(right)) != TYPE_REAL) { right = expv_type_conversion(type_REAL, right); } if (doInline == FALSE) { newC = allocate_temp(type_COMPLEX); output_expr_statement(list3(COMPOUND_STATEMENT, list0(ID_LIST), list0(LIST), list2(LIST, list1(EXPR_STATEMENT, expv_assignment(expv_complex_real(type_REAL, newC), left)), list1(EXPR_STATEMENT, expv_assignment(expv_complex_img(type_REAL, newC), right))))); } else { newC = list2(COMPLEX_NODE, left, right); EXPV_TYPE(newC) = type_COMPLEX; } return newC; } expv expv_z_cons(left, right, doInline) expv left; expv right; int doInline; { expv newZ; if (TYPE_BASIC_TYPE(EXPV_TYPE(left)) != TYPE_DREAL) { left = expv_type_conversion(type_DREAL, left); } if (TYPE_BASIC_TYPE(EXPV_TYPE(right)) != TYPE_DREAL) { right = expv_type_conversion(type_DREAL, right); } if (doInline == FALSE) { newZ = allocate_temp(type_DCOMPLEX); output_expr_statement(list3(COMPOUND_STATEMENT, list0(ID_LIST), list0(LIST), list2(LIST, list1(EXPR_STATEMENT, expv_assignment(expv_complex_real(type_DREAL, newZ), left)), list1(EXPR_STATEMENT, expv_assignment(expv_complex_img(type_DREAL, newZ), right))))); } else { newZ = list2(COMPLEX_NODE, left, right); EXPV_TYPE(newZ) = type_DCOMPLEX; } return newZ; } expv expv_complex_node_to_variable(v, tp) expv v; TYPE_DESC tp; { if (EXPV_CODE(v) == COMPLEX_NODE || EXPV_CODE(v) == COMPLEX_CONSTANT) { expv newV = NULL; TYPE_DESC cTyp = (tp != NULL) ? tp : EXPV_TYPE(v); if (TYPE_BASIC_TYPE(cTyp) != TYPE_COMPLEX && TYPE_BASIC_TYPE(cTyp) != TYPE_DCOMPLEX) { fatal("expv_complex_node_to_variable(): not complex??"); } newV = allocate_ctemp(cTyp); output_expr_statement(expv_assignment(newV, v)); return newV; } else { return v; } } #define C_OP_Unknown 0 #define C_OP_CvC 1 #define C_OP_RvC 2 #define C_OP_CvR 3 static int getComplexOpType(tp, l, r, newTypePtr) TYPE_DESC tp; expv l; expv r; TYPE_DESC *newTypePtr; { int lIsC = (IS_COMPLEX(EXPV_TYPE(l))) ? TRUE : FALSE; int rIsC = (IS_COMPLEX(EXPV_TYPE(r))) ? TRUE : FALSE; if (newTypePtr != NULL) { if (TYPE_BASIC_TYPE(tp) == TYPE_COMPLEX) { *newTypePtr = type_REAL; } else if (TYPE_BASIC_TYPE(tp) == TYPE_DCOMPLEX) { *newTypePtr = type_DREAL; } else { *newTypePtr = NULL; return C_OP_Unknown; } } if (lIsC == TRUE && rIsC == TRUE) { return C_OP_CvC; } else if (lIsC == FALSE && rIsC == TRUE) { return C_OP_RvC; } else if (lIsC == TRUE && rIsC == FALSE) { return C_OP_CvR; } else { return C_OP_Unknown; } } expv expv_arithmetic_complex_op(op, tp, left, right) enum expr_code op; TYPE_DESC tp; expv left; expv right; { TYPE_DESC newTp = NULL; int opSpec; expv nReal = NULL; expv nImg = NULL; int doInline = FALSE; if (op == UNARY_MINUS_EXPR) { expv nReal, nImg; if (TYPE_BASIC_TYPE(tp) == TYPE_COMPLEX) { nReal = expv_cons(UNARY_MINUS_EXPR, type_REAL, expv_complex_real(type_REAL, left), NULL); nImg = expv_cons(UNARY_MINUS_EXPR, type_REAL, expv_complex_img(type_REAL, left), NULL); return expv_c_cons(nReal, nImg, TRUE); } else { nReal = expv_cons(UNARY_MINUS_EXPR, type_DREAL, expv_complex_real(type_DREAL, left), NULL); nImg = expv_cons(UNARY_MINUS_EXPR, type_DREAL, expv_complex_img(type_DREAL, left), NULL); return expv_z_cons(nReal, nImg, TRUE); } } opSpec = getComplexOpType(tp, left, right, &newTp); if (opSpec == C_OP_Unknown) { return NULL; } #define ConvIt(exp, toTyp) if (TYPE_BASIC_TYPE(EXPV_TYPE((exp))) != TYPE_BASIC_TYPE((toTyp))) {(exp) = expv_type_conversion((toTyp), (exp));} switch (op) { case MINUS_EXPR: case PLUS_EXPR: { doInline = TRUE; switch (opSpec) { case C_OP_RvC: { ConvIt(left, newTp); nReal = expv_cons(op, newTp, left, expv_complex_real(newTp, right)); if (op == PLUS_EXPR) { nImg = expv_complex_img(newTp, right); } else { nImg = expv_cons(UNARY_MINUS_EXPR, newTp, expv_complex_img(newTp, right), NULL); } break; } case C_OP_CvR: { ConvIt(right, newTp); nReal = expv_cons(op, newTp, expv_complex_real(newTp, left), right); nImg = expv_complex_img(newTp, left); break; } case C_OP_CvC: { nReal = expv_cons(op, newTp, expv_complex_real(newTp, left), expv_complex_real(newTp, right)); nImg = expv_cons(op, newTp, expv_complex_img(newTp, left), expv_complex_img(newTp, right)); break; } } break; } case MUL_EXPR: { switch (opSpec) { case C_OP_RvC: { /* * R = left * right.r * I = left * right.i */ doInline = TRUE; ConvIt(left, newTp); nReal = expv_cons(MUL_EXPR, newTp, left, expv_complex_real(newTp, right)); nImg = expv_cons(MUL_EXPR, newTp, left, expv_complex_img(newTp, right)); break; } case C_OP_CvR: { /* * R = left.r * right * I = left.i * right */ doInline = TRUE; ConvIt(right, newTp); nReal = expv_cons(MUL_EXPR, newTp, expv_complex_real(newTp, left), right); nImg = expv_cons(MUL_EXPR, newTp, expv_complex_img(newTp, left), right); break; } case C_OP_CvC: { /* * R = left.r * right.r - left.i * right.i * I = left.r * right.i + left.i * right.r */ nReal = expv_cons(MINUS_EXPR, newTp, expv_cons(MUL_EXPR, newTp, expv_complex_real(newTp, left), expv_complex_real(newTp, right)), expv_cons(MUL_EXPR, newTp, expv_complex_img(newTp, left), expv_complex_img(newTp, right))); nImg = expv_cons(PLUS_EXPR, newTp, expv_cons(MUL_EXPR, newTp, expv_complex_real(newTp, left), expv_complex_img(newTp, right)), expv_cons(MUL_EXPR, newTp, expv_complex_img(newTp, left), expv_complex_real(newTp, right))); break; } } break; } case DIV_EXPR: { expv normV; switch (opSpec) { /* * Well, I know there is a method to avoid computing a * norm of "right", But for inlining, I have no idea * How should I implement it. So, compute norm, costs * 2 more mul :( */ case C_OP_RvC: { /* * norm = right.r ^ 2 + right.i ^ 2 * R = (left * right.r) / norm * I = -(left * right.i) / norm */ ConvIt(left, newTp); normV = expv_cons(PLUS_EXPR, newTp, expv_cons(MUL_EXPR, newTp, expv_complex_real(newTp, right), expv_complex_real(newTp, right)), expv_cons(MUL_EXPR, newTp, expv_complex_img(newTp, right), expv_complex_img(newTp, right))); normV = expv_set_temp(newTp, expv_reduce(normV)); nReal = expv_cons(DIV_EXPR, newTp, expv_cons(MUL_EXPR, newTp, left, expv_complex_real(newTp, right)), normV); nImg = expv_cons(UNARY_MINUS_EXPR, newTp, expv_cons(DIV_EXPR, newTp, expv_cons(MUL_EXPR, newTp, left, expv_complex_img(newTp, right)), normV), NULL); break; } case C_OP_CvR: { /* * This one is easy :) * R = left.r / right * I = left.i / right */ doInline = TRUE; ConvIt(right, newTp); nReal = expv_cons(DIV_EXPR, newTp, expv_complex_real(newTp, left), right); nImg = expv_cons(DIV_EXPR, newTp, expv_complex_img(newTp, left), right); break; } case C_OP_CvC: { /* * norm = right.r ^ 2 + right.i ^ 2 * R = (left.r * right.r + left.i * right.i) / norm * I = (left.i * right.r - left.r * right.i) / norm */ normV = expv_cons(PLUS_EXPR, newTp, expv_cons(MUL_EXPR, newTp, expv_complex_real(newTp, right), expv_complex_real(newTp, right)), expv_cons(MUL_EXPR, newTp, expv_complex_img(newTp, right), expv_complex_img(newTp, right))); normV = expv_set_temp(newTp, expv_reduce(normV)); nReal = expv_cons(DIV_EXPR, newTp, expv_cons(PLUS_EXPR, newTp, expv_cons(MUL_EXPR, newTp, expv_complex_real(newTp, left), expv_complex_real(newTp, right)), expv_cons(MUL_EXPR, newTp, expv_complex_img(newTp, left), expv_complex_img(newTp, right))), normV); nImg = expv_cons(DIV_EXPR, newTp, expv_cons(MINUS_EXPR, newTp, expv_cons(MUL_EXPR, newTp, expv_complex_img(newTp, left), expv_complex_real(newTp, right)), expv_cons(MUL_EXPR, newTp, expv_complex_real(newTp, left), expv_complex_img(newTp, right))), normV); break; } } break; } default: { fatal("expv_arithmetic_complex_op: unknown complex op."); break; } } if (nReal == NULL || nImg == NULL) { fatal("expv_arithmetic_complex_op: Not be cared in case??:"); } nReal = expv_reduce(nReal); nImg = expv_reduce(nImg); if (TYPE_BASIC_TYPE(tp) == TYPE_COMPLEX) { return expv_c_cons(nReal, nImg, doInline); } else { return expv_z_cons(nReal, nImg, doInline); } #undef ConvIt } /* * complex operator */ expv expv_complex_op(enum expr_code op,TYPE_DESC tp, expv left, expv right) { typedef expv (expvComplexConsProc) _ANSI_ARGS_((expv l, expv r, int doInline)); TYPE_DESC cTyp; expvComplexConsProc *cConsProc = NULL; expv cZero = NULL; if (TYPE_BASIC_TYPE(tp) == TYPE_COMPLEX) { cTyp = type_REAL; cConsProc = expv_c_cons; cZero = expv_float_0; } else if (TYPE_BASIC_TYPE(tp) == TYPE_DCOMPLEX) { cTyp = type_DREAL; cConsProc = expv_z_cons; cZero = expv_double_0; } else if (op == CAST_EXPR) { /* conversion from complex to numeric, may be */ switch (TYPE_BASIC_TYPE(EXPV_TYPE(left))) { case TYPE_COMPLEX: { return expv_type_conversion(tp, expv_complex_real(type_REAL, left)); } case TYPE_DCOMPLEX: { return expv_type_conversion(tp, expv_complex_real(type_DREAL, left)); } default: { fatal("expv_complex_op: about to cast to numeric from non complex??"); return NULL; } } } else { goto UnknownOp; } switch (op) { case UNARY_MINUS_EXPR: case PLUS_EXPR: case MINUS_EXPR: case MUL_EXPR: case DIV_EXPR: { return expv_arithmetic_complex_op(op, tp, left, right); } case F_COMPLEX_CONSTANT: { return (cConsProc)(left, right, TRUE); } case LOG_EQ_EXPR: { return expv_cons(LOG_AND_EXPR, type_LOGICAL, expv_cons(LOG_EQ_EXPR, type_LOGICAL, expv_complex_real(cTyp, left), expv_complex_real(cTyp, right)), expv_cons(LOG_EQ_EXPR,type_LOGICAL, expv_complex_img(cTyp, left), expv_complex_img(cTyp, right))); } case LOG_NEQ_EXPR: { return expv_cons(LOG_OR_EXPR, type_LOGICAL, expv_cons(LOG_NEQ_EXPR, type_LOGICAL, expv_complex_real(cTyp, left), expv_complex_real(cTyp, right)), expv_cons(LOG_NEQ_EXPR, type_LOGICAL, expv_complex_img(cTyp, left), expv_complex_img(cTyp, right))); } case CAST_EXPR: { TYPE_DESC lTyp = EXPV_TYPE(left); if (TYPE_BASIC_TYPE(lTyp) == TYPE_BASIC_TYPE(tp)) { return left; } else if (!IS_COMPLEX(lTyp)) { return (cConsProc)(left, cZero, TRUE); } else { /* * C <- Z or Z <- C */ TYPE_DESC lCTyp = NULL; if (TYPE_BASIC_TYPE(lTyp) == TYPE_COMPLEX) { lCTyp = type_REAL; } else if (TYPE_BASIC_TYPE(lTyp) == TYPE_DCOMPLEX) { lCTyp = type_DREAL; } else { fatal("expv_complex_op: WHY HERE???"); } return (cConsProc)(expv_complex_real(lCTyp, left), expv_complex_img(lCTyp, left), TRUE); } } default: { goto UnknownOp; } } UnknownOp: fatal("expv_complex_op: unknown op"); return NULL; } static expv expv_complex_ref(retTp, v, rORi) TYPE_DESC retTp; expv v; SYMBOL rORi; { expv retV = NULL; TYPE_DESC cTyp; if (TYPE_BASIC_TYPE(EXPV_TYPE(v)) == TYPE_COMPLEX) { cTyp = type_REAL; } else { cTyp = type_DREAL; } if (EXPR_CODE(v) == COMPLEX_CONSTANT || EXPR_CODE(v) == COMPLEX_NODE) { if (rORi == complex_real_name) { retV = EXPR_ARG1(v); } else if (rORi == complex_img_name) { retV = EXPR_ARG2(v); } else { fatal("expv_complex_ref: reference is not neither img nor real??"); } } else { retV = expv_cons(MEMBER_REF, cTyp, v, expv_sym_term(IDENT, cTyp, rORi)); } if (TYPE_BASIC_TYPE(cTyp) != TYPE_BASIC_TYPE(retTp)) { retV = expv_type_conversion(retTp, retV); } return retV; } expv expv_complex_real(TYPE_DESC retTp, expv v) { return expv_complex_ref(retTp, v, complex_real_name); } expv expv_complex_img(TYPE_DESC retTp, expv v) { return expv_complex_ref(retTp, v, complex_img_name); } /* * runtime interface */ expv expv_call_runtime(char *fname,TYPE_DESC tp,expv args) { SYMBOL sp = c_find_symbol(fname); EXT_ID eid = declare_external_proc_id(sp, tp, FALSE); if (tp != NULL && TYPE_BASIC_TYPE(tp) == TYPE_CHAR) { EXT_PROC_C_TYPE(eid) = type_CHAR_POINTER; } EXT_PROC_IS_RUNTIME(eid) = TRUE; return expv_cons(FUNCTION_CALL, tp, expv_sym_term(FUNC_ADDR, NULL, sp), args); }