static char rcsid[] = "$Id: F-compile.c,v 1.70 2003/03/23 19:44:28 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" /* flags and defaults */ int save_all = FALSE; int sub_stars = FALSE; enum storage_class default_stg = STG_BSS; /* parser context */ enum prog_state current_state = OUTSIDE; expv global_proc_list; /* current procedure */ int current_proc_no; SYMBOL current_proc_name; enum name_class current_proc_class = CL_UNKNOWN; ID current_procedure; expv current_statements; int current_blk_level; expv current_return_value; EXT_ID current_ext_id; int n_entry; /* directive info */ expv current_directives; /* control stack */ CTL ctls[MAX_CTL]; CTL *ctl_top; /* current statement label */ ID this_label; TYPE_DESC type_REAL, type_INT, type_SUBR, type_CHAR, type_LOGICAL; TYPE_DESC type_DREAL, type_COMPLEX, type_DCOMPLEX, type_CHAR_POINTER; TYPE_DESC type_LONGLONG; #ifdef ENABLE_QREAL TYPE_DESC type_QREAL; #endif /* ENABLE_QREAL */ TYPE_DESC basic_type_desc[N_BASIC_TYPES]; expv expv_constant_1,expv_constant_0,expv_constant_m1; expv expv_float_0,expv_double_0; SYMBOL complex_real_name,complex_img_name; static void begin_procedure _ANSI_ARGS_((void)); static void end_procedure _ANSI_ARGS_((void)); static void compile_exec_statement _ANSI_ARGS_((expr x)); static void compile_DO_statement _ANSI_ARGS_((int range_st_no, expr var, expr init, expr limit, expr incr)); static void compile_DOWHILE_statement _ANSI_ARGS_((expr cond)); static void check_DO_end _ANSI_ARGS_((ID label)); static void end_declaration _ANSI_ARGS_((void)); static EXT_ID define_external_function_id _ANSI_ARGS_((ID id)); static void make_multiple_entry_function _ANSI_ARGS_((void)); void initialize_compile() { int t; TYPE_DESC tp; current_proc_no = 0; external_symbols = NULL; global_proc_list = list0(LIST); for(t = 0; t < N_BASIC_TYPES; t++){ if((BASIC_DATA_TYPE)t == TYPE_UNKNOWN || (BASIC_DATA_TYPE)t == TYPE_ARRAY){ basic_type_desc[t] = NULL; continue; } tp = new_type_desc(); TYPE_BASIC_TYPE(tp) = (BASIC_DATA_TYPE)t; basic_type_desc[t] = tp; } type_REAL = BASIC_TYPE_DESC(TYPE_REAL); type_DREAL= BASIC_TYPE_DESC(TYPE_DREAL); type_COMPLEX = BASIC_TYPE_DESC(TYPE_COMPLEX); type_DCOMPLEX = BASIC_TYPE_DESC(TYPE_DCOMPLEX); type_INT = BASIC_TYPE_DESC(TYPE_INT); type_SUBR = BASIC_TYPE_DESC(TYPE_SUBR); type_LOGICAL = BASIC_TYPE_DESC(TYPE_LOGICAL); type_CHAR = BASIC_TYPE_DESC(TYPE_CHAR); type_LONGLONG = BASIC_TYPE_DESC(TYPE_LONGLONG); #ifdef ENABLE_QREAL type_QREAL = BASIC_TYPE_DESC(TYPE_QREAL); #endif /* ENABLE_QREAL */ TYPE_CHAR_LEN(type_CHAR) = 1; type_CHAR_POINTER = new_type_desc(); TYPE_REF(type_CHAR_POINTER) = type_char(0); expv_constant_1 = expv_int_term(INT_CONSTANT,type_INT,1); expv_constant_0 = expv_int_term(INT_CONSTANT,type_INT,0); expv_constant_m1 = expv_int_term(INT_CONSTANT,type_INT,-1); expv_float_0 = expv_float_term(FLOAT_CONSTANT,type_REAL,0.0); expv_double_0 = expv_float_term(FLOAT_CONSTANT,type_DREAL,0.0); complex_real_name = c_find_symbol("re"); complex_img_name = c_find_symbol("im"); initialize_intrinsic(); initialize_compile_procedure(); InitializeEquivalence(); } void finalize_compile() { begin_procedure(); finalize_common_storage(); } /* initialize for each procedure */ void initialize_compile_procedure() { current_state = OUTSIDE; save_all = FALSE; sub_stars = FALSE; this_label = NULL; need_keyword = 0; ++current_proc_no; current_proc_class = CL_UNKNOWN; current_procedure = NULL; current_return_value = NULL; /* control stack */ ctl_top = ctls; CTL_TYPE(ctl_top) = CTL_NONE; local_symbols = NULL; local_labels = NULL; n_entry = 0; current_statements = NULL; current_blk_level = 1; current_directives = NULL; if (doImplicitUndef == TRUE) { set_implicit_type(NULL, 'a', 'z'); } else { /* default implicit type */ /* a - z : initialize all to real. */ set_implicit_type(BASIC_TYPE_DESC(defaultSingleRealType), 'a', 'z'); /* i - n : initialize to int. */ set_implicit_type(BASIC_TYPE_DESC(defaultIntType), 'i', 'n'); } set_implicit_storage(default_stg, 'a', 'z'); /* set class */ init_for_OMP_pragma(); } void output_expr_statement(v) expv v; { if(v == NULL) { /* fatal("output_expr_statment: v==NULL"); */ return; /* error recovery */ } output_statement(list1(EXPR_STATEMENT,v)); } void output_statement(v) expv v; { /* check line number */ if(EXPR_LINE(v) == NULL) EXPR_LINE(v) = current_line; if(current_statements == NULL) current_statements = v; else if(EXPV_CODE(current_statements) == LIST) current_statements = list_put_last(current_statements,v); else { current_statements = list2(LIST,current_statements,v); } } /* enter control block */ void push_ctl(ctl) enum control_type ctl; { if(++ctl_top >= &ctls[MAX_CTL]) fatal("too many nested loop or if-then-else"); CTL_TYPE(ctl_top) = ctl; CTL_SAVE(ctl_top) = current_statements; current_statements = NULL; current_blk_level++; } /* pop control block and output statement block */ void pop_ctl() { /* restore previous statements */ current_statements = CTL_SAVE(ctl_top); output_statement(CTL_BLOCK(ctl_top)); /* pop */ if(ctl_top-- <= ctls) fatal("control stack empty"); current_blk_level--; } void compile_statement(st_no,x) int st_no; expr x; { expv v,st; list lp; if(x == NULL) return; /* error recovery */ if(debug_flag){ fprintf(debug_fp,"##line(%d):\n",st_no); expr_print(x,debug_fp); } check_for_OMP_pragma(x); if(st_no != 0) { this_label = declare_label(st_no, LAB_UNKNOWN, TRUE); if(LAB_TYPE(this_label) != LAB_FORMAT) output_statement(list1(STATEMENT_LABEL,ID_ADDR(this_label))); } else this_label = NULL; switch(EXPR_CODE(x)){ /* entry statements */ case F_PROGRAM_STATEMENT: /* (F_PROGRAM_STATEMENT name) */ begin_procedure(); declare_procedure(CL_MAIN,EXPR_ARG1(x),NULL,NULL); break; case F_BLOCK_STATEMENT: /* (F_BLOCK_STATEMENT name) */ begin_procedure(); declare_procedure(CL_BLOCK,EXPR_ARG1(x),NULL,NULL); break; case F_SUBROUNTINE_STATEMENT: /* (F_SUBROUNTINE_STATEMENT name dummy_arg_list) */ begin_procedure(); declare_procedure(CL_PROC,EXPR_ARG1(x),type_SUBR,EXPR_ARG2(x)); break; case F_FUNCTION_STATEMENT: /* (F_FUNCTION_STATEMENT name dummy_arg_list type) */ begin_procedure(); declare_procedure(CL_PROC,EXPR_ARG1(x), compile_type(EXPR_ARG3(x)),EXPR_ARG2(x)); break; case F_ENTRY_STATEMENT: /* (F_ENTRY_STATEMENT name dummy_arg_list) */ if(current_state == OUTSIDE || current_proc_class == CL_MAIN || current_proc_class == CL_BLOCK){ error("misplaced entry statement"); break; } declare_procedure(CL_ENTRY,EXPR_ARG1(x),NULL,EXPR_ARG2(x)); break; case F_INCLUDE_STATEMENT: /* (F_INCLUDE_STATEMENT filename) */ v = EXPR_ARG1(x); if(v == NULL) break; /* error recovery */ if(EXPR_CODE(v) == STRING_CONSTANT) include_file(EXPR_STR(v)); else error("bad file name in include statement"); break; case F_END_STATEMENT: /* (F_END_STATEMENT) */ check_INEXEC(); if(current_return_value != NULL){ /* check return statement if return value is required */ FOR_ITEMS_IN_LIST(lp,current_statements){ if(LIST_NEXT(lp) == NULL && EXPR_CODE(LIST_ITEM(lp)) != RETURN_STATEMENT){ output_statement(list1(RETURN_STATEMENT, current_return_value)); break; } } } end_procedure(); break; /* * declaration statement */ case F_TYPE_DECL: /* (F_TYPE_DECL type (LIST data ....)) */ check_INDCL(); compile_type_decl(EXPR_ARG1(x),EXPR_ARG2(x)); break; case F_COMMON_DECL: /* (F_COMMON_DECL common_decl) */ check_INDCL(); /* common_decl = (LIST common_name (LIST var dims) ...) */ compile_COMMON_decl(EXPR_ARG1(x)); break; case F_EQUIV_DECL: /* (F_EQUIVE_DECL (LIST lhs ...) ...) */ check_INDCL(); compile_EQUIVALENCE_decl(EXPR_ARG1(x), FALSE); break; case F_IMPLICIT_DECL: check_INDCL(); FOR_ITEMS_IN_LIST(lp,EXPR_ARG1(x)){ v = LIST_ITEM(lp); compile_IMPLICIT_decl(EXPR_ARG1(v),EXPR_ARG2(v)); } break; case F_FORMAT_DECL: { if (this_label == NULL) { fatal("format without statement label."); } this_label = declare_label(st_no, LAB_FORMAT, FALSE); if (LAB_TYPE(this_label) != LAB_FORMAT) { fatal("can't generate label for format."); } compile_FORMAT_decl(st_no, x); break; } case F_PARAM_DECL: check_INDCL(); compile_PARAM_decl(EXPR_ARG1(x)); break; case F_POINTER_DECL: check_INDCL(); compile_cray_POINTER_decl(EXPR_ARG1(x)); break; case F_EXTERNAL_DECL: check_INDCL(); compile_EXTERNAL_decl(EXPR_ARG1(x)); break; case F_DATA_DECL: check_INDCL(); compile_DATA_decl(EXPR_ARG1(x)); break; case F_INTRINSIC_DECL: check_INDCL(); compile_INTRINSIC_decl(EXPR_ARG1(x)); break; case F_SAVE_DECL: check_INDCL(); compile_SAVE_decl(EXPR_ARG1(x)); break; case F_NAMELIST_DECL: check_INDCL(); compile_NAMELIST_decl(EXPR_ARG1(x)); break; case F_IF_STATEMENT: /* (F_IF_STATEMENT condition statement) */ check_INEXEC(); push_ctl(CTL_IF); /* evluate condition and make IF_STATEMENT clause */ v = compile_logical_expression(EXPR_ARG1(x)); st = list3(IF_STATEMENT,v,NULL,NULL); output_statement(st); CTL_BLOCK(ctl_top) = current_statements; current_statements = NULL; /* set current IF_STATEMENT */ CTL_IF_STATEMENT(ctl_top) = st; if(EXPR_ARG2(x)){ compile_exec_statement(EXPR_ARG2(x)); CTL_IF_THEN(ctl_top) = current_statements; pop_ctl(); /* pop and output */ break; } break; case F_ELSE_STATEMENT: /* (F_ELSE_STATEMENT) */ check_INEXEC(); if(CTL_TYPE(ctl_top) == CTL_IF){ /* store current statements to 'then' part, and clear */ CTL_IF_THEN(ctl_top) = current_statements; current_statements = NULL; /* change to CTL_ELSE */ CTL_TYPE(ctl_top) = CTL_ELSE; } else error("'else', out of place"); break; case F_ELSEIF_STATEMENT: /* (F_IF_STATEMENT condition) */ check_INEXEC(); if(CTL_TYPE(ctl_top) == CTL_IF){ /* store current statements to 'then' part, and clear */ CTL_IF_THEN(ctl_top) = current_statements; current_statements = NULL; /* evaluate condition and make IF_STATEMENT clause */ v = compile_logical_expression(EXPR_ARG1(x)); st = list3(IF_STATEMENT,v,NULL,NULL); output_statement(st); CTL_IF_ELSE(ctl_top) = current_statements; current_statements = NULL; /* set current IF_STATEMENT clause */ CTL_IF_STATEMENT(ctl_top) = st; } else { v = compile_logical_expression(EXPR_ARG1(x)); /* error check */ error("'elseif', out of place"); } break; case F_ENDIF_STATEMENT: /* (F_ENDIF_STATEMENT) */ check_INEXEC(); if(CTL_TYPE(ctl_top) == CTL_IF){ /* use current_statements */ CTL_IF_THEN(ctl_top) = current_statements; pop_ctl(); } else if(CTL_TYPE(ctl_top) == CTL_ELSE) { CTL_IF_ELSE(ctl_top) = current_statements; pop_ctl(); } else error("'endif', out of place"); break; case F_DO_STATEMENT: { int doStNo = -1; check_INEXEC(); /* (F_DO_STATEMENT label do_spec) */ /* do_spec := (LIST id e1 e2 e3) */ if (EXPR_ARG1(x) != NULL) { expv stLabel = expr_constant_value(EXPR_ARG1(x), TRUE); if (stLabel == NULL) { error("illegal label in DO"); break; } doStNo = EXPV_INT_VALUE(stLabel); } compile_DO_statement(doStNo, EXPR_ARG1(EXPR_ARG2(x)), EXPR_ARG2(EXPR_ARG2(x)), EXPR_ARG3(EXPR_ARG2(x)), EXPR_ARG4(EXPR_ARG2(x))); break; } case F_ENDDO_STATEMENT: check_INEXEC(); check_DO_end(NULL); break; case F_DOWHILE_STATEMENT: check_INEXEC(); /* (F_DOWHILE_STATEMENT cond_expr) */ compile_DOWHILE_statement(EXPR_ARG1(x)); break; default: compile_exec_statement(x); } /* check do range */ if(this_label) check_DO_end(this_label); } #ifdef ENABLE_QREAL static expv findFunctionCall(v) expv v; { if (EXPR_CODE_IS_TERMINAL(EXPV_CODE(v))) { return NULL; } else if (EXPV_CODE(v) == FUNCTION_CALL) { return v; } else { list lp; expv tmp; FOR_ITEMS_IN_LIST(lp, v) { tmp = LIST_ITEM(lp); tmp = findFunctionCall(tmp); if (tmp != NULL) { return tmp; } } } return NULL; } static int expv_opt_qreal_let_statement(v1, v2) expv v1; /* left hand */ expv v2; /* right hand */ { int found = FALSE; EXT_ID fId = NULL; SYMBOL fSym = NULL; list lp = NULL; int n = 0; int i; expv fcNode = NULL; expv args = NULL; expv tmp; expv addrV1 = NULL; expv addrV2 = NULL; SYMBOL symV2 = NULL; SYMBOL tSym; ID v2Id; /* * Dirty hack for qreal op optimization. * * Check all emited statements ever to find the most recent * RUNTIME FUNCTION_CALL with v2 (in this case, IT MUST BE A * TEMPORARY VARIABLE!!!). If found, replace v2 to v1. */ if (EXPV_CODE(v1) == POINTER_REF) { addrV1 = EXPV_LEFT(v1); } if (EXPV_CODE(v2) == POINTER_REF) { addrV2 = EXPV_LEFT(v2); if (EXPV_CODE(addrV2) != LVAR_ADDR) { return FALSE; } symV2 = EXPV_NAME(addrV2); } if (addrV1 == NULL || addrV2 == NULL) { return FALSE; } v2Id = declare_ident(symV2, CL_UNKNOWN); if (v2Id == NULL) { fatal("expv_opt_qreal_let_statement: can't get righ hand identifier??"); return FALSE; } if (ID_CLASS(v2Id) != CL_VAR) { return FALSE; } if (ID_STORAGE(v2Id) != STG_TEMP) { return FALSE; } /* First count statement number :( */ FOR_ITEMS_IN_LIST(lp, current_statements) { n++; } /* Second, find the most recent function call. */ for (i = n - 1; i >= 0; i--) { tmp = expr_list_get_n(current_statements, i); if (tmp == NULL) { continue; } fcNode = findFunctionCall(tmp); if (fcNode == NULL) { continue; } else { found = TRUE; break; } } if (found == FALSE) { return FALSE; } /* Third, check found function is runtime function or not. */ fSym = EXPV_NAME(EXPR_ARG1(fcNode)); fId = findRuntimeExternalId(fSym); if (fId == NULL) { return FALSE; } if (EXT_PROC_IS_RUNTIME(fId) != TRUE) { return FALSE; } /* Forth, check found runtime function call have args. */ args = expr_list_get_n(fcNode, 1); if (args == NULL) { return FALSE; } /* Fourth, check v2 is in the function's arguments. */ n = 0; found = FALSE; FOR_ITEMS_IN_LIST(lp, args) { tmp = LIST_ITEM(lp); tSym = EXPV_NAME(tmp); if (tSym == NULL) { continue; } if (tSym == symV2) { found = TRUE; break; } n++; } if (found == FALSE) { return FALSE; } else { /* Replace ! */ expr_list_set_n(args, n, addrV1, TRUE); /* No need v2. Turn it VAR_IS_IMPLIED_DO_DUMMY B) */ VAR_IS_IMPLIED_DO_DUMMY(v2Id) = TRUE; return TRUE; } } #endif /* ENABLE_QREAL */ /* * executable statement */ static void compile_exec_statement(expr x) { expr x1; expv w,v1,v2; SYMBOL s; ID id; int atomic_flag,i; list lp; if(EXPR_CODE(x) != F_LET_STATEMENT) check_INEXEC(); switch(EXPR_CODE(x)){ case F_LET_STATEMENT: /* (F_LET_STATEMENT lhs rhs) */ atomic_flag = OMP_atomic_required; OMP_atomic_required = FALSE; if(current_state == OUTSIDE){ begin_procedure(); declare_procedure(CL_MAIN,NULL,NULL,NULL); } x1 = EXPR_ARG1(x); switch(EXPR_CODE(x1)){ case F_ARRAY_REF: s = EXPR_SYM(EXPR_ARG1(x1)); id = declare_ident(s,CL_UNKNOWN); if(ID_CLASS(id) == CL_UNKNOWN){ if(current_state == INEXEC) error("statement function amid executables"); else declare_statement_function(id,EXPR_ARG2(x1),EXPR_ARG2(x)); break; } /* fall through */ case IDENT: case F_SUBSTR_REF: if(NOT_INDATA_YET) end_declaration(); v1 = compile_lhs_expression(EXPR_ARG1(x)); v2 = compile_expression(EXPR_ARG2(x)); if(v1 == NULL || v2 == NULL) goto err; if(!expv_is_lvalue(v1) && !expv_is_str_lvalue(v1)){ error("bad lhs expression in assignment"); goto err; } #ifdef ENABLE_QREAL if (doQRealOpt == TRUE && atomic_flag == FALSE) { if (TYPE_BASIC_TYPE(EXPV_TYPE(v1)) == TYPE_QREAL && TYPE_BASIC_TYPE(EXPV_TYPE(v2)) == TYPE_QREAL) { if (expv_opt_qreal_let_statement(v1, v2) == TRUE) { break; } } } #endif /* ENABLE_QREAL */ if((w = expv_assignment(v1,v2)) == NULL){ error("incompatible type assignment"); goto err; } #ifdef ENABLE_QREAL if (doQRealOpt == TRUE && atomic_flag == FALSE) { if (TYPE_BASIC_TYPE(EXPV_TYPE(v1)) == TYPE_QREAL) { if (expv_opt_qreal_let_statement(v1, EXPR_ARG2(w)) == TRUE) { break; } } } #endif /* ENABLE_QREAL */ if(atomic_flag){ output_statement(OMP_atomic_statement(w)); break; } output_expr_statement(w); break; default: error("assignment to a non-variable"); } break; case F_CONTINUE_STATEMENT: /* do nothing */ break; case F_GOTO_STATEMENT: { /* (F_GOTO_STATEMENT label) */ expv stLabel; x1 = EXPR_ARG1(x); stLabel = expr_constant_value(x1, TRUE); if (stLabel == NULL) { error("illegal label"); break; } if ((id = declare_label(EXPV_INT_VALUE(stLabel), LAB_EXEC,FALSE)) == NULL) break; output_statement(list1(GOTO_STATEMENT, expv_sym_term(IDENT,NULL,ID_SYM(id)))); break; } case F_CALL_STATEMENT: /* (F_CALL_STATEMENT identifier args)*/ x1 = EXPR_ARG1(x); if(EXPR_CODE(x1) != IDENT) fatal("compile_exec_statement: bad id in call"); id = declare_ident(EXPR_SYM(x1),CL_UNKNOWN); if(ID_TYPE(id) == NULL) ID_TYPE(id) = type_SUBR; if(ID_CLASS(id) == CL_PROC && !IS_SUBR(ID_TYPE(id))) if(ID_STORAGE(id) != STG_ARG) error("function is invoked as subroutine"); output_expr_statement(compile_function_call(id,EXPR_ARG2(x))); break; case F_RETURN_STATEMENT: /* (F_RETURN_STATMENT arg) */ if(EXPR_ARG1(x) != NULL){ error("alternative return is not supported"); break; } if(current_proc_class != CL_PROC) warning("RETURN statement in main or block data"); output_statement(list1(RETURN_STATEMENT,current_return_value)); break; case F_STOP_STATEMENT: case F_PAUSE_STATEMENT: x1 = EXPR_ARG1(x); if(x1 != NULL) v1 = expv_reduce(compile_expression(x1)); else v1 = NULL; if(v1 != NULL){ if (EXPR_CODE(v1) == INT_CONSTANT) { char str[32]; sprintf(str,"%d",EXPV_INT_VALUE(v1)); v1 = expv_str_term(STRING_CONSTANT,type_CHAR,strdup(str)); #ifdef HAS_INT64 } else if (EXPR_CODE(v1) == LONGLONG_CONSTANT) { char str[32]; int i = (int)EXPR_INT64(v1); sprintf(str,"%d",i); v1 = expv_str_term(STRING_CONSTANT,type_CHAR,strdup(str)); #endif /* HAS_INT64 */ } else if(EXPR_CODE(v1) != STRING_CONSTANT){ error("bad expression in %s statement", EXPR_CODE(x) == F_STOP_STATEMENT ? "STOP":"PAUSE"); break; } } w = expv_call_runtime(EXPR_CODE(x)==F_STOP_STATEMENT ? "s_stop":"s_paus",NULL, list2(LIST, v1 != NULL ? v1 : expv_constant_0, v1 != NULL ? expv_int_term(INT_CONSTANT,type_INT, strlen(EXPR_STR(v1))) : expv_constant_0)); output_expr_statement(w); break; case F_ARITHIF_STATEMENT: { /* (F_ARITHIF_STATEMENT expr l1 l2 l3) */ expv stLabel; v1 = compile_expression(EXPR_ARG1(x)); if(v1 == NULL) break; #ifdef HAS_INT64 if ((EXPR_CODE(EXPR_ARG4(x)) != INT_CONSTANT && EXPR_CODE(EXPR_ARG4(x)) != LONGLONG_CONSTANT) || (EXPR_CODE(EXPR_ARG3(x)) != INT_CONSTANT && EXPR_CODE(EXPR_ARG3(x)) != LONGLONG_CONSTANT) || (EXPR_CODE(EXPR_ARG2(x)) != INT_CONSTANT && EXPR_CODE(EXPR_ARG2(x)) != LONGLONG_CONSTANT)) #else if (EXPR_CODE(EXPR_ARG4(x)) != INT_CONSTANT || EXPR_CODE(EXPR_ARG3(x)) != INT_CONSTANT || EXPR_CODE(EXPR_ARG2(x)) != INT_CONSTANT) #endif /* HAS_INT64 */ { error("illegal label in arithmetic IF"); break; } if(!IS_INT(EXPV_TYPE(v1)) && !IS_REAL(EXPV_TYPE(v1))){ error("expression must be integer or real in arithmetic IF"); break; } { /* * To avoid side effect by evaluating v1 more than once, * have to generate temporary variable. */ expv vTmp = allocate_temp(EXPV_TYPE(v1)); output_expr_statement(expv_assignment(vTmp, v1)); v1 = vTmp; } v2 = expv_type_conversion(EXPV_TYPE(v1),expv_constant_0); stLabel = expr_constant_value(EXPR_ARG4(x), TRUE); if (stLabel == NULL) { error("illegal label in arithmetic IF"); break; } if((id = declare_label(EXPV_INT_VALUE(stLabel),LAB_EXEC,FALSE)) == NULL) break; output_statement( list3(IF_STATEMENT, expv_cons(LOG_GT_EXPR,type_LOGICAL,v1,v2), list1(GOTO_STATEMENT,expv_sym_term(IDENT,NULL,ID_SYM(id))), NULL)); stLabel = expr_constant_value(EXPR_ARG3(x), TRUE); if (stLabel == NULL) { error("illegal label in arithmetic IF"); break; } if((id = declare_label(EXPV_INT_VALUE(stLabel),LAB_EXEC,FALSE)) == NULL) break; output_statement( list3(IF_STATEMENT, expv_cons(LOG_EQ_EXPR,type_LOGICAL,v1,v2), list1(GOTO_STATEMENT,expv_sym_term(IDENT,NULL,ID_SYM(id))), NULL)); stLabel = expr_constant_value(EXPR_ARG2(x), TRUE); if (stLabel == NULL) { error("illegal label in arithmetic IF"); break; } if((id = declare_label(EXPV_INT_VALUE(stLabel),LAB_EXEC,FALSE)) == NULL) break; output_statement( list1(GOTO_STATEMENT,expv_sym_term(IDENT,NULL,ID_SYM(id)))); break; } case F_COMPGOTO_STATEMENT: { /* (F_COMPGOTO_STATEMENT (LIST ) expr) */ expv stLabel; v1 = compile_expression(EXPR_ARG2(x)); if(EXPR_ARG1(x) == NULL) break; /* error recovery */ FOR_ITEMS_IN_LIST(lp,EXPR_ARG1(x)){ x1 = LIST_ITEM(lp); if (EXPR_CODE(x1) != INT_CONSTANT #ifdef HAS_INT64 && EXPR_CODE(x1) != LONGLONG_CONSTANT #endif /* HAS_INT64 */ ) { error("illegal label in computed GOTO"); v1 = NULL; break; } } if(v1 == NULL) break; if(!IS_INT(EXPV_TYPE(v1))){ error("expression must be integer in computed GOTO"); break; } w = EMPTY_LIST; i = 1; FOR_ITEMS_IN_LIST(lp,EXPR_ARG1(x)){ x1 = LIST_ITEM(lp); stLabel = expr_constant_value(x1, TRUE); if (stLabel == NULL) { error("illegal label in computed GOTO"); break; } if((id = declare_label(EXPV_INT_VALUE(stLabel),LAB_EXEC,FALSE)) == NULL){ w = NULL; break; } v2 = list2(LIST, list1(CASE_LABEL, expv_int_term(INT_CONSTANT,type_INT,i++)), list1(GOTO_STATEMENT, expv_sym_term(IDENT,NULL,ID_SYM(id)))); list_put_last(w,v2); } if(w == NULL) break; output_statement(list2(SWITCH_STATEMENT,v1,w)); break; } /* * I/O statements */ case F_WRITE_STATEMENT: case F_PRINT_STATEMENT: case F_READ_STATEMENT: case F_READ1_STATEMENT: { compile_IO_statement(x); break; } case F_OPEN_STATEMENT: { compile_OPEN_statement(x); break; } case F_CLOSE_STATEMENT: { compile_CLOSE_statement(x); break; } case F_BACKSPACE_STATEMENT: case F_ENDFILE_STATEMENT: case F_REWIND_STATEMENT: { compile_FPOS_statement(x); break; } case F_INQUIRE_STATEMENT: { compile_INQUIRE_statement(x); break; } case F_ASSIGN_STATEMENT: { /* (F_ASSIGN_STATEMENT label id) */ expv stLabel; x1 = EXPR_ARG1(x); stLabel = expr_constant_value(x1, TRUE); if (stLabel == NULL) { error("illegal label"); break; } if((id = declare_label(EXPV_INT_VALUE(stLabel),LAB_EXEC,FALSE)) == NULL) break; if(EXPR_CODE(EXPR_ARG2(x)) != IDENT) fatal("F_ASSIGN_STATEMENT: not ident"); v1 = compile_lhs_expression(EXPR_ARG2(x)); if(!IS_INT(EXPV_TYPE(v1))) error("variable must be integer type in ASSIGN statement"); w = expv_cons(ASSIGN_EXPR,NULL,v1, expv_int_term(INT_CONSTANT,type_INT,EXPV_INT_VALUE(stLabel))); output_expr_statement(w); break; } case F_ASGOTO_STATEMENT: { /* (F_ASGOTO_STATEMENT IDENT list) */ expv stLabel; if(EXPR_ARG2(x) == NULL){ error("line number list must be specified in assigned GOTO"); break; } if(EXPR_CODE(EXPR_ARG1(x)) != IDENT) fatal("F_ASGOTO_STATEMENT: not ident"); v1 = compile_lhs_expression(EXPR_ARG1(x)); FOR_ITEMS_IN_LIST(lp,EXPR_ARG2(x)){ x1 = LIST_ITEM(lp); if (EXPR_CODE(x1) != INT_CONSTANT #ifdef HAS_INT64 && EXPR_CODE(x1) != LONGLONG_CONSTANT #endif /* HAS_INT64 */ ) { error("illegal label in assigned GOTO"); v1 = NULL; break; } } if(v1 == NULL) break; if(!IS_INT(EXPV_TYPE(v1))) error("variable must be integer type in assigned GOTO"); w = EMPTY_LIST; FOR_ITEMS_IN_LIST(lp,EXPR_ARG2(x)){ x1 = LIST_ITEM(lp); stLabel = expr_constant_value(x1, TRUE); if (stLabel == NULL) { error("illegal label in assigned GOTO"); w = NULL; break; } if((id = declare_label(EXPV_INT_VALUE(stLabel),LAB_EXEC,FALSE)) == NULL){ w = NULL; break; } v2 = list2(LIST, list1(CASE_LABEL, expv_int_term(INT_CONSTANT, type_INT,EXPV_INT_VALUE(stLabel))), list1(GOTO_STATEMENT, expv_sym_term(IDENT,NULL,ID_SYM(id)))); list_put_last(w,v2); } if(w == NULL) break; output_statement(list2(SWITCH_STATEMENT,v1,w)); output_expr_statement(expv_call_runtime("__abort_ASGOTO",NULL,NULL)); break; } default: fatal("unknown statement"); } err: /* clean up temps */ return; } /* * context control. keep track of context */ static void begin_procedure() { if(current_state != OUTSIDE){ error("missing end statement"); end_procedure(); } current_state = INSIDE; current_proc_class = CL_MAIN; /* default */ } void check_INDATA() { if(current_state == OUTSIDE){ begin_procedure(); declare_procedure(CL_MAIN,NULL,NULL,NULL); } if(NOT_INDATA_YET){ end_declaration(); current_state = INDATA; } } void check_INDCL() { switch(current_state){ case OUTSIDE: begin_procedure(); declare_procedure(CL_MAIN,NULL,NULL,NULL); case INSIDE: current_state = INDCL; case INDCL: break; default: error("declaration among executables"); } } void check_INEXEC() { if(current_state == OUTSIDE){ begin_procedure(); declare_procedure(CL_MAIN,NULL,NULL,NULL); } if(NOT_INDATA_YET) end_declaration(); } /* called at the end of declaration part */ static void end_declaration() { ID ip; current_state = INEXEC; /* the next status is EXEC */ if (debug_flag) { fprintf(debug_fp,"--- end_declaration ---\n"); print_IDs(local_symbols,debug_fp); } for (ip = local_symbols; ip != NULL; ip = ID_NEXT(ip)){ if(IS_ARRAY_TYPE(ID_TYPE(ip))){ fix_array_dimensions(ID_TYPE(ip)); implicit_declaration(ip); if (ID_TYPE(ip) == NULL) { error("can't determine type of '%s'", ID_NAME(ip)); continue; } if (ID_STORAGE(ip) == STG_UNKNOWN && type_length(ID_TYPE(ip)) < 0) { /* * Local adjustable array case. But How should I do if * this variable is used as a dummy arg for possible * later ENTRY statement???? * However, IN MOST CASE, we should treat it as a * stack variable allocated via alloca(), thus set * storage class to STG_AUTO. */ ID_STORAGE(ip) = STG_AUTO; output_expr_statement(expv_cons(ALLOCA, ID_TYPE(ip), expv_sym_term(IDENT, ID_TYPE(ip), ID_SYM(ip)), NULL)); } } } /* fix variable and proc definition so far */ for (ip = local_symbols; ip != NULL; ip = ID_NEXT(ip)){ if (ID_CLASS(ip) == CL_VAR) { /* * not declare_variable() but implicit_declaration(), cuz * gotta decide type at least. */ implicit_declaration(ip); } #ifdef not /* cannot decide type of argument until reference */ if (ID_STORAGE(ip) == STG_ARG && ID_CLASS(ip) == CL_UNKNOWN) { declare_variable(ip); } #endif } if(current_procedure != NULL){ current_ext_id = define_external_function_id(current_procedure); } /* * Fix common status before fixing equivalence status. */ declare_common_variables(); FinalizeEquivalence(); InitializeEquivalence(); FinalizeCrayPointer(); if (current_procedure != NULL) { /* * Mark here. */ output_statement(make_enode(FIRST_EXECUTION_POINT, (void *)NULL)); /* * Checking for entry declaration. Must be done at very here, * avoiding to generate entry jump label BEFORE switch-goto * table. */ for (ip = local_symbols; ip != NULL; ip = ID_NEXT(ip)) { if (ID_CLASS(ip) == CL_ENTRY) { define_entry(ip); } } } #ifdef ENABLE_QREAL else if (current_proc_class == CL_MAIN) { output_expr_statement(expv_call_runtime("_ompf77_QReal_init", NULL, list3(LIST, expv_int_term(INT_CONSTANT, type_INT, qRealPrec), expv_int_term(INT_CONSTANT, type_INT, gmpLimbSize), expv_int_term(INT_CONSTANT, type_INT, basic_type_size(TYPE_QREAL))))); } #endif /* ENABLE_QREAL */ } void define_entry(ID id) { EXT_ID ext_id; SYMBOL sp; ext_id = define_external_function_id(id); EXT_PROC_ENTRY_NEXT(ext_id) = EXT_PROC_ENTRY_NEXT(current_ext_id); EXT_PROC_ENTRY_NEXT(current_ext_id) = ext_id; if(ctl_top != ctls) error("entry in DO or IF"); sp = gen_symbol('E'); output_statement(list1(STATEMENT_LABEL,expv_sym_term(IDENT,NULL,sp))); EXT_PROC_ENTRY_LABEL(ext_id) = sp; EXT_PROC_ENTRY_NO(ext_id) = ++n_entry; } static EXT_ID define_external_function_id(ID id) { expr args; TYPE_DESC tp,tq; list lp; SYMBOL sp; ID ip; int have_char_param; expr x; EXT_ID ext_id; ext_id = NULL; /* clear */ implicit_declaration(id); tp = ID_TYPE(id); if(!IS_ELEMENT_TYPE(tp)){ error("bad data type declaration for function '%s'",ID_NAME(id)); return NULL; } args = EMPTY_LIST; /* make external entry */ ext_id = declare_external_proc_id(ID_SYM(id), tp, TRUE); if(ID_CLASS(id) == CL_ENTRY){ if(IS_CHAR(ID_TYPE(current_procedure)) && !IS_CHAR(tp)) error("entry '%s' must be character type in chacter function", ID_NAME(id)); if(!IS_CHAR(ID_TYPE(current_procedure)) && IS_CHAR(tp)) error("entry '%s' must not be character type in chacter function", ID_NAME(id)); } /* allocate return value space */ switch(TYPE_BASIC_TYPE(tp)){ case TYPE_SUBR: break; case TYPE_CHAR: if(TYPE_CHAR_LEN(tp) < 0){ error("bad character type declaration for function/entry '%s'", ID_NAME(id)); return NULL; } EXT_PROC_C_TYPE(ext_id) = type_CHAR_POINTER; sp = c_find_symbol("ret_val"); ip = declare_ident(sp,CL_VAR); ID_TYPE(ip) = tp; ID_STORAGE(ip) = STG_ARG; declare_variable(ip); x = list2(LIST,expv_sym_term(IDENT,type_CHAR_POINTER,sp),ID_ADDR(ip)); list_put_last(args,x); if(ID_CLASS(id) != CL_ENTRY) current_return_value = ID_ADDR(ip); PROC_RET_VAL(id) = current_return_value; break; case TYPE_COMPLEX: case TYPE_DCOMPLEX: /* OK */ default: /* if not subroutine, make return value slot */ if (ID_CLASS(id) != CL_ENTRY){ current_return_value = allocate_auto(tp); PROC_RET_VAL(id) = current_return_value; } else { /* multiple entry */ sp = c_find_symbol("ret_val"); ip = declare_ident(sp,CL_VAR); ID_TYPE(ip) = type_CHAR_POINTER; ID_STORAGE(ip) = STG_ARG; declare_variable(ip); if(EXPR_CODE(EXPR_ARG1(current_return_value)) == LVAR_ADDR){ EXPR_ARG1(current_return_value) = expv_cons(CAST_EXPR, pointer_type(EXPV_TYPE(current_return_value)), expv_sym_term(PARAM_VAR, type_CHAR_POINTER,sp), NULL); } PROC_RET_VAL(id) = expv_cons(POINTER_REF,tp, expv_cons(CAST_EXPR,pointer_type(tp), expv_sym_term(PARAM_VAR, type_CHAR_POINTER,sp), NULL),NULL); } break; } /* copy arg list */ have_char_param = FALSE; FOR_ITEMS_IN_LIST(lp,PROC_ARGS(id)){ x = LIST_ITEM(lp); if (EXPR_CODE(x) != IDENT) { error("define_external_funciton_id: not ident"); return NULL; } sp = EXPR_SYM(x); if((ip = find_ident(sp)) == NULL) fatal("define_external_function_id: ident is not found"); if(ID_CLASS(ip) == CL_PROC){ /* dummy procedure must be declared by 'external' */ implicit_declaration(ip); /* make ID_ADDR */ tq = pointer_type(function_type(ID_TYPE(ip))); ID_ADDR(ip) = expv_sym_term(FPARAM_VAR_ADDR,tq,ID_SYM(ip)); } else { declare_variable(ip); if (ID_ADDR(ip) == NULL) { error("'%s' is not declared", ID_NAME(ip)); return NULL; } tq = ID_TYPE(ip); if(is_char_type(tq)) have_char_param = TRUE; } x = list2(LIST,expv_sym_term(IDENT,tq,sp),ID_ADDR(ip)); list_put_last(args,x); } if(have_char_param){ FOR_ITEMS_IN_LIST(lp,PROC_ARGS(id)){ x = LIST_ITEM(lp); sp = EXPR_SYM(x); ip = find_ident(sp); if(is_char_type(ID_TYPE(ip))){ x = list2(LIST,expv_sym_term(IDENT,type_INT, char_len_param_name(sp)), expv_sym_term(PARAM_ADDR,pointer_type(type_INT), char_len_param_name(sp))); list_put_last(args,x); } } } EXT_PROC_ARGS(ext_id) = args; return ext_id; } /* end of procedure. generate variables, epilogs, and prologs */ static void end_procedure() { ID id; if(NOT_INDATA_YET) end_declaration(); FinalizeFormat(); /* check undefined variable */ for(id = local_symbols; id != NULL; id = ID_NEXT(id)){ if(ID_CLASS(id) == CL_UNKNOWN){ #ifdef not warning("variable '%s' is defined, but never used",ID_NAME(id)); #endif declare_variable(id); } if (ID_CLASS(id) == CL_VAR) { declare_variable(id); } } /* check undefined label */ for(id = local_labels; id != NULL; id = ID_NEXT(id)){ if(LAB_TYPE(id) != LAB_UNKNOWN && LAB_IS_USED(id) && !LAB_IS_DEFINED(id)) error("missing statement number %d", LAB_ST_NO(id)); } /* * Special case. */ if (current_statements != NULL && EXPV_CODE(current_statements) == FIRST_EXECUTION_POINT) { /* * Means no body. */ current_statements = NULL; } /* output */ switch(current_proc_class){ case CL_MAIN: EXT_PROC_BODY(current_ext_id) = current_statements; EXT_PROC_ID_LIST(current_ext_id) = local_symbols; EXT_PROC_LABEL_LIST(current_ext_id) = local_labels; EXT_PROC_DIRECTIVES(current_ext_id) = current_directives; if(debug_flag){ fprintf(debug_fp,"\n*** CL_MAIN:\n"); print_IDs(local_symbols,debug_fp); expv_output(current_statements,debug_fp); } break; case CL_BLOCK: if(debug_flag){ fprintf(debug_fp,"\n*** CL_BLOCK:\n"); print_IDs(local_symbols,debug_fp); } break; case CL_PROC: if(current_ext_id != NULL){ if(n_entry > 0){ make_multiple_entry_function(); } else { EXT_PROC_BODY(current_ext_id) = current_statements; EXT_PROC_ID_LIST(current_ext_id) = local_symbols; EXT_PROC_LABEL_LIST(current_ext_id) = local_labels; EXT_PROC_DIRECTIVES(current_ext_id) = current_directives; } } if(debug_flag){ fprintf(debug_fp,"\n*** CL_PROC('%s'):\n", SYM_NAME(current_proc_name)); print_IDs(local_symbols,debug_fp); expv_output(current_statements,debug_fp); } break; default: fatal("end_procedure: unknown current_proc_class"); } /* check control nesting */ if(ctl_top > ctls) error("DO loop or BLOCK IF not closed"); #ifdef not donmlist(); dobss(); #endif /* clean up for next procedure */ initialize_compile_procedure(); } /* * DO loop */ static void compile_DO_statement(range_st_no, var, init, limit, incr) int range_st_no; expr var, init, limit, incr; { expv do_var, do_init, do_limit, do_incr, t; ID do_label; TYPE_DESC var_tp; SYMBOL do_var_sym; int incsign = 0; CTL *cp; expr setup, setup_var, incr_var; setup = list0(COMMA_EXPR); setup_var = NULL; incr_var = NULL; if (range_st_no > 0) { do_label = declare_label(range_st_no, LAB_EXEC, FALSE); if (do_label == NULL) return; if (LAB_IS_DEFINED(do_label)) { error("no backward DO loops"); return; } LAB_IS_USED(do_label) = FALSE; /* turn off, becuase this is not branch */ } else do_label = NULL; if (EXPR_CODE(var) != IDENT) { fatal("compile_DO_statement: DO var is not IDENT"); } do_var_sym = EXPR_SYM(var); /* loop variable in parallel region is implicitly private. */ check_OMP_loop_var(do_var_sym); /* check nested loop with the same variable */ for (cp = ctls; cp < ctl_top; cp++) { if(CTL_TYPE(cp) == CTL_DO && CTL_DO_VAR(cp) == do_var_sym) { error("nested loops with variable '%s'", SYM_NAME(do_var_sym)); break; } } do_var = compile_lhs_expression(var); if (!expv_is_lvalue(do_var)) error("bad DO variable"); do_init = expv_reduce(compile_expression(init)); do_limit = expv_reduce(compile_expression(limit)); if (incr != NULL) do_incr = expv_reduce(compile_expression(incr)); else do_incr = expv_constant_1; if (do_var == NULL || do_init == NULL || do_limit == NULL || do_incr == NULL) return; var_tp = EXPV_TYPE(do_var); if (!IS_INT(var_tp) && !IS_REAL(var_tp)) { error("bad type on do variable"); return; } if ((!IS_INT(EXPV_TYPE(do_init)) && !IS_REAL(EXPV_TYPE(do_init))) || (!IS_INT(EXPV_TYPE(do_limit)) && !IS_REAL(EXPV_TYPE(do_limit))) || (!IS_INT(EXPV_TYPE(do_incr)) && !IS_REAL(EXPV_TYPE(do_incr)))) { error("bad type on DO parameter"); return; } #ifdef ENABLE_QREAL if (TYPE_BASIC_TYPE(EXPV_TYPE(do_var)) == TYPE_QREAL || TYPE_BASIC_TYPE(EXPV_TYPE(do_init)) == TYPE_QREAL || TYPE_BASIC_TYPE(EXPV_TYPE(do_limit)) == TYPE_QREAL || TYPE_BASIC_TYPE(EXPV_TYPE(do_incr)) == TYPE_QREAL) { error("quad-real do parameter is not supported yet."); return; } #endif /* ENABLE_QREAL */ if (IS_CONSTANT(do_incr)) { do_incr = expv_reduce_conv_const(var_tp, do_incr); if (EXPV_CODE(do_incr) == INT_CONSTANT) { incsign = EXPV_INT_VALUE(do_incr); if (incsign == 0) error("zero DO increment"); } else if (EXPV_CODE(do_incr) == FLOAT_CONSTANT) { if (EXPV_FLOAT_VALUE(do_incr) > 0.0) { incsign = 1; } else if (EXPV_FLOAT_VALUE(do_incr) < 0.0) { incsign = -1; } else { incsign = 0; error("zero DO increment"); } #ifdef HAS_INT64 } else if (EXPV_CODE(do_incr) == LONGLONG_CONSTANT) { _omInt64_t i64 = EXPV_INT64_VALUE(do_incr); if (i64 == 0) { error("zero DO increment"); } if (i64 < 0) { incsign = -1; } else { incsign = 1; } #endif /* HAS_INT64 */ } else { fatal("compile_DO_statement: do_incr is not CONSTANT"); } /* check limit */ if (IS_CONSTANT(do_limit)) { do_limit = expv_reduce_conv_const(var_tp, do_limit); } else { t = allocate_temp(var_tp); list_put_last(setup, expv_assignment(t, do_limit)); do_limit = t; } } else { /* if do_incr is a variable, convert as follows: * for(do_var=do_init, max_count=..., i = 0; i 0) { if (eI < sI) { warning("DO range never executed"); } } else if (incsign < 0) { if (sI < eI) { warning("DO range never executed"); } } } else if (IS_REAL(var_tp)) { double sD = EXPV_FLOAT_VALUE(do_init); double eD = EXPV_FLOAT_VALUE(do_limit); if (incsign > 0) { if (eD < sD) { warning("DO range never executed"); } } else if (incsign < 0) { if (sD < eD) { warning("DO range never executed"); } } } #else /* check loop which is never executed */ if (incsign > 0) { /* increment */ if ((IS_INT(var_tp) && EXPV_INT_VALUE(do_limit) < EXPV_INT_VALUE(do_init)) || (IS_REAL(var_tp) && EXPV_FLOAT_VALUE(do_limit) < EXPV_FLOAT_VALUE(do_init))) { warning("DO range never executed"); } } else if (incsign < 0) { /* decrement */ if ((IS_INT(var_tp) && EXPV_INT_VALUE(do_limit) > EXPV_INT_VALUE(do_init)) || (IS_REAL(var_tp) && EXPV_FLOAT_VALUE(do_limit) > EXPV_FLOAT_VALUE(do_init))) { warning("DO range never executed"); } } #endif /* HAS_INT64 */ } push_ctl(CTL_DO); CTL_DO_VAR(ctl_top) = do_var_sym; CTL_DO_LABEL(ctl_top) = do_label; /* * convert to FOR loop in C */ if (EXPV_LIST(setup) != NULL) { t = expv_assignment(do_var, do_init); list_put_last(setup, t); t = setup; } else { t = expv_assignment(do_var, do_init); } CTL_BLOCK(ctl_top) = list4(FOR_STATEMENT, t, NULL, NULL, NULL); if (incsign > 0) { /* increment */ CTL_DO_END(ctl_top) = expv_cons(LOG_LE_EXPR, type_LOGICAL, do_var, do_limit); } else if (incsign < 0) { /* decrement */ CTL_DO_END(ctl_top) = expv_cons(LOG_GE_EXPR, type_LOGICAL, do_var, do_limit); } else { /* variable */ CTL_DO_END(ctl_top) = expv_cons(LOG_LT_EXPR, type_LOGICAL, do_var, do_limit); } /* for variable incr loop */ if (setup_var != NULL) { CTL_DO_INCR(ctl_top) = list2(COMMA_EXPR, expv_cons(ASG_PLUS_EXPR, var_tp, do_var, do_incr), incr_var); output_expr_statement(setup_var); } else { CTL_DO_INCR(ctl_top) = expv_cons(ASG_PLUS_EXPR, var_tp, do_var, do_incr); } } static void compile_DOWHILE_statement(cond) expr cond; { expv v; if(cond == NULL) return; /* error recovery */ v = compile_expression(cond); push_ctl(CTL_DO); CTL_DO_VAR(ctl_top) = NULL; CTL_DO_LABEL(ctl_top) = NULL; CTL_BLOCK(ctl_top) = list2(WHILE_STATEMENT,v,NULL); } static void check_DO_end(label) ID label; { CTL *cp; if(label == NULL){ /* do ... enddo case */ if(CTL_TYPE(ctl_top) == CTL_DO && CTL_DO_LABEL(ctl_top) == NULL){ if(EXPR_CODE(CTL_BLOCK(ctl_top)) == WHILE_STATEMENT) EXPR_ARG2(CTL_BLOCK(ctl_top)) = current_statements; else /* else FOR_STATEMENT */ CTL_DO_BODY(ctl_top) = current_statements; pop_ctl(); } else error("'do' is not found for 'enddo'"); return; } while(CTL_TYPE(ctl_top) == CTL_DO && CTL_DO_LABEL(ctl_top) == label){ /* close DO block */ CTL_DO_BODY(ctl_top) = current_statements; pop_ctl(); } /* check DO loop which is not propery closed. */ for(cp = ctl_top; cp >= ctls; cp--){ if(CTL_TYPE(cp) == CTL_DO && CTL_DO_LABEL(cp) == label){ error("DO loop or IF-block not closed"); ctl_top = cp; pop_ctl(); } } } void make_multiple_entry_function() { SYMBOL sp,ent_arg_sp,ret_val_sp; expv args,x,xx,a; expv switches,params,tblV; EXT_ID ext_id,ep; list lp,lq; ID ids,ip; char name[MAX_NAME_LEN+10]; int gotFirstExec = FALSE; ret_val_sp = c_find_symbol("ret_val"); /* collect all parameters */ params = EMPTY_LIST; for(ep = current_ext_id; ep != NULL; ep = EXT_PROC_ENTRY_NEXT(ep)){ FOR_ITEMS_IN_LIST(lp,EXT_PROC_ARGS(ep)){ x = LIST_ITEM(lp); sp = EXPV_NAME(EXPR_ARG1(x)); FOR_ITEMS_IN_LIST(lq,params){ xx = LIST_ITEM(lq); if(sp == EXPV_NAME(EXPR_ARG1(xx))) goto found; } list_put_last(params,x); found: continue; } } /* internal function */ strcpy(name,"_body_"); strcat(name,SYM_NAME(EXT_SYM(current_ext_id))); ext_id = declare_external_proc_id(c_find_symbol(name), EXT_PROC_TYPE(current_ext_id), TRUE); if(IS_CHAR(EXT_PROC_TYPE(current_ext_id))) EXT_PROC_C_TYPE(ext_id) = type_CHAR_POINTER; switches = EMPTY_LIST; for(ep = current_ext_id; ep != NULL; ep = EXT_PROC_ENTRY_NEXT(ep)){ /* construct swtiches */ if(EXT_PROC_ENTRY_NO(ep) != 0){ x = list2(LIST, list1(CASE_LABEL,expv_int_term(INT_CONSTANT,type_INT, EXT_PROC_ENTRY_NO(ep))), list1(GOTO_STATEMENT, expv_sym_term(IDENT,NULL, EXT_PROC_ENTRY_LABEL(ep)))); list_put_last(switches,x); } /* make dummy list for VAR_DECL */ ids = NULL; if(EXT_PROC_TYPE(current_ext_id) != type_SUBR && !IS_CHAR(EXT_PROC_TYPE(current_ext_id))){ ip = new_ident_desc(ret_val_sp); ID_CLASS(ip) = CL_VAR; ID_STORAGE(ip) = STG_AUTO; ID_TYPE(ip) = type_char(basic_type_size(TYPE_DCOMPLEX)); ids = ip; } FOR_ITEMS_IN_LIST(lp,EXT_PROC_ARGS(ep)){ x = LIST_ITEM(lp); if(EXPR_CODE(EXPR_ARG1(x)) != PARAM_ADDR){ ip = new_ident_desc(EXPV_NAME(EXPR_ARG1(x))); ID_NEXT(ip) = ids; ids = ip; ID_CLASS(ip) = CL_PARAM; ID_STORAGE(ip) = STG_ARG; ID_TYPE(ip) = EXPV_TYPE(EXPR_ARG1(x)); } } EXT_PROC_ID_LIST(ep) = ids; /* setup arguments */ args = list1(LIST,expv_int_term(INT_CONSTANT,type_INT, EXT_PROC_ENTRY_NO(ep))); if(EXT_PROC_TYPE(current_ext_id) != type_SUBR && !IS_CHAR(EXT_PROC_TYPE(current_ext_id))){ list_put_last(args,expv_sym_term(LARRAY_ADDR,type_CHAR_POINTER, ret_val_sp)); } FOR_ITEMS_IN_LIST(lq,params){ x = LIST_ITEM(lq); a = expv_constant_0; FOR_ITEMS_IN_LIST(lp,EXT_PROC_ARGS(ep)){ xx = LIST_ITEM(lp); if(EXPV_NAME(EXPR_ARG1(x)) == EXPV_NAME(EXPR_ARG1(xx))){ a = EXPR_ARG2(xx); break; } } list_put_last(args,a); } if(EXT_PROC_TYPE(current_ext_id) == type_SUBR){ EXT_PROC_BODY(ep) = list1(EXPR_STATEMENT, list2(FUNCTION_CALL, expv_sym_term(FUNC_ADDR,NULL,EXT_SYM(ext_id)), args)); } else if(IS_CHAR(EXT_PROC_TYPE(current_ext_id)) || EXT_PROC_TYPE(current_ext_id) == EXT_PROC_TYPE(ep)){ EXT_PROC_BODY(ep) = list1(RETURN_STATEMENT, list2(FUNCTION_CALL, expv_sym_term(FUNC_ADDR,NULL,EXT_SYM(ext_id)), args)); } else { EXT_PROC_BODY(ep) = list2(LIST, list1(EXPR_STATEMENT, list2(FUNCTION_CALL, expv_sym_term(FUNC_ADDR,NULL, EXT_SYM(ext_id)), args)), list1(RETURN_STATEMENT, expv_cons(POINTER_REF,EXT_PROC_TYPE(ep), expv_cons(CAST_EXPR, pointer_type(EXT_PROC_TYPE(ep)),expv_sym_term(LARRAY_ADDR,type_CHAR_POINTER,ret_val_sp), NULL),NULL))); } } /* generate body */ if(EXT_PROC_TYPE(current_ext_id) != type_SUBR && !IS_CHAR(EXT_PROC_TYPE(current_ext_id))){ x = list2(LIST,expv_sym_term(IDENT,type_CHAR_POINTER,ret_val_sp), expv_sym_term(IDENT,type_CHAR_POINTER,ret_val_sp)); list_cons(x,params); } ent_arg_sp = c_find_symbol("_entry_n"); x = list2(LIST,expv_sym_term(IDENT,type_INT,ent_arg_sp), expv_sym_term(IDENT,pointer_type(type_INT),ent_arg_sp)); list_cons(x,params); EXT_PROC_ARGS(ext_id) = params; #if 0 list_cons(list2(SWITCH_STATEMENT, expv_sym_term(PARAM_VAR,type_INT,ent_arg_sp), switches), current_statements); #else tblV = list2(SWITCH_STATEMENT, expv_sym_term(PARAM_VAR,type_INT,ent_arg_sp), switches); FOR_ITEMS_IN_LIST(lp, current_statements) { if (EXPV_CODE(LIST_ITEM(lp)) == FIRST_EXECUTION_POINT) { LIST_ITEM(lp) = tblV; gotFirstExec = TRUE; break; } } if (gotFirstExec == FALSE) { fatal("make_multiple_entry_function(): can't find first execution point??"); } #endif EXT_PROC_BODY(ext_id) = current_statements; EXT_PROC_ID_LIST(ext_id) = local_symbols; EXT_PROC_LABEL_LIST(ext_id) = local_labels; }