static char rcsid[] = "$Id: F-compile-decl.c,v 1.90 2003/07/01 15:34:53 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" #define ROUND(a,b) (b * ( (a+b-1)/b)) /* implicit type information */ TYPE_DESC implicit_types[26]; enum storage_class implicit_stg[26]; /* local symbols */ ID local_symbols; ID local_labels; /* externl symbol */ EXT_ID external_symbols; EXT_ID blank_common = NULL; expr crayPointerList = NULL; static void declare_dummy_args _ANSI_ARGS_((expr l)); static int markAsSave _ANSI_ARGS_((ID id)); /* * define main program or block data, subroutine, functions */ void declare_procedure(enum name_class class,expr name,TYPE_DESC type,expr args) { SYMBOL s = NULL; ID id; if(name) { if(EXPR_CODE(name) != IDENT) abort(); s = EXPR_SYM(name); } if(class != CL_ENTRY){ current_proc_class = class; if(name) current_proc_name = s; } switch(class){ case CL_MAIN: fprintf(diag_file," MAIN %s:\n",(name ? SYM_NAME(s): "")); current_ext_id = declare_external_id(c_find_symbol(OMNI_FORTRAN_ENTRY_POINT), STG_EXT,TRUE); if(name) declare_ident(s,CL_MAIN); break; case CL_BLOCK: fprintf(diag_file," BLOCK DATA %s:\n",name ? SYM_NAME(s): ""); if(name) declare_ident(s,CL_BLOCK); break; case CL_PROC: /* subroutine or functions */ fprintf(diag_file," %s:\n",SYM_NAME(s)); /* make local entry */ id = declare_ident(s,CL_PROC); declare_id_type(id,type); PROC_CLASS(id) = P_THISPROC; PROC_ARGS(id) = args; ID_STORAGE(id) = STG_EXT; declare_dummy_args(args); current_procedure = id; break; case CL_ENTRY: fprintf(diag_file," entry %s:\n",SYM_NAME(s)); id = declare_ident(s,CL_ENTRY); if(IS_SUBR(ID_TYPE(current_procedure))){ type = type_SUBR; declare_id_type(id,type); } PROC_CLASS(id) = P_THISPROC; PROC_ARGS(id) = args; declare_dummy_args(args); if(INDCL_OVER) define_entry(id); break; default: fatal("declare_procedure: unknown class"); } } static void declare_dummy_args(expr l) { list lp; expr x; SYMBOL s; ID id; FOR_ITEMS_IN_LIST(lp,l) { x = LIST_ITEM(lp); if (EXPR_CODE(x) != IDENT) { fatal("declare_dummy_args: not IDENT"); } s = EXPR_SYM(x); id = declare_ident(s,CL_UNKNOWN); if (ID_STORAGE(id) == STG_UNKNOWN) { ID_STORAGE(id) = STG_ARG; } else if (ID_STORAGE(id) != STG_ARG) { if (ID_STORAGE(id) == STG_AUTO && IS_ARRAY_TYPE(ID_TYPE(id)) && type_length(ID_TYPE(id)) < 0) { /* * Local adjustable array is about to be used as a * dummy arg for ENTRY statement. Currently unsupported. */ error("Local adjustable array '%s' is about to be used as a dummy argument for an ENTRY statement, not supported yet.", ID_NAME(id)); } else { error("illegal dummy argument '%s'",SYM_NAME(s)); } } } } /* * identifier management */ void implicit_declaration(ID id) { TYPE_DESC tp; char c; if (ID_CLASS(id) == CL_MAIN || (ID_CLASS(id) == CL_PROC && PROC_CLASS(id) == P_INTRINSIC)) { return; } if (ID_STORAGE(id) == STG_EQBLK) { return; } tp = ID_TYPE(id); if(tp == NULL || (IS_ARRAY_TYPE(tp) && array_element_type(tp) == NULL)){ c = ID_NAME(id)[0]; if(isupper((int)c)) c = tolower((int)c); tp = implicit_types[c-'a']; if(tp == NULL) { if(ID_CLASS(id) == CL_PROC) return; error("attempt to use undefined type variable, %s", ID_NAME(id)); return; } declare_id_type(id,tp); } } TYPE_DESC getBaseType(tp) TYPE_DESC tp; { if (TYPE_REF(tp) != NULL) { return getBaseType(TYPE_REF(tp)); } else { return tp; } } /* variable declaration */ ID declare_variable(ID id) { expv v; int tLen; if (ID_CLASS(id) == CL_MAIN) return id; /* don't care */ if(ID_CLASS(id) == CL_NAMELIST){ fatal("declare_variable: NAME_LIST, not implemented yet."); } if(ID_CLASS(id) == CL_UNKNOWN) ID_CLASS(id) = CL_VAR; else if(ID_CLASS(id) != CL_VAR){ error("used as variable, %s", ID_NAME(id)); return NULL; } if(ID_IS_DECLARED(id)){ if(ID_ADDR(id) == NULL) return NULL; /* error recovery */ return id; } else ID_IS_DECLARED(id) = TRUE; implicit_declaration(id); if(ID_TYPE(id) == NULL) return NULL; /* error */ if (ID_STORAGE(id) == STG_UNKNOWN) { if (VAR_IS_SAVE(id) || VAR_INIT_LIST(id)|| current_proc_class == CL_MAIN) { ID_STORAGE(id) = STG_BSS; } else if(saveArray){ if (IS_ARRAY_TYPE(ID_TYPE(id))) { ID_STORAGE(id) = STG_BSS; } else { ID_STORAGE(id) = STG_AUTO; } } else { tLen = type_length(ID_TYPE(id)); if (tLen < 0) { fatal("Local adjustable array case must be treated in end_declaration()."); } if (tLen >= (maxStackSize / 4)) { if (OMP_flag == FALSE) { warning("about to allocate large stack variable '%s'(%d bytes), allocated in static area instead.", SYM_NAME(ID_SYM(id)), tLen); ID_STORAGE(id) = STG_BSS; } else { warning("about to allocate large stack variable '%s'(%d bytes), better unlimit stack size of your process environment before running this object, otherwise will get SIGSEGV.", SYM_NAME(ID_SYM(id)), tLen); ID_STORAGE(id) = STG_AUTO; } } else { ID_STORAGE(id) = STG_AUTO; } } } switch(ID_STORAGE(id)){ case STG_BSS: /* allocate in uninitialized data */ if(IS_ARRAY_TYPE(ID_TYPE(id)) || IS_CHAR(ID_TYPE(id))) ID_ADDR(id) = expv_sym_term(ARRAY_ADDR,ID_TYPE(id),ID_SYM(id)); else ID_ADDR(id) = expv_sym_term(VAR_ADDR,pointer_type(ID_TYPE(id)), ID_SYM(id)); break; case STG_ARG: /* dummy argument */ if (IS_ARRAY_TYPE(ID_TYPE(id)) || IS_CHAR(ID_TYPE(id))) { ID_ADDR(id) = expv_sym_term(FPARAM_ARRAY_ADDR, ID_TYPE(id), ID_SYM(id)); } else { ID_ADDR(id) = expv_sym_term(FPARAM_VAR_ADDR, pointer_type(ID_TYPE(id)), ID_SYM(id)); } break; case STG_AUTO: case STG_TEMP: case STG_CTEMP: case STG_EQBLK: if(IS_ARRAY_TYPE(ID_TYPE(id)) || IS_CHAR(ID_TYPE(id))) ID_ADDR(id) = expv_sym_term(LARRAY_ADDR,ID_TYPE(id),ID_SYM(id)); else ID_ADDR(id) = expv_sym_term(LVAR_ADDR,pointer_type(ID_TYPE(id)), ID_SYM(id)); break; case STG_COMEQ: case STG_COMMON: v = expv_cons(LIST, NULL, expv_sym_term(IDENT, NULL, EXT_SYM(VAR_COM_NAME(id))), expv_int_term(INT_CONSTANT, NULL, VAR_EQUIV_STRUCT_NO(id))); if(IS_ARRAY_TYPE(ID_TYPE(id)) || IS_CHAR(ID_TYPE(id))) ID_ADDR(id) = expv_cons(FCOMM_ARRAY_ADDR,ID_TYPE(id), expv_sym_term(IDENT,NULL,ID_SYM(id)),v); else ID_ADDR(id) = expv_cons(FCOMM_VAR_ADDR,pointer_type(ID_TYPE(id)), expv_sym_term(IDENT,NULL,ID_SYM(id)),v); break; case STG_EQUIV: v = expv_cons(LIST, NULL, expv_sym_term(IDENT, NULL, VAR_EQUIV_NAME(id)), expv_int_term(INT_CONSTANT, NULL, VAR_EQUIV_STRUCT_NO(id))); if(IS_ARRAY_TYPE(ID_TYPE(id)) || IS_CHAR(ID_TYPE(id))) ID_ADDR(id) = expv_cons(FCOMM_ARRAY_ADDR,ID_TYPE(id), expv_sym_term(IDENT,NULL,ID_SYM(id)),v); else ID_ADDR(id) = expv_cons(FCOMM_VAR_ADDR,pointer_type(ID_TYPE(id)), expv_sym_term(IDENT,NULL,ID_SYM(id)),v); break; case STG_PTRBASE: { TYPE_DESC pTyp, tp; expv pV; if (IS_ARRAY_TYPE(ID_TYPE(id)) == TRUE && TYPE_ARRAY_SIZE(ID_TYPE(id)) < 0) { /* * Adjustable array. One dimension array accsess. */ tp = pointer_type(getBaseType(ID_TYPE(id))); } else { if (TYPE_REF(ID_TYPE(id)) == NULL) { tp = pointer_type(ID_TYPE(id)); } else { tp = pointer_type(TYPE_REF(ID_TYPE(id))); } } pTyp = pointer_type(ID_TYPE(VAR_POINTER_ID(id))); if (ID_STORAGE(VAR_POINTER_ID(id)) == STG_ARG) { pV = expv_cons(POINTER_REF, pTyp, expv_sym_term(FPARAM_VAR_ADDR, ID_TYPE(VAR_POINTER_ID(id)), ID_SYM(VAR_POINTER_ID(id))), NULL); } else if (ID_STORAGE(VAR_POINTER_ID(id)) == STG_COMMON || ID_STORAGE(VAR_POINTER_ID(id)) == STG_COMEQ || ID_STORAGE(VAR_POINTER_ID(id)) == STG_EQUIV) { declare_variable(VAR_POINTER_ID(id)); pV = expv_cons(POINTER_REF, pTyp, ID_ADDR(VAR_POINTER_ID(id)), NULL); } else { pV = expv_cons(POINTER_REF, pTyp, expv_sym_term(LVAR_ADDR, ID_TYPE(VAR_POINTER_ID(id)), ID_SYM(VAR_POINTER_ID(id))), NULL); } if (IS_ARRAY_TYPE(ID_TYPE(id)) || IS_CHAR(ID_TYPE(id))) { v = expv_cons(CRAY_POINTER_REF, tp, pV, NULL); } else { v = expv_cons(CRAY_POINTER_REF, tp, pV, NULL); } ID_ADDR(id) = v; break; } default: fatal("declare_variable: unknown class"); } return id; } ID declare_function(ID id, int is_arg) { if(ID_CLASS(id) == CL_UNKNOWN){ /* if name class is unknown, define it as CL_PROC */ ID_CLASS(id) = CL_PROC; if(ID_STORAGE(id) == STG_UNKNOWN){ if(is_intrinsic_function(id)){ PROC_CLASS(id) = P_INTRINSIC; ID_STORAGE(id) = STG_NONE; ID_IS_DECLARED(id) = TRUE; return id; } else { /* it must be extenal function call */ PROC_CLASS(id) = P_EXTERNAL; } } else if(ID_STORAGE(id) == STG_ARG){ warning("Dummy procedure not declared EXTERNAL. Code may be wrong."); PROC_CLASS(id) = P_EXTERNAL; } else fatal("compile_function_call: bad storage"); } else if(ID_CLASS(id) != CL_PROC){ error("identifier '%s' is used as a function", ID_NAME(id)); return NULL; } if(ID_IS_DECLARED(id)) return id; else ID_IS_DECLARED(id) = TRUE; /* check omp_* function */ check_OMP_runtime_function(id); if(!is_arg) implicit_declaration(id); if(ID_STORAGE(id) == STG_UNKNOWN) ID_STORAGE(id) = STG_EXT; if(ID_ADDR(id) == NULL){ /* fix stoarge */ /* NOTE that function address's type is ignored. * don't need keep track of function type in Fortran. */ switch(ID_STORAGE(id)){ case STG_EXT: declare_external_proc_id(ID_SYM(id),ID_TYPE(id),FALSE); ID_ADDR(id) = expv_sym_term(FUNC_ADDR,NULL,ID_SYM(id)); break; default: fatal("declare_function: unknown storage"); } } return id; } void declare_statement_function(id,args,body) ID id; expr args,body; { ID ip; list lp; expr x; if(ID_CLASS(id) != CL_UNKNOWN) fatal("declare_statement_function: not CL_UNKNOWN"); ID_CLASS(id) = CL_PROC; PROC_CLASS(id) = P_STFUNCT; ID_STORAGE(id) = STG_NONE; implicit_declaration(id); /* check argument */ FOR_ITEMS_IN_LIST(lp,args){ x = LIST_ITEM(lp); if(EXPR_CODE(x) != IDENT){ error("non-variable argument in statement function definition"); return; } ip = declare_ident(EXPR_SYM(x),CL_UNKNOWN); /* fix type of paramter */ implicit_declaration(ip); if(ID_TYPE(ip) == NULL) fatal("statement function call: unknown type parameter"); if(!IS_ELEMENT_TYPE(ID_TYPE(ip))){ error("function statement parameter is not variable,'%s'", ID_NAME(ip)); return; } } PROC_STBODY(id) = body; PROC_ARGS(id) = args; } ID declare_label(int st_no,LABEL_TYPE type,int def_flag) { ID ip,last_ip; char name[10]; if(st_no <= 0){ error("illegal label %d", st_no); return NULL; } last_ip = NULL; for(ip = local_labels; ip != NULL; ip = ID_NEXT(ip)){ if(LAB_ST_NO(ip) == st_no) goto found; last_ip = ip; } /* if not found, make label entry */ sprintf(name,"L%05d",st_no); ip = new_ident_desc(c_find_symbol(name)); if(last_ip == NULL) local_labels = ip; else ID_NEXT(last_ip) = ip; ID_ADDR(ip) = expv_sym_term(IDENT,NULL,ID_SYM(ip)); ID_CLASS(ip) = CL_LABEL; LAB_ST_NO(ip) = st_no; found: if(def_flag){ if(LAB_IS_DEFINED(ip)){ error("label %d already defined", st_no); return ip; } if(type == LAB_EXEC){ if(LAB_IS_USED(ip) && LAB_TYPE(ip) != LAB_FORMAT && LAB_BLK_LEVEL(ip) < current_blk_level) warning("there is a branch to label %d from outside block", st_no); LAB_BLK_LEVEL(ip) = current_blk_level; if(LAB_TYPE(ip) == LAB_FORMAT) error("label %d is referenced as format number",st_no); } else if(type == LAB_FORMAT){ if(LAB_TYPE(ip) == LAB_EXEC) error("format number %d is referenced as label",st_no); } /* define label */ LAB_TYPE(ip) = type; LAB_IS_DEFINED(ip) = TRUE; } else { LAB_IS_USED(ip) = TRUE; /* referenced */ if(LAB_TYPE(ip) == LAB_UNKNOWN) LAB_TYPE(ip) = type; if(type == LAB_EXEC){ if(LAB_CANNOT_JUMP(ip)) warning("illegal branch to inner block, statement %d",st_no); if(!LAB_IS_DEFINED(ip)) LAB_BLK_LEVEL(ip) = current_blk_level; if(LAB_TYPE(ip) == LAB_FORMAT) error("may not branch to a format"); } else if(type == LAB_FORMAT){ if(LAB_TYPE(ip) == LAB_EXEC) error("bad format number"); } } return ip; } EXT_ID declare_external_proc_id(SYMBOL s,TYPE_DESC tp,int def_flag) { EXT_ID ep; /* allocate external symbol */ ep = declare_external_id(s,STG_EXT,def_flag); if (ep != NULL) { if (EXT_PROC_TYPE(ep) != NULL){ if(!type_is_compatible(EXT_PROC_TYPE(ep), tp)) error("inconsistent external type"); } else { EXT_PROC_TYPE(ep) = tp; EXT_PROC_C_TYPE(ep) = tp; /* set C type */ } } return ep; } /* 'intern' external symbol with tag. * if def_flag, mark it as defined */ EXT_ID declare_external_id(SYMBOL s,enum storage_class tag,int def_flag) { EXT_ID ep,last_ep; if (tag == STG_COMEQ) { fatal("creating named common as equivalance??"); } last_ep = NULL; for(ep = external_symbols; ep != NULL; ep = EXT_NEXT(ep)){ if(EXT_SYM(ep) == s) break; /* found */ last_ep = ep; } if(ep == NULL){ /* not found */ ep = new_external_id(s); if(last_ep == NULL) external_symbols = ep; else EXT_NEXT(last_ep) = ep; EXT_SYM(ep) = s; } if(EXT_TAG(ep) != STG_UNKNOWN){ /* not referenced yet */ #ifdef BUGFIX if (EXT_IS_DEFINED(ep) && EXT_TAG(ep) != tag) { /* defined, but not desired tag */ error("external name is already used, '%s'",SYM_NAME(s)); return NULL; } #else if(tag == STG_EXT && (EXT_IS_DEFINED(ep) || EXT_TAG(ep) != tag)){ error("external name is already used, '%s'",SYM_NAME(s)); return NULL; } #endif if (tag == STG_COMMON && EXT_TAG(ep) != tag){ error("%s cannot be a common block name", SYM_NAME(s)); return NULL; } } EXT_TAG(ep) = tag; if(!EXT_IS_DEFINED(ep)) EXT_IS_DEFINED(ep) = def_flag; return ep; } ID declare_ident(SYMBOL s,enum name_class class) { ID ip,last_ip; last_ip = NULL; for(ip = local_symbols; ip != NULL; ip = ID_NEXT(ip)){ if(ID_SYM(ip) == s){ /* if argument 'class' is CL_UNKNOWN, find id */ if(class == CL_UNKNOWN || ID_CLASS(ip) == class) return ip; /* define name class */ if(ID_CLASS(ip) == CL_UNKNOWN) ID_CLASS(ip) = class; else error("name is already declared, '%s'",SYM_NAME(s)); return ip; } last_ip = ip; } ip = new_ident_desc(s); if(last_ip == NULL) local_symbols = ip; else ID_NEXT(last_ip) = ip; ID_SYM(ip) = s; ID_CLASS(ip) = class; ID_STORAGE(ip) = STG_UNKNOWN; return ip; } ID find_ident(SYMBOL s) { ID ip; for(ip = local_symbols; ip != NULL; ip = ID_NEXT(ip)){ if(ID_SYM(ip) == s) return ip; } return NULL; } SYMBOL char_len_param_name(SYMBOL sp) { char name[MAX_NAME_LEN+5]; strcpy(name,SYM_NAME(sp)); strcat(name,"_len"); return c_find_symbol(name); } int is_char_type(TYPE_DESC tp) { while(IS_ARRAY_TYPE(tp)) tp = TYPE_REF(tp); return IS_CHAR(tp); } int temp_gen = 0; SYMBOL gen_symbol(char leader) { char name[10]; sprintf(name,"%c%03d",leader,temp_gen++); return c_find_symbol(name); } expv allocate_temp(TYPE_DESC tp) { return allocate_temporary_variable(tp,NULL,STG_TEMP); } expv allocate_ctemp(TYPE_DESC tp) { return allocate_temporary_variable(tp,NULL,STG_CTEMP); } expv allocate_temp2(TYPE_DESC tp, ID *idPtr) { return allocate_temporary_variable(tp,idPtr,STG_TEMP); } expv allocate_auto(TYPE_DESC tp) { return allocate_temporary_variable(tp,NULL,STG_AUTO); } expv allocate_temporary_variable(TYPE_DESC tp, ID *idPtr,enum storage_class c) { ID id; SYMBOL sym; sym = gen_symbol('T'); id = declare_ident(sym,CL_VAR); if (idPtr != NULL) { *idPtr = id; } ID_TYPE(id) = tp; ID_STORAGE(id) = c; declare_variable(id); if(IS_CHAR(ID_TYPE(id))) return ID_ADDR(id); else return expv_cons(POINTER_REF,tp,ID_ADDR(id),NULL); } /* * type handling */ /* declare type for id */ /* check compatibility if id's type is already declared. */ void declare_id_type(ID id, TYPE_DESC tp) { TYPE_DESC tq,tpp; if(tp == NULL || ID_TYPE(id) == tp) return; /* nothing for TYPE_UNKNOWN */ if(!IS_ARRAY_TYPE(tp) && !IS_ELEMENT_TYPE(tp)) fatal("declare_id_type: may be poiner?"); if(IS_ARRAY_TYPE(tp)){ /* tp is array */ if(ID_CLASS(id) == CL_UNKNOWN) ID_CLASS(id) = CL_VAR; else if(ID_CLASS(id) != CL_VAR){ error("array must be a variable, %s", ID_NAME(id)); return; } if((tq = ID_TYPE(id)) != NULL){ if(IS_ARRAY_TYPE(tq)){ error("already declared as array, '%s'",ID_NAME(id)); return; } /* declared as scalar type, then array declaration come later. */ tpp = tp; while(TYPE_REF(tpp) != NULL && IS_ARRAY_TYPE(TYPE_REF(tpp))) tpp = TYPE_REF(tpp); if(TYPE_REF(tpp) == NULL || type_is_compatible(tq,TYPE_REF(tpp))) TYPE_REF(tpp) = tq; else goto no_compatible; } ID_TYPE(id) = tp; return; } /* tp is not ARRAY_TYPE */ if((tq = ID_TYPE(id)) != NULL && IS_ARRAY_TYPE(tq)){ /* already defined as array */ while(TYPE_REF(tq) != NULL && IS_ARRAY_TYPE(TYPE_REF(tq))) tq = TYPE_REF(tq); if(TYPE_REF(tq) == NULL || type_is_compatible(TYPE_REF(tq),tp)){ TYPE_REF(tq) = tp; return; } else goto no_compatible; } /* both are not ARRAY_TYPE */ if(IS_SUBR(tp) && ID_TYPE(id)!= NULL && ID_STORAGE(id) == STG_ARG){ /* if argument, may override with TYPE_SUBR ??? */ ID_TYPE(id) = tp; return; } else if((tq = ID_TYPE(id)) == NULL || type_is_compatible(tq,tp)){ ID_TYPE(id) = tp; return; } no_compatible: error("incompatible type declarations, %s", ID_NAME(id)); } /* check type compatiblity of element types */ int type_is_compatible(TYPE_DESC tp,TYPE_DESC tq) { if(tp == NULL || tq == NULL || IS_ARRAY_TYPE(tp) || IS_ARRAY_TYPE(tq)) return FALSE; if(TYPE_BASIC_TYPE(tp) != TYPE_BASIC_TYPE(tq)) return FALSE; if(TYPE_BASIC_TYPE(tp) == TYPE_CHAR){ if(TYPE_CHAR_LEN(tp) != TYPE_CHAR_LEN(tq)) return FALSE; } return TRUE; } int type_align(TYPE_DESC tp) { while(TYPE_REF(tp)) tp=TYPE_REF(tp); return basic_type_align(TYPE_BASIC_TYPE(tp)); } int type_length(TYPE_DESC tp) { int len; len = 1; while(TYPE_REF(tp)) { /* it must be array */ len *= TYPE_ARRAY_SIZE(tp); if(len < 0) return -1; tp=TYPE_REF(tp); } if(TYPE_BASIC_TYPE(tp) == TYPE_CHAR) return len*TYPE_CHAR_LEN(tp); else return len * basic_type_size(TYPE_BASIC_TYPE(tp)); } void declare_storage(ID id, enum storage_class stg) { if(ID_STORAGE(id) == STG_UNKNOWN) ID_STORAGE(id) = stg; else if(ID_STORAGE(id) != stg) error("incompatible storage declarations, %s", ID_NAME(id)); } /* create TYPE_DESC from type expression x. */ /* x := (LIST basic_type leng_spec) * leng_spec = NULL | expr | (LIST) */ TYPE_DESC compile_type(expr x) { expr ty,leng; int len; BASIC_DATA_TYPE t; expv v; if(x == NULL) return NULL; ty = EXPR_ARG1(x); leng = EXPR_ARG2(x); if (ty == NULL) { if (leng != NULL) { error("invalid type-length"); } return NULL; } if (EXPR_CODE(ty) != F_TYPE_NODE) { fatal("compile_type: not F_TYPE_NODE"); } if (leng == NULL) { /* default */ len = 1; } else if (EXPR_CODE(leng) == LIST) { len = CHAR_UNKNOWN_LEN; } else { if ((v = compile_int_constant(leng)) == NULL) { return NULL; } len = EXPV_INT_VALUE(v); if (len <= 0) { error("length specification must be positive"); return NULL; } } switch (t = (BASIC_DATA_TYPE)EXPR_INT(ty)) { case TYPE_DREAL: { if (leng != NULL) { error("invalid length specification"); return NULL; } } /* through */ case TYPE_REAL: { switch (len) { case 1: { if (t == TYPE_REAL) { return BASIC_TYPE_DESC(defaultSingleRealType); } else { return BASIC_TYPE_DESC(defaultDoubleRealType); } } case SIZEOF_FLOAT: { return BASIC_TYPE_DESC(TYPE_REAL); } case SIZEOF_DOUBLE: { return BASIC_TYPE_DESC(TYPE_DREAL); } #ifdef ENABLE_QREAL case 16: { return BASIC_TYPE_DESC(TYPE_QREAL); } #else case 16: { error("quad/multiple precision real is not supported."); } #endif /* ENABLE_QREAL */ } break; } case TYPE_DCOMPLEX: { if (leng != NULL) { error("invalid length specification"); return NULL; } } /* through */ case TYPE_COMPLEX: { switch (len) { case SIZEOF_FLOAT * 2: { return BASIC_TYPE_DESC(TYPE_COMPLEX); } case SIZEOF_DOUBLE * 2: { return BASIC_TYPE_DESC(TYPE_DCOMPLEX); } } break; } case TYPE_INT: { switch (len) { case 1: { return BASIC_TYPE_DESC(defaultIntType); } case SIZEOF_UNSIGNED_SHORT: { return BASIC_TYPE_DESC(TYPE_SHORT); } case SIZEOF_UNSIGNED_INT: { return BASIC_TYPE_DESC(TYPE_INT); } #ifdef HAS_INT64 case SIZEOF_UNSIGNED_LONG_LONG: { return BASIC_TYPE_DESC(TYPE_LONGLONG); } #else case SIZEOF_UNSIGNED_LONG_LONG: { error("integer*%d is not supported.", len); } #endif /* HAS_INT64 */ } break; } #ifdef ENABLE_QREAL case TYPE_QREAL: { if (leng != NULL) { error("invalid length specification"); return NULL; } return BASIC_TYPE_DESC(TYPE_QREAL); } #endif /* ENABLE_QREAL */ case TYPE_LOGICAL: { if (len == 1 || len == type_LOGICAL_SIZE) { return BASIC_TYPE_DESC(TYPE_LOGICAL); } break; } case TYPE_CHAR: { if (len == 1) { break; } return type_char(len); } case TYPE_UNKNOWN: { error("bad type name"); return NULL; } default: { fatal("compile_type: badtype"); return NULL; } } if (len != 1) { error("incompatible type-length combination"); return NULL; } return BASIC_TYPE_DESC(t); } TYPE_DESC pointer_type(TYPE_DESC tp) { TYPE_DESC tq; if(IS_CHAR(tp)) return tp; tq = new_type_desc(); TYPE_REF(tq) = tp; return tq; } TYPE_DESC function_type(TYPE_DESC tp) { TYPE_DESC tq; tq = new_type_desc(); TYPE_BASIC_TYPE(tq) = TYPE_FUNCTION; TYPE_REF(tq) = tp; return tq; } TYPE_DESC type_char(int len) { TYPE_DESC tp; /* if(len <= 0) fatal("type_char: len <= 0"); *//* character*(*) */ if(len == 1) return BASIC_TYPE_DESC(TYPE_CHAR); tp = new_type_desc(); TYPE_BASIC_TYPE(tp) = TYPE_CHAR; TYPE_CHAR_LEN(tp) = len; return tp; } TYPE_DESC type_equiv() { TYPE_DESC tp = new_type_desc(); TYPE_BASIC_TYPE(tp) = TYPE_EQBLK; return tp; } void compile_IMPLICIT_decl(expr type,expr l) { TYPE_DESC tp; list lp; expr v; if(type == NULL){ /* DIMENSION */ error("bad IMPLICIT declaration"); return; } if(EXPR_ARG1(type) != NULL && ((BASIC_DATA_TYPE) EXPR_INT(EXPR_ARG1(type))) == TYPE_UNKNOWN){ tp = NULL; if(l == NULL){ set_implicit_type(NULL,'a','z'); return; } } else { tp = compile_type(type); if(tp == NULL) return; /* error */ if(l == NULL) { error("no implicit set"); return; } } FOR_ITEMS_IN_LIST(lp,l){ v = LIST_ITEM(lp); if(EXPR_CODE(v) == IDENT) set_implicit_type(tp,*(SYM_NAME(EXPR_SYM(v))), * (SYM_NAME(EXPR_SYM(v)))); else set_implicit_type(tp,*SYM_NAME(EXPR_SYM(EXPR_ARG1(v))), *SYM_NAME(EXPR_SYM(EXPR_ARG2(v)))); } } void set_implicit_type(TYPE_DESC tp, int c1, int c2) { int i; if(c1==0 || c2==0) return; if(c1 > c2){ error("characters out of order in IMPLICIT:%c-%c", c1, c2); } else { for(i = c1 ; i<=c2 ; ++i) implicit_types[i-'a'] = tp; } } void set_implicit_storage(enum storage_class stg,int c1,int c2) { int i; if(c1==0 || c2==0) return; if(c1 > c2){ error("characters out of order in implicit:%c-%c", c1, c2); } else { for(i = c1 ; i<=c2 ; ++i) implicit_stg[i-'a'] = stg; } } TYPE_DESC max_type(TYPE_DESC tp1, TYPE_DESC tp2) { BASIC_DATA_TYPE t; t = TYPE_BASIC_TYPE(tp2); switch(TYPE_BASIC_TYPE(tp1)){ case TYPE_SHORT: return(tp2); case TYPE_INT: if(t == TYPE_SHORT) return(tp1); else return(tp2); #ifdef HAS_INT64 case TYPE_LONGLONG: if (t == TYPE_INT || t == TYPE_SHORT) return tp1; else return tp2; #endif /* HAS_INT64 */ case TYPE_REAL: #ifdef ENABLE_QREAL if (t == TYPE_DREAL|| t == TYPE_QREAL || t == TYPE_COMPLEX || t == TYPE_DCOMPLEX) #else if(t == TYPE_DREAL|| t == TYPE_COMPLEX || t == TYPE_DCOMPLEX) #endif /* ENABLE_QREAL */ return tp2; else return tp1; case TYPE_DREAL: #ifdef ENABLE_QREAL if (t == TYPE_QREAL) { return tp2; } else if (t == TYPE_COMPLEX || t == TYPE_DCOMPLEX) { return BASIC_TYPE_DESC(TYPE_DCOMPLEX); } else { return tp1; } #else if(t == TYPE_COMPLEX || t == TYPE_DCOMPLEX) return BASIC_TYPE_DESC(TYPE_DCOMPLEX); else return tp1; #endif /* ENABLE_QREAL */ #ifdef ENABLE_QREAL case TYPE_QREAL: if (t == TYPE_COMPLEX || t == TYPE_DCOMPLEX) { return BASIC_TYPE_DESC(TYPE_DCOMPLEX); } else { return tp1; } #endif /* ENABLE_QREAL */ case TYPE_COMPLEX: #ifdef ENABLE_QREAL if (t == TYPE_DREAL || t == TYPE_QREAL || t == TYPE_DCOMPLEX) #else if(t == TYPE_DREAL || t == TYPE_DCOMPLEX) #endif /* ENABLE_QREAL */ return BASIC_TYPE_DESC(TYPE_DCOMPLEX); else return tp1; case TYPE_DCOMPLEX: return tp1; case TYPE_CHAR: if(t == TYPE_CHAR) return tp1; break; default: if(t == TYPE_BASIC_TYPE(tp2)) return(tp2); fatal("max_type: non numeric type"); } return NULL; } /* type = (LIST basic_type length) * data_list = (LIST (LIST ident dims length) ...) * dims = (LIST dim ...) * dim = expr | (LIST expr expr) */ void compile_type_decl(expr type,expr decl_list) { expr x,ident,dims,leng; TYPE_DESC tp,tp0; int len; list lp; ID id; expr v; tp0 = compile_type(type); FOR_ITEMS_IN_LIST(lp,decl_list){ x = LIST_ITEM(lp); ident = EXPR_ARG1(x); dims = EXPR_ARG2(x); leng = EXPR_ARG3(x); if(ident == NULL) continue; /* error in parser ? */ if(EXPR_CODE(ident) != IDENT) fatal("compile_type_decl: not IDENT"); id = declare_ident(EXPR_SYM(ident),CL_UNKNOWN); tp = tp0; if(leng != NULL){ if(EXPR_CODE(leng) == LIST) len = CHAR_UNKNOWN_LEN; else { if((v = compile_int_constant(leng)) == NULL) continue; /* error */ len = EXPV_INT_VALUE(v); } if(TYPE_BASIC_TYPE(tp) != TYPE_CHAR){ error("length specification to non character"); continue; /* error */ } else tp = type_char(len); } if(dims != NULL) tp = compile_dimensions(tp,dims); if(id != NULL) declare_id_type(id,tp); } } /* create dimensions block for array variable. */ TYPE_DESC compile_dimensions(TYPE_DESC tp, expr dims) { expr x; expr lower,upper; TYPE_DESC tq; int n; list lp; n = 0; FOR_ITEMS_IN_LIST(lp,dims){ x = LIST_ITEM(lp); if(x == NULL){ if(LIST_NEXT(lp) != NULL) error("only last bound may be asterisk"); lower = upper = NULL; } else if(EXPR_CODE(x) == LIST){ /* (LIST lower upper) */ lower = EXPR_ARG1(x); upper = EXPR_ARG2(x); } else { lower = NULL; upper = x; } n++; if(n > MAX_DIM){ error("no more than MAX_DIM(%d) dimensions",MAX_DIM); break; } tq = new_type_desc(); TYPE_BASIC_TYPE(tq) = TYPE_ARRAY; if (lower != NULL) { expv tmp = expr_constant_value(lower, TRUE); if (tmp != NULL) { lower = tmp; } } TYPE_DIM_LOWER(tq) = lower; if (upper != NULL) { expv tmp = expr_constant_value(upper, TRUE); if (tmp != NULL) { upper = tmp; } } TYPE_DIM_UPPER(tq) = upper; TYPE_N_DIM(tq) = n; TYPE_DIM_FIXED(tq) = 0; /* immature */ TYPE_REF(tq) = tp; tp = tq; } return tp; } void fix_array_dimensions(TYPE_DESC tp) { int s; expv t; expv size,upper,lower; if(tp == NULL) return; if(IS_ARRAY_TYPE(tp)) fix_array_dimensions(TYPE_REF(tp)); else return; if(TYPE_DIM_FIXING(tp)){ error("cyclic reference in adjustable array size"); return; } if(TYPE_DIM_FIXED(tp)) return; TYPE_DIM_FIXING(tp) = TRUE; /* fixing */ if(TYPE_DIM_LOWER(tp) != NULL){ lower = expv_reduce(compile_expression(TYPE_DIM_LOWER(tp))); if (IS_NUMERIC_CONST_V(lower)) { lower = expv_reduce_conv_const(type_INT, lower); } else { t = allocate_ctemp(type_INT); output_expr_statement(expv_assignment(t,lower)); lower = t; } } else lower = expv_constant_1; if(TYPE_DIM_UPPER(tp) != NULL){ upper = expv_reduce(compile_expression(TYPE_DIM_UPPER(tp))); if (IS_NUMERIC_CONST_V(upper)) { upper = expv_reduce_conv_const(type_INT, upper); } else { t = allocate_ctemp(type_INT); output_expr_statement(expv_assignment(t,upper)); upper = t; } } else { /* A(lower:*) */ TYPE_ARRAY_SIZE(tp) = -1; TYPE_DIM_SIZE(tp) = NULL; TYPE_DIM_LOWER(tp) = lower; TYPE_DIM_FIXED(tp) = TRUE; /* fix it */ TYPE_DIM_FIXING(tp) = FALSE; return; } if(EXPV_CODE(upper) == INT_CONSTANT && EXPV_CODE(lower) == INT_CONSTANT){ s = EXPV_INT_VALUE(upper)-EXPV_INT_VALUE(lower)+1; if(s <= 0) error_at_node(TYPE_DIM_UPPER(tp), "upper bound must be larger than lower bound"); size = expv_int_term(INT_CONSTANT,type_INT,s); } else { /* adujstable array */ s = -1; if(lower == expv_constant_1) size = upper; else size = expv_cons(PLUS_EXPR,type_INT, expv_cons(MINUS_EXPR,type_INT,upper,lower), expv_constant_1); } if(IS_ARRAY_TYPE(TYPE_REF(tp)) && TYPE_ARRAY_SIZE(TYPE_REF(tp)) < 0) s = -1; TYPE_ARRAY_SIZE(tp) = s; TYPE_DIM_SIZE(tp) = size; TYPE_DIM_LOWER(tp) = lower; TYPE_DIM_UPPER(tp) = upper; TYPE_DIM_FIXED(tp) = 1; /* fix it */ TYPE_DIM_FIXING(tp) = FALSE; } TYPE_DESC array_element_type(TYPE_DESC tp) { if(!IS_ARRAY_TYPE(tp)) fatal("array_element_type: not ARRAY_TYPE"); while(IS_ARRAY_TYPE(tp)) tp = TYPE_REF(tp); return tp; } /* return total array size. if char_type, return size in byte */ expv array_total_size(TYPE_DESC tp) { expv v; if(!IS_ARRAY_TYPE(tp)) return NULL; if(TYPE_DIM_SIZE(tp) == NULL) return NULL; if(!IS_ARRAY_TYPE(TYPE_REF(tp))){ if(IS_CHAR(TYPE_REF(tp))){ if(TYPE_CHAR_LEN(TYPE_REF(tp)) == CHAR_UNKNOWN_LEN) return NULL; else return expv_cons(MUL_EXPR,type_INT, expv_int_term(INT_CONSTANT,type_INT, TYPE_CHAR_LEN(TYPE_REF(tp))), TYPE_DIM_SIZE(tp)); } else return TYPE_DIM_SIZE(tp); } else { v = array_total_size(TYPE_REF(tp)); if(v == NULL) return NULL; return expv_cons(MUL_EXPR,type_INT,v,TYPE_DIM_SIZE(tp)); } } void compile_PARAM_decl(expr const_list) { expr x,ident,e; expv v; ID id; list lp; if (const_list == NULL) { return; /* error */ } FOR_ITEMS_IN_LIST(lp, const_list) { x = LIST_ITEM(lp); if (x == NULL) { continue; /* error */ } ident = EXPR_ARG1(x); e = EXPR_ARG2(x); if (EXPR_CODE(ident) != IDENT) { fatal("comile_PARAM_decl: no IDENT"); return; } if (expr_is_constant(e) != TRUE) { error("bad constant expression in PARAMETER statement, not a constant?"); continue; } v = expr_constant_value(e, FALSE); if (v == NULL) { error("bad constant expression in PARAMETER statement"); continue; } id = declare_ident(EXPR_SYM(ident), CL_PARAM); if (id == NULL) { continue; } implicit_declaration(id); v = expv_reduce_conv_const(ID_TYPE(id), v); if (EXPR_CODE(v) == COMPLEX_CONSTANT) { /* * Special case. C language can't handle complex constant * as a native language constant. * * 1. "id" is treated as CL_PARAM. * 2. Generate a tempolary variable that contains the * complex constant. * 3. Set ID_CONST(id) as variable expression generated in * 2. * 4. Set PARAM_COMPLEX(id) to original COMPLEX_CONSTANT. */ TYPE_DESC cTyp = ID_TYPE(id); expv czVal; expv cV = NULL; if (TYPE_BASIC_TYPE(cTyp) == TYPE_COMPLEX) { czVal = expv_c_cons(EXPR_ARG1(v), EXPR_ARG2(v), TRUE); } else { czVal = expv_z_cons(EXPR_ARG1(v), EXPR_ARG2(v), TRUE); } cV = expv_complex_node_to_variable(czVal, cTyp); if (cV == NULL) { goto doNormal; } ID_CONST(id) = cV; EXPV_IS_RVALUE(cV) = TRUE; #ifdef ENABLE_QREAL PARAM_QREAL(id) = NULL; #endif /* ENABLE_QREAL */ PARAM_COMPLEX(id) = v; continue; #ifdef ENABLE_QREAL } else if (EXPR_CODE(v) == QREAL_CONSTANT) { if (doQCZFolding == TRUE) { /* * Special case 2. Like the complex constant, C * language can't handle multiple precision floating * point constant as a native language constant, too * B) * * 1. "id" is treat as CL_PARAM, too. * 2. Generate a tempolary variable. * 3. Generate a DATA statement with the variable and * the constant. * 4. Set ID_CONST(id) as variable expression gnerated * in 2. * 5. Set PARAM_QREAL(id) to original QREAL_CONSTANT. */ expv qV = expv_qreal_const_DATA_initialize(v); if (qV == NULL) { goto doNormal; } ID_CONST(id) = qV; EXPV_IS_RVALUE(qV) = TRUE; PARAM_COMPLEX(id) = NULL; PARAM_QREAL(id) = v; continue; } else { goto doNormal; } #endif /* ENABLE_QREAL */ } else { doNormal: PARAM_COMPLEX(id) = NULL; #ifdef ENABLE_QREAL PARAM_QREAL(id) = NULL; #endif /* ENABLE_QREAL */ } if ((v = expv_type_conversion(ID_TYPE(id),v)) == NULL) { continue; } ID_CONST(id) = expv_reduce(v); } } static void genBlankCommon() { SYMBOL sym = c_find_symbol(BLANK_COMMON_NAME); blank_common = declare_external_id(sym, STG_COMMON, TRUE); } static SYMBOL genCommonName(ident) expr ident; { char buf[65536]; sprintf(buf, "%s_COMMON", SYM_NAME(EXPR_SYM(ident))); return c_find_symbol(buf); } char * getCommonNameFromExtId(eid) EXT_ID eid; { char *name = NULL; char *p; if (EXT_TAG(eid) != STG_COMMON) { return "???"; } name = strdup(SYM_NAME(EXT_SYM(eid))); p = strstr(name, "_COMMON"); if (p != NULL) { *p = '\0'; } if (strncmp(name, BLANK_COMMON_NAME, strlen(name)) == 0) { free(name); return strdup("(blank common)"); } return name; } EXT_ID findCommon(ident) expr ident; { SYMBOL sym = genCommonName(ident); int found = FALSE; EXT_ID ep; for (ep = external_symbols; ep != NULL; ep = EXT_NEXT(ep)) { if (EXT_SYM(ep) == sym && EXT_TAG(ep) == STG_COMMON) { found = TRUE; break; } } if (found == TRUE) { return ep; } else { return NULL; } } EXT_ID findRuntimeExternalId(sym) SYMBOL sym; { EXT_ID ep; int found = FALSE; for (ep = external_symbols; ep != NULL; ep = EXT_NEXT(ep)) { if (EXT_SYM(ep) == sym && EXT_TAG(ep) == STG_EXT && EXT_PROC_IS_RUNTIME(ep) == TRUE) { found = TRUE; break; } } if (found == TRUE) { return ep; } else { return NULL; } } void compile_COMMON_decl(expr com_list) { expr x,ident,dims; EXT_ID ep; list lp; ID id; TYPE_DESC tp; if (blank_common == NULL) { genBlankCommon(); } ep = blank_common; FOR_ITEMS_IN_LIST(lp,com_list){ x = LIST_ITEM(lp); if(x == NULL){ ep = blank_common; continue; } if (EXPR_CODE(x) == IDENT) { /* common name */ ep = declare_external_id(genCommonName(x), STG_COMMON, TRUE); if(ep == NULL) ep = blank_common; continue; } if (EXPR_CODE(x) != LIST) fatal("compile_COMMON_decl: syntax error"); ident = EXPR_ARG1(x); dims = EXPR_ARG2(x); if (ident == NULL) continue; if (EXPR_CODE(ident) != IDENT) fatal("compile_COMMON_decl: not ident"); id = declare_ident(EXPR_SYM(ident),CL_VAR); tp = ID_TYPE(id); if (dims != NULL) tp = compile_dimensions(tp,dims); if (id != NULL){ declare_id_type(id,tp); if (ID_STORAGE(id) != STG_UNKNOWN && ID_STORAGE(id) != STG_EQUIV && ID_STORAGE(id) != STG_COMEQ && ID_STORAGE(id) != STG_AUTO && ID_STORAGE(id) != STG_BSS) { error("incompatible common declaration, %s '%s'", ID_NAME(id), storage_class_names[(int)ID_STORAGE(id)]); continue; } if (ID_STORAGE(id) == STG_EQUIV) { ID_STORAGE(id) = STG_COMEQ; } else { ID_STORAGE(id) = STG_COMMON; } VAR_COM_NAME(id) = ep; /* for struct/union ID */ VAR_EQUIV_STRUCT_NO(id) = current_proc_no; /* use ID_LIST to store the pointer to ID */ if (EXT_COM_LIST(ep) == NULL) { EXT_COM_LIST(ep) = list0(LIST); } EXT_COM_LIST(ep) = list_put_last(EXT_COM_LIST(ep), expv_any_term(ID_LIST,(void *)id)); } } } /* * declare all common variables after declarations. * clean up EXT_COM_LIST. */ void declare_common_variables() { EXT_ID ep; int length,align,l, oLength; list lp; ID id; TYPE_DESC tp; for (ep = external_symbols; ep != NULL; ep = EXT_NEXT(ep)) { if (EXT_TAG(ep) == STG_COMMON && EXT_COM_LIST(ep) != NULL) { oLength = EXT_COM_LEN(ep); length = 0; FOR_ITEMS_IN_LIST(lp, EXT_COM_LIST(ep)) { id = EXPV_ANY(ID, LIST_ITEM(lp)); if((id = declare_variable(id)) == NULL) continue; /* error */ tp = ID_TYPE(id); align = type_align(tp); if (length % align != 0) { warning_at_node(EXT_COM_LIST(ep), "'%s' in common '%s' is not aligned to %d.", ID_NAME(id), getCommonNameFromExtId(ep), align); length = ROUND(length,align); } l = type_length(tp); if (l < 0) { error_at_node(EXT_COM_LIST(ep), "adjustable array in common, %s", ID_NAME(id)); } else { length += l; } } if (ep != blank_common && EXT_COM_LEN(ep) != 0 && EXT_COM_LEN(ep) != length) { warning_at_node(EXT_COM_LIST(ep), "incompatible length for common block '%s'", getCommonNameFromExtId(ep)); } /* Set maximum length as length of the common block */ if (length > oLength) { EXT_COM_LEN(ep) = length; } if (EXT_COM_LISTS(ep) == NULL) { EXT_COM_LISTS(ep) = list0(LIST); } EXT_COM_LISTS(ep) = list_put_last(EXT_COM_LISTS(ep), list2(LIST, expv_int_term(INT_CONSTANT, NULL, current_proc_no), EXT_COM_LIST(ep))); if (current_proc_class == CL_BLOCK) { if (EXT_COM_IN_BLOCKDATA(ep) > 0) { error("common block '%s' is already initialized.", getCommonNameFromExtId(ep)); } else { EXT_COM_IN_BLOCKDATA(ep) = current_proc_no; } } EXT_COM_LIST(ep) = NULL; /* check save */ if (EXT_COM_IS_SAVE(ep)) { list lq, lr; FOR_ITEMS_IN_LIST(lq, EXT_COM_LISTS(ep)) { FOR_ITEMS_IN_LIST(lr, EXPR_ARG2(LIST_ITEM(lq))) { id = EXPV_ANY(ID, LIST_ITEM(lr)); (void)markAsSave(id); } } EXT_COM_IS_SAVE(ep) = FALSE; } } } } void finalize_common_storage() { EXT_ID ep; ID id; char buf[4096]; int wholeId = 0; expv wV, tmp; for (ep = external_symbols; ep != NULL; ep = EXT_NEXT(ep)) { if (EXT_TAG(ep) == STG_COMMON && EXT_COM_LISTS(ep) != NULL) { sprintf(buf, "__common_whole_%d", wholeId++); id = declare_ident(c_find_symbol(buf), CL_VAR); ID_IS_DECLARED(id) = FALSE; ID_STORAGE(id) = STG_COMMON; VAR_COM_NAME(id) = ep; ID_TYPE(id) = type_char(EXT_COM_LEN(ep)); VAR_EQUIV_STRUCT_NO(id) = 0; declare_variable(id); wV = list1(LIST, expv_int_term(INT_CONSTANT, type_INT, VAR_EQUIV_STRUCT_NO(id))); tmp = list1(LIST, expv_any_term(ID_LIST, (void *)id)); wV = list_put_last(wV, tmp); EXT_COM_LISTS(ep) = list_put_last(EXT_COM_LISTS(ep), wV); } } } /* declare external function */ void compile_EXTERNAL_decl(id_list) expr id_list; { list lp; expr ident; ID id; if(id_list == NULL) return; /* error */ FOR_ITEMS_IN_LIST(lp,id_list){ ident = LIST_ITEM(lp); if(ident == NULL) break; if(EXPR_CODE(ident) != IDENT) fatal("compile_EXTERNAL_decl:not ident"); if((id = declare_ident(EXPR_SYM(ident),CL_PROC)) == NULL) continue; if(PROC_CLASS(id) == P_UNKNOWN) PROC_CLASS(id) = P_EXTERNAL; else if(PROC_CLASS(id) != P_EXTERNAL){ error("invalid external declaration, %s", ID_NAME(id)); continue; } } } /* declare intrinsic function */ void compile_INTRINSIC_decl(id_list) expr id_list; { list lp; expr ident; ID id; if(id_list == NULL) return; /* error */ FOR_ITEMS_IN_LIST(lp,id_list){ ident = LIST_ITEM(lp); if(ident == NULL) break; if(EXPR_CODE(ident) != IDENT)fatal("compile_INTRINSIC_decl:not ident"); if((id = declare_ident(EXPR_SYM(ident),CL_PROC)) == NULL) continue; if(PROC_CLASS(id) == P_UNKNOWN) PROC_CLASS(id) = P_INTRINSIC; else if(PROC_CLASS(id) != P_INTRINSIC) error("invalid intrinsic declaration, %s", ID_NAME(id)); } } static int markAsSave(id) ID id; { if ((ID_CLASS(id) != CL_VAR && ID_CLASS(id) != CL_UNKNOWN) || ID_STORAGE(id) == STG_ARG) { error("\"%s\" is not a variable.", SYM_NAME(ID_SYM(id))); return FALSE; } VAR_IS_SAVE(id) = TRUE; return TRUE; } /* declare save variable */ void compile_SAVE_decl(id_list) expr id_list; { list lp; expr ident; ID id; if (id_list == NULL) { EXT_ID eId; /* * special care. must save ALL variable in this scope. */ /* local symbol. */ for (id = local_symbols; id != NULL; id = ID_NEXT(id)) { if ((ID_CLASS(id) == CL_UNKNOWN || ID_CLASS(id) == CL_VAR) && ID_STORAGE(id) != STG_ARG) { markAsSave(id); } } /* common */ for (eId = external_symbols; eId != NULL; eId = EXT_NEXT(eId)) { if (EXT_TAG(eId) == STG_COMMON && EXT_COM_LIST(eId) != NULL) { EXT_COM_IS_SAVE(eId) = TRUE; } } return; } FOR_ITEMS_IN_LIST(lp, id_list) { ident = LIST_ITEM(lp); switch (EXPR_CODE(ident)) { case IDENT: { if ((id = find_ident(EXPR_SYM(ident))) == NULL) { id = declare_ident(EXPR_SYM(ident), CL_VAR); if (id == NULL) { /* must not happen. */ continue; } } (void)markAsSave(id); break; } case LIST: { /* COMMON name */ EXT_ID cId = NULL; ident = EXPR_ARG1(ident); cId = findCommon(ident); if (cId == NULL) { error("common block \"%s\" is not declared.", SYM_NAME(EXPR_SYM(ident))); continue; } /* * After this closure is parsed, mark variables in this common as saved. */ EXT_COM_IS_SAVE(cId) = TRUE; break; } default: { fatal("illegal item(s) in save statement."); break; } } } } void compile_cray_POINTER_decl(x) expr x; { list lp; /* * just add them. */ if (crayPointerList == NULL) { crayPointerList = list0(LIST); } FOR_ITEMS_IN_LIST(lp, x) { crayPointerList = list_put_last(crayPointerList, LIST_ITEM(lp)); } } void FinalizeCrayPointer() { ID ptrId, baseId; expr ptrX, baseX; list lp; int ptrIsArg = FALSE; #if 0 int baseNotDeclared = FALSE; #endif int baseIsArray = FALSE; expr baseDimX = NULL; TYPE_DESC baseTp = NULL; FOR_ITEMS_IN_LIST(lp, crayPointerList) { ptrIsArg = FALSE; #if 0 baseNotDeclared = FALSE; #endif baseIsArray = FALSE; baseDimX = NULL; baseTp = NULL; ptrX = EXPR_ARG1(LIST_ITEM(lp)); baseX = EXPR_ARG2(LIST_ITEM(lp)); if (EXPR_CODE(ptrX) != IDENT) { error("pointer variable must be a scalar variable."); continue; } switch (EXPR_CODE(baseX)) { case IDENT: { break; } case F_ARRAY_REF: { baseIsArray = TRUE; baseDimX = EXPR_ARG2(baseX); baseX = EXPR_ARG1(baseX); break; } default: { error("not a variable."); continue; } } ptrId = declare_ident(EXPR_SYM(ptrX), CL_UNKNOWN); /* * Pointer variable validness check */ if (ID_TYPE(ptrId) != NULL) { #if defined(ADDR_IS_64) && defined(HAS_INT64) if (TYPE_BASIC_TYPE(ID_TYPE(ptrId)) != TYPE_LONGLONG) { error("'%s' is not an integer variable that can hold address space.", SYM_NAME(ID_SYM(ptrId))); continue; } #else if (TYPE_BASIC_TYPE(ID_TYPE(ptrId)) != TYPE_INT) { error("'%s' is not an integer variable.", SYM_NAME(ID_SYM(ptrId))); continue; } #endif /* ADDR_IS_64 && HAS_INT64 */ } if (VAR_POINTER_BASE_ID(ptrId) != NULL) { error("'%s' is already declared as pointer variable of '%s'.", SYM_NAME(ID_SYM(ptrId)), SYM_NAME(ID_SYM(VAR_POINTER_BASE_ID(ptrId)))); continue; } if (ID_STORAGE(ptrId) != STG_UNKNOWN && ID_STORAGE(ptrId) != STG_AUTO && ID_STORAGE(ptrId) != STG_BSS && ID_STORAGE(ptrId) != STG_ARG && ID_STORAGE(ptrId) != STG_COMMON && ID_STORAGE(ptrId) != STG_COMEQ && ID_STORAGE(ptrId) != STG_EQUIV) { error("'%s' is not valid pointer variable.", SYM_NAME(ID_SYM(ptrId))); continue; } if (ID_STORAGE(ptrId) == STG_ARG) { if (IS_ARRAY_TYPE(ID_TYPE(ptrId)) == TRUE) { error("'%s' is not a scalar variable.", SYM_NAME(ID_SYM(ptrId))); continue; #if defined(ADDR_IS_64) && defined(HAS_INT64) } else if (TYPE_BASIC_TYPE(ID_TYPE(ptrId)) != TYPE_LONGLONG) { error("'%s' is not an integer variable that can hold address space.", SYM_NAME(ID_SYM(ptrId))); continue; } #else } else if (TYPE_BASIC_TYPE(ID_TYPE(ptrId)) != TYPE_INT) { error("'%s' is not an integer variable.", SYM_NAME(ID_SYM(ptrId))); continue; } #endif /* ADDR_IS_64 && HAS_INT64 */ ptrIsArg = TRUE; } if (ID_CLASS(ptrId) == CL_UNKNOWN) { /* * Type of the pointer variable is always int. */ if (ptrIsArg == FALSE) { #if defined(ADDR_IS_64) && defined(HAS_INT64) declare_id_type(ptrId, type_LONGLONG); #else declare_id_type(ptrId, type_INT); #endif /* ADDR_IS_64 && HAS_INT64 */ declare_variable(ptrId); } } baseId = declare_ident(EXPR_SYM(baseX), CL_VAR); /* * Pointer base variable validness check */ if (ID_STORAGE(baseId) != STG_UNKNOWN && ID_STORAGE(baseId) != STG_AUTO && ID_STORAGE(baseId) != STG_BSS && ID_STORAGE(baseId) != STG_PTRBASE) { error("'%s' is not valid pointer base variable.", SYM_NAME(ID_SYM(baseId))); continue; } if (ID_STORAGE(baseId) == STG_PTRBASE) { error("'%s' is already declared as pointer base variable.", SYM_NAME(ID_SYM(baseId))); continue; } /* * OK, make them a pointer pair. */ ID_STORAGE(baseId) = STG_PTRBASE; VAR_POINTER_ID(baseId) = ptrId; VAR_POINTER_BASE_ID(ptrId) = baseId; baseTp = ID_TYPE(baseId); if (baseTp == NULL) { implicit_declaration(baseId); baseTp = ID_TYPE(baseId); } if (baseIsArray == TRUE || IS_ARRAY_TYPE(baseTp)) { baseTp = compile_dimensions(baseTp, baseDimX); fix_array_dimensions(baseTp); } declare_id_type(baseId, baseTp); } crayPointerList = NULL; }