static char rcsid[] = "$Id: F-io.c,v 1.50 2003/08/21 17:44:10 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" static void genIoStatement _ANSI_ARGS_((char *funcName, expv v, expv ioStatVar, expv errV, expv endV)); static void genSimpleIoRuntimeCall _ANSI_ARGS_((char *funcName, expv ioList, expv ioStatVar, expv errV, expv endV)); #define IOTYPE_SEQUENTIAL 0 #define IOTYPE_DIRECT 1 #define IOTYPE_UNITONLY 2 #define IOTYPE_INTERNAL 3 #define IOTYPE_NAMELIST 4 static char fmtVBuf[1024]; #define COND_ERR 0 #define COND_END 1 static expv genCondBranch(cond, var, label) int cond; ID var; ID label; { expv ret = NULL; enum expr_code eCode = ERROR_NODE; expr condX = NULL; expr zero = make_enode(INT_CONSTANT, (void *)0); expv bra = list1(GOTO_STATEMENT, expv_sym_term(IDENT, NULL, ID_SYM(label))); switch (cond) { case COND_ERR: eCode = F_GT_EXPR; break; case COND_END: eCode = F_LT_EXPR; break; default: fatal("internal compile error."); } condX = list2(eCode, expv_sym_term(IDENT, NULL, ID_SYM(var)), zero); ret = list3(IF_STATEMENT, compile_logical_expression(condX), bra, NULL); return ret; } static char * StatusLineToFormatVariableName(n) int n; { sprintf(fmtVBuf, "Fmt_%06d", n); return strdup(fmtVBuf); } static char * FormatVariableNameToStatusLineStr(name) char *name; { char *s = strstr(name, "Fmt_"); if (s == NULL) { return name; } else { s = name + 4; while (*s == '0') { s++; } return s; } } void compile_FORMAT_decl(st_no, x) int st_no; expr x; { ID fId; SYMBOL sym = NULL; sym = c_find_symbol(StatusLineToFormatVariableName(st_no)); fId = declare_ident(sym, CL_UNKNOWN); if (ID_CLASS(fId) == CL_UNKNOWN) { /* * means this format is declared before appeared in I/O * statement(s). */ fId = declare_ident(sym, CL_FORMAT); } else if (ID_CLASS(fId) != CL_FORMAT) { fatal("compile_FORMAT_decl: format type label is declared as other type??"); } if (FORMAT_STR(fId) == NULL) { switch (EXPR_CODE(EXPR_ARG1(x))) { case STRING_CONSTANT: { int len = strlen(EXPR_STR(EXPR_ARG1(x))); FORMAT_STR(fId) = expv_str_term(STRING_CONSTANT, type_char(len), strdup(EXPR_STR(EXPR_ARG1(x)))); break; } default: { error("invalid format."); break; } } } return; } void FinalizeFormat() { ID id; for (id = local_symbols; id != NULL; id = ID_NEXT(id)) { if (ID_CLASS(id) == CL_FORMAT) { if (FORMAT_STR(id) == NULL) { error("missing statement number %s (format).", FormatVariableNameToStatusLineStr(SYM_NAME(ID_SYM(id)))); } } } } static expv genIoArgs(v, new) expv v; expv new; { if (new == NULL) { new = list0(LIST); } switch (EXPR_CODE(v)) { case LIST: { list lp; expr x; FOR_ITEMS_IN_LIST(lp, v) { x = LIST_ITEM(lp); new = genIoArgs(x, new); } break; } case F_IMPLIED_DO: { expv newDo = list1(F_IMPLIED_DO, EXPR_ARG1(v)); new = list_put_last(new, list_put_last(newDo, genIoArgs(EXPR_ARG2(v), (expr)NULL))); break; } default: { new = list_put_last(new, v); break; } } return new; } #define TYUNKNOWN 0 #define TYADDR 1 #define TYSHORT 2 #define TYLONG 3 #define TYREAL 4 #define TYDREAL 5 #define TYCOMPLEX 6 #define TYDCOMPLEX 7 #define TYLOGICAL 8 #define TYCHAR 9 #define TYSUBR 10 #define TYINT1 11 #define TYLOGICAL1 12 #define TYLOGICAL2 13 #define TYQUAD 14 #ifdef ENABLE_QREAL #define TYQREAL 15 #endif /* ENABLE_QREAL */ static int omniTypeTof2cType(type) BASIC_DATA_TYPE type; { int ret = TYUNKNOWN; switch (type) { case TYPE_UNKNOWN: { ret = TYUNKNOWN; break; } case TYPE_SHORT: { ret = TYSHORT; break; } case TYPE_INT: { ret = TYLONG; break; } case TYPE_REAL: { ret = TYREAL; break; } case TYPE_DREAL: { ret = TYDREAL; break; } case TYPE_COMPLEX: { ret = TYCOMPLEX; break; } case TYPE_DCOMPLEX: { ret = TYDCOMPLEX; break; } case TYPE_LOGICAL: { ret = TYLOGICAL; break; } case TYPE_CHAR: { ret = TYCHAR; break; } case TYPE_SUBR: { ret = TYSUBR; break; } case TYPE_LONGLONG: { ret = TYQUAD; break; } #ifdef ENABLE_QREAL case TYPE_QREAL: { ret = TYQREAL; break; } #endif /* ENABLE_QREAL */ default: { fatal("unknown type in io list."); break; } } return ret; } static int compileIoArg(a, vVPtr, lVPtr, tVPtr, nVPtr) expr a; expv *vVPtr; expv *lVPtr; expv *tVPtr; expv *nVPtr; { int nTimes = 1; int basicLen = 0; expv v; BASIC_DATA_TYPE typ = TYPE_UNKNOWN; int doAddr = FALSE; expv vCharLen = NULL; expv vNTimes = NULL; expv basicLen_v = NULL; if (EXPR_CODE(a) == IDENT) { ID id = declare_ident(EXPR_SYM(a),CL_UNKNOWN); switch (ID_CLASS(id)) { case CL_PROC: if (PROC_CLASS(id) == P_THISPROC) { if (current_return_value) { v = current_return_value; v = expv_get_address(v); } else { error("illegal use of subroutine name."); return FALSE; } } else { if (declare_function(id,FALSE) == NULL) { error("can't declare id."); return FALSE; } v = ID_ADDR(id); } goto vOk; case CL_VAR: case CL_UNKNOWN: /* check variable name */ declare_variable(id); typ = getBasicType(ID_TYPE(id)); if (typ == TYPE_UNKNOWN) { error("can't determine type."); return FALSE; } basicLen = basic_type_size(typ); if (IS_ARRAY_TYPE(ID_TYPE(id)) /*|| IS_CHAR(ID_TYPE(id))*/) { v = ID_ADDR(id); if (IS_ARRAY_TYPE(ID_TYPE(id))) { expv lSpec = id_array_dimension_list(id); list lp; vNTimes = expv_constant_1; FOR_ITEMS_IN_LIST(lp, lSpec) { vNTimes = expv_cons(MUL_EXPR, type_INT, vNTimes, EXPR_ARG1(LIST_ITEM(lp))); } vNTimes = expv_reduce(vNTimes); if (BASIC_IS_CHAR(typ)) { int typLen = type_length(ID_TYPE(id)); if (typLen < 0) { vCharLen = expv_int_term(INT_CONSTANT, type_INT, type_length(getBaseType(ID_TYPE(id)))); } else { vCharLen = expv_cons(DIV_EXPR, type_INT, expv_int_term(INT_CONSTANT, type_INT, typLen), vNTimes); } } vCharLen = expv_reduce(vCharLen); goto lOk; } goto vOk; } break; case CL_PARAM: break; default: fatal("illegal argument."); } } else if (EXPR_CODE(a) == F_SUBSTR_REF) { v = convertSubstrRefToPointerRef(a, &vCharLen); if (v == NULL) { fatal("can't parse I/O list."); } typ = TYPE_CHAR; goto lOk; } if ((v = compile_expression(a)) == NULL) { fatal("can't parse I/O list."); } if ((v = expv_reduce(v)) == NULL) { fatal("can't parse I/O list."); } doAddr = TRUE; vOk: typ = getBasicType(EXPV_TYPE(v)); if (typ == TYPE_UNKNOWN) { fatal("can't determine type."); } basicLen = basic_type_size(typ); if (IS_CHAR(EXPV_TYPE(v))) { vCharLen = expv_reduce(expv_char_len(v)); if (vCharLen == NULL) { fatal("compileIoArg: not CHAR??"); } } else { basicLen = type_length(EXPV_TYPE(v)); if (basicLen < 0) { basicLen_v = expv_char_len(v); /* fatal("compileIoArg: adjustable?"); */ } } lOk: if (lVPtr != NULL) { if (vCharLen == NULL) { if(basicLen < 0){ if(basicLen_v == NULL) fatal("compileIoArg: adjustable?"); *lVPtr = basicLen_v; } else *lVPtr = expv_int_term(INT_CONSTANT, type_INT, basicLen); } else { *lVPtr = vCharLen; } } if (nVPtr != NULL) { if (vNTimes == NULL) { *nVPtr = expv_int_term(INT_CONSTANT, type_INT, nTimes); } else { *nVPtr = vNTimes; } } if (tVPtr != NULL) { *tVPtr = expv_int_term(INT_CONSTANT, type_INT, omniTypeTof2cType(typ)); } if (doAddr == TRUE) { v = expv_get_address(v); } if (vVPtr != NULL) { *vVPtr = v; } return TRUE; } void genSimpleIoRuntimeCall(funcName, ioList, ioStatVar, errV, endV) char *funcName; expv ioList; expv ioStatVar; expv errV; expv endV; { if (ioList == NULL) { return; } else { expv v; expv vv, vl, vt, vn; list lp; expr a; expv ioArgs = NULL; int nIoArgs = 0; FOR_ITEMS_IN_LIST(lp, ioList) { nIoArgs++; } ioArgs = list1(LIST, expv_int_term(INT_CONSTANT, type_INT, nIoArgs)); FOR_ITEMS_IN_LIST(lp, ioList) { a = LIST_ITEM(lp); if (compileIoArg(a, &vv, &vl, &vt, &vn) != TRUE) { fatal("can't generate I/O runtime call."); } list_put_last(ioArgs, vv); list_put_last(ioArgs, vl); list_put_last(ioArgs, vn); list_put_last(ioArgs, vt); } if (ioStatVar != NULL) { v = expv_assignment(ioStatVar, expv_call_runtime(funcName, type_INT, ioArgs)); } else { v = expv_call_runtime(funcName, type_INT, ioArgs); } output_expr_statement(v); if (errV != NULL) { output_expr_statement(errV); } if (endV != NULL) { output_expr_statement(endV); } } } static void genLoopStart(loopSpec) expr loopSpec; { expv do_var, do_init, do_limit, do_incr, t; expr var, init, limit, incr; TYPE_DESC var_tp; SYMBOL do_var_sym; int incsign = 0; CTL *cp; expr setup, setup_var, incr_var; var = EXPR_ARG1(loopSpec); init = EXPR_ARG2(loopSpec); limit = EXPR_ARG3(loopSpec); incr = EXPR_ARG4(loopSpec); setup = list0(COMMA_EXPR); setup_var = NULL; incr_var = 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; } 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; /* * 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 genLoopEnd() { CTL_DO_BODY(ctl_top) = list1(LIST, current_statements); pop_ctl(); } static void genIoStatement(funcName, v, ioStatVar, errV, endV) char *funcName; expv v; expv ioStatVar; expv errV; expv endV; { if (EXPV_CODE(v) != LIST) { fatal("internal compiler error."); } else { list lp; expr x; expv ioList = NULL; FOR_ITEMS_IN_LIST(lp, v) { x = LIST_ITEM(lp); if (EXPR_CODE(x) == F_IMPLIED_DO) { if (ioList != NULL) { genSimpleIoRuntimeCall(funcName, ioList, ioStatVar, errV, endV); } ioList = NULL; genLoopStart(EXPR_ARG1(x)); genIoStatement(funcName, EXPR_ARG2(x), ioStatVar, errV, endV); genLoopEnd(); } else { if (ioList == NULL) { ioList = list0(LIST); } ioList = list_put_last(ioList, x); } } if (ioList != NULL) { genSimpleIoRuntimeCall(funcName, ioList, ioStatVar, errV, endV); } } } static int expr_is_namelist(x, idPtr) expr x; ID *idPtr; { if (idPtr != NULL) { *idPtr = NULL; } if (EXPR_CODE(x) == IDENT) { ID id = declare_ident(EXPR_SYM(x), CL_UNKNOWN); if (ID_CLASS(id) == CL_NAMELIST) { if (idPtr != NULL) { *idPtr = id; } return TRUE; } } return FALSE; } static expr expr_namelist(x) expr x; { ID id; if (expr_is_namelist(x, &id) == TRUE) { return NL_LIST(id); } return NULL; } static char * upperIdent(str) char *str; { char *ret = strdup(str); char *rC = ret; while (*rC != '\0') { if (isalpha((int)*rC) && islower((int)*rC)) { *rC = toupper((int)*rC); } rC++; } return ret; } #define FIO_READ 0 #define FIO_WRITE 1 static void genNamelistIoCall(rw, namelistStr, nlVars, unit, ioStatVar, errFlagV, errV, endFlagV, endV, recV) int rw; expr namelistStr; expr nlVars; expv unit; expv ioStatVar; expv errFlagV; expv errV; expv endFlagV; expv endV; expv recV; { ID nlVId; list lp; expr nlVX; TYPE_DESC tp; int nVars = 0; expv addrV; expv typV; expv initArgs = NULL; char *varName; char *nlName; char *doFunc = NULL; expv v; expv rwArgs = list0(LIST); if (rw == FIO_READ) { doFunc = "_IO_Do_R_Namelist"; } else { doFunc = "_IO_Do_W_Namelist"; } list_put_last(rwArgs, expv_int_term(INT_CONSTANT, type_INT, rw)); output_expr_statement(expv_call_runtime("_IO_Init_Namelist_Prolog", NULL, rwArgs)); FOR_ITEMS_IN_LIST(lp, nlVars) { initArgs = list0(LIST); nlVX = LIST_ITEM(lp); nlVId = declare_ident(EXPR_SYM(nlVX), CL_UNKNOWN); if (ID_CLASS(nlVId) == CL_UNKNOWN) { declare_ident(EXPR_SYM(nlVX), CL_VAR); } if (ID_CLASS(nlVId) != CL_VAR) { error("'%s' is not a variable.", SYM_NAME(ID_SYM(nlVId))); return; } if (compileIoArg(nlVX, &addrV, (expv *)NULL, &typV, (expv *)NULL) == FALSE) { fatal("can't generate I/O runtime call (namelist)."); } varName = upperIdent(SYM_NAME(ID_SYM(nlVId))); initArgs = list_put_last(initArgs, expv_str_term(STRING_CONSTANT, type_char(strlen(varName)), varName)); initArgs = list_put_last(initArgs, addrV); initArgs = list_put_last(initArgs, typV); tp = ID_TYPE(nlVId); if (IS_ARRAY_TYPE(tp)) { list lq; expv dimSpec = id_array_spec_list(nlVId); expv dimV = EXPR_ARG2(dimSpec); expv maxX = expv_constant_1; int nDim = EXPR_INT(EXPR_ARG1(dimSpec)); int i; expv cIdxV, cDimV; expv cMulV = expv_constant_1; expv offV = expv_constant_0; FOR_ITEMS_IN_LIST(lq, dimV) { maxX = expv_cons(MUL_EXPR, type_INT, maxX, EXPR_ARG1(LIST_ITEM(lq))); } maxX = expv_reduce(maxX); for (i = 0; i < nDim; i++) { cDimV = expr_list_get_n(dimV, i); cIdxV = EXPR_ARG3(cDimV); offV = expv_cons(PLUS_EXPR, type_INT, offV, expv_cons(MUL_EXPR, type_INT, cMulV, cIdxV)); cMulV = expv_cons(MUL_EXPR, type_INT, cMulV, EXPR_ARG1(cDimV)); } offV = expv_cons(MINUS_EXPR, type_INT, offV, maxX); offV = expv_cons(PLUS_EXPR, type_INT, offV, expv_constant_1); offV = expv_reduce(offV); initArgs = list_put_last(initArgs, expv_int_term(INT_CONSTANT, type_INT, nDim)); initArgs = list_put_last(initArgs, maxX); initArgs = list_put_last(initArgs, offV); for (i = 0; i < (nDim - 1); i++) { initArgs = list_put_last(initArgs, EXPR_ARG1(expr_list_get_n(dimV, i))); } } else { initArgs = list_put_last(initArgs, expv_constant_0); } output_expr_statement(expv_call_runtime("_IO_Init_Namelist_AddVar", NULL, initArgs)); nVars++; } initArgs = list0(LIST); initArgs = list_put_last(initArgs, unit); nlName = upperIdent(SYM_NAME(EXPR_SYM(namelistStr))); initArgs = list_put_last(initArgs, expv_str_term(STRING_CONSTANT, type_char(strlen(nlName)), nlName)); initArgs = list_put_last(initArgs, expv_int_term(INT_CONSTANT, type_INT, nVars)); initArgs = list_put_last(initArgs, recV); initArgs = list_put_last(initArgs, errFlagV); initArgs = list_put_last(initArgs, endFlagV); output_expr_statement(expv_call_runtime("_IO_Init_Namelist_Epilog", NULL, initArgs)); if (ioStatVar != NULL) { v = expv_assignment(ioStatVar, expv_call_runtime(doFunc, type_INT, list0(LIST))); } else { v = expv_call_runtime(doFunc, type_INT, list0(LIST)); } output_expr_statement(v); if (errV != NULL) { output_expr_statement(errV); } if (endV != NULL) { output_expr_statement(endV); } output_expr_statement(expv_call_runtime("_IO_Clean_Namelist", NULL, rwArgs)); } void compile_IO_statement(x) expr x; { #ifdef DEBUG_IO int isFormatNULL = FALSE; #endif expv formatStr = NULL; expv namelistStr = NULL; expv unit = NULL; expv ioList = EXPR_ARG2(x); expv ioSpec = NULL; ID fID; expv v; expv initArgs; int rw = FIO_READ; int ioType = IOTYPE_SEQUENTIAL; int hasFMTSpec = FALSE; int hasUNITSpec = FALSE; int hasRECSpec = FALSE; int hasNMLSpec = FALSE; expv nlVars = NULL; expv memLen = NULL; char *ioInitFunc = NULL; char *ioCleanFunc = NULL; char *ioDoFunc = NULL; expv ioStatVar = NULL; expv errV = NULL; expv endV = NULL; expv recV = NULL; expv errFlagV = NULL; expv endFlagV = NULL; switch (EXPR_CODE(x)) { case F_WRITE_STATEMENT: case F_PRINT_STATEMENT: { rw = FIO_WRITE; break; } case F_READ_STATEMENT: case F_READ1_STATEMENT: { rw = FIO_READ; break; } default: { fatal("no IO statement."); } } if (rw == FIO_READ) { ioInitFunc = "_IO_Init_R"; ioCleanFunc = "_IO_Clean_R"; ioDoFunc = "_IO_Do_R"; } else { ioInitFunc = "_IO_Init_W"; ioCleanFunc = "_IO_Clean_W"; ioDoFunc = "_IO_Do_W"; } if (EXPR_ARG1(x) != NULL) { if (EXPR_CODE(EXPR_ARG1(x)) == LIST) { ID errLabel = NULL; ID endLabel = NULL; ID vId = NULL; int allowSpecs[] = { IO_SPEC_UNIT, IO_SPEC_FMT, IO_SPEC_REC, IO_SPEC_IOSTAT, IO_SPEC_ERR, IO_SPEC_NML, IO_SPEC_END }; ioSpec = NormalizeIoSpecifier(x); if (ioSpec == NULL) { return; } if (CheckIoSpecifierSanity(ioSpec, allowSpecs, 7) != TRUE) { return; } /* * check unit. */ unit = GetIoSpecifierValue(ioSpec, IO_SPEC_UNIT, &hasUNITSpec); if (hasUNITSpec == FALSE) { error("unit is not specified."); return; } /* * check format/namelist. */ formatStr = GetIoSpecifierValue(ioSpec, IO_SPEC_FMT, &hasFMTSpec); namelistStr = GetIoSpecifierValue(ioSpec, IO_SPEC_NML, &hasNMLSpec); if (hasFMTSpec == TRUE && hasNMLSpec == TRUE) { error("format and namelist are exclusive."); return; } if (hasNMLSpec == TRUE) { nlVars = expr_namelist(namelistStr); } /* * check other I/O specifier. */ ioStatVar = Get_IOSTAT_Variable(ioSpec, &vId); /* * check record specifier. */ recV = GetIoSpecifierValueAsInteger(ioSpec, IO_SPEC_REC, TRUE, &hasRECSpec); /* * check error specifier. */ errLabel = Get_ERRorEND_Label(ioSpec, IO_SPEC_ERR); /* * check end-of-file specifier. */ endLabel = Get_ERRorEND_Label(ioSpec, IO_SPEC_END); if (EXPR_CODE(x) == F_WRITE_STATEMENT && endLabel != NULL) { error("write statement should not have a end-of-file specifier."); return; } if (errLabel != NULL || endLabel != NULL) { if (ioStatVar == NULL) { ioStatVar = allocate_temp2(type_INT, &vId); } } if (errLabel != NULL) { errV = genCondBranch(COND_ERR, vId, errLabel); } if (endLabel != NULL) { endV = genCondBranch(COND_END, vId, endLabel); } if (hasUNITSpec == TRUE && hasFMTSpec == FALSE && hasRECSpec == FALSE) { ioType = IOTYPE_UNITONLY; } else if (hasRECSpec == TRUE) { if (hasFMTSpec == TRUE && formatStr == NULL) { error("direct list-directed I/O not allowed."); return; } ioType = IOTYPE_DIRECT; } } else { if (EXPR_CODE(x) == F_READ1_STATEMENT || EXPR_CODE(x) == F_PRINT_STATEMENT) { formatStr = EXPR_ARG1(x); if (expr_is_namelist(formatStr, (ID *)NULL) == TRUE) { hasNMLSpec = TRUE; namelistStr = formatStr; formatStr = NULL; nlVars = expr_namelist(namelistStr); } } else { error("only print and read statement should be in this form."); return; } } } else { if (EXPR_CODE(x) == F_READ1_STATEMENT || EXPR_CODE(x) == F_PRINT_STATEMENT) { formatStr = NULL; } else { error("only print and read statement should be in this form."); return; } } if (formatStr != NULL) { BASIC_DATA_TYPE typ; expv vTmp = compile_args(list1(LIST, formatStr), TRUE); if (vTmp == NULL || EXPR_ARG1(vTmp) == NULL) { fatal("internal compiler error."); } vTmp = EXPR_ARG1(vTmp); if (EXPV_TYPE(vTmp) == NULL) { fatal("can't determine type of format specifier."); } typ = getBasicType(EXPV_TYPE(vTmp)); if (typ == TYPE_UNKNOWN) { fatal("can't determine type of format specifier."); } if (EXPR_CODE(vTmp) == FCOMM_ARRAY_ADDR) { /* * special case. */ ID id = declare_ident(EXPR_SYM(EXPR_ARG1(vTmp)), CL_UNKNOWN); if ((ID_STORAGE(id) == STG_COMEQ || ID_STORAGE(id) == STG_EQUIV) && VAR_EQUIV_BY_DATA(id) == TRUE) { int len = type_length(ID_TYPE(id)); expv tmpStrV = allocate_temp(type_char(len + 1)); expv argsV = list3(LIST, tmpStrV, vTmp, expv_int_term(INT_CONSTANT, type_INT, len)); output_expr_statement(expv_call_runtime("_to_str", NULL, argsV)); formatStr = tmpStrV; } else { goto InvalidFormat; } } else if (BASIC_IS_INT(typ)) { if (EXPR_CODE(formatStr) == INT_CONSTANT #ifdef HAS_INT64 || EXPR_CODE(formatStr) == LONGLONG_CONSTANT #endif /* HAS_INT64 */ ) { expv stLabel = expr_constant_value(formatStr, TRUE); SYMBOL fSym; if (stLabel == NULL) { error("illegal format statement label"); return; } fSym = c_find_symbol(StatusLineToFormatVariableName(EXPV_INT_VALUE(stLabel))); fID = declare_ident(fSym, CL_UNKNOWN); if (ID_CLASS(fID) == CL_FORMAT && FORMAT_STR(fID) != NULL) { formatStr = FORMAT_STR(fID); } else { fID = declare_ident(fSym, CL_FORMAT); FORMAT_STR(fID) = NULL; formatStr = list1(UNRESOLVED_FORMAT, expv_any_term(ID_LIST, (void *)fID)); } } else { fatal("format specified by integer variable, but not supported by runtime."); } } else if (BASIC_IS_CHAR(typ)) { formatStr = vTmp; } else { InvalidFormat: error("invalid format."); return; } } else { #ifdef DEBUG_IO isFormatNULL = TRUE; #endif formatStr = expv_int_term(INT_CONSTANT, type_INT, 0); } if (unit == NULL) { unit = allocate_temp(type_INT); if (rw == FIO_READ) { output_expr_statement(expv_assignment(unit, expv_int_term(INT_CONSTANT, type_INT, 5))); } else { output_expr_statement(expv_assignment(unit, expv_int_term(INT_CONSTANT, type_INT, 6))); } unit = expv_get_address(unit); } else { if (EXPR_CODE(unit) == F_SUBSTR_REF) { unit = convertSubstrRefToPointerRef(unit, &memLen); if (unit == NULL) { fatal("can't parse unit specifier."); } if (ioType == IOTYPE_UNITONLY) { error("unformatted internal I/O not allowed."); return; } else if (ioType == IOTYPE_DIRECT) { error("direct internal I/O not allowed."); return; } ioType = IOTYPE_INTERNAL; } else if (EXPR_CODE(unit) == INT_CONSTANT #ifdef HAS_INT64 || EXPR_CODE(unit) == LONGLONG_CONSTANT #endif /* HAS_INT64 */ ) { expv tI = compile_expression(unit); unit = allocate_temp(type_INT); output_expr_statement(expv_assignment(unit, (EXPR_CODE(unit) == INT_CONSTANT) ? tI : expv_cons(CAST_EXPR, type_INT, tI, NULL))); unit = expv_get_address(unit); } else { BASIC_DATA_TYPE typ; expv vTmp = compile_args(list1(LIST, unit), TRUE); if (vTmp == NULL || EXPR_ARG1(vTmp) == NULL) { fatal("internal compiler error."); } vTmp = EXPR_ARG1(vTmp); if (EXPV_TYPE(vTmp) == NULL) { fatal("can't determine type of format specifier."); } typ = getBasicType(EXPV_TYPE(vTmp)); if (typ == TYPE_UNKNOWN) { fatal("can't determine type of format specifier."); } if (BASIC_IS_CHAR(typ)) { expv vOrg = expv_reduce(compile_expression(unit)); memLen = expv_reduce(expv_char_len(vOrg)); if (memLen == NULL) { fatal("internal compiler error."); } if (ioType == IOTYPE_UNITONLY) { error("unformatted internal I/O not allowed."); return; } else if (ioType == IOTYPE_DIRECT) { error("direct internal I/O not allowed."); return; } ioType = IOTYPE_INTERNAL; } else if (BASIC_IS_INT(typ)) { if (typ != TYPE_INT) { /* unit must be integer*4. */ expv tt = allocate_temp(type_INT); output_expr_statement( expv_assignment(tt, expv_cons(CAST_EXPR, type_INT, expv_cons(POINTER_REF, EXPV_TYPE(vTmp), vTmp, NULL), NULL))); vTmp = expv_get_address(tt); } } else { error_at_node(unit, "unit must be integer or string expression."); return; } unit = vTmp; } if (ioType == IOTYPE_INTERNAL) { if (rw == FIO_READ) { ioInitFunc = "_IO_Init_R_Mem"; ioCleanFunc = "_IO_Clean_R_Mem"; ioDoFunc = "_IO_Do_R_Mem"; } else { ioInitFunc = "_IO_Init_W_Mem"; ioCleanFunc = "_IO_Clean_W_Mem"; ioDoFunc = "_IO_Do_W_Mem"; } } } #ifdef DEBUG_IO { char *ccc; fprintf(stderr, "debug: s_%c", (rw == FIO_READ) ? 'r' : 'w'); if (ioType == IOTYPE_UNITONLY) { ccc = "sue"; } else if (ioType == IOTYPE_SEQUENTIAL) { if (isFormatNULL == TRUE) { ccc = "sle"; } else { ccc = "sfe"; } } else if (ioType == IOTYPE_DIRECT) { if (isFormatNULL == TRUE) { ccc = "due"; } else { ccc = "dfe"; } } else if (ioType == IOTYPE_INTERNAL) { if (isFormatNULL == TRUE) { ccc = "sli"; } else { ccc = "sfi"; } } fprintf(stderr, "%s()\n", ccc); } #endif if (errV != NULL || ioStatVar != NULL) { errFlagV = expv_int_term(INT_CONSTANT, type_INT, 1); } else { errFlagV = expv_int_term(INT_CONSTANT, type_INT, 0); } if (endV != NULL || ioStatVar != NULL) { endFlagV = expv_int_term(INT_CONSTANT, type_INT, 1); } else { endFlagV = expv_int_term(INT_CONSTANT, type_INT, 0); } if (nlVars != NULL && namelistStr != NULL) { if (recV == NULL) { recV = expv_int_term(INT_CONSTANT, type_INT, 0); } genNamelistIoCall(rw, namelistStr, nlVars, unit, ioStatVar, errFlagV, errV, endFlagV, endV, recV); return; } /* * Call Initializer. */ initArgs = list0(LIST); if (ioType == IOTYPE_INTERNAL) { initArgs = list_put_last(initArgs, unit); initArgs = list_put_last(initArgs, memLen); initArgs = list_put_last(initArgs, formatStr); initArgs = list_put_last(initArgs, errFlagV); initArgs = list_put_last(initArgs, endFlagV); } else { expv ioTypeV = expv_int_term(INT_CONSTANT, type_INT, ioType); if (recV == NULL) { recV = expv_int_term(INT_CONSTANT, type_INT, 0); } initArgs = list_put_last(initArgs, ioTypeV); initArgs = list_put_last(initArgs, unit); initArgs = list_put_last(initArgs, formatStr); initArgs = list_put_last(initArgs, recV); initArgs = list_put_last(initArgs, errFlagV); initArgs = list_put_last(initArgs, endFlagV); } if (ioStatVar != NULL) { v = expv_assignment(ioStatVar, expv_call_runtime(ioInitFunc, type_INT, initArgs)); } else { v = expv_call_runtime(ioInitFunc, type_INT, initArgs); } output_expr_statement(v); if (errV != NULL) { output_expr_statement(errV); } if (endV != NULL) { output_expr_statement(endV); } /* * Call IO routine. */ if (ioList != NULL) { genIoStatement(ioDoFunc, genIoArgs(ioList, (expv)NULL), ioStatVar, errV, endV); } /* * Call Cleaner */ if (ioStatVar != NULL) { v = expv_assignment(ioStatVar, expv_call_runtime(ioCleanFunc, type_INT, NULL)); } else { v = expv_call_runtime(ioCleanFunc, type_INT, NULL); } output_expr_statement(v); if (errV != NULL) { output_expr_statement(errV); } if (endV != NULL) { output_expr_statement(endV); } return; } static expv genDefaultStringValue(str, lenVPtr) char *str; expv *lenVPtr; { int len = strlen(str); expv ret = expv_str_term(STRING_CONSTANT, type_char(len), strdup(str)); if (lenVPtr != NULL) { expv lenV = expv_int_term(INT_CONSTANT, type_INT, len); *lenVPtr = lenV; } return ret; } static expv genDefaultIntegerValue(val) int val; { expv ret = allocate_temp(type_INT); output_expr_statement(expv_assignment(ret, expv_int_term(INT_CONSTANT, type_INT, val))); return expv_get_address(ret); } void compile_OPEN_statement(x) expr x; { expv callArgs = list0(LIST); expv oList = NULL; expv v; ID vId = NULL; expv unitV = NULL; expv ioStatVar = NULL; expv errV = NULL; ID errLabel = NULL; expv fileV = NULL; expv fileLenV = NULL; expv statusV = NULL; expv statusLenV = NULL; expv accessV = NULL; expv accessLenV = NULL; expv formV = NULL; expv formLenV = NULL; expv reclV = NULL; expv blankV = NULL; expv blankLenV = NULL; expv errFlagV = NULL; int hasUNITSpec = FALSE; int allowSpecs[] = { IO_SPEC_UNIT, IO_SPEC_IOSTAT, IO_SPEC_ERR, IO_SPEC_FILE, IO_SPEC_STATUS, IO_SPEC_ACCESS, IO_SPEC_FORM, IO_SPEC_RECL, IO_SPEC_BLANK }; if (EXPR_CODE(EXPR_ARG1(x)) != LIST) { return; } oList = NormalizeIoSpecifier(x); if (oList == NULL) { return; } if (CheckIoSpecifierSanity(oList, allowSpecs, 9) != TRUE) { return; } /* UNIT */ unitV = GetIoSpecifierValueAsInteger(oList, IO_SPEC_UNIT, TRUE, &hasUNITSpec); if (hasUNITSpec == FALSE) { error("no unit number is specified."); return; } callArgs = list_put_last(callArgs, unitV); /* FILE */ fileV = GetIoSpecifierValueAsString(oList, IO_SPEC_FILE, NULL, &fileLenV); if (fileV == NULL) { fileV = genDefaultStringValue("", &fileLenV); } callArgs = list_put_last(callArgs, fileV); callArgs = list_put_last(callArgs, fileLenV); /* STATUS */ statusV = GetIoSpecifierValueAsString(oList, IO_SPEC_STATUS, NULL, &statusLenV); if (statusV == NULL) { statusV = genDefaultStringValue("UNKNOWN", &statusLenV); } callArgs = list_put_last(callArgs, statusV); callArgs = list_put_last(callArgs, statusLenV); /* ACCESS */ accessV = GetIoSpecifierValueAsString(oList, IO_SPEC_ACCESS, NULL, &accessLenV); if (accessV == NULL) { accessV = genDefaultStringValue("SEQUENTIAL", &accessLenV); } callArgs = list_put_last(callArgs, accessV); callArgs = list_put_last(callArgs, accessLenV); /* FORM */ formV = GetIoSpecifierValueAsString(oList, IO_SPEC_FORM, NULL, &formLenV); if (formV == NULL) { formV = genDefaultStringValue("", &formLenV); } callArgs = list_put_last(callArgs, formV); callArgs = list_put_last(callArgs, formLenV); /* RECL */ reclV = GetIoSpecifierValueAsInteger(oList, IO_SPEC_RECL, TRUE, NULL); if (reclV == NULL) { reclV = genDefaultIntegerValue(0); } callArgs = list_put_last(callArgs, reclV); /* BLANK */ blankV = GetIoSpecifierValueAsString(oList, IO_SPEC_BLANK, NULL, &blankLenV); if (blankV == NULL) { blankV = genDefaultStringValue("NULL", &blankLenV); } callArgs = list_put_last(callArgs, blankV); callArgs = list_put_last(callArgs, blankLenV); /* IOSTAT */ ioStatVar = Get_IOSTAT_Variable(oList, &vId); /* ERR */ errLabel = Get_ERRorEND_Label(oList, IO_SPEC_ERR); if (errLabel != NULL) { if (ioStatVar == NULL) { ioStatVar = allocate_temp2(type_INT, &vId); } errV = genCondBranch(COND_ERR, vId, errLabel); } if (errV == NULL && ioStatVar == NULL) { errFlagV = expv_int_term(INT_CONSTANT, type_INT, 0); } else { errFlagV = expv_int_term(INT_CONSTANT, type_INT, 1); } callArgs = list_put_last(callArgs, errFlagV); if (ioStatVar != NULL) { v = expv_assignment(ioStatVar, expv_call_runtime("_IO_Open", type_INT, callArgs)); } else { v = expv_call_runtime("_IO_Open", type_INT, callArgs); } output_expr_statement(v); if (errV != NULL) { output_expr_statement(errV); } } void compile_CLOSE_statement(x) expr x; { expv callArgs = list0(LIST); expv cList = NULL; expv v; ID vId = NULL; expv unitV = NULL; expv ioStatVar = NULL; expv errV = NULL; ID errLabel = NULL; expv statusV = NULL; expv statusLenV = NULL; expv errFlagV = NULL; int hasUNITSpec = FALSE; int allowSpecs[] = { IO_SPEC_UNIT, IO_SPEC_IOSTAT, IO_SPEC_ERR, IO_SPEC_STATUS }; if (EXPR_CODE(EXPR_ARG1(x)) != LIST) { return; } cList = NormalizeIoSpecifier(x); if (cList == NULL) { return; } if (CheckIoSpecifierSanity(cList, allowSpecs, 4) != TRUE) { return; } /* UNIT */ unitV = GetIoSpecifierValueAsInteger(cList, IO_SPEC_UNIT, TRUE, &hasUNITSpec); if (hasUNITSpec == FALSE) { error("no unit number is specified."); return; } callArgs = list_put_last(callArgs, unitV); /* STATUS */ statusV = GetIoSpecifierValueAsString(cList, IO_SPEC_STATUS, NULL, &statusLenV); if (statusV == NULL) { statusV = genDefaultStringValue("KEEP", &statusLenV); } callArgs = list_put_last(callArgs, statusV); callArgs = list_put_last(callArgs, statusLenV); /* IOSTAT */ ioStatVar = Get_IOSTAT_Variable(cList, &vId); /* ERR */ errLabel = Get_ERRorEND_Label(cList, IO_SPEC_ERR); if (errLabel != NULL) { if (ioStatVar == NULL) { ioStatVar = allocate_temp2(type_INT, &vId); } errV = genCondBranch(COND_ERR, vId, errLabel); } if (errV == NULL && ioStatVar == NULL) { errFlagV = expv_int_term(INT_CONSTANT, type_INT, 0); } else { errFlagV = expv_int_term(INT_CONSTANT, type_INT, 1); } callArgs = list_put_last(callArgs, errFlagV); if (ioStatVar != NULL) { v = expv_assignment(ioStatVar, expv_call_runtime("_IO_Close", type_INT, callArgs)); } else { v = expv_call_runtime("_IO_Close", type_INT, callArgs); } output_expr_statement(v); if (errV != NULL) { output_expr_statement(errV); } } /* * BACKSPACE * ENDFILE * REWIND */ void compile_FPOS_statement(x) expr x; { char *func = NULL; expv callArgs = list0(LIST); expv v; expv unitV = NULL; expv ioStatVar = NULL; expv errV = NULL; ID errLabel = NULL; expv errFlagV = NULL; int hasUNITSpec = FALSE; switch (EXPR_CODE(x)) { case F_BACKSPACE_STATEMENT: { func = "_IO_Backspace"; break; } case F_REWIND_STATEMENT: { func = "_IO_Rewind"; break; } case F_ENDFILE_STATEMENT: { func = "_IO_Endfile"; break; } default: { fatal("unknown file positioning statement."); } } if (EXPR_ARG1(x) == NULL) { unitV = expv_get_address(expv_int_term(INT_CONSTANT, type_INT, 6)); } else if (EXPR_CODE(EXPR_ARG1(x)) == LIST) { ID vId = NULL; int allowSpecs[] = { IO_SPEC_UNIT, IO_SPEC_IOSTAT, IO_SPEC_ERR }; expv aList = NormalizeIoSpecifier(x); if (aList == NULL) { return; } if (CheckIoSpecifierSanity(aList, allowSpecs, 4) != TRUE) { return; } /* UNIT */ unitV = GetIoSpecifierValueAsInteger(aList, IO_SPEC_UNIT, TRUE, &hasUNITSpec); if (hasUNITSpec == FALSE) { error("no unit number is specified."); return; } if (unitV == NULL) { unitV = expv_get_address(expv_int_term(INT_CONSTANT, type_INT, 6)); } callArgs = list_put_last(callArgs, unitV); /* IOSTAT */ ioStatVar = Get_IOSTAT_Variable(aList, &vId); /* ERR */ errLabel = Get_ERRorEND_Label(aList, IO_SPEC_ERR); if (errLabel != NULL) { if (ioStatVar == NULL) { ioStatVar = allocate_temp2(type_INT, &vId); } errV = genCondBranch(COND_ERR, vId, errLabel); } if (errV == NULL && ioStatVar == NULL) { errFlagV = expv_int_term(INT_CONSTANT, type_INT, 0); } else { errFlagV = expv_int_term(INT_CONSTANT, type_INT, 1); } callArgs = list_put_last(callArgs, errFlagV); } else { BASIC_DATA_TYPE typ; expv vTmp = compile_args(list1(LIST, EXPR_ARG1(x)), TRUE); if (vTmp == NULL || EXPR_ARG1(vTmp) == NULL) { fatal("internal compiler error."); } vTmp = EXPR_ARG1(vTmp); if (EXPV_TYPE(vTmp) == NULL) { fatal("can't determine type of format specifier."); } typ = getBasicType(EXPV_TYPE(vTmp)); if (typ == TYPE_UNKNOWN) { fatal("can't determine type of format specifier."); } if (!BASIC_IS_INT(typ)) { error("unit must be specified as interger."); return; } unitV = vTmp; callArgs = list_put_last(callArgs, unitV); errFlagV = expv_int_term(INT_CONSTANT, type_INT, 0); callArgs = list_put_last(callArgs, errFlagV); } if (ioStatVar != NULL) { v = expv_assignment(ioStatVar, expv_call_runtime(func, type_INT, callArgs)); } else { v = expv_call_runtime(func, type_INT, callArgs); } output_expr_statement(v); if (errV != NULL) { output_expr_statement(errV); } } void compile_INQUIRE_statement(x) expr x; { expv callArgs = list0(LIST); expv iList = NULL; expv v; int hasUNITSpec = FALSE; int hasFILESpec = FALSE; expv errFlagV = NULL; expv unitV = NULL; expv fileV = NULL; expv fileLenV = NULL; expv ioStatVar = NULL; expv errV = NULL; ID errLabel = NULL; expv nullV = expv_int_term(INT_CONSTANT, type_INT, 0); expv curV; expv curLenV; ID vId; if (EXPV_CODE(EXPR_ARG1(x)) != LIST) { fatal("syntax error in INQUIRE ???"); } iList = NormalizeIoSpecifier(x); if (iList == NULL) { return; } unitV = GetIoSpecifierValueAsInteger(iList, IO_SPEC_UNIT, TRUE, &hasUNITSpec); fileV = GetIoSpecifierValueAsString(iList, IO_SPEC_FILE, &hasFILESpec, &fileLenV); if (hasUNITSpec == TRUE && hasFILESpec == TRUE) { error("inquire by unit or by file, not both."); return; } else if (hasUNITSpec == TRUE) { if (unitV == NULL) { unitV = expv_get_address(expv_int_term(INT_CONSTANT, type_INT, 6)); } fileV = nullV; fileLenV = nullV; } else if (hasFILESpec == TRUE) { unitV = nullV; } else { error("must inquire by unit or by file."); return; } callArgs = list_put_last(callArgs, unitV); callArgs = list_put_last(callArgs, fileV); callArgs = list_put_last(callArgs, fileLenV); /* IOSTAT */ ioStatVar = Get_IOSTAT_Variable(iList, &vId); /* ERR */ errLabel = Get_ERRorEND_Label(iList, IO_SPEC_ERR); if (errLabel != NULL) { if (ioStatVar == NULL) { ioStatVar = allocate_temp2(type_INT, &vId); } errV = genCondBranch(COND_ERR, vId, errLabel); } if (errV == NULL && ioStatVar == NULL) { errFlagV = expv_int_term(INT_CONSTANT, type_INT, 0); } else { errFlagV = expv_int_term(INT_CONSTANT, type_INT, 1); } /* EXIST */ curV = GetIoSpecifierValueAsLogicalVariable(iList, IO_SPEC_EXIST, TRUE, NULL, NULL); if (curV != NULL) { callArgs = list_put_last(callArgs, curV); } else { callArgs = list_put_last(callArgs, nullV); } /* OPENED */ curV = GetIoSpecifierValueAsLogicalVariable(iList, IO_SPEC_OPENED, TRUE, NULL, NULL); if (curV != NULL) { callArgs = list_put_last(callArgs, curV); } else { callArgs = list_put_last(callArgs, nullV); } /* NUMBER */ curV = GetIoSpecifierValueAsIntegerVariable(iList, IO_SPEC_NUMBER, TRUE, NULL, NULL); if (curV != NULL) { callArgs = list_put_last(callArgs, curV); } else { callArgs = list_put_last(callArgs, nullV); } /* NAMED */ curV = GetIoSpecifierValueAsLogicalVariable(iList, IO_SPEC_NAMED, TRUE, NULL, NULL); if (curV != NULL) { callArgs = list_put_last(callArgs, curV); } else { callArgs = list_put_last(callArgs, nullV); } /* NAME */ curV = GetIoSpecifierValueAsStringVariable(iList, IO_SPEC_NAME, NULL, &curLenV, NULL); if (curV != NULL) { callArgs = list_put_last(callArgs, curV); callArgs = list_put_last(callArgs, curLenV); } else { callArgs = list_put_last(callArgs, nullV); callArgs = list_put_last(callArgs, nullV); } /* ACCESS */ curV = GetIoSpecifierValueAsStringVariable(iList, IO_SPEC_ACCESS, NULL, &curLenV, NULL); if (curV != NULL) { callArgs = list_put_last(callArgs, curV); callArgs = list_put_last(callArgs, curLenV); } else { callArgs = list_put_last(callArgs, nullV); callArgs = list_put_last(callArgs, nullV); } /* SEQUENTAIL */ curV = GetIoSpecifierValueAsStringVariable(iList, IO_SPEC_SEQUENTIAL, NULL, &curLenV, NULL); if (curV != NULL) { callArgs = list_put_last(callArgs, curV); callArgs = list_put_last(callArgs, curLenV); } else { callArgs = list_put_last(callArgs, nullV); callArgs = list_put_last(callArgs, nullV); } /* DIRECT */ curV = GetIoSpecifierValueAsStringVariable(iList, IO_SPEC_DIRECT, NULL, &curLenV, NULL); if (curV != NULL) { callArgs = list_put_last(callArgs, curV); callArgs = list_put_last(callArgs, curLenV); } else { callArgs = list_put_last(callArgs, nullV); callArgs = list_put_last(callArgs, nullV); } /* FORM */ curV = GetIoSpecifierValueAsStringVariable(iList, IO_SPEC_FORM, NULL, &curLenV, NULL); if (curV != NULL) { callArgs = list_put_last(callArgs, curV); callArgs = list_put_last(callArgs, curLenV); } else { callArgs = list_put_last(callArgs, nullV); callArgs = list_put_last(callArgs, nullV); } /* FORMATTED */ curV = GetIoSpecifierValueAsStringVariable(iList, IO_SPEC_FORMATTED, NULL, &curLenV, NULL); if (curV != NULL) { callArgs = list_put_last(callArgs, curV); callArgs = list_put_last(callArgs, curLenV); } else { callArgs = list_put_last(callArgs, nullV); callArgs = list_put_last(callArgs, nullV); } /* UNFORMATTED */ curV = GetIoSpecifierValueAsStringVariable(iList, IO_SPEC_UNFORMATTED, NULL, &curLenV, NULL); if (curV != NULL) { callArgs = list_put_last(callArgs, curV); callArgs = list_put_last(callArgs, curLenV); } else { callArgs = list_put_last(callArgs, nullV); callArgs = list_put_last(callArgs, nullV); } /* RECL */ curV = GetIoSpecifierValueAsIntegerVariable(iList, IO_SPEC_RECL, TRUE, NULL, NULL); if (curV != NULL) { callArgs = list_put_last(callArgs, curV); } else { callArgs = list_put_last(callArgs, nullV); } /* NEXTREC */ curV = GetIoSpecifierValueAsIntegerVariable(iList, IO_SPEC_NEXTREC, TRUE, NULL, NULL); if (curV != NULL) { callArgs = list_put_last(callArgs, curV); } else { callArgs = list_put_last(callArgs, nullV); } /* BLANK */ curV = GetIoSpecifierValueAsStringVariable(iList, IO_SPEC_BLANK, NULL, &curLenV, NULL); if (curV != NULL) { callArgs = list_put_last(callArgs, curV); callArgs = list_put_last(callArgs, curLenV); } else { callArgs = list_put_last(callArgs, nullV); callArgs = list_put_last(callArgs, nullV); } callArgs = list_put_last(callArgs, errFlagV); if (ioStatVar != NULL) { v = expv_assignment(ioStatVar, expv_call_runtime("_IO_Inquire", type_INT, callArgs)); } else { v = expv_call_runtime("_IO_Inquire", type_INT, callArgs); } output_expr_statement(v); if (errV != NULL) { output_expr_statement(errV); } } void compile_NAMELIST_decl(x) expr x; { ID nlId; list lp, lq; expr nlName; expr idList; expr nlVX; FOR_ITEMS_IN_LIST(lp, x) { nlName = EXPR_ARG1(LIST_ITEM(lp)); idList = EXPR_ARG2(LIST_ITEM(lp)); nlId = declare_ident(EXPR_SYM(nlName), CL_UNKNOWN); if (ID_CLASS(nlId) == CL_UNKNOWN) { /* * First. */ if (NL_LIST(nlId) == NULL) { NL_LIST(nlId) = list0(LIST); } declare_ident(EXPR_SYM(nlName), CL_NAMELIST); } else { if (ID_CLASS(nlId) != CL_NAMELIST) { error("'%s' is not a namelist.", SYM_NAME(ID_SYM(nlId))); continue; } } FOR_ITEMS_IN_LIST(lq, idList) { nlVX = LIST_ITEM(lq); if (EXPR_CODE(nlVX) != IDENT) { error("invalid type in namelist."); continue; } NL_LIST(nlId) = list_put_last(NL_LIST(nlId), LIST_ITEM(lq)); } } }