Open64 (mfef90, whirl2f, and IR tools)
TAG: version-openad; SVN changeset: 916
|
00001 /* 00002 00003 Copyright (C) 2000, 2001 Silicon Graphics, Inc. All Rights Reserved. 00004 00005 This program is free software; you can redistribute it and/or modify it 00006 under the terms of version 2 of the GNU General Public License as 00007 published by the Free Software Foundation. 00008 00009 This program is distributed in the hope that it would be useful, but 00010 WITHOUT ANY WARRANTY; without even the implied warranty of 00011 MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. 00012 00013 Further, this software is distributed without any warranty that it is 00014 free of the rightful claim of any third person regarding infringement 00015 or the like. Any license provided herein, whether implied or 00016 otherwise, applies only to this software file. Patent licenses, if 00017 any, provided herein do not apply to combinations of this program with 00018 other software, or any other product whatsoever. 00019 00020 You should have received a copy of the GNU General Public License along 00021 with this program; if not, write the Free Software Foundation, Inc., 59 00022 Temple Place - Suite 330, Boston MA 02111-1307, USA. 00023 00024 Contact information: Silicon Graphics, Inc., 1600 Amphitheatre Pky, 00025 Mountain View, CA 94043, or: 00026 00027 http://www.sgi.com 00028 00029 For further information regarding this notice, see: 00030 00031 http://oss.sgi.com/projects/GenInfo/NoticeExplan 00032 00033 */ 00034 00035 00036 /* ==================================================================== 00037 * ==================================================================== 00038 * 00039 * 00040 * Revision history: 00041 * dd-mmm-95 - Original Version 00042 * 00043 * Description: Contains routines to convert IO statements. Entry points from 00044 the PDGCS layer are: 00045 fei_*_read, fei_*_write, fei_control_list, fei_IO_list, 00046 fei_implied_do and fei_iolength. 00047 * 00048 * ==================================================================== 00049 * ==================================================================== 00050 */ 00051 00052 static char *source_file = __FILE__; 00053 00054 #ifdef _KEEP_RCS_ID 00055 #endif /* _KEEP_RCS_ID */ 00056 00057 /* sgi includes */ 00058 00059 #include "defs.h" 00060 #include "glob.h" 00061 #include "stab.h" 00062 #include "strtab.h" 00063 #include "errors.h" 00064 #include "config.h" 00065 #include "config_targ.h" 00066 #include "wn.h" 00067 #include "const.h" 00068 #include "wio.h" 00069 #include "ir_reader.h" 00070 #include "wn_util.h" 00071 #include "targ_const.h" 00072 #include "targ_sim.h" 00073 00074 /* Cray includes */ 00075 00076 #include "i_cvrt.h" 00077 00078 00079 /* conversion includes */ 00080 00081 #include "cwh_defines.h" 00082 #include "cwh_addr.h" 00083 #include "cwh_dope.h" 00084 #include "cwh_stk.h" 00085 #include "cwh_types.h" 00086 #include "cwh_expr.h" 00087 #include "cwh_block.h" 00088 #include "sgi_cmd_line.h" 00089 #include "cwh_preg.h" 00090 #include "cwh_stab.h" 00091 #include "cwh_auxst.h" 00092 00093 #include "cwh_io.i" 00094 #include "cwh_io.h" 00095 00096 #define STACK_PUSH(x) \ 00097 if (x != NULL) \ 00098 cwh_stk_push(x, WN_item); 00099 00100 #define IoItem_TY(wn) (WN_kid(wn,3)) 00101 #ifndef NIL 00102 #define NIL 0 00103 #endif 00104 00105 static INT32 num_list_items_last_processed; 00106 00107 typedef enum { 00108 CILIST_EDFLAG = 0, 00109 CILIST_EEEFLAG = 1, 00110 CILIST_FLFLAG = 2, 00111 CILIST_UNIT = 3, 00112 CILIST_IOSTAT = 4, 00113 CILIST_REC = 5, 00114 CILIST_PARSFMT = 6, 00115 CILIST_FMTSRC = 7, 00116 CILIST_ADVANCE = 8, 00117 CILIST_SIZE = 9, 00118 CILIST_ERR = 10, 00119 CILIST_END = 11, 00120 CILIST_EOR = 12 00121 } CILIST_TABLE_ITEM; 00122 00123 typedef enum { 00124 OPEN_CALLNAME = 0, 00125 OPEN_VERSION = 1, 00126 OPEN_UNIT = 2, 00127 OPEN_IOSTAT = 3, 00128 OPEN_ERRFLAG = 4, 00129 OPEN_FILE = 5, 00130 OPEN_STATUS = 6, 00131 OPEN_ACCESS = 7, 00132 OPEN_FORM = 8, 00133 OPEN_RECL = 9, 00134 OPEN_BLANK = 10, 00135 OPEN_POSITION = 11, 00136 OPEN_ACTION = 12, 00137 OPEN_DELIM = 13, 00138 OPEN_PAD = 14, 00139 OPEN_ERR = 15 00140 } OPEN_TABLE_ITEM; 00141 00142 typedef enum { 00143 CLOSE_CALLNAME = 0, 00144 CLOSE_VERSION = 1, 00145 CLOSE_UNIT = 2, 00146 CLOSE_IOSTAT = 3, 00147 CLOSE_ERRFLAG = 4, 00148 CLOSE_STATUS = 5, 00149 CLOSE_ERR = 6 00150 } CLOSE_TABLE_ITEM; 00151 00152 typedef enum { 00153 INQ_CALLNAME = 0, 00154 INQ_VERSION = 1, 00155 INQ_UNIT = 2, 00156 INQ_FILE = 3, 00157 INQ_IOSTAT = 4, 00158 INQ_ERRFLAG = 5, 00159 INQ_EXIST = 6, 00160 INQ_OPENED = 7, 00161 INQ_NUMBER = 8, 00162 INQ_NAMED = 9, 00163 INQ_NAME = 10, 00164 INQ_ACCESS = 11, 00165 INQ_SEQUENTIAL = 12, 00166 INQ_DIRECT = 13, 00167 INQ_FORM = 14, 00168 INQ_FORMATTED = 15, 00169 INQ_UNFORMATTED = 16, 00170 INQ_RECL =17, 00171 INQ_NEXTREC = 18, 00172 INQ_BLANK = 19, 00173 INQ_POSITION = 20, 00174 INQ_ACTION = 21, 00175 INQ_READ = 22, 00176 INQ_WRITE = 23, 00177 INQ_READWRITE = 24, 00178 INQ_DELIM = 25, 00179 INQ_PAD = 26, 00180 INQ_ERR = 27 00181 } INQ_TABLE_ITEM; 00182 00183 typedef enum { 00184 BIO_CALLNAME = 0, 00185 BIO_VERSION = 1, 00186 BIO_UNIT = 2, 00187 BIO_RECMODE = 3, 00188 BIO_BLOC = 4, 00189 BIO_ELOC = 5, 00190 BIO_TIPTR = 6 00191 } BIO_TABLE_ITEM; 00192 00193 /* Rewind, backspace and endfile do not require the io descriptor setup 00194 and use the following enum */ 00195 00196 typedef enum { 00197 NODESC_CALLNAME = 0, 00198 NODESC_UNIT = 1, 00199 NODESC_IOSTAT = 2, 00200 NODESC_ERRFLAG = 3, 00201 NODESC_ERR = 4 00202 } NODESC_TABLE_ITEM; 00203 00204 #define WRITE_STMT 0 00205 #define READ_STMT 1 00206 #define NML_MASK 2 00207 #define READ_WRITE_MASK 1 00208 #define NAMELIST_MODE(x) ((x) & NML_MASK) 00209 #define READ_MODE(x) ((x) & READ_WRITE_MASK) 00210 #define WRITE_MODE(x) (!((x) & READ_WRITE_MASK)) 00211 00212 static WN * cwh_io_ioitem(int mode, WN *craytype); 00213 static WN * cwh_io_str_ioitem(IOITEM it, int mode, WN *craytype); 00214 static WN * cwh_io_char_ioitem(IOITEM it, WN *len, int mode, WN *craytype); 00215 00216 static INT32 eeeflag; 00217 static MARKED_SET *marked_set; 00218 00219 static TY_IDX 00220 cwh_io_scalar_type(WN *wn) { 00221 TY_IDX ty = NIL; 00222 00223 if (wn) { 00224 ty = cwh_types_WN_TY(wn,FALSE); 00225 ty = cwh_types_array_TY(ty); 00226 ty = cwh_types_scalar_TY(ty); 00227 } 00228 return ty; 00229 } 00230 00231 /*=============================================== 00232 * 00233 * fei_control_list 00234 * 00235 * Create IO item nodes from the list items already pushed on the 00236 * stack. 00237 * Ten list items are assumed to have already been pushed onto the stack 00238 * with #10 at the top of the stack. 00239 * 1. Encode/Decode Flag 00240 * 2. eeeflag value 00241 * 1 if ERR=specified 00242 * 2 if END=specified 00243 * 4 if EOR=specified 00244 * 8 if IOSTAT=specified 00245 * 3. flflag value -- indicates information on first/last flag 00246 * 4. Unit Specifier 00247 * 5. IOSTAT variable 00248 * 6. REC variable 00249 * 7. Preparsed format variable 00250 * 8. format source variable 00251 * 9. ADVANCE variable 00252 * 10. SIZE variable 00253 *=============================================== 00254 */ 00255 00256 extern void 00257 fei_control_list(int mode) 00258 { 00259 INT item; 00260 WN *wn_eeeflag = NULL; 00261 WN *wn_unit = NULL; 00262 WN *wn_iostat = NULL; 00263 WN *wn_rec = NULL; 00264 WN *wn_parsfmt = NULL; 00265 WN *wn_fmtsrc = NULL; 00266 WN *wn_advance = NULL; 00267 WN *wn_size = NULL; 00268 WN *wn_flflag = NULL; 00269 WN *wn_edflag = NULL; 00270 WN *wn_end = NULL; 00271 WN *wn_err = NULL; 00272 WN *wn_eor = NULL; 00273 WN *wn1; 00274 WN *wn2; 00275 WN *unit_address = NULL; 00276 WN *ed_unit = NULL; /* unit for encode decode */ 00277 ST *st; 00278 TY_IDX ts = NIL; 00279 TY_IDX td = NIL; 00280 TY_IDX ty = NIL; 00281 WN *se; 00282 INT32 edflag = 0; 00283 00284 eeeflag = 0; 00285 for (item=CILIST_EOR; item >= CILIST_EDFLAG ; item--) { 00286 00287 switch (item) { 00288 00289 case CILIST_SIZE: 00290 ts = cwh_stk_get_TY(); 00291 wn1 = cwh_expr_address(f_NONE); 00292 00293 if (wn1) { 00294 if (ts != NIL) { 00295 ty = cwh_types_array_TY(ts); 00296 ty = cwh_types_scalar_TY(ty); 00297 } else { 00298 ty = cwh_io_scalar_type(wn1); 00299 } 00300 wn_size = WN_CreateIoItem1 ( IOC_SIZE, wn1, ty ); 00301 } 00302 break; 00303 00304 case CILIST_ADVANCE: 00305 if (cwh_stk_get_class() == STR_item) { 00306 cwh_stk_pop_STR(); 00307 wn2 = cwh_expr_operand(NULL); 00308 wn1 = cwh_expr_address(f_NONE); 00309 wn_advance = WN_CreateIoItem2 (IOC_ADVANCE, wn1, wn2, NIL); 00310 } else { 00311 /* Assume there was a null wn for a place holder; just pop it */ 00312 //wn1 = cwh_expr_operand(DELETE_ARRAYEXP_WN); 00313 wn1 = cwh_expr_operand(NULL); 00314 } 00315 break; 00316 00317 case CILIST_FMTSRC: 00318 if (target_io_library == IOLIB_MIPS) { 00319 wn1 = cwh_expr_address(f_NONE); 00320 if (wn1 == NULL) 00321 wn_fmtsrc = WN_CreateIoItem0 ( IOF_LIST_DIRECTED, NIL ); 00322 else 00323 DevWarn(("Only List directed I/O supported now")); 00324 } else { /* Library = CRAY */ 00325 switch(cwh_stk_get_class()) { 00326 00327 case STR_item : 00328 00329 cwh_stk_pop_STR(); 00330 wn2 = cwh_expr_operand(DELETE_ARRAYEXP_WN); 00331 ts = cwh_stk_get_TY(); 00332 wn1 = cwh_expr_address(f_NONE); 00333 se = cwh_addr_find_section(wn1, p_RETURN_SECTION); 00334 if (se) { 00335 ty = cwh_types_array_TY(ts); 00336 wn1 = cwh_dope_from_expression(wn1, NULL, wn2, ts, NULL ); 00337 ty = cwh_types_scalar_TY(ty); 00338 wn_fmtsrc = WN_CreateIoItem2 (IOF_CR_FMTSRC_DOPE, wn1, 00339 cwh_addr_find_address(se), ty); 00340 } else { 00341 wn_fmtsrc = WN_CreateIoItem2 (IOF_CR_FMTSRC, wn1, wn2, NIL); 00342 } 00343 break ; 00344 00345 case ST_item : 00346 case ST_item_whole_array: 00347 00348 if (NAMELIST_MODE(mode)) { 00349 00350 ST *namelist_group; 00351 ITEM* element; 00352 NLIST *dummy, *nmlist; 00353 INT32 count, i; 00354 00355 element = NULL; 00356 namelist_group = cwh_stk_pop_ST(); 00357 wn1 = cwh_addr_address_ST(namelist_group, 0); 00358 dummy = (NLIST *) malloc(sizeof (NLIST)) ; 00359 Nlist_wn(dummy) = wn1; 00360 Nlist_next(dummy) = NULL; 00361 nmlist = dummy; 00362 count = 1; 00363 while ((element = cwh_auxst_next_element( 00364 namelist_group,element,l_NAMELIST)) != NULL ) { 00365 wn1 = cwh_addr_address_ST(I_element(element), 0 ); 00366 dummy = (NLIST *) malloc(sizeof (NLIST)) ; 00367 Nlist_wn(dummy) = wn1; 00368 Nlist_next(dummy) = nmlist; 00369 nmlist = dummy; 00370 count++; 00371 } 00372 wn_fmtsrc = WN_CreateIoItemN(IOF_NAMELIST_DIRECTED, 00373 count, NIL); 00374 for(i=0; i<count; i++) { 00375 WN_kid(wn_fmtsrc, i) = Nlist_wn(nmlist); 00376 nmlist = Nlist_next(nmlist); 00377 } 00378 free (dummy); 00379 00380 } else { 00381 00382 st = cwh_stk_pop_ST(); 00383 cwh_stk_push(st, ST_item); 00384 ty = ST_type(st); 00385 00386 /* For ASSIGN 0012 TO I 00387 WRITE (*,I) 00388 Cray FE puts the address of the format in I, and we 00389 need to use cwh_expr_operand to load I to get to the 00390 address of the format. 00391 For write(*,100) i 00392 100 format(I4) 00393 the Cray FE provides a TEMP of KIND_ARRAY that holds the 00394 format. For this we need to use cwh_expr_address. 00395 */ 00396 00397 if (TY_kind(ty) == KIND_ARRAY) 00398 wn1 = cwh_expr_address(f_NONE); 00399 else 00400 wn1 = cwh_expr_operand(NULL); 00401 wn_fmtsrc = WN_CreateIoItem1 ( IOF_CR_FMTSRC, wn1, NIL ); 00402 } 00403 break; 00404 00405 default: 00406 if (cwh_stk_get_class() == FLD_item) { 00407 td = cwh_stk_get_FLD_TY(); 00408 } 00409 00410 wn1 = cwh_expr_address(f_NONE); 00411 se = cwh_addr_find_section(wn1, p_RETURN_SECTION); 00412 if (se) { 00413 if (td != NIL) { 00414 ty = cwh_types_array_TY(td); 00415 ty = cwh_types_scalar_TY(ty); 00416 } else { 00417 ts = cwh_types_WN_TY(se,FALSE); 00418 ts = cwh_types_array_TY(ts); 00419 ty = cwh_types_scalar_TY(ts); 00420 } 00421 wn1 = cwh_dope_from_expression(wn1, NULL, NULL, ty, 00422 NULL); 00423 wn_fmtsrc = WN_CreateIoItem2 (IOF_CR_FMTSRC_DOPE, wn1, 00424 cwh_addr_find_address(se), ty); 00425 } else { 00426 if (wn1 != NULL) 00427 wn_fmtsrc = WN_CreateIoItem1 (IOF_CR_FMTSRC, wn1, NIL); 00428 else 00429 wn_fmtsrc = WN_CreateIoItem0 ( IOF_NONE, NIL ); 00430 } 00431 break; 00432 00433 } 00434 } 00435 break; 00436 00437 case CILIST_PARSFMT: 00438 /* Preparsed format variable */ 00439 wn1 = cwh_expr_operand(NULL); 00440 if (wn1) 00441 wn_parsfmt = WN_CreateIoItem1 ( IOF_CR_PARSFMT, wn1, NIL ); 00442 break; 00443 00444 case CILIST_REC: 00445 wn1 = cwh_expr_operand(NULL); 00446 if (wn1) 00447 wn_rec = WN_CreateIoItem1 ( IOC_REC, wn1, NIL ); 00448 break; 00449 00450 case CILIST_IOSTAT: 00451 ts = cwh_stk_get_TY(); 00452 wn1 = cwh_expr_address(f_NONE); 00453 if (wn1) { 00454 if (ts != NIL) { 00455 ty = cwh_types_array_TY(ts); 00456 ty = cwh_types_scalar_TY(ty); 00457 } else { 00458 ty = cwh_io_scalar_type(wn1); 00459 } 00460 wn_iostat = WN_CreateIoItem1 ( IOC_IOSTAT, wn1, ty ); 00461 } 00462 break; 00463 case CILIST_END: 00464 case CILIST_ERR: 00465 case CILIST_EOR: 00466 00467 /* if label, mark assigned so not removed by optimizer */ 00468 wn1 = cwh_io_cvt_tos_label_to_wn(TRUE); 00469 if (wn1) { 00470 if (item == CILIST_END) 00471 wn_end = WN_CreateIoItem1 ( IOC_END, wn1, NIL ); 00472 else if (item == CILIST_ERR) 00473 wn_err = WN_CreateIoItem1 ( IOC_ERR, wn1, NIL ); 00474 else if (item == CILIST_EOR) 00475 wn_eor = WN_CreateIoItem1 ( IOC_EOR, wn1, NIL ); 00476 } 00477 break; 00478 00479 case CILIST_UNIT: 00480 switch(cwh_stk_get_class()) { 00481 case STR_item: 00482 00483 cwh_stk_pop_STR(); 00484 wn2 = cwh_expr_operand(NULL); 00485 00486 ts = cwh_stk_get_TY(); 00487 wn1 = cwh_expr_address(f_NONE); 00488 se = cwh_addr_find_section(wn1, p_RETURN_SECTION); 00489 if (se) { 00490 wn1 = cwh_dope_from_expression(wn1, NULL, wn2, ts, NULL); 00491 wn_unit = WN_CreateIoItem2(IOU_DOPE, wn1, 00492 cwh_addr_find_address(se), NIL); 00493 } else { 00494 wn_unit = WN_CreateIoItem2 (IOU_INTERNAL, wn1, wn2, NIL); 00495 } 00496 break ; 00497 00498 default: 00499 00500 /* Push the top item again on the stack and extract it thru 00501 cwh_expr_address. We save the resultant item, in case we 00502 need to use it later, if we happen to be in an encode/decode 00503 statement */ 00504 00505 cwh_stk_push_top_item_again(); 00506 unit_address = cwh_expr_address(f_NONE); 00507 00508 wn1 = cwh_expr_operand(NULL); 00509 if (target_io_library == IOLIB_MIPS) { 00510 if (wn1 == NULL) { 00511 wn1 = WN_CreateIntconst ( OPC_I4INTCONST, 6); 00512 wn_unit = WN_CreateIoItem1 ( IOU_DEFAULT, wn1, NIL ); 00513 } else { 00514 /* Only handle external IO for now */ 00515 wn_unit = WN_CreateIoItem1 ( IOU_EXTERNAL, wn1, NIL); 00516 } 00517 } else { /* Target library is Cray */ 00518 if (wn1 != NULL) { 00519 00520 /* DIMENSION IREC(2) 00521 * ENCODE(8,100,IREC) LREC(K),ICNT,ITAU 00522 * 00523 * The above can cause the code to reach here, with wn1 00524 as an ARRSECTION 00525 */ 00526 00527 se = cwh_addr_find_section(wn1, p_RETURN_SECTION); 00528 if (se) { 00529 ts = cwh_types_WN_TY(se,FALSE); 00530 ts = cwh_types_array_TY(ts); 00531 ty = cwh_types_scalar_TY(ts); 00532 wn1 = cwh_dope_from_expression(wn1, NULL, NULL, ty, 00533 NULL); 00534 wn_unit = WN_CreateIoItem2(IOU_DOPE, wn1, 00535 cwh_addr_find_address(se), NIL); 00536 } else { 00537 wn_unit = WN_CreateIoItem1 ( IOU_EXTERNAL, wn1, NIL ); 00538 ed_unit = WN_CreateIoItem1 ( IOU_EXTERNAL, unit_address, NIL); 00539 } 00540 } else { 00541 wn_unit = WN_CreateIoItem0 ( IOU_NONE, NIL ); 00542 } 00543 } 00544 break; 00545 00546 } 00547 break; 00548 00549 case CILIST_FLFLAG: 00550 wn1 = cwh_expr_operand(NULL); 00551 00552 if (target_io_library == IOLIB_CRAY) 00553 wn_flflag = WN_CreateIoItem1 ( IOC_CR_FLFLAG, wn1, NIL); 00554 break; 00555 00556 case CILIST_EEEFLAG: 00557 /* eeeflag value; 1 if err= specified, 2 if end= specified, 00558 4 if eor= specified, 8 if iostat= specified 00559 */ 00560 wn1 = cwh_expr_operand(NULL); 00561 00562 eeeflag = WN_const_val(wn1); 00563 if (target_io_library == IOLIB_CRAY) 00564 wn_eeeflag = WN_CreateIoItem1 ( IOC_CR_EEEFLAG, wn1, NIL ); 00565 break; 00566 00567 case CILIST_EDFLAG: 00568 /* Version Number */ 00569 wn1 = cwh_expr_operand(NULL); 00570 00571 edflag = WN_const_val(wn1); 00572 wn_edflag = WN_CreateIoItem1(IOC_CR_EDFLAG, wn1, NIL); 00573 /* Ignore */ 00574 break; 00575 00576 } /* Switch */ 00577 } /* for */ 00578 00579 if (edflag != 0 && ed_unit) { 00580 wn_unit = WN_CreateIoItem2 (IOU_INTERNAL, WN_kid0(ed_unit), WN_kid0(wn_edflag), NIL); 00581 STACK_PUSH(wn_unit); 00582 } else { 00583 STACK_PUSH(wn_unit); 00584 } 00585 STACK_PUSH(wn_fmtsrc); 00586 STACK_PUSH(wn_flflag); 00587 STACK_PUSH(wn_parsfmt); 00588 STACK_PUSH(wn_eeeflag); 00589 STACK_PUSH(wn_iostat); 00590 STACK_PUSH(wn_rec); 00591 STACK_PUSH(wn_advance); 00592 STACK_PUSH(wn_size); 00593 STACK_PUSH(wn_edflag); 00594 STACK_PUSH(wn_end); 00595 STACK_PUSH(wn_err); 00596 STACK_PUSH(wn_eor); 00597 } 00598 00599 /*=================================================== 00600 * 00601 * fei_IO_list 00602 * 00603 * Process the iolist items on the stack. For scalars 00604 * just load the value or pass the expression along 00605 * wrapped as an IO_item. For array sections a dope 00606 * vector supplants the OPC_ARRSECTION on the stack. 00607 * 00608 *==================================================== 00609 */ 00610 extern void 00611 fei_IO_list (int num_args, int mode ) 00612 { 00613 int i; 00614 WN *wn; 00615 WN **iolist; 00616 WN *cray_type_code = NULL; 00617 00618 iolist = (WN **) malloc(sizeof (WN *) * num_args); 00619 00620 for (i=0; i < num_args; i++) { 00621 00622 if (!NAMELIST_MODE(mode)) { 00623 cray_type_code = cwh_expr_operand(NULL); 00624 00625 /* Implied do's that have already been processed by fei_implied_do don't 00626 have a type code over them; in this case, we need to push the 00627 item back on the stack, because it is not a cray type code, and 00628 continue with further processing */ 00629 00630 if ((WN_opcode(cray_type_code) == OPC_IO_ITEM) && 00631 (WN_io_item(cray_type_code) == IOL_IMPLIED_DO)) 00632 cwh_stk_push(cray_type_code,WN_item); 00633 } 00634 00635 switch(cwh_stk_get_class()) { 00636 case STR_item : 00637 wn = cwh_io_str_ioitem(IOL_CHAR, mode, cray_type_code); 00638 break ; 00639 00640 default: 00641 wn = cwh_io_ioitem(mode, cray_type_code); 00642 break; 00643 00644 } 00645 iolist[i] = wn; 00646 } 00647 00648 for (i=num_args-1; i >= 0; i--) { 00649 cwh_stk_push(iolist[i], WN_item); 00650 } 00651 00652 num_list_items_last_processed = num_args; 00653 00654 free(iolist); 00655 } 00656 00657 /*=================================================== 00658 * 00659 * fei_formatted_write 00660 * 00661 * Pops all the control items and the list items from 00662 * stack and makes them kids of a IOS_CR_FWF node. 00663 * 00664 *==================================================== 00665 */ 00666 00667 extern void 00668 fei_formatted_write( void ) 00669 { 00670 WN *wn; 00671 BOOL status; 00672 00673 if (target_io_library == IOLIB_MIPS) 00674 wn = cwh_stk_pop_iostmt (IOS_WRITE, eeeflag); 00675 else 00676 wn = cwh_stk_pop_iostmt (IOS_CR_FWF, eeeflag); 00677 00678 if (Use_Three_Call) { 00679 cwh_io_split_io_statement(wn); 00680 } else { 00681 marked_set = NULL; 00682 status = cwh_io_analyse_io_statement(wn, WRITE_STMT); 00683 cwh_io_unmark(); 00684 00685 if (status) { 00686 cwh_io_split_io_statement(wn); 00687 } 00688 00689 cwh_block_append(wn); 00690 } 00691 } 00692 00693 /*=================================================== 00694 * 00695 * fei_formatted_read 00696 * 00697 * Pops all the control items and the list items from 00698 * stack and makes them kids of a IOS_CR_FRF node. 00699 * 00700 *==================================================== 00701 */ 00702 00703 extern void 00704 fei_formatted_read(void) 00705 { 00706 WN *wn; 00707 BOOL status; 00708 00709 wn = cwh_stk_pop_iostmt (IOS_CR_FRF, eeeflag); 00710 00711 if (Use_Three_Call) { 00712 cwh_io_split_io_statement(wn); 00713 } else { 00714 marked_set = NULL; 00715 status = cwh_io_analyse_io_statement(wn, READ_STMT); 00716 cwh_io_unmark(); 00717 00718 #if 0 00719 if (status) { 00720 cwh_io_split_io_statement(wn); 00721 } else { 00722 #endif 00723 cwh_block_append(wn); 00724 // } 00725 } 00726 } 00727 00728 /*=================================================== 00729 * 00730 * fei_unformatted_write 00731 * 00732 * Pops all the control items and the list items from 00733 * stack and makes them kids of a IOS_CR_FWU node. 00734 * 00735 *==================================================== 00736 */ 00737 00738 extern void 00739 fei_unformatted_write(void) 00740 { 00741 WN *wn; 00742 BOOL status; 00743 00744 wn = cwh_stk_pop_iostmt (IOS_CR_FWU, eeeflag); 00745 00746 if (Use_Three_Call) { 00747 cwh_io_split_io_statement(wn); 00748 } else { 00749 marked_set = NULL; 00750 status = cwh_io_analyse_io_statement(wn, WRITE_STMT); 00751 cwh_io_unmark(); 00752 00753 #if 0 00754 if (status) { 00755 cwh_io_split_io_statement(wn); 00756 } else { 00757 #endif 00758 cwh_block_append(wn); 00759 // } 00760 } 00761 } 00762 00763 /*=================================================== 00764 * 00765 * fei_unformatted_read 00766 * 00767 * Pops all the control items and the list items from 00768 * stack and makes them kids of a IOS_CR_FRU node. 00769 * 00770 *==================================================== 00771 */ 00772 00773 extern void 00774 fei_unformatted_read(void) 00775 { 00776 WN *wn; 00777 BOOL status; 00778 00779 wn = cwh_stk_pop_iostmt (IOS_CR_FRU, eeeflag); 00780 00781 if (Use_Three_Call) { 00782 cwh_io_split_io_statement(wn); 00783 } else { 00784 marked_set = NULL; 00785 status = cwh_io_analyse_io_statement(wn, READ_STMT); 00786 cwh_io_unmark(); 00787 00788 if (status) { 00789 cwh_io_split_io_statement(wn); 00790 } else { 00791 cwh_block_append(wn); 00792 } 00793 } 00794 } 00795 00796 /*=================================================== 00797 * 00798 * fei_namelist_write 00799 * 00800 * Pops all the control items and the list items from 00801 * stack and makes them kids of a IOS_CR_FWN node. 00802 * 00803 *==================================================== 00804 */ 00805 00806 extern void 00807 fei_namelist_write(void) 00808 { 00809 WN *wn; 00810 00811 wn = cwh_stk_pop_iostmt (IOS_CR_FWN, eeeflag); 00812 cwh_block_append(wn); 00813 } 00814 00815 /*=================================================== 00816 * 00817 * fei_namelist_read 00818 * 00819 * Pops all the control items and the list items from 00820 * stack and makes them kids of a IOS_CR_FRN node. 00821 * 00822 *==================================================== 00823 */ 00824 00825 extern void 00826 fei_namelist_read(void) 00827 { 00828 WN *wn; 00829 00830 wn = cwh_stk_pop_iostmt (IOS_CR_FRN, eeeflag); 00831 cwh_block_append(wn); 00832 } 00833 00834 /*=================================================== 00835 * 00836 * fei_implied_do 00837 * 00838 * The following are already on the stack: implied_do_var, 00839 * start expr, end expr, incr expr, and the list of items 00840 * to iterate over. It builds an entry for implied do 00841 * out of it. If any of the list items happen to be an 00842 * array element, a dope vector is created out of it, if 00843 * the implied_do_var happens to be part of the array index. 00844 * 00845 *==================================================== 00846 */ 00847 00848 extern void 00849 fei_implied_do(void) 00850 { 00851 WN **iolist; 00852 WN *incr; 00853 WN *stop; 00854 WN *start; 00855 WN *index; 00856 WN *wn; 00857 ST *st; 00858 INT32 num_list_items; 00859 INT32 i, j; 00860 00861 num_list_items = num_list_items_last_processed; 00862 iolist = (WN **) malloc(sizeof (WN *) * num_list_items); 00863 00864 for (i = 0; i < num_list_items; i++) 00865 iolist[i] = cwh_expr_operand(NULL); 00866 00867 incr = cwh_expr_operand(NULL); 00868 00869 stop = cwh_expr_operand(NULL); 00870 00871 start = cwh_expr_operand(NULL); 00872 00873 st = cwh_stk_pop_ST(); 00874 index = WN_CreateIdname(0, st); 00875 00876 wn = WN_CreateIoItemN ( IOL_IMPLIED_DO, num_list_items + 4, NIL); 00877 WN_index(wn) = index; 00878 WN_start(wn) = start; 00879 WN_end(wn) = stop; 00880 WN_step(wn) = incr; 00881 00882 for(i = num_list_items-1, j = 4; i >= 0 ; i--, j++) { 00883 WN_kid(wn,j) = iolist[i]; 00884 } 00885 00886 cwh_stk_push(wn, WN_item); 00887 free (iolist); 00888 } 00889 00890 /*=================================================== 00891 * 00892 * cwh_io_ioitem 00893 * 00894 * A utility routine for non-character scalar 00895 * io items. Load the value TOS & return it as 00896 * WN IO_item. 00897 * 00898 * The only way to distinguish a logical constant 00899 * from an integer is to look a the TY that's pushed 00900 * on the stack (by fei_constant). 00901 00902 * First pop the type code 00903 * 00904 *==================================================== 00905 */ 00906 static WN * 00907 cwh_io_ioitem(int mode, WN *cray_type_code) 00908 { 00909 WN * wn ; 00910 WN * wr ; 00911 TY_IDX ty ; 00912 TY_IDX ts = NIL ; 00913 TY_IDX cray_ptr_ty = NIL; 00914 00915 if (cwh_stk_get_class() == FLD_item) { 00916 ts = cwh_stk_get_FLD_TY(); 00917 } else if (cwh_stk_get_class() == DEREF_item) { 00918 ts = cwh_stk_get_TY(); 00919 if (ts) { 00920 /* Get the type of the item stored from the dope vector */ 00921 ts = TY_pointed(FLD_type(TY_fld(Ty_Table[ts]))); 00922 } 00923 } else if ((cwh_stk_get_class() == ADDR_item) && !NAMELIST_MODE(mode)){ 00924 ts = Be_Type_Tbl(Pointer_type); 00925 if (READ_MODE(mode)) 00926 DevAssert((0),("Received an ADDR item in read mode")); 00927 } else if (cwh_stk_get_class() == ST_item) { 00928 ST *st; 00929 00930 st = cwh_stk_pop_ST(); 00931 00932 if (ST_sclass(st) == SCLASS_FORMAL) { 00933 if ( !ST_is_value_parm(st) && 00934 (TY_kind(TY_pointed(ST_type(st))) == KIND_POINTER)) { 00935 /* This is a cray pointer */ 00936 DevAssert((!ST_is_temp_var(st)), ("Expecting a Cray Pointer")); 00937 cray_ptr_ty = ST_type(st); 00938 } 00939 } else if (TY_kind(ST_type(st)) == KIND_POINTER) { 00940 /* This is a cray pointer */ 00941 DevAssert((!ST_is_temp_var(st)), ("Expecting a Cray Pointer")); 00942 cray_ptr_ty = ST_type(st); 00943 } 00944 cwh_stk_push(st,ST_item); 00945 00946 } else { 00947 ts = cwh_stk_get_TY(); 00948 } 00949 00950 if (NAMELIST_MODE(mode) || READ_MODE(mode)) { 00951 wn = cwh_expr_address(f_NONE); 00952 } else { 00953 wn = cwh_expr_operand(NULL); 00954 } 00955 00956 if (cray_ptr_ty != NIL) { 00957 ty = cray_ptr_ty; 00958 } else if (ts != NIL) { 00959 ty = cwh_types_array_TY(ts); 00960 ty = cwh_types_scalar_TY(ty); 00961 } else { 00962 ty = cwh_types_WN_TY(wn,FALSE); 00963 ty = cwh_types_array_TY(ty); 00964 ty = cwh_types_scalar_TY(ty); 00965 } 00966 00967 if ((WN_opcode(wn) == OPC_IO_ITEM) && (WN_io_item(wn) == IOL_IMPLIED_DO)) 00968 return wn; 00969 00970 00971 if (NAMELIST_MODE(mode)) { 00972 wr = WN_CreateIoItem1 ( IOL_VAR, wn, ty); 00973 } else if (READ_MODE(mode)) { 00974 wr = WN_CreateIoItem2 ( IOL_VAR, wn, cray_type_code, ty); 00975 } else { 00976 wr = WN_CreateIoItem2 ( IOL_EXPR, wn, cray_type_code, ty); 00977 } 00978 return (wr); 00979 } 00980 00981 /*=================================================== 00982 * 00983 * cwh_io_str_ioitem 00984 * 00985 * A utility routine for character scalar 00986 * io items. Load the value TOS & return it as 00987 * WN IO_item. If it's an array section, it needs 00988 * a dope vector, otherwise it's just a 2 element item 00989 * 00990 *==================================================== 00991 */ 00992 static WN * 00993 cwh_io_str_ioitem(IOITEM it, int mode, WN *craytype) 00994 { 00995 WN * wn2 ; 00996 WN * wn ; 00997 00998 cwh_stk_pop_STR(); 00999 01000 wn2 = cwh_expr_operand(NULL); 01001 wn = cwh_io_char_ioitem(it,wn2, mode, craytype); 01002 01003 return(wn); 01004 } 01005 /*=================================================== 01006 * 01007 * cwh_io_char_ioitem 01008 * 01009 * create an item of the given kind with the address 01010 * of the string on TOS and its length passed. 01011 * 01012 *==================================================== 01013 */ 01014 static WN * 01015 cwh_io_char_ioitem(IOITEM it, WN *len, int mode, WN *craytype) 01016 { 01017 WN * wn ; 01018 TY_IDX ty ; 01019 01020 ty = cwh_stk_get_TY(); 01021 01022 wn = cwh_expr_address(f_NONE); 01023 01024 if (cwh_addr_find_section(wn, p_RETURN_SECTION)) { 01025 wn = WN_CreateIoItem3 (IOL_DOPE, wn, craytype, len, ty ); 01026 return wn; 01027 } 01028 01029 wn = WN_CreateIoItem3 (it, wn, craytype, len, ty); 01030 01031 return (wn); 01032 } 01033 01034 /*=================================================== 01035 * 01036 * fei_iolength 01037 * 01038 * Handles inquire(iolength=len) <iolist> 01039 * 01040 * The iolist is assumed to have gone through an fei_IO_list 01041 * interface. Also on the stack is a constant which represents 01042 * the first last flag. 01043 * 01044 *==================================================== 01045 */ 01046 01047 extern void 01048 fei_iolength(void) 01049 { 01050 INT32 num_items; 01051 INT32 i, j; 01052 WN *item; 01053 WN *wn; 01054 WN *wn1; 01055 ST *st; 01056 WN *temp; 01057 BOOL status; 01058 01059 num_items = cwh_stk_get_num_inquire_items(); 01060 wn = WN_CreateIo ( IOS_INQLENGTH, num_items + 4); 01061 01062 /* Kids 1 and 2 are passed because for every IO sttaement 01063 the IO lowerer expects that the first kid is a UNIT, 01064 and the second a format; it just satisfies this requirement 01065 of the io lowerer and then ignored. 01066 */ 01067 01068 WN_kid0(wn) = WN_CreateIoItem0 ( IOU_NONE, NIL ); 01069 WN_kid1(wn) = WN_CreateIoItem0 ( IOF_NONE, NIL ); 01070 for (i=0, j = 4+num_items-1; i<num_items; i++, j--) { 01071 item = cwh_expr_operand(NULL); 01072 WN_kid(wn,j) = item; 01073 } 01074 wn1 = cwh_expr_operand(NULL); 01075 WN_kid(wn,2) = WN_CreateIoItem1 ( IOC_CR_FLFLAG, wn1, NIL); 01076 01077 st = cwh_stk_pop_ST(); 01078 cwh_stk_push(st, ST_item); 01079 wn1 = cwh_expr_address(f_NONE); 01080 WN_kid(wn,3) = WN_CreateIoItem1(IOC_INQLENGTH_VAR, wn1, NIL); 01081 01082 /* The following is just to fool the subsequent fei_store call; 01083 We make it store the inqlength var into itself. The var has 01084 already been passed to the io lowerer and it makes sure that 01085 the value returned by _INQIL is stored into this var. 01086 */ 01087 01088 cwh_stk_push(st, ST_item); 01089 temp = cwh_expr_operand(NULL); 01090 01091 cwh_stk_push(st, ST_item); 01092 cwh_stk_push(temp,WN_item); 01093 01094 if (Use_Three_Call) { 01095 cwh_io_split_io_statement(wn); 01096 } else { 01097 marked_set = NULL; 01098 status = cwh_io_analyse_io_statement(wn, WRITE_STMT); 01099 cwh_io_unmark(); 01100 01101 if (status) { 01102 cwh_io_split_io_statement(wn); 01103 } else { 01104 cwh_block_append(wn); 01105 } 01106 } 01107 01108 } 01109 01110 /*=================================================== 01111 * 01112 * fei_start_ioblock 01113 * 01114 * Mark the beginning of the translation for an IO statement with 01115 * two comments: First, with the user's original IO statement, and 01116 * the second with just "START_IO". Also add a pragma, to prevent 01117 * region processing from splitting IO statements. 01118 * 01119 *==================================================== 01120 */ 01121 01122 extern void 01123 fei_start_ioblock(void) 01124 { 01125 char *str; 01126 TCON tc; 01127 ST *st; 01128 WN *wn; 01129 01130 cwh_stk_pop_STR(); 01131 cwh_stk_pop_whatever(); 01132 st = cwh_stk_pop_ST(); 01133 ++cwh_io_in_ioblock; 01134 01135 if (IO_Comments) { 01136 tc = STC_val(st); 01137 str = Targ_String_Address(tc); 01138 wn = WN_CreateComment(str); 01139 cwh_auxst_clear(WN_st(wn)); 01140 cwh_block_append(wn); 01141 01142 # if 0 01143 str = (char *) malloc(9*sizeof(char)); 01144 strcpy(str, "START_IO"); 01145 wn = WN_CreateComment(str); 01146 cwh_auxst_clear(WN_st(wn)); 01147 cwh_block_append(wn); 01148 free(str); 01149 # endif 01150 01151 } 01152 wn = WN_CreatePragma(WN_PRAGMA_START_STMT_CLUMP, (ST *) NIL, NIL,NIL); 01153 cwh_block_append(wn); 01154 01155 } 01156 01157 /*=================================================== 01158 * 01159 * fei_start_ioblock 01160 * 01161 * Mark the end of the translation for this IO statement 01162 * with the comment "END_IO" 01163 * 01164 *==================================================== 01165 */ 01166 01167 extern void 01168 fei_end_ioblock(void) 01169 { 01170 char *str; 01171 WN *wn; 01172 01173 wn = WN_CreatePragma(WN_PRAGMA_END_STMT_CLUMP, (ST *) NIL, NIL,NIL); 01174 cwh_block_append(wn); 01175 01176 --cwh_io_in_ioblock; 01177 # if 0 01178 if (IO_Comments) { 01179 str = (char *) malloc(7*sizeof(char)); 01180 strcpy(str, "END_IO"); 01181 wn = WN_CreateComment(str); 01182 cwh_auxst_clear(WN_st(wn)); 01183 cwh_block_append(wn); 01184 free(str); 01185 } 01186 # endif 01187 } 01188 01189 /*================================================================ 01190 * 01191 * static BOOL cwh_io_null_address(WN * addr) 01192 * 01193 * return TRUE if the addr node is a NULL pointer (constant 0) 01194 * also deletes the pointer. 01195 * 01196 *================================================================ 01197 */ 01198 static BOOL cwh_io_null_address(WN *addr) 01199 { 01200 if (WN_operator(addr) == OPR_INTCONST && 01201 WN_const_val(addr) == 0) { 01202 WN_Delete(addr); 01203 return (TRUE); 01204 } 01205 01206 return (FALSE); 01207 } 01208 01209 /*=================================================== 01210 * 01211 * fei_open 01212 * 01213 * Handles the F90 open statement 01214 * 01215 *==================================================== 01216 */ 01217 01218 void 01219 fei_open(void) 01220 { 01221 INT item; 01222 WN **open_list; 01223 WN *wn; 01224 WN *length; 01225 WN *addr; 01226 WN *unit= NULL; 01227 TY_IDX ty = NIL; 01228 INT32 num_items = 0; 01229 INT32 i,j; 01230 TY_IDX ts = NIL; 01231 01232 open_list = (WN **) malloc(sizeof (WN *) * 15); 01233 01234 for (item=OPEN_ERR; item >= OPEN_CALLNAME; item--) { 01235 switch (item) { 01236 01237 case OPEN_ERR: 01238 addr = cwh_io_cvt_tos_label_to_wn(FALSE); 01239 if (addr != NULL) { 01240 wn = WN_CreateIoItem1(IOC_ERR, addr, NIL); 01241 open_list[num_items++] = wn; 01242 } 01243 break; 01244 01245 case OPEN_PAD: 01246 case OPEN_DELIM: 01247 case OPEN_ACTION: 01248 case OPEN_POSITION: 01249 case OPEN_BLANK: 01250 case OPEN_FORM: 01251 case OPEN_ACCESS: 01252 case OPEN_STATUS: 01253 case OPEN_FILE: 01254 switch(cwh_stk_get_class()) { 01255 case STR_item: 01256 cwh_stk_pop_STR(); 01257 length = cwh_expr_operand(NULL); 01258 01259 addr = cwh_expr_address(f_NONE); 01260 01261 if (item == OPEN_PAD) 01262 wn = WN_CreateIoItem2 (IOC_PAD, addr, length, NIL); 01263 else if (item == OPEN_DELIM) 01264 wn = WN_CreateIoItem2 (IOC_DELIM, addr, length, NIL); 01265 else if (item == OPEN_ACTION) 01266 wn = WN_CreateIoItem2 (IOC_ACTION, addr, length, NIL); 01267 else if (item == OPEN_POSITION) 01268 wn = WN_CreateIoItem2 (IOC_POSITION, addr, length, NIL); 01269 else if (item == OPEN_BLANK) 01270 wn = WN_CreateIoItem2 (IOC_BLANK, addr, length, NIL); 01271 else if (item == OPEN_FORM) 01272 wn = WN_CreateIoItem2 (IOC_FORM, addr, length, NIL); 01273 else if (item == OPEN_ACCESS) 01274 wn = WN_CreateIoItem2 (IOC_ACCESS, addr, length, NIL); 01275 else if (item == OPEN_STATUS) 01276 wn = WN_CreateIoItem2 (IOC_STATUS, addr, length, NIL); 01277 else if (item == OPEN_FILE) 01278 wn = WN_CreateIoItem2 (IOC_FILE, addr, length, NIL); 01279 01280 open_list[num_items++] = wn; 01281 break; 01282 default: 01283 cwh_stk_pop_whatever(); 01284 break; 01285 } 01286 break; 01287 01288 case OPEN_RECL: 01289 case OPEN_IOSTAT: 01290 case OPEN_UNIT: 01291 ts = cwh_stk_get_TY(); 01292 switch(cwh_stk_get_class()) { 01293 case ADDR_item: 01294 01295 addr = cwh_expr_address(f_NONE); 01296 if (cwh_io_null_address(addr)) break; 01297 01298 if (ts != NIL) { 01299 ty = cwh_types_array_TY(ts); 01300 ty = cwh_types_scalar_TY(ty); 01301 } else { 01302 ty = cwh_io_scalar_type(addr); 01303 } 01304 01305 if (item == OPEN_RECL) 01306 wn = WN_CreateIoItem1(IOC_RECL, addr, ty); 01307 else if (item == OPEN_IOSTAT) 01308 wn = WN_CreateIoItem1(IOC_IOSTAT, addr, ty); 01309 else if (item == OPEN_UNIT) 01310 unit = WN_CreateIoItem1(IOU_EXTERNAL, addr, NIL); 01311 01312 if (item != OPEN_UNIT) 01313 open_list[num_items++] = wn; 01314 break; 01315 01316 case ST_item: 01317 wn = cwh_addr_address_ST(cwh_stk_pop_ST()); 01318 if (item == OPEN_RECL) 01319 wn = WN_CreateIoItem1(IOC_RECL, wn, ts); 01320 else if (item == OPEN_IOSTAT) 01321 wn = WN_CreateIoItem1(IOC_IOSTAT, wn, ts); 01322 else if (item == OPEN_UNIT) 01323 unit = WN_CreateIoItem1(IOU_EXTERNAL, wn, NIL); 01324 01325 if (item != OPEN_UNIT) 01326 open_list[num_items++] = wn; 01327 break; 01328 01329 case WN_item: 01330 case FLD_item: 01331 wn = cwh_expr_operand(NULL); 01332 if (wn !=NULL) { 01333 if (item == OPEN_RECL) 01334 wn = WN_CreateIoItem1(IOC_RECL, wn, ts); 01335 else if (item == OPEN_IOSTAT) 01336 wn = WN_CreateIoItem1(IOC_IOSTAT, wn, ts); 01337 else if (item == OPEN_UNIT) 01338 unit = WN_CreateIoItem1(IOU_EXTERNAL, wn, NIL); 01339 01340 if (item != OPEN_UNIT) 01341 open_list[num_items++] = wn; 01342 } 01343 01344 break; 01345 01346 default: 01347 cwh_stk_pop_whatever(); 01348 break; 01349 } 01350 break; 01351 01352 case OPEN_ERRFLAG: 01353 switch(cwh_stk_get_class()) { 01354 case ADDR_item: 01355 case WN_item: 01356 case WN_item_whole_array: 01357 wn = cwh_expr_operand(NULL); 01358 if (wn!=NULL) { 01359 wn = WN_CreateIoItem1(IOC_ERRFLAG, wn, NIL); 01360 open_list[num_items++] = wn; 01361 } 01362 break; 01363 01364 default: 01365 DevAssert((0),("Odd Open Item")); 01366 cwh_stk_pop_whatever(); 01367 break; 01368 } 01369 break; 01370 01371 case OPEN_VERSION: 01372 case OPEN_CALLNAME: 01373 cwh_stk_pop_whatever(); /* ignore */ 01374 break; 01375 } 01376 } 01377 01378 wn = WN_CreateIo (IOS_CR_OPEN, num_items + 2); 01379 01380 if (unit) 01381 WN_kid0(wn) = unit; 01382 else 01383 WN_kid0(wn) = WN_CreateIoItem0 ( IOU_NONE, NIL ); 01384 01385 WN_kid1(wn) = WN_CreateIoItem0 ( IOF_NONE, NIL ); 01386 for(i=0,j=2; i<num_items; i++,j++) 01387 WN_kid(wn,j) = open_list[i]; 01388 cwh_block_append(wn); 01389 01390 free(open_list); 01391 01392 } 01393 01394 /*=================================================== 01395 * 01396 * fei_inquire 01397 * 01398 * Handles the F90 inquire statement 01399 * 01400 *==================================================== 01401 */ 01402 01403 void 01404 fei_inquire(void) 01405 { 01406 INT item; 01407 WN **inq_list; 01408 WN *wn; 01409 WN *length; 01410 WN *addr; 01411 WN *unit= NULL; 01412 INT32 num_items = 0; 01413 INT32 i,j; 01414 TY_IDX ts = NIL; 01415 ST *st; 01416 01417 inq_list = (WN **) malloc(sizeof (WN *) * 27); 01418 01419 for (item=INQ_ERR; item >= INQ_CALLNAME; item--) { 01420 switch (item) { 01421 01422 case INQ_ERR: 01423 01424 addr = cwh_io_cvt_tos_label_to_wn(FALSE); 01425 01426 if (addr != NULL) { 01427 wn = WN_CreateIoItem1(IOC_ERR, addr, NIL); 01428 inq_list[num_items++] = wn; 01429 } 01430 break; 01431 01432 case INQ_PAD: 01433 case INQ_DELIM: 01434 case INQ_READWRITE: 01435 case INQ_WRITE: 01436 case INQ_READ: 01437 case INQ_ACTION: 01438 case INQ_POSITION: 01439 case INQ_BLANK: 01440 case INQ_UNFORMATTED: 01441 case INQ_FORMATTED: 01442 case INQ_FORM: 01443 case INQ_DIRECT: 01444 case INQ_SEQUENTIAL: 01445 case INQ_ACCESS: 01446 case INQ_NAME: 01447 case INQ_FILE: 01448 switch(cwh_stk_get_class()) { 01449 case STR_item: 01450 cwh_stk_pop_STR(); 01451 length = cwh_expr_operand(NULL); 01452 01453 addr = cwh_expr_address(f_NONE); 01454 01455 if (item == INQ_PAD) 01456 wn = WN_CreateIoItem2 (IOC_PAD, addr, length, NIL); 01457 else if (item == INQ_DELIM) 01458 wn = WN_CreateIoItem2 (IOC_DELIM, addr, length, NIL); 01459 else if (item == INQ_READWRITE) 01460 wn = WN_CreateIoItem2 (IOC_READWRITE, addr, length, NIL); 01461 else if (item == INQ_WRITE) 01462 wn = WN_CreateIoItem2 (IOC_WRITE, addr, length, NIL); 01463 else if (item == INQ_READ) 01464 wn = WN_CreateIoItem2 (IOC_READ, addr, length, NIL); 01465 else if (item == INQ_ACTION) 01466 wn = WN_CreateIoItem2 (IOC_ACTION, addr, length, NIL); 01467 else if (item == INQ_POSITION) 01468 wn = WN_CreateIoItem2 (IOC_POSITION, addr, length, NIL); 01469 else if (item == INQ_BLANK) 01470 wn = WN_CreateIoItem2 (IOC_BLANK, addr, length, NIL); 01471 else if (item == INQ_UNFORMATTED) 01472 wn = WN_CreateIoItem2 (IOC_UNFORMATTED, addr, length, NIL); 01473 else if (item == INQ_FORMATTED) 01474 wn = WN_CreateIoItem2 (IOC_FORMATTED, addr, length, NIL); 01475 else if (item == INQ_FORM) 01476 wn = WN_CreateIoItem2 (IOC_FORM, addr, length, NIL); 01477 else if (item == INQ_DIRECT) 01478 wn = WN_CreateIoItem2 (IOC_DIRECT, addr, length, NIL); 01479 else if (item == INQ_SEQUENTIAL) 01480 wn = WN_CreateIoItem2 (IOC_SEQUENTIAL, addr, length, NIL); 01481 else if (item == INQ_ACCESS) 01482 wn = WN_CreateIoItem2 (IOC_ACCESS, addr, length, NIL); 01483 else if (item == INQ_NAME) 01484 wn = WN_CreateIoItem2 (IOC_NAME, addr, length, NIL); 01485 else if (item == INQ_FILE) 01486 wn = WN_CreateIoItem2 (IOC_FILE, addr, length, NIL); 01487 01488 inq_list[num_items++] = wn; 01489 break; 01490 /*we need add ST_item here fzhao*/ 01491 case ST_item: 01492 st = cwh_stk_pop_ST(); 01493 wn = cwh_addr_address_ST(st); 01494 if (item == INQ_PAD) 01495 wn = WN_CreateIoItem1 (IOC_PAD, wn, NIL); 01496 else if (item == INQ_DELIM) 01497 wn = WN_CreateIoItem1 (IOC_DELIM, wn, NIL); 01498 else if (item == INQ_READWRITE) 01499 wn = WN_CreateIoItem1 (IOC_READWRITE, wn, NIL); 01500 else if (item == INQ_WRITE) 01501 wn = WN_CreateIoItem1 (IOC_WRITE, wn, NIL); 01502 else if (item == INQ_READ) 01503 wn = WN_CreateIoItem1 (IOC_READ, wn, NIL); 01504 else if (item == INQ_ACTION) 01505 wn = WN_CreateIoItem1 (IOC_ACTION, wn, NIL); 01506 else if (item == INQ_POSITION) 01507 wn = WN_CreateIoItem1 (IOC_POSITION, wn, NIL); 01508 else if (item == INQ_BLANK) 01509 wn = WN_CreateIoItem1 (IOC_BLANK, wn, NIL); 01510 else if (item == INQ_UNFORMATTED) 01511 wn = WN_CreateIoItem1 (IOC_UNFORMATTED, wn, NIL); 01512 else if (item == INQ_FORMATTED) 01513 wn = WN_CreateIoItem1 (IOC_FORMATTED, wn, NIL); 01514 else if (item == INQ_FORM) 01515 wn = WN_CreateIoItem1 (IOC_FORM, wn, NIL); 01516 else if (item == INQ_DIRECT) 01517 wn = WN_CreateIoItem1 (IOC_DIRECT, wn, NIL); 01518 else if (item == INQ_SEQUENTIAL) 01519 wn = WN_CreateIoItem1 (IOC_SEQUENTIAL, wn, NIL); 01520 else if (item == INQ_ACCESS) 01521 wn = WN_CreateIoItem1 (IOC_ACCESS, wn, NIL); 01522 else if (item == INQ_NAME) 01523 wn = WN_CreateIoItem1 (IOC_NAME, wn, NIL); 01524 else if (item == INQ_FILE) 01525 wn = WN_CreateIoItem1(IOC_FILE, wn, NIL); 01526 01527 inq_list[num_items++] = wn; 01528 01529 default: 01530 cwh_stk_pop_whatever(); 01531 break; 01532 } 01533 break; 01534 01535 case INQ_NEXTREC: 01536 case INQ_RECL: 01537 case INQ_NAMED: 01538 case INQ_NUMBER: 01539 case INQ_OPENED: 01540 case INQ_EXIST: 01541 case INQ_IOSTAT: 01542 case INQ_UNIT: 01543 01544 ts = cwh_stk_get_TY(); 01545 switch(cwh_stk_get_class()) { 01546 TY_IDX ty; 01547 01548 case ADDR_item: 01549 addr = cwh_expr_address(f_NONE); 01550 if (cwh_io_null_address(addr)) break; 01551 01552 if (ts != NIL) { 01553 ty = cwh_types_array_TY(ts); 01554 ty = cwh_types_scalar_TY(ty); 01555 } else { 01556 ty = cwh_io_scalar_type(addr); 01557 } 01558 01559 if (item == INQ_NEXTREC) 01560 wn = WN_CreateIoItem1(IOC_NEXTREC, addr, ty); 01561 else if (item == INQ_RECL) 01562 wn = WN_CreateIoItem1(IOC_RECL, addr, ty); 01563 else if (item == INQ_NAMED) 01564 wn = WN_CreateIoItem1(IOC_NAMED, addr, ty); 01565 else if (item == INQ_NUMBER) 01566 wn = WN_CreateIoItem1(IOC_NUMBER, addr, ty); 01567 else if (item == INQ_OPENED) 01568 wn = WN_CreateIoItem1(IOC_OPENED, addr, ty); 01569 else if (item == INQ_EXIST) 01570 wn = WN_CreateIoItem1(IOC_EXIST, addr, ty); 01571 else if (item == INQ_IOSTAT) 01572 wn = WN_CreateIoItem1(IOC_IOSTAT, addr, ty); 01573 else if (item == INQ_UNIT) 01574 unit = WN_CreateIoItem1(IOU_EXTERNAL, addr, NIL); 01575 01576 if (item != INQ_UNIT) 01577 inq_list[num_items++] = wn; 01578 break; 01579 01580 case ST_item: 01581 wn = cwh_addr_address_ST(cwh_stk_pop_ST()); 01582 if (item == INQ_NEXTREC) 01583 wn = WN_CreateIoItem1(IOC_NEXTREC, wn, NIL); 01584 else if (item == INQ_RECL) 01585 wn = WN_CreateIoItem1(IOC_RECL, wn, NIL); 01586 else if (item == INQ_NAMED) 01587 wn = WN_CreateIoItem1(IOC_NAMED, wn, NIL); 01588 else if (item == INQ_NUMBER) 01589 wn = WN_CreateIoItem1(IOC_NUMBER, wn, NIL); 01590 else if (item == INQ_OPENED) 01591 wn = WN_CreateIoItem1(IOC_OPENED, wn, NIL); 01592 else if (item == INQ_EXIST) 01593 wn = WN_CreateIoItem1(IOC_EXIST, wn, NIL); 01594 else if (item == INQ_IOSTAT) 01595 wn = WN_CreateIoItem1(IOC_IOSTAT, wn, NIL); 01596 else if (item == INQ_UNIT) 01597 unit = WN_CreateIoItem1(IOU_EXTERNAL, wn, NIL); 01598 01599 if (item != INQ_UNIT) 01600 inq_list[num_items++] = wn; 01601 break; 01602 01603 case WN_item: 01604 01605 if (item==INQ_UNIT){ 01606 wn = cwh_expr_operand(NULL); 01607 if (wn!=NULL) 01608 unit = WN_CreateIoItem1(IOU_EXTERNAL,wn,NIL); 01609 } 01610 else 01611 cwh_stk_pop_whatever(); 01612 01613 break; 01614 01615 default: 01616 cwh_stk_pop_whatever(); 01617 break; 01618 } 01619 break; 01620 01621 case INQ_ERRFLAG: 01622 switch(cwh_stk_get_class()) { 01623 case ADDR_item: 01624 case WN_item: 01625 case WN_item_whole_array: 01626 wn = cwh_expr_operand(NULL); 01627 if (wn != NULL) { 01628 wn = WN_CreateIoItem1(IOC_ERRFLAG, wn, NIL); 01629 inq_list[num_items++] = wn; 01630 } 01631 01632 break; 01633 default: 01634 DevAssert((0),("Odd Inquire Item")); 01635 cwh_stk_pop_whatever(); 01636 break; 01637 } 01638 01639 break; 01640 case INQ_VERSION: 01641 case INQ_CALLNAME: 01642 cwh_stk_pop_whatever(); /* ignore */ 01643 break; 01644 } 01645 } 01646 01647 wn = WN_CreateIo (IOS_CR_INQUIRE, num_items + 2); 01648 01649 if (unit) 01650 WN_kid0(wn) = unit; 01651 else 01652 WN_kid0(wn) = WN_CreateIoItem0 ( IOU_NONE, NIL ); 01653 01654 WN_kid1(wn) = WN_CreateIoItem0 ( IOF_NONE, NIL ); 01655 for(i=0,j=2; i<num_items; i++,j++) 01656 WN_kid(wn,j) = inq_list[i]; 01657 cwh_block_append(wn); 01658 01659 free(inq_list); 01660 } 01661 01662 /*=================================================== 01663 * 01664 * fei_close 01665 * 01666 * Handles the F90 close statement 01667 * 01668 *==================================================== 01669 */ 01670 01671 void 01672 fei_close(void) 01673 { 01674 INT item; 01675 WN **close_list; 01676 WN *wn; 01677 WN *length; 01678 WN *addr; 01679 WN *unit= NULL; 01680 INT32 num_items = 0; 01681 INT32 i,j; 01682 TY_IDX ts = NIL; 01683 01684 close_list = (WN **) malloc(sizeof (WN *) * 6); 01685 01686 for (item=CLOSE_ERR; item >= CLOSE_CALLNAME; item--) { 01687 switch (item) { 01688 01689 case CLOSE_ERR: 01690 01691 addr = cwh_io_cvt_tos_label_to_wn(FALSE); 01692 01693 if (addr != NULL) { 01694 wn = WN_CreateIoItem1(IOC_ERR, addr, NIL); 01695 close_list[num_items++] = wn; 01696 } 01697 break; 01698 01699 case CLOSE_STATUS: 01700 switch(cwh_stk_get_class()) { 01701 case STR_item: 01702 cwh_stk_pop_STR(); 01703 length = cwh_expr_operand(NULL); 01704 01705 addr = cwh_expr_address(f_NONE); 01706 wn = WN_CreateIoItem2 (IOC_STATUS, addr, length, NIL); 01707 close_list[num_items++] = wn; 01708 break; 01709 default: 01710 cwh_stk_pop_whatever(); 01711 break; 01712 } 01713 break; 01714 01715 01716 case CLOSE_IOSTAT: 01717 case CLOSE_UNIT: 01718 01719 ts = cwh_stk_get_TY(); 01720 01721 switch(cwh_stk_get_class()) { 01722 TY_IDX ty; 01723 01724 case ADDR_item: 01725 addr = cwh_expr_address(f_NONE); 01726 if (cwh_io_null_address(addr)) break; 01727 01728 if (ts != NIL) { 01729 ty = cwh_types_array_TY(ts); 01730 ty = cwh_types_scalar_TY(ty); 01731 } else { 01732 ty = cwh_io_scalar_type(addr); 01733 } 01734 if (item == CLOSE_IOSTAT) 01735 wn = WN_CreateIoItem1(IOC_IOSTAT, addr, ty); 01736 else if (item == CLOSE_UNIT) 01737 unit = WN_CreateIoItem1(IOU_EXTERNAL, addr, NIL); 01738 01739 if (item != CLOSE_UNIT) 01740 close_list[num_items++] = wn; 01741 01742 break; 01743 01744 case WN_item: 01745 wn = cwh_expr_operand(NULL); 01746 01747 if (wn!=NULL) { 01748 if (item == CLOSE_IOSTAT) 01749 wn = WN_CreateIoItem1(IOC_IOSTAT,wn,ts); 01750 else if (item == CLOSE_UNIT) 01751 unit = WN_CreateIoItem1(IOU_EXTERNAL, wn,NIL); 01752 01753 if (item != CLOSE_UNIT) 01754 close_list[num_items++] = wn; 01755 } 01756 01757 break; 01758 01759 case ST_item: 01760 wn = cwh_addr_address_ST(cwh_stk_pop_ST()); 01761 01762 if (item == CLOSE_IOSTAT) 01763 wn = WN_CreateIoItem1(IOC_IOSTAT,wn,ts); 01764 else if (item == CLOSE_UNIT) 01765 unit = WN_CreateIoItem1(IOU_EXTERNAL, wn, NIL); 01766 01767 if (item != CLOSE_UNIT) 01768 close_list[num_items++] = wn; 01769 01770 break; 01771 default: 01772 cwh_stk_pop_whatever(); 01773 break; 01774 } 01775 break; 01776 01777 case CLOSE_ERRFLAG: 01778 switch(cwh_stk_get_class()) { 01779 case ADDR_item: 01780 case WN_item: 01781 case WN_item_whole_array: 01782 wn = cwh_expr_operand(NULL); 01783 01784 if (wn !=NULL) { 01785 wn = WN_CreateIoItem1(IOC_ERRFLAG, wn, NIL); 01786 close_list[num_items++] = wn; 01787 } 01788 break; 01789 default: 01790 DevAssert((0),("Odd Close Item")); 01791 cwh_stk_pop_whatever(); 01792 break; 01793 01794 } 01795 break; 01796 01797 case CLOSE_VERSION: 01798 case CLOSE_CALLNAME: 01799 cwh_stk_pop_whatever(); /* ignore */ 01800 break; 01801 } 01802 } 01803 01804 wn = WN_CreateIo (IOS_CR_CLOSE, num_items + 2); 01805 01806 if (unit) 01807 WN_kid0(wn) = unit; 01808 else 01809 WN_kid0(wn) = WN_CreateIoItem0 ( IOU_NONE, NIL ); 01810 01811 WN_kid1(wn) = WN_CreateIoItem0 ( IOF_NONE, NIL ); 01812 for(i=0,j=2; i<num_items; i++,j++) 01813 WN_kid(wn,j) = close_list[i]; 01814 cwh_block_append(wn); 01815 01816 free(close_list); 01817 } 01818 01819 01820 /*=================================================== 01821 * 01822 * cwh_io_no_desc 01823 * 01824 * Handles rewind, backspace and endfile 01825 * 01826 *==================================================== 01827 */ 01828 01829 static void 01830 cwh_io_no_desc(IOSTATEMENT statement) 01831 { 01832 INT item; 01833 WN **nodesc_list; 01834 WN *wn; 01835 WN *addr; 01836 WN *unit= NULL; 01837 INT32 num_items = 0; 01838 INT32 i,j; 01839 TY_IDX ts = NIL; 01840 01841 nodesc_list = (WN **) malloc(sizeof (WN *) * 6); 01842 01843 for (item=NODESC_ERR; item >= NODESC_CALLNAME; item--) { 01844 switch (item) { 01845 01846 case NODESC_ERR: 01847 01848 addr = cwh_io_cvt_tos_label_to_wn(FALSE); 01849 if (addr != NULL) { 01850 wn = WN_CreateIoItem1(IOC_ERR, addr, NIL); 01851 nodesc_list[num_items++] = wn; 01852 } 01853 break; 01854 01855 case NODESC_IOSTAT: 01856 case NODESC_UNIT: 01857 01858 ts = cwh_stk_get_TY(); 01859 switch(cwh_stk_get_class()) { 01860 TY_IDX ty; 01861 01862 case ADDR_item: 01863 01864 addr = cwh_expr_address(f_NONE); 01865 if (cwh_io_null_address(addr)) break; 01866 01867 if (ts != NIL) { 01868 ty = cwh_types_array_TY(ts); 01869 ty = cwh_types_scalar_TY(ty); 01870 } else { 01871 ty = cwh_io_scalar_type(addr); 01872 } 01873 01874 if (item == NODESC_IOSTAT) 01875 wn = WN_CreateIoItem1(IOC_IOSTAT, addr, ty); 01876 else if (item == NODESC_UNIT) 01877 unit = WN_CreateIoItem1(IOU_EXTERNAL, addr, NIL); 01878 01879 if (item != NODESC_UNIT) 01880 nodesc_list[num_items++] = wn; 01881 break; 01882 01883 case WN_item: 01884 wn = cwh_expr_operand(NULL); 01885 01886 if (wn!=NULL){ 01887 if (item == NODESC_IOSTAT) 01888 wn = WN_CreateIoItem1(IOC_IOSTAT, wn, NIL); 01889 else if (item == NODESC_UNIT) 01890 unit = WN_CreateIoItem1(IOU_EXTERNAL, wn, NIL); 01891 if (item != NODESC_UNIT) 01892 nodesc_list[num_items++] = wn; 01893 01894 } 01895 break; 01896 01897 case ST_item: 01898 wn = cwh_addr_address_ST(cwh_stk_pop_ST()); 01899 if (wn!=NULL){ 01900 if (item == NODESC_IOSTAT) 01901 wn = WN_CreateIoItem1(IOC_IOSTAT, wn, NIL); 01902 else if (item == NODESC_UNIT) 01903 unit = WN_CreateIoItem1(IOU_EXTERNAL, wn, NIL); 01904 if (item != NODESC_UNIT) 01905 nodesc_list[num_items++] = wn; 01906 01907 } 01908 01909 break; 01910 01911 default: 01912 cwh_stk_pop_whatever(); 01913 break; 01914 } 01915 break; 01916 01917 case NODESC_ERRFLAG: 01918 switch(cwh_stk_get_class()) { 01919 case ADDR_item: 01920 case WN_item: 01921 case WN_item_whole_array: 01922 wn = cwh_expr_operand(DELETE_ARRAYEXP_WN); 01923 if (wn !=NULL) { 01924 wn = WN_CreateIoItem1(IOC_ERRFLAG, wn, NIL); 01925 nodesc_list[num_items++] = wn; 01926 } 01927 01928 break; 01929 default: 01930 DevAssert((0),("Odd Close Item")); 01931 cwh_stk_pop_whatever(); 01932 break; 01933 01934 } 01935 break; 01936 01937 case NODESC_CALLNAME: 01938 cwh_stk_pop_whatever(); /* ignore */ 01939 break; 01940 } 01941 } 01942 01943 if (statement == IOS_CR_REWIND) 01944 wn = WN_CreateIo (IOS_CR_REWIND, num_items + 2); 01945 else if (statement == IOS_CR_BACKSPACE) 01946 wn = WN_CreateIo (IOS_CR_BACKSPACE, num_items + 2); 01947 else if (statement == IOS_CR_ENDFILE) 01948 wn = WN_CreateIo (IOS_CR_ENDFILE, num_items + 2); 01949 01950 if (unit) 01951 WN_kid0(wn) = unit; 01952 else 01953 WN_kid0(wn) = WN_CreateIoItem0 ( IOU_NONE, NIL ); 01954 01955 WN_kid1(wn) = WN_CreateIoItem0 ( IOF_NONE, NIL ); 01956 for(i=0,j=2; i<num_items; i++,j++) 01957 WN_kid(wn,j) = nodesc_list[i]; 01958 cwh_block_append(wn); 01959 01960 free(nodesc_list); 01961 } 01962 01963 /*=================================================== 01964 * 01965 * fei_rewind 01966 * 01967 * Handles the F90 rewind statement 01968 * 01969 *==================================================== 01970 */ 01971 01972 void 01973 fei_rewind(void) 01974 { 01975 cwh_io_no_desc(IOS_CR_REWIND); 01976 } 01977 01978 /*=================================================== 01979 * 01980 * fei_backspace 01981 * 01982 * Handles the F90 backspace statement 01983 * 01984 *==================================================== 01985 */ 01986 01987 void 01988 fei_backspace(void) 01989 { 01990 cwh_io_no_desc(IOS_CR_BACKSPACE); 01991 } 01992 01993 /*=================================================== 01994 * 01995 * fei_endfile 01996 * 01997 * Handles the F90 endfile statement 01998 * 01999 *==================================================== 02000 */ 02001 02002 void 02003 fei_endfile(void) 02004 { 02005 cwh_io_no_desc(IOS_CR_ENDFILE); 02006 } 02007 02008 /*=================================================== 02009 * 02010 * fei_iotype 02011 * 02012 * Handles the io type code operator. They sit above each 02013 * io list item. The io type code constant is on top of the 02014 * stack, followed by the io list item. 02015 * 02016 *==================================================== 02017 */ 02018 02019 void 02020 fei_iotype(void) 02021 { 02022 02023 WN *wn; 02024 02025 wn = cwh_expr_operand(DELETE_ARRAYEXP_WN); 02026 cwh_stk_push(wn, WN_item); 02027 } 02028 02029 /*=================================================== 02030 * 02031 * 02032 * is_f90_pointer 02033 * 02034 * Called only when the OPR is an ILOAD, LDID or LDA. 02035 * Returns TRUE is the ST represents an f90 pointer. 02036 * 02037 * 02038 *==================================================== 02039 */ 02040 02041 static BOOL 02042 is_f90_pointer(WN *addr) 02043 { 02044 OPERATOR opr; 02045 opr = WN_operator(addr); 02046 if (opr == OPR_LDID || opr == OPR_LDA) { 02047 if (ST_class(WN_st(addr)) == CLASS_VAR) { 02048 02049 return (ST_auxst_is_f90_pointer(WN_st(addr))); 02050 } else { 02051 return FALSE; 02052 } 02053 } else if (opr == OPR_ILOAD) { 02054 return (TY_is_f90_pointer(Ty_Table[TY_pointed(WN_load_addr_ty(addr))])); 02055 } else { 02056 return (FALSE); 02057 } 02058 } 02059 02060 /*=================================================== 02061 * 02062 * cwh_io_ST_base 02063 * 02064 * Input : an ST 02065 * Output: Base of the ST 02066 * 02067 *==================================================== 02068 */ 02069 02070 static ST * 02071 cwh_io_ST_base(ST *st) 02072 { 02073 02074 ST *base; 02075 02076 /* cannot follow the base_st of a PREG! 02077 * or text 02078 * or preemptible symbols 02079 */ 02080 02081 if (ST_sclass(st) == SCLASS_REG || 02082 ST_sclass(st) == SCLASS_TEXT || 02083 ((Gen_PIC_Shared || Gen_PIC_Call_Shared) && 02084 ST_export(st) == EXPORT_PREEMPTIBLE) ) 02085 { 02086 return st; 02087 } 02088 02089 /* SCLASS_BASED represents both Fortran pointers and also 02090 * COMMON block spliting. When the base_st is a KIND_POINTER, 02091 * it represents the former case. 02092 */ 02093 02094 if (Has_Base_Block(st)) { 02095 02096 /* need to screen out the base_st that has pointer type */ 02097 //TODO ??? 02098 TY_IDX ty = ST_type(ST_base(st)); 02099 if (ty != NIL && TY_kind(ty) == KIND_POINTER) { 02100 return st; 02101 } 02102 } 02103 02104 base = st; 02105 02106 while ( ST_base(base) != base ) { 02107 02108 base = ST_base(base); 02109 } 02110 02111 return base; 02112 } 02113 02114 /*=================================================== 02115 * 02116 * cwh_io_analyse_io_statement 02117 * 02118 * Returns TRUE is a single call will not suffice for this 02119 * IO statement. If FALSE is returned then a single can 02120 * safely be generated. 02121 * 02122 *==================================================== 02123 */ 02124 02125 static BOOL 02126 cwh_io_analyse_io_statement(WN *tree, int mode) 02127 { 02128 02129 INT32 iolist; 02130 INT32 i; 02131 WN *wn; 02132 INT32 ioitem; 02133 02134 for (iolist=0; iolist<WN_kid_count(tree); iolist++) { 02135 wn = WN_kid(tree,iolist); 02136 ioitem = WN_io_item(wn); 02137 if (ioitem >= IOL_ARRAY) 02138 break; 02139 } 02140 02141 for(i=iolist; i<WN_kid_count(tree); i++) { 02142 wn = WN_kid(tree,i); 02143 if (cwh_io_analyse_io_item(wn, NULL, mode)) 02144 return TRUE; 02145 } 02146 return FALSE; 02147 } 02148 02149 02150 /*=================================================== 02151 * 02152 * cwh_io_analyse_io_item 02153 * 02154 * Analyses one IO item to see if this item requires 02155 * that multiple calls be generated to the library. 02156 * Returns FALSE if a single call will suffice; returns 02157 * TRUE otherwise. 02158 * 02159 * It uses the visited field in AUXST to analyse dependency 02160 * information. 02161 * 02162 *==================================================== 02163 */ 02164 02165 static BOOL 02166 cwh_io_analyse_io_item(WN *tree, IMPDO_INFO *impdo_set, int mode) 02167 { 02168 02169 INT32 item; 02170 WN *kid0; 02171 OPERATOR opr; 02172 ST *index; 02173 IMPDO_INFO *new_impdo_set; 02174 BOOL visited; 02175 INT32 i; 02176 INT32 nd; 02177 02178 return FALSE; //right now for source-to-source, do not do split IO 02179 02180 item = WN_intrinsic(tree); 02181 02182 switch(item) { 02183 02184 case IOL_IMPLIED_DO: 02185 02186 if (is_f90_pointer(WN_index(tree))) 02187 return TRUE; 02188 02189 index = cwh_io_ST_base(WN_st(WN_index(tree))); 02190 new_impdo_set = (IMPDO_INFO *) malloc(sizeof(IMPDO_INFO)); 02191 Impdo_index(new_impdo_set) = WN_st(WN_index(tree)); 02192 Impdo_next(new_impdo_set) = impdo_set; 02193 02194 visited = ST_auxst_visited(index); 02195 if (visited) { 02196 return TRUE; 02197 } else { 02198 Set_ST_auxst_visited(index,TRUE); 02199 cwh_io_add_st_to_marked_set(index); 02200 } 02201 02202 if (cwh_io_analyse_expr(WN_start(tree), new_impdo_set, mode)) 02203 return TRUE; 02204 else if (cwh_io_analyse_expr(WN_end(tree), new_impdo_set, mode)) 02205 return TRUE; 02206 else if (cwh_io_analyse_expr(WN_step(tree), new_impdo_set, mode)) 02207 return TRUE; 02208 02209 for(i=4; i<WN_kid_count(tree); i++) { 02210 if (cwh_io_analyse_io_item(WN_kid(tree,i), new_impdo_set, mode)) 02211 return TRUE; 02212 } 02213 free (new_impdo_set); 02214 break; 02215 02216 case IOL_EXPR: 02217 02218 kid0 = WN_kid0(tree); 02219 opr = WNOPR(kid0); 02220 02221 if ((opr == OPR_ILOAD) && (WNOPR(WN_kid0(kid0)) == OPR_ARRAY)) { 02222 if (cwh_io_analyse_arr(WN_kid0(kid0), impdo_set, mode)) 02223 return TRUE; 02224 } else { 02225 if (cwh_io_analyse_expr(kid0, impdo_set, mode)) 02226 return TRUE; 02227 } 02228 break; 02229 02230 case IOL_VAR: 02231 02232 kid0 = WN_kid0(tree); 02233 opr = WNOPR(kid0); 02234 02235 if (opr == OPR_ARRAY) { 02236 if (cwh_io_analyse_arr(kid0, impdo_set, mode)) 02237 return TRUE; 02238 } else { 02239 if (cwh_io_analyse_expr(kid0, impdo_set, mode)) 02240 return TRUE; 02241 } 02242 break; 02243 02244 case IOL_CHAR: 02245 kid0 = WN_kid0(tree); 02246 02247 /* If the length is dependent on some variable, split */ 02248 02249 if (cwh_io_analyse_expr(WN_kid2(tree), impdo_set, mode)) 02250 return TRUE; 02251 02252 opr = WNOPR(kid0); 02253 02254 if (opr == OPR_ARRAY) { 02255 02256 nd = WN_kid_count(kid0)/2; 02257 02258 if (WNOPR(WN_kid0(kid0)) == OPR_LDA || WNOPR(WN_kid0(kid0)) == OPR_LDID) { 02259 if (cwh_io_analyse_arr(kid0, impdo_set, mode)) 02260 return TRUE; 02261 } else if ((nd == 1) && (WNOPR(WN_kid0(kid0)) == OPR_ARRAY)) { 02262 if (cwh_io_analyse_arr(WN_kid0(kid0), impdo_set, mode)) 02263 return TRUE; 02264 for (i=2*nd; i > nd; i-- ) { 02265 if (cwh_io_analyse_index_expr(WN_kid(kid0,i), 02266 impdo_set, mode) != 0) 02267 return TRUE; 02268 } 02269 } else { 02270 if (cwh_io_analyse_expr(kid0, impdo_set, mode)) 02271 return TRUE; 02272 } 02273 02274 } else { 02275 if (cwh_io_analyse_expr(kid0, impdo_set, mode)) 02276 return TRUE; 02277 } 02278 break; 02279 02280 case IOL_DOPE: 02281 kid0 = WN_kid0(tree); 02282 opr = WNOPR(kid0); 02283 02284 02285 /* If the length is dependent on some variable, split */ 02286 if (WN_kid2(tree) && 02287 cwh_io_analyse_expr(WN_kid2(tree), impdo_set, mode)) 02288 return TRUE; 02289 02290 if (opr == OPR_ARRSECTION) { 02291 if (cwh_io_analyse_arr(kid0, impdo_set, mode)) 02292 return TRUE; 02293 } else if ((opr == OPR_ILOAD) && 02294 (WNOPR(WN_kid0(kid0)) == OPR_ARRSECTION)) { 02295 if (cwh_io_analyse_arr(WN_kid0(kid0), impdo_set, mode)) 02296 return TRUE; 02297 } else if (opr == OPR_ARRAY) { 02298 nd = WN_kid_count(kid0)/2; 02299 if ((nd == 1) && (WNOPR(WN_kid0(kid0)) == OPR_ARRSECTION)) { 02300 if (cwh_io_analyse_arr(WN_kid0(kid0), impdo_set, mode)) 02301 return TRUE; 02302 for (i=2*nd; i > nd; i-- ) { 02303 if (cwh_io_analyse_index_expr(WN_kid(kid0,i), 02304 impdo_set, mode) != 0) 02305 return TRUE; 02306 } 02307 } else { 02308 if (cwh_io_analyse_expr(kid0, impdo_set, mode)) 02309 return TRUE; 02310 } 02311 } else { 02312 if (cwh_io_analyse_expr(kid0, impdo_set, mode)) 02313 return TRUE; 02314 } 02315 break; 02316 02317 default: 02318 DevAssert((0),("Odd iolist Item")); 02319 } 02320 02321 return FALSE; 02322 } 02323 02324 02325 /*=================================================== 02326 * 02327 * cwh_io_analyse_expr 02328 * 02329 * Analyse any expression to see if any ST in that 02330 * expression has the visited bit set, and if so, 02331 * return TRUE to indicate that the IO statement this 02332 * expression appears in, needs multiple calls. 02333 * 02334 * If an ST is encountered that does not have visited 02335 * bit set, the bit is now set so that dependency with 02336 * any subsequent expressions can be analyzed. 02337 * 02338 *==================================================== 02339 */ 02340 02341 static BOOL 02342 cwh_io_analyse_expr(WN *tree, IMPDO_INFO *impdo_set, int mode) 02343 { 02344 ST *st; 02345 BOOL visited; 02346 INT32 i; 02347 02348 #if 0 02349 if ((WNOPR(tree) == OPR_ILOAD) || ( OPCODE_has_aux(WN_opcode(tree)))) 02350 if (is_f90_pointer(tree)) 02351 return TRUE; 02352 #endif 02353 02354 if ( OPCODE_has_aux(WN_opcode(tree))) { 02355 st = cwh_io_ST_base(WN_st(tree)); 02356 visited = ST_auxst_visited(st); 02357 if (visited) { 02358 return TRUE; 02359 } else if (READ_MODE(mode)) { 02360 Set_ST_auxst_visited(st,TRUE); 02361 cwh_io_add_st_to_marked_set(st); 02362 } 02363 } else { 02364 ; 02365 // for ( i = 0; i < WN_kid_count(tree); i++ ) 02366 // if (cwh_io_analyse_expr(WN_kid(tree,i), impdo_set, mode)) 02367 // return TRUE; 02368 } 02369 return FALSE; 02370 } 02371 02372 /*=================================================== 02373 * 02374 * cwh_io_analyse_arr 02375 * 02376 * Analyse an OPC_ARRAY node or an OPC_ARRSECTION node 02377 * to see if it has constructs that prevent a single call 02378 * from being generated. If kid0 is anything other than 02379 * an LDA, a TRUE value is returned to indicate multiple 02380 * calls are required. The indexes along all dimensions 02381 * are analyzed (see cwh_io_analyse_index_expr) and if 02382 * everything looks okay a value of FALSE is returned 02383 * to indicate that this node does not prevent a single call 02384 * from being generated. 02385 * 02386 * 02387 *==================================================== 02388 */ 02389 02390 static BOOL 02391 cwh_io_analyse_arr(WN *tree, IMPDO_INFO *impdo_set, int mode) 02392 { 02393 INT32 nd; 02394 WN *addr; 02395 ST *st; 02396 BOOL visited; 02397 INT32 i; 02398 02399 nd = WN_kid_count(tree)/2; 02400 02401 /* addr = cwh_addr_find_address(tree); */ 02402 addr = WN_kid0(tree); 02403 02404 if (WNOPR(addr) == OPR_LDA || WNOPR(addr) == OPR_LDID) { 02405 02406 if (is_f90_pointer(addr)) 02407 return TRUE; 02408 02409 st = cwh_io_ST_base(WN_st(addr)); 02410 visited = ST_auxst_visited(st); 02411 if (visited) { 02412 return TRUE; 02413 } else if (READ_MODE(mode)) { 02414 Set_ST_auxst_visited(st,TRUE); 02415 cwh_io_add_st_to_marked_set(st); 02416 } 02417 for (i=2*nd; i > nd; i-- ) { 02418 if (cwh_io_analyse_index_expr(WN_kid(tree,i), impdo_set, mode) == -1) 02419 return TRUE; 02420 } 02421 } else { 02422 if (cwh_io_analyse_expr(tree, impdo_set, mode)) 02423 return TRUE; 02424 } 02425 02426 return FALSE; 02427 } 02428 02429 /*=================================================== 02430 * 02431 * cwh_io_analyse_index_expr 02432 * 02433 * Analyze the index along a dimension of an ARRAY or 02434 * ARRSECTION node. If the index expr happens to be 02435 * an OPR_TRIPLET, then the kids representing the extent 02436 * and stride are analyzed by cwh_io_analyse_expr to make 02437 * sure there is no dependency on an ST that has visited 02438 * bit set. kid0 of the TRIPLET node is analyzed by this 02439 * same routine as would an index under an OPC_ARRAY node. 02440 * 02441 * If the index is of the form <i+<expr>> or <i-<expr>> 02442 * where i can possible be an implied do index, and expr 02443 * does not contain an implied do index, then it is a 02444 * candidate for a single call. If anything in <expr> 02445 * has the visited bit set, multiple calls are needed. 02446 * Any expressions which is not of the above type and 02447 * is not a constant will cause a multiple call to be 02448 * generated. 02449 * 02450 *==================================================== 02451 */ 02452 02453 static INT32 02454 cwh_io_analyse_index_expr(WN *tree, IMPDO_INFO *impdo_set, int mode) 02455 { 02456 INT32 kid0_status; 02457 INT32 kid1_status; 02458 INT32 i; 02459 INT32 pos; 02460 BOOL visited; 02461 ST *st; 02462 02463 if (WNOPR(tree) == OPR_SRCTRIPLET) { 02464 for (i=1; i<=2; i++) 02465 if (cwh_io_analyse_expr(WN_kid(tree, i), impdo_set, mode)) 02466 return -1; 02467 02468 kid0_status = cwh_io_analyse_index_expr(WN_kid0(tree), impdo_set, 02469 mode); 02470 return kid0_status; 02471 02472 } else if (WNOPR(tree) == OPR_LDID) { 02473 02474 if (is_f90_pointer(tree)) 02475 return -1; 02476 02477 if ( (pos = member (WN_st(tree), impdo_set)) != 0) { 02478 return pos; 02479 } else { 02480 st = cwh_io_ST_base(WN_st(tree)); 02481 visited = ST_auxst_visited(st); 02482 if (visited) 02483 return -1; 02484 else 02485 return 0; 02486 } 02487 } else if ( WN_operator_is(tree,OPR_CONST) || 02488 WN_operator_is(tree,OPR_INTCONST)) { 02489 return 0; 02490 } else if ( WN_operator_is(tree,OPR_ADD) ) { 02491 kid0_status = cwh_io_analyse_index_expr(WN_kid0(tree), impdo_set, mode); 02492 kid1_status = cwh_io_analyse_index_expr(WN_kid1(tree), impdo_set, mode); 02493 switch(kid0_status) { 02494 case 0: 02495 return kid1_status; 02496 case -1: 02497 return -1; 02498 default: /* >= 1 */ 02499 if (kid1_status == 0) 02500 return kid0_status; 02501 else 02502 return -1; 02503 } 02504 } else if (WN_operator_is(tree,OPR_SUB)) { 02505 kid0_status = cwh_io_analyse_index_expr(WN_kid0(tree), impdo_set, mode); 02506 kid1_status = cwh_io_analyse_index_expr(WN_kid1(tree), impdo_set, mode); 02507 switch(kid0_status) { 02508 case 0: 02509 if (kid1_status == 0) 02510 return 0; 02511 else 02512 return -1; 02513 case -1: 02514 return -1; 02515 default: /* >= 1 */ 02516 if (kid1_status == 0) 02517 return kid0_status; 02518 else 02519 return -1; 02520 } 02521 } 02522 return -1; 02523 } 02524 02525 /*=================================================== 02526 * 02527 * member 02528 * 02529 * Checks if the given ST is a memeber of the ST's 02530 * contained in the implied do set. If it is a member, 02531 * the position of the ST is returned, else 0 is returned. 02532 * 02533 * 02534 *==================================================== 02535 */ 02536 02537 static mINT32 02538 member(ST *st, IMPDO_INFO *impdo_set) 02539 { 02540 mINT32 ret_val = 1; 02541 while (impdo_set) { 02542 if (st == Impdo_index(impdo_set)) 02543 return ret_val; 02544 impdo_set = Impdo_next(impdo_set); 02545 ret_val++; 02546 } 02547 return 0; 02548 } 02549 02550 /*=================================================== 02551 * 02552 * cwh_io_create_dopes 02553 * 02554 * This routine is invoked only after it has been previously 02555 * determined that a single call will suffice for this IO 02556 * statement. This routine takes an IO statement as argument 02557 * and converts: 02558 * 02559 * 1. All ARRSECTION nodes into dope vectors. 02560 * 2. OPC_ARRAY nodes under the control of an implied do 02561 * are converted to dope vectors. 02562 * 02563 * 02564 *==================================================== 02565 */ 02566 02567 static void 02568 cwh_io_create_dopes(WN *tree) 02569 { 02570 INT32 iolist; 02571 INT32 i; 02572 WN *wn; 02573 INT32 ioitem; 02574 02575 for (iolist=0; iolist<WN_kid_count(tree); iolist++) { 02576 wn = WN_kid(tree,iolist); 02577 ioitem = WN_io_item(wn); 02578 if (ioitem >= IOL_ARRAY) 02579 break; 02580 } 02581 02582 for(i=iolist; i<WN_kid_count(tree); i++) { 02583 wn = WN_kid(tree,i); 02584 cwh_io_create_dope_from_item(tree, i, NULL); 02585 } 02586 } 02587 02588 /*=================================================== 02589 * 02590 * cwh_io_create_dope_from_item 02591 * 02592 * Called by cwh_io_create_dopes to deal with a single 02593 * item when creating dope vectors. For implied do's 02594 * the routine recursively calls itself. For other items, 02595 * it finds the appropriate array node and passes that to 02596 * cwh_io_conv_array_to_dope for conversion. 02597 * 02598 * 02599 *==================================================== 02600 */ 02601 02602 static void 02603 cwh_io_create_dope_from_item(WN *parent, int kid_num, IMPDO_INFO *impdo_set) 02604 { 02605 INT32 item; 02606 WN *kid0; 02607 OPERATOR opr; 02608 ST *index; 02609 IMPDO_INFO *new_impdo_set; 02610 INT32 i; 02611 WN *tree; 02612 02613 tree = WN_kid(parent, kid_num); 02614 02615 item = WN_intrinsic(tree); 02616 02617 switch(item) { 02618 02619 case IOL_IMPLIED_DO: 02620 02621 index = WN_st(WN_index(tree)); 02622 new_impdo_set = (IMPDO_INFO *) malloc(sizeof(IMPDO_INFO)); 02623 Impdo_index(new_impdo_set) = index; 02624 Impdo_next(new_impdo_set) = impdo_set; 02625 02626 for(i=4; i<WN_kid_count(tree); i++) 02627 cwh_io_create_dope_from_item(tree, i, new_impdo_set); 02628 02629 free(new_impdo_set); 02630 break; 02631 02632 case IOL_EXPR: 02633 02634 if (impdo_set == NULL) 02635 return; 02636 02637 kid0 = WN_kid0(tree); 02638 opr = WNOPR(kid0); 02639 02640 break; 02641 02642 case IOL_VAR: 02643 02644 if (impdo_set == NULL) 02645 return; 02646 02647 kid0 = WN_kid0(tree); 02648 opr = WNOPR(kid0); 02649 02650 02651 break; 02652 02653 case IOL_CHAR: 02654 02655 if (impdo_set == NULL) 02656 return; 02657 02658 kid0 = WN_kid0(tree); 02659 02660 opr = WNOPR(kid0); 02661 02662 02663 break; 02664 02665 02666 case IOL_DOPE: 02667 02668 kid0 = WN_kid0(tree); 02669 break; 02670 02671 default: 02672 DevAssert((0),("Odd iolist Item")); 02673 } 02674 02675 } 02676 02677 /*=================================================== 02678 * 02679 * cwh_io_conv_array_to_dope 02680 * 02681 * The routine receives an ARRAY or an ILOAD node as argument. 02682 * Thr routine first extracts the ARRAY node from the argument. 02683 * It then checks if any index is under the control of an implied 02684 * do; if yes, an IOL_DOPE item is created; the base address in the 02685 * dope vector may have some offset added to it. eg. for 02686 * a(i+5), i=1,n), the address stored in the dope vector is the address 02687 * of a(5). kids 2 thru n+2 are added for the n dims of the array. The 02688 * 2+ith kid is set to the address of the corresponding implied do 02689 * var, if the ith dimension is under the control of an implied do index, 02690 * otherwise it contains 0. 02691 * 02692 * If no index is under the control of an implied do, then 02693 * a dope vector is not created. 02694 * The second kid on the IOL_DOPE is the base address of the arr node; this is 02695 * passed as a dummy argument in the call generated in the IO lowerer. 02696 * 02697 *==================================================== 02698 */ 02699 02700 static WN * 02701 cwh_io_conv_array_to_dope(WN *tree, IMPDO_INFO *impdo_set, WN *old_item, WN *char_len,TY_IDX ty, WN *craytype) 02702 { 02703 INT32 nd; 02704 ST *st; 02705 WN *wn; 02706 INT32 pos; 02707 INT32 indflag = 0; 02708 IMPDO_INFO *impdo; 02709 INT32 i; 02710 INT32 j; 02711 INT32 k; 02712 WN *index; 02713 WN *address_fixup; 02714 WN *final_address = NULL; 02715 WN *offset = NULL; 02716 WN *new_index_expr; 02717 WN *kid; 02718 OPERATOR opr; 02719 WN *arr; 02720 02721 opr = WNOPR(tree); 02722 02723 switch(opr) { 02724 case OPR_ILOAD: 02725 kid = WN_kid0(tree); 02726 if (WNOPR(kid) == OPR_ARRAY) { 02727 arr = kid; 02728 offset = WN_Intconst(Pointer_Mtype,WN_load_offset(tree)); 02729 } else { 02730 return (WN_COPY_Tree(old_item)); 02731 } 02732 break; 02733 02734 case OPR_ARRAY: 02735 kid = WN_kid0(tree); 02736 nd = WN_kid_count(tree)/2; 02737 if (WNOPR(kid) == OPR_LDA || WNOPR(kid) == OPR_LDID) { 02738 arr = tree; 02739 } else if ((WNOPR(kid) == OPR_ARRAY) && (nd == 1) ) { 02740 arr = kid; 02741 final_address = WN_Create(OPCODE_make_op(OPR_ARRAY,Pointer_Mtype, 02742 MTYPE_V), 3); 02743 WN_element_size(final_address) = WN_element_size(tree); 02744 WN_kid(final_address, 1) = WN_COPY_Tree(WN_kid(tree,nd)); 02745 WN_kid(final_address, 2) = WN_COPY_Tree(WN_kid(tree, 2*nd)); 02746 } else { 02747 02748 /* Previous dependence analysis guarantees that if we hit this else 02749 then the array is not dependent on an implied do; if it were, 02750 dependence analysis would have asked us to convert the 02751 implied do into a do loop and we wouldn't be here */ 02752 02753 return (WN_COPY_Tree(old_item)); 02754 } 02755 break; 02756 02757 default: 02758 /* Previous dependence analysis guarantees that if we hit this case 02759 then the array is not dependent on an implied do; if it were, 02760 dependence analysis would have asked us to convert the 02761 implied do into a do loop and we wouldn't be here */ 02762 02763 return (WN_COPY_Tree(old_item)); 02764 } 02765 02766 nd = WN_kid_count(arr)/2; 02767 02768 if (impdo_set != NULL) { 02769 for (i=2*nd; i > nd; i-- ) { 02770 index = WN_kid(arr,i); 02771 if (WNOPR(index) == OPR_SRCTRIPLET) 02772 pos = cwh_io_search_implied_do_index(WN_kid0(index), impdo_set); 02773 else 02774 pos = cwh_io_search_implied_do_index(index, impdo_set); 02775 if (pos >= 1 ) { 02776 indflag = 1; 02777 break; 02778 } 02779 } 02780 } 02781 02782 if (indflag == 0) { 02783 return(WN_COPY_Tree(old_item)); 02784 } else { 02785 wn = WN_CreateIoItemN (IOL_DOPE, nd+2, NIL); 02786 address_fixup = WN_Create(OPCODE_make_op(OPR_ARRAY,Pointer_Mtype,MTYPE_V), 02787 WN_kid_count(arr)); 02788 WN_kid0(address_fixup) = WN_kid0(arr); 02789 WN_element_size(address_fixup) = WN_element_size(arr); 02790 02791 02792 for (i=2*nd, k=2; i > nd; i--, k++ ) { 02793 WN_kid(address_fixup,i-nd) = WN_COPY_Tree(WN_kid(arr,i-nd)); 02794 index = WN_kid(arr,i); 02795 pos = cwh_io_search_implied_do_index(index, impdo_set); 02796 if (pos >= 1) { 02797 impdo = impdo_set; 02798 for (j=1; j < pos; j++) 02799 impdo = Impdo_next(impdo); 02800 WN_kid(wn,k) = WN_CreateLda (opc_lda, 0, 02801 Make_Pointer_Type(ST_type(Impdo_index(impdo))), 02802 Impdo_index(impdo)); 02803 new_index_expr = Substitute_1_For_Impdo_Index_Val( 02804 WN_COPY_Tree(index), impdo); 02805 WN_kid(address_fixup,i) = new_index_expr; 02806 } else { 02807 WN_kid(address_fixup,i) = WN_COPY_Tree(index); 02808 WN_kid(wn,k) = WN_CreateIntconst ( OPC_I4INTCONST, 0); 02809 } 02810 } 02811 if (final_address != NULL) { 02812 WN_kid0(final_address) = address_fixup; 02813 } else if (offset != NULL) { 02814 final_address = WN_Add(Pointer_Mtype, address_fixup, offset); 02815 } else { 02816 final_address = address_fixup; 02817 } 02818 WN_kid0(wn) = cwh_dope_from_expression(arr, arr, char_len,ty, craytype); 02819 WN_kid1(wn) = cwh_addr_find_address(arr); 02820 st = WN_st(WN_kid0(wn)); 02821 cwh_addr_store_ST(st, 0, Be_Type_Tbl(Pointer_type), final_address); 02822 return wn; 02823 } 02824 } 02825 02826 /*=================================================== 02827 * 02828 * cwh_io_conv_arrsection_to_dope 02829 * 02830 * The routine receives an expr as argument that has an ARRSECTION somewhere. 02831 * The routine first checks for an ILOAD over an ARRSECTION or an ARRAY 02832 * over an ARRSECTION or just an ARRSECTION at the top level. If any of 02833 * these is found, it extracts the ARRSECTION node and proceeds with 02834 * further processing, otherwise, the entire expr is just converted to 02835 * a dope vector. 02836 * 02837 * It first checks if any index is under the control of an implied 02838 * do; if yes, an IOL_DOPE item is created; the base address in the 02839 * dope vector may have some offset added to it. eg. for 02840 * a(i+5, :), i=1,n), the address stored in the dope vector is the address 02841 * of a(5,1). kids 2 thru n+2 are added for the n dims of the array. The 02842 * 2+ith kid is set to the address of the corresponding implied do 02843 * var, if the ith dimension is under the control of an implied do index, 02844 * otherwise it contains 0. 02845 * 02846 * If no index is under the control of an implied do, then f dope vector 02847 * is still created. 02848 * The second kid on the IOL_DOPE is the base address of the arr node; this is 02849 * passed as a dummy argument in the call generated in the IO lowerer. 02850 * 02851 *==================================================== 02852 */ 02853 02854 static WN * 02855 cwh_io_conv_arrsection_to_dope(WN *tree, IMPDO_INFO *impdo_set, WN *old_item, 02856 WN *char_len, TY_IDX ty, WN *craytype) 02857 { 02858 INT32 nd; 02859 ST *st; 02860 WN *wn; 02861 INT32 pos; 02862 INT32 indflag = 0; 02863 IMPDO_INFO *impdo; 02864 INT32 i; 02865 INT32 j; 02866 INT32 k; 02867 WN *index; 02868 WN *address_fixup; 02869 WN *final_address = NULL; 02870 WN *offset = NULL; 02871 WN *new_index_expr; 02872 WN *ad; 02873 WN *kid; 02874 OPERATOR opr; 02875 WN *arr; 02876 02877 opr = WNOPR(tree); 02878 02879 switch(opr) { 02880 case OPR_ILOAD: 02881 kid = WN_kid0(tree); 02882 if (WNOPR(kid) == OPR_ARRSECTION) { 02883 arr = kid; 02884 offset = WN_Intconst(Pointer_Mtype,WN_load_offset(tree)); 02885 } else { 02886 /* Previous dependence analysis guarantees us that if we reach 02887 here, we can safely convert this to a dope vector; the ARRSECTION 02888 hidden somewhere in this expression is not dependent on any 02889 implied do, and we can avoid further analysis; if it were 02890 dependent on an implied do index, then we would have decided 02891 to split this statement, and we wouldn't be here */ 02892 02893 arr = cwh_addr_find_section(tree, p_RETURN_SECTION); 02894 ad = cwh_addr_find_address(arr); 02895 wn = cwh_dope_from_expression(tree, NULL, char_len, ty, craytype); 02896 wn = WN_CreateIoItem2(IOL_DOPE, wn, ad, NIL); 02897 return wn; 02898 } 02899 break; 02900 02901 case OPR_ARRAY: 02902 kid = WN_kid0(tree); 02903 nd = WN_kid_count(tree)/2; 02904 if ((WNOPR(kid) == OPR_ARRSECTION) && (nd == 1) ) { 02905 arr = kid; 02906 final_address = WN_Create(OPCODE_make_op(OPR_ARRAY,Pointer_Mtype, 02907 MTYPE_V), 3); 02908 WN_element_size(final_address) = WN_element_size(tree); 02909 WN_kid(final_address, 1) = WN_COPY_Tree(WN_kid(tree,nd)); 02910 WN_kid(final_address, 2) = WN_COPY_Tree(WN_kid(tree, 2*nd)); 02911 } else { 02912 /* Previous dependence analysis guarantees us that if we reach 02913 here, we can safely convert this to a dope vector; the ARRSECTION 02914 hidden somewhere in this expression is not dependent on any 02915 implied do, and we can avoid further analysis; if it were 02916 dependent on an implied do index, then we would have decided 02917 to split this statement, and we wouldn't be here */ 02918 02919 arr = cwh_addr_find_section(tree, p_RETURN_SECTION); 02920 ad = cwh_addr_find_address(arr); 02921 wn = cwh_dope_from_expression(tree, NULL, char_len, ty, craytype); 02922 wn = WN_CreateIoItem2(IOL_DOPE, wn, ad, NIL); 02923 return wn; 02924 } 02925 break; 02926 02927 case OPR_ARRSECTION: 02928 arr = tree; 02929 break; 02930 02931 default: 02932 /* Previous dependence analysis guarantees us that if we reach 02933 here, we can safely convert this to a dope vector; the ARRSECTION 02934 hidden somewhere in this expression is not dependent on any 02935 implied do, and we can avoid further analysis; if it were 02936 dependent on an implied do index, then we would have decided 02937 to split this statement, and we wouldn't be here */ 02938 02939 arr = cwh_addr_find_section(tree, p_RETURN_SECTION); 02940 ad = cwh_addr_find_address(arr); 02941 wn = cwh_dope_from_expression(tree, NULL, char_len, ty, craytype); 02942 wn = WN_CreateIoItem2(IOL_DOPE, wn, ad, NIL); 02943 return wn; 02944 } 02945 02946 nd = WN_kid_count(arr)/2; 02947 02948 if (impdo_set != NULL) { 02949 for (i=2*nd; i > nd; i-- ) { 02950 index = WN_kid(arr,i); 02951 if (WNOPR(index) == OPR_SRCTRIPLET) 02952 pos = cwh_io_search_implied_do_index(WN_kid0(index), impdo_set); 02953 else 02954 pos = cwh_io_search_implied_do_index(index, impdo_set); 02955 if (pos >= 1 ) { 02956 indflag = 1; 02957 break; 02958 } 02959 } 02960 } 02961 02962 if (indflag == 0) { 02963 arr = cwh_addr_find_section(tree, p_RETURN_SECTION); 02964 ad = cwh_addr_find_address(arr); 02965 wn = cwh_dope_from_expression(tree, NULL, char_len, ty, craytype); 02966 wn = WN_CreateIoItem2(IOL_DOPE, wn, ad, NIL); 02967 return wn; 02968 } else { 02969 wn = WN_CreateIoItemN (IOL_DOPE, nd+2, NIL); 02970 address_fixup = WN_Create(OPCODE_make_op(OPR_ARRAY,Pointer_Mtype,MTYPE_V), 02971 WN_kid_count(arr)); 02972 WN_kid0(address_fixup) = WN_kid0(arr); 02973 WN_element_size(address_fixup) = WN_element_size(arr); 02974 02975 02976 for (i=2*nd, k=2; i > nd; i--, k++ ) { 02977 WN_kid(address_fixup,i-nd) = WN_COPY_Tree(WN_kid(arr,i-nd)); 02978 index = WN_kid(arr,i); 02979 if (WNOPR(index) == OPR_SRCTRIPLET) 02980 index = WN_kid0(index); 02981 pos = cwh_io_search_implied_do_index(index, impdo_set); 02982 if (pos >= 1) { 02983 impdo = impdo_set; 02984 for (j=1; j < pos; j++) 02985 impdo = Impdo_next(impdo); 02986 WN_kid(wn,k) = WN_CreateLda (opc_lda, 0, 02987 Make_Pointer_Type(ST_type(Impdo_index(impdo))), 02988 Impdo_index(impdo)); 02989 new_index_expr = Substitute_1_For_Impdo_Index_Val( 02990 WN_COPY_Tree(index), impdo); 02991 WN_kid(address_fixup,i) = new_index_expr; 02992 } else { 02993 WN_kid(address_fixup,i) = WN_COPY_Tree(index); 02994 WN_kid(wn,k) = WN_CreateIntconst ( OPC_I4INTCONST, 0); 02995 } 02996 } 02997 02998 if (final_address != NULL) { 02999 WN_kid0(final_address) = address_fixup; 03000 } else if (offset != NULL) { 03001 final_address = WN_Add(Pointer_Mtype, address_fixup, offset); 03002 } else { 03003 final_address = address_fixup; 03004 } 03005 03006 WN_kid0(wn) = cwh_dope_from_expression(arr, NULL, char_len, ty, 03007 craytype); 03008 WN_kid1(wn) = cwh_addr_find_address(arr); 03009 st = WN_st(WN_kid0(wn)); 03010 cwh_addr_store_ST(st, 0, Be_Type_Tbl(Pointer_type), final_address); 03011 return wn; 03012 } 03013 } 03014 03015 /*=================================================== 03016 * 03017 * cwh_io_search_implied_do_index 03018 * 03019 * Checks if any ST in the array index <passed in tree> 03020 * is a member of the implied do index set. If yes, the 03021 * position of the ST is returned, else, 0 is returned. 03022 * 03023 *==================================================== 03024 */ 03025 03026 static INT32 03027 cwh_io_search_implied_do_index(WN *tree, IMPDO_INFO *impdo_set) 03028 { 03029 INT32 pos; 03030 ST *st; 03031 INT32 i; 03032 03033 if (WNOPR(tree) == OPR_LDID) { 03034 st = WN_st(tree); 03035 if ( (pos = member (st, impdo_set)) != 0) 03036 return pos; 03037 } else { 03038 for(i=0; i < WN_kid_count(tree); i++) { 03039 pos = cwh_io_search_implied_do_index(WN_kid(tree, i),impdo_set); 03040 if (pos != 0) 03041 return pos; 03042 } 03043 } 03044 return 0; 03045 } 03046 03047 /*=================================================== 03048 * 03049 * cwh_io_add_st_to_marked_set 03050 * 03051 * Adds a new ST to the visited set. 03052 * 03053 *==================================================== 03054 */ 03055 03056 static void 03057 cwh_io_add_st_to_marked_set(ST *st) { 03058 03059 MARKED_SET *new_marked_set; 03060 03061 new_marked_set = (MARKED_SET *) malloc(sizeof(MARKED_SET)); 03062 Marked_st(new_marked_set) = st; 03063 Marked_next(new_marked_set) = marked_set; 03064 03065 marked_set = new_marked_set; 03066 } 03067 03068 /*=================================================== 03069 * 03070 * cwh_io_unmark 03071 * 03072 * Unmarks all ST's that were marked visited, since we 03073 * are done with this IO statement. 03074 * 03075 *==================================================== 03076 */ 03077 03078 static void 03079 cwh_io_unmark(void) { 03080 03081 MARKED_SET *temp; 03082 03083 while(marked_set) { 03084 temp = marked_set; 03085 if (ST_auxst_visited(Marked_st(marked_set))) 03086 Set_ST_auxst_visited(Marked_st(marked_set),FALSE); 03087 marked_set = Marked_next(marked_set); 03088 free(temp); 03089 } 03090 } 03091 03092 /*=================================================== 03093 * 03094 * Substitute_1_For_Impdo_Index_Val 03095 * 03096 * Searches for occurences of the implied do index in 03097 * the tree, and replaces the occurence by an INTCONST 03098 * node with val 1. 03099 * 03100 ==================================================== 03101 */ 03102 03103 static WN * 03104 Substitute_1_For_Impdo_Index_Val(WN *tree, IMPDO_INFO *impdo) 03105 { 03106 INT32 i; 03107 OPCODE opc_intconst; 03108 INT32 rtype; 03109 03110 if (WN_operator_is(tree,OPR_LDID) && 03111 (WN_st(tree) == Impdo_index(impdo)) ) { 03112 rtype = WN_rtype(tree); 03113 switch (rtype) { 03114 case MTYPE_I4: 03115 opc_intconst = OPC_I4INTCONST; 03116 break; 03117 case MTYPE_I8: 03118 opc_intconst = OPC_I8INTCONST; 03119 break; 03120 case MTYPE_U4: 03121 opc_intconst = OPC_U4INTCONST; 03122 break; 03123 case MTYPE_U8: 03124 opc_intconst = OPC_U8INTCONST; 03125 break; 03126 default: 03127 DevAssert((0),("Odd type")); 03128 } 03129 return (WN_CreateIntconst ( opc_intconst, 1)); 03130 } else { 03131 for(i=0; i<WN_kid_count(tree); i++ ) { 03132 WN_kid(tree, i) = Substitute_1_For_Impdo_Index_Val(WN_kid(tree, i), 03133 impdo); 03134 } 03135 } 03136 return tree; 03137 } 03138 03139 /*=================================================== 03140 * 03141 * cwh_io_split_io_statement 03142 * 03143 * Splits IO statement completely into a three call model. 03144 * 03145 *==================================================== 03146 */ 03147 static void 03148 cwh_io_split_io_statement(WN *tree) { 03149 WN **cilist; 03150 WN *wn_tmp; 03151 WN *item; 03152 WN *wn; 03153 INT32 ioitem_tmp; 03154 INT32 i; 03155 INT32 j; 03156 INT32 iolist_marker; 03157 INT32 num_cilist_items; 03158 INT32 iostatement; 03159 WN *kid0; 03160 INT32 flflag; 03161 INT32 new_flflag; 03162 03163 iostatement = WN_io_statement(tree); 03164 03165 for(i=0; i<WN_kid_count(tree); i++) { 03166 wn_tmp = WN_kid(tree,i); 03167 ioitem_tmp = WN_io_item(wn_tmp); 03168 if (ioitem_tmp >= IOL_ARRAY) 03169 break; 03170 } 03171 03172 iolist_marker = i; 03173 03174 num_cilist_items = i ; 03175 03176 cilist = (WN **) malloc(sizeof (WN *) * num_cilist_items ); 03177 03178 for(i=0; i<iolist_marker; i++) 03179 cilist[i] = WN_kid(tree,i); 03180 03181 wn = WN_CreateIo ( (IOSTATEMENT) iostatement, num_cilist_items); 03182 03183 for(j=0; j<num_cilist_items; j++) { 03184 wn_tmp = cilist[j]; 03185 ioitem_tmp = WN_io_item(cilist[j]); 03186 if (ioitem_tmp == IOC_CR_FLFLAG) { 03187 kid0 = WN_kid0(wn_tmp); 03188 flflag = WN_const_val(kid0); 03189 new_flflag = flflag & 2; 03190 WN_kid(wn,j) = WN_CreateIoItem1 ( IOC_CR_FLFLAG, 03191 WN_CreateIntconst ( OPC_I4INTCONST, new_flflag), 03192 NIL); 03193 } else { 03194 WN_kid(wn,j) = WN_COPY_Tree(cilist[j]); 03195 } 03196 } 03197 cwh_block_append(wn); 03198 03199 03200 for(i=iolist_marker; i<WN_kid_count(tree); i++) { 03201 item = WN_kid(tree,i); 03202 cwh_io_split_io_items((IOSTATEMENT)iostatement, cilist, num_cilist_items, item); 03203 } 03204 03205 wn = WN_CreateIo ( (IOSTATEMENT)iostatement, num_cilist_items); 03206 for(j=0; j<num_cilist_items; j++) { 03207 wn_tmp = cilist[j]; 03208 ioitem_tmp = WN_io_item(cilist[j]); 03209 if (ioitem_tmp == IOC_CR_FLFLAG) { 03210 kid0 = WN_kid0(wn_tmp); 03211 flflag = WN_const_val(kid0); 03212 new_flflag = flflag & 1; 03213 WN_kid(wn,j) = WN_CreateIoItem1 ( IOC_CR_FLFLAG, 03214 WN_CreateIntconst ( OPC_I4INTCONST, new_flflag), 03215 NIL); 03216 } else { 03217 WN_kid(wn,j) = WN_COPY_Tree(cilist[j]); 03218 } 03219 } 03220 cwh_block_append(wn); 03221 free(cilist); 03222 } 03223 03224 /*=================================================== 03225 * 03226 * cwh_io_split_io_items 03227 * 03228 * Called by cwh_io_split_iostatement to deal with an 03229 * individual item. Recursively calls itself for implied 03230 * do's. 03231 * 03232 *==================================================== 03233 */ 03234 03235 static void 03236 cwh_io_split_io_items(IOSTATEMENT ios, WN **cilist, 03237 INT32 num_cilist_items, WN *item) { 03238 WN *wn; 03239 INT32 ioitem_tmp; 03240 INT32 i; 03241 INT32 j; 03242 WN *top_label; 03243 WN *cont_label; 03244 TY_IDX ty; 03245 INT32 mtype; 03246 INT32 ntype; 03247 WN *load_index; 03248 WN *start; 03249 WN *step; 03250 WN *end; 03251 PREG_NUM pregnum; 03252 ST *pregst; 03253 WN *ad; 03254 WN *se; 03255 03256 if (WN_io_item(item) == IOL_IMPLIED_DO) { 03257 top_label = cwh_io_create_new_label(); 03258 cont_label = cwh_io_create_new_label(); 03259 ty = ST_type(WN_st(WN_index(item))); 03260 if ( TY_kind(ty) != KIND_POINTER ) { 03261 ntype = mtype = TY_mtype(ty); 03262 if (ntype == MTYPE_I1 || ntype == MTYPE_I2) 03263 ntype = MTYPE_I4; 03264 load_index = WN_Ldid ( mtype, WN_idname_offset(WN_index(item)), 03265 WN_st(WN_index(item)), ty ); 03266 start = WN_Stid ( mtype, WN_idname_offset(WN_index(item)), 03267 WN_st(WN_index(item)), ty, WN_start(item) ); 03268 step = WN_Stid ( mtype, WN_idname_offset(WN_index(item)), 03269 WN_st(WN_index(item)), ty, 03270 WN_CreateExp2 ( OPCODE_make_op ( OPR_ADD, ntype, 03271 MTYPE_V ), 03272 WN_COPY_Tree ( load_index ), 03273 WN_COPY_Tree(WN_step(item)) )); 03274 } else { 03275 ntype = mtype = TY_mtype(TY_pointed(ty)); 03276 if (ntype == MTYPE_I1 || ntype == MTYPE_I2) 03277 ntype = MTYPE_I4; 03278 load_index = WN_Iload ( mtype, 0, TY_pointed(ty), 03279 WN_Ldid ( Pointer_type, 03280 WN_idname_offset(WN_index(item)), 03281 WN_st(WN_index(item)), ty )); 03282 start = WN_Istore ( mtype, 0, ty, 03283 WN_Ldid ( Pointer_type, 03284 WN_idname_offset(WN_index(item)), 03285 WN_st(WN_index(item)), ty ), 03286 WN_start(item) ); 03287 step = WN_Istore ( mtype, 0, ty, 03288 WN_Ldid ( Pointer_type, 03289 WN_idname_offset(WN_index(item)), 03290 WN_st(WN_index(item)), ty ), 03291 WN_CreateExp2 ( OPCODE_make_op ( OPR_ADD, 03292 ntype, 03293 MTYPE_V ), 03294 WN_COPY_Tree ( load_index ), 03295 WN_COPY_Tree(WN_step(item)) )); 03296 } 03297 if ( WN_operator(WN_step(item)) == OPR_INTCONST || 03298 WN_operator(WN_step(item)) == OPR_CONST ) { 03299 if ( ( WN_operator(WN_step(item)) == OPR_INTCONST && 03300 WN_const_val(WN_step(item)) >= 0 ) || 03301 ( WN_operator(WN_step(item)) == OPR_CONST && 03302 STC_val(WN_st(WN_step(item))).vals.ival.v0 >= 0 ) ) 03303 end = WN_LE ( ntype, load_index, WN_end(item) ); 03304 else 03305 end = WN_GE ( ntype, load_index, WN_end(item) ); 03306 } else { 03307 pregst = MTYPE_To_PREG ( Boolean_type ); 03308 pregnum = Create_Preg ( Boolean_type, "stoptemp"); 03309 cwh_block_append( WN_StidIntoPreg ( Boolean_type, pregnum, 03310 pregst, 03311 WN_GE ( ntype, 03312 WN_COPY_Tree ( WN_step(item) ), WN_Zerocon ( ntype )))); 03313 end = WN_Select ( Boolean_type, 03314 WN_LdidPreg ( Boolean_type, pregnum ), 03315 WN_LE ( ntype, load_index, WN_end(item) ), 03316 WN_GE ( ntype, WN_COPY_Tree (load_index), 03317 WN_COPY_Tree (WN_end(item)) )); 03318 } 03319 cwh_block_append(start ); 03320 03321 cwh_block_append( WN_CreateGoto ( (ST_IDX) NULL, 03322 WN_label_number(cont_label) )); 03323 cwh_block_append( top_label ); 03324 03325 for (i=4; i < WN_kid_count(item); i++) 03326 cwh_io_split_io_items(ios, cilist, num_cilist_items, 03327 WN_kid(item,i)); 03328 03329 cwh_block_append( step ); 03330 cwh_block_append( cont_label ); 03331 cwh_block_append( WN_CreateTruebr ( WN_label_number(top_label), 03332 end )); 03333 03334 } else { 03335 03336 if (WN_io_item(item) == IOL_DOPE) { 03337 se = cwh_addr_find_section(WN_kid0(item), p_RETURN_SECTION); 03338 ad = cwh_addr_find_address(se); 03339 wn = cwh_dope_from_expression(WN_kid0(item), NULL, WN_kid2(item), WN_ty(item), WN_kid1(item)); 03340 WN_Delete(item); 03341 item = WN_CreateIoItem2(IOL_DOPE, wn, ad, NIL); 03342 } 03343 03344 wn = WN_CreateIo ( ios, num_cilist_items+1); 03345 for(j=0; j<num_cilist_items; j++) { 03346 ioitem_tmp = WN_io_item(cilist[j]); 03347 if (ioitem_tmp == IOC_CR_FLFLAG) { 03348 WN_kid(wn,j) = WN_CreateIoItem1 ( IOC_CR_FLFLAG, 03349 WN_CreateIntconst ( OPC_I4INTCONST, 0), 03350 NIL); 03351 } else { 03352 WN_kid(wn,j) = WN_COPY_Tree(cilist[j]); 03353 } 03354 } 03355 03356 03357 WN_kid(wn,num_cilist_items) = WN_COPY_Tree(item); 03358 cwh_block_append(wn); 03359 } 03360 } 03361 03362 /*=================================================== 03363 * 03364 * OPCODE_has_aux 03365 * 03366 * Return TRUE if operator is an LDID, or LDA or STID. 03367 * 03368 *==================================================== 03369 */ 03370 03371 static BOOL 03372 OPCODE_has_aux(const OPCODE opc) 03373 { 03374 03375 OPERATOR opr = OPCODE_operator(opc); 03376 return (opr == OPR_LDID || opr == OPR_STID || 03377 opr == OPR_LDA || opr == OPR_IDNAME); 03378 } 03379 03380 /*=================================================== 03381 * 03382 * cwh_io_create_new_label 03383 * 03384 * Create a new label and make a WN out of it. 03385 * 03386 *==================================================== 03387 */ 03388 03389 static WN * 03390 cwh_io_create_new_label(void) 03391 { 03392 LABEL_IDX label; 03393 03394 (void) New_LABEL (CURRENT_SYMTAB, label); 03395 return WN_CreateLabel(NIL, label, 0, NIL); 03396 } 03397 03398 /*=================================================== 03399 * 03400 * cwh_io_cvt_tos_label_to_wn 03401 * 03402 * If TOS is a label, make a WN out of it. 03403 * 03404 * If flag is true, mark the label as LKIND_ASSIGNED. 03405 * 03406 *==================================================== 03407 */ 03408 static WN * 03409 cwh_io_cvt_tos_label_to_wn(BOOL flag) 03410 { 03411 WN *wn; 03412 03413 if (cwh_stk_get_class() == LB_item) { 03414 LABEL_IDX lbl; 03415 lbl = (LABEL_IDX) cwh_stk_pop_LB(); 03416 if (flag) 03417 Set_LABEL_KIND(Label_Table[lbl], LKIND_ASSIGNED); 03418 wn = WN_CreateGoto (lbl); 03419 } else { 03420 cwh_stk_pop_whatever(); 03421 wn = NULL; 03422 } 03423 return wn; 03424 }